a9/mart/skeleton9.icl

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