implementation module htmlButtons
import StdFunc, StdList, StdString
import htmlFormlib, htmlHandler, htmlStylelib, htmlTrivial
derive gUpd (,), (,,), (,,,), (<->), <|>, HtmlDate, HtmlTime, DisplayMode/*, Button, CheckBox*/, RadioButton /*, PullDownMenu, TextInput , TextArea, PasswordBox*/
derive gPrint (,), (,,), (,,,), (<->), <|>, HtmlDate, HtmlTime, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea, PasswordBox
derive gParse (,), (,,), (,,,), (<->), <|>, HtmlDate, HtmlTime, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea, PasswordBox
derive gerda (,), (,,), (,,,), (<->), <|>, HtmlDate, HtmlTime, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea, PasswordBox
:: 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
// Types that have an effect on lay-out
:: HTML = HTML [BodyTag]
gForm {|HTML|} (init,formid ) hst = specialize myeditor (Set,formid) hst
where
myeditor (init,formid ) hst
# (HTML bodytag) = formid.ival
= ({changed = False, form = bodytag, value = formid.ival},hst)
gUpd {|HTML|} mode v = (mode,v)
gPrint{|HTML|} (HTML x) st = st <<- "XYX"
gParse{|HTML|} st = case gParse {|*|} st of
Just "XYX" -> Just (HTML [EmptyBody])
_ -> Just (HTML [EmptyBody])
gerda{|HTML|} = undef
// Tuples are placed next to each other, pairs below each other ...
layoutTableAtts :== [Tbl_CellPadding (Pixels 0), Tbl_CellSpacing (Pixels 0)] // default table attributes for arranging layout
gForm{|(,)|} gHa gHb (init,formid) hst
# (na,hst) = gHa (init,reuseFormId formid a) (incrHSt 1 hst) // one more for the now invisible (,) constructor
# (nb,hst) = gHb (init,reuseFormId formid b) hst
= ( { changed = na.changed || nb.changed
, value = (na.value,nb.value)
, form = [STable layoutTableAtts [[BodyTag na.form, BodyTag nb.form]]]
},hst)
where
(a,b) = formid.ival
gForm{|(,,)|} gHa gHb gHc (init,formid) hst
# (na,hst) = gHa (init,reuseFormId formid a) (incrHSt 1 hst) // one more for the now invisible (,,) constructor
# (nb,hst) = gHb (init,reuseFormId formid b) hst
# (nc,hst) = gHc (init,reuseFormId formid c) hst
= ( { changed = na.changed || nb.changed || nc.changed
, value = (na.value,nb.value,nc.value)
, form = [STable layoutTableAtts [[BodyTag na.form,BodyTag nb.form,BodyTag nc.form]]]
},hst)
where
(a,b,c) = formid.ival
gForm{|(,,,)|} gHa gHb gHc gHd (init,formid) hst
# (na,hst) = gHa (init,reuseFormId formid a) (incrHSt 1 hst) // one more for the now invisible (,,) constructor
# (nb,hst) = gHb (init,reuseFormId formid b) hst
# (nc,hst) = gHc (init,reuseFormId formid c) hst
# (nd,hst) = gHd (init,reuseFormId formid d) hst
= ( { changed = na.changed || nb.changed || nc.changed || nd.changed
, value = (na.value,nb.value,nc.value,nd.value)
, form = [STable layoutTableAtts [[BodyTag na.form,BodyTag nb.form,BodyTag nc.form, BodyTag nd.form]]]
},hst)
where
(a,b,c,d) = formid.ival
// <-> works exactly the same as (,) and places its arguments next to each other, for compatibility with GEC's
gForm{|(<->)|} gHa gHb (init,formid) hst
# (na,hst) = gHa (init,reuseFormId formid a) (incrHSt 1 hst) // one more for the now invisible <-> constructor
# (nb,hst) = gHb (init,reuseFormId formid b) hst
= ( { changed = na.changed || nb.changed
, value = na.value <-> nb.value
, form = [STable layoutTableAtts [[BodyTag na.form, BodyTag nb.form]]]
},hst)
where
(a <-> b) = formid.ival
// <|> works exactly the same as PAIR and places its arguments below each other, for compatibility with GEC's
gForm{|(<|>)|} gHa gHb (init,formid) hst
# (na,hst) = gHa (init,reuseFormId formid a) (incrHSt 1 hst) // one more for the now invisible <|> constructor
# (nb,hst) = gHb (init,reuseFormId formid b) hst
= ( { changed = na.changed || nb.changed
, value = na.value <|> nb.value
, form = [STable layoutTableAtts [na.form, nb.form]]
},hst)
where
(a <|> b) = formid.ival
// to switch between modes within a type ...
gForm{|DisplayMode|} gHa (init,formid) hst
= case formid.ival of
(HideMode a)
# (na,hst) = gHa (init,reuseFormId formid a <@ Display) (incrHSt 1 hst)
= ( { changed = na.changed
, value = HideMode na.value
, form = [EmptyBody]
},hst)
(DisplayMode a)
# (na,hst) = gHa (init,reuseFormId formid a <@ Display) (incrHSt 1 hst)
= ( { changed = False
, value = DisplayMode na.value
, form = na.form
},hst)
(EditMode a)
# (na,hst) = gHa (init,reuseFormId formid a <@ Edit) (incrHSt 1 hst)
= ( { changed = na.changed
, value = EditMode na.value
, form = na.form
},hst)
EmptyMode
= ( { changed = False
, value = EmptyMode
, form = [EmptyBody]
},incrHSt 1 hst)
// Buttons to press
gForm{|Button|} (init,formid) hst
# (cntr,hst) = CntrHSt hst
= case formid.ival of
v=:(LButton size bname)
= ( { changed = False
, value = v
, form = [Input (onMode formid.mode [] [] [Inp_Disabled Disabled] [] ++
[ Inp_Type Inp_Button
, Inp_Value (SV bname)
, Inp_Name (encodeTriplet (formid.id,cntr,UpdS bname))
, `Inp_Std [Std_Style ("width:" <+++ size)]
, `Inp_Events (callClean OnClick Edit "")
]) ""]
},(incrHSt 1 hst))
v=:(PButton (height,width) ref)
= ( { changed = False
, value = v
, form = [Input (onMode formid.mode [] [] [Inp_Disabled Disabled] [] ++
[ Inp_Type Inp_Image
, Inp_Value (SV ref)
, Inp_Name (encodeTriplet (formid.id,cntr,UpdS ref))
, `Inp_Std [Std_Style ("width:" <+++ width <+++ " height:" <+++ height)]
, `Inp_Events (callClean OnClick Edit "")
, Inp_Src ref
]) ""]
},incrHSt 1 hst)
Pressed
= gForm {|*|} (init,(setFormId formid (LButton defpixel "??"))) hst // end user should reset button
gForm{|CheckBox|} (init,formid) hst
# (cntr,hst) = CntrHSt hst
= case formid.ival of
v=:(CBChecked name)
= ( { changed = False
, value = v
, form = [Input (onMode formid.mode [] [] [Inp_Disabled Disabled] [] ++
[ Inp_Type Inp_Checkbox
, Inp_Value (SV name)
, Inp_Name (encodeTriplet (formid.id,cntr,UpdS name))
, Inp_Checked Checked
, `Inp_Events (callClean OnClick formid.mode "")
]) ""]
},incrHSt 1 hst)
v=:(CBNotChecked name)
= ( { changed = False
, value = v
, form = [Input (onMode formid.mode [] [] [Inp_Disabled Disabled] [] ++
[ Inp_Type Inp_Checkbox
, Inp_Value (SV name)
, Inp_Name (encodeTriplet (formid.id,cntr,UpdS name))
, `Inp_Events (callClean OnClick formid.mode "")
]) ""]
},incrHSt 1 hst)
gForm{|RadioButton|} (init,formid) hst
# (cntr,hst) = CntrHSt hst
= case formid.ival of
v=:(RBChecked name)
= ( { changed = False
, value = v
, form = [Input (onMode formid.mode [] [] [Inp_Disabled Disabled] [] ++
[ Inp_Type Inp_Radio
, Inp_Value (SV name)
, Inp_Name (encodeTriplet (formid.id,cntr,UpdS name))
, Inp_Checked Checked
, `Inp_Events (callClean OnClick formid.mode "")
]) ""]
},incrHSt 1 hst)
v=:(RBNotChecked name)
= ( { changed = False
, value = v
, form = [Input (onMode formid.mode [] [] [Inp_Disabled Disabled] [] ++
[ Inp_Type Inp_Radio
, Inp_Value (SV name)
, Inp_Name (encodeTriplet (formid.id,cntr,UpdS name))
, `Inp_Events (callClean OnClick formid.mode "")
]) ""]
},incrHSt 1 hst)
gForm{|PullDownMenu|} (init,formid) hst=:{submits}
# (cntr,hst) = CntrHSt hst
= case formid.ival of
v=:(PullDown (size,width) (menuindex,itemlist))
= ( { changed = False
, value = v
, form = [Select (onMode formid.mode [] [] [Sel_Disabled Disabled] [] ++
[ Sel_Name (selectorInpName +++ encodeString
(if (menuindex >= 0 && menuindex < length itemlist) (itemlist!!menuindex) ""))
, Sel_Size size
, `Sel_Std [Std_Style ("width:" <+++ width <+++ "px")]
, `Sel_Events (if submits [] (callClean OnChange formid.mode formid.id))
])
[ Option
[ Opt_Value (encodeTriplet (formid.id,cntr,UpdC (itemlist!!j)))
: if (j == menuindex) [Opt_Selected Selected] []
]
elem
\\ elem <- itemlist & j <- [0..]
]]
},incrHSt 1 hst)
gForm{|TextInput|} (init,formid) hst
# (cntr,hst) = CntrHSt hst
# (body,hst) = mkInput size (init,formid) v updv hst
= ({changed=False, value=formid.ival, form=[body]},incrHSt 2 hst)
where
(size,v,updv) = case formid.ival of
(TI size i) = (size,IV i,UpdI i)
(TR size r) = (size,RV r,UpdR r)
(TS size s) = (size,SV s,UpdS s)
gForm{|TextArea|} (init,formid) hst
# (cntr,hst) = CntrHSt hst
= ( { changed = False
, value = formid.ival
, form = [myTable [ [ Textarea [ Txa_Name (encodeTriplet (formid.id,cntr,UpdS string))
, Txa_Rows (if (row == 0) 10 row)
, Txa_Cols (if (col == 0) 50 col)
] string ]
]
]
},incrHSt 1 hst)
where
(TextArea row col string) = formid.ival
myTable table
= Table [] (mktable table)
where
mktable table = [Tr [] (mkrow rows) \\ rows <- table]
mkrow rows = [Td [Td_VAlign Alo_Top, Td_Width (Pixels defpixel)] [row] \\ row <- rows]
gUpd{|TextArea|} (UpdSearch (UpdS name) 0) (TextArea r c s) = (UpdDone, TextArea r c (urlDecode name)) // update button value
gUpd{|TextArea|} (UpdSearch val cnt) t = (UpdSearch val (cnt - 1),t) // continue search, don't change
gUpd{|TextArea|} (UpdCreate l) _ = (UpdCreate l, TextArea defsize defsize "") // create default value
gUpd{|TextArea|} mode t = (mode, t) // don't change
gForm{|PasswordBox|} (init,formid) hst
= case formid.ival of
(PasswordBox password)
# (body,hst) = mkPswInput defsize (init,formid) password (UpdS password) hst
= ({ changed = False
, value = PasswordBox password
, form = [body]
},incrHSt 1 hst)
where
mkPswInput :: !Int !(InIDataId d) String UpdValue !*HSt -> (!BodyTag,!*HSt)
mkPswInput size (init,formid=:{mode}) sval updval hst=:{cntr,submits}
| mode == Edit || mode == Submit
= ( Input [ Inp_Type Inp_Password
, Inp_Value (SV sval)
, Inp_Name (encodeTriplet (formid.id,cntr,updval))
, Inp_Size size
, `Inp_Std [EditBoxStyle, Std_Title "::Password"]
, `Inp_Events if (mode == Edit && not submits) (callClean OnChange Edit "") []
] ""
,incrHSt 1 hst)
| mode == Display
= ( Input [ Inp_Type Inp_Password
, Inp_Value (SV sval)
, Inp_ReadOnly ReadOnly
, `Inp_Std [DisplayBoxStyle]
, Inp_Size size
] ""
,incrHSt 1 hst)
= ( EmptyBody,incrHSt 1 hst )
// time and date
import StdTime
getTimeAndDate :: !*HSt -> *(!(!HtmlTime,!HtmlDate),!*HSt)
getTimeAndDate hst
# (time,hst) = accWorldHSt getCurrentTime hst
# (date,hst) = accWorldHSt getCurrentDate hst
= ((Time time.hours time.minutes time.seconds,Date date.day date.month date.year),hst)
gForm {|HtmlTime|} (init,formid) hst
= specialize (flip mkBimapEditor {map_to = toPullDown, map_from = fromPullDown}) (init,formid <@ Page) hst
where
toPullDown (Time h m s) = (hv,mv,sv)
where
hv = PullDown (1, defpixel/2) (h,[toString i \\ i <- [0..23]])
mv = PullDown (1, defpixel/2) (m,[toString i \\ i <- [0..59]])
sv = PullDown (1, defpixel/2) (s,[toString i \\ i <- [0..59]])
fromPullDown (hv,mv,sv) = Time (convert hv) (convert mv) (convert sv)
where
convert x = toInt (toString x)
gForm {|HtmlDate|} (init,formid) hst
= specialize (flip mkBimapEditor {map_to = toPullDown, map_from = fromPullDown}) (init,formid <@ Page) hst
where
toPullDown (Date d m y) = (dv,mv,yv)
where
dv = PullDown (1, defpixel/2) (md-1, [toString i \\ i <- [1..31]])
mv = PullDown (1, defpixel/2) (mm-1, [toString i \\ i <- [1..12]])
yv = PullDown (1,2*defpixel/3) (my-1950,[toString i \\ i <- [1950..2015]])
my = if (y >= 2006 && y <= 2015) y 2006
md = if (d >= 1 && d <= 31) d 1
mm = if (m >= 1 && m <= 12) m 1
fromPullDown (dv,mv,yv) = Date (convert dv) (convert mv) (convert yv)
where
convert x = toInt (toString x)
// Updates that have to be treated specially:
gUpd{|PullDownMenu|} (UpdSearch (UpdC cname) 0) (PullDown dim (menuindex,itemlist))
= (UpdDone, PullDown dim (itemlist??cname,itemlist)) // update integer value
gUpd{|PullDownMenu|} (UpdSearch val cnt) v = (UpdSearch val (cnt - 1),v) // continue search, don't change
gUpd{|PullDownMenu|} (UpdCreate l) _ = (UpdCreate l, PullDown (1,defpixel) (0,["error"])) // create default value
gUpd{|PullDownMenu|} mode v = (mode, v) // don't change
gUpd{|Button|} (UpdSearch (UpdS name) 0) _ = (UpdDone, Pressed) // update button value
gUpd{|Button|} (UpdSearch val cnt) b = (UpdSearch val (cnt - 1),b) // continue search, don't change
gUpd{|Button|} (UpdCreate l) _ = (UpdCreate l, LButton defsize "Press") // create default value
gUpd{|Button|} mode b = (mode, b) // don't change
gUpd{|CheckBox|} (UpdSearch (UpdS name) 0) (CBChecked s) = (UpdDone, CBNotChecked s) // update CheckBox value
gUpd{|CheckBox|} (UpdSearch (UpdS name) 0) (CBNotChecked s) = (UpdDone, CBChecked s) // update CheckBox value
gUpd{|CheckBox|} (UpdSearch val cnt) b = (UpdSearch val (cnt - 1),b) // continue search, don't change
gUpd{|CheckBox|} (UpdCreate l) _ = (UpdCreate l, CBNotChecked "defaultCheckboxName") // create default value
gUpd{|CheckBox|} mode b = (mode, b) // don't change
gUpd{|TextInput|} (UpdSearch (UpdI ni) 0) (TI size i) = (UpdDone, TI size ni) // update integer value
gUpd{|TextInput|} (UpdSearch (UpdR nr) 0) (TR size r) = (UpdDone, TR size nr) // update real value
gUpd{|TextInput|} (UpdSearch (UpdS ns) 0) (TS size s) = (UpdDone, TS size ns) // update string value
gUpd{|TextInput|} (UpdSearch val cnt) i = (UpdSearch val (cnt - 3),i) // continue search, don't change
gUpd{|TextInput|} (UpdCreate l) _ = (UpdCreate l, TI defsize 0) // create default value
gUpd{|TextInput|} mode i = (mode, i) // don't change
gUpd{|PasswordBox|} (UpdSearch (UpdS name) 0) _ = (UpdDone, PasswordBox name) // update password value
gUpd{|PasswordBox|} (UpdSearch val cnt) b = (UpdSearch val (cnt - 2),b) // continue search, don't change
gUpd{|PasswordBox|} (UpdCreate l) _ = (UpdCreate l, PasswordBox "") // create default value
gUpd{|PasswordBox|} mode b = (mode, b) // don't change
// small utility stuf
instance toBool RadioButton where
toBool (RBChecked _) = True
toBool _ = False
instance toBool CheckBox where
toBool (CBChecked _) = True
toBool _ = False
instance toBool Button where
toBool Pressed = True
toBool _ = False
instance toInt PullDownMenu where
toInt (PullDown _ (i,_)) = i
instance toString PullDownMenu where
toString (PullDown _ (i,s)) = if (i>=0 && i <=length s) (s!!i) ""
derive gEq PasswordBox, HtmlTime, HtmlDate
instance == PasswordBox where (==) pb1 pb2 = pb1 === pb2
instance == HtmlTime where (==) ht1 ht2 = ht1 === ht2
instance == HtmlDate where (==) hd1 hd2 = hd1 === hd2
instance == (DisplayMode a) | == a
where
(==) (DisplayMode a) (DisplayMode b) = a == b
(==) (EditMode a) (EditMode b) = a == b
(==) (HideMode a) (HideMode b) = a == b
(==) EmptyMode EmptyMode = True
(==) _ _ = False
derive gLexOrd HtmlTime, HtmlDate
instance < HtmlTime where (<) ht1 ht2 = gEq{|*|} (gLexOrd{|*|} ht1 ht2) LT
instance + HtmlTime where (+) (Time h1 m1 s1) (Time h2 m2 s2)
= Time (h1 + h2) (m1 + m2) (s1 + s2)
instance - HtmlTime where (-) (Time h1 m1 s1) (Time h2 m2 s2)
= Time (h1 - h2) (m1 - m2) (s1 - s2)
instance < HtmlDate where (<) hd1 hd2 = gEq{|*|} (gLexOrd{|*|} hd1 hd2) LT
instance toString HtmlTime where
toString (Time hrs min sec) = toString hrs <+++ ":" <+++ min <+++ ":" <+++ sec
instance toString HtmlDate where
toString (Date day month year) = toString day <+++ "/" <+++ month <+++ "/" <+++ year