1 {-# OPTIONS -fcontext-stack=30 -fglasgow-exts -fth -fallow-undecidable-instances #-}
9 import HAppS.State.Transaction
10 import HAppS.Server.SimpleHTTP
13 import Language.Haskell.Parser
14 import Language.Haskell.Pretty
17 $( deriveAll [''Ord,''Eq,''Read,''Show,''Default]
19 newtype FormData = FormData String
22 -- plainEdit :: (Read a, Show a) => IO a -> (a -> IO ()) -> [ServerPart]
23 plainEdit :: ( UpdateEvent ue (),
25 QueryEvent qe a) => qe -> (a -> ue) -> [ServerPart]
27 plainEdit getter setter = [
28 method GET $ query getter >>= ok . toDataForm "." "POST" . pshow,
29 withData $ \(FormData fdat) -> [ method POST $ update (setter (read fdat)) >> redirect "." ]
33 -- Just a copy from HAppS/Data/Pairs.hs, with textfield instead of input
34 toDataForm action method fdat
36 Attr "xmlns" "http://www.w3.org/1999/xhtml" :
37 Attr "action" action :
38 Attr "method" method :
42 Attr "name" "formData"
47 Elem "input" [Attr "type" "submit"] :
53 pshow :: Show a => a -> String
54 pshow v = case parseModule ("value = "++s) of
55 ParseOk m -> tidy $ prettyPrint m
58 tidy x = case readPrec_to_S skipBoring 0 x of
59 [((), tail)] -> " " ++ tail
62 skipBoring :: ReadPrec ()
64 do { Ident "value" <- lexP; Punc "=" <- lexP; return () } <++
65 do { lexP; skipBoring }