diff --git a/heist.cabal b/heist.cabal --- a/heist.cabal +++ b/heist.cabal @@ -1,5 +1,5 @@ name: heist -version: 0.11.1 +version: 0.12.0 synopsis: An Haskell template system supporting both HTML5 and XML. description: Heist is a powerful template system that supports both HTML5 and XML. @@ -155,6 +155,7 @@ random >= 1.0.1.0 && < 1.1, text >= 0.10 && < 0.12, time >= 1.1 && < 1.5, + transformers >= 0.3 && < 0.4, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.9 && < 0.11, xmlhtml >= 0.2.1 && < 0.3 diff --git a/src/Heist.hs b/src/Heist.hs --- a/src/Heist.hs +++ b/src/Heist.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-| @@ -17,6 +18,7 @@ ( -- * Primary Heist initialization functions loadTemplates + , reloadTemplates , addTemplatePathPrefix , initHeist , initHeistWithCacheTag @@ -24,9 +26,11 @@ , defaultLoadTimeSplices -- * Core Heist data types + , HeistConfig(..) + , TemplateRepo + , TemplateLocation , Template , TPath - , HeistConfig(..) , MIMEType , DocumentFile(..) , AttrSplice @@ -79,29 +83,38 @@ type TemplateRepo = HashMap TPath DocumentFile + +------------------------------------------------------------------------------ +-- | An IO action for getting a template repo from this location. By not just +-- using a directory path here, we support templates loaded from a database, +-- retrieved from the network, or anything else you can think of. +type TemplateLocation = EitherT [String] IO TemplateRepo + + data HeistConfig m = HeistConfig { hcInterpretedSplices :: [(Text, I.Splice m)] - -- ^ Interpreted splices are the splices that Heist has always had. They - -- return a list of nodes and are processed at runtime. + -- ^ Interpreted splices are the splices that Heist has always had. They + -- return a list of nodes and are processed at runtime. , hcLoadTimeSplices :: [(Text, I.Splice IO)] - -- ^ Load time splices are like interpreted splices because they return a - -- list of nodes. But they are like compiled splices because they are - -- processed once at load time. All of Heist's built-in splices should be - -- used as load time splices. + -- ^ Load time splices are like interpreted splices because they return a + -- list of nodes. But they are like compiled splices because they are + -- processed once at load time. All of Heist's built-in splices should be + -- used as load time splices. , hcCompiledSplices :: [(Text, C.Splice m)] - -- ^ Compiled splices return a DList of Chunks and are processed at load - -- time to generate a runtime monad action that will be used to render the - -- template. + -- ^ Compiled splices return a DList of Chunks and are processed at load + -- time to generate a runtime monad action that will be used to render the + -- template. , hcAttributeSplices :: [(Text, AttrSplice m)] - -- ^ Attribute splices are bound to attribute names and return a list of - -- attributes. - , hcTemplates :: TemplateRepo - -- ^ Templates returned from the 'loadTemplates' function. + -- ^ Attribute splices are bound to attribute names and return a list of + -- attributes. + , hcTemplateLocations :: [TemplateLocation] + -- ^ A list of all the locations that Heist should get its templates + -- from. } instance Monoid (HeistConfig m) where - mempty = HeistConfig [] [] [] [] Map.empty + mempty = HeistConfig [] [] [] [] mempty mappend (HeistConfig a b c d e) (HeistConfig a' b' c' d' e') = HeistConfig (a `mappend` a') (b `mappend` b') @@ -111,9 +124,11 @@ ------------------------------------------------------------------------------ --- | The built-in set of static splices. All the splices that used to be --- enabled by default are included here. To get the normal Heist behavior you --- should include these in the hcLoadTimeSplices list in your HeistConfig. +-- | The built-in set of splices that you should use in compiled splice mode. +-- This list includes everything from 'defaultInterpretedSplices' plus a +-- splice for the content tag that errors out when it sees any instance of the +-- old content tag, which has now been moved to two separate tags called +-- apply-content and bind-content. defaultLoadTimeSplices :: MonadIO m => [(Text, (I.Splice m))] defaultLoadTimeSplices = ("content", deprecatedContentCheck) -- To be removed in later versions @@ -123,7 +138,9 @@ ------------------------------------------------------------------------------ -- | The built-in set of static splices. All the splices that used to be -- enabled by default are included here. To get the normal Heist behavior you --- should include these in the hcLoadTimeSplices list in your HeistConfig. +-- should include these in the hcLoadTimeSplices list in your HeistConfig. If +-- you are using interpreted splice mode, then you might also want to bind the +-- 'deprecatedContentCheck' splice to the content tag as a load time splice. defaultInterpretedSplices :: MonadIO m => [(Text, (I.Splice m))] defaultInterpretedSplices = [ (applyTag, applyImpl) @@ -133,6 +150,16 @@ ] +allErrors :: [Either String (TPath, v)] + -> EitherT [String] IO (HashMap TPath v) +allErrors tlist = + case errs of + [] -> right $ Map.fromList $ rights tlist + _ -> left errs + where + errs = lefts tlist + + ------------------------------------------------------------------------------ -- | Loads templates from disk. This function returns just a template map so -- you can load multiple directories and combine the maps before initializing @@ -140,14 +167,27 @@ loadTemplates :: FilePath -> EitherT [String] IO TemplateRepo loadTemplates dir = do d <- lift $ readDirectoryWith (loadTemplate dir) dir - let tlist = F.fold (free d) - errs = lefts tlist - case errs of - [] -> right $ Map.fromList $ rights tlist - _ -> left errs + allErrors $ F.fold (free d) ------------------------------------------------------------------------------ +-- | Reloads all the templates an an existing TemplateRepo. +reloadTemplates :: TemplateRepo -> EitherT [String] IO TemplateRepo +reloadTemplates repo = do + tlist <- lift $ mapM loadOrKeep $ Map.toList repo + allErrors tlist + where + loadOrKeep (p,df) = + case dfFile df of + Nothing -> return $ Right (p, df) + Just fp -> do + df' <- loadTemplate' fp + return $ fmap (p,) $ case df' of + [t] -> t + _ -> Left "Template repo has non-templates" + + +------------------------------------------------------------------------------ -- | Adds a path prefix to a templates in a map returned by loadTemplates. If -- you want to add multiple levels of directories, separate them with slashes -- as in "foo/bar". Using an empty string as a path prefix will leave the @@ -165,8 +205,8 @@ ------------------------------------------------------------------------------ -- | 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 ------------------------------------------------------------------------------ @@ -191,16 +231,18 @@ -> EitherT [String] IO (HeistState n) initHeist hc = do keyGen <- lift HE.newKeyGen - initHeist' keyGen hc + repos <- sequence $ hcTemplateLocations hc + initHeist' keyGen hc (Map.unions repos) initHeist' :: Monad n => HE.KeyGen -> HeistConfig n + -> TemplateRepo -> EitherT [String] IO (HeistState n) -initHeist' keyGen (HeistConfig i lt c a rawTemplates) = do +initHeist' keyGen (HeistConfig i lt c a locations) repo = do let empty = emptyHS keyGen - tmap <- preproc keyGen lt rawTemplates + tmap <- preproc keyGen lt repo let hs1 = empty { _spliceMap = Map.fromList i , _templateMap = tmap , _compiledSpliceMap = Map.fromList c @@ -244,26 +286,27 @@ ------------------------------------------------------------------------------ -- | Wrapper around initHeist that also sets up a cache tag. It sets up both -- compiled and interpreted versions of the cache tag splices. If you need to --- do configure the cache tag differently than how this function does it, you +-- configure the cache tag differently than how this function does it, you -- will still probably want to pattern your approach after this function's -- implementation. initHeistWithCacheTag :: MonadIO n => HeistConfig n -> EitherT [String] IO (HeistState n, CacheTagState) -initHeistWithCacheTag (HeistConfig i lt c a rawTemplates) = do +initHeistWithCacheTag (HeistConfig i lt c a locations) = do (ss, cts) <- liftIO mkCacheTag let tag = "cache" keyGen <- lift HE.newKeyGen + repos <- sequence locations -- We have to do one preprocessing pass with the cache setup splice. This -- has to happen for both interpreted and compiled templates, so we do it -- here by itself because interpreted templates don't get the same load -- time splices as compiled templates. - rawWithCache <- preproc keyGen [(tag, ss)] rawTemplates + rawWithCache <- preproc keyGen [(tag, ss)] $ Map.unions repos let hc' = HeistConfig ((tag, cacheImpl cts) : i) lt ((tag, cacheImplCompiled cts) : c) - a rawWithCache - hs <- initHeist' keyGen hc' + a locations + hs <- initHeist' keyGen hc' rawWithCache return (hs, cts) diff --git a/src/Heist/Common.hs b/src/Heist/Common.hs --- a/src/Heist/Common.hs +++ b/src/Heist/Common.hs @@ -203,22 +203,31 @@ loadTemplate :: String -- ^ path of the template root -> String -- ^ full file path (includes the template root) -> IO [Either String (TPath, DocumentFile)] --TemplateMap -loadTemplate templateRoot fname - | isHTMLTemplate = do - c <- getDoc fname - return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c] - | isXMLTemplate = do - c <- getXMLDoc fname - return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c] - | otherwise = return [] +loadTemplate templateRoot fname = do + c <- loadTemplate' fname + return $ map (fmap (\t -> (splitLocalPath $ BC.pack tName, t))) c where -- tName is path relative to the template root directory - isHTMLTemplate = ".tpl" `isSuffixOf` fname - isXMLTemplate = ".xtpl" `isSuffixOf` fname - correction = if last templateRoot == '/' then 0 else 1 - extLen = if isHTMLTemplate then 4 else 5 - tName = drop ((length templateRoot)+correction) $ - -- We're only dropping the template root, not the whole path - take ((length fname) - extLen) fname + isHTMLTemplate = ".tpl" `isSuffixOf` fname + correction = if last templateRoot == '/' then 0 else 1 + extLen = if isHTMLTemplate then 4 else 5 + tName = drop ((length templateRoot)+correction) $ + -- We're only dropping the template root, not the whole path + take ((length fname) - extLen) fname + + +------------------------------------------------------------------------------ +-- | Loads a template at the specified path, choosing the appropriate parser +-- based on the file extension. The template is only loaded if it has a +-- \".tpl\" or \".xtpl\" extension. Returns an empty list if the extension +-- doesn't match. +loadTemplate' :: String -> IO [Either String DocumentFile] +loadTemplate' fullDiskPath + | isHTMLTemplate = liftM (:[]) $ getDoc fullDiskPath + | isXMLTemplate = liftM (:[]) $ getXMLDoc fullDiskPath + | otherwise = return [] + where + isHTMLTemplate = ".tpl" `isSuffixOf` fullDiskPath + isXMLTemplate = ".xtpl" `isSuffixOf` fullDiskPath ------------------------------------------------------------------------------ diff --git a/src/Heist/Compiled.hs b/src/Heist/Compiled.hs --- a/src/Heist/Compiled.hs +++ b/src/Heist/Compiled.hs @@ -26,12 +26,11 @@ , prefixSplices , namespaceSplices , textSplices - , nodeSplices + , htmlSplices , pureSplices , textSplice - , nodeSplice + , htmlSplice , pureSplice - , mapInputPromise , repromise , repromiseMay , repromise' @@ -57,8 +56,6 @@ , yieldRuntimeEffect , yieldPureText , yieldRuntimeText - , yieldLater - , addSplices , withLocalSplices -- * Lower level promise functions diff --git a/src/Heist/Compiled/Internal.hs b/src/Heist/Compiled/Internal.hs --- a/src/Heist/Compiled/Internal.hs +++ b/src/Heist/Compiled/Internal.hs @@ -137,10 +137,18 @@ => [(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 + + ------------------------------------------------------------------------------ -- | Yields pure text known at load time. pureTextChunk :: Text -> Chunk n @@ -188,14 +196,6 @@ ------------------------------------------------------------------------------ --- | This lets you turn a plain runtime monad function returning a Builder --- into a compiled splice. -yieldLater :: Monad n => n Builder -> DList (Chunk n) -yieldLater = yieldRuntime . RuntimeSplice . lift -{-# INLINE yieldLater #-} - - ------------------------------------------------------------------------------- -- | Returns a computation that performs load-time splice processing on the -- supplied list of nodes. runNodeList :: Monad n => [X.Node] -> Splice n @@ -235,7 +235,11 @@ -> 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 @@ -331,9 +335,9 @@ 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 @@ -446,6 +450,35 @@ ------------------------------------------------------------------------------ +-- | +parseAtt2 :: Monad n + => (Text, Text) + -> HeistT n IO (RuntimeSplice n [(Text, Text)]) +parseAtt2 (k,v) = do + mas <- getsHS (H.lookup k . _attrSpliceMap) + maybe doInline (return . doAttrSplice) mas + + where + cvt (Literal x) = return $ return x + cvt (Ident x) = + localParamNode (const $ X.Element x [] []) $ getAttributeSplice2 x + + -- Handles inline parsing of $() splice syntax in attributes + doInline = do + let ast = case AP.feed (AP.parse attParser v) "" of + (AP.Done _ res) -> res + (AP.Fail _ _ _) -> [] + (AP.Partial _ ) -> [] + chunks <- mapM cvt ast + return $ do + list <- sequence chunks + return [(k, T.concat list)] + + -- Handles attribute splices + doAttrSplice splice = splice v + + +------------------------------------------------------------------------------ -- | Performs splice processing on a list of attributes. This is useful in -- situations where you need to stop recursion, but still run splice -- processing on the node's attributes. @@ -457,16 +490,12 @@ -- | Performs splice processing on a list of attributes. This is useful in -- situations where you need to stop recursion, but still run splice -- processing on the node's attributes. -runAttributesRaw :: (Monad m, Monad n) +runAttributesRaw :: Monad n => [(Text, Text)] - -> HeistT n m (RuntimeSplice n [(Text, Text)]) + -> HeistT n IO (RuntimeSplice n [(Text, Text)]) runAttributesRaw attrs = do - arrs <- mapM runSingle attrs + arrs <- mapM parseAtt2 attrs return $ liftM concat $ sequence arrs - where - runSingle p@(k,v) = do - mas <- getsHS (H.lookup k . _attrSpliceMap) - return $ maybe (return [p]) ($v) mas attrToChunk :: Text -> DList (Chunk n) -> DList (Chunk n) @@ -500,6 +529,17 @@ {-# INLINE getAttributeSplice #-} +getAttributeSplice2 :: Monad n => Text -> HeistT n IO (RuntimeSplice n Text) +getAttributeSplice2 name = do + mSplice <- lookupSplice name + case mSplice of + Nothing -> return $ return $ T.concat ["${", name, "}"] + Just splice -> do + res <- splice + return $ liftM (T.decodeUtf8 . toByteString) $ codeGen res +{-# INLINE getAttributeSplice2 #-} + + ------------------------------------------------------------------------------ -- | Promises are used for referencing the results of future runtime -- computations during load time splice processing. @@ -555,51 +595,6 @@ -- $ "deferenced empty promise created at" ++ from -- return prom -- {-# INLINE newEmptyPromiseWithError #-} --- --- --- ------------------------------------------------------------------------------ --- -- | Creates a promise for a future runtime computation. --- promise :: (Monad n) => n a -> HeistT n IO (Promise a) --- promise act = runtimeSplicePromise (lift act) --- {-# INLINE promise #-} --- --- --- ------------------------------------------------------------------------------ --- -- | Turns a RuntimeSplice computation into a promise. --- runtimeSplicePromise :: (Monad n) --- => RuntimeSplice n a --- -> HeistT n IO (Promise a) --- runtimeSplicePromise act = do --- prom <- newEmptyPromiseWithError "runtimeSplicePromise" --- --- let m = do --- x <- act --- putPromise prom x --- return () --- --- yieldRuntimeEffect m --- return prom --- {-# INLINE runtimeSplicePromise #-} --- --- --- ------------------------------------------------------------------------------ --- -- | Sets up a runtime transformation on a 'Promise'. --- withPromise :: (Monad n) --- => Promise a --- -> (a -> n b) --- -> HeistT n IO (Promise b) --- withPromise promA f = do --- promB <- newEmptyPromiseWithError "withPromise" --- --- let m = do --- a <- getPromise promA --- b <- lift $ f a --- putPromise promB b --- return () --- --- yieldRuntimeEffect m --- return promB --- {-# INLINE withPromise #-} ------------------------------------------------------------------------------ @@ -624,15 +619,6 @@ -- | Adds a list of compiled splices to the splice map. This function is -- useful because it allows compiled splices to bind other compiled splices -- during load-time splice processing. -addSplices :: Monad m => [(Text, Splice n)] -> HeistT n m () -addSplices ss = modifyHS (bindSplices ss) -{-# DEPRECATED addSplices "addSplices will be removed in the next release! Use withLocalSplices instead."#-} - - ------------------------------------------------------------------------------- --- | Adds a list of compiled splices to the splice map. This function is --- useful because it allows compiled splices to bind other compiled splices --- during load-time splice processing. withLocalSplices :: [(Text, Splice n)] -> [(Text, AttrSplice n)] -> HeistT n IO a @@ -719,14 +705,14 @@ ------------------------------------------------------------------------------ -- | 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 ------------------------------------------------------------------------------ @@ -746,25 +732,17 @@ return $ f a -mapInputPromise :: Monad n - => (a -> b) - -> (Promise b -> Splice n) - -> Promise a -> Splice n -mapInputPromise f = repromise' (return . f) -{-# DEPRECATED mapInputPromise "Use repromise' instead."#-} - - ------------------------------------------------------------------------------ -- | Change the promise type of a splice function. repromise' :: Monad n - => (a -> n b) + => (a -> RuntimeSplice n b) -> (Promise b -> Splice n) -> Promise a -> Splice n repromise' f pf p = do p2 <- newEmptyPromise let action = yieldRuntimeEffect $ do a <- getPromise p - putPromise p2 =<< lift (f a) + putPromise p2 =<< f a res <- pf p2 return $ action `mappend` res @@ -772,7 +750,7 @@ ------------------------------------------------------------------------------ -- | Repromise a list of splices. repromise :: Monad n - => (a -> n b) + => (a -> RuntimeSplice n b) -> [(d, Promise b -> Splice n)] -> [(d, Promise a -> Splice n)] repromise f = mapSnd (repromise' f) @@ -783,7 +761,7 @@ -- fail. If a Nothing is encountered, then the splice will generate no -- output. repromiseMay' :: Monad n - => (a -> n (Maybe b)) + => (a -> RuntimeSplice n (Maybe b)) -> (Promise b -> Splice n) -> Promise a -> Splice n repromiseMay' f pf p = do @@ -791,7 +769,7 @@ action <- pf p2 return $ yieldRuntime $ do a <- getPromise p - mb <- lift (f a) + mb <- f a case mb of Nothing -> return mempty Just b -> do @@ -802,7 +780,7 @@ ------------------------------------------------------------------------------ -- | repromiseMay' for a list of splices. repromiseMay :: Monad n - => (a -> n (Maybe b)) + => (a -> RuntimeSplice n (Maybe b)) -> [(d, Promise b -> Splice n)] -> [(d, Promise a -> Splice n)] repromiseMay f = mapSnd (repromiseMay' f) @@ -845,16 +823,39 @@ return $ mconcat res +------------------------------------------------------------------------------ +-- | Another useful way of combining groups of splices. +-- FIXME - We probably need to export this +--applyDeferred :: Monad n +-- => RuntimeSplice n a +-- -> [(Text, Promise a -> Splice n)] +-- -> [(Text, Splice n)] +--applyDeferred m = applySnd m . mapSnd defer + + +------------------------------------------------------------------------------ +-- | This is kind of the opposite of defer. Not sure what to name it yet. +-- FIXME - This is a really common pattern, so I think we do want to expose it +--deferred :: (Monad n) +-- => (t -> RuntimeSplice n Builder) +-- -> Promise t +-- -> Splice n +--deferred f p = return $ yieldRuntime $ f =<< getPromise p + + +------------------------------------------------------------------------------ +-- | Runs a splice computation with a list of splices that are functions of +-- runtime data. withSplices :: Monad n => Splice n -> [(Text, Promise a -> Splice n)] - -> n a + -> RuntimeSplice n a -> Splice n withSplices splice splices runtimeAction = do p <- newEmptyPromise let splices' = mapSnd ($p) splices chunks <- withLocalSplices splices' [] splice - let fillPromise = yieldRuntimeEffect $ putPromise p =<< lift runtimeAction + let fillPromise = yieldRuntimeEffect $ putPromise p =<< runtimeAction return $ fillPromise `mappend` chunks @@ -869,7 +870,7 @@ -- You'll frequently use 'runChildren' here. -> [(Text, Promise a -> Splice n)] -- ^ List of splices to bind - -> n [a] + -> RuntimeSplice n [a] -- ^ Runtime action returning a list of items to render. -> Splice n manyWithSplices splice splices runtimeAction = do @@ -877,18 +878,21 @@ let splices' = mapSnd ($p) splices chunks <- withLocalSplices splices' [] splice return $ yieldRuntime $ do - items <- lift runtimeAction + items <- runtimeAction res <- forM items $ \item -> putPromise p item >> codeGen chunks return $ mconcat res +------------------------------------------------------------------------------ +-- | Like 'withSplices', but works for \"pure\" splices that don't operate in +-- the HeistT monad. withPureSplices :: Monad n => Splice n -> [(Text, a -> Builder)] - -> n a + -> RuntimeSplice n a -> Splice n withPureSplices splice splices action = do - let fieldSplice g = return $ yieldRuntime $ liftM g $ lift action + let fieldSplice g = return $ yieldRuntime $ liftM g action let splices' = map (second fieldSplice) splices withLocalSplices splices' [] splice diff --git a/src/Heist/Splices/Apply.hs b/src/Heist/Splices/Apply.hs --- a/src/Heist/Splices/Apply.hs +++ b/src/Heist/Splices/Apply.hs @@ -93,6 +93,12 @@ Just template -> applyNodes (X.childNodes node) template +------------------------------------------------------------------------------ +-- | This splice crashes with an error message. Its purpose is to provide a +-- load-time warning to anyone still using the old content tag in their +-- templates. In Heist 0.10, tho content tag was replaced by two separate +-- apply-content and bind-content tags used by the apply and bind splices +-- respectively. deprecatedContentCheck :: Monad m => Splice m deprecatedContentCheck = return [] `orError` unwords diff --git a/src/Heist/TemplateDirectory.hs b/src/Heist/TemplateDirectory.hs --- a/src/Heist/TemplateDirectory.hs +++ b/src/Heist/TemplateDirectory.hs @@ -42,8 +42,7 @@ -> HeistConfig n -> EitherT [String] IO (TemplateDirectory n) newTemplateDirectory dir hc = do - templates <- loadTemplates dir - let hc' = hc { hcTemplates = templates } + let hc' = hc { hcTemplateLocations = [loadTemplates dir] } (hs,cts) <- initHeistWithCacheTag hc' tsMVar <- liftIO $ newMVar hs ctsMVar <- liftIO $ newMVar cts @@ -84,8 +83,7 @@ -> IO (Either String ()) reloadTemplateDirectory (TemplateDirectory p hc tsMVar ctsMVar) = do ehs <- runEitherT $ do - templates <- loadTemplates p - initHeistWithCacheTag (hc { hcTemplates = templates }) + initHeistWithCacheTag (hc { hcTemplateLocations = [loadTemplates p] }) leftPass ehs $ \(hs,cts) -> do modifyMVar_ tsMVar (const $ return hs) modifyMVar_ ctsMVar (const $ return cts) diff --git a/src/Heist/Types.hs b/src/Heist/Types.hs --- a/src/Heist/Types.hs +++ b/src/Heist/Types.hs @@ -72,6 +72,11 @@ ------------------------------------------------------------------------------ +-- | 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 @@ -- 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 } diff --git a/test/suite/Benchmark.hs b/test/suite/Benchmark.hs --- a/test/suite/Benchmark.hs +++ b/test/suite/Benchmark.hs @@ -31,8 +31,7 @@ loadWithCache baseDir = do etm <- runEitherT $ do - templates <- loadTemplates baseDir - let hc = HeistConfig [] defaultLoadTimeSplices [] [] templates + let hc = HeistConfig [] defaultLoadTimeSplices [] [] [loadTemplates baseDir] initHeistWithCacheTag hc either (error . unlines) (return . fst) etm diff --git a/test/suite/Heist/Interpreted/Tests.hs b/test/suite/Heist/Interpreted/Tests.hs --- a/test/suite/Heist/Interpreted/Tests.hs +++ b/test/suite/Heist/Interpreted/Tests.hs @@ -71,6 +71,7 @@ , testCase "heist/attrSpliceContext" attrSpliceContext , testCase "heist/json/values" jsonValueTest , testCase "heist/json/object" jsonObjectTest + , testCase "heist/renderXML" xmlNotHtmlTest ] @@ -137,7 +138,7 @@ 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 @@ -195,7 +196,7 @@ where splices = defaultLoadTimeSplices ++ [("foo", return [X.TextNode "meaning_of_everything"])] - + check str ts expected = do Just (resDoc, _) <- renderTemplate ts "attrs" H.assertEqual str expected $ toByteString $ resDoc @@ -338,7 +339,7 @@ result <- evalHeistT markdownSplice (X.TextNode "This *is* a test.") hs - H.assertEqual "Markdown text" markdownHtmlExpected + H.assertEqual "Markdown text" markdownHtmlExpected (B.filter (/= '\n') $ toByteString $ X.render (X.HtmlDocument X.UTF8 Nothing result)) @@ -358,7 +359,7 @@ ignoreTest = do es <- loadEmpty [] [] [] [] res <- evalHeistT ignoreImpl - (X.Element "ignore" [("tag", "ignorable")] + (X.Element "ignore" [("tag", "ignorable")] [X.TextNode "This should be ignored"]) es H.assertEqual " tag" [] res @@ -372,6 +373,10 @@ res <- runHeistT k (X.TextNode "") hs H.assertBool "lookup context test" $ isJust $ fst res +------------------------------------------------------------------------------ +xmlNotHtmlTest :: H.Assertion +xmlNotHtmlTest = renderTest "rss" expected where + expected = "http://www.devalot.com/" ------------------------------------------------------------------------------ identStartChar :: [Char] @@ -636,4 +641,3 @@ --prn = L.putStrLn . formatNode --runTests :: IO () --runTests = defaultMain tests - diff --git a/test/suite/Heist/TestCommon.hs b/test/suite/Heist/TestCommon.hs --- a/test/suite/Heist/TestCommon.hs +++ b/test/suite/Heist/TestCommon.hs @@ -6,8 +6,8 @@ import Control.Monad.Trans import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import qualified Data.HashMap.Strict as Map import Data.Maybe +import Data.Monoid import Data.Text (Text) @@ -35,9 +35,8 @@ -> [(Text, AttrSplice m)] -> IO (Either [String] (HeistState m)) loadT baseDir a b c d = runEitherT $ do - ts <- loadTemplates baseDir let hc = HeistConfig (defaultInterpretedSplices ++ a) - (defaultLoadTimeSplices ++ b) c d ts + (defaultLoadTimeSplices ++ b) c d [loadTemplates baseDir] initHeist hc @@ -49,9 +48,8 @@ -> [(Text, AttrSplice IO)] -> IO (Either [String] (HeistState IO)) loadIO baseDir a b c d = runEitherT $ do - ts <- loadTemplates baseDir let hc = HeistConfig (defaultInterpretedSplices ++ a) - (defaultLoadTimeSplices ++ b) c d ts + (defaultLoadTimeSplices ++ b) c d [loadTemplates baseDir] initHeist hc @@ -59,9 +57,8 @@ loadHS :: FilePath -> IO (HeistState IO) loadHS baseDir = do etm <- runEitherT $ do - templates <- loadTemplates baseDir let hc = HeistConfig defaultInterpretedSplices - defaultLoadTimeSplices [] [] templates + defaultLoadTimeSplices [] [] [loadTemplates baseDir] initHeist hc either (error . concat) return etm @@ -73,7 +70,7 @@ -> IO (HeistState IO) loadEmpty a b c d = do let hc = HeistConfig (defaultInterpretedSplices ++ a) - (defaultLoadTimeSplices ++ b) c d Map.empty + (defaultLoadTimeSplices ++ b) c d mempty res <- runEitherT $ initHeist hc either (error . concat) return res diff --git a/test/suite/Heist/Tutorial/CompiledSplices.lhs b/test/suite/Heist/Tutorial/CompiledSplices.lhs --- a/test/suite/Heist/Tutorial/CompiledSplices.lhs +++ b/test/suite/Heist/Tutorial/CompiledSplices.lhs @@ -107,8 +107,8 @@ > -> IO (HeistState n) > load baseDir splices = do > tmap <- runEitherT $ do -> templates <- loadTemplates baseDir -> let hc = HeistConfig [] defaultLoadTimeSplices splices [] templates +> let hc = HeistConfig [] defaultLoadTimeSplices splices [] +> [loadTemplates baseDir] > initHeist hc > either (error . concat) return tmap