iDataHandler.icl 29.8 KB
Newer Older
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
1
2
3
4
5
6
implementation module iDataHandler

import StdArray, StdChar, StdList, StdStrictLists, StdString, StdTuple
import ArgEnv, StdMaybe
import iDataHtmlDef, iDataTrivial, iDataSettings, iDataStylelib, iDataState
import StdGeneric, GenParse, GenPrint
7
import Http, HttpUtil, HttpServer, HttpTextUtil, sapldebug
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
8
import Gerda
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
9
import StdBimap
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
10

11

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
12
13
14
15
derive gPrint (,), (,,), (,,,), UpdValue
derive gParse (,), (,,), (,,,), UpdValue
derive gHpr   (,), (,,), (,,,)
derive gUpd		   (,,), (,,,)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
16
derive bimap Form, FormId
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
17
18
19
20

gParse{|(->)|} gArg gRes _ 		= Nothing 
gPrint{|(->)|} gArg gRes _ _	= abort "functions can only be used with dynamic storage option!\n" 

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
21
22
:: *HSt 		= { cntr 	:: !Int 			// counts position in expression
				  , submits	:: !Bool			// True if we are in submit form
23
				  , issub	:: !Bool			// True if this form is a subform of another
24
25
				  , states	:: !*FormStates  	// all form states are collected here ... 
				  , request :: !HTTPRequest		// to enable access to the current HTTP request	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
26
				  , world	:: *NWorld			// to enable all other kinds of I/O
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
27
				  }	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
28
29
:: InputId	 	:== Int							// unique id for every constructor and basic value appearing in the state
:: FormUpdate	:== (InputId,UpdValue)			// info obtained when form is updated
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
30

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
31
32
:: Inline 		= Inline String

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
33
// Database OPTION
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
34

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
35
36
37
38
openDatabase database world
:== IF_Database (openGerda database world) (abort "Trying to open a relational database while this option is switched off",world)
closeDatabase database world
:== IF_Database (closeGerda database world) world
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
39

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
40
// DataFile OPTION
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
41

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
42
43
44
45
openmDataFile datafile world
:== IF_DataFile (openDataFile  datafile world) (abort "Trying to open a dataFile while this option is switched off",world)
closemDataFile datafile world
:== IF_DataFile (closeDataFile datafile world) world
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
46

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
47

48
49
50
//doHtmlWrapper: When using a client/server architecture, the doHtmlWrapper may be used instead of
//doHtmlServer. It switches between doHtmlServer and doHtmlClient depending on which compile option
//is selected.
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
51

52
53
doHtmlWrapper :: UserPage !*World -> *World
doHtmlWrapper userpage world = IF_Client (doHtmlClient userpage world) (doHtmlServer userpage world)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
54
55

// doHtmlServer: top level function given to end user.
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
56
// It sets up the communication with a (sub)server or client, depending on the option chosen.
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
57

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
58
doHtmlServer :: UserPage !*World -> *World
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
59
doHtmlServer userpage world
60
61
62
63
64
65
66
| ServerKind == Internal
	# world	= instructions world
	= StartServer userpage world									// link in the Clean http 1.0 server	
//| ServerKind == External											// connect with http 1.1 server
//| ServerKind == CGI												// build as CGI application
| otherwise
	= unimplemented world
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
67
where
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
	instructions :: *World -> *World
	instructions world
		# (console, world)	= stdio world
		# console			= fwrites "HTTP server started...\n" console
		# console			= fwrites ("Please point your browser to http://localhost/" +++ ThisExe +++ "\n") console
		# (_,world)			= fclose console world
		= world
		
	unimplemented :: *World -> *World
	unimplemented world
		# (console, world)	= stdio world
		# console			= fwrites "The chosen server mode is not supported yet.\n" console
		# console			= fwrites "Please select ServerKind Internal in iDataSettings.dcl.\n" console
		# (_,world)			= fclose console world
		= world
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
83

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
StartServer :: !UserPage !*World -> *World
StartServer userpage world
= http_startServer ServerOptions [((==) ("/" +++ ThisExe), IF_Ajax doAjaxInit (doDynamicResource userpage))
								 ,((==) ("/" +++ ThisExe +++ "_ajax"), IF_Ajax (doDynamicResource userpage) http_notfoundResponse)
								 ,(\_ -> True, doStaticResource)
								 ] world

// Request handler which serves static resources from the application directory,
// or a system wide default directory if it is not found locally.
// This request handler is used for serving system wide javascript, css, images, etc...
doStaticResource :: !HTTPRequest *World -> (!HTTPResponse, !*World)
doStaticResource req world
	# filename				= MyAbsDir +++ req.req_path	
	# (type, world)			= http_staticFileMimeType filename world
	# (ok, content, world)	= http_staticFileContent filename world
	| ok					= ({rsp_headers = [("Status","200 OK"),
											   ("Content-Type", type),
											   ("Content-Length", toString (size content))]
							   ,rsp_data = content}, world)
	# filename				= ResourceDir +++ (req.req_path % ((size ThisExe) + 1, size req.req_path)) //Remove the /(ThisExe)/ from the filename
	# (type, world)			= http_staticFileMimeType filename world
	# (ok, content, world)	= http_staticFileContent filename world
	|  ok 					= ({rsp_headers = [("Status","200 OK"),
											   ("Content-Type", type),
											   ("Content-Length", toString (size content))]
							   	,rsp_data = content}, world)		 							   
	= http_notfoundResponse req world

// Request handler which handles dynamically generated pages.
doDynamicResource :: !UserPage !HTTPRequest !*World -> (!HTTPResponse, !*World)
doDynamicResource userpage request world
	# (toServer,html,world)	= doHtmlPage request userpage [|] world
	= ({http_emptyResponse & rsp_data = (toString html)}, world)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
117

118
119
120
// General entry used by all servers and client to calculate the next page
doHtmlPage :: !HTTPRequest !.(*HSt -> (!Bool,Html,!*HSt)) !*HtmlStream !*World -> (!Bool,!*HtmlStream,!*World)
doHtmlPage request userpage inout world
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
121
122
123
# (gerda,world)				= openDatabase ODCBDataBaseName world						// open the relational database if option chosen
# (datafile,world)			= openmDataFile DataFileName world							// open the datafile if option chosen
# nworld 					= {worldC = world, inout = inout, gerda = gerda, datafile = datafile}	
124
125
126
127
# (initforms,nworld)	 	= retrieveFormStates request.arg_post nworld				// Retrieve the state information stored in an html page, other state information is collected lazily
# hst						= {(mkHSt initforms nworld) & request = request}			// Create the HSt
# (toServer,Html (Head headattr headtags) (Body bodyattr bodytags),{states,world}) 
							= userpage hst												// Call the user application
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
128
# (debugOutput,states)		= if TraceOutput (traceStates states) (EmptyBody,states)	// Optional show debug information
129
# (pagestate, focus, world=:{worldC,gerda,inout,datafile})	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
130
131
132
133
134
							= storeFormStates states world								// Store all state information
# worldC					= closeDatabase gerda worldC								// close the relational database if option chosen
# worldC					= closemDataFile datafile worldC							// close the datafile if option chosen
# inout						= IF_Ajax
								(print_to_stdout "" inout <+
135
136
								(pagestate) <+ State_FormList_Separator <+				// state information
        		 				AjaxCombine bodytags [debugInput,debugOutput]			// page, or part of a page
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
137
138
								)
								(print_to_stdout 										// Print out all html code
139
140
									(Html (Head headattr [mkJsTag, mkCssTag : headtags]) 
									(Body bodyattr [mkInfoDiv pagestate focus : bodytags ++ [debugInput,debugOutput]]))
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
141
142
									inout
								)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
143
= (toServer,inout,worldC)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
144
145
146
147
148
where
	AjaxCombine [Ajax bodytags:ys] [EmptyBody,EmptyBody] 	= [Ajax bodytags:ys]
	AjaxCombine [Ajax bodytags:ys] debug 					= [Ajax [("debug",debug):bodytags]:ys]
	AjaxCombine [] debug 									= abort "AjaxCombine cannot combine empty result"
	
149
	debugInput				= if TraceInput (traceHtmlInput request.arg_post) EmptyBody
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
150

151
152
mkPage :: [HeadAttr] [HeadTag] [BodyAttr] [BodyTag] -> Html
mkPage headattr headtags bodyattr bodytags = Html (Head headattr headtags) (Body bodyattr bodytags)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
153

154
155
mkCssTag :: HeadTag
mkCssTag = Hd_Link [Lka_Type "text/css", Lka_Rel Docr_Stylesheet, Lka_Href ExternalCleanStyles]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
156

157
158
mkJsTag :: HeadTag
mkJsTag = Hd_Script [Scr_Src (ThisExe +++ "/js/clean.js"), Scr_Type TypeJavascript ] (SScript "")
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
159

160
161
162
163
164
165
166
167
168
169
170
mkInfoDiv :: String String -> BodyTag
mkInfoDiv state focus =
	Div [`Div_Std [Std_Style "display:none"]] [
	Div [`Div_Std [Std_Id "GS"]] [Txt state],
	Div [`Div_Std [Std_Id "FS"]] [Txt focus],
	Div [`Div_Std [Std_Id "AN"]] [Txt ThisExe],
	Div [`Div_Std [Std_Id "OPT-ajax"]] [Txt (IF_Ajax "true" "false")]
	]

doAjaxInit :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
doAjaxInit req world = ({http_emptyResponse & rsp_data = toString (print_to_stdout page [|])}, world)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
171
where
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
	page = mkPage [] [mkCssTag, mkJsTag] []	 
		([ mkInfoDiv "" ""
		 , Div [`Div_Std [Std_Id "thePage", Std_Class "thread"]] [Txt (ThisExe +++ " loading. Please wait...")]
		 , Div [`Div_Std [Std_Id "iTaskInfo", Std_Class "thread"]] []
		 , Div [`Div_Std [Std_Id "debug", Std_Class "thread"]] []
		 ] ++ (IF_ClientServer 
		 		[Applet [`Apl_Std [Std_Id "SA", Std_Style "visibility: hidden; width: 1px; height: 1px;"]
		 				, Apl_Archive (ThisExe +++ "/jar/jme.jar")
		 				, Apl_Codebase "."
		 				, Apl_Code "jme.ClientApplet.class"	
		 				] ""
		 		]
		 		[]
		 	   )
		)
				  	
//This wrapper is used when the program is run on the client in the sapl interpreter
doHtmlClient :: UserPage !*World -> !*World
doHtmlClient userpage world
# (sio,world) 					= stdio world
# (data,sio)					= freadline sio															//Fetch all input
# req							= http_emptyRequest
# (req,mdone,hdone,ddone,error)	= http_addRequestData req False False False data
# req							= http_parseArguments req												//Parse the parameters int he request
# (toServer,html,world)			= doHtmlPage req userpage [|] world										//Run the user page
# sio							= fwrites (toString toServer +++ "#0#" +++ toString html) sio			//Write the output
# world							= snd (fclose sio world)
= world



 	
mkHSt :: *FormStates *NWorld -> *HSt
205
mkHSt states nworld = {cntr=0, states=states, request= http_emptyRequest, world=nworld, submits = False, issub = False }
206

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
207

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
208
209
210
// The function mkViewForm is *the* magic main function 
// All idata /itasks end up in this function
// It does everything, a swiss army knife editor that makes coffee too ...
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
211
212

mkViewForm :: !(InIDataId d) !(HBimap d v) !*HSt -> (Form d,!*HSt) | iData v
213
mkViewForm (init,formid) bm=:{toForm, updForm, fromForm, resetForm} hst=:{states,world,submits,issub} 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
| init == Const	&& formid.lifespan <> Temp
= mkViewForm (init,{formid & lifespan = Temp}) bm hst					// constant i-data are never stored
| init == Const															// constant i-data, no look up of previous value
= calcnextView False Nothing states world				
# (isupdated,view,states,world) = findFormInfo vformid states world 	// determine current view value in the state store
= calcnextView isupdated view states world								// and calculate new i-data
where
	vformid					= reuseFormId formid (toForm init formid.ival Nothing)

	calcnextView isupdated view states world
	# (changedids,states)	= getUpdateId states
	# changed				= {isChanged = isupdated, changedId = changedids}
	# view					= toForm init formid.ival view				// map value to view domain, given previous view value
	# view					= updForm  changed view						// apply update function telling user if an update has taken place
	# newval				= fromForm changed view						// convert back to data domain	 
	# view					= case resetForm of							// optionally reset the view hereafter for next time
								Nothing 	-> view		 
								Just reset 	-> reset view

	| formid.mode == NoForm												// don't make a form at all
		# (states,world)	= replaceState` vformid view states world	// store new value into the store of states
		= ({ changed		= False
		   , value			= newval
		   , form			= []
		   }
		  ,mkHSt states world)

	# (viewform,{states,world})											// make a form for it
242
							= mkForm (init,if (init == Const) vformid (reuseFormId formid view)) ({mkHSt states world & submits = submits, issub = issub})
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
243
244
245
246
247
248
249
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
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301

	| viewform.changed && not isupdated						 			// important: redo it all to handle the case that a user defined specialisation is updated !!
							= calcnextView True (Just viewform.value) states world

	# (states,world)		= replaceState` vformid viewform.value states world	// store new value into the store of states

	= (	{ changed			= isupdated
		, value				= newval
		, form				= viewform.form
		}
	  ,mkHSt states world)

	replaceState` vformid view states world
	| init <> Const			= replaceState vformid view states world
	| otherwise				= (states,world)

//	findFormInfo :: FormId *FormStates *NWorld -> (Bool,Maybe a,*FormStates,*NWorld) | gUpd{|*|} a & gParse{|*|} a & TC a
	findFormInfo formid formStates world
	# (updateids,formStates) 					= getUpdateId formStates // get list of updated id's
	| not (isMember formid.id updateids)		
		# (bool,justcurstate,formStates,world)	= findState formid formStates world									// the current form is not updated
		= (False,justcurstate,formStates,world)
	# (alltriplets,formStates)	= getTriplets formid.id formStates		// get my update triplets
	= case (findState formid formStates world) of
			(False,Just currentState,formStates,world) -> (False, Just currentState,formStates,world) 				// yes, but update already handled
			(True, Just currentState,formStates,world) -> updateState alltriplets currentState formStates world		// yes, handle update
			(_,    Nothing,formStates,world) 		   -> (False, Nothing,formStates,world) 		  				// cannot find previously stored state


	updateState alltriplets currentState formStates world
	# allUpdates = [update \\ tripletupd <- alltriplets, (Just update) <- [examineTriplet tripletupd]]
	# newState = applyUpdates allUpdates currentState
	= (True,Just newState,formStates,world)

	applyUpdates [] currentState 					= currentState
	applyUpdates [(pos,upd):updates] currentState	= applyUpdates updates (snd (gUpd{|*|} (UpdSearch upd pos) currentState))

	examineTriplet :: TripletUpdate -> Maybe (Int,UpdValue)
	examineTriplet tripletupd
		= case parseTriplet tripletupd of
			((sid,pos,UpdC s), Just "") 								= (Just (pos,UpdC s) )
			((sid,pos,UpdC s), _) 										= (Just (pos,UpdC s) )
			(_,_)= case parseTriplet tripletupd of
					((sid,pos,UpdI i), Just ni) 						= (Just (pos,UpdI ni))
					((sid,pos,UpdI i), _) 								= (Just (pos,UpdI i) )
					(_,_) = case parseTriplet tripletupd of
							((sid,pos,UpdR r), Just nr) 				= (Just (pos,UpdR nr))
							((sid,pos,UpdR r), _) 						= (Just (pos,UpdR r) )
							(_,_) = case parseTriplet tripletupd of
									((sid,pos,UpdB b), Just nb) 		= (Just (pos,UpdB nb))
									((sid,pos,UpdB b), _) 				= (Just (pos,UpdB b) )
									(_,_) = case parseTriplet tripletupd of
										((sid,pos,UpdS s),	Just ns)	= (Just (pos,UpdS ns))
										_								= case  tripletupd of
																			((sid,pos,UpdS s), ns) -> (Just (pos, UpdS ns))
																			_ -> (Nothing			 )
	where
		parseTriplet :: TripletUpdate -> (Triplet,Maybe b) | gParse {|*|} b
		parseTriplet (triplet,update) = (triplet,parseString update)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
302

303
// It can be convenient to explicitly delete IData, in particular for persistent IData object
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
304
// or to optimize iTasks
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
305
// All IData objects administrated in the state satisfying the predicate will be deleted, no matter where they are stored.
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
306
307
308
309
310
311

deleteIData :: !String !*HSt -> *HSt
deleteIData prefix hst=:{states,world}
# (states,world) = deleteStates prefix states world
= {hst & states = states, world = world}

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
312
313
314
315
316
317
changeLifespanIData :: !String !Lifespan !Lifespan !*HSt -> *HSt
changeLifespanIData prefix oldspan newspan hst=:{states,world}
# (states,world) = changeLifetimeStates  prefix oldspan newspan states world
= {hst & states = states, world = world}


Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
// specialize has to be used if a programmer wants to specialize gForm.
// It remembers the current value of the index in the expression and creates an editor to show this value.
// The value might have been changed with this editor, so the value returned might differ from the value you started with!

specialize :: !((InIDataId a) *HSt -> (Form a,*HSt)) !(InIDataId a) !*HSt -> (!Form a,!*HSt) | gUpd {|*|} a
specialize editor (init,formid) hst=:{cntr = inidx,states = formStates,submits,world}
# nextidx					= incrIndex inidx formid.ival		// this value will be repesented differently, so increment counter 
# (nv,hst) 					= editor (init,nformid) (setCntr 0 hst)
= (nv,{setCntr nextidx hst & submits = submits})
where
	nformid					= {formid & id = formid.id <+++ "_specialize_" <+++ inidx <+++ "_"}

	incrIndex :: Int v -> Int | gUpd {|*|} v
	incrIndex i v
	# (UpdSearch _ cnt,v)	= gUpd {|*|} (UpdSearch (UpdI 0) -1) v
	= i + (-1 - cnt)

335

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
336
337
338
// gForm: automatically derives a Html form for any Clean type

mkForm :: !(InIDataId a) !*HSt -> *(Form a, !*HSt)	| gForm {|*|} a
339
340
mkForm (init,formid) hst =: {issub}
# (form,hst) 	= gForm{|*|} (init,formid) {hst & submits = (formid.mode == Submit), issub = True}	//Use gForm to create the html form
341
342
343
344
# buttons		= if (formid.mode == Submit) 										 				//Add submit and clear buttons to a form in submit mode.
						[ Br
						, Input [ Inp_Type Inp_Submit, Inp_Value (SV "Submit")] ""
						, Input [ Inp_Type Inp_Reset, Inp_Value (SV "Clear")] ""
345
						, Br
346
347
348
						]
						[ Input [Inp_Type Inp_Submit, `Inp_Std [Std_Style "display: none"] ] ""]	//Add a hidden submit input to allow updates on press of "enter" button 

349
350
351
# sform			= if issub
					form.form
					[Form [ Frm_Action ("/" +++ ThisExe)												//Wrap the form in html form tags
352
353
354
355
356
357
						, Frm_Method Post
						, Frm_Name  (encodeString formid.id)										//Enable the use of any character in a form name
						, Frm_Enctype "multipart/form-data"
						, `Frm_Events [OnSubmit (SScript "return catchSubmit(this);")]
						, `Frm_Std [Std_Id (encodeString formid.id)]
						] (form.form ++ buttons)
358
				  	] 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
359
= ({form & form = sform} ,hst)
360

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
generic gForm a :: !(InIDataId a) !*HSt -> *(Form a, !*HSt)	

gForm{|Int|} (init,formid) hst 	
# (body,hst)				= mkInput defsize (init,formid) (IV i) (UpdI i) hst
= ({ changed				= False
   , value					= i
   , form					= [body]
   },hst)
where
	i						= formid.ival 
gForm{|Real|} (init,formid) hst 	
# (body,hst)				= mkInput defsize (init,formid) (RV r) (UpdR r) hst
= ({ changed				= False
   , value					= r
   , form					= [body]
   },hst)
where
	r						= formid.ival 
gForm{|Bool|} (init,formid) hst 	
# (body,hst)				= mkInput defsize (init,formid) (BV b) (UpdB b) hst
= ({ changed				= False
   , value					= b
   , form					= [body]
   },hst)
where
	b						= formid.ival 
gForm{|String|} (init,formid) hst 	
# (body,hst)				= mkInput defsize (init,formid) (SV s) (UpdS s) hst
= ({ changed				= False
   , value					= s
   , form					= [body]
   },hst)
where
	s						= formid.ival 
gForm{|UNIT|}  _ hst
= ({ changed				= False
   , value					= UNIT
   , form					= [EmptyBody]
   },hst)
gForm{|PAIR|} gHa gHb (init,formid) hst 
# (na,hst)					= gHa (init,reuseFormId formid a) hst
# (nb,hst)					= gHb (init,reuseFormId formid b) hst
= ({ changed				= na.changed || nb.changed
   , value					= PAIR na.value nb.value
   , form					= [STable [Tbl_CellPadding (Pixels 0), Tbl_CellSpacing (Pixels 0)] [na.form,nb.form]]
   },hst)
where
	(PAIR a b)				= formid.ival 
gForm{|EITHER|} gHa gHb (init,formid)  hst 
= case formid.ival of
	(LEFT a)
		# (na,hst)			= gHa (init,reuseFormId formid a) hst
		= ({na & value=LEFT na.value},hst)
	(RIGHT b)
		# (nb,hst)			= gHb (init,reuseFormId formid b) hst
		= ({nb & value=RIGHT nb.value},hst)
gForm{|OBJECT|} gHo (init,formid) hst
# (no,hst)					= gHo (init,reuseFormId formid o) hst
= ({no & value=OBJECT no.value},hst)
where
	(OBJECT o) = formid.ival
gForm{|CONS of t|} gHc (init,formid) hst=:{cntr,submits}
| not (isEmpty t.gcd_fields) 		 
	# (nc,hst)				= gHc (init,reuseFormId formid c) (setCntr (cntr+1) hst) // don't display record constructor
	= ({nc & value=CONS nc.value},hst)
| t.gcd_type_def.gtd_num_conses == 1 
	# (nc,hst)				= gHc (init,reuseFormId formid c) (setCntr (cntr+1) hst) // don't display constructors that have no alternative
	= ({nc & value=CONS nc.value},hst)
| t.gcd_name.[(size t.gcd_name) - 1] == '_' 										 // don't display constructor names which end with an underscore
	# (nc,hst)				= gHc (init,reuseFormId formid c) (setCntr (cntr+1) hst) 
	= ({nc & value=CONS nc.value},hst)
# (selector,hst)			= mkConsSelector formid t hst
# (nc,hst)					= gHc (init,reuseFormId formid c) hst
= ({ changed				= nc.changed
   , value					= CONS nc.value
   , form					= [STable [Tbl_CellPadding (Pixels 0), Tbl_CellSpacing (Pixels 0)] [[selector,BodyTag nc.form]]]
   },hst)
where
	(CONS c)				= formid.ival

	mkConsSelector formid thiscons hst=:{cntr} 
							= (mkConsSel cntr myname allnames myindex formid, setCntr (cntr+1) hst)
	where
		myname				= thiscons.gcd_name
		allnames			= map (\n -> n.gcd_name) thiscons.gcd_type_def.gtd_conses
		myindex				= case allnames ?? myname of
								-1			-> abort ("cannot find index of " +++ myname )
								i			-> i

	mkConsSel :: Int String [String] Int (FormId x) -> BodyTag
	mkConsSel cntr myname list nr formid
		= Select [ Sel_Name (selectorInpName +++ encodeString myname) : styles ]		// changed to see changes in case of a submit
				 [ Option  
					[Opt_Value (encodeTriplet (formid.id,cntr,UpdC elem)) : if (j == nr) [Opt_Selected Selected:optionstyle] optionstyle] elem
				 \\ elem <- list & j <- [0..]
				 ] 
		where
			styles			= case formid.mode of
459
460
								Edit	-> [ `Sel_Std	[Std_Style width, EditBoxStyle, Std_Id (encodeInputId (formid.id,cntr,UpdC myname))]
										   , `Sel_Events (if submits [] (callClean OnChange Edit "" formid.lifespan True))
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
461
										   ]
462
								Submit	-> [ `Sel_Std	[Std_Style width, EditBoxStyle, Std_Id (encodeInputId (formid.id,cntr,UpdC myname))]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
463
464
465
466
467
468
469
470
471
472
473
474
										   ]
								_		-> [ `Sel_Std	[Std_Style width, DisplayBoxStyle]
										   ,  Sel_Disabled Disabled
										   ]
			optionstyle		= case formid.mode of
								Edit	-> []
								Submit	-> []
								_	 	-> [`Opt_Std [DisplayBoxStyle]]

			width			= "width:" <+++ defpixel <+++ "px"
gForm{|FIELD of d |} gHx (init,formid) hst 
# (nx,hst)					= gHx (init,reuseFormId formid x) hst
475
476
477
478
479
| d.gfd_name.[(size d.gfd_name) - 1] == '_' 										 // don't display field names which end with an underscore
							= ({ changed	= False
							   , value		= formid.ival
							   , form		= []
							   },hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
= ({ changed				= nx.changed
   , value					= FIELD nx.value
   , form					= [STable [Tbl_CellPadding (Pixels 1), Tbl_CellSpacing (Pixels 1)] [[fieldname,BodyTag nx.form]]]
   },hst)
where
	(FIELD x)				= formid.ival
	
	fieldname				= Input [ Inp_Type		Inp_Text
									, Inp_Value		(SV (prettify d.gfd_name +++ ": "))
									, Inp_ReadOnly	ReadOnly
									, Inp_Disabled	Disabled
									, `Inp_Std		[DisplayBoxStyle]
									, Inp_Size		maxsize`
									] ""

	prettify name			= mkString [toUpper lname : addspace lnames]
	where
		[lname:lnames]		= mkList name
		addspace []			= []
		addspace [c:cs]
		| isUpper c			= [' ',toLower c:addspace cs]
		| otherwise			= [c:addspace cs]
		
	maxsize`				= ndefsize maxsize defsize
	maxsize					= takemax defsize [size (prettify gfd_name) * 8 / 10 \\ {gfd_name} <- d.gfd_cons.gcd_fields]
	
	takemax i []			= i
	takemax i [j:js] 
	| i > j					= takemax i js
	| otherwise				= takemax j js

	ndefsize max def
	| max - def <= 0		= def
	| otherwise				= ndefsize max (def + defsize)
gForm{|(->)|} garg gres (init,formid) hst 	
= ({ changed = False, value = formid.ival, form = []},hst)

// gUpd calculates a new value given the current value and a change in the value.
// If necessary it invents new default values (e.g. when switching from Nil to Cons)
// and leaves the rest untouched.

:: UpdMode	= UpdSearch UpdValue Int		// search for indicated postion and update it
			| UpdCreate [ConsPos]			// create new values if necessary
			| UpdDone						// and just copy the remaining stuff

generic gUpd t :: UpdMode t -> (UpdMode,t)

gUpd{|Int|} (UpdSearch (UpdI ni) 0) 	_ = (UpdDone,ni)					// update integer value
gUpd{|Int|} (UpdSearch val cnt)     	i = (UpdSearch val (dec cnt),i)		// continue search, don't change
gUpd{|Int|} (UpdCreate l)				_ = (UpdCreate l,0)					// create default value
gUpd{|Int|} mode 			  	    	i = (mode,i)						// don't change

gUpd{|Real|} (UpdSearch (UpdR nr) 0) 	_ = (UpdDone,nr)					// update real value
gUpd{|Real|} (UpdSearch val cnt)     	r = (UpdSearch val (dec cnt),r)		// continue search, don't change
gUpd{|Real|} (UpdCreate l)			 	_ = (UpdCreate l,0.0)				// create default value
gUpd{|Real|} mode 			  	     	r = (mode,r)						// don't change

gUpd{|Bool|} (UpdSearch (UpdB nb) 0) 	_ = (UpdDone,nb)					// update boolean value
gUpd{|Bool|} (UpdSearch val cnt)     	b = (UpdSearch val (dec cnt),b)		// continue search, don't change
gUpd{|Bool|} (UpdCreate l)			 	_ = (UpdCreate l,False)				// create default value
gUpd{|Bool|} mode 			  	     	b = (mode,b)						// don't change

gUpd{|String|} (UpdSearch (UpdS ns) 0) 	_ = (UpdDone,ns)					// update string value
gUpd{|String|} (UpdSearch val cnt)     	s = (UpdSearch val (dec cnt),s)		// continue search, don't change
gUpd{|String|} (UpdCreate l)		   	_ = (UpdCreate l,"")				// create default value
gUpd{|String|} mode 			  	 	s = (mode,s)						// don't change

gUpd{|UNIT|} mode _			= (mode,UNIT)

gUpd{|PAIR|} gUpda gUpdb mode=:(UpdCreate l) _								// invent a pair
# (mode,a)					= gUpda mode (abort "PAIR a evaluated")
# (mode,b)					= gUpdb mode (abort "PAIR b evaluated")
= (mode,PAIR a b)
gUpd{|PAIR|} gUpda gUpdb mode (PAIR a b)									// pass mode to a and b in all other cases
# (mode,a)					= gUpda mode a
# (mode,b)					= gUpdb mode b
= (mode,PAIR a b)

gUpd{|EITHER|} gUpda gUpdb (UpdCreate [ConsLeft:cl]) _
# (mode,a)					= gUpda (UpdCreate cl) (abort "LEFT a evaluated")
= (mode,LEFT a)
gUpd{|EITHER|} gUpda gUpdb (UpdCreate [ConsRight:cl]) _
# (mode,b)					= gUpdb (UpdCreate cl) (abort "RIGHT b evaluated")
= (mode,RIGHT b)
gUpd{|EITHER|} gUpda gUpdb (UpdCreate []) _ 
# (mode,b)					= gUpdb (UpdCreate []) (abort "Empty EITHER evaluated")
= (mode,RIGHT b)
gUpd{|EITHER|} gUpda gUpdb mode (LEFT a)
# (mode,a)					= gUpda mode a
= (mode,LEFT a)
gUpd{|EITHER|} gUpda gUpdb mode (RIGHT b)
# (mode,b)					= gUpdb mode b
= (mode,RIGHT b)

gUpd{|OBJECT|} gUpdo (UpdCreate l) _ 										// invent new type
# (mode,o)					= gUpdo (UpdCreate l) (abort "OBJECT evaluated")
= (mode,OBJECT o)
gUpd{|OBJECT of typedes|} gUpdo (UpdSearch (UpdC cname) 0) (OBJECT o) 		// constructor changed of this type
# (mode,o)					= gUpdo (UpdCreate path) o
= (UpdDone,OBJECT o)
where
	path					= getConsPath (hd [cons \\ cons <- typedes.gtd_conses | cons.gcd_name == cname])
gUpd{|OBJECT|} gUpdo (UpdSearch val cnt) (OBJECT o)							// search further
# (mode,o)					= gUpdo (UpdSearch val (dec cnt)) o
= (mode,OBJECT o)
gUpd{|OBJECT|} gUpdo mode (OBJECT o)										// other cases
# (mode,o)					= gUpdo mode o
= (mode,OBJECT o)

gUpd{|CONS|} gUpdo (UpdCreate l) _ 											// invent new constructor ??
# (mode,c)					= gUpdo (UpdCreate l) (abort "CONS evaluated")
= (mode,CONS c)
gUpd{|CONS|} gUpdo mode (CONS c) 											// other cases
# (mode,c)					= gUpdo mode c
= (mode,CONS c)

gUpd{|FIELD|} gUpdx (UpdCreate l) _  										// invent new type 
# (mode,x)					= gUpdx (UpdCreate l) (abort "Value of FIELD evaluated")
= (mode,FIELD x)
gUpd{|FIELD|} gUpdx mode (FIELD x)											// other cases
# (mode,x)					= gUpdx mode x
= (mode,FIELD x)

gUpd{|(->)|} gUpdArg gUpdRes mode f
= (mode,f)	

// small utility functions

mkInput :: !Int !(InIDataId d) Value UpdValue !*HSt -> (BodyTag,*HSt) 
mkInput size (init,formid=:{mode}) val updval hst=:{cntr,submits} 
| mode == Edit || mode == Submit
	= ( Input 	[ Inp_Type		Inp_Text
				, Inp_Value		val
				, Inp_Name		(encodeTriplet (formid.id,cntr,updval))
				, Inp_Size		size
615
				, `Inp_Std		[EditBoxStyle, Std_Title (showType val), Std_Id (encodeInputId (formid.id,cntr,updval))]
616
				, `Inp_Events	if (mode == Edit && not submits) (callClean OnChange formid.mode "" formid.lifespan False) []
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
				] ""
	  , setCntr (cntr+1) hst)
| mode == Display
	= ( Input 	[ Inp_Type		Inp_Text
				, Inp_Value		val
				, Inp_ReadOnly	ReadOnly
				, `Inp_Std		[DisplayBoxStyle]
				, Inp_Size		size
				] ""
		,setCntr (cntr+1) hst)
= ( EmptyBody,setCntr (cntr+1) hst)
where
	showType (SV  str) 	= "::String"
	showType (NQV str)	= "::String"
	showType (IV i)		= "::Int"
	showType (RV r) 	= "::Real"
	showType (BV b) 	= "::Bool"
		
toHtml :: a -> BodyTag | gForm {|*|} a
toHtml a
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
637
# (na,_)						= mkForm (Set,mkFormId "__toHtml" a <@ Display) (mkHSt emptyFormStates (abort "illegal call to toHtml"))
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
638
639
640
641
642
643
644
645
646
647
648
649
650
651
= BodyTag na.form

toHtmlForm :: !(*HSt -> *(Form a,*HSt)) -> [BodyTag] | gForm{|*|}, gUpd{|*|}, gPrint{|*|}, gParse{|*|}, TC a
toHtmlForm anyform 
# (na,hst)						= anyform (mkHSt emptyFormStates undef)
= na.form

toBody :: (Form a) -> BodyTag
toBody form						= BodyTag form.form

derive gUpd 	Inline
derive gParse 	Inline
derive gPrint 	Inline
derive gerda 	Inline
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
652
653
derive read 	Inline
derive write 	Inline
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715

gForm{|Inline|} (init,formid) hst
# (Inline string) =  formid.ival 	
= ({changed=False, value=formid.ival, form=[InlineCode string]},incrHSt 2 hst)

showHtml :: [BodyTag] -> Inline
showHtml bodytags = Inline (foldl (+++) "" (reverse [x \\ x <|- gHpr {|*|} [|] bodytags]))

createDefault :: a | gUpd{|*|} a 
createDefault					= fromJust (snd (gUpd {|*|} (UpdSearch (UpdC "Just") 0) Nothing))
derive gUpd Maybe

setCntr :: InputId *HSt -> *HSt
setCntr i hst					= {hst & cntr = i}

incrHSt :: Int !*HSt -> *HSt
incrHSt i hst					= {hst & cntr = hst.cntr + i} // BUG ??????

CntrHSt :: !*HSt -> (Int,*HSt)
CntrHSt hst=:{cntr}				= (cntr,hst)

getChangedId :: !*HSt -> ([String],!*HSt)	// id of form that has been changed by user
getChangedId hst=:{states}
# (ids,states)					= getUpdateId states
= (ids,{hst & states = states })

// Enabling file IO on HSt

instance FileSystem HSt where
	fopen string int hst=:{world}
		# (bool,file,world)		= fopen string int world
		= (bool,file,{hst & world = world})

	fclose file hst=:{world}
		# (bool,world)			= fclose file world
		= (bool,{hst & world = world})

	stdio hst=:{world}
		# (file,world)			= stdio world
		= (file,{hst & world = world})

	sfopen string int hst=:{world}
		# (bool,file,world)		= sfopen string int world
		= (bool,file,{hst & world = world})

// General access to the World environment on HSt:

appWorldHSt :: !.(*World -> *World) !*HSt -> *HSt
appWorldHSt f hst=:{world}
	= {hst & world=appWorldNWorld f world}

accWorldHSt :: !.(*World -> *(.a,*World)) !*HSt -> (.a,!*HSt)
accWorldHSt f hst=:{world}
	# (a,world)	= accWorldNWorld f world
	= (a,{hst & world=world})

// test interface

runUserApplication :: .(*HSt -> *(.a,*HSt)) *FormStates *NWorld -> *(.a,*FormStates,*NWorld)
runUserApplication userpage states nworld
# (html,{states,world})			= userpage (mkHSt states nworld)
= (html,states,world)