module skeleton12

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
	(*.) infixl 7 :: (x a) (x a) -> x a | * a
class store x where
	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
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

class aexpr x | arith, store, except, =.= x
class bexpr x | arith, truth, except, =.= 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

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
throw1 = lit 3 +. throw

six :: e Int | expr e
six = write (lit 3) +. read

try1 :: e Int | expr e
try1 = try throw1 (lit 42)

loge :: e Bool | expr e
loge = lit True *. -. (lit True)

comp :: e Bool | expr e
comp = lit 1 =.= lit 2 XOR -. (-. (lit True))

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")
*/