DynEditorExample.icl 11.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
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
// Helpers //

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

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

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

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

255 256
applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"]

Tim Steenvoorden's avatar
Tim Steenvoorden committed
257

Tim Steenvoorden's avatar
Tim Steenvoorden committed
258 259
// Evaluation //////////////////////////////////////////////////////////////////

260
evalTaskConstExpr :: TaskConstExpr -> Task Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
261
evalTaskConstExpr (EnterInfo msg (Ty toValue)) = enterInformation msg [] @ toValue
Tim Steenvoorden's avatar
Tim Steenvoorden committed
262
evalTaskConstExpr (Apply taskFunc expr) = evalTaskFuncExpr taskFunc $ evalExpr expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
263
evalTaskConstExpr (Then task taskFunc) = evalTaskConstExpr task >>= evalTaskFuncExpr taskFunc
Tim Steenvoorden's avatar
Tim Steenvoorden committed
264 265 266 267 268 269 270
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
271
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
272
  test pred (VInt i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
273 274 275 276
    LessV (VInt j) -> i < j
    GrtV (VInt j) -> i > j
    EqV (VInt j) -> i == j

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

282 283

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

305 306

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