|
sourcecode:
|
{-# OPTIONS_FRONTEND -Wno-incomplete-patterns #-}
module HTML.WUI
( --WuiState,cgiRef2state,state2cgiRef,value2state,state2value,
--states2state,state2states,altstate2state,state2altstate,
Rendering,WuiSpec,
withRendering,withError,withCondition,adaptWSpec,transformWSpec,
wHidden,wConstant,wInt,
wString,wStringSize,wRequiredString,wRequiredStringSize,wTextArea,
wPassword, wPasswordSize,
wSelect,wSelectInt,wSelectBool,wRadioSelect,wRadioBool,wCheckBool,
wMultiCheckSelect,
wPair,wTriple,w4Tuple,w5Tuple,w6Tuple,w7Tuple,w8Tuple,
w9Tuple,w10Tuple,w11Tuple,w12Tuple,w13Tuple,w14Tuple,
-- these parameterized constructor combinators cause
-- non-determinism in KiCS2:
wCons2,wCons3,wCons4,wCons5,wCons6,wCons7,wCons8,
wCons9,wCons10,wCons11,wCons12,wCons13,wCons14,
wJoinTuple,wMaybe,wCheckMaybe,wRadioMaybe,
wList,wListWithHeadings,wHList,wMatrix,wEither,
WTree(..),wTree,
WuiHandler,wuiHandler2button,
renderTuple,renderTaggedTuple,renderList,
WuiStore, WuiSessionStore, setWuiStore, wui2FormDef,
ParWuiSessionStore, setParWuiStore, pwui2FormDef,
wuiSimpleRenderer
)
where
import Data.Char ( isDigit, isSpace )
import Data.List ( elemIndex )
import Data.Function.Inversion ( invf1 )
import HTML.Base
import HTML.Session
infixl 0 `withRendering`
infixl 0 `withError`
infixl 0 `withCondition`
------------------------------------------------------------------------------
--- An internal WUI state is used to maintain the cgi references of the input
--- fields as a structure that corresponds to the structure of the edit data.
data WuiState =
Ref HtmlRef -- reference to elementary input field
| Hidden String -- string representation of a hidden value
| CompNode [WuiState] -- composition of trees (substructures)
| AltNode (Int,WuiState) -- alternative of trees (union of substructures)
cgiRef2state :: HtmlRef -> WuiState
cgiRef2state cr = Ref cr
state2cgiRef :: WuiState -> HtmlRef
state2cgiRef (Ref cr) = cr
value2state :: Show a => a -> WuiState
value2state v = Hidden (show v)
state2value :: Read a => WuiState -> a
state2value (Hidden s) = read s
states2state :: [WuiState] -> WuiState
states2state sts = CompNode sts
state2states :: WuiState -> [WuiState]
state2states (CompNode sts) = sts
altstate2state :: (Int,WuiState) -> WuiState
altstate2state alt = AltNode alt
state2altstate :: WuiState -> (Int,WuiState)
state2altstate (AltNode alt) = alt
------------------------------------------------------------------------------
--- A rendering is a function that combines the visualization of components
--- of a data structure into some HTML expression.
type Rendering = [HtmlExp] -> HtmlExp
--- WuiParams specify the parameters of an individual Wui component type:
--- * the standard rendering
--- * an error message shown in case of illegal inputs
--- * a condition to specify legal input values
type WuiParams a = (Rendering, String, a -> Bool)
renderOf :: WuiParams a -> Rendering
renderOf (render,_,_) = render
errorOf :: WuiParams a -> String
errorOf (_,err,_) = err
conditionOf :: WuiParams a -> (a -> Bool)
conditionOf (_,_,c) = c
------------------------------------------------------------------------------
--- The type HtmlSate are values consisting of an HTML expression
--- (usually containing some input elements) and a WUI state containing
--- references to input elements in the HTML expression.
type HtmlState = (HtmlExp,WuiState)
------------------------------------------------------------------------------
--- A handler for a WUI is an event handler for HTML forms possibly with some
--- specific code attached (for future extensions).
data WuiHandler = WHandler HtmlHandler
--- Transform a WUI handler into a submit button with a given label string.
wuiHandler2button :: String -> WuiHandler -> HtmlExp
wuiHandler2button title (WHandler handler) = button title handler
------------------------------------------------------------------------------
--- The type of WUI specifications.
--- The first component are parameters specifying the behavior of this WUI type
--- (rendering, error message, and constraints on inputs).
--- The second component is a "show" function returning an HTML expression for
--- the edit fields and a WUI state containing the HtmlRefs to extract
--- the values from the edit fields. If the second component of the show
--- function is `True`, then the WUI condition is not checked for the data,
--- otherwise the data is rendered with an error message if the
--- WUI condition does not hold for the data.
--- The third component is a predicate to check the correctness of
--- the current data (with all its subcomponents).
--- The fourth component is "read" function to extract the values from
--- the edit fields for a given cgi environment.
data WuiSpec a =
WuiSpec (WuiParams a)
(WuiParams a -> Bool -> a -> HtmlState)
(WuiParams a -> a -> Bool)
(HtmlEnv -> WuiState -> a)
--- Puts a new rendering function into a WUI specification.
withRendering :: WuiSpec a -> Rendering -> WuiSpec a
withRendering (WuiSpec (_,errmsg,legal) showhtml correct readvalue) render =
WuiSpec (render,errmsg,legal) showhtml correct readvalue
--- Puts a new error message into a WUI specification.
withError :: WuiSpec a -> String -> WuiSpec a
withError (WuiSpec (render,_,legal) showhtml correct readvalue) errmsg =
WuiSpec (render,errmsg,legal) showhtml correct readvalue
--- Puts a new condition into a WUI specification.
withCondition :: WuiSpec a -> (a -> Bool) -> WuiSpec a
withCondition (WuiSpec (render,errmsg,_) showhtml correct readvalue) legal =
(WuiSpec (render,errmsg,legal) showhtml correct readvalue)
--- Transforms a WUI specification from one type to another.
transformWSpec :: (a->b,b->a) -> WuiSpec a -> WuiSpec b
transformWSpec (a2b,b2a) (WuiSpec wparamsa showhtmla correcta readvaluea) =
WuiSpec (transParam b2a wparamsa)
(\wparamsb nchk b -> showhtmla (transParam a2b wparamsb) nchk (b2a b))
(\wparamsb b -> correcta wparamsa (b2a b) && conditionOf wparamsb b)
(\env wst -> a2b (readvaluea env wst))
where
transParam :: (b->a) -> WuiParams a -> WuiParams b
transParam toa (render,errmsg,legal) = (render,errmsg,legal . toa)
--- Adapt a WUI specification to a new type. For this purpose,
--- the first argument must be a transformation mapping values
--- from the old type to the new type. This function must be bijective
--- and operationally invertible (i.e., the inverse must be computable
--- by narrowing). Otherwise, use `transformWSpec`!
adaptWSpec :: (Data a, Data b) => (a -> b) -> WuiSpec a -> WuiSpec b
adaptWSpec a2b = transformWSpec (a2b, invf1 a2b)
------------------------------------------------------------------------------
-- A collection of basic WUIs and WUI combinators:
--- A hidden widget for a value that is not shown in the WUI.
--- Usually, this is used in components of larger
--- structures, e.g., internal identifiers, data base keys.
wHidden :: (Read a, Show a) => WuiSpec a
wHidden =
WuiSpec (head, "?", const True) -- dummy values, not used
(\_ _ v -> (hempty, value2state v))
(\_ _ -> True)
(\_ wst -> (state2value wst))
--- A widget for values that are shown but cannot be modified.
--- The first argument is a mapping of the value into a HTML expression
--- to show this value.
wConstant :: (Read a, Show a) => (a -> HtmlExp) -> WuiSpec a
wConstant showhtml =
WuiSpec (head, "?", const True)
(\wparams _ v -> ((renderOf wparams) [showhtml v], value2state v))
(\_ _ -> True)
(\_ wst -> state2value wst)
------------------------------------------------------------------------------
--- A widget for editing integer values.
wInt :: WuiSpec Int
wInt =
WuiSpec (head,"Illegal integer:",const True)
(checkLegalInput intWidget)
(\wparams -> conditionOf wparams)
(\env wst ->
let input = env (state2cgiRef wst)
in maybe 0 id (readMaybeInt (stripSpaces input)))
where
intWidget render i = let ref free in
(render [textField ref (show i) `addAttr` ("size","6")], cgiRef2state ref)
-- Remove leading and ending spaces in a string.
stripSpaces :: String -> String
stripSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
-- Read a (possibly negative) integer in a string.
-- Return Nothing is this is not an integer string.
readMaybeInt :: String -> Maybe Int
readMaybeInt "" = Nothing
readMaybeInt (v:s) | v=='-' = maybe Nothing (\i->Just (-i)) (acc 0 s)
| isDigit v = acc 0 (v:s)
| otherwise = Nothing
where
acc n "" = Just n
acc n (c:cs) | isDigit c = acc (10*n + ord c - ord '0') cs
| otherwise = Nothing
checkLegalInput :: (Rendering -> a -> HtmlState) -> WuiParams a -> Bool -> a
-> HtmlState
checkLegalInput value2widget (render,errmsg,legal) nocheck value =
if nocheck || legal value
then value2widget render value
else value2widget (renderError render errmsg) value
------------------------------------------------------------------------------
-- WUIs for strings.
--- A predefined filter for processing string inputs.
--- Here, we replace \r\n by \n:
filterStringInput :: String -> String
filterStringInput = removeCRs
--- Replace all \r\n by \n:
removeCRs :: String -> String
removeCRs [] = []
removeCRs [c] = [c]
removeCRs (c1:c2:cs) =
if c1=='\r' && c2=='\n' then '\n' : removeCRs cs
else c1 : removeCRs (c2:cs)
--- A widget for editing string values.
wString :: WuiSpec String
wString = wStringAttrs []
--- A widget for editing string values with a size attribute.
wStringSize :: Int -> WuiSpec String
wStringSize size = wStringAttrs [("size",show size)]
--- A widget for editing string values with some attributes for the
--- text field.
wStringAttrs :: [(String,String)] -> WuiSpec String
wStringAttrs attrs =
WuiSpec (head, "?", const True)
(checkLegalInput stringWidget)
(\wparams -> conditionOf wparams)
(\env s -> filterStringInput (env (state2cgiRef s)))
where
stringWidget render v = let ref free in
(render [foldr (flip addAttr) (textField ref v) attrs], cgiRef2state ref)
--- A widget for editing string values that are required to be non-empty.
wRequiredString :: WuiSpec String
wRequiredString =
wString `withError` "Missing input:"
`withCondition` (not . null)
--- A widget with a size attribute for editing string values
--- that are required to be non-empty.
wRequiredStringSize :: Int -> WuiSpec String
wRequiredStringSize size =
wStringSize size `withError` "Missing input:"
`withCondition` (not . null)
--- A widget for editing string values in a text area.
--- The argument specifies the height and width of the text area.
wTextArea :: (Int,Int) -> WuiSpec String
wTextArea dims =
WuiSpec (head, "?", const True)
(checkLegalInput textareaWidget)
(\wparams -> conditionOf wparams)
(\env s -> filterStringInput (env (state2cgiRef s)))
where
textareaWidget render v = let ref free in
(render [textArea ref dims v], cgiRef2state ref)
------------------------------------------------------------------------------
-- WUIs for password which are not visible
--- A widget for entering a password.
--- The contents is not visible and, by default,
--- values are required to be non-empty.
wPassword :: WuiSpec String
wPassword = wPasswordAttrs []
--- A widget with a size attribute for entering a password.
--- The contents is not visible and, by default,
--- values are required to be non-empty.
wPasswordSize :: Int -> WuiSpec String
wPasswordSize size = wPasswordAttrs [("size",show size)]
--- A widget for editing string values with some attributes for the
--- password field.
wPasswordAttrs :: [(String,String)] -> WuiSpec String
wPasswordAttrs attrs =
WuiSpec (head, "Missing input:", (not . null))
(checkLegalInput passwordWidget)
(\wparams -> conditionOf wparams)
(\env s -> env (state2cgiRef s))
where
passwordWidget render _ = let ref free in
(render [foldr (flip addAttr) (password ref) attrs], cgiRef2state ref)
------------------------------------------------------------------------------
--- A widget to select a value from a given list of values.
--- The current value should be contained in the value list and is preselected.
--- The first argument is a mapping from values into strings to be shown
--- in the selection widget.
wSelect :: Eq a => (a -> String) -> [a] -> WuiSpec a
wSelect showelem selset =
WuiSpec (head, "?", const True)
(checkLegalInput selWidget)
(\wparams -> conditionOf wparams)
(\env s -> selset !! read (env (state2cgiRef s)))
where
selWidget render v =
let ref free
idx = elemIndex v selset
namevalues = zip (map showelem selset) (map show [0..])
in (render [maybe (selection ref namevalues)
(\i -> selectionInitial ref namevalues i)
idx],
cgiRef2state ref)
--- A widget to select a value from a given list of integers (provided as
--- the argument).
--- The current value should be contained in the value list and is preselected.
wSelectInt :: [Int] -> WuiSpec Int
wSelectInt = wSelect show
--- A widget to select a Boolean value via a selection box.
--- The arguments are the strings that are shown for the values
--- True and False in the selection box, respectively.
--- @param true - string for selection of True
--- @param false - string for selection of False
--- @return a WUI specification for a Boolean selection widget
wSelectBool :: String -> String -> WuiSpec Bool
wSelectBool true false = wSelect (\b -> if b then true else false) [True,False]
--- A widget to select a Boolean value via a check box.
--- The first argument are HTML expressions that are shown after the
--- check box. The result is True if the box is checked.
wCheckBool :: [HtmlExp] -> WuiSpec Bool
wCheckBool hexps =
WuiSpec (head, "?", const True)
(checkLegalInput checkWidget)
(\wparams -> conditionOf wparams)
(\env wst -> env (state2cgiRef wst)=="True")
where
checkWidget render v = let ref free in
(render [inline ((if v then checkedBox else checkBox) ref "True" : hexps)],
cgiRef2state ref)
--- A widget to select a list of values from a given list of values
--- via check boxes.
--- The current values should be contained in the value list and are preselected.
--- The first argument is a mapping from values into HTML expressions
--- that are shown for each item after the check box.
wMultiCheckSelect :: Eq a => (a -> [HtmlExp]) -> [a] -> WuiSpec [a]
wMultiCheckSelect showelem selset =
WuiSpec (renderTuple, tupleError, const True)
(checkLegalInput checkWidget)
(\wparams -> conditionOf wparams)
(\env st ->
concatMap (\ (ref,s) -> if env ref=="True" then [s] else [])
(zip (map state2cgiRef (state2states st)) selset))
where
checkWidget render vs =
let refs = take (length selset) newVars
numsetitems = zip refs selset
showItem (ref,s) =
inline ((if s `elem` vs then checkedBox else checkBox)
ref "True" : showelem s)
in (render (map showItem numsetitems),
states2state (map cgiRef2state refs))
newVars :: Data a => [a]
newVars = unknown : newVars
--- A widget to select a value from a given list of values via a radio button.
--- The current value should be contained in the value list and is preselected.
--- The first argument is a mapping from values into HTML expressions
--- that are shown for each item after the radio button.
wRadioSelect :: Eq a => (a->[HtmlExp]) -> [a] -> WuiSpec a
wRadioSelect showelem selset =
WuiSpec (renderTuple, tupleError, const True)
(checkLegalInput radioWidget)
(\wparams -> conditionOf wparams)
(\env s -> selset !! read (env (state2cgiRef s)))
where
radioWidget render v =
let ref free
idx = maybe 0 id (elemIndex v selset)
numhitems = zip [0..] (map showelem selset)
showItem (i,s) = table [[[(if i==idx then radioMain else radioOther)
ref (show i)],s]]
in (render (map showItem numhitems),
cgiRef2state ref)
--- A widget to select a Boolean value via a radio button.
--- The arguments are the lists of HTML expressions that are shown after
--- the True and False radio buttons, respectively.
--- @param true - HTML expressions for True radio button
--- @param false - HTML expressions for False radio button
--- @return a WUI specification for a Boolean selection widget
wRadioBool :: [HtmlExp] -> [HtmlExp] -> WuiSpec Bool
wRadioBool truehexps falsehexps =
wRadioSelect (\b -> if b then truehexps else falsehexps) [True,False]
--- WUI combinator for pairs.
wPair :: (Data a, Data b) => WuiSpec a -> WuiSpec b -> WuiSpec (a,b)
-- This simple implementation does not work in KiCS2 due to non-determinism
-- cause by functional patterns:
-- wPair = wCons2 (\a b -> (a,b))
wPair (WuiSpec wparamsa showa cora reada) (WuiSpec wparamsb showb corb readb) =
WuiSpec (renderTuple, tupleError, const True) showc corc readc
where
showc (render,errmsg,legal) nocheck (va,vb) =
let (hea,rta) = showa wparamsa nocheck va
(heb,rtb) = showb wparamsb nocheck vb
in ((if nocheck || legal (va,vb)
then render
else renderError render errmsg) [hea,heb], states2state [rta,rtb])
corc wparamsc (va,vb) = conditionOf wparamsc (va,vb) &&
cora wparamsa va && corb wparamsb vb
readc env s =
let [ra,rb] = state2states s
in (reada env ra, readb env rb)
--- WUI combinator for constructors of arity 2.
--- The first argument is the binary constructor.
--- The second and third arguments are the WUI specifications
--- for the argument types.
wCons2 :: (Data a, Data b, Data c) =>
(a->b->c) -> WuiSpec a -> WuiSpec b -> WuiSpec c
wCons2 cons (WuiSpec wparamsa showa cora reada)
(WuiSpec wparamsb showb corb readb) =
WuiSpec (renderTuple, tupleError, const True) showc corc readc
where
showc (render,errmsg,legal) nocheck vc | cons va vb =:<= vc =
let (hea,rta) = showa wparamsa nocheck va
(heb,rtb) = showb wparamsb nocheck vb
in ((if nocheck || legal (cons va vb)
then render
else renderError render errmsg) [hea,heb], states2state [rta,rtb])
where va,vb free
corc wparamsc vc | cons va vb =:<= vc =
conditionOf wparamsc (cons va vb) &&
cora wparamsa va && corb wparamsb vb where va,vb free
readc env s =
let [ra,rb] = state2states s
in cons (reada env ra) (readb env rb)
--- WUI combinator for triples.
wTriple :: (Data a, Data b, Data c) =>
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec (a,b,c)
-- This simple implementation does not work in KiCS2 due to non-determinism
-- cause by functional patterns:
--wTriple = wCons3 (\a b c -> (a,b,c))
wTriple (WuiSpec wparamsa showa cora reada)
(WuiSpec wparamsb showb corb readb)
(WuiSpec wparamsc showc corc readc) =
WuiSpec (renderTuple, tupleError, const True) showd cord readd
where
showd (render,errmsg,legal) nocheck (va,vb,vc) =
let (hea,rta) = showa wparamsa nocheck va
(heb,rtb) = showb wparamsb nocheck vb
(hec,rtc) = showc wparamsc nocheck vc
in ((if nocheck || legal (va,vb,vc)
then render
else renderError render errmsg) [hea,heb,hec],
states2state [rta,rtb,rtc])
cord wparamsd (va,vb,vc) = conditionOf wparamsd (va,vb,vc) &&
cora wparamsa va &&
corb wparamsb vb &&
corc wparamsc vc
readd env s =
let [ra,rb,rc] = state2states s
in (reada env ra, readb env rb, readc env rc)
--- WUI combinator for constructors of arity 3.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons3 :: (Data a, Data b, Data c, Data d) => (a -> b -> c -> d)
-> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d
wCons3 cons (WuiSpec wparamsa showa cora reada)
(WuiSpec wparamsb showb corb readb)
(WuiSpec wparamsc showc corc readc) =
WuiSpec (renderTuple, tupleError, const True) showd cord readd
where
showd (render,errmsg,legal) nocheck vd | cons va vb vc =:<= vd =
let (hea,rta) = showa wparamsa nocheck va
(heb,rtb) = showb wparamsb nocheck vb
(hec,rtc) = showc wparamsc nocheck vc
in ((if nocheck || legal (cons va vb vc)
then render
else renderError render errmsg) [hea,heb,hec],
states2state [rta,rtb,rtc])
where va,vb,vc free
cord wparamsd vd | cons va vb vc =:<= vd =
conditionOf wparamsd (cons va vb vc) &&
cora wparamsa va &&
corb wparamsb vb &&
corc wparamsc vc where va,vb,vc free
readd env s =
let [ra,rb,rc] = state2states s
in cons (reada env ra) (readb env rb) (readc env rc)
--- WUI combinator for tuples of arity 4.
w4Tuple :: (Data a, Data b, Data c, Data d) => WuiSpec a -> WuiSpec b -> WuiSpec c
-> WuiSpec d -> WuiSpec (a,b,c,d)
--w4Tuple = wCons4 (\a b c d -> (a,b,c,d)) -- does not work for KiCS2
w4Tuple wa wb wc wd =
transformWSpec (\ ((a,b),(c,d)) -> (a,b,c,d),
\ (a,b,c,d) -> ((a,b),(c,d)))
(wJoinTuple (wPair wa wb) (wPair wc wd))
--- WUI combinator for constructors of arity 4.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons4 :: (Data a, Data b, Data c, Data d, Data e) => (a->b->c->d->e) ->
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e
wCons4 cons wa wb wc wd =
adaptWSpec (\ ((a,b),(c,d)) -> cons a b c d)
(wJoinTuple (wPair wa wb) (wPair wc wd))
--- WUI combinator for tuples of arity 5.
w5Tuple :: (Data a, Data b, Data c, Data d, Data e) => WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec (a,b,c,d,e)
--w5Tuple = wCons5 (\a b c d e -> (a,b,c,d,e)) -- does not work for KiCS2
w5Tuple wa wb wc wd we =
transformWSpec (\ ((a,b,c),(d,e)) -> (a,b,c,d,e),
\ (a,b,c,d,e) -> ((a,b,c),(d,e)))
(wJoinTuple (wTriple wa wb wc) (wPair wd we))
--- WUI combinator for constructors of arity 5.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons5 :: (Data a, Data b, Data c, Data d, Data e, Data f) => (a->b->c->d->e->f) ->
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f
wCons5 cons wa wb wc wd we =
adaptWSpec (\ ((a,b,c),(d,e)) -> cons a b c d e)
(wJoinTuple (wTriple wa wb wc) (wPair wd we))
--- WUI combinator for tuples of arity 6.
w6Tuple :: (Data a, Data b, Data c, Data d, Data e, Data f) => WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec (a,b,c,d,e,f)
--w6Tuple = wCons6 (\a b c d e f -> (a,b,c,d,e,f))
w6Tuple wa wb wc wd we wf =
transformWSpec (\ ((a,b,c),(d,e,f)) -> (a,b,c,d,e,f),
\ (a,b,c,d,e,f) -> ((a,b,c),(d,e,f)))
(wJoinTuple (wTriple wa wb wc) (wTriple wd we wf))
--- WUI combinator for constructors of arity 6.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons6 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) =>
(a->b->c->d->e->f->g) ->
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g
wCons6 cons wa wb wc wd we wf =
adaptWSpec (\ ((a,b,c),(d,e,f)) -> cons a b c d e f)
(wJoinTuple (wTriple wa wb wc) (wTriple wd we wf))
--- WUI combinator for tuples of arity 7.
w7Tuple :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec (a,b,c,d,e,f,g)
--w7Tuple = wCons7 (\a b c d e f g -> (a,b,c,d,e,f,g))
w7Tuple wa wb wc wd we wf wg =
transformWSpec (\ ((a,b,c,d),(e,f,g)) -> (a,b,c,d,e,f,g),
\ (a,b,c,d,e,f,g) -> ((a,b,c,d),(e,f,g)))
(wJoinTuple (w4Tuple wa wb wc wd) (wTriple we wf wg))
--- WUI combinator for constructors of arity 7.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons7 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h) =>
(a->b->c->d->e->f->g->h) ->
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h
wCons7 cons wa wb wc wd we wf wg =
adaptWSpec (\ ((a,b,c,d),(e,f,g)) -> cons a b c d e f g)
(wJoinTuple (w4Tuple wa wb wc wd) (wTriple we wf wg))
--- WUI combinator for tuples of arity 8.
w8Tuple :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h) => WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec (a,b,c,d,e,f,g,h)
--w8Tuple = wCons8 (\a b c d e f g h -> (a,b,c,d,e,f,g,h))
w8Tuple wa wb wc wd we wf wg wh =
transformWSpec (\ ((a,b,c,d),(e,f,g,h)) -> (a,b,c,d,e,f,g,h),
\ (a,b,c,d,e,f,g,h) -> ((a,b,c,d),(e,f,g,h)))
(wJoinTuple (w4Tuple wa wb wc wd) (w4Tuple we wf wg wh))
--- WUI combinator for constructors of arity 8.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons8 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h, Data i) =>
(a->b->c->d->e->f->g->h->i) ->
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i
wCons8 cons wa wb wc wd we wf wg wh =
adaptWSpec (\ ((a,b,c,d),(e,f,g,h)) -> cons a b c d e f g h)
(wJoinTuple (w4Tuple wa wb wc wd) (w4Tuple we wf wg wh))
--- WUI combinator for tuples of arity 9.
w9Tuple :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h, Data i) => WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i ->
WuiSpec (a,b,c,d,e,f,g,h,i)
--w9Tuple = wCons9 (\a b c d e f g h i -> (a,b,c,d,e,f,g,h,i))
w9Tuple wa wb wc wd we wf wg wh wi =
transformWSpec (\ ((a,b,c,d,e),(f,g,h,i)) -> (a,b,c,d,e,f,g,h,i),
\ (a,b,c,d,e,f,g,h,i) -> ((a,b,c,d,e),(f,g,h,i)))
(wJoinTuple (w5Tuple wa wb wc wd we) (w4Tuple wf wg wh wi))
--- WUI combinator for constructors of arity 9.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons9 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h, Data i, Data j) => (a->b->c->d->e->f->g->h->i->j) ->
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j
wCons9 cons wa wb wc wd we wf wg wh wi =
adaptWSpec (\ ((a,b,c,d,e),(f,g,h,i)) -> cons a b c d e f g h i)
(wJoinTuple (w5Tuple wa wb wc wd we) (w4Tuple wf wg wh wi))
--- WUI combinator for tuples of arity 10.
w10Tuple :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h, Data i, Data j) => WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j ->
WuiSpec (a,b,c,d,e,f,g,h,i,j)
--w10Tuple = wCons10 (\a b c d e f g h i j -> (a,b,c,d,e,f,g,h,i,j))
w10Tuple wa wb wc wd we wf wg wh wi wj =
transformWSpec (\ ((a,b,c,d,e),(f,g,h,i,j)) -> (a,b,c,d,e,f,g,h,i,j),
\ (a,b,c,d,e,f,g,h,i,j) -> ((a,b,c,d,e),(f,g,h,i,j)))
(wJoinTuple (w5Tuple wa wb wc wd we) (w5Tuple wf wg wh wi wj))
--- WUI combinator for constructors of arity 10.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons10 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h, Data i, Data j, Data k) => (a->b->c->d->e->f->g->h->i->j->k) ->
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j ->
WuiSpec k
wCons10 cons wa wb wc wd we wf wg wh wi wj =
adaptWSpec (\ ((a,b,c,d,e),(f,g,h,i,j)) -> cons a b c d e f g h i j)
(wJoinTuple (w5Tuple wa wb wc wd we) (w5Tuple wf wg wh wi wj))
--- WUI combinator for tuples of arity 11.
w11Tuple :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h, Data i, Data j, Data k) => WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j ->
WuiSpec k -> WuiSpec (a,b,c,d,e,f,g,h,i,j,k)
--w11Tuple = wCons11 (\a b c d e f g h i j k -> (a,b,c,d,e,f,g,h,i,j,k))
w11Tuple wa wb wc wd we wf wg wh wi wj wk =
transformWSpec (\ ((a,b,c,d,e),(f,g,h,i,j,k)) -> (a,b,c,d,e,f,g,h,i,j,k),
\ (a,b,c,d,e,f,g,h,i,j,k) -> ((a,b,c,d,e),(f,g,h,i,j,k)))
(wJoinTuple (w5Tuple wa wb wc wd we) (w6Tuple wf wg wh wi wj wk))
--- WUI combinator for constructors of arity 11.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons11 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h, Data i, Data j, Data k, Data l) =>
(a->b->c->d->e->f->g->h->i->j->k->l) ->
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j ->
WuiSpec k -> WuiSpec l
wCons11 cons wa wb wc wd we wf wg wh wi wj wk =
adaptWSpec (\ ((a,b,c,d,e),(f,g,h,i,j,k)) -> cons a b c d e f g h i j k)
(wJoinTuple (w5Tuple wa wb wc wd we) (w6Tuple wf wg wh wi wj wk))
--- WUI combinator for tuples of arity 12.
w12Tuple :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h,
Data i, Data j, Data k, Data l) =>
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j ->
WuiSpec k -> WuiSpec l -> WuiSpec (a,b,c,d,e,f,g,h,i,j,k,l)
--w12Tuple = wCons12 (\a b c d e f g h i j k l -> (a,b,c,d,e,f,g,h,i,j,k,l))
w12Tuple wa wb wc wd we wf wg wh wi wj wk wl =
transformWSpec (\ ((a,b,c,d,e,f),(g,h,i,j,k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l),
\ (a,b,c,d,e,f,g,h,i,j,k,l) -> ((a,b,c,d,e,f),(g,h,i,j,k,l)))
(wJoinTuple (w6Tuple wa wb wc wd we wf) (w6Tuple wg wh wi wj wk wl))
--- WUI combinator for constructors of arity 12.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons12 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h,
Data i, Data j, Data k, Data l, Data m) =>
(a->b->c->d->e->f->g->h->i->j->k->l->m) ->
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j ->
WuiSpec k -> WuiSpec l -> WuiSpec m
wCons12 cons wa wb wc wd we wf wg wh wi wj wk wl =
adaptWSpec (\ ((a,b,c,d,e,f),(g,h,i,j,k,l)) -> cons a b c d e f g h i j k l)
(wJoinTuple (w6Tuple wa wb wc wd we wf) (w6Tuple wg wh wi wj wk wl))
--- WUI combinator for tuples of arity 13.
w13Tuple :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h,
Data i, Data j, Data k, Data l, Data m) =>
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j ->
WuiSpec k -> WuiSpec l -> WuiSpec m ->
WuiSpec (a,b,c,d,e,f,g,h,i,j,k,l,m)
--w13Tuple = wCons13 (\a b c d e f g h i j k l m -> (a,b,c,d,e,f,g,h,i,j,k,l,m))
w13Tuple wa wb wc wd we wf wg wh wi wj wk wl wm =
transformWSpec
(\ ((a,b,c,d,e,f),(g,h,i,j,k,l,m)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m),
\ (a,b,c,d,e,f,g,h,i,j,k,l,m) -> ((a,b,c,d,e,f),(g,h,i,j,k,l,m)))
(wJoinTuple (w6Tuple wa wb wc wd we wf) (w7Tuple wg wh wi wj wk wl wm))
--- WUI combinator for constructors of arity 13.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons13 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h,
Data i, Data j, Data k, Data l, Data m, Data n) =>
(a->b->c->d->e->f->g->h->i->j->k->l->m->n) ->
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j ->
WuiSpec k -> WuiSpec l -> WuiSpec m -> WuiSpec n
wCons13 cons wa wb wc wd we wf wg wh wi wj wk wl wm =
adaptWSpec
(\ ((a,b,c,d,e,f),(g,h,i,j,k,l,m)) -> cons a b c d e f g h i j k l m)
(wJoinTuple (w6Tuple wa wb wc wd we wf) (w7Tuple wg wh wi wj wk wl wm))
--- WUI combinator for tuples of arity 14.
w14Tuple :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h,
Data i, Data j, Data k, Data l, Data m, Data n) =>
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j ->
WuiSpec k -> WuiSpec l -> WuiSpec m -> WuiSpec n ->
WuiSpec (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
--w14Tuple = wCons14 (\a b c d e f g h i j k l m n -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n))
w14Tuple wa wb wc wd we wf wg wh wi wj wk wl wm wn =
transformWSpec
(\ ((a,b,c,d,e,f,g),(h,i,j,k,l,m,n)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n),
\ (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> ((a,b,c,d,e,f,g),(h,i,j,k,l,m,n)))
(wJoinTuple (w7Tuple wa wb wc wd we wf wg) (w7Tuple wh wi wj wk wl wm wn))
--- WUI combinator for constructors of arity 14.
--- The first argument is the ternary constructor.
--- The further arguments are the WUI specifications for the argument types.
wCons14 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g, Data h,
Data i, Data j, Data k, Data l, Data m, Data n, Data o) =>
(a->b->c->d->e->f->g->h->i->j->k->l->m->n->o) ->
WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e ->
WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j ->
WuiSpec k -> WuiSpec l -> WuiSpec m -> WuiSpec n -> WuiSpec o
wCons14 cons wa wb wc wd we wf wg wh wi wj wk wl wm wn =
adaptWSpec
(\ ((a,b,c,d,e,f,g),(h,i,j,k,l,m,n)) -> cons a b c d e f g h i j k l m n)
(wJoinTuple (w7Tuple wa wb wc wd we wf wg) (w7Tuple wh wi wj wk wl wm wn))
--- WUI combinator to combine two tuples into a joint tuple.
--- It is similar to wPair but renders both components as a single
--- tuple provided that the components are already rendered as tuples,
--- i.e., by the rendering function `renderTuple`.
--- This combinator is useful to define combinators for large tuples.
wJoinTuple :: (Data a, Data b) => WuiSpec a -> WuiSpec b -> WuiSpec (a,b)
wJoinTuple (WuiSpec wparamsa showa cora reada)
(WuiSpec wparamsb showb corb readb) =
WuiSpec (renderTuple, tupleError, const True) showc corc readc
where
render2joinrender render [h1,h2] =
let h1s = unRenderTuple h1
h2s = unRenderTuple h2
in render (h1s ++ h2s)
showc (render,errmsg,legal) nocheck (va,vb) =
let (hea,rta) = showa wparamsa nocheck va
(heb,rtb) = showb wparamsb nocheck vb
in ((if nocheck || legal (va,vb)
then render2joinrender render
else renderError (render2joinrender render) errmsg) [hea,heb],
states2state [rta,rtb])
corc wparamsc (va,vb) = conditionOf wparamsc (va,vb) &&
cora wparamsa va && corb wparamsb vb
readc env s =
let [ra,rb] = state2states s
in (reada env ra, readb env rb)
--- WUI combinator for list structures where the list elements are vertically
--- aligned in a table.
wList :: Eq a => WuiSpec a -> WuiSpec [a]
wList (WuiSpec wparamsa showa cora reada) =
WuiSpec (renderList, "Illegal list:", const True)
(\ (render,errmsg,legal) nocheck vas ->
listWidget
(if nocheck || legal vas
then render
else renderError render errmsg)
(unzip (map (showa wparamsa nocheck) vas)))
(\wparams vas -> conditionOf wparams vas &&
all (cora wparamsa) vas)
(\env wst -> map (reada env) (state2states wst))
where
listWidget render (hes,refs) = (render hes, states2state refs)
--- Add headings to a standard WUI for list structures:
wListWithHeadings :: Eq a => [String] -> WuiSpec a -> WuiSpec [a]
wListWithHeadings headings wspec =
wList wspec `withRendering` renderHeadings
where
renderHeadings hs = addHeadings (renderList hs) (map (\s->[htxt s]) headings)
--- Add a row of items (where each item is a list of HTML expressions)
--- as headings to a table. If the first argument is not a table,
--- the headings are ignored.
addHeadings :: HtmlExp -> [[HtmlExp]] -> HtmlExp
addHeadings htable headings = case htable of
HtmlStruct "table" attrs rows ->
HtmlStruct "table" attrs
(HtmlStruct "tr" [] (map (HtmlStruct "th" []) headings) : rows)
_ -> htable
--- WUI combinator for list structures where the list elements are horizontally
--- aligned in a table.
wHList :: Eq a => WuiSpec a -> WuiSpec [a]
wHList wspec = wList wspec `withRendering` renderTuple
--- WUI for matrices, i.e., list of list of elements
--- visualized as a matrix.
wMatrix :: Eq a => WuiSpec a -> WuiSpec [[a]]
wMatrix wspec = wList (wHList wspec)
--- WUI for Maybe values. It is constructed from a WUI for
--- Booleans and a WUI for the potential values. Nothing corresponds
--- to a selection of False in the Boolean WUI.
--- The value WUI is shown after the Boolean WUI.
--- @param wspecb - a WUI specification for Boolean values
--- @param wspeca - a WUI specification for the type of potential values
--- @param def - a default value that is used if the current value is Nothing
wMaybe :: Eq a => WuiSpec Bool -> WuiSpec a -> a -> WuiSpec (Maybe a)
wMaybe (WuiSpec paramb showb _ readb) (WuiSpec parama showa cora reada) def =
WuiSpec
(renderTuple, tupleError, const True)
(\ (render,errmsg,legal) nocheck mbs ->
let (heb,rtb) = showb paramb nocheck (mbs/=Nothing)
(hea,rta) = showa parama nocheck (maybe def id mbs)
in ((if nocheck || legal mbs
then render
else renderError render errmsg) [heb,hea],
states2state [rtb,rta]))
(\wparams mbv -> conditionOf wparams mbv &&
maybe True (\v -> cora parama v) mbv)
(\env s ->
let [rb,ra] = state2states s
vb = readb env rb
va = reada env ra
in if vb then Just va else Nothing)
--- A WUI for Maybe values where a check box is used to select Just.
--- The value WUI is shown after the check box.
--- @param wspec - a WUI specification for the type of potential values
--- @param hexps - a list of HTML expressions shown after the check box
--- @param def - a default value if the current value is Nothing
wCheckMaybe :: Eq a => WuiSpec a -> [HtmlExp] -> a -> WuiSpec (Maybe a)
wCheckMaybe wspec exps = wMaybe (wCheckBool exps) wspec
--- A WUI for Maybe values where radio buttons are used to switch
--- between Nothing and Just.
--- The value WUI is shown after the radio button WUI.
--- @param wspec - a WUI specification for the type of potential values
--- @param hexps - a list of HTML expressions shown after the Nothing button
--- @param hexps - a list of HTML expressions shown after the Just button
--- @param def - a default value if the current value is Nothing
wRadioMaybe :: Eq a => WuiSpec a -> [HtmlExp] -> [HtmlExp] -> a
-> WuiSpec (Maybe a)
wRadioMaybe wspec hnothing hjust = wMaybe wBool wspec
where
wBool = wRadioSelect (\b->if b then hjust else hnothing) [False,True]
--- WUI for union types.
--- Here we provide only the implementation for Either types
--- since other types with more alternatives can be easily reduced to this case.
wEither :: (Eq a, Eq b) => WuiSpec a -> WuiSpec b -> WuiSpec (Either a b)
wEither (WuiSpec rendera showa cora reada) (WuiSpec renderb showb corb readb) =
WuiSpec (head, "?", const True) showEither corEither readEither
where
showEither (render,errmsg,legal) nocheck (Left va) =
let (hea,rta) = showa rendera nocheck va
in ((if nocheck || legal (Left va)
then render
else renderError render errmsg) [hea], altstate2state (1,rta))
showEither (render,errmsg,legal) nocheck (Right vb) =
let (heb,rtb) = showb renderb nocheck vb
in ((if nocheck || legal (Right vb)
then render
else renderError render errmsg) [heb], altstate2state (2,rtb))
corEither wparam vab = conditionOf wparam vab &&
either (cora rendera) (corb renderb) vab
readEither env s =
let (altindex,rab) = state2altstate s
in case altindex of
1 -> Left (reada env rab)
2 -> Right (readb env rab)
--- A simple tree structure to demonstrate the construction of WUIs for tree
--- types.
data WTree a = WLeaf a | WNode [WTree a]
deriving Eq
--- WUI for tree types.
--- The rendering specifies the rendering of inner nodes.
--- Leaves are shown with their default rendering.
wTree :: Eq a => WuiSpec a -> WuiSpec (WTree a)
wTree (WuiSpec wparama showa cora reada) =
WuiSpec (renderList, "Illegal tree:", const True) showTree corTree readTree
where
showTree (render,errmsg,legal) nocheck (WLeaf va) =
let (hea,rta) = showa wparama nocheck va
in ((if nocheck || legal (WLeaf va)
then render
else renderError render errmsg) [hea],
altstate2state (1,rta))
showTree wparams@(render,errmsg,legal) nocheck (WNode ns) =
let (hes,sts) = unzip (map (showTree wparams nocheck) ns)
in ((if nocheck || legal (WNode ns)
then render
else renderError render errmsg) hes,
altstate2state (2,states2state sts))
corTree wparam (WLeaf va) = conditionOf wparam (WLeaf va) && cora wparama va
corTree wparam (WNode tvs) = conditionOf wparam (WNode tvs) &&
all (corTree wparam) tvs
readTree env wst =
let (altindex,rab) = state2altstate wst
in case altindex of
1 -> WLeaf (reada env rab)
2 -> WNode (map (readTree env) (state2states rab))
-------------------------------------------------------------------------------
-- Definition of standard rendering functions
--- Standard rendering of tuples as a table with a single row.
--- Thus, the elements are horizontally aligned.
renderTuple :: Rendering
renderTuple hexps = table [map (\h->[h]) hexps]
--- Inverse operation of renderTuple. If the argument has not the
--- shape of the renderTuple output, it is returned unchanged.
--- In future versions, this operation is better implemented using
--- functional logic features, but currently the encapsulated search
--- is a bit weak for this purpose.
unRenderTuple :: HtmlExp -> [HtmlExp]
unRenderTuple hexp =
if isTupleTable hexp
then getTupleTableElems hexp
else [hexp]
where
isTupleTable he = case he of
HtmlStruct "table" [] [HtmlStruct "tr" [] tds] -> all isSingleElem tds
_ -> False
isSingleElem he = case he of
HtmlStruct "td" _ [_] -> True
_ -> False
getTupleTableElems (HtmlStruct "table" [] [HtmlStruct "tr" [] tds]) =
map (\ (HtmlStruct "td" _ [e]) -> e) tds
-- Standard error message for tuples:
tupleError :: String
tupleError = "Illegal combination:"
--- Standard rendering of tuples with a tag for each element.
--- Thus, each is preceded by a tag, that is set in bold, and all
--- elements are vertically aligned.
renderTaggedTuple :: [String] -> Rendering
renderTaggedTuple tags hexps =
table (map (\(t,h)->[[bold [htxt t]],[h]]) (zip tags hexps))
--- Standard rendering of lists as a table with a row for each item:
--- Thus, the elements are vertically aligned.
renderList :: Rendering
renderList hexps = mergeTableOfTable (table (map (\h->[[h]]) hexps))
`addAttr` ("border","1")
-- Combine a rendering with an error message.
-- The error message is put as the first row of a table with background color
-- yellow.
renderError :: Rendering -> String -> Rendering
renderError render errmsg hexps =
table [[[boldRedTxt errmsg]], [[render hexps]]]
`addAttr` ("bgcolor","#ffff00") -- background color: yellow
boldRedTxt :: String -> HtmlExp
boldRedTxt s = HtmlStruct "font" [("color","#ff0000")] [bold [htxt s]]
mergeTableOfTable :: HtmlExp -> HtmlExp
mergeTableOfTable (HtmlStruct "table" attrs rows) =
HtmlStruct "table" attrs
(if all isRowWithSingleTableData rows
then map mergeRowWithSingleTableData rows
else rows )
isRowWithSingleTableData :: HtmlExp -> Bool
isRowWithSingleTableData row = case row of
(HtmlStruct "tr" []
[HtmlStruct "td" []
[HtmlStruct "table" _ [HtmlStruct "tr" _ _]]]) -> True
_ -> False
mergeRowWithSingleTableData :: HtmlExp -> HtmlExp
mergeRowWithSingleTableData
(HtmlStruct "tr" [] [HtmlStruct "td" [] [HtmlStruct "table" _ [row]]]) = row
-------------------------------------------------------------------------------
--- The type of data actually stored in a WUI store.
--- If the first component is `True`, the current data is not immediately
--- checked for correctness (usually, if it is the first edit call).
--- The second component is `Nothing` if the data is not yet set.
type WuiStore a = (Bool, Maybe a)
--- A `WuiSessionStore` is a persistent global entity to store the
--- information required for WUIs in HTML sessions.
type WuiSessionStore a = SessionStore (WuiStore a)
--- A `ParWuiSessionStore b a` is a persistent global entity to store the
--- information required for WUIs in HTML sessions which manipulates
--- data of type `a` and depend on additional information of type `b`.
type ParWuiSessionStore b a = SessionStore (b, WuiStore a)
--- Sets the initial data which are edited in a WUI form in the session store.
setWuiStore :: (Read a, Show a) => WuiSessionStore a -> a -> IO ()
setWuiStore wuistore val = putSessionData wuistore (True, Just val)
--- Reads the data which are edited in a WUI form from the session store.
getWuiStore :: (Read a, Show a) =>
WuiSessionStore a -> FormReader (WuiStore a)
getWuiStore wuistore = getSessionData wuistore (True, Nothing)
--- Sets the initial data which are edited in a parameterized WUI form
--- in the session store.
setParWuiStore :: (Read a, Show a, Read b, Show b) =>
ParWuiSessionStore b a -> b -> a -> IO ()
setParWuiStore wuistore par val =
putSessionData wuistore (par, (True, Just val))
--- Reads the data which are edited in a parameterized WUI form
--- from the session store.
getParWuiStore :: (Read a, Show a, Read b, Show b) =>
ParWuiSessionStore b a -> FormReader (b,WuiStore a)
getParWuiStore wuistore = getSessionData wuistore (failed, (True, Nothing))
-- Main operations to generate HTML form definitions from WUI specifications:
--- Generates an HTML form definition from a string (the qualified name
--- of the top-level operation corresponding to this form),
--- a session data store containing the data to be edited,
--- a WUI specification,
--- an action to store the updated data and returning an HTML answer,
--- an operation to render the WUI (e.g., `wuiSimpleRenderer`), and
--- which is used when input errors must be corrected,
--- from the HTML WUI expression and submit handler.
wui2FormDef :: (Read a, Show a) =>
String
-> WuiSessionStore a
-> WuiSpec a
-> (a -> IO [BaseHtml])
-> (HtmlExp -> (HtmlEnv -> IO [BaseHtml]) -> [HtmlExp])
-> HtmlFormDef (WuiStore a)
wui2FormDef formqname wuistore wuispec storepage renderwui =
let wuiformdef = formDefWithID formqname (getWuiStore wuistore)
(formHtml wuiformdef)
in wuiformdef
where
formHtml iform sdata =
wui2HtmlExp wuistore wuispec storepage renderwui iform sdata
--- Generates an HTML form expression from
--- a session store containing the data to be edited,
--- a WUI data specification,
--- an action to store the updated data and returning an HTML answer,
--- an operation to render the WUI (e.g., `wuiSimpleRenderer`),
--- which is used when input errors must be corrected,
--- an HTML form definition representing the generated form,
--- and the actual data of the store.
wui2HtmlExp :: (Read a, Show a) =>
WuiSessionStore a
-> WuiSpec a
-> (a -> IO [BaseHtml])
-> (HtmlExp -> (HtmlEnv -> IO [BaseHtml]) -> [HtmlExp])
-> HtmlFormDef (WuiStore a)
-> WuiStore a -> [HtmlExp]
wui2HtmlExp _ _ _ _ _ (_,Nothing) =
[h1 [htxt "Execution error!"],
htxt "Cookie not yet set, please run again or accept cookies!"]
wui2HtmlExp wuistore (WuiSpec wparams wshow wcor wread) storepage renderwui
wuiformdef (fstcall,Just val) =
let (hexp,wst) = wshow wparams fstcall val
in renderwui hexp (handler wst)
where
handler wst env = do
let newval = id $## wread env wst -- ensure that everything is evaluated
if (wcor wparams) newval
then do putSessionData wuistore (True, Nothing)
storepage newval
else do putSessionData wuistore (False, Just newval)
return [formElem wuiformdef]
--- Generates an HTML form definition similarly to `wui2FormDef`
--- but with some additional data on which the further arguments depend.
pwui2FormDef :: (Read a, Show a, Read b, Show b) =>
String
-> ParWuiSessionStore b a
-> (b -> WuiSpec a)
-> (b -> a -> IO [BaseHtml])
-> (b -> HtmlExp -> (HtmlEnv -> IO [BaseHtml]) -> [HtmlExp])
-> HtmlFormDef (b, WuiStore a)
pwui2FormDef formqname wuistore wuispec storepage renderwui =
let wuiformdef = formDefWithID formqname (getParWuiStore wuistore)
(formHtml wuiformdef)
in wuiformdef
where
formHtml iform sdata =
pwui2HtmlExp wuistore wuispec storepage renderwui iform sdata
--- Generates an HTML form expression similarly to `wui2HtmlExp`
--- but with some additional data on which the further arguments depend.
pwui2HtmlExp :: (Read a, Show a, Read b, Show b) =>
ParWuiSessionStore b a
-> (b -> WuiSpec a)
-> (b -> a -> IO [BaseHtml])
-> (b -> HtmlExp -> (HtmlEnv -> IO [BaseHtml]) -> [HtmlExp])
-> HtmlFormDef (b,WuiStore a)
-> (b, WuiStore a) -> [HtmlExp]
pwui2HtmlExp _ _ _ _ _ (_,(_,Nothing)) =
[h1 [htxt "Execution error!"],
htxt "Cookie not yet set, please run again or accept cookies!"]
pwui2HtmlExp wuistore pwuispec storepage renderwui
wuiformdef (par, (fstcall,Just val)) =
let (WuiSpec wparams wshow wcor wread) = pwuispec par
(hexp,wst) = wshow wparams fstcall val
in renderwui par hexp (handler wparams wcor wread wst)
where
handler wparams wcor wread wst env = do
let newval = id $## wread env wst -- ensure that everything is evaluated
if (wcor wparams) newval
then do putSessionData wuistore (par, (True, Nothing))
storepage par newval
else do putSessionData wuistore (par, (False, Just newval))
return [formElem wuiformdef]
--- A standard rendering for WUI forms.
--- The arguments are the HTML expression representing the WUI fields
--- and the handler for the "submit" button.
wuiSimpleRenderer :: HtmlExp -> (HtmlEnv -> IO [BaseHtml]) -> [HtmlExp]
wuiSimpleRenderer inputhexp storehandler =
[inputhexp, breakline,
button "Submit" (\env -> storehandler env >>= return . page "Answer")]
--------------------------------------------------------------------------
|