a7/mart/skeleton7.icl

   1 module skeleton7
   2
   3 from iTasks import
   4         always, hasValue, :: TaskValue(..), :: Task, :: Stability,
   5         :: TaskCont(..), :: Action, updateInformation, viewInformation,
   6         class descr, instance descr String, :: UpdateOption, :: ViewOption(..),
   7         -||-, -||, ||-, startEngine, class Publishable, >>*, class TFunctor,
   8         instance TFunctor Task, class TApplicative, instance TApplicative Task,
   9         instance Publishable Task, Void
  10 import Data.Tuple, StdClass, StdList, iTasks._Framework.Generic, Text.JSON,
  11         Data.Functor, Control.Applicative, Control.Monad, Data.Map, Data.Either
  12 import qualified iTasks
  13 import qualified Text
  14 import qualified Data.List as List
  15 import StdTuple
  16 from Text import class Text, instance Text String
  17 from StdFunc import o
  18
  19 e = Insert New (Oper New +. (Union (Integer 7) (Size (Integer 9))))
  20
  21 :: Expression
  22         = New
  23         | Insert         Element Set
  24         | Delete         Element Set
  25         | Variable       Ident
  26         | Union  Set    Set
  27         | Difference     Set    Set
  28         | Intersection   Set    Set
  29         | Integer        Int
  30         | Size   Set
  31         | Oper   Element Op Element
  32         | (=.) infixl 2 Ident Expression
  33
  34 :: Op = +. | -. | *.
  35 :: Set  :== Expression
  36 :: Element      :== Expression
  37 :: Ident        :== String
  38
  39
  40 // === State
  41 :: Val = Int Int | Set [Int]
  42 :: State :== Map String Val
  43
  44 :: Sem a = Sem (State -> (Either String a, State))
  45
  46 // === semantics
  47 unsem :: (Sem a) -> (State -> (Either String a, State))
  48 unsem (Sem a) = a
  49
  50 instance Functor Sem where
  51         fmap f s = Sem \st.let (a, st`)=unsem s st in (fmap f a, st`)
  52
  53 instance Applicative Sem where
  54         pure s = Sem \st.(pure s, st)
  55         (<*>) a f = ap a f
  56
  57 instance Monad Sem where
  58         bind (Sem s) f = Sem \st.case s st of
  59                 (Right v, st`) = unsem (f v) st`
  60                 (Left e, st`) = (Left e, st`)
  61
  62 store :: Ident Val -> Sem Val
  63 store i v = Sem \st.(pure v, put i v st)
  64
  65 read :: Ident -> Sem Val
  66 read i = Sem \st.case get i st of
  67                 (Just v) = (Right v, st)
  68                 _ = unsem (fail "variable not found") st
  69
  70 fail :: String -> Sem a
  71 fail s = Sem \st.(Left s,st)
  72
  73 expectInt :: Expression String -> Sem Int
  74 expectInt e m = eval e >>= \r.case r of
  75         (Int i) = return i
  76         _ = fail (m +++ " argument has to be an Int")
  77
  78 expectSet :: Expression String -> Sem [Int]
  79 expectSet e m = eval e >>= \r.case r of
  80         (Set i) = return i
  81         _ = fail (m +++ " argument has to be a Set")
  82
  83 instance toString Op where
  84         toString (+.) = "+"
  85         toString (-.) = "-"
  86         toString (*.) = "*"
  87
  88 eval :: Expression -> Sem Val
  89 eval New = return (Set [])
  90 eval (Insert e s) = expectInt e "Insert, 1st"
  91         >>= \e.expectSet s "Insert, 2nd"
  92         >>= \s.return (Set [e:s])
  93 eval (Delete e s) = expectInt e "Delete, 1st"
  94         >>= \e.expectSet s "Delete, 2nd"
  95         >>= \s.return (Set ('List'.delete e s))
  96 eval (Variable e) = read e
  97 eval (Union s1 s2) = expectSet s1 "Union, 1st"
  98         >>= \s1.expectSet s2 "Union, 2nd"
  99         >>= \s2.return (Set ('List'.union s1 s2))
 100 eval (Difference s1 s2) = expectSet s1 "Difference, 1st"
 101         >>= \s1.expectSet s2 "Difference, 2nd"
 102         >>= \s2.return (Set ('List'.difference s1 s2))
 103 eval (Intersection s1 s2) = expectSet s1 "Intersection, 1st"
 104         >>= \s1.expectSet s2 "Intersection, 2nd"
 105         >>= \s2.return (Set ('List'.intersect s1 s2))
 106 eval (Integer i) = return (Int i)
 107 eval (Size s) = expectSet e "Size, 1st" >>= \e.return (Int (length e))
 108 eval (Oper e1 o e2) = expectInt e1 (toString o +++ ", 1st")
 109         >>= \e1.expectInt e2 (toString o +++ ", 2nd")
 110         >>= \e2.case o of
 111                 (+.) = return (Int (e1+e2))
 112                 (-.) = return (Int (e1-e2))
 113                 (*.) = return (Int (e1*e2))
 114 eval (i =. e) = eval e >>= \e.store i e
 115
 116 evalExpr :: Expression State -> Either String Val
 117 evalExpr e s = fst (unsem (eval e) s)
 118
 119 print :: Expression -> String
 120 print e = 'Text'.concat (print` e [])
 121
 122 print` :: Expression [String] -> [String]
 123 print` New l = ["Ø":l]
 124 print` (Insert e s) l = ["{":print` e ["}∪":print` s l]]
 125 print` (Delete e s) l = ["(":print` s [")\\{":print` e ["}":l]]]
 126 print` (Variable e) l = [e:l]
 127 print` (Union s1 s2) l = ["(":print` s1 [")∪(":print` s2 [")":l]]]
 128 print` (Difference s1 s2) l = ["(":print` s1 [")∆(":print` s2 [")":l]]]
 129 print` (Intersection s1 s2) l = ["(":print` s1 [")∩(":print` s2 [")":l]]]
 130 print` (Integer i) l = [toString i: l]
 131 print` (Size s) l = ["|":print` s ["|":l]]
 132 print` (Oper e1 o e2) l = ["(":print` e1 [")",toString o,"(":print` e2 [")":l]]]
 133 print` (i =. e) l = [i,"=":print` e l++["\n"]]
 134
 135 // === simulation
 136
 137 (>>>=) :== 'iTasks'.tbind
 138 (>>>|) a b :== 'iTasks'.tbind a (\_ -> b)
 139 treturn :== 'iTasks'.return
 140 ActionOk :== 'iTasks'.ActionOk
 141 ActionQuit :== 'iTasks'.ActionQuit
 142 ActionNew :== 'iTasks'.ActionNew
 143
 144 mainTask = viewInformation (print e)
 145
 146 Start :: *World -> *World
 147 Start world = startEngine mainTask world
 148 //Start = print (Insert (Size (Insert (Oper (Integer 5) +. (Integer 6)) New)) New)