Commit ee85297f authored by Jan Reese's avatar Jan Reese

working on adding pertiap page updates to the WUI librtary, still a mess of type error right now

parent 7d409c00
......@@ -39,7 +39,6 @@ module HTML.WUI
)
where
import Char(isDigit,isSpace)
import FunctionInversion (invf1)
import Global
import List(elemIndex)
......@@ -49,6 +48,7 @@ import ReadShowTerm
import HTML.Base
import HTML.Session
import HTML.Util
infixl 0 `withRendering`
infixl 0 `withError`
......@@ -90,7 +90,10 @@ 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 = [HtmlDynExp] -> HtmlDynExp
--- left holds update instructions in case of error, right holds Normal rendering.
type Rendering = Either [HtmlUpdate] ([HtmlDynExp] -> HtmlDynExp)
--- WuiParams specify the parameters of an individual Wui component type:
--- * the standard rendering
......@@ -98,9 +101,15 @@ type Rendering = [HtmlDynExp] -> HtmlDynExp
--- * a condition to specify legal input values
type WuiParams a = (Rendering, String, a -> Bool)
apply :: Rendering -> [HtmlDynExp] -> Either [HtmlUpdate] HtmlDynExp
apply (Left updates) _ = Left updates
apply (Right render) exps = Right (render exps)
renderOf :: WuiParams a -> Rendering
renderOf (render,_,_) = render
--TODO : turn error into an html Update instead. (or a collection of updates)
-- see what that does to the typing of the library -.-'
errorOf :: WuiParams a -> String
errorOf (_,err,_) = err
......@@ -108,11 +117,11 @@ conditionOf :: WuiParams a -> (a -> Bool)
conditionOf (_,_,c) = c
------------------------------------------------------------------------------
--- The type HtmlSate are values consisting of an HTML expression
--- The type HtmlState 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 = (HtmlDynExp,WuiState)
type HtmlState = (Either [HtmlUpdate] HtmlDynExp, WuiState)
------------------------------------------------------------------------------
--- A handler for a WUI is an event handler for HTML forms possibly with some
......@@ -186,8 +195,8 @@ adaptWSpec a2b = transformWSpec (a2b, invf1 a2b)
--- structures, e.g., internal identifiers, data base keys.
wHidden :: WuiSpec a
wHidden =
WuiSpec (head, "?", const True) -- dummy values, not used
(\_ _ v -> (hempty, value2state v))
WuiSpec (Right head, "?", const True) -- dummy values, not used
(\_ _ v -> (Right hempty, value2state v))
(\_ _ -> True)
(\_ wst -> (state2value wst))
......@@ -195,16 +204,16 @@ wHidden =
--- The first argument is a mapping of the value into a HTML expression
--- to show this value.
wConstant :: (a -> HtmlDynExp) -> WuiSpec a
wConstant showhtml =
WuiSpec (head, "?", const True)
(\wparams _ v -> ((renderOf wparams) [showhtml v], value2state v))
wConstant showhtml =
WuiSpec (Right head, "?", const True)
(\wparams _ v -> (apply (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)
WuiSpec (Right head, "Illegal integer:", const True)
(checkLegalInput intWidget)
(\wparams -> conditionOf wparams)
(\env wst ->
......@@ -212,24 +221,9 @@ wInt =
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
(apply render [textField ref (show i) `addAttr` ("size","6")], cgiRef2state ref)
-- TODO : this is where the partial updates will be included
checkLegalInput :: (Rendering -> a -> HtmlState) -> WuiParams a -> Bool -> a
-> HtmlState
checkLegalInput value2widget (render,errmsg,legal) nocheck value =
......@@ -237,19 +231,6 @@ checkLegalInput value2widget (render,errmsg,legal) nocheck value =
then value2widget render value
else value2widget (renderError render errmsg) value
--- 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 []
......@@ -262,13 +243,13 @@ wStringSize size = wStringAttrs [("size",show size)]
--- text field.
wStringAttrs :: [(String,String)] -> WuiSpec String
wStringAttrs attrs =
WuiSpec (head, "?", const True)
WuiSpec (Right 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)
(apply 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
......@@ -287,13 +268,13 @@ wRequiredStringSize size =
--- The argument specifies the height and width of the text area.
wTextArea :: (Int,Int) -> WuiSpec String
wTextArea dims =
WuiSpec (head, "?", const True)
WuiSpec (Right 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)
(apply render [textArea ref dims v], 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.
......@@ -301,7 +282,7 @@ wTextArea dims =
--- in the selection widget.
wSelect :: Eq a => (a -> String) -> [a] -> WuiSpec a
wSelect showelem selset =
WuiSpec (head, "?", const True)
WuiSpec (Right head, "?", const True)
(checkLegalInput selWidget)
(\wparams -> conditionOf wparams)
(\env s -> selset !! readNat (env (state2cgiRef s)))
......@@ -310,7 +291,7 @@ wSelect showelem selset =
let ref free
idx = elemIndex v selset
namevalues = zip (map showelem selset) (map show [0..])
in (render [maybe (selection ref namevalues)
in (apply render [maybe (selection ref namevalues)
(\i -> selectionInitial ref namevalues i)
idx],
cgiRef2state ref)
......@@ -335,13 +316,13 @@ wSelectBool true false = wSelect (\b -> if b then true else false) [True,False]
--- check box. The result is True if the box is checked.
wCheckBool :: [HtmlDynExp] -> WuiSpec Bool
wCheckBool hexps =
WuiSpec (head, "?", const True)
WuiSpec (Right 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)],
(apply 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
......@@ -364,7 +345,7 @@ wMultiCheckSelect showelem selset =
showItem (ref,s) =
inline ((if s `elem` vs then checkedBox else checkBox)
ref "True" : showelem s)
in (render (map showItem numsetitems),
in (apply render (map showItem numsetitems),
states2state (map cgiRef2state refs))
newVars :: [_]
......@@ -387,7 +368,7 @@ wRadioSelect showelem 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),
in (apply render (map showItem numhitems),
cgiRef2state ref)
--- A widget to select a Boolean value via a radio button.
......@@ -408,12 +389,12 @@ wPair :: (Eq a, Eq b) => WuiSpec a -> WuiSpec b -> WuiSpec (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
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])
then (apply render)
else (apply (renderError render errmsg))) [hea, heb], states2state [rta,rtb])
corc wparamsc (va,vb) = conditionOf wparamsc (va,vb) &&
cora wparamsa va && corb wparamsb vb
......@@ -435,8 +416,8 @@ wCons2 cons (WuiSpec wparamsa showa cora reada)
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])
then apply render
else apply (renderError render errmsg)) [hea,heb], states2state [rta,rtb])
where va,vb free
corc wparamsc vc | cons va vb =:<= vc =
......@@ -464,8 +445,8 @@ wTriple (WuiSpec wparamsa showa cora reada)
(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],
then apply render
else apply (renderError render errmsg)) [hea,heb,hec],
states2state [rta,rtb,rtc])
cord wparamsd (va,vb,vc) = conditionOf wparamsd (va,vb,vc) &&
......@@ -492,8 +473,8 @@ wCons3 cons (WuiSpec wparamsa showa cora reada)
(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],
then apply render
else apply (renderError render errmsg)) [hea,heb,hec],
states2state [rta,rtb,rtc])
where va,vb,vc free
......@@ -769,14 +750,14 @@ wJoinTuple (WuiSpec wparamsa showa cora reada)
render2joinrender render [h1,h2] =
let h1s = unRenderTuple h1
h2s = unRenderTuple h2
in render (h1s++h2s)
in apply 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],
then apply (render2joinrender render)
else apply (renderError (render2joinrender render) errmsg (head (mapMaybe getRef [hea,heb])))) [hea,heb],
states2state [rta,rtb])
corc wparamsc (va,vb) = conditionOf wparamsc (va,vb) &&
......@@ -802,7 +783,7 @@ wList (WuiSpec wparamsa showa cora reada) =
all (cora wparamsa) vas)
(\env wst -> map (reada env) (state2states wst))
where
listWidget render (hes,refs) = (render hes, states2state refs)
listWidget render (hes,refs) = (apply render hes, states2state refs)
--- Add headings to a standard WUI for list structures:
wListWithHeadings :: Eq a => [String] -> WuiSpec a -> WuiSpec [a]
......@@ -838,8 +819,8 @@ wMaybe (WuiSpec paramb showb _ readb) (WuiSpec parama showa cora reada) def =
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],
then apply render
else apply (renderError render errmsg (head (mapMaybe getRef [hea,heb])))) [heb,hea],
states2state [rtb,rta]))
(\wparams mbv -> conditionOf wparams mbv &&
maybe True (\v -> cora parama v) mbv)
......@@ -882,12 +863,12 @@ wEither (WuiSpec rendera showa cora reada) (WuiSpec renderb showb corb readb) =
let (hea,rta) = showa rendera nocheck va
in ((if nocheck || legal (Left va)
then render
else renderError render errmsg) [hea], altstate2state (1,rta))
else renderError render errmsg (head (maybeToList (getRef hea)))) [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))
then apply render
else apply (renderError render errmsg (head (maybeToList (getRef heb))))) [heb], altstate2state (2,rtb))
corEither wparam vab = conditionOf wparam vab &&
either (cora rendera) (corb renderb) vab
......@@ -913,14 +894,14 @@ wTree (WuiSpec wparama showa cora reada) =
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],
then apply render
else apply (renderError render errmsg (head (maybeToList (getRef hea))))) [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,
then apply render
else apply (renderError render errmsg (head (mapMaybe getRef hes)))) hes,
altstate2state (2,states2state sts))
corTree wparam (WLeaf va) = conditionOf wparam (WLeaf va) && cora wparama va
......@@ -939,7 +920,7 @@ wTree (WuiSpec wparama showa cora reada) =
--- 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]
renderTuple = Right (\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.
......@@ -967,23 +948,26 @@ tupleError = "Illegal combination:"
--- 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))
renderTaggedTuple tags =
Right (\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")
renderList = Right (\hexps -> (mergeTableOfTable (table (map (\h->[[h]]) hexps)))
`addAttr` ("border","1"))
-- TODO : This is where the partial updates are rendered -----------------------
-- 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
renderError :: Rendering -> String -> CgiRef -> Rendering
renderError render errmsg ref =
case render of
Right _ -> Left [(insertBeforeWUI ref ((boldRedTxt errmsg)))]
Left updates -> Left ((insertBeforeWUI ref ((boldRedTxt errmsg))) : updates)
boldRedTxt :: HtmlStatic a => String -> a
boldRedTxt s = htmlStruct "font" [("color","#ff0000")] [bold [htxt s]]
......@@ -1145,9 +1129,9 @@ pwui2HtmlExp wuistore pwuispec storepage renderwui
wuiSimpleRenderer :: HtmlDynExp -> (CgiEnv -> IO [HtmlExp]) -> [HtmlDynExp]
wuiSimpleRenderer inputhexp storehandler =
[inputhexp, breakline,
(button "Submit" handler)::HtmlDynExp]
where
handler :: CgiEnv -> (IO HtmlPage)
(button "Submit" handler) :: HtmlDynExp]
where
handler :: CgiEnv -> (IO HtmlPage)
handler = (\env -> storehandler env >>= return . page "Answer")
--------------------------------------------------------------------------
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