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