DynEditorExample.icl 12.2 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 37 38 39 40 41 42
:: TaskConstExpr
  = Apply TaskFuncExpr Expr
  | EnterInformation String Ty
  | Bind TaskConstExpr TaskFuncExpr
  | Blind TaskConstExpr TaskConstExpr
  | Or TaskConstExpr TaskConstExpr
  | And TaskConstExpr TaskConstExpr
  | When TaskConstExpr (List (FunExpr, String, TaskFuncExpr))
43

Tim Steenvoorden's avatar
Tim Steenvoorden committed
44 45 46 47
:: TaskFuncExpr
  = ViewInformation String
  | UpdateInformation String
  | Return
48

Tim Steenvoorden's avatar
Tim Steenvoorden committed
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73
:: 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
74

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

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

86

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

89
taskEditor :: DynamicEditor TaskConstExpr
90 91
taskEditor = DynamicEditor conses
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
92 93
  conses =
    [ // This cons is used to provide untyped `TaskConstExpr` values.
Tim Steenvoorden's avatar
Tim Steenvoorden committed
94 95
      DynamicCons
        $ functionConsDyn "TaskConstExpr" "(enter task)" (dynamic \(Typed taskExpr) -> taskExpr ::  A.a: (Typed TaskConstExpr a) -> TaskConstExpr)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
96
        <<@@@ HideIfOnlyChoice
Tim Steenvoorden's avatar
Tim Steenvoorden committed
97 98 99 100 101
    , DynamicConsGroup "Combinators"
        [ functionConsDyn "Bind" ">>="
            ( dynamic \(Typed task) (Typed taskFunc) ->
              Typed (Bind task taskFunc) ::
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
102 103
                (Typed TaskConstExpr (Task a)) (Typed TaskFuncExpr (a -> Task b))
                -> Typed TaskConstExpr (Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
104 105 106 107 108
            )
        , functionConsDyn "Blind" ">>|"
            ( dynamic \(Typed task1) (Typed task2) ->
              Typed (Blind task1 task2) ::
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
109 110
                (Typed TaskConstExpr (Task a)) (Typed TaskConstExpr (Task b))
                -> Typed TaskConstExpr (Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
111 112 113 114 115
            )
        , functionConsDyn "Or" "-||-"
            ( dynamic \(Typed task1) (Typed task2) ->
              Typed (Or task1 task2) ::
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
116 117
                (Typed TaskConstExpr (Task a)) (Typed TaskConstExpr (Task a))
                -> Typed TaskConstExpr (Task a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
118 119 120 121 122
            )
        , functionConsDyn "And" "-&&-"
            ( dynamic \(Typed task1) (Typed task2) ->
              Typed (And task1 task2) ::
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
123 124
                (Typed TaskConstExpr (Task a)) (Typed TaskConstExpr (Task b))
                -> Typed TaskConstExpr (Task (a, b))
Tim Steenvoorden's avatar
Tim Steenvoorden committed
125 126 127 128 129
            )
        , functionConsDyn "When" "when"
            ( dynamic \(Typed task1) (Typed steps) ->
              Typed (When task1 [(expr, pred, tfExpr) \\ (Typed expr, pred, Typed tfExpr) <- steps]) ::
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
130 131 132
                (Typed TaskConstExpr (Task a))
                (Typed (List (Typed FunExpr (a -> Bool), String, Typed TaskFuncExpr (a -> Task a))) (a -> Task b))
                -> Typed TaskConstExpr (Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
133 134 135 136 137 138
            )
            <<@@@ applyHorizontalClasses
        , listConsDyn "[(FunExpr, String, TaskFuncExpr)]" "[(FunExpr, String, TaskFuncExpr)]"
            ( dynamic \typedSteps ->
              Typed ((\(Typed expr) -> expr) <$> typedSteps) ::
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
139 140 141
                (List (Typed (FunExpr, String, TaskFuncExpr)
                (a -> Task b)))
                -> Typed (List (FunExpr, String, TaskFuncExpr)) (a -> Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
142 143 144 145 146 147
            )
            <<@@@ 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
148 149 150 151
                (Typed FunExpr a)
                String
                (Typed TaskFuncExpr (a -> Task b))
                -> Typed (FunExpr, String, TaskFuncExpr) (a -> Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
152 153 154
            )
            <<@@@ HideIfOnlyChoice
        ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
155
    , DynamicConsGroup "Editors"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
156 157 158 159
        [ functionConsDyn "Apply" "apply"
            ( dynamic \(Typed taskFunc) (Typed expr) ->
              Typed (Apply taskFunc expr) ::
                A.a b:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
160 161 162
                (Typed TaskFuncExpr (a -> Task b))
                (Typed Expr a)
                -> Typed TaskConstExpr (Task b)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
163 164 165 166 167
            )
        , functionConsDyn "EnterInformation" "enter information"
            ( dynamic \s (Typed ty) ->
              Typed (EnterInformation s ty) ::
                A.a:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
168 169
                String (Typed Ty a)
                -> Typed TaskConstExpr (Task a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
170 171 172 173 174 175
            )
            <<@@@ applyHorizontalClasses
        , functionConsDyn "ViewInformation" "view information"
            ( dynamic \s ->
              Typed (ViewInformation s) ::
                A.a:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
176 177
                String
                -> Typed TaskFuncExpr (a -> Task a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
178 179 180 181 182 183
            )
            <<@@@ applyHorizontalClasses
        , functionConsDyn "UpdateInformation" "update information"
            ( dynamic \s ->
              Typed (UpdateInformation s) ::
                A.a:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
184 185
                String
                -> Typed TaskFuncExpr (a -> Task a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
186 187 188 189 190
            )
            <<@@@ applyHorizontalClasses
        , functionConsDyn "Return" "return"
            ( dynamic Typed Return ::
              A.a:
Tim Steenvoorden's avatar
Tim Steenvoorden committed
191
              Typed TaskFuncExpr (a -> Task a)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
192 193
            )
        ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
194
    // ordinary (non-task) expressions
Tim Steenvoorden's avatar
Tim Steenvoorden committed
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 225 226 227 228 229 230 231 232 233
    , 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
234
    // type specifications for enterInformation
Tim Steenvoorden's avatar
Tim Steenvoorden committed
235 236 237 238 239 240 241 242 243 244 245
    , 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
246 247 248
    ]


Tim Steenvoorden's avatar
Tim Steenvoorden committed
249 250 251 252 253 254
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
255

Tim Steenvoorden's avatar
Tim Steenvoorden committed
256 257
intEditor :: Editor Int
intEditor = gEditor{|*|}
Tim Steenvoorden's avatar
Tim Steenvoorden committed
258

Tim Steenvoorden's avatar
Tim Steenvoorden committed
259 260
boolEditor :: Editor Bool
boolEditor = gEditor{|*|}
261

Tim Steenvoorden's avatar
Tim Steenvoorden committed
262 263
stringEditor :: Editor String
stringEditor = gEditor{|*|}
264

265 266
applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"]

Tim Steenvoorden's avatar
Tim Steenvoorden committed
267

268
evalTaskConstExpr :: TaskConstExpr -> Task Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
269 270 271 272 273 274 275 276 277 278 279
evalTaskConstExpr (EnterInformation prompt (Ty toValue)) = enterInformation prompt [] @ toValue
evalTaskConstExpr (Apply taskFunc expr) = evalTaskFuncExpr taskFunc $ evalExpr expr
evalTaskConstExpr (Bind task taskFunc) = evalTaskConstExpr task >>= evalTaskFuncExpr taskFunc
evalTaskConstExpr (Blind task1 task2) = evalTaskConstExpr task1 >>| evalTaskConstExpr task2
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
280
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
281
  test pred (VInt i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
282 283 284 285
    LessV (VInt j) -> i < j
    GrtV (VInt j) -> i > j
    EqV (VInt j) -> i == j

Tim Steenvoorden's avatar
Tim Steenvoorden committed
286
  test pred (VBool i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
287 288 289 290
    EqV (VBool j) -> i == j
    LessV (VBool j) -> False
    GrtV (VBool j) -> False

291 292

evalTaskFuncExpr :: TaskFuncExpr Value -> Task Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316

evalTaskFuncExpr (ViewInformation p) (VInt i) = (viewInformation p [] i @ VInt) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (ViewInformation p) (VBool b) = (viewInformation p [] b @ VBool) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (ViewInformation p) (VString s) = (viewInformation p [] s @ VString) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (ViewInformation p) (VTuple a b) =
  ( viewInformation p [] ()
    ||- evalTaskFuncExpr (ViewInformation "") a
    -&&- evalTaskFuncExpr (ViewInformation "") b
    @ \(a, b) -> VTuple a b
  )
    <<@ ApplyLayout arrangeHorizontal

evalTaskFuncExpr (UpdateInformation p) (VInt i) = (updateInformation p [] i @ VInt) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (UpdateInformation p) (VBool b) = (updateInformation p [] b @ VBool) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (UpdateInformation p) (VString s) = (updateInformation p [] s @ VString) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr (UpdateInformation p) (VTuple a b) =
  ( viewInformation p [] ()
    ||- evalTaskFuncExpr (UpdateInformation "") a
    -&&- evalTaskFuncExpr (UpdateInformation "") b
    @ \(a, b) -> VTuple a b
  )
    <<@ ApplyLayout arrangeHorizontal

evalTaskFuncExpr Return value = return value
Steffen Michels's avatar
Steffen Michels committed
317

318 319

evalExpr :: Expr -> Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
320 321 322
evalExpr (Int i) = VInt i
evalExpr (Bool b) = VBool b
evalExpr (String s) = VString s
323
evalExpr (Tuple fstExpr sndExpr) = VTuple (evalExpr fstExpr) (evalExpr sndExpr)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
324
evalExpr (Fst expr) = fst
325
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
326
  (VTuple fst _) = evalExpr expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
327
evalExpr (Snd expr) = snd
328
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
329
  (VTuple _ snd) = evalExpr expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
330
evalExpr (Eq expr1 expr2) = VBool $ evalExpr expr1 === evalExpr expr2