a9/mart/skeleton9.icl

   1 // Mart Lubbers s4109503
   2 // Charlie Gerhardus s3050009
   3
   4 module skeleton9
   5 //One does not go over 80chars.
   6 //the true lambda character is the .
   7
   8 from iTasks import always, hasValue, :: TaskValue(..), :: Task, :: Stability,
   9         :: TaskCont(..), :: Action, updateInformation, viewInformation, class
  10         descr, instance descr String, :: UpdateOption, :: ViewOption(..), -||-,
  11         -||, ||-, startEngine, class Publishable, >>*, class TFunctor,
  12         instance TFunctor Task, class TApplicative, instance TApplicative Task,
  13         instance Publishable Task, Void
  14 import Data.Tuple, StdClass, StdList, iTasks._Framework.Generic, Text.JSON,
  15         Data.Functor, Control.Applicative, Control.Monad, Data.Map, StdMisc
  16 import qualified iTasks
  17 import qualified Text
  18 from Text import class Text, instance Text String
  19 from StdFunc import o
  20 import qualified Data.List as List
  21
  22 :: BM a b = {t :: a -> b, f :: b -> a}
  23 bm :: BM a a
  24 bm = {f=id, t=id}
  25 :: Op = Pl | Mi | Ti
  26 :: Set :== Expr [Int]
  27 :: Element :== Expr Int
  28 :: Expr a
  29         = New (BM a [Int])
  30         | Insert (BM a [Int]) Element Set
  31         | Delete (BM a [Int]) Element Set
  32         | Variable (BM a a) Ident
  33         | Union (BM a [Int]) Set Set
  34         | Difference (BM a [Int]) Set Set
  35         | Intersection (BM a [Int]) Set Set
  36         | Integer (BM a Int) Int
  37         | Size (BM a Int) Set
  38         | Oper (BM a Int) Element Op Element
  39         | Assign (BM a a) Ident (Expr a)
  40 new :== New bm
  41 insert = Insert bm
  42 delete = Delete bm
  43 variable = Variable bm
  44 union = Union bm
  45 difference = Difference bm
  46 intersection = Intersection bm
  47 integer :== Integer bm
  48 size = Size bm
  49 oper = Oper bm
  50 instance + Element where (+) x y = Oper bm x Pl y
  51 instance - Element where (-) x y = Oper bm x Mi y
  52 instance * Element where (*) x y = Oper bm x Ti y
  53 (=.) infix 4
  54 (=.) x y = Assign bm x y
  55
  56 print :: a -> String | show a
  57 print x = 'Text'.concat (show x [])
  58
  59 class show a :: a [String] -> [String]
  60 instance show Op where
  61         show o l = case o of Pl = ["+":l]; Mi = ["-":l]; Ti = ["*":l];
  62 instance show Int where show i l = [toString i:l]
  63 instance show [Int] where show i l = [toString i:l]
  64 instance show (Expr a) | show a where
  65         show (New _) l = ["{}":l]
  66         show (Insert _ e s) l = ["{":show e ["}|":show s l]]
  67         show (Delete _ e s) l = ["{":show e ["}\\":show s l]]
  68         show (Variable _ s) l = [s:l]
  69         show (Union _ s1 s2) l = show s1 ["|":show s2 l]
  70         show (Difference _ s1 s2) l = show s1 ["\\":show s2 l]
  71         show (Intersection _ s1 s2) l = show s1 ["&":show s2 l]
  72         show (Integer _ i) l = show i l
  73         show (Size _ s) l = ["|":show s ["|":l]]
  74         show (Oper _ e1 op e2) l = show e1 (show op (show e2 l))
  75         show (Assign _ s e) l = [s:["=":show e l]]
  76
  77 // === State
  78 :: Ident :== String
  79 :: State :== Map Ident Dynamic
  80 :: Sem a = Sem (State -> (MaybeEx a, State))
  81 :: MaybeEx a = Result a | Exception String
  82
  83 // === state handling
  84
  85 instance Functor Sem where
  86         fmap :: (a -> b) (Sem a) -> Sem b
  87         fmap f (Sem sF) = Sem (appFst (fmap f) o sF)
  88
  89 instance Functor MaybeEx where
  90         fmap :: (a -> b) (MaybeEx a) -> MaybeEx b
  91         fmap f (Result a) = Result (f a)
  92         fmap _ (Exception e) = Exception e
  93
  94 instance Applicative Sem where
  95         pure :: a -> Sem a
  96         pure a = Sem \st.(pure a, st)
  97
  98         (<*>) infixl 4 :: (Sem (a -> b)) (Sem a) -> Sem b
  99         (<*>) (Sem sFA) (Sem sFB) = Sem newSF
 100         where
 101                 newSF st
 102                         # (ra, st) = sFA st
 103                         # (rb, st) = sFB st
 104                         = (ra <*> rb, st)
 105
 106 instance Applicative MaybeEx where
 107         pure :: a -> MaybeEx a
 108         pure a = Result a
 109
 110         (<*>) infixl 4 :: (MaybeEx (a -> b)) (MaybeEx a) -> MaybeEx b
 111         (<*>) (Result f) (Result x) = Result (f x)
 112         (<*>) (Exception e) _ = Exception e
 113         (<*>) _ (Exception e) = Exception e
 114
 115 instance Monad Sem where
 116         bind :: (Sem a) (a -> Sem b) -> Sem b
 117         bind (Sem sFA) f = Sem sF
 118         where
 119                 sF st
 120                         # (mbA, st) = sFA st
 121                         = case mbA of
 122                                 Result a
 123                                         # (Sem sFB) = f a
 124                                         = sFB st
 125                                 Exception e = (Exception e, st)
 126
 127 fail :: String -> Sem a
 128 fail msg = Sem \st.(Exception msg, st)
 129
 130 store :: Ident a -> Sem a | TC a
 131 store i v = Sem \st.(Result v, put i (dynamic v) st)
 132
 133 read :: Ident -> Sem a | TC a
 134 read i = Sem \st.case get i st of
 135         Just (a :: a^) = (Result a, st)
 136         Just d = (Exception ('Text'.concat ["expected ", toString expType, " got ",
 137                 toString (typeCodeOfDynamic d)]), st)
 138         Nothing = (Exception "No variable with that name", st)
 139 where
 140         expType = typeCodeOfDynamic (dynamic undef :: a^)
 141
 142 // === semantics
 143 eval :: (Expr a) -> Sem a | TC a
 144 eval (New {f}) = return (f [])
 145 eval (Variable {f} i) = read i
 146 eval (Assign {f} v e) = eval e >>= \a.store v a
 147 eval (Insert {f} e s) = eval e >>= \a.eval s
 148         >>= \x.return (f ('List'.union [a] x))
 149 eval (Delete {f} e s) = eval e >>= \a.eval s
 150         >>= \x.return (f ('List'.delete a x))
 151 eval (Union {f} s1 s2) = eval s1 >>= \x.eval s2
 152         >>= \y.return (f ('List'.union x y))
 153 eval (Difference {f} s1 s2) = eval s1 >>= \x.eval s2
 154         >>= \y.return (f ('List'.difference x y))
 155 eval (Intersection {f} s1 s2) = eval s1 >>= \x.eval s2
 156         >>= \y.return (f ('List'.intersect x y))
 157 eval (Integer {f} i) = return (f i)
 158 eval (Size {f} s) = eval s >>= \x.return (f (length x))
 159 eval (Oper {f} e1 o e2) = eval e1 >>= \a.eval e2 >>= \b.return (f (case o of
 160         Pl = a+b
 161         Mi = a-b
 162         Ti = a*b))
 163
 164 evalExpr :: (Expr a) State -> (MaybeEx a, State) | TC a
 165 evalExpr expr st = let (Sem func) = eval expr in func st
 166
 167 Start :: (MaybeEx Int, State)
 168 Start = evalExpr (size (variable "x")) state
 169         where
 170                 (_, state) = evalExpr ("x" =. (insert (integer 42) new)) newMap