DynEditorExample.icl 11.5 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 36
:: TaskConstExpr
  = Apply TaskFuncExpr Expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
37 38
  | EnterInfo String Ty
  | Then TaskConstExpr TaskFuncExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
39 40 41
  | Or TaskConstExpr TaskConstExpr
  | And TaskConstExpr TaskConstExpr
  | When TaskConstExpr (List (FunExpr, String, TaskFuncExpr))
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 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
:: 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

:: FunExpr
  = EqV Value
  | GrtV Value
  | LessV Value

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

:: Typed a b
  =: Typed a
72

Steffen Michels's avatar
Steffen Michels committed
73
derive class iTask TaskConstExpr, TaskFuncExpr, Expr, Value, Typed, FunExpr
74

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

84

Tim Steenvoorden's avatar
Tim Steenvoorden committed
85 86
// Editor //////////////////////////////////////////////////////////////////////

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


Tim Steenvoorden's avatar
Tim Steenvoorden committed
237 238 239 240 241 242
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
243

Tim Steenvoorden's avatar
Tim Steenvoorden committed
244 245
intEditor :: Editor Int
intEditor = gEditor{|*|}
Tim Steenvoorden's avatar
Tim Steenvoorden committed
246

Tim Steenvoorden's avatar
Tim Steenvoorden committed
247 248
boolEditor :: Editor Bool
boolEditor = gEditor{|*|}
249

Tim Steenvoorden's avatar
Tim Steenvoorden committed
250 251
stringEditor :: Editor String
stringEditor = gEditor{|*|}
252

253 254
applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"]

Tim Steenvoorden's avatar
Tim Steenvoorden committed
255

256
evalTaskConstExpr :: TaskConstExpr -> Task Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
257
evalTaskConstExpr (EnterInfo prompt (Ty toValue)) = enterInformation prompt [] @ toValue
Tim Steenvoorden's avatar
Tim Steenvoorden committed
258
evalTaskConstExpr (Apply taskFunc expr) = evalTaskFuncExpr taskFunc $ evalExpr expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
259
evalTaskConstExpr (Then task taskFunc) = evalTaskConstExpr task >>= evalTaskFuncExpr taskFunc
Tim Steenvoorden's avatar
Tim Steenvoorden committed
260 261 262 263 264 265 266
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
  >>* [ OnAction (Action butName) (ifValue (test pred) (evalTaskFuncExpr taskFunc))
        \\ (pred, butName, taskFunc)
        <- options
    ]
Steffen Michels's avatar
Steffen Michels committed
267
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
268
  test pred (VInt i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
269 270 271 272
    LessV (VInt j) -> i < j
    GrtV (VInt j) -> i > j
    EqV (VInt j) -> i == j

Tim Steenvoorden's avatar
Tim Steenvoorden committed
273
  test pred (VBool i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
274 275 276 277
    EqV (VBool j) -> i == j
    LessV (VBool j) -> False
    GrtV (VBool j) -> False

278 279

evalTaskFuncExpr :: TaskFuncExpr Value -> Task Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
280

Tim Steenvoorden's avatar
Tim Steenvoorden committed
281 282 283 284
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
285
  ( viewInformation p [] ()
Tim Steenvoorden's avatar
Tim Steenvoorden committed
286 287
    ||- evalTaskFuncExpr (ViewInfo "") a
    -&&- evalTaskFuncExpr (ViewInfo "") b
Tim Steenvoorden's avatar
Tim Steenvoorden committed
288 289 290 291
    @ \(a, b) -> VTuple a b
  )
    <<@ ApplyLayout arrangeHorizontal

Tim Steenvoorden's avatar
Tim Steenvoorden committed
292 293 294 295
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
296
  ( viewInformation p [] ()
Tim Steenvoorden's avatar
Tim Steenvoorden committed
297 298
    ||- evalTaskFuncExpr (UpdateInfo "") a
    -&&- evalTaskFuncExpr (UpdateInfo "") b
Tim Steenvoorden's avatar
Tim Steenvoorden committed
299 300 301 302
    @ \(a, b) -> VTuple a b
  )
    <<@ ApplyLayout arrangeHorizontal

303 304

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