DynEditorExample.icl 15.7 KB
Newer Older
1 2
module DynEditorExample

Steffen Michels's avatar
Steffen Michels committed
3
import StdEnv
Tim Steenvoorden's avatar
Tim Steenvoorden committed
4 5 6 7
import Data.Func
import Data.Functor
import iTasks
import iTasks.Extensions.Editors.DynamicEditor
8

Tim Steenvoorden's avatar
Tim Steenvoorden committed
9

10
// Helpers /////////////////////////////////////////////////////////////////////
Tim Steenvoorden's avatar
Tim Steenvoorden committed
11

Tim Steenvoorden's avatar
Tim Steenvoorden committed
12
:: List a :== [a]
13 14
:: Message :== String
:: Button :== String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
15

16
always x :== const True x
Tim Steenvoorden's avatar
Tim Steenvoorden committed
17

18 19 20 21
(>?>) infixl 1 :: (Task a) (List ( Button, a -> Bool, a -> Task b )) -> Task b | iTask a & iTask b
(>?>) task options = task >>* map trans options
where
  trans ( a, p, t ) = OnAction (Action a) (ifValue p t)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
22

23

24 25 26 27 28 29 30 31 32 33 34 35 36 37
// Main ////////////////////////////////////////////////////////////////////////

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) [] () ||- (evalTaskExpr (toValue taskEditor v) <<@ ApplyLayout frameCompact) >?>
        [ ( "Finish", always, \r -> viewInformation ("Done!", info3) [] r >?>
            [ ( "Back", always, \_ -> editTaskExpr (Just v) ) ]
          )
        ]
      )
    ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
38
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
39
  info1 :: String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
40
  info1 = "Select the editors and combinators you'd like to use. When you're ready, push the 'Continue' button below to run your program."
Tim Steenvoorden's avatar
Tim Steenvoorden committed
41
  info2 :: String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
42
  info2 = "Now step through the task you just created to test it."
Tim Steenvoorden's avatar
Tim Steenvoorden committed
43
  info3 :: String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
44
  info3 = "The program is done, the result is given below."
45

46
  enterOrUpdateExpr msg Nothing = enterInformation msg [EnterUsing id $ dynamicEditor taskEditor]
47
  enterOrUpdateExpr msg (Just v) = updateInformation msg [UpdateUsing id (curry snd) (dynamicEditor taskEditor)] v
48

49

Tim Steenvoorden's avatar
Tim Steenvoorden committed
50 51
// Data ////////////////////////////////////////////////////////////////////////

Tim Steenvoorden's avatar
Tim Steenvoorden committed
52
:: TaskExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
53
  = Done Expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
54
  | EnterInfo String Ty
Tim Steenvoorden's avatar
Tim Steenvoorden committed
55 56 57 58 59
  | Then TaskExpr TaskFunc
  | Both TaskExpr TaskExpr
  | Any TaskExpr TaskExpr
  | One TaskExpr TaskExpr
  // | Apply TaskFunc Expr
60

Tim Steenvoorden's avatar
Tim Steenvoorden committed
61
:: TaskFunc
Tim Steenvoorden's avatar
Tim Steenvoorden committed
62
  = ViewF String Func
Tim Steenvoorden's avatar
Tim Steenvoorden committed
63 64
  | UpdateF String
  | ThenF TaskFunc TaskFunc
Tim Steenvoorden's avatar
Tim Steenvoorden committed
65

Tim Steenvoorden's avatar
Tim Steenvoorden committed
66 67 68 69 70
:: Expr
  = Int Int
  | Bool Bool
  | String String
  | Tuple Expr Expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
71
  | Apply Func Expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
72

Tim Steenvoorden's avatar
Tim Steenvoorden committed
73
:: Func
Tim Steenvoorden's avatar
Tim Steenvoorden committed
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
  = 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
Tim Steenvoorden's avatar
Tim Steenvoorden committed
89

Tim Steenvoorden's avatar
Tim Steenvoorden committed
90 91 92 93 94 95
:: Value
  = VInt Int
  | VBool Bool
  | VString String
  | VTuple Value Value

Tim Steenvoorden's avatar
Tim Steenvoorden committed
96 97 98 99 100
:: Ty
  = E.a: Ty (a -> Value) & iTask a

:: Typed a b
  =: Typed a
101

Tim Steenvoorden's avatar
Tim Steenvoorden committed
102
derive class iTask TaskExpr, TaskFunc, Expr, Func, Value, Typed
103

Tim Steenvoorden's avatar
Tim Steenvoorden committed
104 105
// These instances cannot be auto derived because of the existential quantifier.
// However, they will be never used, so we make them undefined.
Tim Steenvoorden's avatar
Tim Steenvoorden committed
106 107 108 109 110 111 112
gDefault{|Ty|} = undef
gEq{|Ty|} _ _ = undef
JSONEncode{|Ty|} _ _ = undef
JSONDecode{|Ty|} _ _ = undef
gText{|Ty|} _ _ = undef
gEditor{|Ty|} = undef

113

Tim Steenvoorden's avatar
Tim Steenvoorden committed
114 115
// Editor //////////////////////////////////////////////////////////////////////

Tim Steenvoorden's avatar
Tim Steenvoorden committed
116
taskEditor :: DynamicEditor TaskExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
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 "Then" "sequence"
          ( dynamic \(Typed task) (Typed taskFunc) -> Typed (Then task taskFunc) ::
              A.a b:
              (Typed TaskExpr (Task a)) (Typed TaskFunc (a -> Task b))
              -> Typed TaskExpr (Task b)
          )
      , 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)
          )
Tim Steenvoorden's avatar
Tim Steenvoorden committed
135
          <<@@@ applyVerticalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
      , functionConsDyn "Both" "both"
          ( dynamic \(Typed task1) (Typed task2) -> Typed (Both task1 task2) ::
              A.a b:
              (Typed TaskExpr (Task a))
              (Typed TaskExpr (Task b))
              -> Typed TaskExpr (Task (a, b))
          )
          <<@@@ applyHorizontalClasses
      , 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 "One" "one of"
          ( dynamic \(Typed task1) (Typed task2) -> Typed (One task1 task2) ::
              A.a b:
              (Typed TaskExpr (Task a))
              (Typed TaskExpr (Task a))
              -> Typed TaskExpr (Task a)
          )
          <<@@@ applyHorizontalClasses
      // , 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 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)
      //     )
      //     <<@@@ 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:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
192 193
              String
              (Typed Ty a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
194 195 196 197
              -> Typed TaskExpr (Task a)
          )
          <<@@@ applyHorizontalClasses
      , functionConsDyn "ViewF" "view"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
198 199
          ( dynamic \s (Typed func) -> Typed (ViewF s func) ::
              A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
200
              String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
201 202
              (Typed Func (a -> b))
              -> Typed TaskFunc (a -> Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219
          )
          <<@@@ applyHorizontalClasses
      , functionConsDyn "UpdateF" "update"
          ( dynamic \s -> Typed (UpdateF s) ::
              A.a:
              String
              -> 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)
          )
Tim Steenvoorden's avatar
Tim Steenvoorden committed
220
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
221 222
      ]
  // Non-task functions:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
223
  , DynamicConsGroup "Basics"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
224 225 226 227 228 229 230 231 232
      [ 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
Tim Steenvoorden's avatar
Tim Steenvoorden committed
233
          )
Tim Steenvoorden's avatar
Tim Steenvoorden committed
234
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
235 236 237 238 239 240
      , 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
Tim Steenvoorden's avatar
Tim Steenvoorden committed
241
      ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
242
  , DynamicConsGroup "Arithmetic"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
243 244
      [ functionConsDyn "Add" "add"
          (dynamic \(Typed i) -> Typed (Add i) :: (Typed Expr Int) -> Typed Func (Int -> Int)) //XXX (Typed Expr Int) -> Typed Func (Int -> Int)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
245
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
246 247
      , functionConsDyn "Sub" "sub"
          (dynamic \(Typed i) -> Typed (Sub i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
248
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
249 250
      , functionConsDyn "Mul" "mul"
          (dynamic \(Typed i) -> Typed (Mul i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
251
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
252 253
      , functionConsDyn "Div" "div"
          (dynamic \(Typed i) -> Typed (Div i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
254 255 256
          <<@@@ applyHorizontalClasses
      ]
  , DynamicConsGroup "Logic"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
257 258
      [ functionConsDyn "Conj" "and"
          (dynamic \(Typed b) -> Typed (Conj b) :: (Typed Expr Bool) -> Typed Func (Bool -> Bool))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
259
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
260 261
      , functionConsDyn "Disj" "or"
          (dynamic \(Typed b) -> Typed (Disj b) :: (Typed Expr Bool) -> Typed Func (Bool -> Bool))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
262
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
263 264
      , functionConsDyn "Not" "not"
          (dynamic Typed Not :: Typed Func (Bool -> Bool))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
265 266
          <<@@@ applyHorizontalClasses
      ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
267
  , DynamicConsGroup "Comparison"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
268 269
      [ functionConsDyn "Gt" "greater than"
          (dynamic \(Typed i) -> Typed (Gt i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
270
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
271 272
      , functionConsDyn "Ge" "greater or equal"
          (dynamic \(Typed i) -> Typed (Ge i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
273
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
274 275
      , functionConsDyn "Eq" "equal to"
          (dynamic \(Typed i) -> Typed (Eq i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
276
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
277 278
      , functionConsDyn "Le" "lesser than"
          (dynamic \(Typed i) -> Typed (Le i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
279
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
280 281
      , functionConsDyn "Lt" "lesser than"
          (dynamic \(Typed i) -> Typed (Lt i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301
          <<@@@ applyHorizontalClasses
      ]
  // Non-task expressions:
  , DynamicConsGroup "Values"
      [ functionConsDyn "Int" "the integer"
          (dynamic \i -> Typed (Int i) :: Int -> Typed Expr Int)
          <<@@@ applyHorizontalClasses
      , functionConsDyn "Bool" "the boolean"
          (dynamic \b -> Typed (Bool b) :: Bool -> Typed Expr Bool)
          <<@@@ applyHorizontalClasses
      , functionConsDyn "String" "the string"
          (dynamic \s -> Typed (String s) :: String -> Typed Expr String)
          <<@@@ applyHorizontalClasses
      , 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)
          )
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
302
    ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
303 304 305 306
  // Types
  , DynamicConsGroup "Types"
      [ functionConsDyn "Ty.Int" "Int"
          (dynamic Typed (Ty VInt) :: Typed Ty Int)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
307
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
308 309
      , functionConsDyn "Ty.Bool" "Bool"
          (dynamic Typed (Ty VBool) :: Typed Ty Bool)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
310
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
311 312
      , functionConsDyn "Ty.String" "String"
          (dynamic Typed (Ty VString) :: Typed Ty String)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
313
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
314 315 316 317 318 319 320 321 322 323 324 325 326 327
      , 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
      ]
  // Internal helper editors
  , DynamicConsGroup "Helpers"
    [ customEditorCons "int" "(enter integer)" intEditor <<@@@ HideIfOnlyChoice
    , customEditorCons "bool" "(enter boolean)" boolEditor <<@@@ HideIfOnlyChoice
    , customEditorCons "string" "(enter string )" stringEditor <<@@@ HideIfOnlyChoice
    ]
  ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
328
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
329 330
  intEditor :: Editor Int
  intEditor = gEditor{|*|}
Tim Steenvoorden's avatar
Tim Steenvoorden committed
331

Tim Steenvoorden's avatar
Tim Steenvoorden committed
332 333
  boolEditor :: Editor Bool
  boolEditor = gEditor{|*|}
Tim Steenvoorden's avatar
Tim Steenvoorden committed
334

Tim Steenvoorden's avatar
Tim Steenvoorden committed
335 336
  stringEditor :: Editor String
  stringEditor = gEditor{|*|}
337

Tim Steenvoorden's avatar
Tim Steenvoorden committed
338
  applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
339
  applyVerticalClasses = ApplyCssClasses ["itasks-vertical", "itasks-wrap-width", "itasks-panel"]
340

Tim Steenvoorden's avatar
Tim Steenvoorden committed
341

Tim Steenvoorden's avatar
Tim Steenvoorden committed
342 343
// Evaluation //////////////////////////////////////////////////////////////////

Tim Steenvoorden's avatar
Tim Steenvoorden committed
344 345 346 347 348 349 350 351 352 353 354
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 (Apply taskFunc expr) = evalTaskFunc taskFunc $ evalExpr expr
// evalTaskExpr (When task1 options) = evalTaskExpr task1
//   >>* [ OnAction (Action name) (ifValue (test pred) (evalTaskFunc cont))
//       \\ {name, pred, cont} <- options
//       ]
Steffen Michels's avatar
Steffen Michels committed
355
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
356
  test pred (VInt i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
357 358 359
    Lt (VInt j) -> i < j
    Gt (VInt j) -> i > j
    Eq (VInt j) -> i == j
Tim Steenvoorden's avatar
Tim Steenvoorden committed
360
  test pred (VBool i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
361 362 363
    Eq (VBool j) -> i == j
    Lt (VBool j) -> False
    Gt (VBool j) -> False
Tim Steenvoorden's avatar
Tim Steenvoorden committed
364 365 366 367


evalTaskFunc :: TaskFunc Value -> Task Value
evalTaskFunc (ThenF this next) val = evalTaskFunc this val >>= evalTaskFunc next
Tim Steenvoorden's avatar
Tim Steenvoorden committed
368
evalTaskFunc (ViewF msg func) val = case evalFunc val func of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
369 370 371 372 373
  (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 [] ()
Tim Steenvoorden's avatar
Tim Steenvoorden committed
374
      ||- evalTaskFunc (ViewF "" Identity) a -&&- evalTaskFunc (ViewF "" Identity) b
Tim Steenvoorden's avatar
Tim Steenvoorden committed
375 376 377 378 379 380 381 382 383 384 385 386 387 388 389
      @ \(a, b) -> VTuple a b
    )
      <<@ ApplyLayout arrangeHorizontal
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

Tim Steenvoorden's avatar
Tim Steenvoorden committed
390

391
evalExpr :: Expr -> Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
392 393 394
evalExpr (Int i) = VInt i
evalExpr (Bool b) = VBool b
evalExpr (String s) = VString s
395
evalExpr (Tuple fstExpr sndExpr) = VTuple (evalExpr fstExpr) (evalExpr sndExpr)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
396
evalExpr (Apply func expr) = evalFunc (evalExpr expr) func
Tim Steenvoorden's avatar
Tim Steenvoorden committed
397 398 399


evalFunc :: Value Func -> Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
400
evalFunc val Identity = val
Tim Steenvoorden's avatar
Tim Steenvoorden committed
401

Tim Steenvoorden's avatar
Tim Steenvoorden committed
402
evalFunc (VInt i1) func = case func of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
403 404 405 406 407 408 409 410 411
  (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
Tim Steenvoorden's avatar
Tim Steenvoorden committed
412 413 414 415 416
where
  evalInt :: Expr -> Int
  evalInt expr = case evalExpr expr of
    (VInt i) -> i

Tim Steenvoorden's avatar
Tim Steenvoorden committed
417
evalFunc (VBool b1) func = case func of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
418 419 420 421
  (Eq expr) -> VBool $ b1 == evalBool expr
  (Conj expr) -> VBool $ b1 && evalBool expr
  (Disj expr) -> VBool $ b1 || evalBool expr
  (Not) -> VBool $ not b1
Tim Steenvoorden's avatar
Tim Steenvoorden committed
422 423 424 425 426
where
  evalBool :: Expr -> Bool
  evalBool expr = case evalExpr expr of
    (VBool b) -> b

Tim Steenvoorden's avatar
Tim Steenvoorden committed
427
evalFunc (VString s1) func = case func of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
428
  (Eq expr) -> VBool $ s1 == evalString expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
429 430 431 432
where
  evalString :: Expr -> String
  evalString expr = case evalExpr expr of
    (VString s) -> s
Tim Steenvoorden's avatar
Tim Steenvoorden committed
433 434 435 436

evalFunc (VTuple x1 x2) func = case func of
  Fst -> x1
  Snd -> x2