DynEditorExample.icl 7.99 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 81 82
			[ 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)
				) <<@@@ ApplyCssClasses["horizontal"] // don't know css class names to choose from 
			, functionConsDyn "EnterInformation" "enter information"
83 84 85 86
				(	dynamic \(Typed type) -> Typed (EnterInformation type) ::
					A.a: (Typed Type a) -> Typed TaskConstExpr (Task a)
				)
			, 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 98 99 100 101 102

		, DynamicCons $ functionConsDyn "EqV"   "equal"
			(dynamic \i -> Typed (EqV (VInt i))  :: Int  -> Typed FunExpr Int)
		, DynamicCons $ functionConsDyn "GrtV"   "greater"
			(dynamic \i -> Typed (GrtV (VInt i))  :: Int  -> Typed FunExpr Int)
		, DynamicCons $ functionConsDyn "LessV"   "less"
			(dynamic \i -> Typed (LessV (VInt i))  :: Int  -> Typed FunExpr Int)

103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
		, 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)
		, DynamicCons $ functionConsDyn "snd"   "snd"
			(dynamic \(Typed (Tuple _ b)) -> Typed b :: A.a b: (Typed Expr (a, b)) -> Typed Expr b)
		, DynamicCons $ functionConsDyn "=="    "=="
			(	dynamic \(Typed a) (Typed b) -> Typed (Eq a b) ::
				A.a: (Typed Expr a) (Typed Expr a) -> Typed Expr Bool
			)
		, DynamicCons $ customEditorCons "Int"   "(enter integer)" intEditor  <<@@@ HideIfOnlyChoice
		, DynamicCons $ customEditorCons "Bool"  "(enter boolean)" boolEditor <<@@@ HideIfOnlyChoice
Steffen Michels's avatar
Steffen Michels committed
121

122
		// type specifications for enterInformation
Steffen Michels's avatar
Steffen Michels committed
123

124 125 126 127 128 129 130 131 132
		, 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)
			)
133 134
		, DynamicCons $ functionConsDyn "Type.?" "(derived type)"
			(dynamic derivedType :: A.a: Typed Type a | iTask a)
135 136
		]

137 138 139 140 141 142
	derivedType :: Typed Type a | iTask a
	derivedType = case dynToValue of
		(toValue :: a^ -> Value | iTask a^) = Typed (Type toValue)
	where
		dynToValue = dynamic ()

143 144 145 146 147 148
	intEditor :: Editor Int
	intEditor = gEditor{|*|}

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

149
evalTaskConstExpr :: TaskConstExpr -> Task Value
Steffen Michels's avatar
Steffen Michels committed
150
evalTaskConstExpr (EnterInformation (Type toValue)) = enterInformation () [] @ toValue
151 152
evalTaskConstExpr (Apply taskFunc expr)             = evalTaskFuncExpr taskFunc $ evalExpr expr
evalTaskConstExpr (Bind task taskFunc)              = evalTaskConstExpr task >>= evalTaskFuncExpr taskFunc
Steffen Michels's avatar
Steffen Michels committed
153 154 155 156 157 158 159 160 161 162 163
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
164 165

evalTaskFuncExpr :: TaskFuncExpr Value -> Task Value
Steffen Michels's avatar
Steffen Michels committed
166 167 168 169 170 171 172 173
evalTaskFuncExpr ViewInformation (VInt i)		= viewInformation () [] i @ VInt
evalTaskFuncExpr ViewInformation (VBool b)		= viewInformation () [] b @ VBool
evalTaskFuncExpr ViewInformation (VTuple a b)	= evalTaskFuncExpr ViewInformation a -&&- evalTaskFuncExpr ViewInformation b @ \(a,b) -> VTuple a b 
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

174 175

evalExpr :: Expr -> Value
176 177 178 179 180 181 182 183 184 185
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
186