Commit 9eafce85 authored by Tim Steenvoorden's avatar Tim Steenvoorden

Merge branch 'typed-task-editor-simple' into typed-task-editor

parents b2189b57 34deb068
Pipeline #25100 passed with stage
in 5 minutes and 50 seconds
......@@ -28,7 +28,7 @@ Start world = doTasks (editTaskExpr Nothing) world
editTaskExpr :: (Maybe (DynamicEditorValue TaskExpr)) -> Task (Maybe (DynamicEditorValue TaskExpr))
editTaskExpr mv =
enterOrUpdateExpr ("Contruct a task", info1) mv >?>
[ ( "Run", always, \v -> viewInformation ("Evaluate the task", info2) [] () ||- (evalTaskConstExpr (toValue taskEditor v) <<@ ApplyLayout frameCompact) >?>
[ ( "Run", always, \v -> viewInformation ("Evaluate the task", info2) [] () ||- (evalTaskExpr (toValue taskEditor v) <<@ ApplyLayout frameCompact) >?>
[ ( "Finish", always, \r -> viewInformation ("Done!", info3) [] r >?>
[ ( "Back", always, \_ -> editTaskExpr (Just v) ) ]
)
......@@ -44,35 +44,47 @@ where
info3 = "The program is done, the result is given below."
enterOrUpdateExpr msg Nothing = enterInformation msg [EnterUsing id $ dynamicEditor taskEditor]
enterOrUpdateExpr msg (Just v) = updateInformation msg [UpdateUsing id (curry fst) (dynamicEditor taskEditor)] v
enterOrUpdateExpr msg (Just v) = updateInformation msg [UpdateUsing id (curry snd) (dynamicEditor taskEditor)] v
// Data ////////////////////////////////////////////////////////////////////////
:: TaskExpr
= Done Expr
// | Apply TaskFuncExpr Expr
| EnterInfo String Ty
| Then TaskExpr TaskFuncExpr
| Or TaskExpr TaskExpr
| And TaskExpr TaskExpr
| When TaskExpr (List TaskContExpr)
| Then TaskExpr TaskFunc
| Both TaskExpr TaskExpr
| Any TaskExpr TaskExpr
| One TaskExpr TaskExpr
:: TaskFuncExpr
= ViewInfo String
| UpdateInfo String
:: TaskContExpr
= { name :: String, pred :: FuncExpr, cont :: TaskFuncExpr}
:: TaskFunc
= ViewF String Func
| UpdateF String
| ThenF TaskFunc TaskFunc
:: Expr
= Int Int
| Bool Bool
| String String
| Tuple Expr Expr
| Fst Expr
| Snd Expr
| Eq Expr Expr
| Apply Func Expr
:: Func
= Identity
| Conj Expr
| Disj Expr
| Not
| Gt Expr
| Ge Expr
| Eq Expr
| Le Expr
| Lt Expr
| Add Expr
| Sub Expr
| Mul Expr
| Div Expr
| Fst
| Snd
:: Value
= VInt Int
......@@ -80,18 +92,13 @@ where
| VString String
| VTuple Value Value
:: FuncExpr
= EqV Value
| GrtV Value
| LessV Value
:: Ty
= E.a: Ty (a -> Value) & iTask a
:: Typed a b
=: Typed a
derive class iTask TaskExpr, TaskFuncExpr, TaskContExpr, Expr, FuncExpr, Value, Typed
derive class iTask TaskExpr, TaskFunc, Expr, Func, Value, Typed
// These instances cannot be auto derived because of the existential quantifier.
// However, they will be never used, so we make them undefined.
......@@ -106,233 +113,324 @@ gEditor{|Ty|} = undef
// Editor //////////////////////////////////////////////////////////////////////
taskEditor :: DynamicEditor TaskExpr
taskEditor = DynamicEditor conses
where
conses =
taskEditor = DynamicEditor
[ // This cons is used to provide untyped `TaskExpr` values.
DynamicCons
$ functionConsDyn "TaskExpr" "(enter task)" (dynamic \(Typed taskExpr) -> taskExpr :: A.a: (Typed TaskExpr a) -> TaskExpr)
<<@@@ HideIfOnlyChoice
, DynamicConsGroup "Combinators"
[ functionConsDyn "Done" "done"
( dynamic \(Typed expr) -> Typed (Done expr) ::
A.a:
(Typed Expr a)
-> Typed TaskExpr (Task a)
)
, functionConsDyn "Then" "sequence"
[ functionConsDyn "Then" "sequence"
( dynamic \(Typed task) (Typed taskFunc) -> Typed (Then task taskFunc) ::
A.a b:
(Typed TaskExpr (Task a)) (Typed TaskFuncExpr (a -> Task b))
(Typed TaskExpr (Task a)) (Typed TaskFunc (a -> Task b))
-> Typed TaskExpr (Task b)
)
, functionConsDyn "When" "guarded sequence"
( dynamic \(Typed task1) (Typed steps) -> Typed (When task1 steps) ::
// Typed (When task1 [(expr, pred, tfExpr) \\ (Typed expr, pred, Typed tfExpr) <- steps]) ::
, functionConsDyn "ThenF" "sequence"
( dynamic \(Typed taskFunc1) (Typed taskFunc2) -> Typed (ThenF taskFunc1 taskFunc2) ::
A.a b c:
(Typed TaskFunc (a -> Task b)) (Typed TaskFunc (b -> Task c))
-> Typed TaskFunc (a -> Task c)
)
<<@@@ applyVerticalClasses
, functionConsDyn "Both" "both"
( dynamic \(Typed task1) (Typed task2) -> Typed (Both task1 task2) ::
A.a b:
(Typed TaskExpr (Task a))
(Typed (List TaskContExpr) (a -> Task b))
// (Typed (List (Typed FuncExpr (a -> Bool), String, Typed TaskFuncExpr (a -> Task a))) (a -> Task b))
-> Typed TaskExpr (Task b)
(Typed TaskExpr (Task b))
-> Typed TaskExpr (Task (a, b))
)
<<@@@ applyHorizontalClasses
, functionConsDyn "Or" "or"
( dynamic \(Typed task1) (Typed task2) -> Typed (Or task1 task2) ::
, functionConsDyn "Any" "any of"
( dynamic \(Typed task1) (Typed task2) -> Typed (Any task1 task2) ::
A.a b:
(Typed TaskExpr (Task a))
(Typed TaskExpr (Task a))
-> Typed TaskExpr (Task a)
)
<<@@@ applyHorizontalClasses
, functionConsDyn "And" "and"
( dynamic \(Typed task1) (Typed task2) -> Typed (And task1 task2) ::
, functionConsDyn "One" "one of"
( dynamic \(Typed task1) (Typed task2) -> Typed (One task1 task2) ::
A.a b:
(Typed TaskExpr (Task a))
(Typed TaskExpr (Task b))
-> Typed TaskExpr (Task (a, b))
(Typed TaskExpr (Task a))
-> Typed TaskExpr (Task a)
)
<<@@@ applyHorizontalClasses
, listConsDyn "List TaskContExpr" "continuations"
( dynamic \typedSteps -> Typed ((\(Typed expr) -> expr) <$> typedSteps) ::
A.a b:
(List (Typed TaskContExpr (a -> Task b)))
-> Typed (List TaskContExpr) (a -> Task b)
)
<<@@@ HideIfOnlyChoice
, functionConsDyn "TaskContExpr" "continuation"
( dynamic \s (Typed func) (Typed taskFunc) -> Typed {name = s, pred = func, cont = taskFunc} ::
A.a b:
String
(Typed FuncExpr a)
(Typed TaskFuncExpr (a -> Task b))
-> Typed TaskContExpr (a -> Task b)
)
<<@@@ HideIfOnlyChoice
<<@@@ AddLabels [Just "name", Just "predicate", Just "continuation"]
]
, DynamicConsGroup "Editors"
// [ functionConsDyn "Apply" "apply"
// ( dynamic \(Typed taskFunc) (Typed expr) ->
// Typed (Apply taskFunc expr) ::
// , functionConsDyn "When" "guarded sequence"
// ( dynamic \(Typed task1) (Typed steps) -> Typed (When task1 steps) ::
// // Typed (When task1 [(expr, pred, tfExpr) \\ (Typed expr, pred, Typed tfExpr) <- steps]) ::
// A.a b:
// (Typed TaskFuncExpr (a -> Task b))
// (Typed Expr a)
// (Typed TaskExpr (Task a))
// (Typed (List TaskContExpr) (a -> Task b))
// // (Typed (List (Typed Func (a -> Bool), String, Typed TaskFunc (a -> Task a))) (a -> Task b))
// -> Typed TaskExpr (Task b)
// )
[ functionConsDyn "EnterInfo" "enter information"
// <<@@@ applyHorizontalClasses
// , listConsDyn "List TaskContExpr" "continuations"
// ( dynamic \typedSteps -> Typed ((\(Typed expr) -> expr) <$> typedSteps) ::
// A.a b:
// (List (Typed TaskContExpr (a -> Task b)))
// -> Typed (List TaskContExpr) (a -> Task b)
// )
// <<@@@ HideIfOnlyChoice
// , functionConsDyn "TaskContExpr" "continuation"
// ( dynamic \s (Typed func) (Typed taskFunc) -> Typed {name = s, pred = func, cont = taskFunc} ::
// A.a b:
// String
// (Typed Func a)
// (Typed TaskFunc (a -> Task b))
// -> Typed TaskContExpr (a -> Task b)
// )
// <<@@@ HideIfOnlyChoice
// <<@@@ AddLabels [Just "name", Just "predicate", Just "continuation"]
]
, DynamicConsGroup "Editors"
[ functionConsDyn "Enter" "enter"
( dynamic \s (Typed ty) -> Typed (EnterInfo s ty) ::
A.a:
String (Typed Ty a)
String
(Typed Ty a)
-> Typed TaskExpr (Task a)
)
<<@@@ applyHorizontalClasses
, functionConsDyn "ViewInfo" "view information"
( dynamic \s -> Typed (ViewInfo s) ::
A.a:
, functionConsDyn "ViewF" "view"
( dynamic \s (Typed func) -> Typed (ViewF s func) ::
A.a b:
String
-> Typed TaskFuncExpr (a -> Task a)
(Typed Func (a -> b))
-> Typed TaskFunc (a -> Task b)
)
<<@@@ applyHorizontalClasses
, functionConsDyn "UpdateInfo" "update information"
( dynamic \s -> Typed (UpdateInfo s) ::
, functionConsDyn "UpdateF" "update"
( dynamic \s -> Typed (UpdateF s) ::
A.a:
String
-> Typed TaskFuncExpr (a -> Task a)
-> Typed TaskFunc (a -> Task a)
)
<<@@@ applyHorizontalClasses
]
, DynamicConsGroup "Special"
[ functionConsDyn "Done" "done"
( dynamic \(Typed expr) -> Typed (Done expr) ::
A.a:
(Typed Expr a)
-> Typed TaskExpr (Task a)
)
<<@@@ applyHorizontalClasses
]
// Non-task functions:
, DynamicConsGroup "Basics"
[ functionConsDyn "Identity" "this value"
(dynamic Typed Identity :: A.a: Typed Func (a -> a))
, functionConsDyn "Apply" "apply"
( dynamic \(Typed func) (Typed expr) ->
Typed (Apply func expr) ::
A.a b:
(Typed Func (a -> b))
(Typed Expr a)
-> Typed Expr b
)
<<@@@ applyHorizontalClasses
, functionConsDyn "Fst" "fst"
(dynamic Typed Fst :: A.a b: Typed Func ((a, b) -> a))
<<@@@ applyHorizontalClasses
, functionConsDyn "Snd" "snd"
(dynamic Typed Snd :: A.a b: Typed Func ((a, b) -> b))
<<@@@ applyHorizontalClasses
]
, DynamicConsGroup "Arithmetic"
[ functionConsDyn "Add" "add"
(dynamic \(Typed i) -> Typed (Add i) :: (Typed Expr Int) -> Typed Func (Int -> Int)) //XXX (Typed Expr Int) -> Typed Func (Int -> Int)
<<@@@ applyHorizontalClasses
, functionConsDyn "Sub" "sub"
(dynamic \(Typed i) -> Typed (Sub i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalClasses
, functionConsDyn "Mul" "mul"
(dynamic \(Typed i) -> Typed (Mul i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalClasses
, functionConsDyn "Div" "div"
(dynamic \(Typed i) -> Typed (Div i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalClasses
]
, DynamicConsGroup "Logic"
[ functionConsDyn "Conj" "and"
(dynamic \(Typed b) -> Typed (Conj b) :: (Typed Expr Bool) -> Typed Func (Bool -> Bool))
<<@@@ applyHorizontalClasses
, functionConsDyn "Disj" "or"
(dynamic \(Typed b) -> Typed (Disj b) :: (Typed Expr Bool) -> Typed Func (Bool -> Bool))
<<@@@ applyHorizontalClasses
, functionConsDyn "Not" "not"
(dynamic Typed Not :: Typed Func (Bool -> Bool))
<<@@@ applyHorizontalClasses
]
, DynamicConsGroup "Comparison"
[ functionConsDyn "Gt" "greater than"
(dynamic \(Typed i) -> Typed (Gt i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalClasses
, functionConsDyn "Ge" "greater or equal"
(dynamic \(Typed i) -> Typed (Ge i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalClasses
, functionConsDyn "Eq" "equal to"
(dynamic \(Typed i) -> Typed (Eq i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalClasses
, functionConsDyn "Le" "lesser than"
(dynamic \(Typed i) -> Typed (Le i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalClasses
, functionConsDyn "Lt" "lesser than"
(dynamic \(Typed i) -> Typed (Lt i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
<<@@@ applyHorizontalClasses
]
// ordinary (non-task) expressions
, DynamicCons
$ functionConsDyn "EqV" "equal" (dynamic \i -> Typed (EqV (VInt i)) :: Int -> Typed FuncExpr Int)
// Non-task expressions:
, DynamicConsGroup "Values"
[ functionConsDyn "Int" "the integer"
(dynamic \i -> Typed (Int i) :: Int -> Typed Expr Int)
<<@@@ applyHorizontalClasses
, DynamicCons
$ functionConsDyn "GrtV" "greater" (dynamic \i -> Typed (GrtV (VInt i)) :: Int -> Typed FuncExpr Int)
, functionConsDyn "Bool" "the boolean"
(dynamic \b -> Typed (Bool b) :: Bool -> Typed Expr Bool)
<<@@@ applyHorizontalClasses
, DynamicCons
$ functionConsDyn "LessV" "less" (dynamic \i -> Typed (LessV (VInt i)) :: Int -> Typed FuncExpr Int)
, functionConsDyn "String" "the string"
(dynamic \s -> Typed (String s) :: String -> Typed Expr String)
<<@@@ applyHorizontalClasses
, DynamicCons
$ functionConsDyn "int" "enter an integer:" (dynamic \i -> Typed (Int i) :: Int -> Typed Expr Int)
, DynamicCons
$ functionConsDyn "bool" "enter a boolean:" (dynamic \b -> Typed (Bool b) :: Bool -> Typed Expr Bool)
, DynamicCons
$ functionConsDyn "string" "enter a string:" (dynamic \s -> Typed (String s) :: String -> Typed Expr String)
, DynamicCons
$ functionConsDyn "tuple" "enter tuple:"
, functionConsDyn "Tuple" "the tuple"
( dynamic \(Typed a) (Typed b) ->
Typed (Tuple a b) ::
A.a b:
(Typed Expr a) (Typed Expr b) -> Typed Expr (a, b)
)
, DynamicCons
$ functionConsDyn "fst" "fst" (dynamic \(Typed (Tuple a _)) -> Typed a :: A.a b: (Typed Expr (a, b)) -> Typed Expr a)
<<@@@ applyHorizontalClasses
, DynamicCons
$ functionConsDyn "snd" "snd" (dynamic \(Typed (Tuple _ b)) -> Typed b :: A.a b: (Typed Expr (a, b)) -> Typed Expr b)
]
// Types
, DynamicConsGroup "Types"
[ functionConsDyn "Ty.Int" "Int"
(dynamic Typed (Ty VInt) :: Typed Ty Int)
<<@@@ applyHorizontalClasses
, DynamicCons
$ functionConsDyn "==" "=="
( dynamic \(Typed a) (Typed b) ->
Typed (Eq a b) ::
A.a:
(Typed Expr a) (Typed Expr a) -> Typed Expr Bool
)
, functionConsDyn "Ty.Bool" "Bool"
(dynamic Typed (Ty VBool) :: Typed Ty Bool)
<<@@@ applyHorizontalClasses
, DynamicCons $ customEditorCons "Int" "(enter integer)" intEditor <<@@@ HideIfOnlyChoice
, DynamicCons $ customEditorCons "Bool" "(enter boolean)" boolEditor <<@@@ HideIfOnlyChoice
, DynamicCons $ customEditorCons "String" "(enter string )" stringEditor <<@@@ HideIfOnlyChoice
// type specifications for enterInformation
, DynamicCons $ functionConsDyn "Ty.Int" "Int" (dynamic Typed (Ty VInt) :: Typed Ty Int)
, DynamicCons $ functionConsDyn "Ty.Bool" "Bool" (dynamic Typed (Ty VBool) :: Typed Ty Bool)
, DynamicCons $ functionConsDyn "Ty.String" "String" (dynamic Typed (Ty VString) :: Typed Ty String)
, DynamicCons
$ functionConsDyn "Ty.Tuple" "Tuple"
( dynamic \(Typed (Ty toValue1)) (Typed (Ty toValue2)) ->
Typed (Ty \(x, y) -> VTuple (toValue1 x) (toValue2 y)) ::
, functionConsDyn "Ty.String" "String"
(dynamic Typed (Ty VString) :: Typed Ty String)
<<@@@ applyHorizontalClasses
, functionConsDyn "Ty.Tuple" "Tuple"
( dynamic \(Typed (Ty toValue1)) (Typed (Ty toValue2)) -> Typed (Ty \(x, y) -> VTuple (toValue1 x) (toValue2 y)) ::
A.a b:
(Typed Ty a) (Typed Ty b) -> Typed Ty (a, b)
)
<<@@@ applyHorizontalClasses
]
// Helpers //
derivedType :: Typed Ty a | iTask a
derivedType = case dynToValue of
(toValue :: a^ -> Value | iTask a^) = Typed (Ty toValue)
// Internal helper editors
, DynamicConsGroup "Helpers"
[ customEditorCons "int" "(enter integer)" intEditor <<@@@ HideIfOnlyChoice
, customEditorCons "bool" "(enter boolean)" boolEditor <<@@@ HideIfOnlyChoice
, customEditorCons "string" "(enter string )" stringEditor <<@@@ HideIfOnlyChoice
]
]
where
dynToValue = dynamic ()
intEditor :: Editor Int
intEditor = gEditor{|*|}
intEditor :: Editor Int
intEditor = gEditor{|*|}
boolEditor :: Editor Bool
boolEditor = gEditor{|*|}
boolEditor :: Editor Bool
boolEditor = gEditor{|*|}
stringEditor :: Editor String
stringEditor = gEditor{|*|}
stringEditor :: Editor String
stringEditor = gEditor{|*|}
applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"]
applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"]
applyVerticalClasses = ApplyCssClasses ["itasks-vertical", "itasks-wrap-width", "itasks-panel"]
// Evaluation //////////////////////////////////////////////////////////////////
evalTaskConstExpr :: TaskExpr -> Task Value
evalTaskConstExpr (Done expr) = return $ evalExpr expr
evalTaskConstExpr (EnterInfo msg (Ty toValue)) = enterInformation msg [] @ toValue
// evalTaskConstExpr (Apply taskFunc expr) = evalTaskFuncExpr taskFunc $ evalExpr expr
evalTaskConstExpr (Then task taskFunc) = evalTaskConstExpr task >>= evalTaskFuncExpr taskFunc
evalTaskConstExpr (Or task1 task2) = (evalTaskConstExpr task1 -||- evalTaskConstExpr task2 <<@ ApplyLayout arrangeHorizontal)
evalTaskConstExpr (And task1 task2) = (evalTaskConstExpr task1 -&&- evalTaskConstExpr task2 <<@ ApplyLayout arrangeHorizontal) @ \(a, b) -> VTuple a b
evalTaskConstExpr (When task1 options) = evalTaskConstExpr task1
>>* [ OnAction (Action name) (ifValue (test pred) (evalTaskFuncExpr cont))
\\ {name, pred, cont} <- options
]
where
test pred (VInt i) = case pred of
LessV (VInt j) -> i < j
GrtV (VInt j) -> i > j
EqV (VInt j) -> i == j
test pred (VBool i) = case pred of
EqV (VBool j) -> i == j
LessV (VBool j) -> False
GrtV (VBool j) -> False
evalTaskFuncExpr :: TaskFuncExpr Value -> Task Value
evalTaskFuncExpr (ViewInfo p) (VInt i) = (viewInformation p [] i @ VInt) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (ViewInfo p) (VBool b) = (viewInformation p [] b @ VBool) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (ViewInfo p) (VString s) = (viewInformation p [] s @ VString) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (ViewInfo p) (VTuple a b) =
( viewInformation p [] ()
||- evalTaskFuncExpr (ViewInfo "") a
-&&- evalTaskFuncExpr (ViewInfo "") b
evalTaskExpr :: TaskExpr -> Task Value
evalTaskExpr (Done expr) = return $ evalExpr expr
evalTaskExpr (EnterInfo msg (Ty toValue)) = enterInformation msg [] @ toValue
evalTaskExpr (Then task taskFunc) = evalTaskExpr task >>= evalTaskFunc taskFunc
evalTaskExpr (Any task1 task2) = (evalTaskExpr task1 -||- evalTaskExpr task2) <<@ ApplyLayout arrangeHorizontal
evalTaskExpr (Both task1 task2) = (evalTaskExpr task1 -&&- evalTaskExpr task2) <<@ ApplyLayout arrangeHorizontal @ \(a, b) -> VTuple a b
// evalTaskExpr (When task1 options) = evalTaskExpr task1
// >>* [ OnAction (Action name) (ifValue (test pred) (evalTaskFunc cont))
// \\ {name, pred, cont} <- options
// ]
// where
// test pred (VInt i) = case pred of
// Lt (VInt j) -> i < j
// Gt (VInt j) -> i > j
// Eq (VInt j) -> i == j
// test pred (VBool i) = case pred of
// Eq (VBool j) -> i == j
// Lt (VBool j) -> False
// Gt (VBool j) -> False
evalTaskFunc :: TaskFunc Value -> Task Value
evalTaskFunc (ThenF this next) val = evalTaskFunc this val >>= evalTaskFunc next
evalTaskFunc (ViewF msg func) val = case evalFunc val func of
(VInt i) -> (viewInformation msg [] i @ VInt) <<@ ApplyLayout arrangeHorizontal
(VBool b) -> (viewInformation msg [] b @ VBool) <<@ ApplyLayout arrangeHorizontal
(VString s) -> (viewInformation msg [] s @ VString) <<@ ApplyLayout arrangeHorizontal
(VTuple a b) ->
( viewInformation msg [] ()
||- evalTaskFunc (ViewF "" Identity) a -&&- evalTaskFunc (ViewF "" Identity) b
@ \(a, b) -> VTuple a b
)
<<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (UpdateInfo p) (VInt i) = (updateInformation p [] i @ VInt) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (UpdateInfo p) (VBool b) = (updateInformation p [] b @ VBool) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (UpdateInfo p) (VString s) = (updateInformation p [] s @ VString) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (UpdateInfo p) (VTuple a b) =
( viewInformation p [] ()
||- evalTaskFuncExpr (UpdateInfo "") a
-&&- evalTaskFuncExpr (UpdateInfo "") b
evalTaskFunc (UpdateF msg) val = case val of
(VInt i) -> (updateInformation msg [] i @ VInt) <<@ ApplyLayout arrangeHorizontal
(VBool b) -> (updateInformation msg [] b @ VBool) <<@ ApplyLayout arrangeHorizontal
(VString s) -> (updateInformation msg [] s @ VString) <<@ ApplyLayout arrangeHorizontal
(VTuple a b) ->
( viewInformation msg [] ()
||- evalTaskFunc (UpdateF "") a
-&&- evalTaskFunc (UpdateF "") b
@ \(a, b) -> VTuple a b
)
<<@ ApplyLayout arrangeHorizontal
evalExpr :: Expr -> Value
evalExpr (Int i) = VInt i
evalExpr (Bool b) = VBool b
evalExpr (String s) = VString s
evalExpr (Tuple fstExpr sndExpr) = VTuple (evalExpr fstExpr) (evalExpr sndExpr)
evalExpr (Fst expr) = fst
evalExpr (Apply func expr) = evalFunc (evalExpr expr) func
evalFunc :: Value Func -> Value
evalFunc val Identity = val
evalFunc (VInt i1) func = case func of
(Gt expr) -> VBool $ i1 > evalInt expr
(Ge expr) -> VBool $ i1 >= evalInt expr
(Eq expr) -> VBool $ i1 == evalInt expr
(Le expr) -> VBool $ i1 <= evalInt expr
(Lt expr) -> VBool $ i1 < evalInt expr
(Add expr) -> VInt $ i1 + evalInt expr
(Sub expr) -> VInt $ i1 - evalInt expr
(Mul expr) -> VInt $ i1 * evalInt expr
(Div expr) -> VInt $ i1 / evalInt expr
where
(VTuple fst _) = evalExpr expr
evalExpr (Snd expr) = snd
evalInt :: Expr -> Int
evalInt expr = case evalExpr expr of
(VInt i) -> i
evalFunc (VBool b1) func = case func of
(Eq expr) -> VBool $ b1 == evalBool expr
(Conj expr) -> VBool $ b1 && evalBool expr
(Disj expr) -> VBool $ b1 || evalBool expr
(Not) -> VBool $ not b1
where
(VTuple _ snd) = evalExpr expr
evalExpr (Eq expr1 expr2) = VBool $ evalExpr expr1 === evalExpr expr2
evalBool :: Expr -> Bool
evalBool expr = case evalExpr expr of
(VBool b) -> b
evalFunc (VString s1) func = case func of
(Eq expr) -> VBool $ s1 == evalString expr
where
evalString :: Expr -> String
evalString expr = case evalExpr expr of
(VString s) -> s
evalFunc (VTuple x1 x2) func = case func of
Fst -> x1
Snd -> x2
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment