5cbd240a168aaf7b6330bfa8ab9c5a0fb5d2a584
[darcs-mirror-latutman.git] / haskell / MyHAppS.hs
1 {-# OPTIONS -fcontext-stack=30 -fglasgow-exts -fth -fallow-undecidable-instances #-}
2 module MyHAppS (
3         plainEdit
4         ) where
5
6 import HAppS.Data
7 import HAppS.Server
8 import HAppS.State
9 import HAppS.State.Transaction
10 import HAppS.Server.SimpleHTTP
11
12
13 import Language.Haskell.Parser
14 import Language.Haskell.Pretty
15 import Text.Read
16
17 $( deriveAll [''Ord,''Eq,''Read,''Show,''Default] 
18    [d|
19      newtype FormData = FormData String 
20  |] )
21
22 -- plainEdit :: (Read a, Show a) => IO a -> (a -> IO ()) -> [ServerPart]
23 plainEdit :: (  UpdateEvent ue (),
24                 Read a, Show a,
25                 QueryEvent qe a) => qe -> (a -> ue) -> [ServerPart]
26
27 plainEdit getter setter = [
28         method GET $ query getter >>= ok . toDataForm "." "POST" . pshow,
29         withData $ \(FormData fdat) -> [ method POST $ update (setter (read fdat)) >> redirect "." ]
30         ]
31
32
33 -- Just a copy from HAppS/Data/Pairs.hs, with textfield instead of input
34 toDataForm action method fdat
35  = [ Elem "form" (
36                 Attr "xmlns" "http://www.w3.org/1999/xhtml" :
37                 Attr "action" action :
38                 Attr "method" method :
39                 Elem "div" [
40                          Attr "class" "formEl"
41                         ,Elem "textarea" [
42                                 Attr "name" "formData"
43                                 ,Attr "cols" "120"
44                                 ,Attr "rows" "20"
45                                 ,CData fdat
46                                 ]]:
47                 Elem "input" [Attr "type" "submit"] :
48                 [])]
49
50
51 -- From ipprint
52
53 pshow :: Show a => a -> String
54 pshow v =  case parseModule ("value = "++s) of
55               ParseOk         m -> tidy $ prettyPrint m
56               ParseFailed _ _   -> s
57     where s = show v
58           tidy x = case readPrec_to_S skipBoring 0 x of
59                      [((), tail)] -> "   " ++ tail
60                      _            -> s
61
62 skipBoring :: ReadPrec ()
63 skipBoring = 
64     do { Ident "value" <- lexP; Punc  "=" <- lexP; return () } <++ 
65     do { lexP; skipBoring }
66