DynEditorExample.icl 10.7 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
editTask =		forever
11
		(			viewInformation "Contruct a Task expression:" [] ()
Tim Steenvoorden's avatar
Tim Steenvoorden committed
12
					||-
13 14
					enterInformation () [EnterUsing id $ dynamicEditor taskEditor]
		>>=	\v ->	viewInformation "Evaluate the Expression:" [] ()
Tim Steenvoorden's avatar
Tim Steenvoorden committed
15
					||-
16
					evalTaskConstExpr (toValue taskEditor v)
Tim Steenvoorden's avatar
Tim Steenvoorden committed
17
		>>=			viewInformation "Result of the Task is:" []
18 19 20 21
		>>=			return
		) // <<@ ApplyLayout frameCompact

:: TaskConstExpr = Apply TaskFuncExpr Expr | EnterInformation String Type | Bind TaskConstExpr TaskFuncExpr | Blind TaskConstExpr TaskConstExpr
Steffen Michels's avatar
Steffen Michels committed
22
				 | Or TaskConstExpr TaskConstExpr | And TaskConstExpr TaskConstExpr
Steffen Michels's avatar
Steffen Michels committed
23
				 | When TaskConstExpr [(FunExpr, String, TaskFuncExpr)]
24 25 26 27 28 29 30
:: 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
:: FunExpr	 	 = EqV Value | GrtV Value | LessV Value

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

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

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

44
taskEditor :: DynamicEditor TaskConstExpr
45 46 47
taskEditor = DynamicEditor conses
where
	conses =
48
		[ // This cons is used to provide untyped `TaskConstExpr` values.
49
		  DynamicCons $
50 51
			functionConsDyn "TaskConstExpr" "(enter task)"
				(dynamic \(Typed taskExpr) -> taskExpr :: A.a: (Typed TaskConstExpr a) -> TaskConstExpr)
52
		  <<@@@ HideIfOnlyChoice
53
		, DynamicConsGroup "Combinators"
Steffen Michels's avatar
Steffen Michels committed
54
			[ functionConsDyn "Bind" ">>="
55 56 57 58 59
				(	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
60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
			, 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"
79
				(	dynamic \(Typed task1) (Typed steps) -> Typed (When task1 [(expr,pred,tfExpr)\\ (Typed expr,pred,Typed tfExpr) <- steps]) ::
Steffen Michels's avatar
Steffen Michels committed
80
					A.a b:
81
						(Typed TaskConstExpr (Task a)) (Typed [(Typed FunExpr (a -> Bool) , String, Typed TaskFuncExpr (a -> Task a))] (a -> Task b))
82 83
						-> Typed TaskConstExpr (Task b)
				)	 <<@@@ applyHorizontalClasses
Steffen Michels's avatar
Steffen Michels committed
84 85
			, listConsDyn "[(FunExpr, String, TaskFuncExpr)]" "[(FunExpr, String, TaskFuncExpr)]"
				(	dynamic \typedSteps -> Typed ((\(Typed expr) -> expr) <$> typedSteps) ::
86
					A.a b:
Steffen Michels's avatar
Steffen Michels committed
87 88 89 90 91
						[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) ::
92
					A.a b:
Steffen Michels's avatar
Steffen Michels committed
93
						(Typed FunExpr a) String (Typed TaskFuncExpr (a -> Task b))
Steffen Michels's avatar
Steffen Michels committed
94 95 96 97
						-> Typed (FunExpr, String, TaskFuncExpr) (a -> Task b)
				)
				<<@@@ HideIfOnlyChoice
			]
98
		, DynamicConsGroup "Editors"
Steffen Michels's avatar
Steffen Michels committed
99 100 101
			[ 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)
102
				)
Steffen Michels's avatar
Steffen Michels committed
103
			, functionConsDyn "EnterInformation" "enter information"
104 105
				(	dynamic \s (Typed type) -> Typed (EnterInformation s type) ::
					A.a: String (Typed Type a) -> Typed TaskConstExpr (Task a)
106
				) <<@@@ applyHorizontalClasses
107
			, functionConsDyn "ViewInformation" "view information"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
108
				(	dynamic \s -> Typed (ViewInformation s) ::
109 110
					A.a: String -> Typed TaskFuncExpr (a -> Task a)
				)  <<@@@ applyHorizontalClasses
Steffen Michels's avatar
Steffen Michels committed
111
			, functionConsDyn "UpdateInformation" "update information"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
112
				(	dynamic \s -> Typed (UpdateInformation s) ::
113 114
					A.a: String -> Typed TaskFuncExpr (a -> Task a)
				)  <<@@@ applyHorizontalClasses
Steffen Michels's avatar
Steffen Michels committed
115
			, functionConsDyn "Return" "return"
Tim Steenvoorden's avatar
Tim Steenvoorden committed
116
				(	dynamic Typed Return ::
117 118
					A.a: Typed TaskFuncExpr (a -> Task a)
				)
119
			]
Steffen Michels's avatar
Steffen Michels committed
120

121
		// ordinary (non-task) expressions
Steffen Michels's avatar
Steffen Michels committed
122 123 124

		, DynamicCons $ functionConsDyn "EqV"   "equal"
			(dynamic \i -> Typed (EqV (VInt i))  :: Int  -> Typed FunExpr Int)
125
			<<@@@ applyHorizontalClasses
Steffen Michels's avatar
Steffen Michels committed
126 127
		, DynamicCons $ functionConsDyn "GrtV"   "greater"
			(dynamic \i -> Typed (GrtV (VInt i))  :: Int  -> Typed FunExpr Int)
128
			<<@@@ applyHorizontalClasses
Steffen Michels's avatar
Steffen Michels committed
129 130
		, DynamicCons $ functionConsDyn "LessV"   "less"
			(dynamic \i -> Typed (LessV (VInt i))  :: Int  -> Typed FunExpr Int)
131
			<<@@@ applyHorizontalClasses
132
		, DynamicCons $ functionConsDyn "int"   "enter an integer:"
133
			(dynamic \i -> Typed (Int i)  :: Int  -> Typed Expr Int)
134
		, DynamicCons $ functionConsDyn "bool"  "enter a boolean:"
135
			(dynamic \b -> Typed (Bool b) :: Bool -> Typed Expr Bool)
136 137
		, DynamicCons $ functionConsDyn "string"  "enter a string:"
			(dynamic \s -> Typed (String s) :: String -> Typed Expr String)
138 139 140 141 142 143
		, 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)
144
			<<@@@ applyHorizontalClasses
145 146
		, DynamicCons $ functionConsDyn "snd"   "snd"
			(dynamic \(Typed (Tuple _ b)) -> Typed b :: A.a b: (Typed Expr (a, b)) -> Typed Expr b)
147
			<<@@@ applyHorizontalClasses
148 149 150 151
		, DynamicCons $ functionConsDyn "=="    "=="
			(	dynamic \(Typed a) (Typed b) -> Typed (Eq a b) ::
				A.a: (Typed Expr a) (Typed Expr a) -> Typed Expr Bool
			)
152
			<<@@@ applyHorizontalClasses
153 154
		, DynamicCons $ customEditorCons "Int"   "(enter integer)" intEditor  <<@@@ HideIfOnlyChoice
		, DynamicCons $ customEditorCons "Bool"  "(enter boolean)" boolEditor <<@@@ HideIfOnlyChoice
155
		, DynamicCons $ customEditorCons "String""(enter string )" stringEditor <<@@@ HideIfOnlyChoice
Steffen Michels's avatar
Steffen Michels committed
156

157
		// type specifications for enterInformation
Steffen Michels's avatar
Steffen Michels committed
158

159 160 161 162
		, 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"
163 164 165 166 167
			(	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)
168
			) <<@@@ applyHorizontalClasses
169 170
		]

171 172 173 174 175 176
	derivedType :: Typed Type a | iTask a
	derivedType = case dynToValue of
		(toValue :: a^ -> Value | iTask a^) = Typed (Type toValue)
	where
		dynToValue = dynamic ()

177 178 179 180 181 182
	intEditor :: Editor Int
	intEditor = gEditor{|*|}

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

183 184 185 186
	stringEditor :: Editor String
	stringEditor = gEditor{|*|}


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

189
evalTaskConstExpr :: TaskConstExpr -> Task Value
190 191
evalTaskConstExpr (EnterInformation prompt (Type toValue)) = enterInformation prompt [] @ toValue
evalTaskConstExpr (Apply taskFunc expr)             =	evalTaskFuncExpr taskFunc $ evalExpr expr
Tim Steenvoorden's avatar
Tim Steenvoorden committed
192
evalTaskConstExpr (Bind task taskFunc)              = 	evalTaskConstExpr task
193
													>>= evalTaskFuncExpr taskFunc
Tim Steenvoorden's avatar
Tim Steenvoorden committed
194
evalTaskConstExpr (Blind task1 task2)             	= 	evalTaskConstExpr task1
195
													>>| evalTaskConstExpr task2
Tim Steenvoorden's avatar
Tim Steenvoorden committed
196 197
evalTaskConstExpr (Or task1 task2)             		= 	evalTaskConstExpr task1
													-||-
198
														evalTaskConstExpr task2
Tim Steenvoorden's avatar
Tim Steenvoorden committed
199 200
evalTaskConstExpr (And task1 task2)             	= 	evalTaskConstExpr task1
													-&&-
201
														evalTaskConstExpr task2 @ \(a,b) -> VTuple a b
Tim Steenvoorden's avatar
Tim Steenvoorden committed
202
evalTaskConstExpr (When task1 options)				= 	evalTaskConstExpr task1
203 204 205
													>>* [  OnAction (Action butName) (ifValue (test pred)(evalTaskFuncExpr taskFunc))
														\\ (pred, butName, taskFunc) <- options
														]
Steffen Michels's avatar
Steffen Michels committed
206
where
207
	test pred (VInt i) = case pred of
Steffen Michels's avatar
Steffen Michels committed
208 209 210
						(LessV (VInt j))  = i<j
						(GrtV  (VInt j))  = i>j
						(EqV   (VInt j))  = i==j
211 212 213
	test pred (VBool i) = case pred of
						(EqV   (VBool j))  = i==j
						(LessV (VBool j))  = False
214
						(GrtV  (VBool j))  = False
215 216

evalTaskFuncExpr :: TaskFuncExpr Value -> Task Value
217 218 219 220 221
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
Tim Steenvoorden's avatar
Tim Steenvoorden committed
222
													   -&&-
223 224 225 226 227
													   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 [] () ||-
228
													   evalTaskFuncExpr (UpdateInformation "") a 
Tim Steenvoorden's avatar
Tim Steenvoorden committed
229
													   -&&-
230 231
													   evalTaskFuncExpr (UpdateInformation "" )b @ \(a,b) -> VTuple a b) <<@ ApplyLayout arrangeHorizontal
evalTaskFuncExpr Return value 						= return value
Steffen Michels's avatar
Steffen Michels committed
232

233 234

evalExpr :: Expr -> Value
235 236
evalExpr (Int i)                 = VInt i
evalExpr (Bool b)                = VBool b
237
evalExpr (String s)              = VString s
238 239 240 241 242 243 244 245
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