module WASH.CGI.Submit98
( InputHandle, HasValue (value)
, F0 (F0), F1 (F1), F2 (F2), F3 (F3), F4 (F4), F5 (F5), F6 (F6), F7 (F7), F8 (F8)
, FL (FL), FA (FA)
, deF0, deF1, deF2, deF3, deF4, deF5, deF6, deF7, deF8
, deFL, deFA
, deValueF0, deValueF1, deValueF2, deValueF3, deValueF4, deValueF5, deValueF6, deValueF7, deValueF8
, deValueFL, deValueFA
, submit, submit0, defaultSubmit, DTree, submitx, dtleaf, dtnode
, submitLink, submitLink0, defaultSubmitLink
, activate
)
where
import WASH.CGI.AbstractSelector
import WASH.CGI.CGIInternals
import WASH.CGI.CGIMonad
import WASH.CGI.EventHandlers
import qualified WASH.CGI.HTMLWrapper as H
import WASH.CGI.InputHandle
import Monad
instance HasValue InputField where
value inf = valueInputField inf
instance InputHandle (InputField a) where
validate inf = validateInputField inf
isBound inf = ifBound inf
ihNames inf = [ifName inf]
data F0 x = F0
deF0 :: r -> (F0 x -> r)
deF0 r F0 = r
deValueF0 r F0 = r
instance InputHandle F0 where
validate F0 = Right F0
isBound F0 = True
ihNames F0 = []
data F1 a x = F1 (a x)
deF1 :: (a x -> r) -> (F1 a x -> r)
deF1 g (F1 ax) = g ax
deValueF1 g (F1 ax) = g (value ax)
instance InputHandle a => InputHandle (F1 a) where
validate (F1 ainv) =
feither id F1 (validate ainv)
isBound (F1 ainv) = isBound ainv
ihNames (F1 ainv) = ihNames ainv
data F2 a b x = F2 (a x) (b x)
deF2 :: (a x -> b x -> r) -> (F2 a b x -> r)
deF2 g (F2 ax bx) = g ax bx
deValueF2 g (F2 ax bx) = g (value ax) (value bx)
instance (InputHandle a, InputHandle b) => InputHandle (F2 a b) where
validate (F2 ainv binv) =
feither id (uncurry F2)
(propagate (validate ainv) (validate binv))
isBound (F2 ainv binv) =
isBound ainv && isBound binv
ihNames (F2 ainv binv) =
ihNames ainv ++ ihNames binv
data F3 a b c x = F3 (a x) (b x) (c x)
deF3 :: (a x -> b x -> c x -> r) -> (F3 a b c x -> r)
deF3 g (F3 ax bx cx) = g ax bx cx
deValueF3 g (F3 ax bx cx) = g (value ax) (value bx) (value cx)
instance (InputHandle a, InputHandle b, InputHandle c) => InputHandle (F3 a b c) where
validate (F3 ainv binv cinv) =
feither id (\ (aval,(bval,cval)) -> F3 aval bval cval)
(propagate (validate ainv)
(propagate (validate binv) (validate cinv)))
isBound (F3 ainv binv cinv) =
isBound ainv && isBound binv && isBound cinv
ihNames (F3 ainv binv cinv) =
ihNames ainv ++ ihNames binv ++ ihNames cinv
data F4 a b c d x = F4 (a x) (b x) (c x) (d x)
deF4 :: (a x -> b x -> c x -> d x -> r) -> (F4 a b c d x -> r)
deF4 g (F4 ax bx cx dx) = g ax bx cx dx
deValueF4 g (F4 ax bx cx dx) = g (value ax) (value bx) (value cx) (value dx)
instance (InputHandle a, InputHandle b, InputHandle c, InputHandle d)
=> InputHandle (F4 a b c d) where
validate (F4 ainv binv cinv dinv) =
feither id (\ (aval,(bval,(cval,dval))) -> F4 aval bval cval dval)
(propagate (validate ainv)
(propagate (validate binv)
(propagate (validate cinv) (validate dinv))))
isBound (F4 ainv binv cinv dinv) =
isBound ainv && isBound binv && isBound cinv && isBound dinv
ihNames (F4 ainv binv cinv dinv) =
ihNames ainv ++ ihNames binv ++ ihNames cinv ++ ihNames dinv
data F5 a b c d e x = F5 (a x) (b x) (c x) (d x) (e x)
deF5 :: (a x -> b x -> c x -> d x -> e x -> r) -> (F5 a b c d e x -> r)
deF5 g (F5 ax bx cx dx ex) = g ax bx cx dx ex
deValueF5 g (F5 ax bx cx dx ex) = g (value ax) (value bx) (value cx) (value dx) (value ex)
instance (InputHandle a, InputHandle b, InputHandle c, InputHandle d, InputHandle e)
=> InputHandle (F5 a b c d e) where
validate (F5 ainv binv cinv dinv einv) =
feither id (\ (aval,(bval,(cval,(dval,eval)))) -> F5 aval bval cval dval eval)
(propagate (validate ainv)
(propagate (validate binv)
(propagate (validate cinv)
(propagate (validate dinv) (validate einv)))))
isBound (F5 ainv binv cinv dinv einv) =
isBound ainv && isBound binv && isBound cinv && isBound dinv && isBound einv
ihNames (F5 ainv binv cinv dinv einv) =
ihNames ainv ++ ihNames binv ++ ihNames cinv ++ ihNames dinv ++ ihNames einv
data F6 a b c d e f x = F6 (a x) (b x) (c x) (d x) (e x) (f x)
deF6 :: (a x -> b x -> c x -> d x -> e x -> f x -> r) -> (F6 a b c d e f x -> r)
deF6 g (F6 ax bx cx dx ex fx) = g ax bx cx dx ex fx
deValueF6 g (F6 ax bx cx dx ex fx) = g (value ax) (value bx) (value cx) (value dx) (value ex) (value fx)
instance (InputHandle a, InputHandle b, InputHandle c, InputHandle d, InputHandle e, InputHandle f)
=> InputHandle (F6 a b c d e f) where
validate (F6 ainv binv cinv dinv einv finv) =
feither id (\ (aval,(bval,(cval,(dval,(eval, fval))))) -> F6 aval bval cval dval eval fval)
(propagate (validate ainv)
(propagate (validate binv)
(propagate (validate cinv)
(propagate (validate dinv)
(propagate (validate einv) (validate finv))))))
isBound (F6 ainv binv cinv dinv einv finv) =
isBound ainv && isBound binv && isBound cinv && isBound dinv && isBound einv && isBound finv
ihNames (F6 ainv binv cinv dinv einv finv) =
ihNames ainv ++ ihNames binv ++ ihNames cinv ++ ihNames dinv ++ ihNames einv ++ ihNames finv
data F7 a b c d e f g x = F7 (a x) (b x) (c x) (d x) (e x) (f x) (g x)
deF7 :: (a x -> b x -> c x -> d x -> e x -> f x -> g x -> r) -> (F7 a b c d e f g x -> r)
deF7 g (F7 ax bx cx dx ex fx gx) = g ax bx cx dx ex fx gx
deValueF7 g (F7 ax bx cx dx ex fx gx) = g (value ax) (value bx) (value cx) (value dx) (value ex) (value fx) (value gx)
instance (InputHandle a, InputHandle b, InputHandle c, InputHandle d, InputHandle e, InputHandle f, InputHandle g)
=> InputHandle (F7 a b c d e f g) where
validate (F7 ainv binv cinv dinv einv finv ginv) =
feither id (\ (aval,(bval,(cval,(dval,(eval, (fval, gval)))))) -> F7 aval bval cval dval eval fval gval)
(propagate (validate ainv)
(propagate (validate binv)
(propagate (validate cinv)
(propagate (validate dinv)
(propagate (validate einv)
(propagate (validate finv) (validate ginv)))))))
isBound (F7 ainv binv cinv dinv einv finv ginv) =
isBound ainv && isBound binv && isBound cinv && isBound dinv && isBound einv && isBound finv && isBound ginv
ihNames (F7 ainv binv cinv dinv einv finv ginv) =
ihNames ainv ++ ihNames binv ++ ihNames cinv ++ ihNames dinv ++ ihNames einv ++ ihNames finv ++ ihNames ginv
data F8 a b c d e f g h x = F8 (a x) (b x) (c x) (d x) (e x) (f x) (g x) (h x)
deF8 :: (a x -> b x -> c x -> d x -> e x -> f x -> g x -> h x -> r) -> (F8 a b c d e f g h x -> r)
deF8 g (F8 ax bx cx dx ex fx gx hx) = g ax bx cx dx ex fx gx hx
deValueF8 g (F8 ax bx cx dx ex fx gx hx) = g (value ax) (value bx) (value cx) (value dx) (value ex) (value fx) (value gx) (value hx)
instance (InputHandle a, InputHandle b, InputHandle c, InputHandle d, InputHandle e, InputHandle f, InputHandle g, InputHandle h)
=> InputHandle (F8 a b c d e f g h) where
validate (F8 ainv binv cinv dinv einv finv ginv hinv) =
feither id (\ (aval,(bval,(cval,(dval,(eval, (fval, (gval, hval))))))) -> F8 aval bval cval dval eval fval gval hval)
(propagate (validate ainv)
(propagate (validate binv)
(propagate (validate cinv)
(propagate (validate dinv)
(propagate (validate einv)
(propagate (validate finv)
(propagate (validate ginv) (validate hinv))))))))
isBound (F8 ainv binv cinv dinv einv finv ginv hinv) =
isBound ainv && isBound binv && isBound cinv && isBound dinv && isBound einv && isBound finv && isBound ginv && isBound hinv
ihNames (F8 ainv binv cinv dinv einv finv ginv hinv) =
ihNames ainv ++ ihNames binv ++ ihNames cinv ++ ihNames dinv ++ ihNames einv ++ ihNames finv ++ ihNames ginv ++ ihNames hinv
data FL a x = FL [a x]
deFL :: ([a x] -> r) -> (FL a x -> r)
deFL g (FL axs) = g axs
deValueFL g (FL axs) = g (map value axs)
instance InputHandle a => InputHandle (FL a) where
validate (FL ainvs) =
g (map validate ainvs)
where
g = foldr h (Right (FL []))
h ev evs = feither id (\ (v, FL vs) -> FL (v : vs)) (propagate ev evs)
isBound (FL ainvs) =
all isBound ainvs
ihNames (FL ainvs) =
concatMap ihNames ainvs
data FA a b x = FA a (b x)
deFA :: (a -> b x -> r) -> (FA a b x -> r)
deFA g (FA a bx) = g a bx
deValueFA g (FA a bx) = g a (value bx)
instance InputHandle b => InputHandle (FA a b) where
validate (FA a binv) =
feither id (FA a) (validate binv)
isBound (FA a binv) =
isBound binv
ihNames (FA a binv) =
ihNames binv
submit :: (CGIMonad cgi, InputHandle h)
=> h INVALID
-> (h VALID -> cgi ())
-> HTMLField cgi x y ()
submit = submitInternal False
submit0 :: (CGIMonad cgi) => cgi () -> HTMLField cgi x y ()
submit0 cont = submit F0 (\F0 -> cont)
defaultSubmit :: (CGIMonad cgi, InputHandle h) =>
h INVALID -> (h VALID -> cgi ()) -> HTMLField cgi x y ()
defaultSubmit = submitInternal True
submitLink :: (CGIMonad cgi, InputHandle h) =>
h INVALID -> (h VALID -> cgi ()) -> H.HTMLCons x y cgi ()
submitLink = submitInternalLink False
submitLink0 :: (CGIMonad cgi) => cgi () -> H.HTMLCons x y cgi ()
submitLink0 cont = submitLink F0 (const cont)
defaultSubmitLink :: (CGIMonad cgi, InputHandle h) =>
h INVALID -> (h VALID -> cgi ()) -> H.HTMLCons x y cgi ()
defaultSubmitLink = submitInternalLink True
newtype DTree cgi x y = DTree { unDTree :: HTMLField cgi x y () }
submitx :: DTree cgi x y -> HTMLField cgi x y ()
submitx = unDTree
dtleaf :: (CGIMonad cgi) => cgi () -> DTree cgi x y
dtleaf action = DTree $ submit0 action
dtnode :: (CGIMonad cgi, InputHandle h) =>
h INVALID -> (h VALID -> DTree cgi x y) -> DTree cgi x y
dtnode hinv next =
if isBound hinv then
case validate hinv of
Right hval ->
next hval
Left ss ->
DTree $ internalSubmitField False (Left ss)
else
DTree $ internalSubmitField False (Left [])
submitInternal isDefault hinv g =
internalSubmitField isDefault (validator hinv g)
validator hinv g =
either Left (Right . g) (validate hinv)
submitInternalLink isDefault hinv g =
internalSubmitLink isDefault (validator hinv g)
instance HasValue RadioGroup where
value rg = valueRadioGroup rg
instance InputHandle (RadioGroup a) where
validate rg = validateRadioGroup rg
isBound rg = radioBound rg
ihNames rg = [radioName rg]
instance HasValue SelectionGroup where
value sg = valueSelectionGroup sg
instance InputHandle (SelectionGroup a) where
validate sg = validateSelectionGroup sg
isBound sg = selectionBound sg
ihNames sg = [selectionName sg]
activate :: (CGIMonad cgi, InputHandle (i a), HasValue i) =>
(a -> cgi ()) -> HTMLField cgi x y (i a INVALID) -> HTMLField cgi x y (i a INVALID)
activate actionFun inputField attrs =
do invalid_inf <- inputField (do attrs
onChange $ "WASHSubmit(this.name);")
let r = validate invalid_inf
rv = either Left (Right . value) r
when (isBound invalid_inf) $
activateInternal actionFun (head $ ihNames invalid_inf) rv
return invalid_inf