Commit 055f842b authored by Rinus Plasmeijer's avatar Rinus Plasmeijer
Browse files

*** empty log message ***

parent 032f5614
......@@ -119,9 +119,6 @@ where
= case toString update of
"CS" -> ("clean", decodeChars new, "", toString state)
else -> ("clean", decodeChars update, toString new, toString state)
/* = case decodeChars update of
"CS" -> ("clean", decodeChars new, "", decodeChars state)
else -> ("clean", decodeChars update, decodeChars new, decodeChars state)*/
FindSubstr substr list = FindSubstr` list 0
where
......@@ -141,9 +138,12 @@ traceHtmlInput serverkind args
,[B [] "Identifier:", B [] "Lifetime:", B [] "Format:", B [] "Value:"]
:[[Txt id, Txt (showl life), Txt (showf storage), Txt (shows storage state)]
\\ (id,life,storage,state) <- htmlState]]
, Br
, Br
, Txt string
]
where
(Just string) = args
(htmlState,triplet,update) = DecodeHtmlStatesAndUpdate serverkind args
showl life = case life of Persistent -> "Persistent"; Session -> "Session"; _ -> "Page"
......@@ -300,7 +300,7 @@ skipping [c:cs] list=:[x:xs]
| otherwise = list
skipping any list = list
/* The following code is not used anymore...
// The following code is not used anymore...
// encoding - decoding to hexadecimal code
......@@ -341,4 +341,4 @@ where
| i <= toInt '9' = i - toInt '0'
= i - (toInt 'A' - 10)
urlDecode` [x:xs] = [x:urlDecode` xs]
*/
definition module databaseDef
import StdMaybe, support
// Mydatabase
:: MyDatabase = Academics Academics
| Departments Departments
| Empty
:: Academics = Academic [Academic] // Shared Table
:: Departments = Department [Department] // Shared Table
// types with a special effect
:: Uniq = Uniq Int // will automatically generate non editable unique number
// Academic types
:: Academic = { nr :: Uniq
, person :: Person
, works_for :: RefDept
, room :: Room
, phone :: Phone
, contract :: Contract
, rank :: Rank
, degree :: Degrees
, appointment :: Appointment
, teaches :: Topics
}
:: Person = { surname :: String
, name :: String
, phone :: Opt Int
}
:: Opt a = Yes a | No
:: RefDept = RefDept Int
:: Room = Room RoomNr Building
:: RoomNr :== Int
:: Building = ScienceBuilding
| AcademicHospital
:: Phone = { extension :: Int
, access_Level :: Access_Level
}
:: Access_Level = International
| National
| Local
:: Contract = Tenjured
| Till Date
:: University = RUU
| TUE
| UT
| RU
:: Rank = Prof
| SeniorLecturer
| Lecturer
:: Degrees = Degree [(X_Degree,University)]
:: X_Degree = DSc
| MSc
| BSc
:: Appointment = TeachingAndProf TeachingAndProf
| Professor Professor
| Teacher Teacher
| Standard
:: Teacher = { audited :: Others
}
:: Others = Other [RefTeachers]
:: RefTeachers :== Int
:: Professor = { chair :: Chair
, heads :: Opt RefDept
}
:: Chair = Foundation
| Information_Systems
| Software_Technology
:: TeachingAndProf
= { serves :: String
, teacher :: Teacher
, professor :: Professor
}
:: Topics = Topic [Topic]
:: Topic = { topic :: X_TopicCode
, rating :: Opt Rating
}
:: Rating :== Int
:: X_TopicCode = ProgramI
| ProgramII
| FoundationI
| FuncProgramm
// Department types
:: Department = { dnr :: Uniq
, departmentName :: X_DepartmentName
, teachingBudget :: Dollars
, researchBudget :: Dollars
, head :: RefAcademicus
}
:: X_DepartmentName
= BioChemistry
| Mathematics
| Philosopy
| ComputerScience
| NoDepartment
:: Dollars :== Int
:: RefAcademicus
= RefAcad Int
\ No newline at end of file
implementation module databaseDef
import StdMaybe, support
definition module databaseIData
import StdEnv, StdMaybe
import StdHtml
import databaseDef, support
// specially defined and generated iData
derive gForm [], Maybe,
Academic, X_DepartmentName, Phone, Access_Level, Contract, University, X_Degree, Rank, Chair,
Appointment, Teacher, Professor, TeachingAndProf, Person, Room, Building,
Uniq, Opt, Others, Topic, X_TopicCode, Degrees, Topics,
Department, MyDatabase, RefAcademicus, Academics, Departments,RefDept
derive gUpd [], Maybe,
Academic, X_DepartmentName, Phone, Access_Level, Contract, University, X_Degree, Rank, Chair,
Appointment, Teacher, Professor, TeachingAndProf, Person, Room, Building,
Uniq, Opt, Others, Topic, X_TopicCode, Degrees, Topics,
Department, MyDatabase, RefAcademicus, Academics, Departments,RefDept
derive gPrint Maybe,
Academic, X_DepartmentName, Phone, Access_Level, Contract, University, X_Degree, Rank, Chair,
Appointment, Teacher, Professor, TeachingAndProf, Person, Room, Building,
Uniq, Opt, Others, Topic, X_TopicCode, Degrees, Topics,
Department, MyDatabase, RefAcademicus, Academics, Departments,RefDept
derive gParse Maybe,
Academic, X_DepartmentName, Phone, Access_Level, Contract, University, X_Degree, Rank, Chair,
Appointment, Teacher, Professor, TeachingAndProf, Person, Room, Building,
Uniq, Opt, Others, Topic, X_TopicCode, Degrees, Topics,
Department, MyDatabase, RefAcademicus, Academics, Departments,RefDept
\ No newline at end of file
implementation module databaseIData
import StdEnv, StdMaybe
import StdHtml
import databaseDef, support
academicTable :: FormId [Academic]
academicTable = pFormId "academicTable" []
departmentTable :: FormId [Department]
departmentTable = pFormId "departmentTable" []
/*
swapTable [STable attr table] = swapTable` [STable attr table] [[],[]]
where
swapTable` [STable attr [[Input iattr str,body]]] [fields,bodies] = [STable attr [Input iattr str:fields],[body:bodies]]
swapTable` [STable attr [left,right]] accu = swapTable` right (swapTable` left accu)
swapTable` [x:xs] accu = [x : swapTable` accu]
swapTable` [] accu = accu
swapTable else = else
*/
//turnTable table = [STable attr [[field][value]] \\ (STable attr oneitem) <- table, [field,value:_] <- oneitem ]
gForm {|Academics|} formid hst
= specialize myeditor (Init,formid) hst
where
myeditor (init,formid) hst
# (academicForm,hst) = vertlistFormButs 10 (Init,academicTable) hst
# (nacademicForm,hst) = vertlistFormButs 10 (setID academicTable (pred academicForm.value)) hst
# (error,ok) = testUnique (gCollect {|*|} nacademicForm.value [])
# (_,hst) = Alert (if (not ok ) (\_ -> (True,error)) id) hst
= ( { changed = academicForm.changed
, value = Academic nacademicForm.value
, form = nacademicForm.form
}
,hst )
pred acadTable = [adj mem \\ mem <- acadTable ] // Context sensitive restrictions on Academics
where
adj mem=:{ appointment = Professor {heads = Yes a}
, person = {Person | phone = No}} = { mem & rank = Prof
, person.Person.phone = Yes 0 }
adj mem=:{ appointment = Professor _ } = { mem & rank = Prof }
adj mem=:{ appointment = TeachingAndProf {professor = {heads = Yes a}}
, person = {Person | phone = No}} = {mem & rank = Prof
, person.Person.phone = Yes 0}
adj mem=:{ appointment = TeachingAndProf _ } = {mem & rank = Prof }
adj mem = mem
test = `Batt_Events [OnLoad (SScript "\"alert('Welkom op mijn pagina!')\"")]
alert message = Form [`Frm_Events [OnLoad (SScript ("\"alert('" +++ message +++ "')\""))]] []
gForm {|Departments|} formid hst
= specialize myeditor (Init,formid) hst
where
myeditor (init,formid) hst
# (departmentForm,hst) = vertlistFormButs 5 (Init,departmentTable) hst
# (error,ok) = testUnique (gCollect {|*|} departmentForm.value [])
# (_,hst) = Alert (if (not ok ) (\_ -> (True,error)) id) hst
= ( { changed = departmentForm.changed
, value = Department departmentForm.value
, form = departmentForm.form
}
,hst )
// references to persistent tables:
gForm {|RefDept|} formid hst = specialize myeditor (Init,formid) hst
where
myeditor (init,formid) hst
# (depForm,hst) = mkEditForm (Init,{departmentTable & mode = Display}) hst
| length depForm.value == 0 = ({changed=False,value = RefDept 0,form = [toHtml NoDepartment]},hst)
# (pdform,hst) = pullDownStore id hst
# (PullDown _ (idx,depnames)) = pdform.value
# chosenDepartment = depnames!!idx
# newidx = hd ([let (Uniq nr) = dep.dnr in nr \\ dep <- depForm.value | printToString dep.departmentName == chosenDepartment] ++ [0])
# newmenu = [printToString rec.departmentName \\ rec <- depForm.value]
# newchosen = hd ([i \\ i <- [0..] & newelem <- newmenu | newelem == chosenDepartment]++[0])
# pulldownmenu = PullDown (1,defpixel) (newchosen, newmenu)
# (pdform,hst) = pullDownStore (\_ -> pulldownmenu) hst
= ({changed=pdform.changed || depForm.changed,value = RefDept newidx , form = [[toHtml newidx] <=> pdform.form]},hst)
(RefDept currPtr) = formid.ival
pullDownStore :: (PullDownMenu -> PullDownMenu) !*HSt -> (Form PullDownMenu,!*HSt)
pullDownStore cbf hst = mkStoreForm (Init,pulldownId) cbf hst
where
pulldownId = subFormId formid "sub" (PullDown (1,defpixel) (0,[printToString NoDepartment]))
// to ensure a unique identifier, each time a Uniq value is created, it will get a new unique value
gForm {|Uniq|} formid hst = specialize myeditor (Init,formid) hst
where
myeditor (init,formid) hst
= case formid.ival of
(Uniq 0)
# (unqform,hst) = mkStoreForm (Init,uniqueId) inc hst // side effects are very dangerous !!! THIS DOES NOT INCREMENTED WITH 1
= ({changed=True ,value = Uniq unqform.value,form = [toHtml unqform.value]},hst)
(Uniq n)
= ({changed=False,value = Uniq n, form = [toHtml n]},hst)
where
uniqueId :: FormId Int
uniqueId = pdFormId "uniqueId" 1
gForm {|Others|} formid hst = specialize myeditor (Init,formid) hst
where
myeditor (init,formid) hst
# (listForm,hst) = vertlistFormButs 5 (Init,reuseFormId formid intlist) hst
= ( { changed = listForm.changed, value = Other listForm.value, form = listForm.form},hst)
(Other intlist) = formid.ival
gForm {|Topics|} formid hst = specialize myeditor (Init,formid) hst
where
myeditor (init,formid) hst
# (listForm,hst) = vertlistFormButs 5 (Init,reuseFormId formid intlist) hst
= ( { changed = listForm.changed, value = Topic listForm.value, form = listForm.form},hst)
(Topic intlist) = formid.ival
gForm {|Degrees|} formid hst = specialize myeditor (Init,formid) hst //blue gives rise to run time error
where
myeditor (init,formid) hst
// # (listForm,hst) = vertlistFormButs 5 (Init,reuseFormId formid (ot formid.ival)) hst
# (listForm,hst) = vertlistFormButs 5 (Init,reuseFormId formid intlist) hst
= ( { changed = listForm.changed, value = Degree listForm.value, form = listForm.form},hst)
// = ( { changed = listForm.changed, value = to listForm.value, form = listForm.form},hst)
(Degree intlist) = formid.ival
ot (Degree list) = list
to list = Degree list
derive gForm [],Maybe,
Academic, X_DepartmentName, Phone, Access_Level, Contract, University, X_Degree,Rank, Chair,
Appointment, Teacher, Professor, TeachingAndProf, Person, Room, Building,
/* Uniq, */Opt,/* Others, */ Topic, X_TopicCode, /* Degrees, Topics,*/
Department, MyDatabase, RefAcademicus//, Academics, Departments, RefDept
derive gUpd [], Maybe,
Academic, X_DepartmentName, Phone, Access_Level, Contract, University, X_Degree, Rank, Chair,
Appointment, Teacher, Professor, TeachingAndProf, Person, Room, Building,
Uniq, Opt, Others, Topic, X_TopicCode, Degrees, Topics,
Department, MyDatabase, RefAcademicus, Academics, Departments,RefDept
derive gPrint Maybe,
Academic, X_DepartmentName, Phone, Access_Level, Contract, University, X_Degree, Rank, Chair,
Appointment, Teacher, Professor, TeachingAndProf, Person, Room, Building,
Uniq, Opt, Others, Topic, X_TopicCode, Degrees, Topics,
Department, MyDatabase, RefAcademicus, Academics, Departments,RefDept
derive gParse Maybe,
Academic, X_DepartmentName, Phone, Access_Level, Contract, University, X_Degree, Rank, Chair,
Appointment, Teacher, Professor, TeachingAndProf, Person, Room, Building,
Uniq, Opt, Others, Topic, X_TopicCode, Degrees, Topics,
Department, MyDatabase, RefAcademicus, Academics, Departments,RefDept
derive gCollect [], Maybe, (,), Date,
Academic, X_DepartmentName, Phone, Access_Level, Contract, University, X_Degree, Rank, Chair,
Appointment, Teacher, Professor, TeachingAndProf, Person, Room, Building,
Uniq, Opt, Others, Topic, X_TopicCode, Degrees, Topics,
Department, MyDatabase, RefAcademicus, Academics, Departments,RefDept
// toHtml Uniq gives a crash ??
\ No newline at end of file
module orm
import StdHtml
import databaseIData
// iData definitions
Start world = doHtmlServer myDB world
myDB hst
# (alert,hst) = Alert (\_ -> (False,"")) hst // reset Alert
# (dbform,hst) = mkEditForm (Init,myDB) hst // create an editor for the database
# (alert,hst) = Alert id hst // read out Alert
= mkHtmlB "database" (OnLoadAlert alert.value)
[ H1 [] "database Example: "
, BodyTag dbform.form
] hst
where
myDB :: FormId MyDatabase
myDB = pFormId "myDB" Empty
test hst
# (dbform,hst) = mkEditForm (Init,nFormId "text" (TextArea 4 30 "zal dit werken ???")) hst // create an editor for the database
# (int,hst) = mkEditForm (Init,nFormId "int" 0) hst
# (TextArea row col string) = dbform.value
= mkHtml "database"
[ H1 [] "database Example: "
, BodyTag int.form
, BodyTag dbform.form
, Txt string
] hst
This diff is collapsed.
definition module support
import StdHtml
Alert :: ((Bool,String) -> (Bool,String)) -> (*HSt -> *((Form (Bool,String)),*HSt))
testUnique:: [String] -> (String,Bool)
generic gCollect a :: a [String] -> [String]
derive gCollect Int, Real, Char, Bool, String, PAIR, EITHER, CONS, FIELD, OBJECT, UNIT, {}
implementation module support
import StdHtml, StdGeneric
derive gForm []
derive gUpd []
// generated stuf
generic gCollect a :: a [String] -> [String]
gCollect{|Int|} x accu = accu
gCollect{|Real|} x accu = accu
gCollect{|Char|} x accu = accu
gCollect{|Bool|} x accu = accu
gCollect{|String|} x accu = accu
gCollect{|PAIR|} fx fy (PAIR x y) accu = (fy y (fx x accu))
gCollect{|EITHER|} fl fr (LEFT x) accu = fl x accu
gCollect{|EITHER|} fl fr (RIGHT x) accu = fr x accu
gCollect{|CONS of t|} f (CONS x) accu
| t.gcd_type_def.gtd_name%(0,1) == "X_" = f x [t.gcd_name:accu]
= f x accu
gCollect{|FIELD|} f (FIELD x) accu = f x accu
gCollect{|OBJECT|} f (OBJECT x) accu = f x accu
gCollect{|UNIT|} x accu = accu
gCollect{|{}|} f s accu = accu
testUnique:: [String] -> (String,Bool)
testUnique [] = ("",True)
testUnique [x:xs]
| isMember x xs = ("Chosen value " +++ x +++ " must be unique but has already been used",False)
= testUnique xs
Alert :: ((Bool,String) -> (Bool,String)) -> (*HSt -> *((Form (Bool,String)),*HSt))
Alert fun = mkStoreForm (Init,sdFormId "alert" (False,"")) fun
......@@ -8,6 +8,13 @@ module NumberGuessingGame
*/
import StdEnv, StdHtml, Random
:: Trees a = Leaf | SNode a .(Trees2 a) (Trees2 a)
:: Trees2 a :== Trees a
f :: a *(Trees a) (Trees a) -> *(Trees a)
f a x y = SNode a x y
Start :: *World -> *World
Start world = doHtmlServer numberGuessingGame world
......@@ -65,7 +72,7 @@ numberGuessingGame hst
] ++
(if guess.changed
(if (guess.value == ostate.value.guess)
[ Txt ("Congratulations " <$ name.value <$ ".")
[ Txt` "Answer" ("Congratulations " <$ name.value <$ ".")
, Br
, Txt ("You have guessed the number in " <$ ostate.value.count <$ " turn" <$ if (ostate.value.count>1) "s." ".")
, Br, Br
......@@ -75,7 +82,7 @@ numberGuessingGame hst
, Br, Br
, Txt ("Just type in a new number if you want to guess again...")
]
[ Txt ("Sorry, " <$ name.value <$ ", your guess number " <$ ostate.value.count <$ " was wrong.")
[ Txt` "Answer" ("Sorry, " <$ name.value <$ ", your guess number " <$ ostate.value.count <$ " was wrong.")
, Br, Br
, Txt ("The number to guess is "<$if (guess.value < ostate.value.guess) "larger." "smaller.")
]
......@@ -83,6 +90,8 @@ numberGuessingGame hst
[])
) hst
Txt` tag string = A [Lnk_Name tag] [Txt string]
instance mod Int where mod a b = a - (a/b)*b
/* old code
......
......@@ -4,10 +4,10 @@ definition module htmlButtons
import htmlHandler
derive gForm (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput
derive gUpd (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput
derive gPrint (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput
derive gParse (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput
derive gForm (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea
derive gUpd (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea
derive gPrint (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea
derive gParse (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea
instance toBool CheckBox, Button, RadioButton // True if checkbox checked, button pressed
instance toInt PullDownMenu // Current index in pull down list
......@@ -37,6 +37,7 @@ instance toString PullDownMenu // Corresponding element in pull down list
:: TextInput = TI Int Int // Input box of size Size for Integers
| TR Int Real // Input box of size Size for Reals
| TS Int String // Input box of size Size for Strings
:: TextArea = TextArea Int Int String // Input Area Box, row col initial string
// special's
......
......@@ -4,9 +4,9 @@ import StdEnv, ArgEnv, StdMaybe
import htmlHandler, htmlStylelib, htmlTrivial
derive gUpd (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, /*Button, */CheckBox, RadioButton /*, PullDownMenu, TextInput */
derive gPrint (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput
derive gParse (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput
derive gUpd (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, /*Button, */CheckBox, RadioButton /*, PullDownMenu, TextInput */, TextArea
derive gPrint (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea
derive gParse (,), (,,), (,,,), (<->), <|>, Date, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea
:: TextInput = TI Int Int // Input box of size Size for Integers
| TR Int Real // Input box of size Size for Reals
......@@ -247,6 +247,28 @@ where
, resetForm = Nothing
} hst
gForm{|TextArea|} formid hst
# (cntr,hst) = CntrHSt hst
= ( { changed = False
, value = formid.ival
, form = [Form [Frm_Method Post, `Frm_Events [OnSubmit callClean]]
[mkSTable [ [ Textarea [Txa_Name "message", Txa_Rows row, Txa_Cols col ] "" ]
, [BodyTag [ Input [Inp_Type Inp_Submit, Inp_Name (encodeTriplet (formid.id,cntr+2,UpdS string)), Inp_Value (SV "Submit"),`Inp_Events [OnClick callClean]] ""
, Input [Inp_Type Inp_Reset, Inp_Name "reset", Inp_Value (SV "Reset")] ""
]