CommonDomain.icl 14.7 KB
Newer Older
1 2 3
implementation module CommonDomain

import iTasks
4
import StdOverloaded, StdClass, StdInt, StdMisc, StdArray
5
import GenPrint, GenParse, GenVisualize, GenUpdate, GenLexOrd
6
import Text, Time
7

8 9
derive gPrint			EmailAddress, Password, Note, Date, Time, DateTime, Currency, FormattedText, FormattedTextControls
derive gParse			EmailAddress, Password, Note, Date, Time, DateTime, Currency, FormattedText, FormattedTextControls
10
derive gVisualize		EmailAddress, DateTime
11 12 13 14
derive gUpdate			EmailAddress, Note, DateTime, FormattedText, FormattedTextControls
derive gMerge			EmailAddress, Password, Note, Date, Time, DateTime, Currency, FormattedText, FormattedTextControls
derive gMakeSharedCopy	EmailAddress, Password, Note, Date, Time, DateTime, Currency, FormattedText, FormattedTextControls
derive gMakeLocalCopy	EmailAddress, Password, Note, Date, Time, DateTime, Currency, FormattedText, FormattedTextControls
15
derive gLexOrd			Currency
16

17 18
derive bimap	Maybe, (,)

19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34
//VValue a DataMask
gVisualize{|Password|} old new vst=:{vizType,label,idPrefix,currentPath,useLabels,optional,valid}
	= case vizType of
		VEditorDefinition	= ([TUIFragment (TUIPasswordControl {TUIBasicControl | name = dp2s currentPath, id = id, value = oldV, fieldLabel = labelAttr useLabels label, optional = optional})]
								, 1
								, {VSt | vst & currentPath = stepDataPath currentPath, valid = stillValid currentPath old optional valid})
		VEditorUpdate
			| oldV <> newV	= ([TUIUpdate (TUISetValue id newV)]
								, 1
								, {VSt | vst & currentPath = stepDataPath currentPath, valid = stillValid currentPath new optional valid})
		_					= ([TextFragment (foldr (+++) "" (repeatn (size oldV) "*"))],1,{VSt | vst & currentPath = stepDataPath currentPath, valid = stillValid currentPath old optional valid})
where
	id		= dp2id idPrefix currentPath
	oldV	= value2s currentPath old
	newV	= value2s currentPath new
		
35
gVisualize{|Date|} old new vst=:{vizType,label,idPrefix,currentPath,useLabels,optional,valid}
36
	= case vizType of
37
		VEditorDefinition	= ([TUIFragment (TUIDateControl {TUIBasicControl|name = dp2s currentPath, id = id, value = oldV, fieldLabel = labelAttr useLabels label, optional = optional})]
38
								, 1
39
								, {VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid currentPath old optional valid})
40
		VEditorUpdate
41 42 43 44
			| oldV <> newV 	= ([TUIUpdate (TUISetValue id newV)]
								, 1
								, {VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid currentPath new optional valid})
		_					= ([TextFragment (toString old)],1,{VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid currentPath new optional valid})
45
where
46 47 48
	id		= dp2id idPrefix currentPath
	oldV	= value2s currentPath old
	newV	= value2s currentPath new
49
	
50
gVisualize{|Time|} old new vst=:{vizType,label,idPrefix,currentPath,useLabels,optional,valid}
51
	= case vizType of
52
		VEditorDefinition	= ([TUIFragment (TUITimeControl {TUIBasicControl|name = dp2s currentPath, id = id, value = oldV, fieldLabel = labelAttr useLabels label, optional = optional})]
53
								, 1
54
								, {VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid currentPath old optional valid})
55
		VEditorUpdate
56 57 58 59
			| oldV <> newV 	= ([TUIUpdate (TUISetValue id newV)]
								, 1
								, {VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid currentPath new optional valid})
		_					= ([TextFragment (toString old)],1,{VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid currentPath new optional valid})
60
where
61 62 63
	id		= dp2id idPrefix currentPath
	oldV	= value2s currentPath old
	newV	= value2s currentPath new
64
	
65
gVisualize{|Note|} old new vst=:{vizType,label,idPrefix,currentPath,useLabels,optional,valid}
66
	= case vizType of
67
		VEditorDefinition	= ([TUIFragment (TUINoteControl {TUIBasicControl|name = dp2s contentPath, id = id, value = oldV, fieldLabel = labelAttr useLabels label, optional = optional})]
68 69 70
								, 2
								, {VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid contentPath old optional valid})
		VEditorUpdate
71 72
			| oldV <> newV 	= ([TUIUpdate (TUISetValue id newV)]
								, 2
73
								, {VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid contentPath new optional valid})
74
		_					= ([HtmlFragment (flatten [[Text line,BrTag []] \\ line <- split "\n" (toString old)])]
75 76
								, 2
								, {VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid contentPath new optional valid})
77 78 79
where
	// Use the path to the inner constructor instead of the current path.
	// This way the generic gUpdate will work for this type
80 81 82 83
	contentPath	= shiftDataPath currentPath
	id			= dp2id idPrefix contentPath
	oldV		= value2s contentPath old
	newV		= value2s contentPath new
84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123
	
gVisualize{|FormattedText|} old new vst=:{vizType,label,idPrefix,currentPath,useLabels,optional,valid}
	= case vizType of
		VEditorDefinition	= ([TUIFragment (TUIFormattedTextControl	{ name				= dp2s contentPath
																		, id				= id
																		, value				= oldV
																		, fieldLabel		= labelAttr useLabels label
																		, optional			= optional
																		, enableAlignments	= controls.alignmentControls
																		, enableColors		= controls.colorControls
																		, enableFont		= controls.fontControl
																		, enableFontSize	= controls.fontSizeControls
																		, enableFormat		= controls.formatControls
																		, enableLinks		= controls.linkControl
																		, enableLists		= controls.listControls
																		, enableSourceEdit	= controls.sourceEditControl
																		}
								)]
								, 0
								, {VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid contentPath old optional valid})
		VEditorUpdate
			| oldV <> newV 	= ([TUIUpdate (TUISetValue id newV)]
								, 0
								, {VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid contentPath new optional valid})
		_					# htmlFrag = case old of
								VBlank		= [Text ""]
								VValue v _	= html v
							= ([HtmlFragment htmlFrag]
								, 0
								, {VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid contentPath new optional valid})
where
	// Use the path to the inner constructor instead of the current path.
	// This way the generic gUpdate will work for this type
	contentPath	= shiftDataPath currentPath
	id			= dp2id idPrefix contentPath
	oldV		= value2s contentPath old
	newV		= value2s contentPath new
	controls = case old of
		VBlank								= allControls
		VValue (FormattedText _ controls) _	= controls
124

125
gVisualize{|Currency|} old new vst=:{vizType,label,idPrefix,currentPath,useLabels,optional,valid}
126
	= case vizType of
127 128 129 130 131
		VEditorDefinition	= ([TUIFragment (TUICurrencyControl {TUICurrencyControl|id = id, name = dp2s currentPath
												, value = oldV, fieldLabel = labelAttr useLabels label
												, currencyLabel = curLabel old, optional = optional})]
								, 1
								, {VSt|vst & currentPath = stepDataPath currentPath, valid= stillValid currentPath old optional valid})
132
		VEditorUpdate
133 134
			| oldV <> newV 	= ([TUIUpdate (TUISetValue id newV)]
								, 1
ecrombag's avatar
ecrombag committed
135
								, {VSt|vst & currentPath = stepDataPath currentPath, valid = stillValid currentPath new optional valid})
136
		_					= ([TextFragment (toString old)], 1, {VSt|vst & currentPath = stepDataPath currentPath, valid = stillValid currentPath new optional valid})
137
where
138 139 140 141 142
	curLabel (VValue (EUR _) _)	= "&euro;"
	curLabel (VValue (GBP _) _)	= "&pound;"
	curLabel (VValue (USD _) _)	= "$"
	curLabel (VValue (JPY _) _) = "&yen;"
	curLabel _					= "&euro;" //Use the default currency
143 144 145
	
	oldV	= value currentPath old
	newV	= value currentPath new
146
	value dp VBlank			= ""
147 148 149
	value dp (VValue v dm)	= if (isMasked dp dm) (decFormat (toInt v)) ""
	
	id = dp2id idPrefix currentPath
150 151 152 153 154 155 156 157 158 159 160

gUpdate{|Password|} _ ust=:{USt|mode=UDCreate} 
	= (Password "", ust)
gUpdate{|Password|} s ust=:{USt|mode=UDSearch,searchPath,currentPath,update}
	| currentPath == searchPath
		= (Password update, toggleMask {USt | ust & mode = UDDone})
	| otherwise
		= (s, {USt|ust & currentPath = stepDataPath currentPath})
gUpdate{|Password|} s ust=:{USt|mode=UDMask,currentPath,mask}
	= (s, {USt|ust & currentPath = stepDataPath currentPath, mask = appendToMask currentPath mask})	
	
161 162 163
gUpdate{|Date|} _ ust=:{USt|mode=UDCreate,world}
	# (date,world) = currentDate world
	= (date, {USt|ust & world = world})
164
gUpdate{|Date|} s ust=:{USt|mode=UDSearch,searchPath,currentPath,update}
165 166
	| currentPath == searchPath
		= (fromString update, toggleMask {USt|ust & mode = UDDone})
167 168
	| otherwise
		= (s, {USt|ust & currentPath = stepDataPath currentPath})
169
gUpdate{|Date|} s ust=:{USt|mode=UDMask,currentPath,mask}
170
	= (s, {USt|ust & currentPath = stepDataPath currentPath, mask = appendToMask currentPath mask})
171

172 173
gUpdate{|Date|} s ust = (s, ust)

174 175 176
gUpdate{|Time|} _ ust=:{USt|mode=UDCreate,world}
	# (time,world) = currentTime world
	= (time, {USt|ust & world = world})
177
gUpdate{|Time|} s ust=:{USt|mode=UDSearch,searchPath,currentPath,update}
178 179
	| currentPath == searchPath
		= (fromString update, toggleMask {USt|ust & mode = UDDone})
180 181
	| otherwise
		= (s, {USt|ust & currentPath = stepDataPath currentPath})
182
gUpdate{|Time|} s ust=:{USt|mode=UDMask,currentPath,mask}
183
	= (s, {USt|ust & currentPath = stepDataPath currentPath, mask = appendToMask currentPath mask})
184
gUpdate{|Time|} s ust = (s, ust)
185 186 187

gUpdate{|Currency|} _ ust=:{USt|mode=UDCreate} = (EUR 0, ust)
gUpdate{|Currency|} s ust=:{USt|mode=UDSearch,searchPath,currentPath,update}
188 189
	| currentPath == searchPath
		= (parseUpdate s update, toggleMask {USt|ust & mode = UDDone})
190 191 192
	| otherwise
		= (s, {USt| ust & currentPath = stepDataPath currentPath})
where
193 194
	parseUpdate orig update =
		 case split "." update of
195 196 197
			[whole]		= replaceVal orig (100 * toInt whole)
			[whole,dec] = replaceVal orig (100 * toInt whole + (if (size dec == 1) (10 * toInt dec) (toInt (dec % (0,1)))))
			_			= orig
198
	
199 200 201 202
	replaceVal (EUR _) x = (EUR x)
	replaceVal (GBP _) x = (GBP x)
	replaceVal (USD _) x = (USD x)
	replaceVal (JPY _) x = (JPY x)
203 204

gUpdate{|Currency|} s ust=:{USt|mode=UDMask,currentPath,mask}
205
	= (s, {USt|ust & currentPath = stepDataPath currentPath, mask = appendToMask currentPath mask})	
206 207
gUpdate{|Currency|} s ust = (s,ust)

208 209 210 211
currentTime :: !*World -> (!Time,!*World)
currentTime world
	# (tm,world) = localTime world
	= ({Time|hour = tm.Tm.hour, min = tm.Tm.min, sec= tm.Tm.sec},world)
212

213 214 215 216
currentDate :: !*World -> (!Date,!*World)
currentDate world
	# (tm,world) = localTime world
	= ({Date| day = tm.Tm.mday, mon = 1 + tm.Tm.mon, year = 1900 + tm.Tm.year},world)
217

218 219 220 221 222 223 224
currentDateTime :: !*World -> (!DateTime,!*World)
currentDateTime world
	# (tm,world)	= localTime world
	# date			= {Date| day = tm.Tm.mday, mon = 1 + tm.Tm.mon, year = 1900 + tm.Tm.year}
	# time			= {Time|hour = tm.Tm.hour, min = tm.Tm.min, sec= tm.Tm.sec}
	= (DateTime date time,world)

225 226 227
instance html Note
where
	html (Note msg) = [Text msg]
228 229 230 231 232

instance html FormattedText
where
	html (FormattedText txt _) = [RawText txt]

233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249
instance toString Time
where
	toString {Time|hour,min,sec}	= (pad 2 hour) +++ ":" +++ (pad 2 min) +++ ":" +++ (pad 2 sec)

instance fromString Time
where
	fromString s					= {Time|hour = toInt (s %(0,1)), min = toInt (s %(3,4)), sec = toInt (s %(6,7)) }

instance toString Date
where
	toString {Date|year,mon,day}	= (pad 2 day) +++ "-" +++ (pad 2 mon) +++ "-" +++ (pad 4 year)

instance fromString Date
where
	fromString s					= {Date|day = toInt (s %(0,1)), mon = toInt (s %(3,4)), year = toInt (s %(6,9))}

instance toString Note
250
where
251
	toString (Note s)				= s
252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271
	
instance toString FormattedText
where
	toString (FormattedText s _) = s
	
toUnformattedString :: FormattedText -> String
toUnformattedString (FormattedText s _)
	# s	= replaceSubString "<br>" "\n" s
	# s	= replaceSubString "</li>" "\n" s
	# s	= stripHtmlTags s
	= s
where
	stripHtmlTags s
		# fstOpen	= indexOf "<" s
		# fstClose	= indexOf ">" s
		| fstOpen <> -1 && fstClose <> -1 && fstOpen < fstClose
			= stripHtmlTags (subString 0 fstOpen s +++ subString (fstClose + 1) (textSize s - fstClose) s)
		| otherwise
			= s
				
272 273
instance toString Currency
where
274 275 276 277
	toString (EUR x) = "EUR " +++ decFormat x
	toString (GBP x) = "GBP " +++ decFormat x
	toString (USD x) = "USD " +++ decFormat x
	toString (JPY x) = "JPY " +++ decFormat x
278

279
instance toInt Currency
280
where
281 282 283 284
	toInt (EUR val) = val
	toInt (GBP val) = val
	toInt (USD val) = val
	toInt (JPY val) = val
285
		
286
instance < Currency
287 288 289 290
where
	(<) x y = case x =?= y of
		LT	= True
		_	= False
Bas Lijnse's avatar
Bas Lijnse committed
291 292 293 294

instance < Time
where
	(<) x y
295 296 297 298
		| x.Time.hour < y.Time.hour															= True
		| x.Time.hour == y.Time.hour && x.Time.min < y.Time.min								= True
		| x.Time.hour == y.Time.hour && x.Time.min == y.Time.min && x.Time.sec < y.Time.sec	= True
		| otherwise																			= False
299
		
Bas Lijnse's avatar
Bas Lijnse committed
300 301 302
instance < Date
where
	(<) x y 
303 304 305 306
		| x.Date.year < y.Date.year															= True
		| x.Date.year == y.Date.year && x.Date.mon < y.Date.mon								= True
		| x.Date.year == y.Date.year && x.Date.mon == y.Date.mon && x.Date.day < y.Date.day	= True
		| otherwise																			= False
Bas Lijnse's avatar
Bas Lijnse committed
307

308 309 310 311 312
instance zero Currency
where
	zero = EUR 0

instance + Currency
313
where
314 315 316 317 318
	(+) (EUR x) (EUR y) = EUR (x + y)
	(+) (GBP x) (GBP y) = GBP (x + y)
	(+) (USD x) (USD y) = USD (x + y)
	(+) (JPY x) (JPY y) = JPY (x + y)
	(+) _ _ = abort "Trying to add money of different currencies!"
319

Bas Lijnse's avatar
Bas Lijnse committed
320 321
instance + Time
where
322
	(+) x y = {Time|hour = x.Time.hour + y.Time.hour, min = x.Time.min + y.Time.min, sec = x.Time.sec + y.Time.sec}
Bas Lijnse's avatar
Bas Lijnse committed
323 324 325

instance + Date
where
326
	(+) x y = {Date|year = x.Date.year + y.Date.year, mon = x.Date.mon + y.Date.mon, day = x.Date.day + y.Date.day}
Bas Lijnse's avatar
Bas Lijnse committed
327 328 329

instance - Time
where
330
	(-) x y = {Time|hour = x.Time.hour - y.Time.hour, min = x.Time.min - y.Time.min, sec = x.Time.sec - y.Time.sec}
Bas Lijnse's avatar
Bas Lijnse committed
331 332 333

instance - Date
where
334
	(-) x y = {Date|year = x.Date.year - y.Date.year, mon = x.Date.mon - y.Date.mon, day = x.Date.day - y.Date.day}
Bas Lijnse's avatar
Bas Lijnse committed
335

336
instance - Currency
337
where
338 339 340 341 342 343 344 345 346 347 348 349 350
	(-) (EUR x) (EUR y) = EUR (x - y)
	(-) (GBP x) (GBP y) = GBP (x - y)
	(-) (USD x) (USD y) = USD (x - y)
	(-) (JPY x) (JPY y) = JPY (x - y)
	(-) _ _ = abort "Trying to subtract money of different currencies!"
	
//Utility functions
pad :: Int Int -> String
pad len num = (createArray (max 0 (len - size nums)) '0' ) +++ nums
where 
	nums = toString num

decFormat :: Int -> String
351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
decFormat x = toString (x / 100) +++ "." +++ pad 2 (x rem 100)

mkEmptyFormattedText :: FormattedTextControls -> FormattedText
mkEmptyFormattedText controls = FormattedText "" controls

allControls	:: FormattedTextControls
allControls =	{ alignmentControls	= True
				, colorControls		= True
				, fontControl		= True
				, fontSizeControls	= True
				, formatControls	= True
				, linkControl		= True
				, listControls		= True
				, sourceEditControl	= True
				}
noControls	:: FormattedTextControls
noControls =	{ alignmentControls	= False
				, colorControls		= False
				, fontControl		= False
				, fontSizeControls	= False
				, formatControls	= False
				, linkControl		= False
				, listControls		= False
				, sourceEditControl	= False
				}