a12/mart/skeleton12_1-3.icl

   1 module skeleton12
   2
   3 from Text import class Text, instance Text String
   4 import Control.Applicative, Control.Monad
   5 import Data.Maybe, Data.Functor
   6 import StdInt, StdString, StdBool, StdList
   7 import qualified Text
   8
   9 class arith x where
  10         lit :: a -> x a | toString a
  11         (+.) infixl 6 :: (x a) (x a) -> x a | + a
  12         (*.) infixl 7 :: (x a) (x a) -> x a | * a
  13 class store x where
  14         read :: (x Int)
  15         write :: (x Int) -> x Int
  16 class truth x where
  17         (XOR) infixr 3 :: (x Bool) (x Bool) -> x Bool
  18         -. :: (x Bool) -> x Bool
  19 class (=.=) infix 4 x :: (x a) (x a) -> x Bool | == a
  20 class except x where
  21         throw :: (x a)
  22         try :: (x a) (x a) -> x a
  23
  24 class aexpr x | arith, store, except, =.= x
  25 class bexpr x | arith, truth, except, =.= x
  26 class expr x | aexpr, bexpr x
  27
  28 instance * Bool where (*) b1 b2 = b1 && b2
  29 instance + Bool where (+) b1 b2 = b1 || b2
  30
  31
  32 //Section 1: Showing expressions
  33 :: Show a = Show ([String] -> [String])
  34 instance arith Show where
  35         lit x = Show \s.[toString x:s]
  36         (+.) (Show x1) (Show x2) = Show \s.x1 ["+":x2 s]
  37         (*.) (Show x1) (Show x2) = Show \s.x1 ["*":x2 s]
  38 instance store Show where
  39         read = Show \s.["read":s]
  40         write (Show x) = Show \s.["write (":x [")":s]]
  41 instance truth Show where
  42         (XOR) (Show x1) (Show x2) = Show \s.x1 ["⊕":x2 s]
  43         -. (Show x) = Show \s.["¬":x s]
  44 instance =.= Show where
  45         (=.=) (Show x1) (Show x2) = Show \s.x1 ["=":x2 s]
  46 instance except Show where
  47         throw = Show \s.["throw":s]
  48         try (Show x1) (Show x2) = Show \s.["try (":x1 [") except (":x2 [")":s]]]
  49
  50 show (Show f) = 'Text'.concat (f ["\n"])
  51
  52 //Section 2: Evaluation
  53 :: Step a = Step (State -> (Maybe a, State))
  54 :: State :== Int
  55
  56 instance Functor Step where
  57         fmap f (Step s) = Step \st.let (x, st`)=s st in (fmap f x, st`)
  58 instance Applicative Step where
  59         pure s = Step \st.(pure s, st)
  60         (<*>) x1 x2 = ap x1 x2
  61 instance Monad Step where
  62         bind (Step s) f = Step \st.case s st of
  63                 (Just x, st`) = let (Step s`) = f x in s` st`
  64                 (_, st`) = (Nothing, st`)
  65
  66 instance arith Step where
  67         lit x = pure x
  68         (+.) x1 x2 = (+) <$> x1 <*> x2
  69         (*.) x1 x2 = (*) <$> x1 <*> x2
  70 instance store Step where
  71         read = Step \st.(Just st, st)
  72         write (Step x) = Step \st.case x st of
  73                 (Just v`, _) = (Just v`, v`)
  74                 (_, st) = (Nothing, st)
  75 instance truth Step where
  76         (XOR) x1 x2 = (\x.(\y.x && not y || not x && y)) <$> x1 <*> x2
  77         -. x1 = (not) <$> x1
  78 instance =.= Step where
  79         (=.=) x1 x2 = (==) <$> x1 <*> x2
  80 instance except Step where
  81         throw = Step \st.(Nothing, st)
  82         try (Step x1) (Step x2) = Step \st.case x1 st of
  83                 (Just v`, st`) = (Just v`, st)
  84                 (Nothing, st`) = x2 st`
  85
  86 eval (Step f) = f 0
  87
  88 seven :: e Int | aexpr e
  89 seven = lit 3 +. lit 4
  90
  91 throw1 :: e Int | expr e
  92 throw1 = lit 3 +. throw
  93
  94 six :: e Int | expr e
  95 six = write (lit 3) +. read
  96
  97 try1 :: e Int | expr e
  98 try1 = try throw1 (lit 42)
  99
 100 loge :: e Bool | expr e
 101 loge = lit True *. -. (lit True)
 102
 103 comp :: e Bool | expr e
 104 comp = lit 1 =.= lit 2 XOR -. (-. (lit True))
 105
 106 Start = (
 107         (eval seven, show seven),
 108         (eval throw1, show throw1),
 109         (eval six, show six),
 110         (eval try1, show try1),
 111         (eval loge, show loge),
 112         (eval comp, show comp))
 113 /*
 114 ((Just 7),0),"3+4"),
 115 ((Nothing,0),"3+throw"),
 116 (((Just 6),3),"write (3)+read"),
 117 (((Just 42),0),"try (3+throw) except (42)"),
 118 (((Just False),0),"True*¬True"),
 119 (((Just True),0),"1=2⊕¬¬True")
 120 */