DynEditorExample.icl 11.4 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
editTask =
  forever
Tim Steenvoorden's avatar
Tim Steenvoorden committed
22
    ( enterInformation ("Contruct a task", info) [EnterUsing id $ dynamicEditor taskEditor]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
23
      >>= \v ->
Tim Steenvoorden's avatar
Tim Steenvoorden committed
24 25 26
          viewInformation ("Evaluate the task", "") [] ()
            ||- (evalTaskConstExpr (toValue taskEditor v) <<@ ApplyLayout frameCompact)
            >>= viewInformation ("Done!", "") []
Tim Steenvoorden's avatar
Tim Steenvoorden committed
27
            >>= return
Tim Steenvoorden's avatar
Tim Steenvoorden committed
28 29 30
    )
where
  info = "Select the editors and combinators you'd like to use. When you're ready, push the 'Continue' button below to run your program."
31 32


Tim Steenvoorden's avatar
Tim Steenvoorden committed
33 34
// Data ////////////////////////////////////////////////////////////////////////

Tim Steenvoorden's avatar
Tim Steenvoorden committed
35
:: TaskExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
36
  = Apply TaskFuncExpr Expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
37
  | EnterInfo String Ty
Tim Steenvoorden's avatar
Tim Steenvoorden committed
38 39 40 41
  | Then TaskExpr TaskFuncExpr
  | Or TaskExpr TaskExpr
  | And TaskExpr TaskExpr
  | When TaskExpr (List TaskContExpr)
42

Tim Steenvoorden's avatar
Tim Steenvoorden committed
43
:: TaskFuncExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
44 45
  = ViewInfo String
  | UpdateInfo String
46

Tim Steenvoorden's avatar
Tim Steenvoorden committed
47 48 49
:: TaskContExpr
  = { name :: String, pred :: FuncExpr, cont :: TaskFuncExpr}

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

:: Value
  = VInt Int
  | VBool Bool
  | VString String
  | VTuple Value Value

Tim Steenvoorden's avatar
Tim Steenvoorden committed
65
:: FuncExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
66 67 68 69 70 71 72 73 74
  = EqV Value
  | GrtV Value
  | LessV Value

:: Ty
  = E.a: Ty (a -> Value) & iTask a

:: Typed a b
  =: Typed a
75

Tim Steenvoorden's avatar
Tim Steenvoorden committed
76
derive class iTask TaskExpr, TaskFuncExpr, TaskContExpr, Expr, FuncExpr, Value, Typed
77

Tim Steenvoorden's avatar
Tim Steenvoorden committed
78 79
// 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
80 81 82 83 84 85 86
gDefault{|Ty|} = undef
gEq{|Ty|} _ _ = undef
JSONEncode{|Ty|} _ _ = undef
JSONDecode{|Ty|} _ _ = undef
gText{|Ty|} _ _ = undef
gEditor{|Ty|} = undef

87

Tim Steenvoorden's avatar
Tim Steenvoorden committed
88 89
// Editor //////////////////////////////////////////////////////////////////////

Tim Steenvoorden's avatar
Tim Steenvoorden committed
90
taskEditor :: DynamicEditor TaskExpr
91 92
taskEditor = DynamicEditor conses
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
93
  conses =
Tim Steenvoorden's avatar
Tim Steenvoorden committed
94
    [ // This cons is used to provide untyped `TaskExpr` values.
Tim Steenvoorden's avatar
Tim Steenvoorden committed
95
      DynamicCons
Tim Steenvoorden's avatar
Tim Steenvoorden committed
96
        $ functionConsDyn "TaskExpr" "(enter task)" (dynamic \(Typed taskExpr) -> taskExpr ::  A.a: (Typed TaskExpr a) -> TaskExpr)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
97
        <<@@@ HideIfOnlyChoice
Tim Steenvoorden's avatar
Tim Steenvoorden committed
98
    , DynamicConsGroup "Combinators"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
99
        [ functionConsDyn "Then" "sequence"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
100
            ( dynamic \(Typed task) (Typed taskFunc) ->
Tim Steenvoorden's avatar
Tim Steenvoorden committed
101
              Typed (Then task taskFunc) ::
Tim Steenvoorden's avatar
Tim Steenvoorden committed
102
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
103 104
                (Typed TaskExpr (Task a)) (Typed TaskFuncExpr (a -> Task b))
                -> Typed TaskExpr (Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
105
            )
Tim Steenvoorden's avatar
Tim Steenvoorden committed
106 107
        , functionConsDyn "When" "when"
            ( dynamic \(Typed task1) (Typed steps) ->
108 109
              Typed (When task1 steps) ::
              // Typed (When task1 [(expr, pred, tfExpr) \\ (Typed expr, pred, Typed tfExpr) <- steps]) ::
Tim Steenvoorden's avatar
Tim Steenvoorden committed
110
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
111 112 113 114
                (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)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
115
            )
Tim Steenvoorden's avatar
Tim Steenvoorden committed
116 117
            <<@@@ applyHorizontalClasses
        , functionConsDyn "Or" "or"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
118 119 120
            ( dynamic \(Typed task1) (Typed task2) ->
              Typed (Or task1 task2) ::
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
121 122
                (Typed TaskExpr (Task a)) (Typed TaskExpr (Task a))
                -> Typed TaskExpr (Task a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
123
            )
Tim Steenvoorden's avatar
Tim Steenvoorden committed
124
        , functionConsDyn "And" "and"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
125 126 127
            ( dynamic \(Typed task1) (Typed task2) ->
              Typed (And task1 task2) ::
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
128 129
                (Typed TaskExpr (Task a)) (Typed TaskExpr (Task b))
                -> Typed TaskExpr (Task (a, b))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
130
            )
Tim Steenvoorden's avatar
Tim Steenvoorden committed
131
        , listConsDyn "List TaskContExpr" "continuations"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
132 133 134
            ( dynamic \typedSteps ->
              Typed ((\(Typed expr) -> expr) <$> typedSteps) ::
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
135
                (List (Typed TaskContExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
136
                (a -> Task b)))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
137
                -> Typed (List TaskContExpr) (a -> Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
138 139
            )
            <<@@@ HideIfOnlyChoice
Tim Steenvoorden's avatar
Tim Steenvoorden committed
140 141 142
        , functionConsDyn "TaskContExpr" "continuation"
            ( dynamic \s (Typed func) (Typed taskFunc) ->
              Typed {name = s, pred = func, cont = taskFunc} ::
Tim Steenvoorden's avatar
Tim Steenvoorden committed
143
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
144
                String
Tim Steenvoorden's avatar
Tim Steenvoorden committed
145
                (Typed FuncExpr a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
146
                (Typed TaskFuncExpr (a -> Task b))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
147
                -> Typed TaskContExpr (a -> Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
148 149 150
            )
            <<@@@ HideIfOnlyChoice
        ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
151
    , DynamicConsGroup "Editors"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
152 153 154 155
        [ functionConsDyn "Apply" "apply"
            ( dynamic \(Typed taskFunc) (Typed expr) ->
              Typed (Apply taskFunc expr) ::
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
156 157
                (Typed TaskFuncExpr (a -> Task b))
                (Typed Expr a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
158
                -> Typed TaskExpr (Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
159
            )
Tim Steenvoorden's avatar
Tim Steenvoorden committed
160
        , functionConsDyn "EnterInfo" "enter information"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
161
            ( dynamic \s (Typed ty) ->
Tim Steenvoorden's avatar
Tim Steenvoorden committed
162
              Typed (EnterInfo s ty) ::
Tim Steenvoorden's avatar
Tim Steenvoorden committed
163
                A.a:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
164
                String (Typed Ty a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
165
                -> Typed TaskExpr (Task a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
166 167
            )
            <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
168
        , functionConsDyn "ViewInfo" "view information"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
169
            ( dynamic \s ->
Tim Steenvoorden's avatar
Tim Steenvoorden committed
170
              Typed (ViewInfo s) ::
Tim Steenvoorden's avatar
Tim Steenvoorden committed
171
                A.a:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
172 173
                String
                -> Typed TaskFuncExpr (a -> Task a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
174 175
            )
            <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
176
        , functionConsDyn "UpdateInfo" "update information"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
177
            ( dynamic \s ->
Tim Steenvoorden's avatar
Tim Steenvoorden committed
178
              Typed (UpdateInfo s) ::
Tim Steenvoorden's avatar
Tim Steenvoorden committed
179
                A.a:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
180 181
                String
                -> Typed TaskFuncExpr (a -> Task a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
182 183 184
            )
            <<@@@ applyHorizontalClasses
        ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
185
    // ordinary (non-task) expressions
Tim Steenvoorden's avatar
Tim Steenvoorden committed
186
    , DynamicCons
Tim Steenvoorden's avatar
Tim Steenvoorden committed
187
        $ functionConsDyn "EqV" "equal" (dynamic \i -> Typed (EqV (VInt i)) :: Int -> Typed FuncExpr Int)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
188 189
        <<@@@ applyHorizontalClasses
    , DynamicCons
Tim Steenvoorden's avatar
Tim Steenvoorden committed
190
        $ functionConsDyn "GrtV" "greater" (dynamic \i -> Typed (GrtV (VInt i)) :: Int -> Typed FuncExpr Int)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
191 192
        <<@@@ applyHorizontalClasses
    , DynamicCons
Tim Steenvoorden's avatar
Tim Steenvoorden committed
193
        $ functionConsDyn "LessV" "less" (dynamic \i -> Typed (LessV (VInt i)) :: Int -> Typed FuncExpr Int)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224
        <<@@@ 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:"
            ( 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)
        <<@@@ applyHorizontalClasses
    , DynamicCons
        $ functionConsDyn "==" "=="
            ( dynamic \(Typed a) (Typed b) ->
              Typed (Eq a b) ::
                A.a:
                  (Typed Expr a) (Typed Expr a) -> Typed Expr Bool
            )
        <<@@@ applyHorizontalClasses
    , DynamicCons $ customEditorCons "Int" "(enter integer)" intEditor <<@@@ HideIfOnlyChoice
    , DynamicCons $ customEditorCons "Bool" "(enter boolean)" boolEditor <<@@@ HideIfOnlyChoice
    , DynamicCons $ customEditorCons "String" "(enter string )" stringEditor <<@@@ HideIfOnlyChoice
Tim Steenvoorden's avatar
Tim Steenvoorden committed
225
    // type specifications for enterInformation
Tim Steenvoorden's avatar
Tim Steenvoorden committed
226 227 228 229 230 231 232 233 234 235 236
    , 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)) ::
                A.a b:
                  (Typed Ty a) (Typed Ty b) -> Typed Ty (a, b)
            )
        <<@@@ applyHorizontalClasses
Tim Steenvoorden's avatar
Tim Steenvoorden committed
237 238 239
    ]


Tim Steenvoorden's avatar
Tim Steenvoorden committed
240 241
// Helpers //

Tim Steenvoorden's avatar
Tim Steenvoorden committed
242 243 244 245 246 247
derivedType :: Typed Ty a | iTask a
derivedType = case dynToValue of
  (toValue :: a^ -> Value | iTask a^) = Typed (Ty toValue)
where
  dynToValue = dynamic ()

Tim Steenvoorden's avatar
Tim Steenvoorden committed
248

Tim Steenvoorden's avatar
Tim Steenvoorden committed
249 250
intEditor :: Editor Int
intEditor = gEditor{|*|}
Tim Steenvoorden's avatar
Tim Steenvoorden committed
251

Tim Steenvoorden's avatar
Tim Steenvoorden committed
252 253
boolEditor :: Editor Bool
boolEditor = gEditor{|*|}
254

Tim Steenvoorden's avatar
Tim Steenvoorden committed
255 256
stringEditor :: Editor String
stringEditor = gEditor{|*|}
257

258 259
applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"]

Tim Steenvoorden's avatar
Tim Steenvoorden committed
260

Tim Steenvoorden's avatar
Tim Steenvoorden committed
261 262
// Evaluation //////////////////////////////////////////////////////////////////

Tim Steenvoorden's avatar
Tim Steenvoorden committed
263
evalTaskConstExpr :: TaskExpr -> Task Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
264
evalTaskConstExpr (EnterInfo msg (Ty toValue)) = enterInformation msg [] @ toValue
Tim Steenvoorden's avatar
Tim Steenvoorden committed
265
evalTaskConstExpr (Apply taskFunc expr) = evalTaskFuncExpr taskFunc $ evalExpr expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
266
evalTaskConstExpr (Then task taskFunc) = evalTaskConstExpr task >>= evalTaskFuncExpr taskFunc
Tim Steenvoorden's avatar
Tim Steenvoorden committed
267 268 269
evalTaskConstExpr (Or task1 task2) = evalTaskConstExpr task1 -||- evalTaskConstExpr task2
evalTaskConstExpr (And task1 task2) = evalTaskConstExpr task1 -&&- evalTaskConstExpr task2 @ \(a, b) -> VTuple a b
evalTaskConstExpr (When task1 options) = evalTaskConstExpr task1
Tim Steenvoorden's avatar
Tim Steenvoorden committed
270 271 272
  >>* [ OnAction (Action name) (ifValue (test pred) (evalTaskFuncExpr cont))
      \\ {name, pred, cont} <- options
      ]
Steffen Michels's avatar
Steffen Michels committed
273
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
274
  test pred (VInt i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
275 276 277 278
    LessV (VInt j) -> i < j
    GrtV (VInt j) -> i > j
    EqV (VInt j) -> i == j

Tim Steenvoorden's avatar
Tim Steenvoorden committed
279
  test pred (VBool i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
280 281 282 283
    EqV (VBool j) -> i == j
    LessV (VBool j) -> False
    GrtV (VBool j) -> False

284 285

evalTaskFuncExpr :: TaskFuncExpr Value -> Task Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
286 287 288 289
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) =
Tim Steenvoorden's avatar
Tim Steenvoorden committed
290
  ( viewInformation p [] ()
Tim Steenvoorden's avatar
Tim Steenvoorden committed
291 292
    ||- evalTaskFuncExpr (ViewInfo "") a
    -&&- evalTaskFuncExpr (ViewInfo "") b
Tim Steenvoorden's avatar
Tim Steenvoorden committed
293 294 295
    @ \(a, b) -> VTuple a b
  )
    <<@ ApplyLayout arrangeHorizontal
Tim Steenvoorden's avatar
Tim Steenvoorden committed
296 297 298 299
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) =
Tim Steenvoorden's avatar
Tim Steenvoorden committed
300
  ( viewInformation p [] ()
Tim Steenvoorden's avatar
Tim Steenvoorden committed
301 302
    ||- evalTaskFuncExpr (UpdateInfo "") a
    -&&- evalTaskFuncExpr (UpdateInfo "") b
Tim Steenvoorden's avatar
Tim Steenvoorden committed
303 304 305 306
    @ \(a, b) -> VTuple a b
  )
    <<@ ApplyLayout arrangeHorizontal

307 308

evalExpr :: Expr -> Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
309 310 311
evalExpr (Int i) = VInt i
evalExpr (Bool b) = VBool b
evalExpr (String s) = VString s
312
evalExpr (Tuple fstExpr sndExpr) = VTuple (evalExpr fstExpr) (evalExpr sndExpr)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
313
evalExpr (Fst expr) = fst
314
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
315
  (VTuple fst _) = evalExpr expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
316
evalExpr (Snd expr) = snd
317
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
318
  (VTuple _ snd) = evalExpr expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
319
evalExpr (Eq expr1 expr2) = VBool $ evalExpr expr1 === evalExpr expr2