a12/charlie/skeleton12.icl

   1 module skeleton12
   2
   3 import Data.Maybe
   4 import Control.Monad
   5 import StdInt, StdString, StdBool
   6
   7 class arith x where
   8         lit :: a -> x a | toString a
   9         (+.) infixl 6 :: (x a) (x a) -> x a | + a // integer addition, Boolean OR
  10         (*.) infixl 7 :: (x a) (x a) -> x a | * a // integer multiplication, Boolean AND
  11 class store x where
  12         read  :: (x Int)
  13         write :: (x Int) -> x Int
  14 class truth x where
  15         (XOR) infixr 3 :: (x Bool) (x Bool) -> x Bool
  16         -.    :: (x Bool) -> x Bool
  17 class (=.=) infix 4 x :: (x a) (x a) -> x Bool | == a
  18 class except x where
  19         throw :: (x a)
  20         try   :: (x a) (x a) -> x a
  21
  22 class aexpr x | arith, store, except, =.= x
  23 class bexpr x | arith, truth, except, =.= x
  24 class expr x  | aexpr, bexpr x
  25
  26 :: Step a = Step (State -> (Maybe a, State))
  27 :: State :== Int
  28
  29 instance Functor Step where
  30         fmap f (Step g) = Step \st . h (g st) where
  31                 h (Just x, st) = (Just (f x), st)
  32                 h (Nothing, st) = (Nothing, st)
  33
  34 instance Applicative Step where
  35         pure x = Step \st . (Just x, st)
  36         (<*>) (Step f) (Step g) = Step \st . h (f st) where
  37                 h (Just f, st) = q f (g st)
  38                 h (Nothing, st) = (Nothing, st)
  39                 q f (Just x, st) = (Just (f x), st)
  40                 q _ (Nothing, st) = (Nothing, st)
  41
  42 instance Monad Step where
  43         bind (Step f) g = Step \st . h (f st) where
  44                 h (Just x, st) = q (g x) st
  45                 h (Nothing, st) = (Nothing, st)
  46                 q (Step f) st = f st
  47
  48 instance arith Step where
  49         lit x = return x
  50         (+.) x y = x >>= \x` . y >>= \y` . return (x`+y`)
  51         (*.) x y = x >>= \x` . y >>= \y` . return (x`*y`)
  52
  53 instance store Step where
  54         read = Step \st . (Just st, st)
  55         write x = x >>= \x` . Step \st . (Just x`, x`)
  56
  57 instance truth Step where
  58         (XOR) x y = x >>= \x` . y >>= \y` . return (x` bitxor y`)
  59         -. x = x >>= \x` . return (not x`)
  60
  61 seven :: e Int | aexpr e
  62 seven = lit 3 +. lit 4
  63
  64 throw1 :: e Int | expr e
  65 throw1 = lit 3 +. throw
  66
  67 six :: e Int | expr e
  68 six = write (lit 3) +. read
  69
  70 try1 :: e Int | expr e
  71 try1 = try throw1 (lit 42)
  72
  73 /*loge :: e Bool | expr e
  74 loge = lit True *. -. (lit True)*/
  75
  76 comp :: e Bool | expr e
  77 comp = lit 1 =.= lit 2 XOR -. (-. (lit True))
  78
  79 :: Show a = Show ([String] -> [String])
  80
  81 instance arith Show where
  82         lit x = Show \xs . [toString x:xs]
  83         (+.) (Show f) (Show g) = Show \xs . f ["+":g xs]
  84         (*.) (Show f) (Show g) = Show \xs . f ["*":g xs]
  85
  86 instance store Show where
  87         read = Show \xs . ["read":xs]
  88         write (Show f) = Show \xs . ["write":f xs]
  89
  90 instance truth Show where
  91         (XOR) (Show f) (Show g) = Show \xs . f ["XOR":g xs]
  92         -. (Show f) = Show \xs . ["!":f xs]
  93
  94 instance =.= Show where
  95         (=.=)(Show f) (Show g) = Show \xs . f ["==":g xs]
  96
  97 instance except Show where
  98         throw = Show \xs . ["throw":xs]
  99         try (Show f) (Show g) = Show \xs . ["try":f ["catch":g xs]]
 100
 101 show :: (Show a) -> [String]
 102 show (Show f) = f []
 103
 104 Start :: Step Bool
 105 Start = comp >>= return