DynEditorExample.icl 13.3 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
import Data.Func
import Data.Functor
6
import Text
Tim Steenvoorden's avatar
Tim Steenvoorden committed
7 8
import iTasks
import iTasks.Extensions.Editors.DynamicEditor
9

Tim Steenvoorden's avatar
Tim Steenvoorden committed
10 11 12

// Synonyms ////////////////////////////////////////////////////////////////////

Tim Steenvoorden's avatar
Tim Steenvoorden committed
13
:: List a :== [a]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
14

Tim Steenvoorden's avatar
Tim Steenvoorden committed
15 16 17

// Main ////////////////////////////////////////////////////////////////////////

18 19
Start world = doTasks editTask world

Tim Steenvoorden's avatar
Tim Steenvoorden committed
20 21 22 23 24 25 26 27
editTask :: Task Value
editTask = forever $
  enterInformation ("Contruct a task", info1) [EnterUsing id $ dynamicEditor taskEditor]
    >>= \v ->
        viewInformation ("Evaluate the task", info2) [] ()
          ||- (evalTaskExpr (toValue taskEditor v) <<@ ApplyLayout frameCompact)
          >>= viewInformation ("Done!", info3) []
          >>= return  // Extra return to disable `Continue` button
Tim Steenvoorden's avatar
Tim Steenvoorden committed
28
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
29
  info1 :: String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
30
  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
31
  info2 :: String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
32
  info2 = "Now step through the task you just created to test it."
Tim Steenvoorden's avatar
Tim Steenvoorden committed
33
  info3 :: String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
34
  info3 = "The program is done, the result is given below."
35 36


Tim Steenvoorden's avatar
Tim Steenvoorden committed
37 38
// Data ////////////////////////////////////////////////////////////////////////

Tim Steenvoorden's avatar
Tim Steenvoorden committed
39
:: TaskExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
40
  = Done Expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
41
  | EnterInfo String Ty
Tim Steenvoorden's avatar
Tim Steenvoorden committed
42 43 44 45 46
  | Then TaskExpr TaskFunc
  | Both TaskExpr TaskExpr
  | Any TaskExpr TaskExpr
  | One TaskExpr TaskExpr
  // | Apply TaskFunc Expr
47

Tim Steenvoorden's avatar
Tim Steenvoorden committed
48
:: TaskFunc
Tim Steenvoorden's avatar
Tim Steenvoorden committed
49
  = ViewF String Func
Tim Steenvoorden's avatar
Tim Steenvoorden committed
50 51
  | UpdateF String
  | ThenF TaskFunc TaskFunc
Tim Steenvoorden's avatar
Tim Steenvoorden committed
52

Tim Steenvoorden's avatar
Tim Steenvoorden committed
53 54 55 56 57 58 59 60 61
:: Expr
  = Int Int
  | Bool Bool
  | String String
  | Tuple Expr Expr
  | Fst Expr
  | Snd Expr
  | Eq Expr Expr

Tim Steenvoorden's avatar
Tim Steenvoorden committed
62
:: Func
Tim Steenvoorden's avatar
Tim Steenvoorden committed
63
  = Identity
Tim Steenvoorden's avatar
Tim Steenvoorden committed
64 65
  | And Value
  | Or Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
66
  | GtF Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
67 68 69 70
  | GeF Value
  | EqF Value
  | LeF Value
  | LtF Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
71 72 73 74
  | Add Value
  | Sub Value
  | Mul Value
  | Div Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
75

Tim Steenvoorden's avatar
Tim Steenvoorden committed
76 77 78 79 80 81
:: Value
  = VInt Int
  | VBool Bool
  | VString String
  | VTuple Value Value

Tim Steenvoorden's avatar
Tim Steenvoorden committed
82 83 84 85 86
:: Ty
  = E.a: Ty (a -> Value) & iTask a

:: Typed a b
  =: Typed a
87

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

Tim Steenvoorden's avatar
Tim Steenvoorden committed
90 91
// 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
92 93 94 95 96 97 98
gDefault{|Ty|} = undef
gEq{|Ty|} _ _ = undef
JSONEncode{|Ty|} _ _ = undef
JSONDecode{|Ty|} _ _ = undef
gText{|Ty|} _ _ = undef
gEditor{|Ty|} = undef

99

Tim Steenvoorden's avatar
Tim Steenvoorden committed
100 101
// Editor //////////////////////////////////////////////////////////////////////

Tim Steenvoorden's avatar
Tim Steenvoorden committed
102
taskEditor :: DynamicEditor TaskExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 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
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)
          )
      , 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:
              String (Typed Ty a)
              -> Typed TaskExpr (Task a)
          )
          <<@@@ applyHorizontalClasses
      , functionConsDyn "ViewF" "view"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
182 183
          ( dynamic \s (Typed func) -> Typed (ViewF s func) ::
              A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
184
              String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
185 186
              (Typed Func (a -> b))
              -> Typed TaskFunc (a -> Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
          )
          <<@@@ 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)
          )
      // , functionConsDyn "Apply" "apply"
      //     ( dynamic \(Typed taskFunc) (Typed expr) ->
      //       Typed (Apply taskFunc expr) ::
      //         A.a b:
      //         (Typed TaskFunc (a -> Task b))
      //         (Typed Expr a)
      //         -> Typed TaskExpr (Task b)
      //     )
      ]
  // Non-task functions:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
214 215 216 217 218 219 220
  , DynamicConsGroup "Basics"
      [ functionConsDyn "Identity" "this value"
          (dynamic Typed Identity ::
            A.a:
            Typed Func (a -> a)
          )
      ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266
  , DynamicConsGroup "Comparison"
      [ functionConsDyn "GtF" "greater than"
          (dynamic \i -> Typed (GtF (VInt i)) :: Int -> Typed Func Int)
          <<@@@ applyHorizontalClasses
      , functionConsDyn "GeF" "greater or equal"
          (dynamic \i -> Typed (GeF (VInt i)) :: Int -> Typed Func Int)
          <<@@@ applyHorizontalClasses
      , functionConsDyn "EqF" "equal to"
          (dynamic \i -> Typed (EqF (VInt i)) :: Int -> Typed Func Int)
          <<@@@ applyHorizontalClasses
      , functionConsDyn "LeF" "lesser than"
          (dynamic \i -> Typed (LeF (VInt i)) :: Int -> Typed Func Int)
          <<@@@ applyHorizontalClasses
      , functionConsDyn "LtF" "lesser than"
          (dynamic \i -> Typed (LtF (VInt i)) :: Int -> Typed Func Int)
          <<@@@ 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
      , functionConsDyn "Fst" "fst" (dynamic \(Typed (Tuple a _)) -> Typed a ::  A.a b: (Typed Expr (a, b)) -> Typed Expr a)
          <<@@@ applyHorizontalClasses
      , functionConsDyn "Snd" "snd" (dynamic \(Typed (Tuple _ b)) -> Typed b ::  A.a b: (Typed Expr (a, b)) -> Typed Expr b)
          <<@@@ applyHorizontalClasses
      , functionConsDyn "Eq" "=="
          ( dynamic \(Typed a) (Typed b) ->
            Typed (Eq a b) ::
              A.a:
                (Typed Expr a) (Typed Expr a) -> Typed Expr Bool
          )
          <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
267
    ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289
  // Types
  , DynamicConsGroup "Types"
      [ functionConsDyn "Ty.Int" "Int"
          (dynamic Typed (Ty VInt) :: Typed Ty Int)
      , functionConsDyn "Ty.Bool" "Bool"
          (dynamic Typed (Ty VBool) :: Typed Ty Bool)
      , functionConsDyn "Ty.String" "String"
          (dynamic Typed (Ty VString) :: Typed Ty String)
      , 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
290
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
291 292
  intEditor :: Editor Int
  intEditor = gEditor{|*|}
Tim Steenvoorden's avatar
Tim Steenvoorden committed
293

Tim Steenvoorden's avatar
Tim Steenvoorden committed
294 295
  boolEditor :: Editor Bool
  boolEditor = gEditor{|*|}
Tim Steenvoorden's avatar
Tim Steenvoorden committed
296

Tim Steenvoorden's avatar
Tim Steenvoorden committed
297 298
  stringEditor :: Editor String
  stringEditor = gEditor{|*|}
299

Tim Steenvoorden's avatar
Tim Steenvoorden committed
300
  applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"]
301

Tim Steenvoorden's avatar
Tim Steenvoorden committed
302

Tim Steenvoorden's avatar
Tim Steenvoorden committed
303 304
// Evaluation //////////////////////////////////////////////////////////////////

Tim Steenvoorden's avatar
Tim Steenvoorden committed
305 306 307 308 309 310 311 312 313 314 315
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
316
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
317
  test pred (VInt i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
318 319 320
    LtF (VInt j) -> i < j
    GtF (VInt j) -> i > j
    EqF (VInt j) -> i == j
Tim Steenvoorden's avatar
Tim Steenvoorden committed
321
  test pred (VBool i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
322 323 324 325 326 327 328
    EqF (VBool j) -> i == j
    LtF (VBool j) -> False
    GtF (VBool j) -> False


evalTaskFunc :: TaskFunc Value -> Task Value
evalTaskFunc (ThenF this next) val = evalTaskFunc this val >>= evalTaskFunc next
Tim Steenvoorden's avatar
Tim Steenvoorden committed
329
evalTaskFunc (ViewF msg func) val = case evalFunc val func of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
330 331 332 333 334
  (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
335
      ||- evalTaskFunc (ViewF "" Identity) a -&&- evalTaskFunc (ViewF "" Identity) b
Tim Steenvoorden's avatar
Tim Steenvoorden committed
336 337 338 339 340 341 342 343 344 345 346 347 348 349 350
      @ \(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
351

352
evalExpr :: Expr -> Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
353 354 355
evalExpr (Int i) = VInt i
evalExpr (Bool b) = VBool b
evalExpr (String s) = VString s
356
evalExpr (Tuple fstExpr sndExpr) = VTuple (evalExpr fstExpr) (evalExpr sndExpr)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
357 358 359 360 361 362
evalExpr (Fst expr) = let (VTuple fst _) = evalExpr expr in fst
evalExpr (Snd expr) = let (VTuple _ snd) = evalExpr expr in snd
evalExpr (Eq expr1 expr2) = evalFunc (evalExpr expr1) (EqF (evalExpr expr2))


evalFunc :: Value Func -> Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
363
evalFunc val Identity = val
Tim Steenvoorden's avatar
Tim Steenvoorden committed
364 365 366 367 368 369 370 371 372 373
evalFunc (VInt i1) func = case func of
  (GtF (VInt i2)) -> VBool $ i1 > i2
  (GeF (VInt i2)) -> VBool $ i1 >= i2
  (EqF (VInt i2)) -> VBool $ i1 == i2
  (LeF (VInt i2)) -> VBool $ i1 <= i2
  (LtF (VInt i2)) -> VBool $ i1 < i2
evalFunc (VBool b1) func = case func of
  (EqF (VBool b2)) -> VBool $ b1 == b2
evalFunc (VString s1) func = case func of
  (EqF (VString s2)) -> VBool $ s1 == s2