module skeleton12

import Data.Maybe
import Control.Monad
import StdInt, StdString, StdBool

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
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

:: Step a = Step (State -> (Maybe a, State))
:: State :== Int

instance Functor Step where
	fmap f (Step g) = Step \st . h (g st) where
		h (Just x, st) = (Just (f x), st)
		h (Nothing, st) = (Nothing, st)

instance Applicative Step where
	pure x = Step \st . (Just x, st)
	(<*>) (Step f) (Step g) = Step \st . h (f st) where
		h (Just f, st) = q f (g st)
		h (Nothing, st) = (Nothing, st)
		q f (Just x, st) = (Just (f x), st)
		q _ (Nothing, st) = (Nothing, st)

instance Monad Step where
	bind (Step f) g = Step \st . h (f st) where
		h (Just x, st) = q (g x) st
		h (Nothing, st) = (Nothing, st)
		q (Step f) st = f st

instance arith Step where
	lit x = return x
	(+.) x y = x >>= \x` . y >>= \y` . return (x`+y`)
	(*.) x y = x >>= \x` . y >>= \y` . return (x`*y`)

instance store Step where
	read = Step \st . (Just st, st)
	write x = x >>= \x` . Step \st . (Just x`, x`)

instance truth Step where
	(XOR) x y = x >>= \x` . y >>= \y` . return (x` bitxor y`)
	-. x = x >>= \x` . return (not x`)

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))

:: Show a = Show ([String] -> [String])

instance arith Show where
	lit x = Show \xs . [toString x:xs]
	(+.) (Show f) (Show g) = Show \xs . f ["+":g xs]
	(*.) (Show f) (Show g) = Show \xs . f ["*":g xs]

instance store Show where
	read = Show \xs . ["read":xs]
	write (Show f) = Show \xs . ["write":f xs]
	
instance truth Show where
	(XOR) (Show f) (Show g) = Show \xs . f ["XOR":g xs]
	-. (Show f) = Show \xs . ["!":f xs]

instance =.= Show where
	(=.=)(Show f) (Show g) = Show \xs . f ["==":g xs]

instance except Show where
	throw = Show \xs . ["throw":xs]
	try (Show f) (Show g) = Show \xs . ["try":f ["catch":g xs]]

show :: (Show a) -> [String]
show (Show f) = f []

Start :: Step Bool
Start = comp >>= return