Commit a03eb145 authored by Peter Achten's avatar Peter Achten
Browse files

refactoring modules

parent e14033b3
......@@ -87,7 +87,7 @@ where
DecodeHtmlStatesAndUpdate :: ServerKind (Maybe String) -> ([HtmlState],String,String)
DecodeHtmlStatesAndUpdate serverkind args
# (_,triplet,update,state) = DecodeArguments serverkind args
= ([states \\states=:(id,_,_,nstate) <- DecodeHtmlStates state | id <> "" || nstate <> ""],triplet,update) // to be sure that no rubisch is passed on
= ([states \\states=:(id,_,_,nstate) <- DecodeHtmlStates state | id <> "" || nstate <> ""],triplet,update) // to be sure that no rubbish is passed on
// Parse and decode low level information obtained from server
// In case of using a php script and external server:
......
definition module PrintUtil
// a collection of handy print routines to write html to Std Output
// a collection of print routines to write html to Std Output
// (c) MJP 2005
import StdGeneric
......@@ -8,38 +8,39 @@ import StdFile
import StdStrictLists
import Gerda
:: *HtmlStream :== [# String !]
:: *HtmlStream :== [# String !]
:: FoF :== (*HtmlStream -> *HtmlStream)
:: FoF :== (*HtmlStream -> *HtmlStream)
:: *NWorld // io interface
= { worldC :: !*World // world for any io
, inout :: !*HtmlStream // to read from stdin and write to stdout
, gerda :: *Gerda // to read and write to the database
= { worldC:: !*World // world for any io
, inout :: !*HtmlStream // to read from stdin and write to stdout
, gerda :: *Gerda // to read and write to the database
}
instance FileSystem NWorld
appWorldNWorld :: !.(*World -> *World) !*NWorld -> *NWorld
accWorldNWorld :: !.(*World -> *(.a,*World)) !*NWorld -> (.a,!*NWorld)
appWorldNWorld :: !.(*World -> *World) !*NWorld -> *NWorld
accWorldNWorld :: !.(*World -> *(.a,*World)) !*NWorld -> (.a,!*NWorld)
// generic function for printing tags
// Constructors are converted to html tag strings
// prefix Name_ of Name_Attrname is removed, and Name is converted to lowercase string
generic gHpr a :: !*HtmlStream !a -> *HtmlStream
generic gHpr a :: !*HtmlStream !a -> *HtmlStream
derive gHpr UNIT, PAIR, EITHER, CONS, OBJECT
derive gHpr Int, Real, Bool, String, Char, []
// the main print routine
print_to_stdout :: a *NWorld -> *NWorld | gHpr{|*|} a
print_to_stdout :: !a !*NWorld -> *NWorld | gHpr{|*|} a
// handy utility print routines
print :: !String -> FoF
(<+) infixl :: !*HtmlStream !a -> *HtmlStream | gHpr{|*|} a
(<+>) infixl :: !*HtmlStream FoF -> *HtmlStream
(<+) infixl :: !*HtmlStream !a -> *HtmlStream | gHpr{|*|} a
(<+>) infixl :: !*HtmlStream !FoF -> *HtmlStream
htmlAttrCmnd :: !hdr !tag !body -> FoF | gHpr{|*|} hdr & gHpr{|*|} tag & gHpr{|*|} body
openCmnd :: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
styleCmnd :: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
......
......@@ -9,18 +9,18 @@ import Gerda
generic gHpr a :: !*HtmlStream !a -> *HtmlStream
gHpr{|String|} file s = [|s:file] // the only entry that actualy prints something
gHpr{|String|} file s = [|s:file] // the only entry that actually prints something
// all others eventually come here converted to string
gHpr{|Int|} file i = [|toString i:file]
gHpr{|Real|} file r = [|toString r:file]
gHpr{|Bool|} file b = [|toString b:file]
gHpr{|Char|} file c = [|toString c:file]
gHpr{|UNIT|} file _ = file
gHpr{|PAIR|} gHpra gHprb file (PAIR a b) = gHprb (gHpra file a) b
gHpr{|EITHER|} gHprl gHprr file (LEFT left) = gHprl file left
gHpr{|EITHER|} gHprl gHprr file (RIGHT right) = gHprr file right
gHpr{|OBJECT|} gHpro file (OBJECT object)= gHpro file object
gHpr{|Int|} file i = [|toString i:file]
gHpr{|Real|} file r = [|toString r:file]
gHpr{|Bool|} file b = [|toString b:file]
gHpr{|Char|} file c = [|toString c:file]
gHpr{|UNIT|} file _ = file
gHpr{|PAIR|} gHpra gHprb file (PAIR a b) = gHprb (gHpra file a) b
gHpr{|EITHER|} gHprl gHprr file (LEFT left) = gHprl file left
gHpr{|EITHER|} gHprl gHprr file (RIGHT right) = gHprr file right
gHpr{|OBJECT|} gHpro file (OBJECT object)= gHpro file object
gHpr{|CONS of t|} gPrHtmlc prev (CONS c) // constructor names are printed, prefix Foo_ is stripped
= case t.gcd_name.[0] of
......@@ -46,60 +46,53 @@ where
myfold file [x:xs] = myfold (gHlist file x) xs
myfold file [] = file
// outility print functions based on gHpr
// utility print functions based on gHpr
print :: !String -> FoF
print a = \f -> [|a:f]
print :: !String -> FoF
print a = \f -> [|a:f]
(<+) infixl :: !*HtmlStream !a -> *HtmlStream | gHpr{|*|} a
(<+) file new = gHpr{|*|} file new
(<+) infixl :: !*HtmlStream !a -> *HtmlStream | gHpr{|*|} a
(<+) file new = gHpr{|*|} file new
(<+>) infixl :: !*HtmlStream FoF -> *HtmlStream
(<+>) file new = new file
(<+>) infixl :: !*HtmlStream !FoF -> *HtmlStream
(<+>) file new = new file
print_to_stdout :: a *NWorld -> *NWorld | gHpr{|*|} a
print_to_stdout :: !a !*NWorld -> *NWorld | gHpr{|*|} a
print_to_stdout value nw=:{worldC,inout}
# inout = inout <+ value
= {nw & inout = inout}
htmlCmnd :: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
htmlCmnd hdr txt = \file -> closeCmnd hdr (openCmnd hdr "" file <+ txt)
htmlCmnd :: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
htmlCmnd hdr txt = \file -> closeCmnd hdr (openCmnd hdr "" file <+ txt)
openCmnd :: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
openCmnd hdr attr = \file -> [|"<":file] <+ hdr <+ attr <+ ">"
openCmnd :: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
openCmnd hdr attr = \file -> [|"<":file] <+ hdr <+ attr <+ ">"
closeCmnd :: !a -> FoF | gHpr{|*|} a
closeCmnd hdr = \file -> print "</" file <+ hdr <+ ">"
closeCmnd :: !a -> FoF | gHpr{|*|} a
closeCmnd hdr = \file -> print "</" file <+ hdr <+ ">"
htmlAttrCmnd :: !hdr !attr !body -> FoF | gHpr{|*|} hdr & gHpr{|*|} attr & gHpr{|*|} body
htmlAttrCmnd hdr attr txt
= \file -> closeCmnd hdr (openCmnd hdr attr file <+ txt)
htmlAttrCmnd :: !hdr !attr !body -> FoF | gHpr{|*|} hdr & gHpr{|*|} attr & gHpr{|*|} body
htmlAttrCmnd hdr attr txt = \file -> closeCmnd hdr (openCmnd hdr attr file <+ txt)
styleCmnd :: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
styleCmnd stylename attr = \file -> print "." file <+ stylename <+ "{" <+ attr <+ "}"
styleCmnd :: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
styleCmnd stylename attr = \file -> print "." file <+ stylename <+ "{" <+ attr <+ "}"
styleAttrCmnd :: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
styleAttrCmnd name value = \file -> print "" file <+ name <+ ": " <+ value <+ ";"
styleAttrCmnd :: !a !b -> FoF | gHpr{|*|} a & gHpr{|*|} b
styleAttrCmnd name value = \file -> print "" file <+ name <+ ": " <+ value <+ ";"
instance FileSystem NWorld
where
fopen :: !{#Char} !Int !*NWorld -> (!Bool,!*File,!*NWorld)
instance FileSystem NWorld where
fopen string int nworld=:{worldC}
# (bool,file,worldC) = fopen string int worldC
= (bool,file,{nworld & worldC = worldC})
fclose :: !*File !*NWorld -> (!Bool,!*NWorld)
fclose file nworld=:{worldC}
# (bool,worldC) = fclose file worldC
= (bool,{nworld & worldC = worldC})
stdio :: !*NWorld -> (!*File,!*NWorld)
stdio nworld=:{worldC}
# (file,worldC) = stdio worldC
= (file,{nworld & worldC = worldC})
sfopen :: !{#Char} !Int !*NWorld -> (!Bool,!File,!*NWorld)
sfopen string int nworld=:{worldC}
# (bool,file,worldC) = sfopen string int worldC
= (bool,file,{nworld & worldC = worldC})
......
......@@ -12,8 +12,8 @@ import
, htmlHandler // the kernel module for iData creation and handling
, htmlButtons // basic collections of buttons, data types for lay-out control
, htmlFormlib // handy collection of advanced iData creating functions
, htmlRefFormlib // handy collection of persistent idata maintaining sharing
, htmlFormlib // collection of advanced iData creating functions
, htmlRefFormlib // collection of persistent idata maintaining sharing
, htmlArrow // arrow instantiations for iData forms
......
......@@ -24,17 +24,15 @@ edit :: (FormId a) -> GecCircuit a a | iData a
display :: (FormId a) -> GecCircuit a a | iData a
store :: (FormId a) -> GecCircuit (a -> a) a | iData a
feedback :: (GecCircuit a b) (GecCircuit b a) -> (GecCircuit a b)
feedback :: !(GecCircuit a b) !(GecCircuit b a) -> GecCircuit a b
self :: (a -> a) (GecCircuit a a) -> GecCircuit a a
self :: (a -> a) !(GecCircuit a a) -> GecCircuit a a
loops :: (GecCircuit (a, b) (c, b)) -> GecCircuit a c | iData b
loops :: !(GecCircuit (a, b) (c, b)) -> GecCircuit a c | iData b
(`bindC`) infix 0 :: (GecCircuit a b) (b -> GecCircuit b c) -> (GecCircuit a c)
(`bindCI`) infix 0 :: (GecCircuit a b) ((Form b) -> GecCircuit b c) -> (GecCircuit a c)
(`bindC`) infix 0 :: !(GecCircuit a b) (b -> GecCircuit b c) -> (GecCircuit a c)
(`bindCI`) infix 0 :: !(GecCircuit a b) ((Form b) -> GecCircuit b c) -> (GecCircuit a c)
// to lift library functions to the circuit domain
lift :: !(InIDataId a) (!(InIDataId a) !*HSt -> (!Form b,!*HSt)) -> (GecCircuit a b)
//lift :: !(FormId a) (!(InIDataId a) !*HSt -> (!Form b,!*HSt)) -> (GecCircuit a b)
lift :: !(InIDataId a) (!(InIDataId a) !*HSt -> (!Form b,!*HSt)) -> GecCircuit a b
......@@ -23,17 +23,13 @@ where
:: GecCircuitChanged :== Bool
instance Arrow GecCircuit
where
arr :: (a -> b) -> GecCircuit a b
instance Arrow GecCircuit where
arr fun = HGC fun`
where
fun` ((a,body),ch,hst) = ((fun a,body),ch,hst)
(>>>) infixr 1 :: (GecCircuit a b) (GecCircuit b c) -> GecCircuit a c
(>>>) (HGC gec_ab) (HGC gec_bc) = HGC (gec_bc o gec_ab)
first :: (GecCircuit a b) -> GecCircuit (a, c) (b, c)
first (HGC gec_ab) = HGC first`
where
first` (((a,c),prevbody),ch,hst)
......@@ -61,13 +57,13 @@ where
# (store,hst) = mkStoreForm (Init,formid) fun hst
= ((store.value,[(formid.id,BodyTag store.form):prevbody]),ch||store.changed,hst)
self :: (a -> a) (GecCircuit a a) -> GecCircuit a a
self :: (a -> a) !(GecCircuit a a) -> GecCircuit a a
self fun gecaa = feedback gecaa (arr fun)
feedback :: (GecCircuit a b) (GecCircuit b a) -> (GecCircuit a b)
feedback :: !(GecCircuit a b) !(GecCircuit b a) -> (GecCircuit a b)
feedback (HGC gec_ab) (HGC gec_ba) = HGC (gec_ab o gec_ba o gec_ab)
loops :: (GecCircuit (a, b) (c, b)) -> GecCircuit a c | iData b
loops :: !(GecCircuit (a, b) (c, b)) -> GecCircuit a c | iData b
loops (HGC gec_abcb) = HGC loopForm
where
loopForm ((aval,prevbody),ch,hst)
......@@ -75,13 +71,9 @@ where
# (((cval,bval),bodyac),ch,hst) = gec_abcb (((aval,bstore.value),prevbody),ch,hst)
# (bstore,hst) = mkStoreForm (Set,xsFormId "??" createDefault) (\_ -> bval) hst
= ((cval,bodyac),ch,hst)
//self fun gecaa = feedback gecaa (arr fun)
(`bindC`) infix 0 :: (GecCircuit a b) (b -> GecCircuit b c) -> (GecCircuit a c)
(`bindC`) infix 0 :: !(GecCircuit a b) (b -> GecCircuit b c) -> (GecCircuit a c)
(`bindC`) (HGC gecab) bgecbc = HGC binds
where
binds ((a,abody),ach,hst)
......@@ -89,7 +81,7 @@ where
# (HGC gecbc) = bgecbc b
= gecbc ((b,bbody ++ abody),ach||bch,hst)
(`bindCI`) infix 0 :: (GecCircuit a b) ((Form b) -> GecCircuit b c) -> (GecCircuit a c)
(`bindCI`) infix 0 :: !(GecCircuit a b) ((Form b) -> GecCircuit b c) -> (GecCircuit a c)
(`bindCI`) (HGC gecab) bgecbc = HGC binds
where
binds ((a,abody),ach,hst)
......@@ -97,7 +89,7 @@ where
# (HGC gecbc) = bgecbc {changed = bch, value = b, form = map snd bbody}
= gecbc ((b,bbody ++ abody),ach||bch,hst)
lift :: !(InIDataId a) (!(InIDataId a) !*HSt -> (!Form b,!*HSt)) -> (GecCircuit a b)
lift :: !(InIDataId a) (!(InIDataId a) !*HSt -> (!Form b,!*HSt)) -> GecCircuit a b
lift (Set,formid) fun = HGC fun`
where
fun` ((a,body),ch,hst)
......@@ -108,12 +100,3 @@ where
fun` ((a,body),ch,hst)
# (nb,hst) = fun (Init, setFormId formid a) hst
= ((nb.value,[(formid.id,BodyTag nb.form):body]),ch||nb.changed,hst)
/*
lift :: !(FormId a) (!(InIDataId a) !*HSt -> (!Form b,!*HSt)) -> (GecCircuit a b)
lift formid fun = HGC fun`
where
fun` ((a,body),ch,hst)
# (nb,hst) = fun (setID formid a) hst
= ((nb.value,[(formid.id,BodyTag nb.form):body]),ch||nb.changed,hst)
*/
......@@ -4,6 +4,7 @@ definition module htmlButtons
// (c) 2005 MJP
import htmlHandler
import GenLexOrd
derive gForm (,), (,,), (,,,), (<->), <|>, HtmlDate, HtmlTime, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea, HTML, PasswordBox
derive gUpd (,), (,,), (,,,), (<->), <|>, HtmlDate, HtmlTime, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea, HTML, PasswordBox
......@@ -11,12 +12,16 @@ derive gPrint (,), (,,), (,,,), (<->), <|>, HtmlDate, HtmlTime, DisplayMode, Bu
derive gParse (,), (,,), (,,,), (<->), <|>, HtmlDate, HtmlTime, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea, HTML, PasswordBox
derive gerda (,), (,,), (,,,), (<->), <|>, HtmlDate, HtmlTime, DisplayMode, Button, CheckBox, RadioButton, PullDownMenu, TextInput, TextArea, PasswordBox
instance toBool CheckBox, Button, RadioButton // True if checkbox checked, button pressed
instance toInt PullDownMenu // Current index in pull down list
instance toString PullDownMenu // Corresponding element in pull down list
instance == PasswordBox, HtmlDate, HtmlTime
instance < HtmlDate, HtmlTime
instance toString HtmlDate, HtmlTime
instance toBool CheckBox, Button, RadioButton // True if checkbox checked, button pressed
instance toInt PullDownMenu // Current index in pull down list
instance toString PullDownMenu // Corresponding element in pull down list
derive gEq HtmlDate, HtmlTime, PasswordBox
instance == HtmlDate, HtmlTime, PasswordBox
derive gLexOrd HtmlDate, HtmlTime
instance < HtmlDate, HtmlTime
instance toString HtmlDate, HtmlTime
// lay out
:: <-> a b = (<->) infixl 5 a b // place b to the left of a
......
This diff is collapsed.
This diff is collapsed.
......@@ -55,50 +55,50 @@ dbdDFormId :: !String !d -> FormId d; dbdDFormId s d = dbDFormId s d <@ Displa
// create id's
(++/) infixr 5
(++/) s1 s2 = s1 +++ iDataIdSeparator +++ s2
(++/) s1 s2 = s1 +++ iDataIdSeparator +++ s2
extidFormId :: !(FormId d) !String -> FormId d
extidFormId formid s = formid <@ formid.id ++/ s
extidFormId formid s = formid <@ formid.id ++/ s
subFormId :: !(FormId a) !String !d -> FormId d // make new formid of new type copying other old settinf
subFormId formid s d = reuseFormId (extidFormId formid s) d
subFormId :: !(FormId a) !String !d -> FormId d // make new formid of new type copying other old settinf
subFormId formid s d = reuseFormId (extidFormId formid s) d
subnFormId :: !(FormId a) !String !d -> FormId d // make new formid of new type copying other old settinf
subnFormId formid s d = subFormId formid s d <@ Page
subnFormId :: !(FormId a) !String !d -> FormId d // make new formid of new type copying other old settinf
subnFormId formid s d = subFormId formid s d <@ Page
subsFormId :: !(FormId a) !String !d -> FormId d // make new formid of new type copying other old settinf
subsFormId formid s d = subFormId formid s d <@ Session
subsFormId :: !(FormId a) !String !d -> FormId d // make new formid of new type copying other old settinf
subsFormId formid s d = subFormId formid s d <@ Session
subpFormId :: !(FormId a) !String !d -> FormId d // make new formid of new type copying other old settinf
subpFormId formid s d = subFormId formid s d <@ Persistent
subpFormId :: !(FormId a) !String !d -> FormId d // make new formid of new type copying other old settinf
subpFormId formid s d = subFormId formid s d <@ Persistent
subtFormId :: !(FormId a) !String !d -> FormId d // make new formid of new type copying other old settinf
subtFormId formid s d = subFormId formid s d <@ Temp
subtFormId :: !(FormId a) !String !d -> FormId d // make new formid of new type copying other old settinf
subtFormId formid s d = subFormId formid s d <@ Temp
setFormId :: !(FormId d) !d -> FormId d // set new initial value in formid
setFormId formid d = {formid & ival = d}
setFormId :: !(FormId d) !d -> FormId d // set new initial value in formid
setFormId formid d = reuseFormId formid d
reuseFormId :: !(FormId d) !v -> FormId v
reuseFormId formid v = {formid & ival = v}
reuseFormId formid v = {formid & ival = v}
initID :: !(FormId d) -> InIDataId d // (Init,FormId a)
initID formid = (Init,formid)
initID formid = (Init,formid)
setID :: !(FormId d) !d -> InIDataId d // (Set,FormId a)
setID formid na = (Set,setFormId formid na)
setID formid na = (Set,setFormId formid na)
onMode :: !Mode a a a -> a
onMode Edit e1 e2 e3 = e1
onMode Display e1 e2 e3 = e2
onMode NoForm e1 e2 e3 = e3
onMode Edit e1 e2 e3 = e1
onMode Display e1 e2 e3 = e2
onMode NoForm e1 e2 e3 = e3
toViewId :: !Init !d !(Maybe d) -> d
toViewId Init d Nothing = d
toViewId Init d (Just v) = v
toViewId _ d _ = d
toViewId Init d Nothing = d
toViewId Init d (Just v)= v
toViewId _ d _ = d
toViewMap :: !(d -> v) !Init !d !(Maybe v) -> v
toViewMap f init d mv = toViewId init (f d) mv
toViewMap f init d mv = toViewId init (f d) mv
derive gEq Mode, Init, Lifespan
instance == Mode where == m1 m2 = m1 === m2
......
......@@ -6,10 +6,10 @@ derive bimap Maybe, (,)
// utility
mkString :: [Char] -> *String
mkList :: String -> [Char]
mkString :: [Char] -> *String
mkList :: String -> [Char]
// Useful string concatenation function
(<+++) infixl :: !String !a -> String | toString a
(<+++) infixl :: !String !a -> String | toString a
isNil :: [a] -> Bool
(??) infixl 9 :: ![a] !a -> Int | == a
......@@ -16,8 +16,9 @@ mkList string = [c \\ c <-: string ]
(<+++) infixl :: !String !a -> String | toString a
(<+++) str x = str +++ toString x
isNil :: [a] -> Bool
isNil [] = True
isNil _ = False
(??) infixl 9 :: ![a] !a -> Int | == a
(??) [a:as] b
| a==b = 0
| otherwise = 1 + as??b
(??) [] _
= -1
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment