4 Advanced Progrmming 2018, Assignment 8
5 Pieter Koopman, pieter@cs.ru.nl
10 import Control.Applicative
11 import Control.Monad => qualified join
12 import Control.Monad.State
13 import Control.Monad.Trans
22 import qualified Data.List as List
23 import qualified Data.Map as Map
30 :: Val :== Either Int [Int]
31 :: SemState :== 'Map'.Map String Val
34 { evaluator :: StateT SemState (Either String) a
35 , printer :: [String] -> [String]
38 fail :: String -> StateT SemState (Either String) a
39 fail s = liftT (Left s)
42 integer :: Int -> Elem
43 integer i = {evaluator=pure i,printer = \c->[toString i:c]}
47 { evaluator = pure (removeDup i)
48 , printer = \c->["[":intersperse "," (map toString i)] ++ ["]":c]
53 { evaluator = length <$> s.evaluator
54 , printer = \c->["size(":s.printer [")"]]
57 class variable a :: String -> a
62 = gets ('Map'.get i) >>= \v->case v of
63 Nothing = fail ("No set with identifier " +++ i)
64 Just (Left v) = fail (i +++ " is an element")
65 Just (Right v) = pure v
68 instance variable Elem
72 = gets ('Map'.get i) >>= \v->case v of
73 Nothing = fail ("No element with identifier " +++ i)
74 Just (Right v) = fail (i +++ " is a set")
75 Just (Left v) = pure v
78 class (+.) infixl 6 a b ~c :: a b -> c
79 instance +. Elem Elem Elem
82 { evaluator = (+) <$> a.evaluator <*> b.evaluator
83 , printer = \c->a.printer ["+":b.printer c]
85 instance +. Elem Set Set
88 { evaluator = 'List'.union <$> pure <$> a.evaluator <*> b.evaluator
89 , printer = \c->a.printer ["+":b.printer c]
91 instance +. Set Elem Set
94 { evaluator = 'List'.union <$> a.evaluator <*> (pure <$> b.evaluator)
95 , printer = \c->a.printer ["+":b.printer c]
97 instance +. Set Set Set
100 { evaluator = 'List'.union <$> a.evaluator <*> b.evaluator
101 , printer = \c->a.printer ["+":b.printer c]
103 class (-.) infixl 6 a b ~c :: a b -> c
104 instance -. Elem Elem Elem
107 { evaluator = (-) <$> a.evaluator <*> b.evaluator
108 , printer = \c->a.printer ["-":b.printer c]
110 instance -. Set Elem Set
113 { evaluator = 'List'.difference <$> a.evaluator <*> (pure <$> b.evaluator)
114 , printer = \c->a.printer ["-":b.printer c]
116 instance -. Set Set Set
119 { evaluator = 'List'.difference <$> a.evaluator <*> b.evaluator
120 , printer = \c->a.printer ["-":b.printer c]
122 class (*.) infixl 6 a b ~c :: a b -> c
123 instance *. Elem Elem Elem
126 { evaluator = (*) <$> a.evaluator <*> b.evaluator
127 , printer = \c->a.printer ["*":b.printer c]
129 instance *. Elem Set Set
132 { evaluator = a.evaluator >>= \x->map ((*)x) <$> b.evaluator
133 , printer = \c->a.printer ["*":b.printer c]
135 instance *. Set Set Set
138 { evaluator = 'List'.intersect <$> a.evaluator <*> b.evaluator
139 , printer = \c->a.printer ["*":b.printer c]
142 class (=.) infixl 2 a :: Ident a -> a
146 { evaluator = s.evaluator >>= \v->modify ('Map'.put n (Right v)) *> pure v
147 , printer = \c->[n,"=":s.printer c]
152 { evaluator = s.evaluator >>= \v->modify ('Map'.put n (Left v)) *> pure v
153 , printer = \c->[n,"=":s.printer c]
157 :: Logical :== Sem Bool
159 true = {evaluator = pure True, printer = \c->["True":c]}
162 false = {evaluator = pure False, printer = \c->["False":c]}
164 In :: Elem Set -> Logical
166 { evaluator = elem <$> e.evaluator <*> s.evaluator
167 , printer = \c->e.printer ["In":s.printer c]
170 class (==.) infix 4 a :: a a -> Logical
174 {evaluator = (==) <$> a.evaluator <*> b.evaluator
175 ,printer = \c->a.printer ["==":b.printer c]
180 {evaluator = (==) <$> a.evaluator <*> b.evaluator
181 ,printer = \c->a.printer ["==":b.printer c]
184 class (<=.) infixl 6 a b :: a b -> Logical
185 instance <=. Elem Elem
188 {evaluator = (<=) <$> a.evaluator <*> b.evaluator
189 ,printer = \c->a.printer ["<=":b.printer c]
194 {evaluator = ((<=) `on` length) <$> a.evaluator <*> b.evaluator
195 ,printer = \c->a.printer ["<=":b.printer c]
198 Not :: Logical -> Logical
199 Not a = {evaluator = not <$> a.evaluator, printer = \c->["not":a.printer c]}
201 (||.) infixr 2 :: Logical Logical -> Logical
203 {evaluator = (||) <$> a.evaluator <*> b.evaluator
204 ,printer = \c->a.printer ["||":b.printer c]
207 (&&.) infixr 2 :: Logical Logical -> Logical
209 {evaluator = (&&) <$> a.evaluator <*> b.evaluator
210 ,printer = \c->a.printer ["&&":b.printer c]
215 expression :: Set -> Stmt
216 expression e = {evaluator = e.evaluator *> pure (), printer = e.printer}
218 logical :: Logical -> Stmt
219 logical e = {evaluator = e.evaluator *> pure (), printer = e.printer}
221 For :: String Set Stmt -> Stmt
223 { evaluator = bag.evaluator >>= \v->
224 foldr proc (pure ()) [ident =. integer e\\e<-v]
225 , printer = \c->["For",ident,"=":bag.printer ["In":body.printer c]]
228 proc :: (Sem Int) (StateT SemState (Either String) ()) -> StateT SemState (Either String) ()
229 proc e m = e.evaluator *> body.evaluator *> m
231 If :: Logical Stmt Stmt -> Stmt
233 { evaluator = l.evaluator >>= \b->if b s1.evaluator s2.evaluator
234 , printer = \c->["If":l.printer ["then":s1.printer ["else":s2.printer c]]]
237 evalSem :: (Sem a) -> (SemState -> Either String a)
238 evalSem s = evalStateT s.evaluator
240 printSem :: (Sem a) -> ([String] -> [String])
241 printSem s = s.printer
244 ( evalSem (integer 42 +. integer 42 +. set [] +. integer 4 +. set [42]) 'Map'.newMap
245 , join " " $ printSem (integer 42 +. integer 42 +. set [] +. integer 4 +. set [42]) []