DynEditorExample.icl 8.14 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 8 9
import iTasks, iTasks.Extensions.Editors.DynamicEditor

Start world = doTasks editTask world

Steffen Michels's avatar
Steffen Michels committed
10 11 12 13 14 15 16 17 18 19
editTask =		forever
		(		enterInformation () [EnterUsing id $ dynamicEditor taskEditor]
		>>=		evalTaskConstExpr o toValue taskEditor
		>>=		viewInformation "result of the completed task is:" []
		)

:: TaskConstExpr = Apply TaskFuncExpr Expr | EnterInformation Type | Bind TaskConstExpr TaskFuncExpr | Blind TaskConstExpr TaskConstExpr
				 | Or TaskConstExpr TaskConstExpr | And TaskConstExpr TaskConstExpr
				 | When TaskConstExpr FunExpr
:: TaskFuncExpr  = ViewInformation | UpdateInformation | Return
20 21
:: Expr          = Int Int | Bool Bool | Tuple Expr Expr | Fst Expr | Snd Expr | Eq Expr Expr
:: Value         = VInt Int | VBool Bool | VTuple Value Value
22 23
:: Type          = E.a: Type (a -> Value) & iTask a
:: Typed a b     =: Typed a
Steffen Michels's avatar
Steffen Michels committed
24
:: FunExpr	 	 = EqV Value | GrtV Value | LessV Value
25

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

28 29 30 31 32 33 34 35
// instances are never used
gDefault{|Type|} = undef
gEq{|Type|} _ _ = undef
JSONEncode{|Type|} _ _ = undef
JSONDecode{|Type|} _ _ = undef
gText{|Type|} _ _ = undef
gEditor{|Type|} = undef

36
taskEditor :: DynamicEditor TaskConstExpr
37 38 39
taskEditor = DynamicEditor conses
where
	conses =
40
		[ // This cons is used to provide untyped `TaskConstExpr` values.
41
		  DynamicCons $
42 43
			functionConsDyn "TaskConstExpr" "(enter task)"
				(dynamic \(Typed taskExpr) -> taskExpr :: A.a: (Typed TaskConstExpr a) -> TaskConstExpr)
44
		  <<@@@ HideIfOnlyChoice
45
		, DynamicConsGroup "Combinators"
Steffen Michels's avatar
Steffen Michels committed
46
			[ functionConsDyn "Bind" ">>="
47 48 49 50 51
				(	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)
				)
Steffen Michels's avatar
Steffen Michels committed
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
			, 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 funexpr) -> Typed (When task1 funexpr) ::
					A.a b:
						(Typed TaskConstExpr (Task a)) (Typed FunExpr a)
						-> Typed TaskConstExpr (Task a)
				)
				]
77
		, DynamicConsGroup "Editors"
Steffen Michels's avatar
Steffen Michels committed
78 79 80
			[ 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)
81
				)
Steffen Michels's avatar
Steffen Michels committed
82
			, functionConsDyn "EnterInformation" "enter information"
83 84
				(	dynamic \(Typed type) -> Typed (EnterInformation type) ::
					A.a: (Typed Type a) -> Typed TaskConstExpr (Task a)
85
				) <<@@@ applyHorizontalClasses
86
			, functionConsDyn "ViewInformation" "view information"
87
				(dynamic Typed ViewInformation :: A.a: Typed TaskFuncExpr (a -> Task a))
Steffen Michels's avatar
Steffen Michels committed
88 89 90 91
			, functionConsDyn "UpdateInformation" "update information"
				(dynamic Typed UpdateInformation :: A.a: Typed TaskFuncExpr (a -> Task a))
			, functionConsDyn "Return" "return"
				(dynamic Typed Return :: A.a: Typed TaskFuncExpr (a -> Task a))
92
			]
Steffen Michels's avatar
Steffen Michels committed
93

94
		// ordinary (non-task) expressions
Steffen Michels's avatar
Steffen Michels committed
95 96 97

		, DynamicCons $ functionConsDyn "EqV"   "equal"
			(dynamic \i -> Typed (EqV (VInt i))  :: Int  -> Typed FunExpr Int)
98
			<<@@@ applyHorizontalClasses
Steffen Michels's avatar
Steffen Michels committed
99 100
		, DynamicCons $ functionConsDyn "GrtV"   "greater"
			(dynamic \i -> Typed (GrtV (VInt i))  :: Int  -> Typed FunExpr Int)
101
			<<@@@ applyHorizontalClasses
Steffen Michels's avatar
Steffen Michels committed
102 103
		, DynamicCons $ functionConsDyn "LessV"   "less"
			(dynamic \i -> Typed (LessV (VInt i))  :: Int  -> Typed FunExpr Int)
104
			<<@@@ applyHorizontalClasses
105 106 107 108 109 110 111 112 113 114
		, DynamicCons $ functionConsDyn "int"   "enter integer:"
			(dynamic \i -> Typed (Int i)  :: Int  -> Typed Expr Int)
		, DynamicCons $ functionConsDyn "bool"  "enter boolean:"
			(dynamic \b -> Typed (Bool b) :: Bool -> Typed Expr Bool)
		, 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)
115
			<<@@@ applyHorizontalClasses
116 117
		, DynamicCons $ functionConsDyn "snd"   "snd"
			(dynamic \(Typed (Tuple _ b)) -> Typed b :: A.a b: (Typed Expr (a, b)) -> Typed Expr b)
118
			<<@@@ applyHorizontalClasses
119 120 121 122
		, DynamicCons $ functionConsDyn "=="    "=="
			(	dynamic \(Typed a) (Typed b) -> Typed (Eq a b) ::
				A.a: (Typed Expr a) (Typed Expr a) -> Typed Expr Bool
			)
123
			<<@@@ applyHorizontalClasses
124 125
		, DynamicCons $ customEditorCons "Int"   "(enter integer)" intEditor  <<@@@ HideIfOnlyChoice
		, DynamicCons $ customEditorCons "Bool"  "(enter boolean)" boolEditor <<@@@ HideIfOnlyChoice
Steffen Michels's avatar
Steffen Michels committed
126

127
		// type specifications for enterInformation
Steffen Michels's avatar
Steffen Michels committed
128

129 130 131 132 133 134 135 136
		, 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.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)
137
			) <<@@@ applyHorizontalClasses
138 139
		]

140 141 142 143 144 145
	derivedType :: Typed Type a | iTask a
	derivedType = case dynToValue of
		(toValue :: a^ -> Value | iTask a^) = Typed (Type toValue)
	where
		dynToValue = dynamic ()

146 147 148 149 150 151
	intEditor :: Editor Int
	intEditor = gEditor{|*|}

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

152 153
applyHorizontalClasses = ApplyCssClasses ["itasks-horizontal", "itasks-wrap-width", "itasks-panel"]

154
evalTaskConstExpr :: TaskConstExpr -> Task Value
Steffen Michels's avatar
Steffen Michels committed
155
evalTaskConstExpr (EnterInformation (Type toValue)) = enterInformation () [] @ toValue
156 157
evalTaskConstExpr (Apply taskFunc expr)             = evalTaskFuncExpr taskFunc $ evalExpr expr
evalTaskConstExpr (Bind task taskFunc)              = evalTaskConstExpr task >>= evalTaskFuncExpr taskFunc
Steffen Michels's avatar
Steffen Michels committed
158 159 160 161 162 163 164 165 166 167 168
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 task pred)					= evalTaskConstExpr task >>* [OnAction ActionOk (ifValue test return)]
where
	test (VInt i) = case pred of
						(LessV (VInt j))  = i<j
						(GrtV  (VInt j))  = i>j
						(EqV   (VInt j))  = i==j
	test (VBool i) = case pred of
						(EqV   (VBool j)) = i==j
169 170

evalTaskFuncExpr :: TaskFuncExpr Value -> Task Value
Steffen Michels's avatar
Steffen Michels committed
171 172
evalTaskFuncExpr ViewInformation (VInt i)		= viewInformation () [] i @ VInt
evalTaskFuncExpr ViewInformation (VBool b)		= viewInformation () [] b @ VBool
173
evalTaskFuncExpr ViewInformation (VTuple a b)	= evalTaskFuncExpr ViewInformation a -&&- evalTaskFuncExpr ViewInformation b @ \(a,b) -> VTuple a b
Steffen Michels's avatar
Steffen Michels committed
174 175 176 177 178
evalTaskFuncExpr UpdateInformation (VInt i)		= updateInformation () [] i @ VInt
evalTaskFuncExpr UpdateInformation (VBool b)	= updateInformation () [] b @ VBool
evalTaskFuncExpr UpdateInformation (VTuple a b)	= evalTaskFuncExpr UpdateInformation a -&&- evalTaskFuncExpr UpdateInformation b @ \(a,b) -> VTuple a b
evalTaskFuncExpr Return value 					= return value

179 180

evalExpr :: Expr -> Value
181 182 183 184 185 186 187 188 189 190
evalExpr (Int i)                 = VInt i
evalExpr (Bool b)                = VBool b
evalExpr (Tuple fstExpr sndExpr) = VTuple (evalExpr fstExpr) (evalExpr sndExpr)
evalExpr (Fst expr)              = fst
where
	(VTuple fst _) = evalExpr expr
evalExpr (Snd expr)              = snd
where
	(VTuple _ snd) = evalExpr expr
evalExpr (Eq expr1 expr2)        = VBool $ evalExpr expr1 === evalExpr expr2
191