Controls.icl 6.85 KB
Newer Older
1
implementation module iTasks.UI.Editor.Controls
2 3

import iTasks.UI.Definition, iTasks.UI.Editor
4
import StdFunc, StdBool, GenEq
Bas Lijnse's avatar
Bas Lijnse committed
5
import Data.Error, Text.JSON, Text.HTML
6 7
import qualified Data.Map as DM

8 9
textField :: UIAttributes -> Editor String
textField attr = fieldComponent attr toJSON UITextField
10

11 12
textArea :: UIAttributes -> Editor String
textArea attr = fieldComponent attr toJSON UITextArea
13

14 15
passwordField :: UIAttributes -> Editor String
passwordField attr = fieldComponent attr toJSON UIPasswordField
16

17 18
integerField :: UIAttributes -> Editor Int
integerField attr = fieldComponent attr toJSON UIIntegerField
Bas Lijnse's avatar
Bas Lijnse committed
19

20 21
decimalField :: UIAttributes -> Editor Real
decimalField attr = fieldComponent attr toJSON UIDecimalField
22

23
documentField :: UIAttributes -> Editor (!String,!String,!String,!String,!Int)
24
documentField attr = fieldComponent attr toJSON UIDocumentField
25

26 27
checkBox :: UIAttributes -> Editor Bool
checkBox attr = fieldComponent attr toJSON UICheckbox
28

29 30
slider :: UIAttributes -> Editor Int
slider attr = fieldComponent attr toJSON UISlider
Bas Lijnse's avatar
Bas Lijnse committed
31

32 33
button :: UIAttributes -> Editor Bool
button attr = fieldComponent attr toJSON UIButton
Bas Lijnse's avatar
Bas Lijnse committed
34

35
label :: UIAttributes -> Editor String
36
label attr = viewComponent (\text -> 'DM'.union attr (textAttr text)) UILabel
37

38
icon :: UIAttributes -> Editor (!String,!Maybe String)
39
icon attr = viewComponent (\(iconCls,tooltip) -> 'DM'.unions [iconClsAttr iconCls,maybe 'DM'.newMap tooltipAttr tooltip,attr]) UIIcon
40

41 42
textView :: UIAttributes -> Editor String
textView attr = viewComponent (\text -> 'DM'.fromList [("value",JSONString text)]) UITextView
43

44 45
htmlView :: UIAttributes -> Editor HtmlTag
htmlView attr = viewComponent (\html -> 'DM'.union (valueAttr (JSONString (toString html))) attr) UIHtmlView
46

47 48 49 50 51
progressBar :: UIAttributes -> Editor (Maybe Int, Maybe String)
progressBar attr = viewComponent combine UIProgressBar
where
	combine (amount,text) = 'DM'.unions ((maybe [] (\t -> [textAttr t]) text) ++ (maybe [] (\v -> [valueAttr (JSONInt v)]) amount) ++ [attr])
						
52 53
dropdown :: UIAttributes -> Editor ([ChoiceText], [Int])
dropdown attr = choiceComponent (const attr) id toOptionText checkBoundsText UIDropdown
54

55 56
checkGroup    :: UIAttributes -> Editor ([ChoiceText], [Int])
checkGroup attr = choiceComponent (const attr) id toOptionText checkBoundsText UICheckGroup
57

58 59 60 61 62
choiceList :: UIAttributes -> Editor ([ChoiceText], [Int])
choiceList attr = choiceComponent (const attr) id toOptionText checkBoundsText UIChoiceList

toOptionText {ChoiceText|id,text}= JSONObject [("id",JSONInt id),("text",JSONString text)]
checkBoundsText options idx = or [id == idx \\ {ChoiceText|id} <- options]
63

64
grid :: UIAttributes -> Editor (ChoiceGrid, [Int])
65
grid attr = choiceComponent (\{ChoiceGrid|header} -> 'DM'.union attr (columnsAttr header)) (\{ChoiceGrid|rows} -> rows) toOption checkBounds UIGrid
66
where
67 68
	toOption {ChoiceRow|id,cells}= JSONObject [("id",JSONInt id),("cells",JSONArray (map (JSONString o toString) cells))]
	checkBounds options idx = or [id == idx \\ {ChoiceRow|id} <- options]
69

70 71
tree :: UIAttributes -> Editor ([ChoiceNode], [Int])
tree attr = choiceComponent (const attr) id toOption checkBounds UITree
72 73 74 75
where
	toOption {ChoiceNode|id,label,icon,expanded,children}
		= JSONObject [("text",JSONString label)
					 ,("iconCls",maybe JSONNull (\i -> JSONString ("icon-"+++i)) icon)
76
					 ,("id",JSONInt id)
77 78 79 80
					 ,("expanded",JSONBool expanded)
					 ,("children",JSONArray (map toOption children))
					]

81
	checkBounds options idx 
82 83 84 85
		= or (map (checkNode idx) options)
	checkNode idx {ChoiceNode|id,children}
		| idx == id = True
		| otherwise = or (map (checkNode idx) children)
86

87
//Field like components for which simply knowing the UI type is sufficient
88
fieldComponent attr toValue type = {Editor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh}
89
where 
90 91
	genUI dp val vst=:{VSt|taskId,mode,optional}
		# val = if (mode =: Enter) JSONNull (toValue val) 
92 93
		# valid = if (mode =: Enter) optional True //When entering data a value is initially only valid if it is optional
		# mask = FieldMask {touched = False, valid = valid, state = val}
94
		# attr = 'DM'.unions [attr,optionalAttr optional, taskIdAttr taskId, editorIdAttr (editorId dp), valueAttr val]
Bas Lijnse's avatar
Bas Lijnse committed
95
		= (Ok (uia type attr,mask),vst)
96

97
	onEdit dp (tp,e) val mask vst=:{VSt|optional}
98
		= case e of
99
			JSONNull = (Ok (ChangeUI [SetAttribute "value" JSONNull] [],FieldMask {touched=True,valid=optional,state=JSONNull}),val,vst)
100
			json = case fromJSON e of
101
				Nothing  = (Ok (NoChange,FieldMask {touched=True,valid=False,state=e}),val,vst)
102
				Just val = (Ok (ChangeUI [SetAttribute "value" (toValue val)] [],FieldMask {touched=True,valid=True,state=toValue val}),val,vst)
103

104 105 106 107
	onRefresh dp new old mask vst=:{VSt|mode,optional}
		| old === new = (Ok (NoChange,mask),new,vst)
		| otherwise   = (Ok (ChangeUI [SetAttribute "value" (toValue new)] [],mask),new,vst)

108 109 110 111
//Components which cannot be edited 
viewComponent toAttributes type = {Editor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh}
where
	genUI dp val vst
112
		= (Ok (uia type (toAttributes val), FieldMask {touched = False, valid = True, state = JSONNull}),vst)
113 114 115 116 117

	onEdit dp (tp,e) val mask vst
		= (Error "Edit event for view component",val,vst)

	onRefresh dp new old mask vst
118
		= case [SetAttribute nk nv \\ ((ok,ov),(nk,nv)) <- zip ('DM'.toList (toAttributes old),'DM'.toList (toAttributes new)) | ok == nk && ov =!= nv] of
119 120 121
			[] 		= (Ok (NoChange,mask),new,vst)
			changes = (Ok (ChangeUI changes [],mask),new,vst)

122
//Choice components that have a set of options
123
choiceComponent attr getOptions toOption checkBounds type = {Editor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh}
124 125 126 127
where
	genUI dp (val,sel) vst=:{VSt|taskId,mode,optional}
		# valid = if (mode =: Enter) optional True //When entering data a value is initially only valid if it is optional
		# mask = FieldMask {touched = False, valid = valid, state = JSONNull}
128
		# attr = 'DM'.unions [attr val,choiceAttrs taskId (editorId dp) sel (map toOption (getOptions val))]
129 130 131 132 133 134
		= (Ok (uia type attr,mask), vst)

	onEdit dp (tp,e) (val,sel) mask vst=:{VSt|optional}
		# options = getOptions val
		= case e of
			JSONNull
135
				= (Ok (NoChange,FieldMask {touched=True,valid=optional,state=JSONNull}),(val,[]),vst)
136 137
			(JSONArray ids)
				# selection = [i \\ JSONInt i <- ids]
138
				| all (checkBounds options) selection
139
					= (Ok (NoChange,FieldMask {touched=True,valid=True,state=JSONArray ids}),(val,selection),vst)
140
				| otherwise
141
					= (Error ("Choice event out of bounds: " +++ toString (JSONArray ids)),(val,sel),vst)
142 143 144
			_ 
				= (Error ("Invalid choice event: " +++ toString e), (val,sel),vst)

145 146 147 148 149 150 151 152
	onRefresh dp (new,nsel) (old,osel) mask vst
		//Check options
		# oOpts = map toOption (getOptions old)
		# nOpts = map toOption (getOptions new)
		# cOptions= if (nOpts =!= oOpts) (ChangeUI [SetAttribute "options" (JSONArray nOpts)] []) NoChange
		# cSel = if (nsel =!= osel) (ChangeUI [SetAttribute "value" (toJSON nsel)] []) NoChange
		//Check selection
		= (Ok (mergeUIChanges cOptions cSel, mask),(new,nsel),vst)