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
:: List a :== [a]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
11

12 13
Start world = doTasks editTask world

Tim Steenvoorden's avatar
Tim Steenvoorden committed
14 15 16 17 18 19 20 21 22
editTask =
  forever
    ( viewInformation "Contruct a Task expression:" [] ()
      ||- enterInformation () [EnterUsing id $ dynamicEditor taskEditor]
      >>= \v ->
          viewInformation "Evaluate the Expression:" [] ()
            ||- evalTaskConstExpr (toValue taskEditor v)
            >>= viewInformation "Result of the Task is:" []
            >>= return
Tim Steenvoorden's avatar
Tim Steenvoorden committed
23
    ) // <<@ ApplyLayout frameCompact
24 25


Tim Steenvoorden's avatar
Tim Steenvoorden committed
26 27 28 29 30 31 32 33
:: 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))
34

Tim Steenvoorden's avatar
Tim Steenvoorden committed
35 36 37 38
:: TaskFuncExpr
  = ViewInformation String
  | UpdateInformation String
  | Return
39

Tim Steenvoorden's avatar
Tim Steenvoorden committed
40 41 42 43 44 45 46 47 48 49 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

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

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

:: Typed a b
  =: Typed a
65

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

Tim Steenvoorden's avatar
Tim Steenvoorden committed
68

69
// instances are never used
Tim Steenvoorden's avatar
Tim Steenvoorden committed
70 71 72 73 74 75 76
gDefault{|Ty|} = undef
gEq{|Ty|} _ _ = undef
JSONEncode{|Ty|} _ _ = undef
JSONDecode{|Ty|} _ _ = undef
gText{|Ty|} _ _ = undef
gEditor{|Ty|} = undef

77

78
taskEditor :: DynamicEditor TaskConstExpr
79 80
taskEditor = DynamicEditor conses
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
81 82
  conses =
    [ // This cons is used to provide untyped `TaskConstExpr` values.
Tim Steenvoorden's avatar
Tim Steenvoorden committed
83 84
      DynamicCons
        $ functionConsDyn "TaskConstExpr" "(enter task)" (dynamic \(Typed taskExpr) -> taskExpr ::  A.a: (Typed TaskConstExpr a) -> TaskConstExpr)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
85
        <<@@@ HideIfOnlyChoice
Tim Steenvoorden's avatar
Tim Steenvoorden committed
86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 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
    , DynamicConsGroup "Combinators"
        [ functionConsDyn "Bind" ">>="
            ( dynamic \(Typed task) (Typed taskFunc) ->
              Typed (Bind task taskFunc) ::
                A.a b:
                  (Typed TaskConstExpr (Task a)) (Typed TaskFuncExpr (a -> Task b)) ->
                  Typed TaskConstExpr (Task b)
            )
        , functionConsDyn "Blind" ">>|"
            ( dynamic \(Typed task1) (Typed task2) ->
              Typed (Blind task1 task2) ::
                A.a b:
                  (Typed TaskConstExpr (Task a)) (Typed TaskConstExpr (Task b)) ->
                  Typed TaskConstExpr (Task b)
            )
        , functionConsDyn "Or" "-||-"
            ( dynamic \(Typed task1) (Typed task2) ->
              Typed (Or task1 task2) ::
                A.a b:
                  (Typed TaskConstExpr (Task a)) (Typed TaskConstExpr (Task a)) ->
                  Typed TaskConstExpr (Task a)
            )
        , functionConsDyn "And" "-&&-"
            ( dynamic \(Typed task1) (Typed task2) ->
              Typed (And task1 task2) ::
                A.a b:
                  (Typed TaskConstExpr (Task a)) (Typed TaskConstExpr (Task b)) ->
                  Typed TaskConstExpr (Task (a, b))
            )
        , functionConsDyn "When" "when"
            ( dynamic \(Typed task1) (Typed steps) ->
              Typed (When task1 [(expr, pred, tfExpr) \\ (Typed expr, pred, Typed tfExpr) <- steps]) ::
                A.a b:
                  (Typed TaskConstExpr (Task a)) (Typed (List (Typed FunExpr (a -> Bool), String, Typed TaskFuncExpr (a -> Task a))) (a -> Task b)) ->
                  Typed TaskConstExpr (Task b)
            )
            <<@@@ applyHorizontalClasses
        , listConsDyn "[(FunExpr, String, TaskFuncExpr)]" "[(FunExpr, String, TaskFuncExpr)]"
            ( dynamic \typedSteps ->
              Typed ((\(Typed expr) -> expr) <$> typedSteps) ::
                A.a b:
                  (List (Typed (FunExpr, String, TaskFuncExpr) (a -> Task b))) -> Typed (List (FunExpr, String, TaskFuncExpr)) (a -> Task b)
            )
            <<@@@ HideIfOnlyChoice
        , functionConsDyn "(FunExpr, String, TaskFuncExpr)" "(FunExpr, String, TaskFuncExpr)"
            ( dynamic \(Typed funExpr) s (Typed taskFunc) ->
              Typed (funExpr, s, taskFunc) ::
                A.a b:
                  (Typed FunExpr a) String (Typed TaskFuncExpr (a -> Task b)) ->
                  Typed (FunExpr, String, TaskFuncExpr) (a -> Task b)
            )
            <<@@@ HideIfOnlyChoice
        ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
139
    , DynamicConsGroup "Editors"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
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
        [ functionConsDyn "Apply" "apply"
            ( dynamic \(Typed taskFunc) (Typed expr) ->
              Typed (Apply taskFunc expr) ::
                A.a b:
                  (Typed TaskFuncExpr (a -> Task b)) (Typed Expr a) -> Typed TaskConstExpr (Task b)
            )
        , functionConsDyn "EnterInformation" "enter information"
            ( dynamic \s (Typed ty) ->
              Typed (EnterInformation s ty) ::
                A.a:
                  String (Typed Ty a) -> Typed TaskConstExpr (Task a)
            )
            <<@@@ applyHorizontalClasses
        , functionConsDyn "ViewInformation" "view information"
            ( dynamic \s ->
              Typed (ViewInformation s) ::
                A.a:
                  String -> Typed TaskFuncExpr (a -> Task a)
            )
            <<@@@ applyHorizontalClasses
        , functionConsDyn "UpdateInformation" "update information"
            ( dynamic \s ->
              Typed (UpdateInformation s) ::
                A.a:
                  String -> Typed TaskFuncExpr (a -> Task a)
            )
            <<@@@ applyHorizontalClasses
        , functionConsDyn "Return" "return"
            ( dynamic Typed Return ::
              A.a:
                Typed TaskFuncExpr (a -> Task a)
            )
        ]
Tim Steenvoorden's avatar
Tim Steenvoorden committed
173
    // ordinary (non-task) expressions
Tim Steenvoorden's avatar
Tim Steenvoorden committed
174 175 176 177 178 179 180 181 182 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
    , 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
213
    // type specifications for enterInformation
Tim Steenvoorden's avatar
Tim Steenvoorden committed
214 215 216 217 218 219 220 221 222 223 224
    , 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
225 226 227
    ]


Tim Steenvoorden's avatar
Tim Steenvoorden committed
228 229 230 231 232 233
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
234

Tim Steenvoorden's avatar
Tim Steenvoorden committed
235 236
intEditor :: Editor Int
intEditor = gEditor{|*|}
Tim Steenvoorden's avatar
Tim Steenvoorden committed
237

Tim Steenvoorden's avatar
Tim Steenvoorden committed
238 239
boolEditor :: Editor Bool
boolEditor = gEditor{|*|}
240

Tim Steenvoorden's avatar
Tim Steenvoorden committed
241 242
stringEditor :: Editor String
stringEditor = gEditor{|*|}
243

244 245
applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"]

Tim Steenvoorden's avatar
Tim Steenvoorden committed
246

247
evalTaskConstExpr :: TaskConstExpr -> Task Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
248 249 250 251 252 253 254 255 256 257 258
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
259
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
260
  test pred (VInt i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
261 262 263 264
    LessV (VInt j) -> i < j
    GrtV (VInt j) -> i > j
    EqV (VInt j) -> i == j

Tim Steenvoorden's avatar
Tim Steenvoorden committed
265
  test pred (VBool i) = case pred of
Tim Steenvoorden's avatar
Tim Steenvoorden committed
266 267 268 269
    EqV (VBool j) -> i == j
    LessV (VBool j) -> False
    GrtV (VBool j) -> False

270 271

evalTaskFuncExpr :: TaskFuncExpr Value -> Task Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295

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
296

297 298

evalExpr :: Expr -> Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
299 300 301
evalExpr (Int i) = VInt i
evalExpr (Bool b) = VBool b
evalExpr (String s) = VString s
302
evalExpr (Tuple fstExpr sndExpr) = VTuple (evalExpr fstExpr) (evalExpr sndExpr)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
303
evalExpr (Fst expr) = fst
304
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
305
  (VTuple fst _) = evalExpr expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
306
evalExpr (Snd expr) = snd
307
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
308
  (VTuple _ snd) = evalExpr expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
309
evalExpr (Eq expr1 expr2) = VBool $ evalExpr expr1 === evalExpr expr2