module Text.Digestive.Heist
(
digestiveSplices
, bindDigestiveSplices
, dfInput
, dfInputList
, dfInputText
, dfInputTextArea
, dfInputPassword
, dfInputHidden
, dfInputSelect
, dfInputSelectGroup
, dfInputRadio
, dfInputCheckbox
, dfInputSubmit
, dfLabel
, dfForm
, dfErrorList
, dfChildErrorList
, dfSubView
, dfIfChildErrors
) where
import Control.Monad (liftM, mplus)
import Control.Monad.Trans
import Data.Function (on)
import Data.List (unionBy)
import Data.Maybe (fromMaybe)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
import Heist
import Heist.Interpreted
import qualified Text.XmlHtml as X
import Text.Digestive.Form.List
import Text.Digestive.View
bindDigestiveSplices :: MonadIO m => View Text -> HeistState m -> HeistState m
bindDigestiveSplices = bindSplices . digestiveSplices
digestiveSplices :: MonadIO m => View Text -> Splices (Splice m)
digestiveSplices view = do
"dfInput" ## dfInput view
"dfInputList" ## dfInputList view
"dfInputText" ## dfInputText view
"dfInputTextArea" ## dfInputTextArea view
"dfInputPassword" ## dfInputPassword view
"dfInputHidden" ## dfInputHidden view
"dfInputSelect" ## dfInputSelect view
"dfInputSelectGroup" ## dfInputSelectGroup view
"dfInputRadio" ## dfInputRadio view
"dfInputCheckbox" ## dfInputCheckbox view
"dfInputFile" ## dfInputFile view
"dfInputSubmit" ## dfInputSubmit view
"dfLabel" ## dfLabel view
"dfForm" ## dfForm view
"dfErrorList" ## dfErrorList view
"dfChildErrorList" ## dfChildErrorList view
"dfSubView" ## dfSubView view
"dfIfChildErrors" ## dfIfChildErrors view
attr :: Bool -> (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
attr False _ = id
attr True a = (a :)
makeElement :: Text -> [X.Node] -> [(Text, Text)] -> [X.Node]
makeElement name nodes = return . flip (X.Element name) nodes
getRefAttributes :: Monad m
=> Maybe Text
-> HeistT m m (Text, [(Text, Text)])
getRefAttributes defaultRef = do
node <- getParamNode
return $ case node of
X.Element _ as _ ->
let ref = fromMaybe (error $ show node ++ ": missing ref") $
lookup "ref" as `mplus` defaultRef
in (ref, filter ((/= "ref") . fst) as)
_ -> (error "Wrong type of node!", [])
getContent :: Monad m => HeistT m m [X.Node]
getContent = liftM X.childNodes getParamNode
addAttrs :: [(Text, Text)]
-> [(Text, Text)]
-> [(Text, Text)]
addAttrs = unionBy (on (==) fst)
setDisabled :: Text -> View v -> [(Text, Text)] -> [(Text, Text)]
setDisabled ref view = if viewDisabled ref view then (("disabled",""):) else id
dfInput :: Monad m => View v -> Splice m
dfInput view = do
(ref, attrs) <- getRefAttributes Nothing
let ref' = absoluteRef ref view
value = fieldInputText ref view
return $ makeElement "input" [] $ addAttrs attrs $ setDisabled ref view
[("id", ref'), ("name", ref'), ("value", value)]
dfInputText :: Monad m => View v -> Splice m
dfInputText view = do
(ref, attrs) <- getRefAttributes Nothing
let ref' = absoluteRef ref view
value = fieldInputText ref view
return $ makeElement "input" [] $ addAttrs attrs $ setDisabled ref view
[("type", "text"), ("id", ref'), ("name", ref'), ("value", value)]
dfInputTextArea :: Monad m => View v -> Splice m
dfInputTextArea view = do
(ref, attrs) <- getRefAttributes Nothing
let ref' = absoluteRef ref view
value = fieldInputText ref view
return $ makeElement "textarea" [X.TextNode value] $ addAttrs attrs $
setDisabled ref view [("id", ref'), ("name", ref')]
dfInputPassword :: Monad m => View v -> Splice m
dfInputPassword view = do
(ref, attrs) <- getRefAttributes Nothing
let ref' = absoluteRef ref view
value = fieldInputText ref view
return $ makeElement "input" [] $ addAttrs attrs $ setDisabled ref view
[("type", "password"), ("id", ref'), ("name", ref'), ("value", value)]
dfInputHidden :: Monad m => View v -> Splice m
dfInputHidden view = do
(ref, attrs) <- getRefAttributes Nothing
let ref' = absoluteRef ref view
value = fieldInputText ref view
return $ makeElement "input" [] $ addAttrs attrs $ setDisabled ref view
[("type", "hidden"), ("id", ref'), ("name", ref'), ("value", value)]
dfInputSelect :: Monad m => View Text -> Splice m
dfInputSelect view = do
(ref, attrs) <- getRefAttributes Nothing
let ref' = absoluteRef ref view
choices = fieldInputChoice ref view
kids = map makeOption choices
value i = ref' `mappend` "." `mappend` i
makeOption (i, c, sel) = X.Element "option"
(attr sel ("selected", "selected") [("value", value i)])
[X.TextNode c]
return $ makeElement "select" kids $ addAttrs attrs $ setDisabled ref view
[("id", ref'), ("name", ref')]
dfInputSelectGroup :: Monad m => View Text -> Splice m
dfInputSelectGroup view = do
(ref, attrs) <- getRefAttributes Nothing
let ref' = absoluteRef ref view
choices = fieldInputChoiceGroup ref view
kids = map makeGroup choices
value i = ref' `mappend` "." `mappend` i
makeGroup (name, options) = X.Element "optgroup"
[("label", name)] $ map makeOption options
makeOption (i, c, sel) = X.Element "option"
(attr sel ("selected", "selected") [("value", value i)])
[X.TextNode c]
return $ makeElement "select" kids $ addAttrs attrs $ setDisabled ref view
[("id", ref'), ("name", ref')]
dfInputRadio :: Monad m => View Text -> Splice m
dfInputRadio view = do
(ref, attrs) <- getRefAttributes Nothing
let ref' = absoluteRef ref view
choices = fieldInputChoice ref view
kids = concatMap makeOption choices
value i = ref' `mappend` "." `mappend` i
makeOption (i, c, sel) =
[ X.Element "label" [("for", value i)]
[ X.Element "input"
(attr sel ("checked", "checked") $ addAttrs attrs
[ ("type", "radio"), ("value", value i)
, ("id", value i), ("name", ref')
]) []
, X.TextNode c]
]
return kids
dfInputCheckbox :: Monad m => View Text -> Splice m
dfInputCheckbox view = do
(ref, attrs) <- getRefAttributes Nothing
let ref' = absoluteRef ref view
value = fieldInputBool ref view
return $ makeElement "input" [] $ addAttrs attrs $
attr value ("checked", "checked") $ setDisabled ref view
[("type", "checkbox"), ("id", ref'), ("name", ref')]
dfInputFile :: Monad m => View Text -> Splice m
dfInputFile view = do
(ref, attrs) <- getRefAttributes Nothing
let ref' = absoluteRef ref view
value = maybe "" T.pack $ fieldInputFile ref view
return $ makeElement "input" [] $ addAttrs attrs $ setDisabled ref view
[("type", "file"), ("id", ref'), ("name", ref'), ("value", value)]
dfInputSubmit :: Monad m => View v -> Splice m
dfInputSubmit _ = do
(_, attrs) <- getRefAttributes Nothing
return $ makeElement "input" [] $ addAttrs attrs [("type", "submit")]
dfLabel :: Monad m => View v -> Splice m
dfLabel view = do
(ref, attrs) <- getRefAttributes Nothing
content <- getContent
let ref' = absoluteRef ref view
return $ makeElement "label" content $ addAttrs attrs [("for", ref')]
dfForm :: Monad m => View v -> Splice m
dfForm view = do
(_, attrs) <- getRefAttributes Nothing
content <- getContent
return $ makeElement "form" content $ addAttrs attrs
[ ("method", "POST")
, ("enctype", T.pack (show $ viewEncType view))
]
errorList :: [Text] -> [(Text, Text)] -> [X.Node]
errorList [] _ = []
errorList errs attrs = [X.Element "ul" attrs $ map makeError errs]
where
makeError e = X.Element "li" [] [X.TextNode e]
dfErrorList :: Monad m => View Text -> Splice m
dfErrorList view = do
(ref, attrs) <- getRefAttributes Nothing
return $ errorList (errors ref view) attrs
dfChildErrorList :: Monad m => View Text -> Splice m
dfChildErrorList view = do
(ref, attrs) <- getRefAttributes $ Just ""
return $ errorList (childErrors ref view) attrs
dfSubView :: MonadIO m => View Text -> Splice m
dfSubView view = do
(ref, _) <- getRefAttributes Nothing
let view' = subView ref view
nodes <- localHS (bindDigestiveSplices view') runChildren
return nodes
disableOnclick :: Text -> View v -> [(Text, Text)] -> [(Text, Text)]
disableOnclick ref view =
if viewDisabled ref view then const [("disabled","")] else id
dfInputList :: MonadIO m => View Text -> Splice m
dfInputList view = do
(ref, _) <- getRefAttributes Nothing
let listRef = absoluteRef ref view
listAttrs =
[ ("id", listRef)
, ("class", "inputList")
]
addControl _ = return $ disableOnclick ref view
[ ("onclick", T.concat [ "addInputListItem(this, '"
, listRef
, "'); return false;"] ) ]
removeControl _ = return $ disableOnclick ref view
[ ("onclick", T.concat [ "removeInputListItem(this, '"
, listRef
, "'); return false;"] ) ]
itemAttrs v _ = return
[ ("id", T.concat [listRef, ".", last $ "0" : viewContext v])
, ("class", T.append listRef ".inputListItem")
]
templateAttrs v _ = return
[ ("id", T.concat [listRef, ".", last $ "-1" : viewContext v])
, ("class", T.append listRef ".inputListTemplate")
, ("style", "display: none;")
]
items = listSubViews ref view
f attrs v = localHS (bindAttributeSplices ("itemAttrs" ## attrs v) .
bindDigestiveSplices v) runChildren
dfListItem = do
template <- f templateAttrs (makeListSubView ref (1) view)
res <- mapSplices (f itemAttrs) items
return $ template ++ res
attrSplices = do
"addControl" ## addControl
"removeControl" ## removeControl
nodes <- localHS (bindSplices ("dfListItem" ## dfListItem) .
bindAttributeSplices attrSplices) runChildren
let indices = [X.Element "input"
[ ("type", "hidden")
, ("name", T.intercalate "." [listRef, indicesRef])
, ("value", T.intercalate "," $ map
(last . ("0":) . viewContext) items)
] []
]
return [X.Element "div" listAttrs (indices ++ nodes)]
dfIfChildErrors :: Monad m => View v -> Splice m
dfIfChildErrors view = do
(ref, _) <- getRefAttributes $ Just ""
if null (childErrors ref view)
then return []
else runChildren