Browse files

Proper compiled rendering of XML templates (closes issue #34)

  • Loading branch information...
1 parent 3a0150b commit 78b0343200abc405727befaa25f563ba19eca6a6 @mightybyte mightybyte committed Apr 2, 2013
Showing with 36 additions and 15 deletions.
  1. +2 −2 src/Heist.hs
  2. +2 −2 src/Heist/Compiled.hs
  3. +21 −9 src/Heist/Compiled/Internal.hs
  4. +9 −0 src/Heist/Types.hs
  5. +2 −2 test/suite/Heist/Interpreted/Tests.hs
View
4 src/Heist.hs
@@ -205,8 +205,8 @@ addTemplatePathPrefix dir ts
------------------------------------------------------------------------------
-- | Creates an empty HeistState.
emptyHS :: HE.KeyGen -> HeistState m
-emptyHS kg = HeistState Map.empty Map.empty Map.empty Map.empty
- Map.empty True [] 0 [] Nothing kg False
+emptyHS kg = HeistState Map.empty Map.empty Map.empty Map.empty Map.empty
+ True [] 0 [] Nothing kg False Html
------------------------------------------------------------------------------
View
4 src/Heist/Compiled.hs
@@ -26,10 +26,10 @@ module Heist.Compiled
, prefixSplices
, namespaceSplices
, textSplices
- , nodeSplices
+ , htmlSplices
, pureSplices
, textSplice
- , nodeSplice
+ , htmlSplice
, pureSplice
, repromise
, repromiseMay
View
30 src/Heist/Compiled/Internal.hs
@@ -137,8 +137,16 @@ promiseChildrenWithNodes :: (Monad n)
=> [(Text, a -> [X.Node])]
-> Promise a
-> HeistT n IO (RuntimeSplice n Builder)
-promiseChildrenWithNodes =
- promiseChildrenWithTrans (X.renderHtmlFragment X.UTF8)
+promiseChildrenWithNodes ss p = do
+ markup <- getsHS _curMarkup
+ promiseChildrenWithTrans (renderFragment markup) ss p
+
+
+renderFragment :: Markup -> [X.Node] -> Builder
+renderFragment markup ns =
+ case markup of
+ Html -> X.renderHtmlFragment X.UTF8 ns
+ Xml -> X.renderXmlFragment X.UTF8 ns
------------------------------------------------------------------------------
@@ -227,7 +235,11 @@ compileTemplate :: Monad n
-> DocumentFile
-> IO [Chunk n]
compileTemplate hs tpath df = do
- !chunks <- runSplice nullNode hs $! runDocumentFile tpath df
+ let markup = case dfDoc df of
+ X.XmlDocument _ _ _ -> Xml
+ X.HtmlDocument _ _ _ -> Html
+ hs' = hs { _curMarkup = markup }
+ !chunks <- runSplice nullNode hs' $! runDocumentFile tpath df
return chunks
where
-- This gets overwritten in runDocumentFile
@@ -323,9 +335,9 @@ lookupSplice nm = getsHS (H.lookup nm . _compiledSpliceMap)
runNode :: Monad n => X.Node -> Splice n
runNode node = localParamNode (const node) $ do
isStatic <- subtreeIsStatic node
+ markup <- getsHS _curMarkup
if isStatic
- then return $! yieldPure $!
- X.renderHtmlFragment X.UTF8 [parseAttrs node]
+ then return $! yieldPure $! renderFragment markup [parseAttrs node]
else compileNode node
@@ -693,14 +705,14 @@ textSplice f = fromText . f
------------------------------------------------------------------------------
-- | Converts pure Node splices to pure Builder splices.
-nodeSplices :: [(Text, a -> [X.Node])] -> [(Text, a -> Builder)]
-nodeSplices = mapSnd nodeSplice
+htmlSplices :: [(Text, a -> [X.Node])] -> [(Text, a -> Builder)]
+htmlSplices = mapSnd htmlSplice
------------------------------------------------------------------------------
-- | Converts a pure Node splice function to a pure Builder splice function.
-nodeSplice :: (a -> [X.Node]) -> a -> Builder
-nodeSplice f = X.renderHtmlFragment X.UTF8 . f
+htmlSplice :: (a -> [X.Node]) -> a -> Builder
+htmlSplice f = X.renderHtmlFragment X.UTF8 . f
------------------------------------------------------------------------------
View
9 src/Heist/Types.hs
@@ -72,6 +72,11 @@ data DocumentFile = DocumentFile
------------------------------------------------------------------------------
+-- | Designates whether a document should be treated as XML or HTML.
+data Markup = Xml | Html
+
+
+------------------------------------------------------------------------------
-- | Monad used for runtime splice execution.
newtype RuntimeSplice m a = RuntimeSplice {
unRT :: StateT HeterogeneousEnvironment m a
@@ -166,6 +171,10 @@ data HeistState m = HeistState {
-- preprocessing, errors should stop execution and be reported. During
-- template rendering, it's better to skip the errors and render the page.
, _preprocessingMode :: Bool
+
+ -- | This is needed because compiled templates are generated with a bunch
+ -- of calls to renderFragment rather than a single call to render.
+ , _curMarkup :: Markup
}
View
4 test/suite/Heist/Interpreted/Tests.hs
@@ -138,7 +138,7 @@ loadTest = do
ets <- loadIO "templates" [] [] [] []
either (error "Error loading templates")
(\ts -> do let tm = _templateMap ts
- H.assertEqual "loadTest size" 36 $ Map.size tm
+ H.assertEqual "loadTest size" 37 $ Map.size tm
) ets
@@ -376,7 +376,7 @@ lookupTemplateTest = do
------------------------------------------------------------------------------
xmlNotHtmlTest :: H.Assertion
xmlNotHtmlTest = renderTest "rss" expected where
- expected = "<rss><channel><link>http://www.devalot.com/</link></channel></rss>"
+ expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><rss><channel><link>http://www.devalot.com/</link></channel></rss>"
------------------------------------------------------------------------------
identStartChar :: [Char]

0 comments on commit 78b0343

Please sign in to comment.