Controls.icl 6.5 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 10 11 12
import iTasks.UI.Definition
import iTasks.UI.Editor.Modifiers

disableOnView e = selectByMode (withAttributes (enabledAttr False) e) e e

13 14
textField :: Editor String
textField = fieldComponent toJSON UITextField
15

16 17
textArea :: Editor String
textArea = fieldComponent toJSON UITextArea
18

19 20
passwordField :: Editor String
passwordField = fieldComponent toJSON UIPasswordField
21

22 23
integerField :: Editor Int
integerField = fieldComponent toJSON UIIntegerField
Bas Lijnse's avatar
Bas Lijnse committed
24

25 26
decimalField :: Editor Real
decimalField = fieldComponent toJSON UIDecimalField
27

28 29
documentField :: Editor (!String,!String,!String,!String,!Int)
documentField = fieldComponent toJSON UIDocumentField
30

31 32
checkBox :: Editor Bool
checkBox = fieldComponent toJSON UICheckbox
33

34 35
slider :: Editor Int
slider = fieldComponent toJSON UISlider
Bas Lijnse's avatar
Bas Lijnse committed
36

37 38
button :: Editor Bool
button = fieldComponent toJSON UIButton
Bas Lijnse's avatar
Bas Lijnse committed
39

40 41
label :: Editor String
label = viewComponent (\text -> (textAttr text)) UILabel
42

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

46 47
textView :: Editor String
textView = viewComponent (\text -> valueAttr (JSONString text)) UITextView
48

49 50
htmlView :: Editor HtmlTag
htmlView = viewComponent (\html -> valueAttr (JSONString (toString html))) UIHtmlView
51

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

60 61
checkGroup :: Editor ([ChoiceText], [Int])
checkGroup = choiceComponent (const 'DM'.newMap) id toOptionText checkBoundsText UICheckGroup
62

63 64
choiceList :: Editor ([ChoiceText], [Int])
choiceList = choiceComponent (const 'DM'.newMap) id toOptionText checkBoundsText UIChoiceList
65 66 67

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

69 70
grid :: Editor (ChoiceGrid, [Int])
grid = choiceComponent (\{ChoiceGrid|header} -> columnsAttr header) (\{ChoiceGrid|rows} -> rows) toOption checkBounds UIGrid
71
where
72 73
	toOption {ChoiceRow|id,cells}= JSONObject [("id",JSONInt id),("cells",JSONArray (map (JSONString o toString) cells))]
	checkBounds options idx = or [id == idx \\ {ChoiceRow|id} <- options]
74

75 76
tree :: Editor ([ChoiceNode], [Int])
tree = choiceComponent (const 'DM'.newMap) id toOption checkBounds UITree
77 78 79 80
where
	toOption {ChoiceNode|id,label,icon,expanded,children}
		= JSONObject [("text",JSONString label)
					 ,("iconCls",maybe JSONNull (\i -> JSONString ("icon-"+++i)) icon)
81
					 ,("id",JSONInt id)
82 83 84 85
					 ,("expanded",JSONBool expanded)
					 ,("children",JSONArray (map toOption children))
					]

86
	checkBounds options idx 
87 88 89 90
		= or (map (checkNode idx) options)
	checkNode idx {ChoiceNode|id,children}
		| idx == id = True
		| otherwise = or (map (checkNode idx) children)
91

92
//Field like components for which simply knowing the UI type is sufficient
93
fieldComponent toValue type = disableOnView {Editor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh}
94
where 
95 96
	genUI dp val vst=:{VSt|taskId,mode,optional}
		# val = if (mode =: Enter) JSONNull (toValue val) 
97 98
		# 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}
99
		# attr = 'DM'.unions [optionalAttr optional, taskIdAttr taskId, editorIdAttr (editorId dp), valueAttr val]
Bas Lijnse's avatar
Bas Lijnse committed
100
		= (Ok (uia type attr,mask),vst)
101

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

109 110 111 112
	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)

113 114 115 116
//Components which cannot be edited 
viewComponent toAttributes type = {Editor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh}
where
	genUI dp val vst
117
		= (Ok (uia type (toAttributes val), FieldMask {touched = False, valid = True, state = JSONNull}),vst)
118 119 120 121 122

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

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

127
//Choice components that have a set of options
128
choiceComponent attr getOptions toOption checkBounds type = {Editor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh}
129 130 131 132
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}
133
		# attr = 'DM'.unions [attr val,choiceAttrs taskId (editorId dp) sel (map toOption (getOptions val))]
134 135 136 137 138 139
		= (Ok (uia type attr,mask), vst)

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

150 151 152 153 154 155 156 157
	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)