DynEditorExample.icl 16.6 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
54
  | EnterInfo Ty String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
55 56 57
  | Then TaskExpr TaskFunc
  | Both TaskExpr TaskExpr
  | Any TaskExpr TaskExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
58
  | One Button TaskExpr Button TaskExpr
59

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

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

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

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

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

:: Typed a b
  =: Typed a
100

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

Tim Steenvoorden's avatar
Tim Steenvoorden committed
103 104
// 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
105 106 107 108 109 110 111
gDefault{|Ty|} = undef
gEq{|Ty|} _ _ = undef
JSONEncode{|Ty|} _ _ = undef
JSONDecode{|Ty|} _ _ = undef
gText{|Ty|} _ _ = undef
gEditor{|Ty|} = undef

112

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

Tim Steenvoorden's avatar
Tim Steenvoorden committed
115
taskEditor :: DynamicEditor TaskExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
116 117 118 119 120 121 122 123 124 125 126 127
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)
          )
Steffen Michels's avatar
Steffen Michels committed
128
          <<@@@ applyVerticalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
129 130 131 132 133 134
      , 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
      , 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))
          )
Steffen Michels's avatar
Steffen Michels committed
143
          <<@@@ applyVerticalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
144 145 146 147 148 149 150
      , 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)
          )
Steffen Michels's avatar
Steffen Michels committed
151
          <<@@@ applyVerticalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
152
      , functionConsDyn "One" "one of"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
153
          ( dynamic \button1 (Typed task1) button2 (Typed task2) -> Typed (One button1 task1 button2 task2) ::
Tim Steenvoorden's avatar
Tim Steenvoorden committed
154
              A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
155
              String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
156
              (Typed TaskExpr (Task a))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
157
              String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
158 159 160
              (Typed TaskExpr (Task a))
              -> Typed TaskExpr (Task a)
          )
Steffen Michels's avatar
Steffen Michels committed
161
          <<@@@ applyVerticalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
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 "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"
192
          ( dynamic \(Typed ty) s -> Typed (EnterInfo ty s) ::
Tim Steenvoorden's avatar
Tim Steenvoorden committed
193
              A.a:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
194
              (Typed Ty a)
195
              String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
196 197 198
              -> Typed TaskExpr (Task a)
          )
          <<@@@ applyHorizontalClasses
199
          <<@@@ AddLabels [Nothing, Just "message"]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
200
      , functionConsDyn "ViewF" "view"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
201 202
          ( dynamic \s (Typed func) -> Typed (ViewF s func) ::
              A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
203
              String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
204 205
              (Typed Func (a -> b))
              -> Typed TaskFunc (a -> Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222
          )
          <<@@@ 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
223
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
224 225
      ]
  // Non-task functions:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
226
  , DynamicConsGroup "Basics"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
227 228
      [ functionConsDyn "Identity" "this value"
          (dynamic Typed Identity :: A.a: Typed Func (a -> a))
Steffen Michels's avatar
Steffen Michels committed
229
          <<@@@ applyHorizontalClassesNoBorder
Tim Steenvoorden's avatar
Tim Steenvoorden committed
230 231 232 233 234 235 236
      , 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
237
          )
Tim Steenvoorden's avatar
Tim Steenvoorden committed
238
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
239 240
      , functionConsDyn "Fst" "fst"
          (dynamic Typed Fst :: A.a b: Typed Func ((a, b) -> a))
Steffen Michels's avatar
Steffen Michels committed
241
          <<@@@ applyHorizontalClassesNoBorder
Tim Steenvoorden's avatar
Tim Steenvoorden committed
242 243
      , functionConsDyn "Snd" "snd"
          (dynamic Typed Snd :: A.a b: Typed Func ((a, b) -> b))
Steffen Michels's avatar
Steffen Michels committed
244
          <<@@@ applyHorizontalClassesNoBorder
Tim Steenvoorden's avatar
Tim Steenvoorden committed
245
      ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
246
  , DynamicConsGroup "Arithmetic"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
247
      [ functionConsDyn "Add" "add"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
248
          (dynamic \(Typed i) -> Typed (Add i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
249
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
250 251
      , functionConsDyn "Sub" "sub"
          (dynamic \(Typed i) -> Typed (Sub i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
252
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
253 254
      , functionConsDyn "Mul" "mul"
          (dynamic \(Typed i) -> Typed (Mul i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
255
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
256 257
      , functionConsDyn "Div" "div"
          (dynamic \(Typed i) -> Typed (Div i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
258 259 260
          <<@@@ applyHorizontalClasses
      ]
  , DynamicConsGroup "Logic"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
261 262
      [ functionConsDyn "Conj" "and"
          (dynamic \(Typed b) -> Typed (Conj b) :: (Typed Expr Bool) -> Typed Func (Bool -> Bool))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
263
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
264 265
      , functionConsDyn "Disj" "or"
          (dynamic \(Typed b) -> Typed (Disj b) :: (Typed Expr Bool) -> Typed Func (Bool -> Bool))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
266
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
267 268
      , functionConsDyn "Not" "not"
          (dynamic Typed Not :: Typed Func (Bool -> Bool))
269
          <<@@@ applyHorizontalClassesNoBorder
Tim Steenvoorden's avatar
Tim Steenvoorden committed
270
      ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
271
  , DynamicConsGroup "Comparison"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
272 273
      [ functionConsDyn "Gt" "greater than"
          (dynamic \(Typed i) -> Typed (Gt i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
274
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
275 276
      , 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
277
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
278 279
      , functionConsDyn "Eq" "equal to"
          (dynamic \(Typed i) -> Typed (Eq i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
280
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
281 282
      , functionConsDyn "Le" "lesser than"
          (dynamic \(Typed i) -> Typed (Le i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
283
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
284 285
      , functionConsDyn "Lt" "lesser than"
          (dynamic \(Typed i) -> Typed (Lt i) :: (Typed Expr Int) -> Typed Func (Int -> Int))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
286 287 288 289 290 291
          <<@@@ applyHorizontalClasses
      ]
  // Non-task expressions:
  , DynamicConsGroup "Values"
      [ functionConsDyn "Int" "the integer"
          (dynamic \i -> Typed (Int i) :: Int -> Typed Expr Int)
Steffen Michels's avatar
Steffen Michels committed
292
          <<@@@ applyHorizontalClassesNoBorder
Tim Steenvoorden's avatar
Tim Steenvoorden committed
293 294
      , functionConsDyn "Bool" "the boolean"
          (dynamic \b -> Typed (Bool b) :: Bool -> Typed Expr Bool)
Steffen Michels's avatar
Steffen Michels committed
295
          <<@@@ applyHorizontalClassesNoBorder
Tim Steenvoorden's avatar
Tim Steenvoorden committed
296 297
      , functionConsDyn "String" "the string"
          (dynamic \s -> Typed (String s) :: String -> Typed Expr String)
Steffen Michels's avatar
Steffen Michels committed
298
          <<@@@ applyHorizontalClassesNoBorder
Tim Steenvoorden's avatar
Tim Steenvoorden committed
299 300 301 302 303 304 305
      , 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
306
    ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
307 308 309 310
  // Types
  , DynamicConsGroup "Types"
      [ functionConsDyn "Ty.Int" "Int"
          (dynamic Typed (Ty VInt) :: Typed Ty Int)
Steffen Michels's avatar
Steffen Michels committed
311
          <<@@@ applyHorizontalClassesNoBorder
Tim Steenvoorden's avatar
Tim Steenvoorden committed
312 313
      , functionConsDyn "Ty.Bool" "Bool"
          (dynamic Typed (Ty VBool) :: Typed Ty Bool)
Steffen Michels's avatar
Steffen Michels committed
314
          <<@@@ applyHorizontalClassesNoBorder
Tim Steenvoorden's avatar
Tim Steenvoorden committed
315 316
      , functionConsDyn "Ty.String" "String"
          (dynamic Typed (Ty VString) :: Typed Ty String)
Steffen Michels's avatar
Steffen Michels committed
317
          <<@@@ applyHorizontalClassesNoBorder
Tim Steenvoorden's avatar
Tim Steenvoorden committed
318 319 320 321 322 323 324 325 326 327 328 329 330 331
      , 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
332
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
333 334
  intEditor :: Editor Int
  intEditor = gEditor{|*|}
Tim Steenvoorden's avatar
Tim Steenvoorden committed
335

Tim Steenvoorden's avatar
Tim Steenvoorden committed
336 337
  boolEditor :: Editor Bool
  boolEditor = gEditor{|*|}
Tim Steenvoorden's avatar
Tim Steenvoorden committed
338

Tim Steenvoorden's avatar
Tim Steenvoorden committed
339 340
  stringEditor :: Editor String
  stringEditor = gEditor{|*|}
341

Steffen Michels's avatar
Steffen Michels committed
342 343 344
  applyHorizontalClasses         = ApplyCssClasses ["typedTaskEditor", "itasks-horizontal", "itasks-wrap-width", "itasks-wrap-height", "typedTaskEditorWithBorder"]
  applyHorizontalClassesNoBorder = ApplyCssClasses ["typedTaskEditor", "itasks-horizontal", "itasks-wrap-width", "itasks-wrap-height"]
  applyVerticalClasses           = ApplyCssClasses ["typedTaskEditor", "itasks-vertical", "itasks-wrap-width", "itasks-wrap-height", "typedTaskEditorWithBorder"]
345

Tim Steenvoorden's avatar
Tim Steenvoorden committed
346

Tim Steenvoorden's avatar
Tim Steenvoorden committed
347 348
// Evaluation //////////////////////////////////////////////////////////////////

Tim Steenvoorden's avatar
Tim Steenvoorden committed
349 350
evalTaskExpr :: TaskExpr -> Task Value
evalTaskExpr (Done expr) = return $ evalExpr expr
351
evalTaskExpr (EnterInfo (Ty toValue) msg) = enterInformation msg [] @ toValue
Tim Steenvoorden's avatar
Tim Steenvoorden committed
352
evalTaskExpr (Then task taskFunc) = evalTaskExpr task >>= evalTaskFunc taskFunc
Tim Steenvoorden's avatar
cleanup  
Tim Steenvoorden committed
353
evalTaskExpr (Both task1 task2) = (evalTaskExpr task1 -&&- evalTaskExpr task2) <<@ ApplyLayout arrangeHorizontal @ \(a, b) -> VTuple a b
Tim Steenvoorden's avatar
Tim Steenvoorden committed
354 355 356 357 358 359 360 361 362 363 364
evalTaskExpr (Any task1 task2) = (evalTaskExpr task1 -||- evalTaskExpr task2) <<@ ApplyLayout arrangeHorizontal
evalTaskExpr (One button1 task1 button2 task2)
= viewInformation "Make a choice" [] () >>*
  [ OnAction (Action button1) (ifValue (const True) (\_ -> evalTaskExpr task1))
  , OnAction (Action button2) (ifValue (const True) (\_ -> evalTaskExpr task2))
  ]
evalTaskExpr x = abort $ "My brain hurts!" +++ unlines (gText{|*|} AsMultiLine (Just x))
where
  unlines :: [String] -> String
  unlines xs = foldr (\x acc -> x +++ "\n" +++ acc) "" xs

Tim Steenvoorden's avatar
Tim Steenvoorden committed
365 366 367 368
// evalTaskExpr (When task1 options) = evalTaskExpr task1
//   >>* [ OnAction (Action name) (ifValue (test pred) (evalTaskFunc cont))
//       \\ {name, pred, cont} <- options
//       ]
Tim Steenvoorden's avatar
cleanup  
Tim Steenvoorden committed
369 370 371 372 373 374 375 376 377
// 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
Tim Steenvoorden's avatar
Tim Steenvoorden committed
378 379 380 381


evalTaskFunc :: TaskFunc Value -> Task Value
evalTaskFunc (ThenF this next) val = evalTaskFunc this val >>= evalTaskFunc next
Tim Steenvoorden's avatar
cleanup  
Tim Steenvoorden committed
382

Tim Steenvoorden's avatar
Tim Steenvoorden committed
383
evalTaskFunc (ViewF msg func) val = case evalFunc val func of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
384 385 386 387 388
  (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
389
      ||- evalTaskFunc (ViewF "" Identity) a -&&- evalTaskFunc (ViewF "" Identity) b
Tim Steenvoorden's avatar
Tim Steenvoorden committed
390 391 392
      @ \(a, b) -> VTuple a b
    )
      <<@ ApplyLayout arrangeHorizontal
Tim Steenvoorden's avatar
cleanup  
Tim Steenvoorden committed
393

Tim Steenvoorden's avatar
Tim Steenvoorden committed
394 395 396 397 398 399 400 401 402 403 404 405
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
406

407
evalExpr :: Expr -> Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
408 409 410
evalExpr (Int i) = VInt i
evalExpr (Bool b) = VBool b
evalExpr (String s) = VString s
411
evalExpr (Tuple fstExpr sndExpr) = VTuple (evalExpr fstExpr) (evalExpr sndExpr)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
412
evalExpr (Apply func expr) = evalFunc (evalExpr expr) func
Tim Steenvoorden's avatar
Tim Steenvoorden committed
413 414 415


evalFunc :: Value Func -> Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
416
evalFunc val Identity = val
Tim Steenvoorden's avatar
Tim Steenvoorden committed
417

Tim Steenvoorden's avatar
Tim Steenvoorden committed
418
evalFunc (VInt i1) func = case func of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
419 420 421 422 423 424 425 426 427
  (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
428 429 430 431 432
where
  evalInt :: Expr -> Int
  evalInt expr = case evalExpr expr of
    (VInt i) -> i

Tim Steenvoorden's avatar
Tim Steenvoorden committed
433
evalFunc (VBool b1) func = case func of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
434 435 436 437
  (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
438 439 440 441 442
where
  evalBool :: Expr -> Bool
  evalBool expr = case evalExpr expr of
    (VBool b) -> b

Tim Steenvoorden's avatar
Tim Steenvoorden committed
443
evalFunc (VString s1) func = case func of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
444
  (Eq expr) -> VBool $ s1 == evalString expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
445 446 447 448
where
  evalString :: Expr -> String
  evalString expr = case evalExpr expr of
    (VString s) -> s
Tim Steenvoorden's avatar
Tim Steenvoorden committed
449 450 451 452

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