diff --git a/digestive-functors-heist.cabal b/digestive-functors-heist.cabal
--- a/digestive-functors-heist.cabal
+++ b/digestive-functors-heist.cabal
@@ -1,5 +1,5 @@
Name: digestive-functors-heist
-Version: 0.7.0.0
+Version: 0.8.0.0
Synopsis: Heist frontend for the digestive-functors library
Description: Heist frontend for the digestive-functors library
Homepage: http://github.com/jaspervdj/digestive-functors
@@ -22,7 +22,7 @@
base >= 4 && < 5,
blaze-builder >= 0.3 && < 0.4,
digestive-functors >= 0.6.1 && < 0.7,
- heist >= 0.11.1 && < 0.13,
+ heist >= 0.13 && < 0.14,
mtl >= 2 && < 2.2,
text >= 0.11 && < 0.12,
xmlhtml >= 0.1 && < 0.3
diff --git a/src/Text/Digestive/Heist.hs b/src/Text/Digestive/Heist.hs
--- a/src/Text/Digestive/Heist.hs
+++ b/src/Text/Digestive/Heist.hs
@@ -76,27 +76,27 @@
--------------------------------------------------------------------------------
-digestiveSplices :: MonadIO m => View Text -> [(Text, Splice m)]
-digestiveSplices view =
- [ ("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)
- ]
+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
+
--------------------------------------------------------------------------------
@@ -469,16 +469,16 @@
, ("style", "display: none;")
]
items = listSubViews ref view
- f attrs v = localHS (bindAttributeSplices [("itemAttrs", attrs v)] .
+ 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 = [ ("addControl", addControl)
- , ("removeControl", removeControl)
- ]
- nodes <- localHS (bindSplices [("dfListItem", dfListItem)] .
+ attrSplices = do
+ "addControl" ## addControl
+ "removeControl" ## removeControl
+ nodes <- localHS (bindSplices ("dfListItem" ## dfListItem) .
bindAttributeSplices attrSplices) runChildren
let indices = [X.Element "input"
[ ("type", "hidden")
diff --git a/src/Text/Digestive/Heist/Compiled.hs b/src/Text/Digestive/Heist/Compiled.hs
--- a/src/Text/Digestive/Heist/Compiled.hs
+++ b/src/Text/Digestive/Heist/Compiled.hs
@@ -59,12 +59,13 @@
import Data.Function (on)
import Data.List (unionBy)
import Data.Maybe (fromMaybe)
-import Data.Monoid ((<>), mempty)
+import Data.Monoid ((<>), mempty, mappend)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import Heist
import Heist.Compiled
+import Heist.Compiled.LowLevel
import qualified Text.XmlHtml as X
@@ -77,27 +78,28 @@
-- | List of splices defined for forms. For most uses the formSplice function
-- will be fine and you won't need to use this directly. But this is
-- available if you need more customization.
-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)
- ]
+digestiveSplices :: (Monad m)
+ => RuntimeSplice m (View Text)
+ -> Splices (Splice m)
+digestiveSplices vp = do
+ "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
------------------------------------------------------------------------------
@@ -105,13 +107,13 @@
-- gets the form's view and this function returns a splice that creates a form
-- tag. In your HeistConfig you might have a compiled splice like this:
--
--- `("customerForm", formSplice (liftM fst $ runForm "customer" custForm))`
+-- > ("customerForm" ## formSplice (liftM fst $ runForm "customer" custForm))
--
-- Then you can use the customerForm tag just like you would use the dfForm
-- tag in interpreted templates anywhere you want to have a customer form.
formSplice :: Monad m
- => [(Text, Splice m)]
- -> [(Text, AttrSplice m)]
+ => Splices (Splice m)
+ -> Splices (AttrSplice m)
-> RuntimeSplice m (View Text)
-> Splice m
formSplice ss as getView = do
@@ -124,8 +126,7 @@
])
(X.childNodes node)
action = runNode tree
- defer (\vp -> withLocalSplices (digestiveSplices vp ++ ss) as action)
- getView
+ withLocalSplices (digestiveSplices getView `mappend` ss) as action
--------------------------------------------------------------------------------
@@ -148,30 +149,30 @@
dfEncType :: (Monad m)
- => Promise (View v)
+ => RuntimeSplice m (View v)
-> Splice m
-dfEncType p = do
+dfEncType getView = do
return $ yieldRuntime $ do
- view <- getPromise p
+ view <- getView
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
+ -> RuntimeSplice m (View v) -> Splice m
+dfMaster f getView = do
node <- getParamNode
let (ref, attrs) = getRefAttributes node Nothing
runAttrs <- runAttributesRaw attrs
return $ yieldRuntime $ do
- view <- getPromise p
+ view <- getView
attrs' <- runAttrs
f ref attrs' view
dfTag :: (Monad m)
=> (Text -> [(Text, Text)] -> Text -> [X.Node])
- -> Promise (View v)
+ -> RuntimeSplice m (View v)
-> Splice m
dfTag f = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
@@ -183,7 +184,7 @@
dfInputGeneric :: Monad m
=> [(Text, Text)]
- -> Promise (View v)
+ -> RuntimeSplice m (View v)
-> Splice m
dfInputGeneric as = dfTag $ \ref attrs value ->
makeElement "input" [] $ addAttrs attrs $
@@ -211,13 +212,13 @@
--
-- > Married:
-- >
-dfLabel :: Monad m => Promise (View v) -> Splice m
-dfLabel p = do
+dfLabel :: Monad m => RuntimeSplice m (View v) -> Splice m
+dfLabel getView = do
node <- getParamNode
let (ref, attrs) = getRefAttributes node Nothing
runAttrs <- runAttributesRaw attrs
return $ yieldRuntime $ do
- view <- getPromise p
+ view <- getView
attrs' <- runAttrs
let ref' = absoluteRef ref view
e = makeElement "label" (X.childNodes node) $ addAttrs attrs'
@@ -229,7 +230,7 @@
-- | Generate an input field with a supplied type. Example:
--
-- >
-dfInput :: Monad m => Promise (View v) -> Splice m
+dfInput :: Monad m => RuntimeSplice m (View v) -> Splice m
dfInput = dfInputGeneric []
@@ -237,7 +238,7 @@
-- | Generate a text input field. Example:
--
-- >
-dfInputText :: Monad m => Promise (View v) -> Splice m
+dfInputText :: Monad m => RuntimeSplice m (View v) -> Splice m
dfInputText = dfInputGeneric [("type", "text")]
@@ -245,7 +246,7 @@
-- | Generate a text area. Example:
--
-- >
-dfInputTextArea :: Monad m => Promise (View v) -> Splice m
+dfInputTextArea :: Monad m => RuntimeSplice m (View v) -> Splice m
dfInputTextArea = dfTag $ \ref attrs value ->
makeElement "textarea" [X.TextNode value] $ addAttrs attrs
[("id", ref), ("name", ref)]
@@ -255,7 +256,7 @@
-- | Generate a password field. Example:
--
-- >
-dfInputPassword :: Monad m => Promise (View v) -> Splice m
+dfInputPassword :: Monad m => RuntimeSplice m (View v) -> Splice m
dfInputPassword = dfInputGeneric [("type", "password")]
@@ -263,7 +264,7 @@
-- | Generate a hidden input field. Example:
--
-- >
-dfInputHidden :: Monad m => Promise (View v) -> Splice m
+dfInputHidden :: Monad m => RuntimeSplice m (View v) -> Splice m
dfInputHidden = dfInputGeneric [("type", "hidden")]
@@ -272,7 +273,7 @@
--
-- >
dfInputCheckbox :: Monad m
- => Promise (View v)
+ => RuntimeSplice m (View v)
-> Splice m
dfInputCheckbox = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
@@ -288,7 +289,7 @@
-- | Generate a file upload element. Example:
--
-- >
-dfInputFile :: Monad m => Promise (View v) -> Splice m
+dfInputFile :: Monad m => RuntimeSplice m (View v) -> Splice m
dfInputFile = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
value = maybe "" T.pack $ fieldInputFile ref view
@@ -302,7 +303,7 @@
-- | Generate a select button (also known as a combo box). Example:
--
-- >
-dfInputSelect :: Monad m => Promise (View Text) -> Splice m
+dfInputSelect :: Monad m => RuntimeSplice m (View Text) -> Splice m
dfInputSelect = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
choices = fieldInputChoice ref view
@@ -322,7 +323,7 @@
-- | Generate a select button (also known as a combo box). Example:
--
-- >
-dfInputSelectGroup :: Monad m => Promise (View Text) -> Splice m
+dfInputSelectGroup :: Monad m => RuntimeSplice m (View Text) -> Splice m
dfInputSelectGroup = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
choices = fieldInputChoiceGroup ref view
@@ -344,7 +345,7 @@
-- | Generate a number of radio buttons. Example:
--
-- >
-dfInputRadio :: Monad m => Promise (View Text) -> Splice m
+dfInputRadio :: Monad m => RuntimeSplice m (View Text) -> Splice m
dfInputRadio = dfMaster $ \ref attrs view -> do
let ref' = absoluteRef ref view
choices = fieldInputChoice ref view
@@ -368,11 +369,11 @@
--
-- >
-- >
-dfErrorList :: Monad m => Promise (View Text) -> Splice m
-dfErrorList p = do
+dfErrorList :: Monad m => RuntimeSplice m (View Text) -> Splice m
+dfErrorList getView = do
node <- getParamNode
return $ yieldRuntime $ do
- view <- getPromise p
+ view <- getView
let (ref, attrs) = getRefAttributes node Nothing
nodes = errorList (errors ref view) attrs
return $ X.renderHtmlFragment X.UTF8 nodes
@@ -391,11 +392,11 @@
-- Which is more conveniently written as:
--
-- >
-dfChildErrorList :: Monad m => Promise (View Text) -> Splice m
-dfChildErrorList p = do
+dfChildErrorList :: Monad m => RuntimeSplice m (View Text) -> Splice m
+dfChildErrorList getView = do
node <- getParamNode
return $ yieldRuntime $ do
- view <- getPromise p
+ view <- getView
let (ref, attrs) = getRefAttributes node (Just "")
nodes = errorList (childErrors ref view) attrs
return $ X.renderHtmlFragment X.UTF8 nodes
@@ -410,11 +411,11 @@
-- >
--
-- The @ref@ attribute can be omitted if you want to check the entire form.
-dfIfChildErrors :: (Monad m) => Promise (View v) -> Splice m
-dfIfChildErrors p = do
+dfIfChildErrors :: (Monad m) => RuntimeSplice m (View v) -> Splice m
+dfIfChildErrors getView = do
node <- getParamNode
return $ yieldRuntime $ do
- view <- getPromise p
+ view <- getView
let (ref, _) = getRefAttributes node Nothing
if null (childErrors ref view)
then return mempty
@@ -445,34 +446,34 @@
-- >
-- >
-- >
-dfSubView :: Monad m => Promise (View Text) -> Splice m
-dfSubView p = do
+dfSubView :: Monad m => RuntimeSplice m (View Text) -> Splice m
+dfSubView getView = do
node <- getParamNode
p2 <- newEmptyPromise
let action = yieldRuntimeEffect $ do
- view <- getPromise p
+ view <- getView
let (ref, _) = getRefAttributes node Nothing
view' = subView ref view
putPromise p2 view'
- res <- withLocalSplices (digestiveSplices p2) [] $
+ res <- withLocalSplices (digestiveSplices (getPromise p2)) noSplices $
runNodeList $ X.childNodes node
return $ action <> res
-dfSingleListItem :: Monad m
+dfSingleListItem :: Monad n
=> X.Node
- -> (Promise (View Text) -> AttrSplice m)
- -> Promise (View Text)
- -> HeistT m IO (RuntimeSplice m Builder)
+ -> (RuntimeSplice n (View Text) -> AttrSplice n)
+ -> RuntimeSplice n (View Text)
+ -> Splice n
dfSingleListItem node attrs viewPromise = do
p2 <- newEmptyPromise
let action = yieldRuntimeEffect $ do
- view <- getPromise viewPromise
+ view <- viewPromise
putPromise p2 view
- res <- withLocalSplices (digestiveSplices p2)
- [("itemAttrs", attrs viewPromise)]
+ res <- withLocalSplices (digestiveSplices (getPromise p2))
+ ("itemAttrs" ## attrs viewPromise)
(runNodeList $ X.childNodes node)
- return $ codeGen $ action <> res
+ return $ action <> res
--------------------------------------------------------------------------------
@@ -496,22 +497,22 @@
-- an onclick attribute that calls a javascript function addInputListItem.
-- removeControl - Use this attribute on the control for removing individual
-- items. It adds an onclick attribute that calls removeInputListItem.
-dfInputList :: Monad m => Promise (View Text) -> Splice m
-dfInputList p = do
+dfInputList :: Monad m => RuntimeSplice m (View Text) -> Splice m
+dfInputList getView = do
node <- getParamNode
itemsPromise <- newEmptyPromise
refPromise <- newEmptyPromise
indicesPromise <- newEmptyPromise
templateViewPromise <- newEmptyPromise
- let itemAttrs viewPromise _ = do
- view <- getPromise viewPromise
+ let itemAttrs gv _ = do
+ view <- gv
listRef <- getPromise refPromise
return
[ ("id", T.concat [listRef, ".", last $ "0" : viewContext view])
, ("class", T.append listRef ".inputListItem")
]
- templateAttrs viewPromise _ = do
- view <- getPromise viewPromise
+ templateAttrs gv _ = do
+ view <- gv
listRef <- getPromise refPromise
return
[ ("id", T.concat [listRef, ".", last $ "-1" : viewContext view])
@@ -520,11 +521,10 @@
]
dfListItem = do
n <- getParamNode
- template <- dfSingleListItem n templateAttrs
- templateViewPromise
- body <- mapPromises (dfSingleListItem n itemAttrs) $
- getPromise itemsPromise
- return $ yieldRuntime template <> body
+ template <- dfSingleListItem n templateAttrs (getPromise templateViewPromise)
+ body <- deferMany (dfSingleListItem n itemAttrs) $
+ getPromise itemsPromise
+ return $ template <> body
let listAttrs =
[ ("id", "${dfListRef}")
, ("class", "inputList")
@@ -545,17 +545,17 @@
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)
- ]
+ attrSplices = do
+ "addControl" ## addControl
+ "removeControl" ## removeControl
+ splices = do
+ "dfListRef" ## return $ yieldRuntimeText $ getPromise refPromise
+ "dfIndicesList" ## return $ yieldRuntimeText $ getPromise indicesPromise
+ "dfListItem" ## dfListItem
-- The runtime action that gets the right data and puts it in promises.
let action = yieldRuntimeEffect $ do
- view <- getPromise p
+ view <- getView
let (ref, _) = getRefAttributes node Nothing
listRef = absoluteRef ref view
items = listSubViews ref view