module skeleton12
-import Data.Maybe
-import Control.Monad
-import StdInt, StdString, StdBool
+from Text import class Text, instance Text String
+import Control.Applicative, Control.Monad
+import Data.Maybe, Data.Functor
+import StdInt, StdString, StdBool, StdList
+import qualified Text
class arith x where
lit :: a -> x a | toString a
- (+.) infixl 6 :: (x a) (x a) -> x a | + a // integer addition, Boolean OR
- (*.) infixl 7 :: (x a) (x a) -> x a | * a // integer multiplication, Boolean AND
+ (+.) infixl 6 :: (x a) (x a) -> x a | + a
+ (*.) infixl 7 :: (x a) (x a) -> x a | * a
class store x where
- read :: (x Int)
+ read :: (x Int)
write :: (x Int) -> x Int
class truth x where
(XOR) infixr 3 :: (x Bool) (x Bool) -> x Bool
- -. :: (x Bool) -> x Bool
+ -. :: (x Bool) -> x Bool
class (=.=) infix 4 x :: (x a) (x a) -> x Bool | == a
class except x where
throw :: (x a)
- try :: (x a) (x a) -> x a
+ try :: (x a) (x a) -> x a
class aexpr x | arith, store, except, =.= x
class bexpr x | arith, truth, except, =.= x
-class expr x | aexpr, bexpr x
+class expr x | aexpr, bexpr x
+instance * Bool where (*) b1 b2 = b1 && b2
+instance + Bool where (+) b1 b2 = b1 || b2
+
+
+//Section 1: Showing expressions
+:: Show a = Show ([String] -> [String])
+instance arith Show where
+ lit x = Show \s.[toString x:s]
+ (+.) (Show x1) (Show x2) = Show \s.x1 ["+":x2 s]
+ (*.) (Show x1) (Show x2) = Show \s.x1 ["*":x2 s]
+instance store Show where
+ read = Show \s.["read":s]
+ write (Show x) = Show \s.["write (":x [")":s]]
+instance truth Show where
+ (XOR) (Show x1) (Show x2) = Show \s.x1 ["⊕":x2 s]
+ -. (Show x) = Show \s.["¬":x s]
+instance =.= Show where
+ (=.=) (Show x1) (Show x2) = Show \s.x1 ["=":x2 s]
+instance except Show where
+ throw = Show \s.["throw":s]
+ try (Show x1) (Show x2) = Show \s.["try (":x1 [") except (":x2 [")":s]]]
+
+show (Show f) = 'Text'.concat (f ["\n"])
+
+//Section 2: Evaluation
:: Step a = Step (State -> (Maybe a, State))
:: State :== Int
-/*seven :: e Int | aexpr e
+instance Functor Step where
+ fmap f (Step s) = Step \st.let (x, st`)=s st in (fmap f x, st`)
+instance Applicative Step where
+ pure s = Step \st.(pure s, st)
+ (<*>) x1 x2 = ap x1 x2
+instance Monad Step where
+ bind (Step s) f = Step \st.case s st of
+ (Just x, st`) = let (Step s`) = f x in s` st`
+ (_, st`) = (Nothing, st`)
+
+instance arith Step where
+ lit x = pure x
+ (+.) x1 x2 = (+) <$> x1 <*> x2
+ (*.) x1 x2 = (*) <$> x1 <*> x2
+instance store Step where
+ read = Step \st.(Just st, st)
+ write (Step x) = Step \st.case x st of
+ (Just v`, _) = (Just v`, v`)
+ (_, st) = (Nothing, st)
+instance truth Step where
+ (XOR) x1 x2 = (\x.(\y.x && not y || not x && y)) <$> x1 <*> x2
+ -. x1 = (not) <$> x1
+instance =.= Step where
+ (=.=) x1 x2 = (==) <$> x1 <*> x2
+instance except Step where
+ throw = Step \st.(Nothing, st)
+ try (Step x1) (Step x2) = Step \st.case x1 st of
+ (Just v`, st`) = (Just v`, st)
+ (Nothing, st`) = x2 st`
+
+eval (Step f) = f 0
+
+seven :: e Int | aexpr e
seven = lit 3 +. lit 4
throw1 :: e Int | expr e
loge = lit True *. -. (lit True)
comp :: e Bool | expr e
-comp = lit 1 =.= lit 2 XOR -. (-. (lit True))*/
+comp = lit 1 =.= lit 2 XOR -. (-. (lit True))
-Start = 0
+Start = (
+ (eval seven, show seven),
+ (eval throw1, show throw1),
+ (eval six, show six),
+ (eval try1, show try1),
+ (eval loge, show loge),
+ (eval comp, show comp))
+/*
+((Just 7),0),"3+4"),
+((Nothing,0),"3+throw"),
+(((Just 6),3),"write (3)+read"),
+(((Just 42),0),"try (3+throw) except (42)"),
+(((Just False),0),"True*¬True"),
+(((Just True),0),"1=2⊕¬¬True")
+*/
repositories / ap2015.git / commitdiff