module skeleton7

from iTasks import 
	always, hasValue, :: TaskValue(..), :: Task, :: Stability,
	:: TaskCont(..), :: Action, updateInformation, viewInformation, 
	class descr, instance descr String, :: UpdateOption, :: ViewOption(..),
	-||-, -||, ||- , startEngine, class Publishable, >>*, class TFunctor,
	instance TFunctor Task, class TApplicative, instance TApplicative Task,
	instance Publishable Task, Void
import Data.Tuple, StdClass, StdList, iTasks._Framework.Generic, Text.JSON,
	Data.Functor, Control.Applicative, Control.Monad, Data.Map, Data.Either
import qualified iTasks
import qualified Text
import qualified Data.List as List
import StdTuple
from Text import class Text, instance Text String
from StdFunc import o

e = New

:: Expression
	= New
	| Insert	 Element Set
	| Delete	 Element Set
	| Variable	 Ident
	| Union	 Set 	Set
	| Difference 	 Set 	Set
	| Intersection	 Set 	Set
	| Integer	 Int
	| Size	 Set
	| Oper	 Element Op Element
	| (=.) infixl 2 Ident Expression

:: Op =	+. | -. | *.
:: Set 	:== Expression
:: Element	:== Expression
:: Ident	:== String


// === State
:: Val = Int Int | Set [Int]
:: State :== Map String Val

:: Sem a = Sem (State -> (Either String a, State)) 

// === semantics
unsem :: (Sem a) -> (State -> (Either String a, State))
unsem (Sem a) = a

instance Functor Sem where
	fmap f s = Sem \st.let (a, st`)=unsem s st in (fmap f a, st`)

instance Applicative Sem where
	pure s = Sem \st.(pure s, st)
	(<*>) a f = ap a f

instance Monad Sem where
	bind (Sem s) f = Sem \st.case s st of
		(Right v, st`) = unsem (f v) st`
		(Left e, st`) = (Left e, st`)

store :: Ident Val -> Sem Val
store i v = Sem \st.(pure v, put i v st)

read :: Ident -> Sem Val
read i = Sem \st.case get i st of
		(Just v) = (Right v, st)
		_ = unsem (fail "variable not found") st

fail :: String -> Sem a
fail s = Sem \st.(Left s,st)

expectInt :: Expression String -> Sem Int
expectInt e m = eval e >>= \r.case r of
	(Int i) = return i
	_ = fail (m +++ " argument has to be an Int")

expectSet :: Expression String -> Sem [Int]
expectSet e m = eval e >>= \r.case r of
	(Set i) = return i
	_ = fail (m +++ " argument has to be a Set")

instance toString Op where
	toString (+.) = "+"
	toString (-.) = "-"
	toString (*.) = "*"

eval :: Expression -> Sem Val
eval New = return (Set [])
eval (Insert e s) = expectInt e "Insert, 1st" 
	>>= \e.expectSet s "Insert, 2nd" 
	>>= \s.return (Set [e:s])
eval (Delete e s) = expectInt e "Delete, 1st"
	>>= \e.expectSet s "Delete, 2nd"
	>>= \s.return (Set ('List'.delete e s))
eval (Variable e) = read e
eval (Union s1 s2) = expectSet s1 "Union, 1st"
	>>= \s1.expectSet s2 "Union, 2nd"
	>>= \s2.return (Set ('List'.union s1 s2))
eval (Difference s1 s2) = expectSet s1 "Difference, 1st"
	>>= \s1.expectSet s2 "Difference, 2nd"
	>>= \s2.return (Set ('List'.difference s1 s2))
eval (Intersection s1 s2) = expectSet s1 "Intersection, 1st"
	>>= \s1.expectSet s2 "Intersection, 2nd"
	>>= \s2.return (Set ('List'.intersect s1 s2))
eval (Integer i) = return (Int i)
eval (Size s) = expectSet e "Size, 1st" >>= \e.return (Int (length e))
eval (Oper e1 o e2) = expectInt e1 (toString o +++ ", 1st")
	>>= \e1.expectInt e2 (toString o +++ ", 2nd")
	>>= \e2.case o of
		(+.) = return (Int (e1+e2))
		(-.) = return (Int (e1-e2))
		(*.) = return (Int (e1*e2))
eval (i =. e) = eval e >>= \e.store i e

evalExpr :: Expression State -> Either String Val
evalExpr e s = fst (unsem (eval e) s)

print :: Expression -> String
print e = 'Text'.concat (print` e [])

print` :: Expression [String] -> [String]
print` New l = ["Ø":l]
print` (Insert e s) l = ["{":print` e ["}∪":print` s l]]
print` (Delete e s) l = ["(":print` s [")\\{":print` e ["}":l]]]
print` (Variable e) l = [e:l]
print` (Union s1 s2) l = ["(":print` s1 [")∪(":print` s2 [")":l]]]
print` (Difference s1 s2) l = ["(":print` s1 [")∆(":print` s2 [")":l]]]
print` (Intersection s1 s2) l = ["(":print` s1 [")∩(":print` s2 [")":l]]]
print` (Integer i) l = [toString i: l]
print` (Size s) l = ["|":print` s ["|":l]]
print` (Oper e1 o e2) l = ["(":print` e1 [")",toString o,"(":print` e2 [")":l]]]
print` (i =. e) l = [i,"=":print` e l++["\n"]]

// === simulation

(>>>=) :== 'iTasks'.tbind
(>>>|) a b :== 'iTasks'.tbind a (\_ -> b)
treturn :== 'iTasks'.return
ActionOk :== 'iTasks'.ActionOk
ActionQuit :== 'iTasks'.ActionQuit
ActionNew :== 'iTasks'.ActionNew

expressionLens :: Expression -> String
expressionLens e = case evalExpr e newMap of
	(Left s) = "Error: " +++ s
	(Right (Set s)) = "{" +++ ('Text'.join ", " (map toString s)) +++ "}"
	(Right (Int i)) = toString i

mainTask = updateInformation "Expression enter" [] e
	>>* [OnAction ActionOk (hasValue (viewInformation "Expression view" [ViewWith expressionLens]))]

derive class iTask Expression, Op, Val

Start :: *World -> *World
Start world = startEngine mainTask world
//Start = print (Insert (Size (Insert (Oper (Integer 5) +. (Integer 6)) New)) New)