DynEditorExample.icl 11.5 KB
Newer Older
1 2
module DynEditorExample

Steffen Michels's avatar
Steffen Michels committed
3
import StdEnv
4
import Data.Func, Data.Functor
5
import Text
6 7
import iTasks, iTasks.Extensions.Editors.DynamicEditor

Tim Steenvoorden's avatar
Tim Steenvoorden committed
8

9 10
Start world = doTasks editTask world

Tim Steenvoorden's avatar
Tim Steenvoorden committed
11 12 13 14 15 16 17 18 19 20
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
    ) // <<@ ApplyLayout frameCompact
21 22

:: TaskConstExpr = Apply TaskFuncExpr Expr | EnterInformation String Type | Bind TaskConstExpr TaskFuncExpr | Blind TaskConstExpr TaskConstExpr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
23 24
         | Or TaskConstExpr TaskConstExpr | And TaskConstExpr TaskConstExpr
         | When TaskConstExpr [(FunExpr, String, TaskFuncExpr)]
25 26 27 28 29
:: TaskFuncExpr  = ViewInformation String | UpdateInformation String | Return

:: 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
30
:: FunExpr      = EqV Value | GrtV Value | LessV Value
31

32 33
:: Type          = E.a: Type (a -> Value) & iTask a
:: Typed a b     =: Typed a
34

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

37 38 39 40 41 42 43 44
// instances are never used
gDefault{|Type|} = undef
gEq{|Type|} _ _ = undef
JSONEncode{|Type|} _ _ = undef
JSONDecode{|Type|} _ _ = undef
gText{|Type|} _ _ = undef
gEditor{|Type|} = undef

45
taskEditor :: DynamicEditor TaskConstExpr
46 47
taskEditor = DynamicEditor conses
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
48 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 74 75 76 77 78 79 80 81 82 83 84 85 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 139 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 173 174 175 176 177 178 179 180 181 182 183 184 185
  conses =
    [ // This cons is used to provide untyped `TaskConstExpr` values.
      DynamicCons $
      functionConsDyn "TaskConstExpr" "(enter task)"
        (dynamic \(Typed taskExpr) -> taskExpr :: A.a: (Typed TaskConstExpr a) -> TaskConstExpr)
      <<@@@ HideIfOnlyChoice
    , 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 [(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:
            [Typed (FunExpr, String, TaskFuncExpr) (a -> Task b)] -> Typed [(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
      ]
    , DynamicConsGroup "Editors"
      [ 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 type) -> Typed (EnterInformation s type) ::
          A.a: String (Typed Type 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)
        )
      ]

    // ordinary (non-task) expressions

    , 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

    // type specifications for enterInformation

    , DynamicCons $ functionConsDyn "Type.Int"     "Int"     (dynamic Typed (Type VInt)  :: Typed Type Int)
    , DynamicCons $ functionConsDyn "Type.Bool"    "Bool"    (dynamic Typed (Type VBool) :: Typed Type Bool)
    , DynamicCons $ functionConsDyn "Type.String"    "String"    (dynamic Typed (Type VString) :: Typed Type String)
    , DynamicCons $ functionConsDyn "Type.Tuple"   "Tuple"
      (  dynamic
          \(Typed (Type toValue1)) (Typed (Type toValue2)) ->
            Typed (Type \(x, y) -> VTuple (toValue1 x) (toValue2 y))
        ::
          A.a b: (Typed Type a) (Typed Type b) -> Typed Type (a, b)
      ) <<@@@ applyHorizontalClasses
    ]

  derivedType :: Typed Type a | iTask a
  derivedType = case dynToValue of
    (toValue :: a^ -> Value | iTask a^) = Typed (Type toValue)
  where
    dynToValue = dynamic ()

  intEditor :: Editor Int
  intEditor = gEditor{|*|}

  boolEditor :: Editor Bool
  boolEditor = gEditor{|*|}

  stringEditor :: Editor String
  stringEditor = gEditor{|*|}
186 187


188 189
applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"]

190
evalTaskConstExpr :: TaskConstExpr -> Task Value
191
evalTaskConstExpr (EnterInformation prompt (Type toValue)) = enterInformation prompt [] @ toValue
Tim Steenvoorden's avatar
Tim Steenvoorden committed
192 193 194 195 196 197 198 199 200 201 202 203 204 205 206
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
207
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
208 209 210 211 212 213 214 215
  test pred (VInt i) = case pred of
            (LessV (VInt j))  = i<j
            (GrtV  (VInt j))  = i>j
            (EqV   (VInt j))  = i==j
  test pred (VBool i) = case pred of
            (EqV   (VBool j))  = i==j
            (LessV (VBool j))  = False
            (GrtV  (VBool j))  = False
216 217

evalTaskFuncExpr :: TaskFuncExpr Value -> Task Value
Tim Steenvoorden's avatar
Tim Steenvoorden committed
218 219 220 221 222 223 224 225 226 227 228 229 230 231 232
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
233

234 235

evalExpr :: Expr -> Value
236 237
evalExpr (Int i)                 = VInt i
evalExpr (Bool b)                = VBool b
238
evalExpr (String s)              = VString s
239 240 241
evalExpr (Tuple fstExpr sndExpr) = VTuple (evalExpr fstExpr) (evalExpr sndExpr)
evalExpr (Fst expr)              = fst
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
242
  (VTuple fst _) = evalExpr expr
243 244
evalExpr (Snd expr)              = snd
where
Tim Steenvoorden's avatar
Tim Steenvoorden committed
245
  (VTuple _ snd) = evalExpr expr
246
evalExpr (Eq expr1 expr2)        = VBool $ evalExpr expr1 === evalExpr expr2