Definition.icl 13.7 KB
Newer Older
1 2
implementation module iTasks.UI.Definition

3 4
import StdEnv
import Text.GenJSON, Data.GenEq, Text.HTML, Text, Data.Maybe
5
from Data.Map import :: Map (..)
6
import Data.Map.GenJSON
7 8 9 10
from Data.Functor import class Functor(..)
import qualified Data.Map as DM
import qualified Data.List as DL

11
from iTasks.WF.Definition import class iTask(..)
12 13
from iTasks.Internal.Generic.Visualization	import generic gText, :: TextFormat(..)
from iTasks.Internal.Generic.Defaults			import generic gDefault
Steffen Michels's avatar
Steffen Michels committed
14
from iTasks.UI.Editor import :: Editor, :: EditState
15
from iTasks.UI.Editor.Generic import generic gEditor
16
from Text.GenJSON import generic JSONEncode, generic JSONDecode, :: JSONNode
17 18 19

import Text.HTML

20
derive class iTask UI, UIType
21
derive class iTask UISize, UIBound, UIDirection, UIVAlign, UIHAlign, UISide, UIWindowType
22
derive class iTask UITreeNode 
23

24
ui :: UIType -> UI
25 26
ui type = UI type 'DM'.newMap []

27
uic :: UIType [UI] -> UI
28 29
uic type items = UI type 'DM'.newMap items

30
uia :: UIType UIAttributes -> UI
31 32
uia type attr = UI type attr []

33
uiac :: UIType UIAttributes [UI] -> UI
34 35
uiac type attr items = UI type attr items

36 37 38
emptyAttr :: UIAttributes
emptyAttr = 'DM'.newMap

39
optionalAttr :: !Bool -> UIAttributes
40
optionalAttr optional = 'DM'.singleton "optional" (JSONBool optional)
41

42 43
sizeAttr :: !UISize !UISize -> UIAttributes
sizeAttr width height = 'DM'.fromList [("width",encodeUI width),("height",encodeUI height)]
Bas Lijnse's avatar
Bas Lijnse committed
44

45
widthAttr :: !UISize -> UIAttributes
46
widthAttr width = 'DM'.singleton "width" (encodeUI width)
Bas Lijnse's avatar
Bas Lijnse committed
47

48
heightAttr :: !UISize -> UIAttributes
49
heightAttr height = 'DM'.singleton "height" (encodeUI height)
Bas Lijnse's avatar
Bas Lijnse committed
50

51
hintAttr :: !String -> UIAttributes
52
hintAttr hint = 'DM'.singleton "hint" (JSONString hint)
53

54
titleAttr :: !String -> UIAttributes
55
titleAttr title = 'DM'.singleton "title" (JSONString title)
56

57
iconClsAttr :: !String -> UIAttributes
58
iconClsAttr iconCls = 'DM'.singleton "iconCls" (JSONString iconCls)
Bas Lijnse's avatar
Bas Lijnse committed
59

60
tooltipAttr :: !String -> UIAttributes
61
tooltipAttr tooltip = 'DM'.singleton "tooltip" (JSONString tooltip)
Bas Lijnse's avatar
Bas Lijnse committed
62

63
hposAttr :: !UIHAlign -> UIAttributes
64
hposAttr pos = 'DM'.singleton "hpos" (encodeUI pos)
Bas Lijnse's avatar
Bas Lijnse committed
65

66
vposAttr :: !UIVAlign -> UIAttributes
67
vposAttr pos = 'DM'.singleton "vpos" (encodeUI pos)
68

69
windowTypeAttr :: !UIWindowType -> UIAttributes
70
windowTypeAttr windowType = 'DM'.singleton "windowType" (encodeUI windowType)
Bas Lijnse's avatar
Bas Lijnse committed
71

72
focusTaskIdAttr :: !String -> UIAttributes
73
focusTaskIdAttr taskId = 'DM'.singleton "focusTaskId" (JSONString taskId)
74

75
closeTaskIdAttr :: !String -> UIAttributes
76
closeTaskIdAttr taskId = 'DM'.singleton "closeTaskId" (JSONString taskId)
77

78
activeTabAttr :: !Int -> UIAttributes
79
activeTabAttr activeTab = 'DM'.singleton "activeTab" (JSONInt activeTab)
80

81
valueAttr :: !JSONNode -> UIAttributes
82
valueAttr value = 'DM'.singleton "value" value
83

84
minAttr :: !Int -> UIAttributes
85
minAttr min = 'DM'.singleton "min" (JSONInt min)
86

87
maxAttr :: !Int -> UIAttributes
88
maxAttr max = 'DM'.singleton "max" (JSONInt max)
89

90
textAttr :: !String -> UIAttributes
91
textAttr text = 'DM'.singleton "text" (JSONString text)
92

93
enabledAttr :: !Bool -> UIAttributes
94
enabledAttr enabled = 'DM'.singleton "enabled" (JSONBool enabled)
Bas Lijnse's avatar
Bas Lijnse committed
95

96
multipleAttr :: !Bool -> UIAttributes
97
multipleAttr multiple = 'DM'.singleton "multiple" (JSONBool multiple)
98

99
instanceNoAttr :: !Int -> UIAttributes
100
instanceNoAttr instanceNo = 'DM'.singleton "instanceNo" (JSONInt instanceNo)
101

102
instanceKeyAttr :: !String -> UIAttributes
103
instanceKeyAttr instanceKey = 'DM'.singleton "instanceKey" (JSONString instanceKey)
104

105
columnsAttr :: ![String] -> UIAttributes
106
columnsAttr columns = 'DM'.singleton "columns" (JSONArray (map JSONString columns))
107

108
doubleClickAttr :: !String !String -> UIAttributes
109
doubleClickAttr taskId actionId = 'DM'.singleton "doubleClickAction" (JSONArray [JSONString taskId,JSONString actionId])
110

111
actionIdAttr :: !String -> UIAttributes
112
actionIdAttr actionId = 'DM'.singleton "actionId" (JSONString actionId)
113

114
taskIdAttr :: !String -> UIAttributes
115
taskIdAttr taskId = 'DM'.singleton "taskId" (JSONString taskId)
116

Bas Lijnse's avatar
Bas Lijnse committed
117
editorIdAttr :: !String -> UIAttributes
118
editorIdAttr taskId = 'DM'.singleton "editorId" (JSONString taskId)
Bas Lijnse's avatar
Bas Lijnse committed
119

Bas Lijnse's avatar
Bas Lijnse committed
120
labelAttr :: !String -> UIAttributes
121
labelAttr taskId = 'DM'.singleton "label" (JSONString taskId)
Bas Lijnse's avatar
Bas Lijnse committed
122

123
styleAttr :: !String -> UIAttributes
124
styleAttr style = 'DM'.singleton "style" (JSONString style)
125

126
classAttr :: ![String] -> UIAttributes
127 128 129 130 131 132 133 134 135 136 137 138
classAttr classes = 'DM'.singleton "class" (JSONArray (map JSONString classes))

addClassAttr :: !String !UIAttributes -> UIAttributes
addClassAttr classname attributes = 'DM'.put "class" (JSONArray [JSONString classname:classes]) attributes
where
	classes = case 'DM'.get "class" attributes of (Just (JSONArray names)) = names ; _ = []

removeClassAttr :: !String !UIAttributes -> UIAttributes
removeClassAttr remove attributes 
	= case 'DM'.get "class" attributes of
		(Just (JSONArray items)) = 'DM'.put "class" (JSONArray [i \\ i=:(JSONString name) <- items | name <> remove]) attributes
		_ = attributes
139

140
resizableAttr :: ![UISide] -> UIAttributes
141
resizableAttr sides = 'DM'.singleton "resizable" (JSONArray (map encodeUI sides))
142

Mart Lubbers's avatar
Mart Lubbers committed
143
maxlengthAttr :: !Int -> UIAttributes
144
maxlengthAttr maxlength = 'DM'.singleton "maxlength" (JSONInt maxlength)
Mart Lubbers's avatar
Mart Lubbers committed
145 146

minlengthAttr :: !Int -> UIAttributes
147
minlengthAttr minlength = 'DM'.singleton "minlength" (JSONInt minlength)
Mart Lubbers's avatar
Mart Lubbers committed
148 149 150 151

boundedlengthAttr :: !Int !Int -> UIAttributes
boundedlengthAttr min max = 'DM'.unions [minlengthAttr min, maxlengthAttr max]

152
eventTimeoutAttr :: !(Maybe Int) -> UIAttributes
153
eventTimeoutAttr timeout = 'DM'.singleton "eventTimeout" (maybe JSONNull JSONInt timeout)
154

155 156 157
editAttrs :: !String !String !(Maybe JSONNode) -> UIAttributes
editAttrs taskId editorId mbValue 
	= 'DM'.fromList [("taskId",JSONString taskId),("editorId",JSONString editorId):maybe [] (\value -> [("value",value)]) mbValue]
158

159 160 161
choiceAttrs :: !String !String ![Int] ![JSONNode] -> UIAttributes
choiceAttrs taskId editorId value options
	= 'DM'.fromList [("taskId",JSONString taskId),("editorId",JSONString editorId),("value",JSONArray (map JSONInt value)),("options",JSONArray options)]
162 163 164 165

isOptional :: !UI -> Bool
isOptional (UI _ attr _) = maybe False (\(JSONBool b) -> b) ('DM'.get "optional" attr)

166
stringDisplay :: !String -> UI
167
stringDisplay value = uia UITextView (valueAttr (JSONString (escapeStr value)))
168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191

//Encoding of UI definitions to the JSON format expected by the client
class encodeUI a :: a -> JSONNode

instance encodeUI Int				where encodeUI v = JSONInt v
instance encodeUI Real				where encodeUI v = JSONReal v
instance encodeUI Char 				where encodeUI v = JSONString (toString v)
instance encodeUI String			where encodeUI v = JSONString v
instance encodeUI Bool				where encodeUI v = JSONBool v
instance encodeUI HtmlTag			where encodeUI v = JSONString (toString v)

instance encodeUI JSONNode
where
	encodeUI v = toJSON v

instance encodeUI (Maybe a) | encodeUI a
where
	encodeUI Nothing = JSONNull
	encodeUI (Just a) = encodeUI a

instance encodeUI [a] | encodeUI a
where
	encodeUI l = JSONArray (map encodeUI l)

192
instance encodeUI UI
193
where
Bas Lijnse's avatar
Bas Lijnse committed
194
	encodeUI (UI type attr items) = JSONObject (typeField ++ attrFields ++ childrenField)
195
	where
196 197 198 199
		typeField = [("type",JSONString (toString type))]
		attrFields = case attr of
			'DM'.Tip = []
			_        = [("attributes",JSONObject ('DM'.toList attr))]
Bas Lijnse's avatar
Bas Lijnse committed
200 201 202 203
		childrenField = case items of
			[]    = []
			_     = [("children",JSONArray (map encodeUI items))]

204
instance toString UIType
Bas Lijnse's avatar
Bas Lijnse committed
205
where
206 207 208
	toString UIEmpty           = "RawEmpty"
	toString UIAction          = "RawAction"

Bas Lijnse's avatar
Bas Lijnse committed
209
	toString UIComponent       = "Component" 
Mart Lubbers's avatar
Mart Lubbers committed
210 211
	toString UIViewport        = "Viewport"
	toString UILoader          = "Loader"
212

213 214 215 216 217
	toString UITextField       = "TextField"
	toString UITextArea        = "TextArea"
	toString UIPasswordField   = "PasswordField"
	toString UIIntegerField    = "IntegerField"
	toString UIDecimalField    = "DecimalField"
218
	toString UIDocumentField   = "DocumentField"
219
	toString UICheckbox        = "Checkbox"
220 221 222 223 224 225 226 227 228 229
	toString UISlider          = "Slider"
	toString UIButton          = "Button"
	toString UILabel           = "Label"
	toString UIIcon            = "Icon"

	toString UITextView        = "TextView"
	toString UIHtmlView        = "HtmlView"
	toString UIProgressBar     = "ProgressBar"

	toString UIDropdown        = "Dropdown"
230
	toString UICheckGroup      = "CheckGroup"
231 232 233
	toString UIChoiceList      = "ChoiceList"
	toString UIGrid            = "Grid"
	toString UITree            = "Tree"
234
	toString UITabBar          = "TabBar"
235 236 237 238 239 240

    toString UIContainer       = "Container"
	toString UIPanel           = "Panel"
	toString UITabSet          = "TabSet"
	toString UIWindow          = "Window"
	toString UIMenu            = "Menu"
241
	toString UIMenuSep         = "MenuSep"
242 243
	toString UIToolBar         = "ToolBar"
	toString UIButtonBar       = "ButtonBar"
244 245
	toString UIList            = "List"
	toString UIListItem        = "ListItem"
246 247
	toString UIDebug           = "Debug"

248 249
	toString UIData            = "Data"

250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
instance encodeUI UISize
where
	encodeUI (ExactSize s)	= JSONInt s
	encodeUI WrapSize		= JSONString "wrap"
	encodeUI FlexSize		= JSONString "flex"

instance encodeUI UIBound
where
	encodeUI (ExactBound s)	= JSONInt s
	encodeUI WrapBound		= JSONString "wrap"

instance encodeUI UIVAlign
where
	encodeUI AlignTop		= JSONString "top"
	encodeUI AlignMiddle	= JSONString "middle"
	encodeUI AlignBottom	= JSONString "bottom"

instance encodeUI UIHAlign
where
	encodeUI AlignLeft		= JSONString "left"
	encodeUI AlignCenter	= JSONString "center"
	encodeUI AlignRight		= JSONString "right"

instance encodeUI UIDirection
where
	encodeUI Vertical		= JSONString "vertical"
	encodeUI Horizontal		= JSONString "horizontal"

instance encodeUI UIWindowType
where
	encodeUI FloatingWindow 	= JSONString "floating"
	encodeUI NotificationBubble = JSONString "bubble"

283 284 285 286 287 288 289
instance encodeUI UISide
where
	encodeUI TopSide    = JSONString "top"
	encodeUI BottomSide = JSONString "bottom"
	encodeUI LeftSide   = JSONString "left"
	encodeUI RightSide  = JSONString "right"

290
derive class iTask UIChange, UIAttributeChange, UIChildChange
291

292 293 294 295 296 297 298 299 300 301 302 303
mergeUIChanges :: UIChange UIChange -> UIChange
mergeUIChanges c1 NoChange = c1 
mergeUIChanges NoChange c2 = c2 
mergeUIChanges _ (ReplaceUI ui2) = ReplaceUI ui2 //Any previous change is void when it is followed by a replace
mergeUIChanges (ReplaceUI ui1) (ChangeUI ca2 ci2) = ReplaceUI (applyUIChange (ChangeUI ca2 ci2) ui1)
mergeUIChanges (ChangeUI ca1 ci1) (ChangeUI ca2 ci2) = ChangeUI (ca1 ++ ca2) (ci1 ++ ci2)

applyUIChange :: !UIChange !UI -> UI
applyUIChange NoChange ui = ui 
applyUIChange (ReplaceUI ui) _ = ui
applyUIChange (ChangeUI ca ci) (UI type attr items)
	//Change the attributes
304
	# attr = foldl (flip applyUIAttributeChange) attr ca
305 306 307 308
	//Adjust the children
	# items = foldl appChildChange items ci
	= UI type attr items
where
309 310 311 312 313 314
	appChildChange items (i,RemoveChild)
		| i >= 0 && i < length items = removeAt i items
									 = items
	appChildChange items (i,InsertChild ui)
		| i >= 0 && i <= length items = insertAt i ui items
									  = items
315
	appChildChange items (i,ChangeChild change)
316 317 318 319 320 321
		| i >= 0 && i < length items = updateAt i (applyUIChange change (items !! i)) items
		                             = items
	appChildChange items (s,MoveChild d)
		# num = length items
		| s >= 0 && d >= 0 && s < num && d < num = insertAt d (items !! s) (removeAt s items)
                                                 = items
322 323 324 325

applyUIAttributeChange :: !UIAttributeChange !UIAttributes -> UIAttributes
applyUIAttributeChange (SetAttribute k v) attr  = 'DM'.put k v attr
applyUIAttributeChange (DelAttribute k) attr = 'DM'.del k attr
326 327

//Remove unnessecary directives
328
compactUIChange :: UIChange -> UIChange
329 330 331
compactUIChange (ChangeUI local children) = case (local,compactChildren children) of
	([],[]) = NoChange
	(local,children) = ChangeUI local children
332
where
333 334 335 336
	compactChildren [] = [] 
	compactChildren [(idx,ChangeChild change):cs] = case (compactUIChange change) of
		NoChange = compactChildren cs
		change   = [(idx,ChangeChild change):compactChildren cs]
337

338 339
	compactChildren [c:cs] = [c:compactChildren cs]
compactUIChange change = change
340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368

completeChildChanges :: [(Int,UIChildChange)] -> [(Int,UIChildChange)]
completeChildChanges children = complete 0 (sortBy indexCmp children)
where
	complete i [] = []
	complete i [c:cs]
		| i < fst c = [(i,ChangeChild NoChange):complete (i + 1) cs]
					= [c:complete (fst c + 1) cs]
	indexCmp x y = fst x < fst y

reindexChildChanges :: [(Int,UIChildChange)] -> [(Int,UIChildChange)]
reindexChildChanges children = [(i,c) \\ (_,c) <- children & i <- [0..]]

compactChildChanges :: [(Int,UIChildChange)] -> [(Int,UIChildChange)]
compactChildChanges children = [c \\ c <- children | not (noChangeChild c)]
where
	noChangeChild (_,ChangeChild NoChange) = True
	noChangeChild _ = False

encodeUIChanges:: ![UIChange] -> JSONNode
encodeUIChanges defs = JSONArray (map encodeUIChange defs)

encodeUIChange :: !UIChange -> JSONNode
encodeUIChange NoChange = JSONNull
encodeUIChange (ReplaceUI def)
	= JSONObject
		[("type",JSONString "replace")
		,("definition",encodeUI def)
		]
369
encodeUIChange (ChangeUI attributes children)
370
	= JSONObject fields
371
where
372 373 374 375 376 377 378 379
	fields = [("type",JSONString "change"):attributesField]
	attributesField = case attributes of
		[] -> childrenField
		_  -> [("attributes",JSONArray [encodeAttrChange a \\ a <- attributes]):childrenField]
	childrenField = case children of
		[] -> []
		_  -> [("children",JSONArray [encodeChildChange c \\ c <- children])]

380 381 382
	encodeAttrChange (SetAttribute name value) = JSONObject [("name",JSONString name),("value",value)]
	encodeAttrChange (DelAttribute name) = JSONObject [("name",JSONString name),("value",JSONNull)]

383 384 385
	encodeChildChange (i,ChangeChild child) = JSONArray [JSONInt i,JSONString "change",encodeUIChange child]
	encodeChildChange (i,RemoveChild) 		= JSONArray [JSONInt i,JSONString "remove"]
	encodeChildChange (i,InsertChild child) = JSONArray [JSONInt i,JSONString "insert",encodeUI child]
386
	encodeChildChange (i,MoveChild ni)      = JSONArray [JSONInt i,JSONString "move",JSONInt ni]