Controls.icl 6.35 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 :: Editor String
textField = fieldComponent toJSON UITextField
10

11 12
textArea :: Editor String
textArea = fieldComponent toJSON UITextArea
13

14 15
passwordField :: Editor String
passwordField = fieldComponent toJSON UIPasswordField
16

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

20 21
decimalField :: Editor Real
decimalField = fieldComponent toJSON UIDecimalField
22

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

26 27
checkBox :: Editor Bool
checkBox = fieldComponent toJSON UICheckbox
28

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

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

35 36
label :: Editor String
label = viewComponent (\text -> (textAttr text)) UILabel
37

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

41 42
textView :: Editor String
textView = viewComponent (\text -> valueAttr (JSONString text)) UITextView
43

44 45
htmlView :: Editor HtmlTag
htmlView = viewComponent (\html -> valueAttr (JSONString (toString html))) UIHtmlView
46

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

55 56
checkGroup :: Editor ([ChoiceText], [Int])
checkGroup = choiceComponent (const 'DM'.newMap) id toOptionText checkBoundsText UICheckGroup
57

58 59
choiceList :: Editor ([ChoiceText], [Int])
choiceList = choiceComponent (const 'DM'.newMap) id toOptionText checkBoundsText UIChoiceList
60 61 62

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

64 65
grid :: Editor (ChoiceGrid, [Int])
grid = choiceComponent (\{ChoiceGrid|header} -> 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 :: Editor ([ChoiceNode], [Int])
tree = choiceComponent (const 'DM'.newMap) 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 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 [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)