a9/charlie/Main.hs

   1 {-#LANGUAGE GADTs #-}
   2 {-#LANGUAGE StandaloneDeriving #-}
   3
   4 -- Mart Lubbers s4109503
   5 -- Charlie Gerhardus s3050009
   6
   7 -- for union and intersect
   8 import Data.List
   9
  10 -- type aliases and data structures
  11 type Ident = String
  12 type Set = Expr [Int]
  13 type Elem = Expr Int
  14 data Op = Add |Sub | Mul deriving Show
  15 data Val = Error String | IVal Int | ISVal [Int] deriving Show
  16 type State = [(String, Val)]
  17 data Sem a = Sem (State -> (a, State))
  18
  19 -- the expression GADT
  20 data Expr a where
  21     New :: Set
  22     Ins :: Elem -> Set -> Set
  23     Del :: Elem -> Set -> Set
  24     Var :: Ident -> Expr a
  25     Union :: Set -> Set -> Set
  26     Diff :: Set -> Set -> Set
  27     Intersect :: Set -> Set -> Set
  28     Lit :: Int -> Elem
  29     Size :: Set -> Elem
  30     Oper :: Elem -> Op -> Elem -> Elem
  31     Store :: Ident -> Expr a -> Expr a
  32
  33 -- make it printable
  34 deriving instance Show (Expr a)
  35
  36 -- Execute Sem by applying state
  37 execSem :: Sem a -> State -> (a, State)
  38 execSem (Sem f) st = f st
  39
  40 -- Apply result to functor and preserve state
  41 mapSem :: (a -> b) -> (a, State) -> (b, State)
  42 mapSem f (x, st) = (f x, st)
  43
  44 -- Functor instance for monad
  45 instance Functor Sem where
  46     fmap f (Sem g) = Sem $ \st -> let (x, st') = g st in (f x, st')
  47
  48 -- Applicative instance for monad
  49 instance Applicative Sem where
  50     pure x = Sem $ \st -> (x, st)
  51     Sem f <*> (Sem g) = Sem $ \st -> let (h, st') = f st in mapSem h (g st')
  52
  53 -- The monad
  54 instance Monad Sem where
  55     Sem f >>= g = Sem $ \st -> let (x, st') = f st in execSem (g x) st'
  56
  57 -- Read a variable
  58 varRead :: String -> Sem Val
  59 varRead id = Sem $ \st -> maybe (Error "undefined variable reference!", st) (\v -> (v, st)) (lookup id st)
  60
  61 -- Var write
  62 varWrite :: String -> Val -> Sem Val
  63 varWrite id v = Sem $ \st -> (v, (id, v):st)
  64
  65 -- fail
  66 expFail :: String -> Sem Val
  67 expFail msg = Sem $ \st -> (Error msg, st)
  68
  69 -- insert value into set
  70 setInsert :: Val -> Val -> Sem Val
  71 setInsert (ISVal is) (IVal i) = Sem $ \st -> (ISVal (i:is), st)
  72 setInsert _ _ = expFail "insert fail!"
  73
  74 -- remove value from set
  75 setDelete :: Val -> Val -> Sem Val
  76 setDelete (ISVal is) (IVal i) = Sem $ \st -> (ISVal (delete i is), st)
  77 setDelete _ _ = expFail "delete fail!"
  78
  79 -- set union
  80 setUnion :: Val -> Val -> Sem Val
  81 setUnion (ISVal is1) (ISVal is2) = Sem $ \st -> (ISVal (union is1 is2), st)
  82 setUnion _ _ = expFail "union fail!"
  83
  84 -- set difference
  85 setDiff :: Val -> Val -> Sem Val
  86 setDiff (ISVal is1) (ISVal is2) = Sem $ \st -> (ISVal (is1 \\ is2), st)
  87 setDiff _ _ = expFail "difference fail!"
  88
  89 -- set intersection
  90 setIntersect :: Val -> Val -> Sem Val
  91 setIntersect (ISVal is1) (ISVal is2) = Sem $ \st -> (ISVal (intersect is1 is2), st)
  92 setIntersect _ _ = expFail "intersection fail!"
  93
  94 -- set size
  95 setSize :: Val -> Sem Val
  96 setSize (ISVal is) = Sem $ \st -> (IVal (length is), st)
  97 setSize _ = expFail "size fail!"
  98
  99 -- integer operation
 100 intOper :: Val -> Op -> Val -> Val
 101 intOper (IVal i1) Add (IVal i2) = IVal (i1+i2)
 102 intOper (IVal i1) Sub (IVal i2) = IVal (i1-i2)
 103 intOper (IVal i1) Mul (IVal i2) = IVal (i1*i2)
 104 intOper _ _ _ = Error "Invalid integer operation!"
 105
 106 -- Evaluate expression
 107 eval :: Expr a -> Sem Val
 108 eval New = Sem $ \st -> (ISVal [], st)
 109 eval (Ins e exp) = eval exp >>= \set -> eval e >>= \el -> setInsert set el
 110 eval (Del e exp) = eval exp >>= \set -> eval e >>= \el -> setDelete set el
 111 eval (Union exp1 exp2) = eval exp1 >>= \s1 -> eval exp2 >>= \s2 -> setUnion s1 s2
 112 eval (Diff exp1 exp2) = eval exp1 >>= \s1 -> eval exp2 >>= \s2 -> setDiff s1 s2
 113 eval (Intersect exp1 exp2) = eval exp1 >>= \s1 -> eval exp2 >>= \s2 -> setIntersect s1 s2
 114 eval (Lit i) = Sem $ \st -> (IVal i, st)
 115 eval (Var id) = varRead id
 116 eval (Size exp) = eval exp >>= setSize
 117 eval (Oper exp1 op exp2) = eval exp1 >>= \l -> eval exp2 >>= \r -> Sem $ \st -> (intOper l op r, st)
 118 eval (Store id exp) = eval exp >>= varWrite id
 119
 120 -- expression without error
 121 e = Store "y" (Ins (Lit 4) (Union (Ins (Lit 8) New) (Ins (Store "x" (Lit 55)) New)))
 122
 123 -- expression with error
 124 --e = Size (Lit 1)
 125
 126 -- entry point
 127 main = putStrLn (show (execSem (eval e) []))