Common.icl 13.3 KB
Newer Older
1 2
implementation module iTasks.UI.Editor.Common

3
import StdBool, StdEnum, StdOrdList, StdList, StdList, StdString, StdFunc
4
import Text.GenJSON, Data.GenEq, Data.List
5

6
import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.Editor.Containers, iTasks.UI.Editor.Controls, iTasks.UI.Editor.Modifiers
Steffen Michels's avatar
Steffen Michels committed
7
import Data.Tuple, Data.Error, Text, Text.GenJSON, Data.Func, Data.Functor
8
import Data.Error.GenJSON
9
import qualified Data.Map as DM
10
import Data.Maybe
11

Camil Staps's avatar
Camil Staps committed
12
emptyEditor :: Editor a w | TC a
13
emptyEditor = leafEditorToEditor {LeafEditor|onReset=onReset,onEdit=onEdit,onRefresh=onRefresh,writeValue=writeValue}
14 15
where
	// store initial value in state
16
	onReset attr _ mbVal vst      = (Ok (uia UIEmpty attr, mbVal, ?None),vst)
17 18
	onEdit _ (_, ()) mbVal vst = (Ok (NoChange, mbVal, ?None),vst)     // ignore edit events
	onRefresh _ val _ vst      = (Ok (NoChange, ?Just val, ?None),vst) // just use new value
19
	writeValue _ = Error "Empty editor can't write"
20

Bas Lijnse's avatar
Bas Lijnse committed
21
//TODO: Remove these special cases. They no longer make sense for the asymmetric editors
Camil Staps's avatar
Camil Staps committed
22 23
emptyEditorWithDefaultInEnterMode :: !w -> Editor a w | TC w
emptyEditorWithDefaultInEnterMode defaultValue = emptyEditorWithDefaultInEnterMode_
24 25 26 27
	(\st -> ?Just (dynamic st))
	(\dyn -> case dyn of
		?Just (st :: st^) -> ?Just st
		_                 -> ?None)
Camil Staps's avatar
Camil Staps committed
28
	defaultValue
Steffen Michels's avatar
Steffen Michels committed
29

30
emptyEditorWithDefaultInEnterMode_ :: !(w -> ?Dynamic) !((?Dynamic) -> ?w) !w -> Editor a w
Camil Staps's avatar
Camil Staps committed
31 32
emptyEditorWithDefaultInEnterMode_ encode decode defaultValue = leafEditorToEditor_
	encode decode
33
	{LeafEditor|onReset=onReset,onEdit=onEdit,onRefresh=onRefresh,writeValue=writeValue}
34
where
Steffen Michels's avatar
Steffen Michels committed
35
	// store initial value in state
36
	onReset attr _ _ vst    = (Ok (uia UIEmpty attr, defaultValue, ?None),vst)
37 38
	onEdit _ (_, ()) val vst = (Ok (NoChange, val, ?None),vst)   // ignore edit events
	onRefresh _ _ val vst    = (Ok (NoChange, val, ?None),vst)   // ignore refresh events
Bas Lijnse's avatar
Bas Lijnse committed
39
	writeValue _ = Ok defaultValue 
Steffen Michels's avatar
Steffen Michels committed
40

Camil Staps's avatar
Camil Staps committed
41 42
emptyEditorWithErrorInEnterMode :: !String -> Editor a w | TC a
emptyEditorWithErrorInEnterMode error = emptyEditorWithErrorInEnterMode_
43 44 45 46
	(\st -> ?Just (dynamic st))
	(\dyn -> case dyn of
		?Just (st :: st^) -> ?Just st
		_                 -> ?None)
Camil Staps's avatar
Camil Staps committed
47
	error
Steffen Michels's avatar
Steffen Michels committed
48

49
emptyEditorWithErrorInEnterMode_ :: !(a -> ?Dynamic) !((?Dynamic) -> ?a) !String -> Editor a w
Camil Staps's avatar
Camil Staps committed
50
emptyEditorWithErrorInEnterMode_ encode decode error = leafEditorToEditor_ encode decode
51
	{LeafEditor|onReset=onReset,onEdit=onEdit,onRefresh=onRefresh,writeValue=writeValue}
Steffen Michels's avatar
Steffen Michels committed
52 53
where
	// store initial value in state
54 55
	onReset attr _ mbval vst = case mbval of
		= (maybe (Error error) (\val -> Ok (uia UIEmpty attr, val, ?None)) mbval, vst)
56 57
	onEdit _ (_, ()) val vst = (Ok (NoChange, val, ?None),vst)   // ignore edit events
	onRefresh _ val _ vst    = (Ok (NoChange, val, ?None),vst)   // just use new value
Bas Lijnse's avatar
Bas Lijnse committed
58
	writeValue _ = Error error
59

60
diffChildren :: ![a] ![a] !(a a -> ChildUpdate) !(a -> UI) -> [(Int, UIChildChange)]
61
diffChildren old new updateFromOldToNew toUI = diffChildren` (length old - 1) (reverse old) (reverse new)
62
where
63
    // only children from old list are left -> remove them all
64
    diffChildren` _ old [] = removeRemaining old
65
    // only new children are left -> insert them all
66
    diffChildren` _ [] new = addNew new
67 68 69 70
    diffChildren` idx [nextOld : old] [nextNew : new] = case updateFromOldToNew nextOld nextNew of
        ChildUpdateImpossible
            | isEmpty $ filter (\n -> not $ (updateFromOldToNew nextOld n) =: ChildUpdateImpossible) new
                // old item cannot be reused, as no remaining new item can be updated to it -> remove it
71
                 = [(idx, RemoveChild) : diffChildren` (dec idx) old [nextNew : new]]
72
            | otherwise
73 74
                # (change, idx, old`) = moveFromOldOrInsert (dec idx) old
                = change ++ diffChildren` idx [nextOld : old`] new
75 76
            where
                // no item found which can be updated to next new child -> insert it
77
                moveFromOldOrInsert _ [] = ([(inc idx, InsertChild $ toUI nextNew)], idx, [])
78 79
                moveFromOldOrInsert idxOld [nextOld : oldRest] = case updateFromOldToNew nextOld nextNew of
                    // look for child to reuse in remaining old children elements
80 81
                    ChildUpdateImpossible = appThd3 (\old` -> [nextOld : old`])
                                                    (moveFromOldOrInsert (dec idxOld) oldRest)
82
                    // move item without change
83
                    NoChildUpdateRequired = ([(idxOld, MoveChild idx)], dec idx, oldRest)
84 85
                    // old item which can be updated to next new child found -> reuse it,
                    // i.e. move it to new index & update
86 87 88 89 90
                    ChildUpdate change
                        | idxOld == idx = ([(idx, ChangeChild change)], dec idx, oldRest)
                        | otherwise     = ([(idxOld, MoveChild idx), (idx, ChangeChild change)], dec idx, oldRest)
        NoChildUpdateRequired = diffChildren` (dec idx) old new
        ChildUpdate change    = [(idx, ChangeChild change): diffChildren` (dec idx) old new]
91

92 93
    removeRemaining rem = [(0, RemoveChild) \\ _ <- rem]
    addNew          new = [(0, InsertChild (toUI x)) \\ x <- new]
94

95
chooseWithDropdown :: ![String] -> Editor Int (?Int)
Bas Lijnse's avatar
Bas Lijnse committed
96 97 98 99
chooseWithDropdown labels
	= mapEditorWrite selection
	$ mapEditorRead (\i -> [i])
	$ withConstantChoices options dropdown <<@ multipleAttr False
100
where
101 102
	selection [x] = ?Just x
	selection _   = ?None
103 104 105

	options = [{ChoiceText|id=i,text=t} \\ t <- labels & i <- [0..]]

106
listEditor :: Bool (?([w] -> ?r)) Bool Bool (?([w] -> String)) (r -> w) (Editor r w) -> Editor [r] [w]
107
            | JSONEncode{|*|} w
108
listEditor view add remove reorder count rtow itemEditor = listEditor_ JSONEncode{|*|} view add remove reorder count rtow itemEditor
109

110
listEditor_ :: (Bool w -> [JSONNode]) Bool (?([w] -> ?r)) Bool Bool (?([w] -> String)) (r -> w) (Editor r w)
111
            -> Editor [r] [w]
112
listEditor_ jsonenc view add remove reorder count rtow itemEditor = compoundEditorToEditor
113
	{CompoundEditor|onReset=onReset,onEdit=onEdit,onRefresh=onRefresh,writeValue=writeValue}
114
where
115
	onReset attr dp mbval vst=:{VSt|taskId} = case resetChildUIs dp 0 val [] vst of
116
		(Ok (items, childSts, childWs),vst)
117
			//Add list structure editing buttons
118
			# items = if (not view && (remove || reorder)) [listItemUI taskId dp (length val) idx idx dx \\ dx <- items & idx <- [0..]] items
119
			//Add the add button
120
			# items = if (not view && isJust add) (items ++ [addItemControl val]) items
Steffen Michels's avatar
Steffen Michels committed
121
			//All item UI's have a unique id that is used in the data-paths of that UI
122
			= (Ok (uiac UIList attr items, indexList val, childSts, ?Just childWs), vst)
123
		(Error e,vst)  = (Error e,vst)
Steffen Michels's avatar
Steffen Michels committed
124
	where
125
		val = fromMaybe [] mbval
Steffen Michels's avatar
Steffen Michels committed
126

127
		resetChildUIs dp _ [] us vst = (Ok (unzip3 (reverse us)), vst)
128
		resetChildUIs dp i [c:cs] us vst = case itemEditor.Editor.onReset emptyAttr (dp++[i]) (?Just c) vst of
129 130 131 132
			(Ok (u,m,mbw),vst)
				= case maybe (itemEditor.Editor.writeValue m) Ok mbw of
					(Error e) = (Error e, vst)
					(Ok w) = resetChildUIs dp (i+1) cs [(u,m,w):us] vst
133
			(Error e,vst)  = (Error e,vst)
134 135

		addItemControl val
136
			# val       = [rtow x \\ x <- val]
Bas Lijnse's avatar
Bas Lijnse committed
137
			# counter  	= maybe [] (\f -> [uia UITextView ('DM'.unions [widthAttr FlexSize, valueAttr (JSONString (f val))])]) count
138
			# button	= if (isJust add) [uia UIButton ('DM'.unions [iconClsAttr "icon-add",editAttrs taskId (editorId dp) (?Just (JSONString "add"))])] []
139
			= uiac UIToolBar (classAttr ["itask-listitem-controls"]) (counter ++ button)
140

141
	listItemUI taskId dp numItems idx id item
142
		# buttons	= (if reorder
143 144
			[uia UIButton ('DM'.unions [iconClsAttr "icon-up", enabledAttr (idx <> 0), editAttrs taskId (editorId dp) (?Just (JSONString ("mup_" +++ toString id)))])
							  ,uia UIButton ('DM'.unions [iconClsAttr "icon-down", enabledAttr (idx <> numItems - 1), editAttrs taskId (editorId dp) (?Just (JSONString ("mdn_" +++ toString id)))])
145 146
							  ] []) ++
							  (if remove
147
							  [uia UIButton ('DM'.unions [iconClsAttr "icon-remove",editAttrs taskId (editorId dp) (?Just (JSONString ("rem_" +++ toString id)))])
148
							  ] [])
149
		# attr = 'DM'.unions [heightAttr WrapSize]
150 151 152 153
		= uiac UIListItem attr (if (reorder || remove) ([flexWidth item] ++ buttons) [flexWidth item])
	where
		flexWidth (UI type attr content) = UI type ('DM'.union (widthAttr FlexSize) attr) content

154
	//Structural edits on the list
155
	onEdit dp ([],JSONString e) ids childSts vst=:{VSt|taskId}
156 157 158
		# [op,id:_] = split "_" e
		# id = toInt id 
		# index = itemIndex id ids
Steffen Michels's avatar
Steffen Michels committed
159
		# num = length childSts
160
		| op == "mup" && reorder
Steffen Michels's avatar
Steffen Michels committed
161
			| index < 1 || index >= num = (Error "List move-up out of bounds",vst)
162 163 164
				# changes =  if (index == 1) [(index,toggle 1 False),(index - 1,toggle 1 True)] [] //Update 'move-up' buttons
						  ++ if (index == num - 1) [(index,toggle 2 True),(index - 1,toggle 2 False)] [] //Update 'move-down' buttons
						  ++ [(index,MoveChild (index - 1))] //Actually move the item
165
				# internalSt = swap ids index
166
				# childSts = swap childSts index
167
				= (Ok (ChangeUI [] changes, internalSt, childSts, ?Just (validChildValues childSts)), vst)
168
		| op == "mdn" && reorder
Steffen Michels's avatar
Steffen Michels committed
169
			| index < 0 || index > (num - 2) = (Error "List move-down out of bounds",vst)
170 171 172
				# changes =  if (index == 0) [(index,toggle 1 True),(index + 1,toggle 1 False)] [] //Update 'move-up' buttons
                          ++ if (index == num - 2) [(index,toggle 2 False),(index + 1,toggle 2 True)] [] //Update 'move-down' buttons
                          ++ [(index,MoveChild (index + 1))]
173
				# internalSt = swap ids (index + 1)
174
				# childSts = swap childSts (index + 1)
175
			    = (Ok (ChangeUI [] changes, internalSt, childSts, ?Just (validChildValues childSts)), vst)
176
		| op == "rem" && remove
Steffen Michels's avatar
Steffen Michels committed
177 178
			| index < 0 || index >= num = (Error "List remove out of bounds",vst)
				# childSts   = removeAt index childSts
179
				# internalSt = removeAt index ids
180
				# nitems = [item \\ Ok item <- itemEditor.Editor.writeValue <$> childSts]
181
				# counter = maybe [] (\f -> [(length nitems, ChangeChild (ChangeUI [] [(0,ChangeChild (ChangeUI [SetAttribute "value" (JSONString (f nitems))] []))]))]) count
182 183
				# changes =  if (index == 0 && num > 1) [(index + 1, toggle 1 False)] []
						  ++ if (index == num - 1 && index > 0) [(index - 1, toggle 2 False)] []
184
						  ++ [(index,RemoveChild)] ++ counter
185 186
			= (Ok (ChangeUI [] changes, internalSt, childSts, ?Just (validChildValues childSts)), vst)
		| op == "add" && isJust add
187
			# mbNx = (fromJust add) [i \\ Ok i <- itemEditor.Editor.writeValue <$> childSts]
188
			# ni = num 
189
			# nid = nextId ids
190
            // use enter mode if no value for new item is given; otherwise use update mode
191
			= case itemEditor.Editor.onReset emptyAttr (dp++[nid]) mbNx vst of
Steffen Michels's avatar
Steffen Michels committed
192
				(Error e,vst) = (Error e, vst)
193
				(Ok (ui,nm,_),vst)
Steffen Michels's avatar
Steffen Michels committed
194
					# nChildSts = childSts ++ [nm]
195
					# nitems = [item \\ Ok item <- itemEditor.Editor.writeValue <$> nChildSts]
196 197
					# nids = ids ++ [nid]
					# insert = [(ni,InsertChild (listItemUI taskId dp (ni + 1) ni nid ui))]
198
					# counter = maybe [] (\f -> [(ni + 1, ChangeChild (ChangeUI [] [(0,ChangeChild (ChangeUI [SetAttribute "value" (JSONString (f nitems))] []))]))]) count
199
					# prevdown = if (ni > 0) [(ni - 1,toggle 2 True)] []
200
					# change = ChangeUI [] (insert ++ counter ++ prevdown)
201 202
					= (Ok (change,  nids, nChildSts, ?Just (validChildValues nChildSts)), vst)
		= (Ok (NoChange, ids, childSts, ?None), vst)
203 204 205 206 207 208 209 210 211
	where
		swap []	  _		= []
		swap list index
			| index == 0 			= list //prevent move first element up
			| index >= length list 	= list //prevent move last element down
			| otherwise				
				# f = list !! (index-1)
				# l = list !! (index)
				= updateAt (index-1) l (updateAt index f list)
212
		toggle idx value = ChangeChild (ChangeUI [] [(idx,ChangeChild (ChangeUI [SetAttribute "enabled" (JSONBool value)] []))])
213

214 215
		errorToMaybe (Ok x) = ?Just x
		errorToMaybe _ = ?None
216

217
	//Edits inside the list
218
	onEdit dp ([id:tp],e) ids childSts vst
219
		# index = itemIndex id ids
Steffen Michels's avatar
Steffen Michels committed
220
		| index < 0 || index >= length childSts = (Error ("List edit out of bounds (index:" +++ toString index +++", list length: "+++toString (length childSts)+++")"),vst)
221
		| otherwise
Steffen Michels's avatar
Steffen Michels committed
222 223 224
			= case itemEditor.Editor.onEdit (dp ++ [id]) (tp,e) (childSts !! index) vst of
				(Error e,vst)
					= (Error e, vst)
225
				(Ok (change,nm, _),vst)
226
					# childSts = updateAt index nm childSts
227
					= (Ok (childChange index change, ids, childSts, ?Just (validChildValues childSts)), vst)
228 229
	where
		childChange i NoChange = NoChange
230
		childChange i change = ChangeUI [] [(i,ChangeChild (ChangeUI [] [(0,ChangeChild change)]))]
231 232

	//Very crude full replacement
233 234 235
	onRefresh dp new ids childSts vst
		| [jsonenc False (rtow r) \\ r <- new] == [jsonenc False w \\ w <- fromMaybe [] $ error2mb $ writeValue ids childSts]
			= (Ok (NoChange, ids, childSts, ?None), vst)
Steffen Michels's avatar
Steffen Michels committed
236
		//TODO: Determine small UI change
237
		| otherwise
238
			= case onReset emptyAttr dp (?Just new) vst of
239
				(Ok (ui, internalSt, childSts,_),vst) = (Ok (ReplaceUI ui, internalSt, childSts, ?None), vst)
240
				(Error e,vst) = (Error e, vst)
Steffen Michels's avatar
Steffen Michels committed
241

Bas Lijnse's avatar
Bas Lijnse committed
242
	writeValue _ childSts = writeValues childSts [] //Only return a value if all child values are valid
Steffen Michels's avatar
Steffen Michels committed
243
	where
Bas Lijnse's avatar
Bas Lijnse committed
244
		writeValues [] acc = Ok $ reverse acc
245
		writeValues [st: sts] acc = case itemEditor.Editor.writeValue st of
Bas Lijnse's avatar
Bas Lijnse committed
246 247
			(Ok val) = writeValues sts [val: acc]
			(Error e) = Error e
248

249
	validChildValues childSts = [val \\ Ok val <- map itemEditor.Editor.writeValue childSts]
250

251 252 253 254 255 256 257
	nextId [] = 0
	nextId ids = maxList ids + 1

	itemIndex id ids = itemIndex` 0 id ids
	where
		itemIndex` _ _ [] = -1
		itemIndex` i id [x:xs] = if (id == x) i (itemIndex` (i + 1) id xs)
258