module Text.Digestive.Heist.Compiled
(
formSplice
, dfInput
, dfInputList
, dfInputText
, dfInputTextArea
, dfInputPassword
, dfInputHidden
, dfInputSelect
, dfInputSelectGroup
, dfInputRadio
, dfInputCheckbox
, dfInputSubmit
, dfLabel
, dfErrorList
, dfChildErrorList
, dfSubView
, dfIfChildErrors
, digestiveSplices
) where
import Blaze.ByteString.Builder
import Control.Monad (mplus)
import Data.Function (on)
import Data.List (unionBy)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mempty)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import Heist
import Heist.Compiled
import qualified Text.XmlHtml as X
import Text.Digestive.Form.List
import Text.Digestive.View
digestiveSplices :: (Monad m) => Promise (View Text) -> [(Text, Splice m)]
digestiveSplices vp =
[ ("dfInput", dfInput vp)
, ("dfInputText", dfInputText vp)
, ("dfInputTextArea", dfInputTextArea vp)
, ("dfInputPassword", dfInputPassword vp)
, ("dfInputHidden", dfInputHidden vp)
, ("dfInputSelect", dfInputSelect vp)
, ("dfInputSelectGroup", dfInputSelectGroup vp)
, ("dfInputRadio", dfInputRadio vp)
, ("dfInputCheckbox", dfInputCheckbox vp)
, ("dfInputFile", dfInputFile vp)
, ("dfInputSubmit", dfInputSubmit)
, ("dfLabel", dfLabel vp)
, ("dfErrorList", dfErrorList vp)
, ("dfChildErrorList", dfChildErrorList vp)
, ("dfSubView", dfSubView vp)
, ("dfIfChildErrors", dfIfChildErrors vp)
, ("dfInputList", dfInputList vp)
, ("dfEncType", dfEncType vp)
]
formSplice :: Monad m
=> [(Text, Splice m)]
-> [(Text, AttrSplice m)]
-> RuntimeSplice m (View Text)
-> Splice m
formSplice ss as getView = do
node <- getParamNode
let (_, attrs) = getRefAttributes node Nothing
tree = X.Element "form"
(addAttrs attrs
[ ("method", "POST")
, ("enctype", "${dfEncType}")
])
(X.childNodes node)
action = runNode tree
defer (\vp -> withLocalSplices (digestiveSplices vp ++ ss) as action)
getView
attr :: Bool -> (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
attr False _ = id
attr True a = (a :)
getRefAttributes :: X.Node
-> Maybe Text
-> (Text, [(Text, Text)])
getRefAttributes node defaultRef =
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!", [])
dfEncType :: (Monad m)
=> Promise (View v)
-> Splice m
dfEncType p = do
return $ yieldRuntime $ do
view <- getPromise p
return $ fromByteString $ encodeUtf8 $ T.pack (show $ viewEncType view)
dfMaster :: Monad m
=> (Text -> [(Text, Text)] -> View v -> RuntimeSplice m Builder)
-> Promise (View v) -> Splice m
dfMaster f p = do
node <- getParamNode
let (ref, attrs) = getRefAttributes node Nothing
runAttrs <- runAttributesRaw attrs
return $ yieldRuntime $ do
view <- getPromise p
attrs' <- runAttrs
f ref attrs' view
dfTag :: (Monad m)
=> (Text -> [(Text, Text)] -> Text -> [X.Node])
-> Promise (View v)
-> Splice m
dfTag f = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
!value = fieldInputText ref view
return $ X.renderHtmlFragment X.UTF8 $ f ref' attrs value
dfInputGeneric :: Monad m
=> [(Text, Text)]
-> Promise (View v)
-> Splice m
dfInputGeneric as = dfTag $ \ref attrs value ->
makeElement "input" [] $ addAttrs attrs $
as ++ [("id", ref), ("name", ref), ("value", value)]
dfInputSubmit :: Monad m => Splice m
dfInputSubmit = do
node <- getParamNode
let (_, attrs) = getRefAttributes node Nothing
runAttrs <- runAttributesRaw attrs
return $ yieldRuntime $ do
attrs' <- runAttrs
let e = makeElement "input" [] $ addAttrs attrs'
[("type", "submit")]
return $ X.renderHtmlFragment X.UTF8 e
dfLabel :: Monad m => Promise (View v) -> Splice m
dfLabel p = do
node <- getParamNode
let (ref, attrs) = getRefAttributes node Nothing
runAttrs <- runAttributesRaw attrs
return $ yieldRuntime $ do
view <- getPromise p
attrs' <- runAttrs
let ref' = absoluteRef ref view
e = makeElement "label" (X.childNodes node) $ addAttrs attrs'
[("for", ref')]
return $ X.renderHtmlFragment X.UTF8 e
dfInput :: Monad m => Promise (View v) -> Splice m
dfInput = dfInputGeneric []
dfInputText :: Monad m => Promise (View v) -> Splice m
dfInputText = dfInputGeneric [("type", "text")]
dfInputTextArea :: Monad m => Promise (View v) -> Splice m
dfInputTextArea = dfTag $ \ref attrs value ->
makeElement "textarea" [X.TextNode value] $ addAttrs attrs
[("id", ref), ("name", ref)]
dfInputPassword :: Monad m => Promise (View v) -> Splice m
dfInputPassword = dfInputGeneric [("type", "password")]
dfInputHidden :: Monad m => Promise (View v) -> Splice m
dfInputHidden = dfInputGeneric [("type", "hidden")]
dfInputCheckbox :: Monad m
=> Promise (View v)
-> Splice m
dfInputCheckbox = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
value = fieldInputBool ref view
e = makeElement "input" [] $ addAttrs attrs $
attr value ("checked", "checked") $
[("type", "checkbox"), ("id", ref'), ("name", ref')]
return $ X.renderHtmlFragment X.UTF8 e
dfInputFile :: Monad m => Promise (View v) -> Splice m
dfInputFile = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
value = maybe "" T.pack $ fieldInputFile ref view
e = makeElement "input" [] $ addAttrs attrs $
[ ("type", "file"), ("id", ref')
, ("name", ref'), ("value", value)]
return $ X.renderHtmlFragment X.UTF8 e
dfInputSelect :: Monad m => Promise (View Text) -> Splice m
dfInputSelect = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
choices = fieldInputChoice ref view
kids = map makeOption choices
value i = ref' <> "." <> i
makeOption (i, c, sel) = X.Element "option"
(attr sel ("selected", "selected") [("value", value i)])
[X.TextNode c]
e = makeElement "select" kids $ addAttrs attrs
[("id", ref'), ("name", ref')]
return $ X.renderHtmlFragment X.UTF8 e
dfInputSelectGroup :: Monad m => Promise (View Text) -> Splice m
dfInputSelectGroup = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
choices = fieldInputChoiceGroup ref view
kids = map makeGroup choices
value i = ref' <> "." <> 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]
e = makeElement "select" kids $ addAttrs attrs
[("id", ref'), ("name", ref')]
return $ X.renderHtmlFragment X.UTF8 e
dfInputRadio :: Monad m => Promise (View Text) -> Splice m
dfInputRadio = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
choices = fieldInputChoice ref view
kids = concatMap makeOption choices
value i = ref' <> "." <> i
makeOption (i, c, sel) =
[ X.Element "input"
(attr sel ("checked", "checked") $ addAttrs attrs
[ ("type", "radio"), ("value", value i)
, ("id", value i), ("name", ref')
]) []
, X.Element "label" [("for", value i)] [X.TextNode c]
]
return $ X.renderHtmlFragment X.UTF8 kids
dfErrorList :: Monad m => Promise (View Text) -> Splice m
dfErrorList p = do
node <- getParamNode
return $ yieldRuntime $ do
view <- getPromise p
let (ref, attrs) = getRefAttributes node Nothing
nodes = errorList (errors ref view) attrs
return $ X.renderHtmlFragment X.UTF8 nodes
dfChildErrorList :: Monad m => Promise (View Text) -> Splice m
dfChildErrorList p = do
node <- getParamNode
return $ yieldRuntime $ do
view <- getPromise p
let (ref, attrs) = getRefAttributes node (Just "")
nodes = errorList (childErrors ref view) attrs
return $ X.renderHtmlFragment X.UTF8 nodes
dfIfChildErrors :: (Monad m) => Promise (View v) -> Splice m
dfIfChildErrors p = do
node <- getParamNode
return $ yieldRuntime $ do
view <- getPromise p
let (ref, _) = getRefAttributes node Nothing
if null (childErrors ref view)
then return mempty
else return $ X.renderHtmlFragment X.UTF8 (X.childNodes node)
dfSubView :: Monad m => Promise (View Text) -> Splice m
dfSubView p = do
node <- getParamNode
p2 <- newEmptyPromise
let action = yieldRuntimeEffect $ do
view <- getPromise p
let (ref, _) = getRefAttributes node Nothing
view' = subView ref view
putPromise p2 view'
res <- withLocalSplices (digestiveSplices p2) [] $
runNodeList $ X.childNodes node
return $ action <> res
dfSingleListItem :: Monad m
=> X.Node
-> (Promise (View Text) -> AttrSplice m)
-> Promise (View Text)
-> HeistT m IO (RuntimeSplice m Builder)
dfSingleListItem node attrs viewPromise = do
p2 <- newEmptyPromise
let action = yieldRuntimeEffect $ do
view <- getPromise viewPromise
putPromise p2 view
res <- withLocalSplices (digestiveSplices p2)
[("itemAttrs", attrs viewPromise)]
(runNodeList $ X.childNodes node)
return $ codeGen $ action <> res
dfInputList :: Monad m => Promise (View Text) -> Splice m
dfInputList p = do
node <- getParamNode
itemsPromise <- newEmptyPromise
refPromise <- newEmptyPromise
indicesPromise <- newEmptyPromise
templateViewPromise <- newEmptyPromise
let itemAttrs viewPromise _ = do
view <- getPromise viewPromise
listRef <- getPromise refPromise
return
[ ("id", T.concat [listRef, ".", last $ "0" : viewContext view])
, ("class", T.append listRef ".inputListItem")
]
templateAttrs viewPromise _ = do
view <- getPromise viewPromise
listRef <- getPromise refPromise
return
[ ("id", T.concat [listRef, ".", last $ "-1" : viewContext view])
, ("class", T.append listRef ".inputListTemplate")
, ("style", "display: none;")
]
dfListItem = do
n <- getParamNode
template <- dfSingleListItem n templateAttrs
templateViewPromise
body <- mapPromises (dfSingleListItem n itemAttrs) $
getPromise itemsPromise
return $ yieldRuntime template <> body
let listAttrs =
[ ("id", "${dfListRef}")
, ("class", "inputList")
]
indices = X.Element "input"
[ ("type", "hidden")
, ("name", T.intercalate "." ["${dfListRef}", indicesRef])
, ("value", "${dfIndicesList}")
] []
e = X.Element "div" listAttrs (indices : X.childNodes node)
let addControl _ = do
listRef <- getPromise refPromise
return [ ("onclick", T.concat [ "addInputListItem(this, '"
, listRef
, "'); return false;"] ) ]
removeControl _ = do
listRef <- getPromise refPromise
return [ ("onclick", T.concat [ "removeInputListItem(this, '"
, listRef
, "'); return false;"] ) ]
attrSplices = [ ("addControl", addControl)
, ("removeControl", removeControl)
]
splices = [ ("dfListRef", return $ yieldRuntimeText $ getPromise refPromise)
, ("dfIndicesList", return $ yieldRuntimeText $ getPromise indicesPromise)
, ("dfListItem", dfListItem)
]
let action = yieldRuntimeEffect $ do
view <- getPromise p
let (ref, _) = getRefAttributes node Nothing
listRef = absoluteRef ref view
items = listSubViews ref view
tview = makeListSubView ref (1) view
putPromise refPromise listRef
putPromise indicesPromise $ T.intercalate "," $
map (last . ("0":) . viewContext) items
putPromise itemsPromise items
putPromise templateViewPromise tview
res <- withLocalSplices splices attrSplices $ runNode e
return $ action <> res
makeElement :: Text -> [X.Node] -> [(Text, Text)] -> [X.Node]
makeElement name nodes = return . flip (X.Element name) nodes
addAttrs :: [(Text, Text)]
-> [(Text, Text)]
-> [(Text, Text)]
addAttrs = unionBy (on (==) fst)
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]