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

3
import StdEnv
4
import iTasks.UI.Definition, iTasks.UI.Editor
5
import Data.GenEq, Data.Error, Text.GenJSON, Text.HTML, Data.Func, Data.Functor, Data.Tuple, Data.List, Data.Maybe, Data.Map.GenJSON
6 7
import qualified Data.Map as DM

Mart Lubbers's avatar
Mart Lubbers committed
8
import iTasks.WF.Derives
9 10 11
import iTasks.UI.Definition
import iTasks.UI.Editor.Modifiers

Steffen Michels's avatar
Steffen Michels committed
12
disableOnView e = selectByMode (e <<@ enabledAttr False) e e
13

14
textField :: Editor String
15
textField = fieldComponent UITextField (Just "") isValidString
16

17
textArea :: Editor String
18
textArea = fieldComponent UITextArea (Just "") isValidString
19

20
passwordField :: Editor String
21 22 23 24 25 26 27 28 29 30 31 32
passwordField = fieldComponent UIPasswordField (Just "") isValidString

isValidString :: !UIAttributes !String -> Bool
isValidString attrs str
	= lStr >= getLengthAttr 0 "minlength" && lStr <= getLengthAttr lStr "maxlength"
where
	getLengthAttr :: !Int !String -> Int
	getLengthAttr default attr = case 'DM'.get attr attrs of
		Just (JSONInt l) = l
		_                = default

	lStr = size str
33

34
integerField :: Editor Int
35
integerField = fieldComponent UIIntegerField Nothing (\_ _ -> True)
Bas Lijnse's avatar
Bas Lijnse committed
36

37
decimalField :: Editor Real
38
decimalField = fieldComponent UIDecimalField Nothing (\_ _ -> True)
39

40
documentField :: Editor (!String,!String,!String,!String,!Int)
41
documentField = fieldComponent UIDocumentField Nothing (\_ _ -> True)
42

43
checkBox :: Editor Bool
44
checkBox = fieldComponent UICheckbox (Just False) (\_ _ -> True)
45

46
slider :: Editor Int
47
slider = fieldComponent UISlider Nothing (\_ _ -> True)
Bas Lijnse's avatar
Bas Lijnse committed
48

49
button :: Editor Bool
50
button = fieldComponent UIButton Nothing (\_ _ -> True)
Bas Lijnse's avatar
Bas Lijnse committed
51

52
label :: Editor String
Steffen Michels's avatar
Steffen Michels committed
53
label = viewComponent textAttr UILabel
54

55
icon :: Editor (!String,!Maybe String)
Steffen Michels's avatar
Steffen Michels committed
56 57
icon = viewComponent (\(iconCls,tooltip) -> 'DM'.unions [iconClsAttr iconCls,maybe 'DM'.newMap tooltipAttr tooltip])
                     UIIcon
58

59
textView :: Editor String
Steffen Michels's avatar
Steffen Michels committed
60
textView = viewComponent (valueAttr o JSONString o escapeStr) UITextView
61

62
htmlView :: Editor HtmlTag
Steffen Michels's avatar
Steffen Michels committed
63
htmlView = viewComponent (valueAttr o JSONString o toString) UIHtmlView
64

65 66
progressBar :: Editor (Maybe Int, Maybe String)
progressBar = viewComponent combine UIProgressBar
67
where
Steffen Michels's avatar
Steffen Michels committed
68 69
	combine (amount,text) =
		'DM'.unions ((maybe [] (\t -> [textAttr t]) text) ++ (maybe [] (\v -> [valueAttr (JSONInt v)]) amount))
70
						
71 72
dropdown :: Editor ([ChoiceText], [Int])
dropdown = choiceComponent (const 'DM'.newMap) id toOptionText checkBoundsText UIDropdown
73

74 75
checkGroup :: Editor ([ChoiceText], [Int])
checkGroup = choiceComponent (const 'DM'.newMap) id toOptionText checkBoundsText UICheckGroup
76

77 78
choiceList :: Editor ([ChoiceText], [Int])
choiceList = choiceComponent (const 'DM'.newMap) id toOptionText checkBoundsText UIChoiceList
79

80 81 82
tabBar :: Editor ([ChoiceText], [Int])
tabBar = choiceComponent (const 'DM'.newMap) id toOptionText checkBoundsText UITabBar

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

Steffen Michels's avatar
Steffen Michels committed
86 87 88
derive JSONEncode ChoiceText
derive JSONDecode ChoiceText

89 90
grid :: Editor (ChoiceGrid, [Int])
grid = choiceComponent (\{ChoiceGrid|header} -> columnsAttr header) (\{ChoiceGrid|rows} -> rows) toOption checkBounds UIGrid
91
where
92 93
	toOption {ChoiceRow|id,cells}= JSONObject [("id",JSONInt id),("cells",JSONArray (map (JSONString o toString) cells))]
	checkBounds options idx = or [id == idx \\ {ChoiceRow|id} <- options]
94

Steffen Michels's avatar
Steffen Michels committed
95 96 97
derive JSONEncode ChoiceGrid, ChoiceRow
derive JSONDecode ChoiceGrid, ChoiceRow

98 99
tree :: Editor ([ChoiceNode], [Int])
tree = choiceComponent (const 'DM'.newMap) id toOption checkBounds UITree
100 101 102 103
where
	toOption {ChoiceNode|id,label,icon,expanded,children}
		= JSONObject [("text",JSONString label)
					 ,("iconCls",maybe JSONNull (\i -> JSONString ("icon-"+++i)) icon)
104
					 ,("id",JSONInt id)
105 106 107 108
					 ,("expanded",JSONBool expanded)
					 ,("children",JSONArray (map toOption children))
					]

109
	checkBounds options idx 
110 111 112 113
		= or (map (checkNode idx) options)
	checkNode idx {ChoiceNode|id,children}
		| idx == id = True
		| otherwise = or (map (checkNode idx) children)
114

Steffen Michels's avatar
Steffen Michels committed
115 116 117
derive JSONEncode ChoiceNode
derive JSONDecode ChoiceNode

118 119 120 121 122 123 124 125
withConstantChoices :: !choices !(Editor (!choices, ![Int])) -> Editor [Int]
withConstantChoices choices editor = bijectEditorValue (\sel -> (choices, sel)) snd
                                     (withChangedEditMode editModeFor editor)
where
	// enter mode has to be changed to update mode to pass the choices to the editor
	editModeFor Enter = Update (choices, [])
	editModeFor other = other

126
//Field like components for which simply knowing the UI type is sufficient
127 128
fieldComponent
	:: !UIType !(Maybe a) !(UIAttributes a -> Bool) -> Editor a
129
	| JSONDecode{|*|}, JSONEncode{|*|}, gEq{|*|} a
130
fieldComponent type mbEditModeInitValue isValid = disableOnView $ editorWithJSONEncode (leafEditorToEditor o leafEditor)
131
where 
Steffen Michels's avatar
Steffen Michels committed
132 133 134
	leafEditor toJSON =
		{LeafEditor|genUI=genUI toJSON,onEdit=onEdit,onRefresh=onRefresh toJSON,valueFromState=valueFromState}

135
	genUI toJSON attr dp mode vst=:{VSt|taskId,optional}
136
		# mbVal   = maybe mbEditModeInitValue Just $ editModeValue mode
137
		# mbVal   = maybe Nothing (\val -> if (isValid attr val) (Just val) Nothing) mbVal
Steffen Michels's avatar
Steffen Michels committed
138 139 140
		# attr    = 'DM'.unions [ optionalAttr optional
		                        , taskIdAttr taskId
		                        , editorIdAttr $ editorId dp
141
		                        , valueAttr $ maybe JSONNull toJSON mbVal
142
		                        , attr
Steffen Michels's avatar
Steffen Michels committed
143
		                        ]
144
		= (Ok (uia type attr, (mbVal, attr)), vst)
Steffen Michels's avatar
Steffen Michels committed
145

146 147 148 149 150
	onEdit _ (_, mbVal) (_, attrs) vst = (Ok (NoChange, (mbVal`, attrs)), vst)
	where
		mbVal` = case mbVal of
			Just val | isValid attrs val = Just val
			_                            = Nothing
Steffen Michels's avatar
Steffen Michels committed
151

152 153 154
	onRefresh toJSON dp new (mbOld, attrs) vst
		| mbOld === Just new = (Ok (NoChange, (mbOld, attrs)), vst)
		| otherwise          = (Ok (ChangeUI [SetAttribute "value" (toJSON new)] [], (if (isValid attrs new) (Just new) Nothing, attrs)), vst)
Steffen Michels's avatar
Steffen Michels committed
155

156
	valueFromState (mbVal, _) = mbVal
Steffen Michels's avatar
Steffen Michels committed
157 158 159

	editorWithJSONEncode :: !((a -> JSONNode) -> Editor a) -> Editor a | JSONEncode{|*|} a
	editorWithJSONEncode genFunc = genFunc toJSON
160

161
//Components which cannot be edited 
Steffen Michels's avatar
Steffen Michels committed
162 163
viewComponent :: !(a -> UIAttributes) !UIType -> Editor a | JSONEncode{|*|}, JSONDecode{|*|} a
viewComponent toAttributes type = leafEditorToEditor leafEditor
164
where
Steffen Michels's avatar
Steffen Michels committed
165 166
	leafEditor = {LeafEditor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh,valueFromState=valueFromState}

167 168
	genUI attr dp mode vst = case editModeValue mode of
		Just val = (Ok (uia type ('DM'.union attr $ toAttributes val), val),                vst)
Steffen Michels's avatar
Steffen Michels committed
169 170 171 172 173 174 175 176 177 178 179 180 181 182 183
		_        = (Error "View components cannot be used in enter mode", vst)

	onEdit _ (_, ()) _ vst = (Error "Edit event for view component",vst)

	onRefresh dp new val vst = (Ok (changes, new), vst)
	where
        changes = case setChanges ++ delChanges of
			[]      = NoChange
			changes = ChangeUI changes []

		setChanges = [ SetAttribute key val
		             \\ (key, val) <- 'DM'.toList $ toAttributes new
		             | 'DM'.get key oldAttrs <> Just val
		             ]
		delChanges = [DelAttribute key \\ (key, _) <- 'DM'.toList $ 'DM'.difference oldAttrs newAttrs]
184

Steffen Michels's avatar
Steffen Michels committed
185 186
		oldAttrs = toAttributes val
		newAttrs = toAttributes new
187

Steffen Michels's avatar
Steffen Michels committed
188
	valueFromState val = Just val
189

190
//Choice components that have a set of options
Steffen Michels's avatar
Steffen Michels committed
191 192 193 194
choiceComponent :: !(a -> UIAttributes) !(a -> [o]) !(o -> JSONNode) !([o] Int -> Bool) !UIType -> Editor (!a, ![Int])
                 | JSONEncode{|*|}, JSONDecode{|*|} a
choiceComponent attr getOptions toOption checkBounds type = disableOnView $
	leafEditorToEditor {LeafEditor|genUI=genUI,onEdit=onEdit,onRefresh=onRefresh,valueFromState=valueFromState}
195
where
196
	genUI attrs dp mode vst=:{VSt|taskId}
Steffen Michels's avatar
Steffen Michels committed
197
		# (mbVal, sel) = maybe (Nothing, []) (appFst Just) $ editModeValue mode
198
		# attr = 'DM'.unions [attrs, maybe 'DM'.newMap attr mbVal, choiceAttrs taskId (editorId dp) sel $ mbValToOptions mbVal]
Steffen Michels's avatar
Steffen Michels committed
199

200 201 202 203
		# multiple = maybe False (\(JSONBool b) -> b) ('DM'.get "multiple" attr)
		= (Ok (uia type attr, (mbVal, sel, multiple)), vst)

	onEdit dp (tp, selection) (mbVal, sel, multiple) vst=:{VSt|optional}
Steffen Michels's avatar
Steffen Michels committed
204 205
		# options = maybe [] getOptions mbVal
		| all (checkBounds options) selection
206
			= (Ok (NoChange, (mbVal, selection, multiple)),vst)
Steffen Michels's avatar
Steffen Michels committed
207 208 209
		| otherwise
			= (Error ("Choice event out of bounds: " +++ toString (toJSON selection)), vst)

210
	onRefresh dp (newVal, newSel) (mbOldVal, oldSel, multiple) vst
211
		//Check options
212 213 214 215 216
		# oldOptsJson        = mbValToOptions mbOldVal
		# newOpts            = getOptions newVal
		# newOptsJson        = toOption <$> newOpts
		# cOptions           = if (newOptsJson =!= oldOptsJson)
		                          (ChangeUI [SetAttribute "options" (JSONArray newOptsJson)] [])
Steffen Michels's avatar
Steffen Michels committed
217
		                          NoChange
218 219
		//Check selection, if the selection is out of bounds assume the empty selection
		# newSel             = if (all (checkBounds newOpts) newSel) newSel []
Steffen Michels's avatar
Steffen Michels committed
220
		# cSel               = if (newSel =!= oldSel) (ChangeUI [SetAttribute "value" (toJSON newSel)] []) NoChange
221
		= (Ok (mergeUIChanges cOptions cSel, (Just newVal, newSel, multiple)),vst)
Steffen Michels's avatar
Steffen Michels committed
222

223 224
	valueFromState (Just val, sel, multiple)
		//The selection is only allowed to be empty when multiselect is enabled
225 226 227 228
		| not multiple && lengthSel <> 0 && lengthSel <> 1 = Nothing
		| otherwise                                        = Just (val, sel)
	where
		lengthSel = length sel
Steffen Michels's avatar
Steffen Michels committed
229 230 231
	valueFromState _               = Nothing

	mbValToOptions mbVal = toOption <$> maybe [] getOptions mbVal