diff --git a/heist.cabal b/heist.cabal --- a/heist.cabal +++ b/heist.cabal @@ -1,5 +1,5 @@ name: heist -version: 0.12.0 +version: 0.13.0 synopsis: An Haskell template system supporting both HTML5 and XML. description: Heist is a powerful template system that supports both HTML5 and XML. @@ -116,7 +116,9 @@ exposed-modules: Heist, Heist.Compiled, + Heist.Compiled.LowLevel, Heist.Interpreted, + Heist.SpliceAPI, Heist.Splices, Heist.Splices.Apply, Heist.Splices.Bind, @@ -158,7 +160,7 @@ transformers >= 0.3 && < 0.4, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.9 && < 0.11, - xmlhtml >= 0.2.1 && < 0.3 + xmlhtml >= 0.2.3 && < 0.3 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 diff --git a/src/Heist.hs b/src/Heist.hs --- a/src/Heist.hs +++ b/src/Heist.hs @@ -36,7 +36,7 @@ , AttrSplice , RuntimeSplice , Chunk - , HeistState(..) + , HeistState , templateNames , compiledTemplateNames , hasTemplate @@ -57,12 +57,15 @@ , getDoc , getXMLDoc , orError + + -- * Splice API + , module Heist.SpliceAPI ) where import Control.Error import Control.Exception (SomeException) import Control.Monad.CatchIO -import Control.Monad.Trans +import Control.Monad.State import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.Foldable as F @@ -70,13 +73,13 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map import Data.Monoid -import Data.Text (Text) import System.Directory.Tree import qualified Text.XmlHtml as X import Heist.Common import qualified Heist.Compiled.Internal as C import qualified Heist.Interpreted.Internal as I +import Heist.SpliceAPI import Heist.Splices import Heist.Types @@ -92,19 +95,19 @@ data HeistConfig m = HeistConfig - { hcInterpretedSplices :: [(Text, I.Splice m)] + { hcInterpretedSplices :: Splices (I.Splice m) -- ^ 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)] + , hcLoadTimeSplices :: Splices (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. - , hcCompiledSplices :: [(Text, C.Splice m)] + , hcCompiledSplices :: Splices (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. - , hcAttributeSplices :: [(Text, AttrSplice m)] + , hcAttributeSplices :: Splices (AttrSplice m) -- ^ Attribute splices are bound to attribute names and return a list of -- attributes. , hcTemplateLocations :: [TemplateLocation] @@ -114,12 +117,12 @@ instance Monoid (HeistConfig m) where - mempty = HeistConfig [] [] [] [] mempty + mempty = HeistConfig (put mempty) (put mempty) (put mempty) (put mempty) mempty mappend (HeistConfig a b c d e) (HeistConfig a' b' c' d' e') = - HeistConfig (a `mappend` a') - (b `mappend` b') - (c `mappend` c') - (d `mappend` d') + HeistConfig (unionWithS const a a') + (unionWithS const b b') + (unionWithS const c c') + (unionWithS const d d') (e `mappend` e') @@ -129,10 +132,11 @@ -- 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 :: MonadIO m => Splices (I.Splice m) defaultLoadTimeSplices = - ("content", deprecatedContentCheck) -- To be removed in later versions - : defaultInterpretedSplices + -- To be removed in later versions + insertS "content" deprecatedContentCheck defaultInterpretedSplices + ------------------------------------------------------------------------------ @@ -141,15 +145,15 @@ -- 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) - , (bindTag, bindImpl) - , (ignoreTag, ignoreImpl) - , (markdownTag, markdownSplice) - ] +defaultInterpretedSplices :: MonadIO m => Splices (I.Splice m) +defaultInterpretedSplices = do + applyTag ## applyImpl + bindTag ## bindImpl + ignoreTag ## ignoreImpl + markdownTag ## markdownSplice + allErrors :: [Either String (TPath, v)] -> EitherT [String] IO (HashMap TPath v) allErrors tlist = @@ -240,13 +244,13 @@ -> HeistConfig n -> TemplateRepo -> EitherT [String] IO (HeistState n) -initHeist' keyGen (HeistConfig i lt c a locations) repo = do +initHeist' keyGen (HeistConfig i lt c a _) repo = do let empty = emptyHS keyGen tmap <- preproc keyGen lt repo - let hs1 = empty { _spliceMap = Map.fromList i + let hs1 = empty { _spliceMap = Map.fromList $ splicesToList i , _templateMap = tmap - , _compiledSpliceMap = Map.fromList c - , _attrSpliceMap = Map.fromList a + , _compiledSpliceMap = Map.fromList $ splicesToList c + , _attrSpliceMap = Map.fromList $ splicesToList a } lift $ C.compileTemplates hs1 @@ -254,11 +258,11 @@ ------------------------------------------------------------------------------ -- | Runs preprocess on a TemplateRepo and returns the modified templates. preproc :: HE.KeyGen - -> [(Text, I.Splice IO)] + -> Splices (I.Splice IO) -> TemplateRepo -> EitherT [String] IO TemplateRepo preproc keyGen splices templates = do - let hs = (emptyHS keyGen) { _spliceMap = Map.fromList splices + let hs = (emptyHS keyGen) { _spliceMap = Map.fromList $ splicesToList splices , _templateMap = templates , _preprocessingMode = True } let eval a = evalHeistT a (X.TextNode "") hs @@ -302,10 +306,10 @@ -- 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)] $ Map.unions repos + rawWithCache <- preproc keyGen (tag ## ss) $ Map.unions repos - let hc' = HeistConfig ((tag, cacheImpl cts) : i) lt - ((tag, cacheImplCompiled cts) : c) + let hc' = HeistConfig (insertS tag (cacheImpl cts) i) lt + (insertS tag (cacheImplCompiled cts) c) 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 @@ -7,12 +7,11 @@ import Control.Applicative import Control.Exception (SomeException) import Control.Monad -import Control.Monad.CatchIO +import qualified Control.Monad.CatchIO as C import qualified Data.Attoparsec.Text as AP import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import Data.Either import Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map @@ -20,8 +19,8 @@ import Data.Maybe import Data.Monoid import qualified Data.Text as T -import Prelude hiding (catch) import System.FilePath +import Heist.SpliceAPI import Heist.Types import qualified Text.XmlHtml as X @@ -239,7 +238,7 @@ -- | Reads an HTML or XML template from disk. getDocWith :: ParserFun -> String -> IO (Either String DocumentFile) getDocWith parser f = do - bs <- catch (liftM Right $ B.readFile f) + bs <- C.catch (liftM Right $ B.readFile f) (\(e::SomeException) -> return $ Left $ show e) let eitherDoc = either Left (parser f) bs @@ -291,10 +290,18 @@ ------------------------------------------------------------------------------ -- | Binds a set of new splice declarations within a 'HeistState'. -bindAttributeSplices :: [(T.Text, AttrSplice n)] -- ^ splices to bind - -> HeistState n -- ^ start state +bindAttributeSplices :: Splices (AttrSplice n) -- ^ splices to bind + -> HeistState n -- ^ start state -> HeistState n bindAttributeSplices ss hs = - hs { _attrSpliceMap = Map.union (Map.fromList ss) (_attrSpliceMap hs) } + hs { _attrSpliceMap = Map.union (Map.fromList $ splicesToList ss) + (_attrSpliceMap hs) } + + +------------------------------------------------------------------------------ +-- | Mappends a doctype to the state. +addDoctype :: Monad m => [X.DocType] -> HeistT n m () +addDoctype dt = do + modifyHS (\s -> s { _doctypes = _doctypes s `mappend` dt }) diff --git a/src/Heist/Compiled.hs b/src/Heist/Compiled.hs --- a/src/Heist/Compiled.hs +++ b/src/Heist/Compiled.hs @@ -21,33 +21,17 @@ , runChildren -- * Functions for manipulating lists of compiled splices - , mapSnd - , applySnd - , prefixSplices - , namespaceSplices - , textSplices - , htmlSplices - , pureSplices , textSplice - , htmlSplice + , nodeSplice , pureSplice - , repromise - , repromiseMay - , repromise' - , repromiseMay' - , defer + , deferMany + , deferMap + , mayDeferMap + , bindLater , withSplices , manyWithSplices - , withPureSplices - - -- * Old compiled splice API - , mapPromises - , promiseChildren - , promiseChildrenWith - , promiseChildrenWithTrans - , promiseChildrenWithText - , promiseChildrenWithNodes + , withLocalSplices -- * Constructing Chunks -- $yieldOverview @@ -56,15 +40,7 @@ , yieldRuntimeEffect , yieldPureText , yieldRuntimeText - , withLocalSplices - -- * Lower level promise functions - , Promise - , newEmptyPromise - , getPromise - , putPromise - , adjustPromise - -- * Running nodes and splices , runNodeList , runNode @@ -79,5 +55,8 @@ -- $yieldOverview -- The internals of the Chunk data type are deliberately not exported because -- we want to hide the underlying implementation as much as possible. The --- @yield...@ functions give you lower lever construction of Chunks and DLists --- of Chunks. +-- @yield...@ functions give you lower level construction of DLists of Chunks. +-- +-- Most of the time you will use these functions composed with return to +-- generate a Splice. But we decided not to include the return in these +-- functions to allow you to work with the DLists purely. 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 @@ -28,11 +28,11 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V -import Prelude hiding (catch) import qualified Text.XmlHtml as X import qualified Text.XmlHtml.HTML.Meta as X ------------------------------------------------------------------------------ import Heist.Common +import Heist.SpliceAPI import Heist.Types ------------------------------------------------------------------------------ @@ -61,87 +61,6 @@ {-# INLINE runChildren #-} ------------------------------------------------------------------------------- --- | Takes a promise function and a runtime action returning a list of items --- that fit in the promise and returns a Splice that executes the promise --- function for each item and concatenates the results. --- --- This function works nicely with the 'promiseChildrenWith' family of --- functions, much like the combination of 'mapSplices' and 'runChildrenWith' --- for interpreted splices. -mapPromises :: Monad n - => (Promise a -> HeistT n IO (RuntimeSplice n Builder)) - -- ^ Use 'promiseChildrenWith' or a variant to create this - -- function. - -> RuntimeSplice n [a] - -- ^ Runtime computation returning a list of items - -> Splice n -mapPromises f getList = do - singlePromise <- newEmptyPromise - runSingle <- f singlePromise - return $ yieldRuntime $ do - list <- getList - htmls <- forM list $ \item -> - putPromise singlePromise item >> runSingle - return $ mconcat htmls - - ------------------------------------------------------------------------------- --- | Returns a runtime computation that simply renders the node's children. -promiseChildren :: Monad n => HeistT n IO (RuntimeSplice n Builder) -promiseChildren = liftM codeGen runChildren -{-# INLINE promiseChildren #-} - - ------------------------------------------------------------------------------- --- | Binds a list of Builder splices before using the children of the spliced --- node as a view. -promiseChildrenWith :: (Monad n) - => [(Text, a -> Builder)] - -> Promise a - -> HeistT n IO (RuntimeSplice n Builder) -promiseChildrenWith splices prom = - localHS (bindSplices splices') promiseChildren - where - fieldSplice p f = return $ yieldRuntime $ liftM f $ getPromise p - splices' = map (second (fieldSplice prom)) splices - - ------------------------------------------------------------------------------- --- | Wrapper that composes a transformation function with the second item in --- each of the tuples before calling promiseChildren. -promiseChildrenWithTrans :: Monad n - => (b -> Builder) - -> [(Text, a -> b)] - -> Promise a - -> HeistT n IO (RuntimeSplice n Builder) -promiseChildrenWithTrans f = promiseChildrenWith . map (second (f .)) - - ------------------------------------------------------------------------------- --- | Binds a list of Text splices before using the children of the spliced --- node as a view. -promiseChildrenWithText :: (Monad n) - => [(Text, a -> Text)] - -> Promise a - -> HeistT n IO (RuntimeSplice n Builder) -promiseChildrenWithText = promiseChildrenWithTrans fromText - - ------------------------------------------------------------------------------- --- | Binds a list of Node splices before using the children of the spliced --- node as a view. Note that this will slow down page generation because the --- nodes generated by the splices must be traversed and rendered into a --- ByteString at runtime. -promiseChildrenWithNodes :: (Monad n) - => [(Text, a -> [X.Node])] - -> Promise a - -> HeistT n IO (RuntimeSplice n Builder) -promiseChildrenWithNodes ss p = do - markup <- getsHS _curMarkup - promiseChildrenWithTrans (renderFragment markup) ss p - - renderFragment :: Markup -> [X.Node] -> Builder renderFragment markup ns = case markup of @@ -210,7 +129,7 @@ -> Splice n -> IO [Chunk n] runSplice node hs splice = do - (!a,_) <- runHeistT splice node hs + !a <- evalHeistT splice node hs return $! consolidate a @@ -221,8 +140,12 @@ -> DocumentFile -> Splice n runDocumentFile tpath df = do + addDoctype $ maybeToList $ X.docType $ dfDoc df modifyHS (setCurTemplateFile curPath . setCurContext tpath) - runNodeList nodes + res <- runNodeList nodes + dt <- getsHS (listToMaybe . _doctypes) + let enc = X.docEncoding $ dfDoc df + return $! (yieldPure (X.renderDocType enc dt) `mappend` res) where curPath = dfFile df nodes = X.docContent $! dfDoc df @@ -482,7 +405,9 @@ -- | 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. -runAttributes :: Monad n => [(Text, Text)] -> HeistT n IO [DList (Chunk n)] +runAttributes :: Monad n + => [(Text, Text)] -- ^ List of attributes + -> HeistT n IO [DList (Chunk n)] runAttributes = mapM parseAtt @@ -491,7 +416,8 @@ -- situations where you need to stop recursion, but still run splice -- processing on the node's attributes. runAttributesRaw :: Monad n - => [(Text, Text)] + -- Note that this parameter should not be changed to Splices + => [(Text, Text)] -- ^ List of attributes -> HeistT n IO (RuntimeSplice n [(Text, Text)]) runAttributesRaw attrs = do arrs <- mapM parseAtt2 attrs @@ -609,18 +535,18 @@ ------------------------------------------------------------------------------ -- | Binds a list of compiled splices. This function should not be exported. -bindSplices :: [(Text, Splice n)] -- ^ splices to bind +bindSplices :: Splices (Splice n) -- ^ splices to bind -> HeistState n -- ^ source state -> HeistState n -bindSplices ss ts = foldr (uncurry bindSplice) ts ss +bindSplices ss ts = foldr (uncurry bindSplice) ts $ splicesToList ss ------------------------------------------------------------------------------ -- | 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)] +withLocalSplices :: Splices (Splice n) + -> Splices (AttrSplice n) -> HeistT n IO a -> HeistT n IO a withLocalSplices ss as = localHS (bindSplices ss . bindAttributeSplices as) @@ -656,165 +582,75 @@ ------------------------------------------------------------------------------ --- Functions for manipulating lists of compiled splices ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- --- | Helper function for transforming the second element of each of a list of --- tuples. -mapSnd :: (b -> c) -> [(d, b)] -> [(d, c)] -mapSnd = map . second - - ------------------------------------------------------------------------------- --- | The type signature says it all. -applySnd :: a -> [(d, a -> b)] -> [(d, b)] -applySnd a = mapSnd ($a) - - ------------------------------------------------------------------------------- --- | Adds a prefix to the tag names for a list of splices. If the existing --- tag name is empty, then the new tag name is just the prefix. Otherwise the --- new tag name is the prefix followed by the separator followed by the --- existing name. -prefixSplices :: Text -> Text -> [(Text, a)] -> [(Text, a)] -prefixSplices sep pre = map f - where - f (t,v) = if T.null t then (pre,v) else (T.concat [pre,sep,t], v) - - ------------------------------------------------------------------------------- --- | 'prefixSplices' specialized to use a colon as separator in the style of --- XML namespaces. -namespaceSplices :: Text -> [(Text, a)] -> [(Text, a)] -namespaceSplices = prefixSplices ":" - - ------------------------------------------------------------------------------- --- | Converts pure text splices to pure Builder splices. -textSplices :: [(Text, a -> Text)] -> [(Text, a -> Builder)] -textSplices = mapSnd textSplice - - ------------------------------------------------------------------------------- -- | Converts a pure text splice function to a pure Builder splice function. textSplice :: (a -> Text) -> a -> Builder textSplice f = fromText . f ------------------------------------------------------------------------------- --- | Converts pure Node splices to pure Builder splices. -htmlSplices :: [(Text, a -> [X.Node])] -> [(Text, a -> Builder)] -htmlSplices = mapSnd htmlSplice + --------------- + -- New Stuff -- + --------------- ------------------------------------------------------------------------------ -- | Converts a pure Node splice function to a pure Builder splice function. -htmlSplice :: (a -> [X.Node]) -> a -> Builder -htmlSplice f = X.renderHtmlFragment X.UTF8 . f - - ------------------------------------------------------------------------------- --- | Converts pure Builder splices into monadic splice functions of a --- 'Promise'. -pureSplices :: Monad n => [(d, a -> Builder)] -> [(d, Promise a -> Splice n)] -pureSplices = mapSnd pureSplice +nodeSplice :: (a -> [X.Node]) -> a -> Builder +nodeSplice f = X.renderHtmlFragment X.UTF8 . f ------------------------------------------------------------------------------ -- | Converts a pure Builder splice function into a monadic splice function --- that takes a 'Promise'. -pureSplice :: Monad n => (a -> Builder) -> Promise a -> Splice n -pureSplice f p = do - return $ yieldRuntime $ do - a <- getPromise p - return $ f a - - ------------------------------------------------------------------------------- --- | Change the promise type of a splice function. -repromise' :: Monad n - => (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 =<< f a - res <- pf p2 - return $ action `mappend` res - - ------------------------------------------------------------------------------- --- | Repromise a list of splices. -repromise :: Monad n - => (a -> RuntimeSplice n b) - -> [(d, Promise b -> Splice n)] - -> [(d, Promise a -> Splice n)] -repromise f = mapSnd (repromise' f) - - ------------------------------------------------------------------------------- --- | Change the promise type of a splice function with a function that might --- fail. If a Nothing is encountered, then the splice will generate no --- output. -repromiseMay' :: Monad n - => (a -> RuntimeSplice n (Maybe b)) - -> (Promise b -> Splice n) - -> Promise a -> Splice n -repromiseMay' f pf p = do - p2 <- newEmptyPromise - action <- pf p2 - return $ yieldRuntime $ do - a <- getPromise p - mb <- f a - case mb of - Nothing -> return mempty - Just b -> do - putPromise p2 b - codeGen action +-- of a RuntimeSplice. +pureSplice :: Monad n => (a -> Builder) -> RuntimeSplice n a -> Splice n +pureSplice f n = return $ yieldRuntime (return . f =<< n) ------------------------------------------------------------------------------ --- | repromiseMay' for a list of splices. -repromiseMay :: Monad n - => (a -> RuntimeSplice n (Maybe b)) - -> [(d, Promise b -> Splice n)] - -> [(d, Promise a -> Splice n)] -repromiseMay f = mapSnd (repromiseMay' f) +-- | Runs a splice, but first binds splices given by splice functions that +-- need some runtime data. +withSplices :: Monad n + => Splice n + -- ^ Splice to be run + -> Splices (RuntimeSplice n a -> Splice n) + -- ^ Splices to be bound first + -> RuntimeSplice n a + -- ^ Runtime data needed by the above splices + -> Splice n +withSplices splice splices runtimeAction = + withLocalSplices splices' noSplices splice + where + splices' = mapS ($runtimeAction) splices ------------------------------------------------------------------------------ --- | Allows you to use deferred Promises in a compiled splice. It takes care --- of the boilerplate of creating and storing data in a promise to be used at --- load time when compiled splices are processed. This function is similar to --- mapPromises but runs on a single value instead of a list. -defer :: Monad n - => (Promise a -> Splice n) - -> RuntimeSplice n a - -> Splice n -defer f getItem = do - promise <- newEmptyPromise - chunks <- f promise +-- | Like withSplices, but evaluates the splice repeatedly for each element in +-- a list generated at runtime. +manyWithSplices :: Monad n + => Splice n + -> Splices (RuntimeSplice n a -> Splice n) + -> RuntimeSplice n [a] + -> Splice n +manyWithSplices splice splices runtimeAction = do + p <- newEmptyPromise + let splices' = mapS ($ getPromise p) splices + chunks <- withLocalSplices splices' noSplices splice return $ yieldRuntime $ do - item <- getItem - putPromise promise item - codeGen chunks + items <- runtimeAction + res <- forM items $ \item -> putPromise p item >> codeGen chunks + return $ mconcat res ------------------------------------------------------------------------------ --- | Takes a promise function and a runtime action returning a list of items --- that fit in the promise and returns a Splice that executes the promise --- function for each item and concatenates the results. +-- | Similar to 'mapSplices' in interpreted mode. Gets a runtime list of +-- items and applies a compiled runtime splice function to each element of the +-- list. deferMany :: Monad n - => (Promise a -> Splice n) + => (RuntimeSplice n a -> Splice n) -> RuntimeSplice n [a] -> Splice n deferMany f getItems = do promise <- newEmptyPromise - chunks <- f promise + chunks <- f $ getPromise promise return $ yieldRuntime $ do items <- getItems res <- forM items $ \item -> do @@ -824,76 +660,53 @@ ------------------------------------------------------------------------------ --- | 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)] - -> 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 =<< runtimeAction - return $ fillPromise `mappend` chunks +-- | Saves the results of a runtme computation in a 'Promise' so they don't +-- get recalculated if used more than once. +deferMap :: Monad n + => (a -> RuntimeSplice n b) + -> (RuntimeSplice n b -> Splice n) + -> RuntimeSplice n a -> Splice n +deferMap f pf n = do + p2 <- newEmptyPromise + let action = yieldRuntimeEffect $ putPromise p2 =<< f =<< n + res <- pf $ getPromise p2 + return $ action `mappend` res ------------------------------------------------------------------------------ --- | Gets a list of items at runtime, then for each item it runs the splice --- with the list of splices bound. There is no pure variant of this function --- because the desired behavior can only be achieved as a function of a --- Promise. -manyWithSplices :: Monad n - => Splice n - -- ^ Splice to run for each of the items in the runtime list. - -- You'll frequently use 'runChildren' here. - -> [(Text, Promise a -> Splice n)] - -- ^ List of splices to bind - -> RuntimeSplice n [a] - -- ^ Runtime action returning a list of items to render. - -> Splice n -manyWithSplices splice splices runtimeAction = do - p <- newEmptyPromise - let splices' = mapSnd ($p) splices - chunks <- withLocalSplices splices' [] splice +-- | Like deferMap, but only runs the result if a Maybe function of the +-- runtime value returns Just. If it returns Nothing, then no output is +-- generated. +-- +-- This is a good example of how to do more complex flow control with +-- promises. The generalization of this abstraction is too complex to be +-- distilled to elegant high-level combinators. If you need to implement your +-- own special flow control, then you should use functions from the +-- `Heist.Compiled.LowLevel` module similarly to how it is done in the +-- implementation of this function. +mayDeferMap :: Monad n + => (a -> RuntimeSplice n (Maybe b)) + -> (RuntimeSplice n b -> Splice n) + -> RuntimeSplice n a -> Splice n +mayDeferMap f pf n = do + p2 <- newEmptyPromise + action <- pf $ getPromise p2 return $ yieldRuntime $ do - items <- runtimeAction - res <- forM items $ \item -> putPromise p item >> codeGen chunks - return $ mconcat res + mb <- f =<< n + case mb of + Nothing -> return mempty + Just b -> do + putPromise p2 b + codeGen action ------------------------------------------------------------------------------ --- | Like 'withSplices', but works for \"pure\" splices that don't operate in --- the HeistT monad. -withPureSplices :: Monad n - => Splice n - -> [(Text, a -> Builder)] - -> RuntimeSplice n a - -> Splice n -withPureSplices splice splices action = do - let fieldSplice g = return $ yieldRuntime $ liftM g action - let splices' = map (second fieldSplice) splices - withLocalSplices splices' [] splice +-- | Converts an RuntimeSplice into a Splice, given a helper function that +-- generates a Builder. +bindLater :: (Monad n) + => (a -> RuntimeSplice n Builder) + -> RuntimeSplice n a + -> Splice n +bindLater f p = return $ yieldRuntime $ f =<< p diff --git a/src/Heist/Compiled/LowLevel.hs b/src/Heist/Compiled/LowLevel.hs new file mode 100644 --- /dev/null +++ b/src/Heist/Compiled/LowLevel.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Heist.Compiled.LowLevel + ( + -- * Lower level promise functions + Promise + , newEmptyPromise + , getPromise + , putPromise + , adjustPromise + + ) where + +import Heist.Compiled.Internal diff --git a/src/Heist/Interpreted/Internal.hs b/src/Heist/Interpreted/Internal.hs --- a/src/Heist/Interpreted/Internal.hs +++ b/src/Heist/Interpreted/Internal.hs @@ -8,7 +8,6 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder -import Control.Arrow hiding (loop) import Control.Monad import Control.Monad.State.Strict import qualified Data.Attoparsec.Text as AP @@ -17,14 +16,13 @@ import qualified Data.HashMap.Strict as Map import qualified Data.HeterogeneousEnvironment as HE import Data.Maybe -import Data.Monoid import qualified Data.Text as T import Data.Text (Text) -import Prelude hiding (catch) import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist.Common +import Heist.SpliceAPI import Heist.Types @@ -32,13 +30,6 @@ ------------------------------------------------------------------------------ --- | Mappends a doctype to the state. -addDoctype :: Monad m => [X.DocType] -> HeistT n m () -addDoctype dt = do - modifyHS (\s -> s { _doctypes = _doctypes s `mappend` dt }) - - ------------------------------------------------------------------------------- -- HeistState functions ------------------------------------------------------------------------------ @@ -54,12 +45,12 @@ ------------------------------------------------------------------------------ -- | Binds a set of new splice declarations within a 'HeistState'. -bindSplices :: [(Text, Splice n)] -- ^ splices to bind +bindSplices :: Splices (Splice n) -- ^ splices to bind -> HeistState n -- ^ start state -> HeistState n bindSplices ss hs = foldl' (flip id) hs acts where - acts = map (uncurry bindSplice) ss + acts = map (uncurry bindSplice) $ splicesToList ss ------------------------------------------------------------------------------ @@ -81,7 +72,7 @@ -- | Binds a list of splices before using the children of the spliced node as -- a view. runChildrenWith :: (Monad n) - => [(Text, Splice n)] + => Splices (Splice n) -- ^ List of splices to bind before running the param nodes. -> Splice n -- ^ Returns the passed in view. @@ -94,22 +85,22 @@ runChildrenWithTrans :: (Monad n) => (b -> Splice n) -- ^ Splice generating function - -> [(Text, b)] + -> Splices b -- ^ List of tuples to be bound -> Splice n -runChildrenWithTrans f = runChildrenWith . map (second f) +runChildrenWithTrans f = runChildrenWith . mapS f ------------------------------------------------------------------------------ -- | Like runChildrenWith but using constant templates rather than dynamic -- splices. -runChildrenWithTemplates :: (Monad n) => [(Text, Template)] -> Splice n +runChildrenWithTemplates :: (Monad n) => Splices Template -> Splice n runChildrenWithTemplates = runChildrenWithTrans return ------------------------------------------------------------------------------ -- | Like runChildrenWith but using literal text rather than dynamic splices. -runChildrenWithText :: (Monad n) => [(Text, Text)] -> Splice n +runChildrenWithText :: (Monad n) => Splices Text -> Splice n runChildrenWithText = runChildrenWithTrans textSplice @@ -353,10 +344,10 @@ ------------------------------------------------------------------------------ -- | Binds a list of constant string splices. bindStrings :: Monad n - => [(Text, Text)] + => Splices Text -> HeistState n -> HeistState n -bindStrings pairs hs = foldr (uncurry bindString) hs pairs +bindStrings splices hs = foldr (uncurry bindString) hs $ splicesToList splices ------------------------------------------------------------------------------ @@ -376,11 +367,10 @@ -- returns an empty list. callTemplate :: Monad n => ByteString -- ^ The name of the template - -> [(Text, Splice n)] -- ^ Association list of - -- (name,value) parameter pairs + -> Splices (Splice n) -- ^ Splices to call the template with -> HeistT n n Template -callTemplate name params = do - modifyHS $ bindSplices params +callTemplate name splices = do + modifyHS $ bindSplices splices liftM (maybe [] id) $ evalTemplate name @@ -389,12 +379,9 @@ -- splices. callTemplateWithText :: Monad n => ByteString -- ^ The name of the template - -> [(Text, Text)] -- ^ Association list of - -- (name,value) parameter pairs + -> Splices Text -- ^ Splices to call the template with -> HeistT n n Template -callTemplateWithText name params = do - modifyHS $ bindStrings params - liftM (maybe [] id) $ evalTemplate name +callTemplateWithText name splices = callTemplate name $ mapS textSplice splices ------------------------------------------------------------------------------ @@ -420,7 +407,7 @@ -- using bindString, bindStrings, or bindSplice to set up the arguments to the -- template. renderWithArgs :: Monad n - => [(Text, Text)] + => Splices Text -> HeistState n -> ByteString -> n (Maybe (Builder, MIMEType)) diff --git a/src/Heist/SpliceAPI.hs b/src/Heist/SpliceAPI.hs new file mode 100644 --- /dev/null +++ b/src/Heist/SpliceAPI.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-| + +An API implementing a convenient syntax for defining and manipulating splices. +This module was born from the observation that a list of tuples is +semantically ambiguous about how duplicate keys should be handled. +Additionally, the syntax is inherently rather cumbersome and difficult to work +with. This API takes advantage of do notation to provide a very light syntax +for defining splices while at the same time eliminating the semantic ambiguity +of alists. + +Here's how you can define splices: + +> mySplices :: Splices Text +> mySplices = do +> "firstName" ## "John" +> "lastName" ## "Smith" + +-} + +module Heist.SpliceAPI where + +import Control.Monad.State +import Data.Map (Map) +import qualified Data.Map as M +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T + + +------------------------------------------------------------------------------ +-- | A monad providing convenient syntax for defining splices. +newtype SplicesM s a = SplicesM { unSplices :: State (Map Text s) a } + deriving (Monad, MonadState (Map Text s)) + + +------------------------------------------------------------------------------ +-- | Monoid instance does a union of the two maps with the second map +-- overwriting any duplicates. +instance Monoid (Splices s) where + mempty = noSplices + mappend = unionWithS (\_ b -> b) + + +------------------------------------------------------------------------------ +-- | Convenient type alias that will probably be used most of the time. +type Splices s = SplicesM s () + + +------------------------------------------------------------------------------ +-- | Forces a splice to be added. If the key already exists, its value is +-- overwritten. +(##) :: Text -> s -> Splices s +(##) tag splice = modify $ M.insert tag splice +infixr 0 ## + + +------------------------------------------------------------------------------ +-- | Tries to add a splice, but if the key already exists, then it throws an +-- error message. This may be useful if name collisions are bad and you want +-- to crash when they occur. +(#!) :: Text -> s -> Splices s +(#!) tag splice = modify $ M.insertWithKey err tag splice + where + err k _ _ = error $ "Key "++show k++" already exists in the splice map" +infixr 0 #! + + +------------------------------------------------------------------------------ +-- | Inserts into the map only if the key does not already exist. +(#?) :: Text -> s -> Splices s +(#?) tag splice = modify $ M.insertWith (const id) tag splice +infixr 0 #? + + +------------------------------------------------------------------------------ +-- | A `Splices` with nothing in it. +noSplices :: Splices s +noSplices = put M.empty + + +------------------------------------------------------------------------------ +-- | Runs the SplicesM monad, generating a map of splices. +runSplices :: SplicesM s a -> Map Text s +runSplices splices = execState (unSplices splices) M.empty + + +------------------------------------------------------------------------------ +-- | Constructs an alist representation. +splicesToList :: SplicesM s a -> [(Text, s)] +splicesToList = M.toList . runSplices + + +------------------------------------------------------------------------------ +-- | Maps a function over all the splices. +mapS :: (a -> b) -> Splices a -> Splices b +mapS f ss = put $ M.map f $ runSplices ss + + +------------------------------------------------------------------------------ +-- | Applies an argument to a splice function. +applyS :: a -> Splices (a -> b) -> Splices b +applyS a = mapS ($a) + + +------------------------------------------------------------------------------ +-- | Inserts a splice into the 'Splices'. +insertS :: Text -> s -> Splices s -> Splices s +insertS = insertWithS const + + +------------------------------------------------------------------------------ +-- | Inserts a splice with a function combining new value and old value. +insertWithS :: (s -> s -> s) -> Text -> s -> SplicesM s a2 -> SplicesM s () +insertWithS f k v b = put $ M.insertWith f k v (runSplices b) + + +------------------------------------------------------------------------------ +-- | Union of `Splices` with a combining function. +unionWithS :: (s -> s -> s) -> SplicesM s a1 -> SplicesM s a2 -> SplicesM s () +unionWithS f a b = put $ M.unionWith f (runSplices a) (runSplices b) + + +------------------------------------------------------------------------------ +-- | Infix operator for @flip applyS@ +($$) :: Splices (a -> b) -> a -> Splices b +($$) = flip applyS +infixr 0 $$ + + +------------------------------------------------------------------------------ +-- | Maps a function over all the splice names. +mapNames :: (Text -> Text) -> Splices a -> Splices a +mapNames f = put . M.mapKeys f . runSplices + + +-- The following two functions are formulated as functions of Splices instead +-- of a single splice because they operate on the splice names instead of the +-- splices themselves. + + +------------------------------------------------------------------------------ +-- | Adds a prefix to the tag names for a list of splices. If the existing +-- tag name is empty, then the new tag name is just the prefix. Otherwise the +-- new tag name is the prefix followed by the separator followed by the +-- existing name. +prefixSplices :: Text -> Text -> Splices a -> Splices a +prefixSplices sep pre = mapNames f + where + f t = if T.null t then pre else T.concat [pre,sep,t] + + +------------------------------------------------------------------------------ +-- | 'prefixSplices' specialized to use a colon as separator in the style of +-- XML namespaces. +namespaceSplices :: Text -> Splices a -> Splices a +namespaceSplices = prefixSplices ":" + diff --git a/src/Heist/Splices.hs b/src/Heist/Splices.hs --- a/src/Heist/Splices.hs +++ b/src/Heist/Splices.hs @@ -18,6 +18,7 @@ import Heist.Splices.Html import Heist.Splices.Ignore import Heist.Splices.Markdown +import Heist.Types ------------------------------------------------------------------------------ -- | Run the splice contents if given condition is True, make splice disappear @@ -34,12 +35,12 @@ -- function to determine whether the node's children should be rendered. ifCSplice :: Monad m => (t -> Bool) - -> C.Promise t + -> RuntimeSplice m t -> C.Splice m -ifCSplice predicate prom = do +ifCSplice predicate runtime = do chunks <- C.runChildren return $ C.yieldRuntime $ do - a <- C.getPromise prom + a <- runtime if predicate a then C.codeGen chunks diff --git a/src/Heist/Splices/Json.hs b/src/Heist/Splices/Json.hs --- a/src/Heist/Splices/Json.hs +++ b/src/Heist/Splices/Json.hs @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ import Heist.Interpreted.Internal +import Heist.SpliceAPI import Heist.Types ------------ @@ -161,9 +162,9 @@ go (Object o) = goObject o -------------------------------------------------------------------------- - goText t = lift $ runChildrenWith [ ("value" , return [TextNode t]) - , ("snippet" , asHtml t ) - ] + goText t = lift $ runChildrenWith $ do + "value" ## return [TextNode t] + "snippet" ## asHtml t -------------------------------------------------------------------------- goArray :: (Monad n) => V.Vector Value -> JsonMonad n n [Node] @@ -203,11 +204,12 @@ (findExpr expr v) -------------------------------------------------------------------------- - genericBindings :: Monad n => JsonMonad n n [(Text, Splice n)] - genericBindings = ask >>= \v -> return [ ("with", varAttrTag v explodeTag) - , ("snippet", varAttrTag v snippetTag) - , ("value", varAttrTag v valueTag ) - ] + genericBindings :: Monad n => JsonMonad n n (Splices (Splice n)) + genericBindings = ask >>= \v -> return $ do + "with" ## varAttrTag v explodeTag + "snippet" ## varAttrTag v snippetTag + "value" ## varAttrTag v valueTag + -------------------------------------------------------------------------- goObject obj = do @@ -217,8 +219,8 @@ -------------------------------------------------------------------------- bindKvp bindings k v = - let newBindings = [ (T.append "with:" k , withValue v explodeTag) - , (T.append "snippet:" k, withValue v snippetTag) - , (T.append "value:" k , withValue v valueTag ) - ] - in newBindings ++ bindings + let newBindings = do + T.append "with:" k ## withValue v explodeTag + T.append "snippet:" k ## withValue v snippetTag + T.append "value:" k ## withValue v valueTag + in unionWithS (\a _ -> a) newBindings bindings diff --git a/src/Heist/Splices/Markdown.hs b/src/Heist/Splices/Markdown.hs --- a/src/Heist/Splices/Markdown.hs +++ b/src/Heist/Splices/Markdown.hs @@ -26,7 +26,6 @@ import Control.Monad.CatchIO import Control.Monad.Trans import Data.Typeable -import Prelude hiding (catch) import System.Directory import System.Exit import System.FilePath.Posix diff --git a/src/Heist/Types.hs b/src/Heist/Types.hs --- a/src/Heist/Types.hs +++ b/src/Heist/Types.hs @@ -21,7 +21,8 @@ import Blaze.ByteString.Builder import Control.Applicative import Control.Arrow -import Control.Monad.CatchIO +import Control.Monad.CatchIO (MonadCatchIO) +import qualified Control.Monad.CatchIO as C import Control.Monad.Cont import Control.Monad.Error import Control.Monad.Reader @@ -37,7 +38,6 @@ import qualified Data.Text as T import Data.Text.Encoding import Data.Typeable -import Prelude hiding (catch) import qualified Text.XmlHtml as X import Debug.Trace @@ -295,9 +295,9 @@ instance MonadCatchIO m => MonadCatchIO (HeistT n m) where catch (HeistT a) h = HeistT $ \r s -> do let handler e = runHeistT (h e) r s - catch (a r s) handler - block (HeistT m) = HeistT $ \r s -> block (m r s) - unblock (HeistT m) = HeistT $ \r s -> unblock (m r s) + C.catch (a r s) handler + block (HeistT m) = HeistT $ \r s -> C.block (m r s) + unblock (HeistT m) = HeistT $ \r s -> C.unblock (m r s) ------------------------------------------------------------------------------ diff --git a/test/heist-testsuite.cabal b/test/heist-testsuite.cabal --- a/test/heist-testsuite.cabal +++ b/test/heist-testsuite.cabal @@ -35,7 +35,7 @@ transformers >= 0.2 && < 0.4, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.9 && < 0.11, - xmlhtml >= 0.2.1 && < 0.3 + xmlhtml >= 0.2.3 && < 0.3 ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded @@ -70,12 +70,13 @@ mtl >= 2.0 && < 2.2, process >= 1.1 && < 1.2, random >= 1.0.1.0 && < 1.1, + statistics < 0.10.4, text >= 0.10 && < 0.12, time >= 1.1 && < 1.5, transformers >= 0.2 && < 0.4, unordered-containers >= 0.1.4 && < 0.3, vector >= 0.9 && < 0.11, - xmlhtml >= 0.2.1 && < 0.3 + xmlhtml >= 0.2.3 && < 0.3 ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind -rtsopts diff --git a/test/suite/Benchmark.hs b/test/suite/Benchmark.hs --- a/test/suite/Benchmark.hs +++ b/test/suite/Benchmark.hs @@ -14,6 +14,7 @@ import Control.Monad import qualified Data.ByteString as B import qualified Data.DList as DL +import Data.Monoid import qualified Data.Text as T import Data.Text.Encoding import Data.Time.Clock @@ -31,7 +32,7 @@ loadWithCache baseDir = do etm <- runEitherT $ do - let hc = HeistConfig [] defaultLoadTimeSplices [] [] [loadTemplates baseDir] + let hc = HeistConfig mempty defaultLoadTimeSplices mempty mempty [loadTemplates baseDir] initHeistWithCacheTag hc either (error . unlines) (return . fst) etm diff --git a/test/suite/Heist/Compiled/Tests.hs b/test/suite/Heist/Compiled/Tests.hs --- a/test/suite/Heist/Compiled/Tests.hs +++ b/test/suite/Heist/Compiled/Tests.hs @@ -9,6 +9,7 @@ ------------------------------------------------------------------------------ import Heist.Tutorial.CompiledSplices +import Heist.TestCommon -- NOTE: We can't test compiled templates on the templates directory as it -- stands today because that directory contains some error conditions such as @@ -26,7 +27,7 @@ H.assertEqual "compiled state splice" expected res where expected = - " 3 " + "\n 3 " peopleTest :: IO () peopleTest = do 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 @@ -85,7 +85,7 @@ let result = buildResult bind spliceResult <- run $ do - hs <- loadEmpty defaultLoadTimeSplices [] [] [] + hs <- loadEmpty defaultLoadTimeSplices mempty mempty mempty evalHeistT (runNodeList template) (X.TextNode "") hs @@ -106,7 +106,7 @@ ------------------------------------------------------------------------------ addTest :: IO () addTest = do - es <- loadEmpty [] [] [] [] + es <- loadEmpty mempty mempty mempty mempty let hs = addTemplate "aoeu" [] Nothing es H.assertEqual "lookup test" (Just []) $ fmap (X.docContent . dfDoc . fst) $ @@ -116,9 +116,9 @@ ------------------------------------------------------------------------------ hasTemplateTest :: H.Assertion hasTemplateTest = do - ets <- loadIO "templates" [] [] [] [] + ets <- loadIO "templates" mempty mempty mempty mempty let tm = either (error "Error loading templates") _templateMap ets - hs <- loadEmpty [] [] [] [] + hs <- loadEmpty mempty mempty mempty mempty let hs's = setTemplates tm hs H.assertBool "hasTemplate hs's" (hasTemplate "index" hs's) @@ -135,7 +135,7 @@ ------------------------------------------------------------------------------ loadTest :: H.Assertion loadTest = do - ets <- loadIO "templates" [] [] [] [] + ets <- loadIO "templates" mempty mempty mempty mempty either (error "Error loading templates") (\ts -> do let tm = _templateMap ts H.assertEqual "loadTest size" 37 $ Map.size tm @@ -145,9 +145,9 @@ ------------------------------------------------------------------------------ fsLoadTest :: H.Assertion fsLoadTest = do - ets <- loadIO "templates" [] [] [] [] + ets <- loadIO "templates" mempty mempty mempty mempty let tm = either (error "Error loading templates") _templateMap ets - es <- loadEmpty [] [] [] [] + es <- loadEmpty mempty mempty mempty mempty let hs = setTemplates tm es let f = g hs @@ -163,7 +163,7 @@ ------------------------------------------------------------------------------ renderNoNameTest :: H.Assertion renderNoNameTest = do - ets <- loadT "templates" [] [] [] [] + ets <- loadT "templates" mempty mempty mempty mempty either (error "Error loading templates") (\ts -> do t <- renderTemplate ts "" H.assertBool "renderNoName" $ isNothing t @@ -173,7 +173,7 @@ ------------------------------------------------------------------------------ doctypeTest :: H.Assertion doctypeTest = do - ets <- loadT "templates" [] [] [] [] + ets <- loadT "templates" mempty mempty mempty mempty let ts = either (error "Error loading templates") id ets Just (indexDoc, _) <- renderTemplate ts "index" H.assertEqual "index doctype test" indexRes $ toByteString $ indexDoc @@ -188,14 +188,14 @@ ------------------------------------------------------------------------------ attrSubstTest :: H.Assertion attrSubstTest = do - ets <- loadT "templates" [] [] [] [] + ets <- loadT "templates" mempty mempty mempty mempty let ts = either (error "Error loading templates") id ets check "attr subst 1" (bindSplices splices ts) out1 check "attr subst 2" ts out2 where - splices = defaultLoadTimeSplices ++ - [("foo", return [X.TextNode "meaning_of_everything"])] + splices = defaultLoadTimeSplices `mappend` + ("foo" ## return [X.TextNode "meaning_of_everything"]) check str ts expected = do Just (resDoc, _) <- renderTemplate ts "attrs" @@ -216,7 +216,7 @@ ------------------------------------------------------------------------------ bindAttrTest :: H.Assertion bindAttrTest = do - ets <- loadT "templates" [] [] [] [] + ets <- loadT "templates" mempty mempty mempty mempty let ts = either (error "Error loading templates") id ets check ts "
ByteString -- ^ expected result -> H.Assertion renderTest templateName expectedResult = do - ets <- loadT "templates" [] [] [] [] + ets <- loadT "templates" mempty mempty mempty mempty let ts = either (error "Error loading templates") id ets check ts expectedResult @@ -279,15 +279,15 @@ v = fromJust $ decode txt check ts0 str = do - let ts = bindSplices [ - ("json", bind "[\"ok\", 1, null, false, \"foo\"]") - , ("jsonObject", - bind $ mconcat [ + let splices = do + "json" ## bind "[\"ok\", 1, null, false, \"foo\"]" + "jsonObject" ## + (bind $ mconcat [ "{\"foo\": 1, \"bar\": \"ok\", " , "\"baz\": { \"baz1\": 1, \"baz2\": 2 }, " , "\"quux\": \"quux\" }" ]) - ] ts0 + let ts = bindSplices splices ts0 Just (doc, _) <- renderTemplate ts templateName let result = B.filter (/= '\n') (toByteString doc) H.assertEqual ("Should match " ++ (show str)) str result @@ -335,7 +335,7 @@ -- | Markdown test on supplied text markdownTextTest :: H.Assertion markdownTextTest = do - hs <- loadEmpty [] [] [] [] + hs <- loadEmpty mempty mempty mempty mempty result <- evalHeistT markdownSplice (X.TextNode "This *is* a test.") hs @@ -347,7 +347,7 @@ ------------------------------------------------------------------------------ applyTest :: H.Assertion applyTest = do - es <- loadEmpty [] [] [] [] + es <- loadEmpty mempty mempty mempty mempty res <- evalHeistT applyImpl (X.Element "apply" [("template", "nonexistant")] []) es @@ -357,7 +357,7 @@ ------------------------------------------------------------------------------ ignoreTest :: H.Assertion ignoreTest = do - es <- loadEmpty [] [] [] [] + es <- loadEmpty mempty mempty mempty mempty res <- evalHeistT ignoreImpl (X.Element "ignore" [("tag", "ignorable")] [X.TextNode "This should be ignored"]) es @@ -518,7 +518,7 @@ , L.unpack $ L.concat $ map formatNode $ buildResult b , "Splice result:" , L.unpack $ L.concat $ map formatNode $ unsafePerformIO $ do - hs <- loadEmpty [] [] [] [] + hs <- loadEmpty mempty mempty mempty mempty evalHeistT (runNodeList $ buildBindTemplate b) (X.TextNode "") hs , "Template:" @@ -595,7 +595,7 @@ ------------------------------------------------------------------------------ calcResult :: Apply -> IO [X.Node] calcResult apply@(Apply name _ callee _ _) = do - hs <- loadEmpty defaultLoadTimeSplices [] [] [] + hs <- loadEmpty defaultLoadTimeSplices mempty mempty mempty let hs' = setTemplates (Map.singleton [T.encodeUtf8 $ unName name] (DocumentFile (X.HtmlDocument X.UTF8 Nothing callee) Nothing)) hs 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 @@ -8,7 +8,6 @@ import qualified Data.ByteString.Char8 as B import Data.Maybe import Data.Monoid -import Data.Text (Text) ------------------------------------------------------------------------------ @@ -29,27 +28,27 @@ loadT :: MonadIO m => FilePath - -> [(Text, I.Splice m)] - -> [(Text, I.Splice IO)] - -> [(Text, C.Splice m)] - -> [(Text, AttrSplice m)] + -> Splices (I.Splice m) + -> Splices (I.Splice IO) + -> Splices (C.Splice m) + -> Splices (AttrSplice m) -> IO (Either [String] (HeistState m)) loadT baseDir a b c d = runEitherT $ do - let hc = HeistConfig (defaultInterpretedSplices ++ a) - (defaultLoadTimeSplices ++ b) c d [loadTemplates baseDir] + let hc = HeistConfig (defaultInterpretedSplices `mappend` a) + (defaultLoadTimeSplices `mappend` b) c d [loadTemplates baseDir] initHeist hc ------------------------------------------------------------------------------ loadIO :: FilePath - -> [(Text, I.Splice IO)] - -> [(Text, I.Splice IO)] - -> [(Text, C.Splice IO)] - -> [(Text, AttrSplice IO)] + -> Splices (I.Splice IO) + -> Splices (I.Splice IO) + -> Splices (C.Splice IO) + -> Splices (AttrSplice IO) -> IO (Either [String] (HeistState IO)) loadIO baseDir a b c d = runEitherT $ do - let hc = HeistConfig (defaultInterpretedSplices ++ a) - (defaultLoadTimeSplices ++ b) c d [loadTemplates baseDir] + let hc = HeistConfig (defaultInterpretedSplices `mappend` a) + (defaultLoadTimeSplices `mappend` b) c d [loadTemplates baseDir] initHeist hc @@ -58,19 +57,19 @@ loadHS baseDir = do etm <- runEitherT $ do let hc = HeistConfig defaultInterpretedSplices - defaultLoadTimeSplices [] [] [loadTemplates baseDir] + defaultLoadTimeSplices mempty mempty [loadTemplates baseDir] initHeist hc either (error . concat) return etm -loadEmpty :: [(Text, I.Splice IO)] - -> [(Text, I.Splice IO)] - -> [(Text, C.Splice IO)] - -> [(Text, AttrSplice IO)] +loadEmpty :: Splices (I.Splice IO) + -> Splices (I.Splice IO) + -> Splices (C.Splice IO) + -> Splices (AttrSplice IO) -> IO (HeistState IO) loadEmpty a b c d = do - let hc = HeistConfig (defaultInterpretedSplices ++ a) - (defaultLoadTimeSplices ++ b) c d mempty + let hc = HeistConfig (defaultInterpretedSplices `mappend` a) + (defaultLoadTimeSplices `mappend` b) c d mempty res <- runEitherT $ initHeist hc either (error . concat) return res diff --git a/test/suite/Heist/Tests.hs b/test/suite/Heist/Tests.hs --- a/test/suite/Heist/Tests.hs +++ b/test/suite/Heist/Tests.hs @@ -43,7 +43,7 @@ -- | Tests that load fails correctly on errors. loadErrorsTest :: H.Assertion loadErrorsTest = do - ets <- loadIO "templates-bad" [] [] [] [] + ets <- loadIO "templates-bad" mempty mempty mempty mempty either (H.assertEqual "load errors test" expected . sort) (const $ H.assertFailure "No failure when loading templates-bad") ets @@ -58,7 +58,8 @@ attrSpliceTest :: IO () attrSpliceTest = do - ehs <- loadT "templates" [] [] [] [("autocheck", lift . autocheckedSplice)] + ehs <- loadT "templates" mempty mempty mempty + ("autocheck" ## lift . autocheckedSplice) let hs = either (error . show) id ehs runtime = fromJust $ C.renderTemplate hs "attr_splice" @@ -89,9 +90,9 @@ tdirCacheTest :: IO () tdirCacheTest = do - let rSplices = [ ("foosplice", fooSplice) ] - dSplices = [ ("foosplice", stateSplice) ] - hc = HeistConfig rSplices [] dSplices [] mempty + let rSplices = ("foosplice" ## fooSplice) + dSplices = ("foosplice" ## stateSplice) + hc = HeistConfig rSplices mempty dSplices mempty mempty td <- newTemplateDirectory' "templates" hc [a,b,c,d] <- evalStateT (testInterpreted td) 5 @@ -140,7 +141,7 @@ headMergeTest :: IO () headMergeTest = do - ehs <- loadT "templates" [] [(htmlTag, htmlImpl)] [] [] + ehs <- loadT "templates" mempty (htmlTag ## htmlImpl) mempty mempty let hs = either (error . show) id ehs runtime = fromJust $ C.renderTemplate hs "head_merge/index" mres <- fst runtime 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 @@ -27,6 +27,12 @@ > import qualified Heist.Compiled as C > import Heist.Tutorial.Imports +> import Control.Applicative +> import qualified Data.Text as T +> import Data.Text.Encoding +> import qualified Heist.Compiled.LowLevel as C +> import Text.XmlHtml + As a review, normal (interpreted) Heist splices are defined like this. < type Splice m = HeistT m m [Node] @@ -103,11 +109,11 @@ > load :: MonadIO n > => FilePath -> -> [(Text, C.Splice n)] +> -> Splices (C.Splice n) > -> IO (HeistState n) > load baseDir splices = do > tmap <- runEitherT $ do -> let hc = HeistConfig [] defaultLoadTimeSplices splices [] +> let hc = HeistConfig mempty defaultLoadTimeSplices splices mempty > [loadTemplates baseDir] > initHeist hc > either (error . concat) return tmap @@ -117,7 +123,7 @@ > runWithStateSplice :: FilePath > -> IO ByteString > runWithStateSplice baseDir = do -> hs <- load baseDir [ ("div", stateSplice) ] +> hs <- load baseDir ("div" ## stateSplice) > let runtime = fromJust $ C.renderTemplate hs "index" > builder <- evalStateT (fst runtime) 2 > return $ toByteString builder @@ -139,19 +145,17 @@ > , pAge :: Int > } > -> personSplice :: (Monad n) -> => C.Promise Person -> -> HeistT n IO (RuntimeSplice n Builder) -> personSplice = C.promiseChildrenWithText -> [ ("firstName", pFirstName) -> , ("lastName", pLastName) -> , ("age", pack . show . pAge) -> ] +> personSplices :: Monad n +> => Splices (RuntimeSplice n Person -> C.Splice n) +> personSplices = mapS (C.pureSplice . C.textSplice) $ do +> "firstName" ## pFirstName +> "lastName" ## pLastName +> "age" ## pack . show . pAge > > peopleSplice :: (Monad n) > => RuntimeSplice n [Person] > -> C.Splice n -> peopleSplice getPeople = C.mapPromises personSplice getPeople +> peopleSplice = C.manyWithSplices C.runChildren personSplices > > allPeopleSplice :: C.Splice (StateT [Person] IO) > allPeopleSplice = peopleSplice (lift get) @@ -159,7 +163,7 @@ > personListTest :: FilePath > -> IO ByteString > personListTest baseDir = do -> hs <- load baseDir [ ("people", allPeopleSplice) ] +> hs <- load baseDir ("people" ## allPeopleSplice) > let runtime = fromJust $ C.renderTemplate hs "people" > builder <- evalStateT (fst runtime) > [ Person "John" "Doe" 42 @@ -246,24 +250,25 @@ < failingSplice = do < children <- childNodes <$> getParamNode < promise <- C.newEmptyPromise -< outputChildren <- C.promiseChildrenWithNodes splices promise +< outputChildren <- C.withSplices C.runChildren splices (C.getPromise promise) < return $ C.yieldRuntime $ do < -- :: RuntimeSplice m Builder < mname <- lift $ getParam "username" < let err = return $ fromByteString "Must supply a username" < single name = do -< euser <- liftIO $ lookupUser $ decodeUtf8 name +< euser <- lift $ lookupUser name < either (return . fromByteString . encodeUtf8 . T.pack) < doUser euser < where < doUser value = do < C.putPromise promise (name, value) -< outputChildren +< C.codeGen outputChildren < maybe err single mname < < -< splices :: [(Text, (Text, Text) -> [Node])] -< splices = [ ("user", (:[]) . TextNode . T.pack . fst) -< , ("value", (:[]) . TextNode . T.pack . snd) -< ] +< splices :: Monad n +< => Splices (RuntimeSplice n (Text, Text) -> C.Splice n) +< splices = mapS (C.pureSplice . C.nodeSplice) $ do +< "user" ## (:[]) . TextNode . fst +< "value" ## (:[]) . TextNode . snd