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
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
15 write :: (x Int) -> x Int
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
22 try :: (x a) (x a) -> x a
24 class aexpr x | arith, store, except, =.= x
25 class bexpr x | arith, truth, except, =.= x
26 class expr x | aexpr, bexpr x
28 instance * Bool where (*) b1 b2 = b1 && b2
29 instance + Bool where (+) b1 b2 = b1 || b2
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]]]
50 show (Show f) = 'Text'.concat (f ["\n"])
52 //Section 2: Evaluation
53 :: Step a = Step (State -> (Maybe a, State))
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`)
66 instance arith Step where
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
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`
88 seven :: e Int | aexpr e
89 seven = lit 3 +. lit 4
91 throw1 :: e Int | expr e
92 throw1 = lit 3 +. throw
95 six = write (lit 3) +. read
97 try1 :: e Int | expr e
98 try1 = try throw1 (lit 42)
100 loge :: e Bool | expr e
101 loge = lit True *. -. (lit True)
103 comp :: e Bool | expr e
104 comp = lit 1 =.= lit 2 XOR -. (-. (lit True))
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))
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")