module WASH.CGI.SubmitXX where
import WASH.CGI.CGIInternals
import WASH.CGI.CGIMonad
import WASH.CGI.EventHandlers
import Monad
class StripHandle hx x | hx -> x where
validate :: hx -> Either [ValidationError] x
isBound :: hx -> Bool
ihNames :: hx -> [String]
instance StripHandle (InputField a x) a where
validate inf =
case validateInputField inf of
Left ss ->
Left ss
Right _ ->
Right $ valueInputField inf
isBound inf =
ifBound inf
ihNames inf =
[ifName inf]
instance StripHandle (RadioGroup a x) a where
validate rg =
case validateRadioGroup rg of
Left ss ->
Left ss
Right _ ->
Right $ valueRadioGroup rg
isBound rg =
radioBound rg
ihNames rg =
[radioName rg]
instance StripHandle () () where
validate () = Right ()
isBound () = True
ihNames () = []
instance (StripHandle hx x, StripHandle hy y) => StripHandle (hx, hy) (x, y) where
validate (hx, hy) =
propagate (validate hx) (validate hy)
isBound (hx, hy) =
isBound hx && isBound hy
ihNames (hx, hy) =
ihNames hx ++ ihNames hy
instance (StripHandle hx x, StripHandle hy y, StripHandle hz z)
=> StripHandle (hx, hy, hz) (x, y, z) where
validate (hx, hy, hz) =
feither id (\ (x, (y, z)) -> (x, y, z)) $
propagate (validate hx) (propagate (validate hy) (validate hz))
isBound (hx, hy, hz) =
isBound hx && isBound (hy, hz)
ihNames (hx, hy, hz) =
ihNames hx ++ ihNames (hy, hz)
instance (StripHandle hx x, StripHandle hy y, StripHandle hz z, StripHandle ha a)
=> StripHandle (hx, hy, hz, ha) (x, y, z, a) where
validate (hx, hy, hz, ha) =
feither id (\ ((x, y), (z, a)) -> (x, y, z, a)) $
propagate
(propagate (validate hx) (validate hy))
(propagate (validate hz) (validate ha))
isBound (hx, hy, hz, ha) =
isBound (hx, hy) && isBound (hz, ha)
ihNames (hx, hy, hz, ha) =
ihNames (hx, hy) ++ ihNames (hz, ha)
instance (StripHandle hx x, StripHandle hy y, StripHandle hz z, StripHandle ha a, StripHandle hb b)
=> StripHandle (hx, hy, hz, ha, hb) (x, y, z, a, b) where
validate (hx, hy, hz, ha, hb) =
feither id (\ ((x, y), (z, (a, b))) -> (x, y, z, a, b)) $
propagate
(propagate (validate hx) (validate hy))
(propagate (validate hz) (propagate (validate ha) (validate hb)))
isBound (hx, hy, hz, ha, hb) =
isBound (hx, hy) && isBound (hz, (ha, hb))
ihNames (hx, hy, hz, ha, hb) =
ihNames (hx, hy) ++ ihNames (hz, (ha, hb))
instance (StripHandle hx x, StripHandle hy y, StripHandle hz z, StripHandle ha a, StripHandle hb b, StripHandle hc c)
=> StripHandle (hx, hy, hz, ha, hb, hc) (x, y, z, a, b, c) where
validate (hx, hy, hz, ha, hb, hc) =
feither id (\ ((x, y, z), (a, b, c)) -> (x, y, z, a, b, c)) $
propagate
(validate (hx, hy, hz)) (validate (ha, hb, hc))
isBound (hx, hy, hz, ha, hb, hc) =
isBound (hx, hy, hz) && isBound (ha, hb, hc)
ihNames (hx, hy, hz, ha, hb, hc) =
ihNames (hx, hy, hz) ++ ihNames (ha, hb, hc)
instance (StripHandle hx x, StripHandle hy y, StripHandle hz z, StripHandle ha a, StripHandle hb b, StripHandle hc c, StripHandle hd d)
=> StripHandle (hx, hy, hz, ha, hb, hc, hd) (x, y, z, a, b, c, d) where
validate (hx, hy, hz, ha, hb, hc, hd) =
feither id (\ ((x, y, z), (a, b, c, d)) -> (x, y, z, a, b, c, d)) $
propagate
(validate (hx, hy, hz)) (validate (ha, hb, hc, hd))
isBound (hx, hy, hz, ha, hb, hc, hd) =
isBound (hx, hy, hz) && isBound (ha, hb, hc, hd)
ihNames (hx, hy, hz, ha, hb, hc, hd) =
ihNames (hx, hy, hz) ++ ihNames (ha, hb, hc, hd)
instance (StripHandle hx x, StripHandle hy y, StripHandle hz z, StripHandle ha a, StripHandle hb b, StripHandle hc c, StripHandle hd d, StripHandle he e)
=> StripHandle (hx, hy, hz, ha, hb, hc, hd, he) (x, y, z, a, b, c, d, e) where
validate (hx, hy, hz, ha, hb, hc, hd, he) =
feither id (\ ((x, y, z), (a, b, c, d, e)) -> (x, y, z, a, b, c, d, e)) $
propagate
(validate (hx, hy, hz)) (validate (ha, hb, hc, hd, he))
isBound (hx, hy, hz, ha, hb, hc, hd, he) =
isBound (hx, hy, hz) && isBound (ha, hb, hc, hd, he)
ihNames (hx, hy, hz, ha, hb, hc, hd, he) =
ihNames (hx, hy, hz) ++ ihNames (ha, hb, hc, hd, he)
instance (StripHandle hw w, StripHandle hx x, StripHandle hy y, StripHandle hz z, StripHandle ha a, StripHandle hb b, StripHandle hc c, StripHandle hd d, StripHandle he e)
=> StripHandle (hw, hx, hy, hz, ha, hb, hc, hd, he) (w, x, y, z, a, b, c, d, e) where
validate (hw, hx, hy, hz, ha, hb, hc, hd, he) =
feither id (\ ((w, x, y, z), (a, b, c, d, e)) -> (w, x, y, z, a, b, c, d, e)) $
propagate
(validate (hw, hx, hy, hz)) (validate (ha, hb, hc, hd, he))
isBound (hw, hx, hy, hz, ha, hb, hc, hd, he) =
isBound (hw, hx, hy, hz) && isBound (ha, hb, hc, hd, he)
ihNames (hw, hx, hy, hz, ha, hb, hc, hd, he) =
ihNames (hw, hx, hy, hz) ++ ihNames (ha, hb, hc, hd, he)
instance (StripHandle hx x) => StripHandle [hx] [x] where
validate hxs =
foldr (\ hx xs -> feither id (uncurry (:)) $ propagate (validate hx) xs)
(Right []) hxs
isBound hxs =
all isBound hxs
ihNames hxs =
concatMap ihNames hxs
submit, defaultSubmit :: (CGIMonad cgi, StripHandle handle_a a)
=> handle_a
-> (a -> cgi ())
-> HTMLField cgi x y ()
submit = submitInternal False
defaultSubmit = submitInternal True
submit0 :: (CGIMonad cgi) => cgi () -> HTMLField cgi x y ()
submit0 cont = submit () (const cont)
submitInternal isDefault hinv g =
case validate hinv of
Right hval ->
internalSubmitField isDefault (Right (g hval))
Left ss ->
internalSubmitField isDefault (Left ss)
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, StripHandle handle_a a) =>
handle_a -> (a -> 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 [])
activate :: (CGIMonad cgi, StripHandle ha a) =>
(a -> cgi ()) -> HTMLField cgi x y ha -> HTMLField cgi x y ha
activate actionFun inputField attrs =
do invalid_inf <- inputField (do attrs
onChange $ "WASHSubmit(this.name);")
let rv = validate invalid_inf
when (isBound invalid_inf) $
activateInternal actionFun (head $ ihNames invalid_inf) rv
return invalid_inf