{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Happstack.Server.Dialogues.Scaffold where
import Happstack.Server
import Happstack.Server.Dialogues
import Language.Haskell.TH
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Char (ord)
import Data.Maybe (fromMaybe)
import Data.List
escapeHtml :: String -> String
escapeHtml "" = ""
escapeHtml ('\"':cs) = """ ++ escapeHtml cs
escapeHtml ('\'':cs) = "'" ++ escapeHtml cs
escapeHtml ('&' :cs) = "&" ++ escapeHtml cs
escapeHtml ('<' :cs) = "<" ++ escapeHtml cs
escapeHtml ('>' :cs) = ">" ++ escapeHtml cs
escapeHtml (c :cs) | ord c >= 160 = "&#" ++ show (ord c) ++ ";" ++ escapeHtml cs
| otherwise = c : escapeHtml cs
{-|
The 'scaffold' function builds a user interaction to display and collect information.
In a finished web application, this should generally be replaced with a better
mechanism for rendering pages, such as a templating engine, XSLT, or something
of the sort.
-}
scaffold :: (Scaffolded a, Monad m) => String -> a -> Dlg m a
scaffold s v = showPage out inp
where out uri = return $ setHeader "Content-type" "text/html" $ toResponse $
""
++ escapeHtml s ++ " "
++ ""
++ ""
inp = parse "dlg-vals" v
{-|
The 'Scaffolded' type class represents data that can be included in a form.
To make it easy to compose several of these in a page, rendering and parsing
are parameterized with prefix strings so that they may be made unique across
a page.
-}
class Scaffolded a where
render :: String -> a -> String
parse :: Monad m => String -> a -> ServerPartT m a
instance Scaffolded () where
render _ () = ""
parse _ _ = return ()
instance Scaffolded String where
render pfx s = ""
parse pfx _ = fmap (fromMaybe "") $ getDataFn (look pfx)
instance Scaffolded B.ByteString where
render pfx s = " "
parse pfx _ = do x <- getDataFn (lookInput pfx)
case x of Just inp -> return (inputValue inp)
Nothing -> return B.empty
instance Scaffolded Bool where
render pfx v = ""
parse pfx _ = fmap (maybe False (const True)) $ getDataFn (look pfx)
instance Scaffolded Int where
render pfx s = render pfx (show s)
parse pfx v = fmap read $ parse pfx undefined
instance (Scaffolded a, Scaffolded b) => Scaffolded (a, b) where
render pfx (x,y) = render (pfx ++ "_1") x ++ " "
++ render (pfx ++ "_2") y ++ " "
parse pfx (x,y) = do x <- parse (pfx ++ "_1") x
y <- parse (pfx ++ "_2") y
return (x,y)
instance (Scaffolded a, Scaffolded b, Scaffolded c)
=> Scaffolded (a, b, c) where
render pfx (x,y,z) = render (pfx ++ "_1") x ++ " "
++ render (pfx ++ "_2") y ++ " "
++ render (pfx ++ "_3") z ++ " "
parse pfx (x,y,z) = do x <- parse (pfx ++ "_1") x
y <- parse (pfx ++ "_2") y
z <- parse (pfx ++ "_3") z
return (x,y,z)
{-|
Wrapper type to present a list of options.
-}
data Choice a = Choice [a] Int deriving Show
toChoice :: (Bounded a, Enum a, Eq a) => a -> Choice a
toChoice x = let choices = [minBound .. maxBound]
in Choice choices (fromMaybe minBound $ elemIndex x choices)
fromChoice :: Choice a -> a
fromChoice (Choice cs i) = cs !! i
chooseFrom :: [a] -> Choice a
chooseFrom xs = Choice xs 0
instance (Eq a, Show a) => Scaffolded (Choice a) where
render pfx (Choice cs i) = concat
[ "" else ">"
++ " "
| (c,i') <- zip cs [0..] ]
parse pfx (Choice cs _) = fmap (Choice cs . read) $ parse pfx undefined
{-
deriveScaffolded :: [Name] -> Q [Dec]
deriveScaffolded = mapM $ \n -> return $
InstanceD [] (AppT (ConT (mkName "Scaffolded")) (ConT n)) []
-}