Skip to content
Browse files

Switch to side-by-side implementation of caper

  • Loading branch information...
1 parent 6b3281f commit ffc3aea3e48edc87ce7f2f5ae065f3404a865467 @mightybyte mightybyte committed
View
3 heist.cabal
@@ -80,6 +80,7 @@ Library
Text.Templating.Heist.TemplateDirectory
other-modules:
+ Text.Templating.Heist.Common,
Text.Templating.Heist.Internal,
Text.Templating.Heist.Types
@@ -93,7 +94,9 @@ Library
containers >= 0.2 && < 0.6,
directory,
directory-tree,
+ dlist >= 0.5 && < 0.6,
filepath,
+ hashable >= 1.1 && < 1.2,
MonadCatchIO-transformers >= 0.2.1 && < 0.4,
mtl >= 2.0 && < 2.2,
process,
View
735 src/Caper.hs
@@ -0,0 +1,735 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Caper where
+-- (
+-- -- * Types
+-- Template
+-- , MIMEType
+-- , CaperSplice
+-- , HeistT
+-- , HeistState
+-- , evalHeistT
+-- , templateNames
+-- , spliceNames
+--
+-- -- * Functions and declarations on HeistState values
+-- , addTemplate
+-- , addXMLTemplate
+-- , defaultHeistState
+-- , bindSplice
+-- , bindSplices
+-- , lookupCaperSplice
+-- , setTemplates
+-- , loadTemplates
+-- , hasTemplate
+-- , addTemplatePathPrefix
+--
+-- -- * Hook functions
+-- -- $hookDoc
+-- , addOnLoadHook
+-- , addPreRunHook
+-- , addPostRunHook
+--
+-- -- * HeistT functions
+-- , stopRecursion
+-- , getParamNode
+-- , runNodeList
+-- , getContext
+-- , getTemplateFilePath
+--
+-- , localParamNode
+-- , getsTS
+-- , getTS
+-- , putTS
+-- , modifyTS
+-- , restoreTS
+-- , localTS
+--
+-- -- * Functions for running splices and templates
+-- , evalTemplate
+-- , callTemplate
+-- , callTemplateWithText
+-- , renderTemplate
+-- , renderWithArgs
+-- , bindStrings
+-- , bindString
+--
+-- -- * Functions for creating splices
+-- , textSplice
+-- , runChildren
+-- , runChildrenWith
+-- , runChildrenWithTrans
+-- , runChildrenWithTemplates
+-- , runChildrenWithText
+-- , mapSplices
+--
+-- -- * Misc functions
+-- , getDoc
+-- , getXMLDoc
+-- , mkCacheTag
+-- ) where
+
+import Blaze.ByteString.Builder
+import Blaze.ByteString.Builder.ByteString
+import Control.Applicative
+import Control.Arrow
+import Control.Exception
+import Control.Monad.RWS.Strict
+import Control.Monad.State.Strict
+import qualified Data.Attoparsec.Text as AP
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as S
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.DList (DList)
+import qualified Data.DList as DL
+import Data.Either
+import qualified Data.Foldable as F
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as H
+import Data.HeterogeneousEnvironment (HeterogeneousEnvironment)
+import qualified Data.HeterogeneousEnvironment as HE
+import Data.List (foldl', isSuffixOf)
+import Data.Maybe
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.Lazy as LT
+import qualified Data.Vector as V
+import Prelude hiding (catch)
+import System.Directory.Tree hiding (name)
+import System.FilePath
+import Text.Blaze.Html
+import qualified Text.Blaze.Html as Blaze
+import Text.Blaze.Internal
+import qualified Text.Blaze.Html.Renderer.String as BlazeString
+import qualified Text.Blaze.Html.Renderer.Text as BlazeText
+import Text.Blaze.Html.Renderer.Utf8
+import Text.Templating.Heist.Common
+import Text.Templating.Heist.Types
+import qualified Text.XmlHtml as X
+
+import Debug.Trace
+
+-- $hookDoc
+-- Heist hooks allow you to modify templates when they are loaded and before
+-- and after they are run. Every time you call one of the addAbcHook
+-- functions the hook is added to onto the processing pipeline. The hooks
+-- processes the template in the order that they were added to the
+-- HeistState.
+--
+-- The pre-run and post-run hooks are run before and after every template is
+-- run/rendered. You should be careful what code you put in these hooks
+-- because it can significantly affect the performance of your site.
+
+{-
+
+dlistRunNode :: Monad m
+ => X.Node
+ -> HeistT (Output m1) m (Output m1)
+dlistRunNode (X.Element nm attrs ch) = do
+ -- Parse the attributes: we have Left for static and Right for runtime
+ -- TODO: decide: do we also want substitution in the key?
+ compiledAttrs <- mapM attSubst attrs
+ childHtml <- runNodeList ch
+ return $ DL.concat [ DL.singleton $ Pure tag0
+ , DL.concat $ map renderAttr compiledAttrs
+ , DL.singleton $ Pure ">"
+ , childHtml
+ , DL.singleton $ Pure end
+ ]
+ where
+ tag0 = T.append "<" nm
+ end = T.concat [ "</" , nm , ">"]
+ renderAttr (n,v) = DL.concat [ DL.singleton $ Pure $ T.append " " n
+ , DL.singleton $ Pure "="
+ , v ]
+dlistRunNode (X.TextNode t) = return $ textSplice t
+dlistRunNode (X.Comment t) = return $ textSplice t
+
+
+
+------------------------------------------------------------------------------
+-- | Renders a template with the specified arguments passed to it. This is a
+-- convenience function for the common pattern of calling renderTemplate after
+-- using bindString, bindStrings, or bindSplice to set up the arguments to the
+-- template.
+renderWithArgs :: Monad m
+ => [(Text, Text)]
+ -> HeistState (Output m) m
+ -> ByteString
+ -> m (Maybe (Builder, MIMEType))
+renderWithArgs args ts = renderTemplate (bindStrings args ts)
+
+
+------------------------------------------------------------------------------
+-- | Renders a template from the specified HeistState to a 'Builder'. The
+-- MIME type returned is based on the detected character encoding, and whether
+-- the root template was an HTML or XML format template. It will always be
+-- @text/html@ or @text/xml@. If a more specific MIME type is needed for a
+-- particular XML application, it must be provided by the application.
+renderTemplate :: Monad m
+ => HeistState (Output m) m
+ -> ByteString
+ -> m (Maybe (Builder, MIMEType))
+renderTemplate ts name = evalHeistT tpl (X.TextNode "") ts
+ where
+ tpl = lookupAndRun name $ \(t,ctx) -> do
+ addDoctype $ maybeToList $ X.docType $ cdfDoc t
+ localTS (\ts' -> ts' {_curContext = ctx}) $ do
+ res <- runNodeList $ X.docContent $ cdfDoc t
+ return $ Just (res, mimeType $ cdfDoc t)
+
+-}
+
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+------------------------------------------------------------------------------
+runNodeList :: (Monad m) => Template -> CaperSplice n m
+runNodeList nodes = liftM DL.concat $ mapM runNode nodes
+
+
+------------------------------------------------------------------------------
+lookupCompiledTemplate :: ByteString
+ -> CompiledTemplateMap m
+ -> Maybe (m Builder)
+lookupCompiledTemplate nm (CompiledTemplateMap m) = H.lookup nm m
+
+
+------------------------------------------------------------------------------
+runSplice :: (Monad n)
+ => X.Node
+ -> HeistState n IO
+ -> CaperSplice n IO
+ -> IO (n Builder)
+runSplice node hs splice = do
+ (!a,_) <- runHeistT splice node hs
+ return $! (flip evalStateT HE.empty $! unRT $! codeGen a)
+
+
+------------------------------------------------------------------------------
+runDocumentFile :: (Monad m)
+ => TPath
+ -> DocumentFile
+ -> CaperSplice n m
+runDocumentFile tpath df = do
+ modifyTS (setCurTemplateFile curPath . setCurContext tpath)
+ runNodeList nodes
+ where
+ curPath = dfFile df
+ nodes = X.docContent $ dfDoc df
+
+
+------------------------------------------------------------------------------
+compileTemplate :: Monad n
+ => HeistState n IO
+ -> TPath
+ -> DocumentFile
+ -> IO (n Builder)
+compileTemplate ss tpath df = do
+ runSplice nullNode ss $ runDocumentFile tpath df
+ where
+ -- This gets overwritten in runDocumentFile
+ nullNode = X.TextNode ""
+
+
+------------------------------------------------------------------------------
+compileTemplates :: Monad n => HeistState n IO -> IO (CompiledTemplateMap n)
+compileTemplates hs =
+ liftM CompiledTemplateMap $ foldM runOne H.empty tpathDocfiles
+ where
+ tpathDocfiles :: [(TPath, ByteString, DocumentFile)]
+ tpathDocfiles = map (\(a,b) -> (a, tpathToPath a, b))
+ (H.toList $ _templateMap hs)
+
+ tpathToPath tp = S.intercalate "/" $ reverse tp
+
+ runOne tmap (tpath, nm, df) = do
+ mHtml <- compileTemplate hs tpath df
+ return $! H.insert nm mHtml tmap
+
+
+------------------------------------------------------------------------------
+-- | Given a list of output chunks, consolidate turns consecutive runs of
+-- @Pure Html@ values into maximally-efficient pre-rendered strict
+-- 'ByteString' chunks.
+codeGen :: Monad m => DList (Chunk m) -> RuntimeSplice m Builder
+codeGen = compileConsolidated . consolidate . DL.toList
+ where
+ consolidate :: (Monad m) => [Chunk m] -> [Chunk m]
+ consolidate [] = []
+ consolidate (y:ys) = boilDown [] $! go [] y ys
+ where
+ ----------------------------------------------------------------------
+ go soFar x [] = x : soFar
+
+ go soFar (Pure a) ((Pure b) : xs) =
+ go soFar (Pure $! a `mappend` b) xs
+
+ go soFar (RuntimeHtml a) ((RuntimeHtml b) : xs) =
+ go soFar (RuntimeHtml $! a `mappend` b) xs
+
+ go soFar (RuntimeHtml a) ((RuntimeAction b) : xs) =
+ go soFar (RuntimeHtml $! a >>= \x -> b >> return x) xs
+
+ go soFar (RuntimeAction a) ((RuntimeHtml b) : xs) =
+ go soFar (RuntimeHtml $! a >> b) xs
+
+ go soFar (RuntimeAction a) ((RuntimeAction b) : xs) =
+ go soFar (RuntimeAction $! a >> b) xs
+
+ go soFar a (b : xs) = go (a : soFar) b xs
+
+ ----------------------------------------------------------------------
+ -- FIXME Why isn't this used?
+ --render h = unsafeByteString $! S.concat $! L.toChunks $! renderHtml h
+
+ ----------------------------------------------------------------------
+ boilDown soFar [] = soFar
+
+ boilDown soFar ((Pure h) : xs) = boilDown ((Pure $! h) : soFar) xs
+
+ boilDown soFar (x : xs) = boilDown (x : soFar) xs
+
+
+ --------------------------------------------------------------------------
+ compileConsolidated :: (Monad m) => [Chunk m] -> RuntimeSplice m Builder
+ compileConsolidated l = V.foldr mappend mempty v
+ where
+ toAct (RuntimeHtml m) = liftM (fromByteString . T.encodeUtf8) m
+ toAct (Pure h) = return $ fromByteString $ T.encodeUtf8 h
+ toAct (RuntimeAction m) = m >> return mempty
+
+ !v = V.map toAct $! V.fromList l
+ {-# INLINE compileConsolidated #-}
+{-# INLINE codeGen #-}
+
+
+------------------------------------------------------------------------------
+yieldChunk :: Monad m => a -> m (DList a)
+yieldChunk = return . DL.singleton
+{-# INLINE yieldChunk #-}
+
+
+------------------------------------------------------------------------------
+yield :: (Monad m) => Text -> CaperSplice n m
+yield = yieldChunk . Pure
+{-# INLINE yield #-}
+
+
+------------------------------------------------------------------------------
+yieldRuntimeSplice :: (Monad m) => RuntimeSplice n () -> CaperSplice n m
+yieldRuntimeSplice = yieldChunk . RuntimeAction
+{-# INLINE yieldRuntimeSplice #-}
+
+
+------------------------------------------------------------------------------
+yieldRuntimeHtml :: (Monad m) => RuntimeSplice n Text -> CaperSplice n m
+yieldRuntimeHtml = yieldChunk . RuntimeHtml
+{-# INLINE yieldRuntimeHtml #-}
+
+
+------------------------------------------------------------------------------
+yieldLater :: (Monad n, Monad m) => n Text -> CaperSplice n m
+yieldLater = yieldRuntimeHtml . RuntimeSplice . lift
+{-# INLINE yieldLater #-}
+
+
+------------------------------------------------------------------------------
+yieldPromise :: (Monad m, Monad n) => Promise Text -> CaperSplice n m
+yieldPromise p = yieldRuntimeHtml $ getPromise p
+{-# INLINE yieldPromise #-}
+
+
+------------------------------------------------------------------------------
+lookupCaperSplice :: Monad m => Text -> HeistT n m (Maybe (CaperSplice n m))
+lookupCaperSplice nm = getsTS (H.lookup nm . _caperSpliceMap)
+
+
+------------------------------------------------------------------------------
+runNode :: (Monad m) => X.Node -> CaperSplice n m
+runNode node = localParamNode (const node) $ do
+ isStatic <- subtreeIsStatic node
+ if isStatic
+ then yield $! T.decodeUtf8
+ $! toByteString
+ $! X.renderHtmlFragment X.UTF8 [node]
+ else compileNode node
+
+
+------------------------------------------------------------------------------
+subtreeIsStatic :: Monad m => X.Node -> HeistT n m Bool
+subtreeIsStatic (X.Element nm attrs ch) = do
+ isNodeDynamic <- liftM isJust $ lookupCaperSplice nm
+ if isNodeDynamic
+ then return False
+ else do
+ let hasDynamicAttrs = any hasSubstitutions attrs
+ if hasDynamicAttrs
+ then return False
+ else do
+ staticSubtrees <- mapM subtreeIsStatic ch
+ return $ and staticSubtrees
+ where
+ hasSubstitutions (k,v) = hasAttributeSubstitutions k ||
+ hasAttributeSubstitutions v
+
+subtreeIsStatic _ = return True
+
+
+------------------------------------------------------------------------------
+hasAttributeSubstitutions :: Text -> Bool
+hasAttributeSubstitutions txt = all isLiteral ast
+ where
+ ast = case AP.feed (AP.parse attParser txt) "" of
+ (AP.Done _ res) -> res
+ (AP.Fail _ _ _) -> []
+ (AP.Partial _ ) -> []
+
+
+------------------------------------------------------------------------------
+-- | Given a 'X.Node' in the DOM tree, produces a \"runtime splice\" that will
+-- generate html at runtime. Leaves the writer monad state untouched.
+compileNode :: (Monad m) => X.Node -> CaperSplice n m
+compileNode (X.Element nm attrs ch) =
+ -- Is this node a splice, or does it merely contain splices?
+ lookupCaperSplice nm >>= fromMaybe compileStaticElement
+ where
+ tag0 = T.append "<" nm
+ end = T.concat [ "</" , nm , ">"]
+ -- If the tag is not a splice, but it contains dynamic children
+ compileStaticElement = do
+ -- Parse the attributes: we have Left for static and Right for runtime
+ -- TODO: decide: do we also want substitution in the key?
+ compiledAttrs <- mapM parseAtt attrs
+
+ childHtml <- runNodeList ch
+
+ return $ DL.concat [ DL.singleton $ Pure tag0
+ , DL.concat compiledAttrs
+ , DL.singleton $ Pure ">"
+ , childHtml
+ , DL.singleton $ Pure end
+ ]
+compileNode _ = error "impossible"
+
+
+------------------------------------------------------------------------------
+-- | If this function returns a 'Nothing', there are no dynamic splices in the
+-- attribute text, and you can just spit out the text value statically.
+-- Otherwise, the splice has to be resolved at runtime.
+parseAtt :: Monad m => (Text, Text) -> HeistT n m (DList (Chunk n))
+parseAtt (k,v) = do
+ let ast = case AP.feed (AP.parse attParser v) "" of
+ (AP.Done _ res) -> res
+ (AP.Fail _ _ _) -> []
+ (AP.Partial _ ) -> []
+ chunks <- mapM cvt ast
+ let value = DL.concat chunks
+ return $ DL.concat [ DL.singleton $ Pure $ T.concat [" ", k, "=\""]
+ , value, DL.singleton $ Pure "\"" ]
+ where
+ cvt (Literal x) = return $ DL.singleton $ Pure x
+ cvt (Ident x) =
+ localParamNode (const $ X.Element x [] []) $ getAttributeSplice x
+
+
+------------------------------------------------------------------------------
+getAttributeSplice :: Monad m => Text -> HeistT n m (DList (Chunk n))
+getAttributeSplice name =
+ lookupCaperSplice name >>= fromMaybe (return DL.empty)
+{-# INLINE getAttributeSplice #-}
+
+
+------------------------------------------------------------------------------
+getPromise :: (Monad m) => Promise a -> RuntimeSplice m a
+getPromise (Promise k) = do
+ mb <- gets (HE.lookup k)
+ return $ fromMaybe err mb
+
+ where
+ err = error $ "getPromise: dereferenced empty key (id "
+ ++ show (HE.getKeyId k) ++ ")"
+{-# INLINE getPromise #-}
+
+
+------------------------------------------------------------------------------
+putPromise :: (Monad m) => Promise a -> a -> RuntimeSplice m ()
+putPromise (Promise k) x = modify (HE.insert k x)
+{-# INLINE putPromise #-}
+
+
+------------------------------------------------------------------------------
+adjustPromise :: Monad m => Promise a -> (a -> a) -> RuntimeSplice m ()
+adjustPromise (Promise k) f = modify (HE.adjust f k)
+{-# INLINE adjustPromise #-}
+
+
+------------------------------------------------------------------------------
+newEmptyPromise :: MonadIO m => HeistT n m (Promise a)
+newEmptyPromise = do
+ keygen <- getsTS _keygen
+ key <- liftIO $ HE.makeKey keygen
+ return $! Promise key
+{-# INLINE newEmptyPromise #-}
+
+
+------------------------------------------------------------------------------
+newEmptyPromiseWithError :: (Monad n, MonadIO m)
+ => String -> HeistT n m (Promise a)
+newEmptyPromiseWithError from = do
+ keygen <- getsTS _keygen
+ prom <- liftM Promise $ liftIO $ HE.makeKey keygen
+
+ yieldRuntimeSplice $ putPromise prom
+ $ error
+ $ "deferenced empty promise created at" ++ from
+
+ return prom
+{-# INLINE newEmptyPromiseWithError #-}
+
+
+------------------------------------------------------------------------------
+promise :: (Monad n, MonadIO m) => n a -> HeistT n m (Promise a)
+promise act = runtimeSplicePromise (lift act)
+{-# INLINE promise #-}
+
+
+------------------------------------------------------------------------------
+runtimeSplicePromise :: (Monad n, MonadIO m)
+ => RuntimeSplice n a
+ -> HeistT n m (Promise a)
+runtimeSplicePromise act = do
+ prom <- newEmptyPromiseWithError "runtimeSplicePromise"
+
+ let m = do
+ x <- act
+ putPromise prom x
+ return ()
+
+ yieldRuntimeSplice m
+ return prom
+{-# INLINE runtimeSplicePromise #-}
+
+
+------------------------------------------------------------------------------
+withPromise :: (Monad n, MonadIO m)
+ => Promise a
+ -> (a -> n b)
+ -> HeistT n m (Promise b)
+withPromise promA f = do
+ promB <- newEmptyPromiseWithError "withPromise"
+
+ let m = do
+ a <- getPromise promA
+ b <- lift $ f a
+ putPromise promB b
+ return ()
+
+ yieldRuntimeSplice m
+ return promB
+{-# INLINE withPromise #-}
+
+
+------------------------------------------------------------------------------
+bindCaperSplice :: Text -- ^ tag name
+ -> CaperSplice n m -- ^ splice action
+ -> HeistState n m -- ^ source state
+ -> HeistState n m
+bindCaperSplice n v ts =
+ ts { _caperSpliceMap = H.insert n v (_caperSpliceMap ts) }
+
+
+------------------------------------------------------------------------------
+bindCaperSplices :: [(Text, CaperSplice n m)] -- ^ splices to bind
+ -> HeistState n m -- ^ source state
+ -> HeistState n m
+bindCaperSplices ss ts = foldr (uncurry bindCaperSplice) ts ss
+
+
+------------------------------------------------------------------------------
+-- | Converts 'Text' to a splice yielding the text, html-encoded.
+textSplice :: Monad m => Text -> CaperSplice n m
+textSplice = yield
+
+
+------------------------------------------------------------------------------
+runChildrenCaper :: (Monad m) => CaperSplice n m
+runChildrenCaper = getParamNode >>= runNodeList . X.childNodes
+
+
+------------------------------------------------------------------------------
+-- | Binds a list of splices before using the children of the spliced node as
+-- a view.
+runChildrenWithCaper :: (Monad m)
+ => [(Text, CaperSplice n m)]
+ -- ^ List of splices to bind before running the param nodes.
+ -> CaperSplice n m
+ -- ^ Returns the passed in view.
+runChildrenWithCaper splices = localTS (bindCaperSplices splices) runChildrenCaper
+
+
+------------------------------------------------------------------------------
+-- | Wrapper around runChildrenWithCaper that applies a transformation function to
+-- the second item in each of the tuples before calling runChildrenWithCaper.
+runChildrenWithTransCaper :: (Monad m)
+ => (b -> CaperSplice n m)
+ -- ^ Splice generating function
+ -> [(Text, b)]
+ -- ^ List of tuples to be bound
+ -> CaperSplice n m
+runChildrenWithTransCaper f = runChildrenWithCaper . map (second f)
+
+
+------------------------------------------------------------------------------
+runChildrenWithTextCaper :: (Monad m)
+ => [(Text, Text)]
+ -- ^ List of tuples to be bound
+ -> CaperSplice n m
+runChildrenWithTextCaper = runChildrenWithTransCaper textSplice
+
+
+------------------------------------------------------------------------------
+-- Above here should be correct
+------------------------------------------------------------------------------
+
+
+-- ------------------------------------------------------------------------------
+-- loadTemplate :: FilePath -- ^ path to the template root
+-- -> FilePath -- ^ full file path (includes template root)
+-- -> IO [Either String (TPath, CaperDocumentFile m)]
+-- loadTemplate templateRoot fname
+-- | isHtmlTemplate = do
+-- c <- getDoc fname
+-- return $! [fmap (\t -> (splitLocalPath $ S.pack tName, t)) c]
+-- | otherwise = return []
+--
+-- where
+-- isHtmlTemplate = ".tpl" `isSuffixOf` fname
+-- relfile = makeRelative templateRoot fname
+-- tName = dropExtension relfile
+--
+--
+-- ------------------------------------------------------------------------------
+-- getDoc :: FilePath -> IO (Either String (CaperDocumentFile m))
+-- getDoc f = do
+-- bs <- catch (liftM Right $ S.readFile f)
+-- (\(e::SomeException) -> return $ Left $ show e)
+--
+-- let eitherDoc = either Left (X.parseHTML f) bs
+-- return $ either (\s -> Left $ f ++ " " ++ s)
+-- (\d -> Right $ CaperDocumentFile d (Just f)) eitherDoc
+--
+--
+-- ------------------------------------------------------------------------------
+-- -- | Traverses the specified directory structure and builds a HeistState by
+-- -- loading all the files with a ".tpl" extension.
+-- --loadTemplates :: Monad m
+-- -- => FilePath
+-- -- -> HeistState n m
+-- -- -> IO (Either String (HeistState n m))
+-- loadTemplates dir ts = do
+-- d <- readDirectoryWith (loadTemplate dir) dir
+-- let tlist = F.fold (free d)
+-- errs = lefts tlist
+-- case errs of
+-- [] -> return $! Right $! foldl' ins ts $ rights tlist
+-- _ -> return $ Left $ unlines errs
+--
+-- where
+-- ins !ss (tp, t) = insertTemplate tp t ss
+--
+--
+-- ------------------------------------------------------------------------------
+-- -- | Adds a template to the splice state.
+-- insertTemplate :: Monad m
+-- => TPath
+-- -> CaperDocumentFile m
+-- -> HeistState n m
+-- -> HeistState n m
+-- insertTemplate p t st =
+-- setTemplates (H.insert p t (_caperTemplateMap st)) st
+--
+--
+-- ------------------------------------------------------------------------------
+-- -- | Sets the templateMap in a HeistState.
+-- setTemplates :: HashMap TPath (CaperDocumentFile m)
+-- -> HeistState n m
+-- -> HeistState n m
+-- setTemplates m ts = ts { _caperTemplateMap = m }
+--
+--
+-- ------------------------------------------------------------------------------
+-- --lookupAndRun :: Monad m
+-- -- => ByteString
+-- -- -> ((CaperDocumentFile, TPath) -> HeistT n m (Maybe a))
+-- -- -> HeistT n m (Maybe a)
+-- lookupAndRun name k = do
+-- ts <- getTS
+-- let mt = lookupTemplate name ts _caperTemplateMap
+-- maybe (return Nothing)
+-- (\dftp -> do
+-- let curPath = join $ fmap (cdfFile . fst) mt
+-- modifyTS (setCurTemplateFile curPath)
+-- k dftp)
+-- mt
+--
+--
+-- ------------------------------------------------------------------------------
+-- -- | Gets the current context
+-- getContext :: Monad m => HeistT n m TPath
+-- getContext = getsTS _curContext
+--
+--
+-- ------------------------------------------------------------------------------
+-- -- | Gets the full path to the file holding the template currently being
+-- -- processed. Returns Nothing if the template is not associated with a file
+-- -- on disk or if there is no template being processed.
+-- --getTemplateFilePath :: Monad m => HeistT n m (Maybe FilePath)
+-- getTemplateFilePath = getsTS _curTemplateFile
+--
+--
+-- ------------------------------------------------------------------------------
+-- {-
+--
+-- Example:
+--
+-- <blog:listRecentPosts>
+-- <a href="${post:href}"><post:title/></a>
+-- </blog:listRecentPosts>
+--
+-- getRecentPosts :: Int -> Snap [ PostInfo ]
+-- getRecentPosts = undefined
+--
+--
+-- ------------------------------------------------------------------------------
+-- foo :: HeistT Snap ()
+-- foo = do
+-- postListPromise <- promise (getRecentPosts 10)
+-- postPromise <- newEmptyPromise
+--
+-- childTemplate <- localTS $ do
+-- bindSplices [ ("post:title", titleWith postPromise)
+-- , ("post:href" , hrefWith postPromise)
+-- ]
+--
+-- runChildren
+--
+-- let xxxx = withPromise postListPromise $ \postList -> do
+-- htmls <- mapM (\post -> putPromise postPromise post >> childTemplate) postList
+-- return $! mconcat htmls
+--
+-- yieldLater xxxx
+--
+-- where
+-- titleWith p = yieldLater $ withPromise p (return . postTitle)
+--
+-- -}
+
View
84 src/Data/HeterogeneousEnvironment.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+
+------------------------------------------------------------------------------
+module Data.HeterogeneousEnvironment
+ ( KeyGen
+ , HeterogeneousEnvironment
+ , Key
+ , newKeyGen
+ , empty
+ , makeKey
+ , lookup
+ , insert
+ , delete
+ , adjust
+ , getKeyId
+ ) where
+
+------------------------------------------------------------------------------
+import Control.Monad
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IM
+import Data.IORef
+import GHC.Exts
+import Prelude hiding (lookup)
+import Unsafe.Coerce
+
+------------------------------------------------------------------------------
+data HeterogeneousEnvironment = HeterogeneousEnvironment (IntMap Any)
+newtype Key a = Key Int
+newtype KeyGen = KeyGen (IORef Int)
+
+
+------------------------------------------------------------------------------
+-- | If you use two different KeyGens to work with the same map, you deserve
+-- what you get.
+newKeyGen :: IO KeyGen
+newKeyGen = liftM KeyGen $ newIORef 0
+
+
+------------------------------------------------------------------------------
+getKeyId :: Key a -> Int
+getKeyId (Key x) = x
+
+
+------------------------------------------------------------------------------
+empty :: HeterogeneousEnvironment
+empty = HeterogeneousEnvironment $ IM.empty
+
+
+------------------------------------------------------------------------------
+makeKey :: KeyGen -> IO (Key a)
+makeKey (KeyGen gen) = do
+ k <- atomicModifyIORef gen nextKey
+ return $ Key k
+ where
+ nextKey !x = if x >= maxBound-1
+ then error "too many keys generated"
+ else let !x' = x+1 in (x',x)
+
+
+------------------------------------------------------------------------------
+lookup :: Key a -> HeterogeneousEnvironment -> Maybe a
+lookup (Key k) (HeterogeneousEnvironment m) = fmap unsafeCoerce $ IM.lookup k m
+
+
+------------------------------------------------------------------------------
+insert :: Key a -> a -> HeterogeneousEnvironment -> HeterogeneousEnvironment
+insert (Key k) v (HeterogeneousEnvironment m) = HeterogeneousEnvironment $
+ IM.insert k (unsafeCoerce v) m
+
+
+------------------------------------------------------------------------------
+delete :: Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment
+delete (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $
+ IM.delete k m
+
+
+------------------------------------------------------------------------------
+adjust :: (a -> a) -> Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment
+adjust f (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $
+ IM.adjust f' k m
+ where
+ f' = unsafeCoerce . f . unsafeCoerce
View
15 src/Text/Templating/Heist.hs
@@ -93,8 +93,6 @@ module Text.Templating.Heist
-- * Hook functions
-- $hookDoc
, addOnLoadHook
- , addPreRunHook
- , addPostRunHook
-- * HeistT functions
, stopRecursion
@@ -135,8 +133,11 @@ module Text.Templating.Heist
, mkCacheTag
) where
+import Control.Monad
import Control.Monad.Trans
import qualified Data.HashMap.Strict as Map
+import qualified Data.HeterogeneousEnvironment as HE
+import Text.Templating.Heist.Common
import Text.Templating.Heist.Internal
import Text.Templating.Heist.Splices
import Text.Templating.Heist.Types
@@ -144,7 +145,7 @@ import Text.Templating.Heist.Types
------------------------------------------------------------------------------
-- | The default set of built-in splices.
-defaultSpliceMap :: MonadIO m => SpliceMap m
+defaultSpliceMap :: MonadIO n => SpliceMap n n
defaultSpliceMap = Map.fromList
[(applyTag, applyImpl)
,(bindTag, bindImpl)
@@ -157,10 +158,11 @@ defaultSpliceMap = Map.fromList
-- | An empty heist state, with Heist's default splices (@\<apply\>@,
-- @\<bind\>@, @\<ignore\>@, and @\<markdown\>@) mapped. The cache tag is
-- not mapped here because it must be mapped manually in your application.
-defaultHeistState :: MonadIO m => HeistState m
+defaultHeistState :: MonadIO n => IO (HeistState n n)
defaultHeistState =
- HeistState (defaultSpliceMap) Map.empty True [] 0
- return return return [] Nothing
+ liftM (HeistState (defaultSpliceMap) Map.empty
+ Map.empty Map.empty True [] 0 return [] Nothing)
+ HE.newKeyGen
-- $hookDoc
@@ -174,3 +176,4 @@ defaultHeistState =
-- run/rendered. You should be careful what code you put in these hooks
-- because it can significantly affect the performance of your site.
+
View
153 src/Text/Templating/Heist/Common.hs
@@ -0,0 +1,153 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Text.Templating.Heist.Common where
+
+import Control.Applicative
+import Control.Monad
+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.Hashable
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as Map
+import Data.Maybe
+import Data.Monoid
+import qualified Data.Text as T
+import System.FilePath
+import Text.Templating.Heist.Types
+
+------------------------------------------------------------------------------
+-- | Sets the current template file.
+setCurTemplateFile :: Monad m
+ => Maybe FilePath -> HeistState n m -> HeistState n m
+setCurTemplateFile fp ts = ts { _curTemplateFile = fp }
+
+
+------------------------------------------------------------------------------
+setCurContext :: Monad m => TPath -> HeistState n m -> HeistState n m
+setCurContext tp ts = ts { _curContext = tp }
+
+
+------------------------------------------------------------------------------
+-- | Parser for attribute variable substitution.
+attParser :: AP.Parser [AttAST]
+attParser = liftM ($! []) (loop id)
+ where
+ append !dl !x = dl . (x:)
+
+ loop !dl = go id
+ where
+ finish subDL = let !txt = T.concat $! subDL []
+ lit = Literal $! T.concat $! subDL []
+ in return $! if T.null txt
+ then dl
+ else append dl lit
+
+ go !subDL = (gobbleText >>= go . append subDL)
+ <|> (AP.endOfInput *> finish subDL)
+ <|> (escChar >>= go . append subDL)
+ <|> (do
+ idp <- identParser
+ dl' <- finish subDL
+ loop $! append dl' idp)
+
+ gobbleText = AP.takeWhile1 (AP.notInClass "\\$")
+
+ escChar = AP.char '\\' *> (T.singleton <$> AP.anyChar)
+
+ identParser = AP.char '$' *> (ident <|> return (Literal "$"))
+ ident = (AP.char '{' *> (Ident <$> AP.takeWhile (/='}')) <* AP.string "}")
+
+
+------------------------------------------------------------------------------
+-- | Converts a path into an array of the elements in reverse order. If the
+-- path is absolute, we need to remove the leading slash so the split doesn't
+-- leave @\"\"@ as the last element of the TPath.
+--
+-- FIXME @\"..\"@ currently doesn't work in paths, the solution is non-trivial
+splitPathWith :: Char -> ByteString -> TPath
+splitPathWith s p = if BC.null p then [] else (reverse $ BC.split s path)
+ where
+ path = if BC.head p == s then BC.tail p else p
+
+
+------------------------------------------------------------------------------
+-- | Converts a path into an array of the elements in reverse order using the
+-- path separator of the local operating system. See 'splitPathWith' for more
+-- details.
+splitLocalPath :: ByteString -> TPath
+splitLocalPath = splitPathWith pathSeparator
+
+
+------------------------------------------------------------------------------
+-- | Converts a path into an array of the elements in reverse order using a
+-- forward slash (/) as the path separator. See 'splitPathWith' for more
+-- details.
+splitTemplatePath :: ByteString -> TPath
+splitTemplatePath = splitPathWith '/'
+
+
+------------------------------------------------------------------------------
+-- | Convenience function for looking up a template.
+lookupTemplate :: ByteString
+ -> HeistState n m
+ -> (HeistState n m -> HashMap TPath t)
+ -> Maybe (t, [ByteString])
+lookupTemplate nameStr ts tm = f (tm ts) path name
+ where
+ (name:p) = case splitTemplatePath nameStr of
+ [] -> [""]
+ ps -> ps
+ ctx = if B.isPrefixOf "/" nameStr then [] else _curContext ts
+ path = p ++ ctx
+ f = if '/' `BC.elem` nameStr
+ then singleLookup
+ else traversePath
+
+
+------------------------------------------------------------------------------
+-- | Returns 'True' if the given template can be found in the heist state.
+hasTemplate :: ByteString -> HeistState n m -> Bool
+hasTemplate nameStr ts =
+ isJust $ lookupTemplate nameStr ts _templateMap
+
+
+------------------------------------------------------------------------------
+-- | Does a single template lookup without cascading up.
+singleLookup :: (Eq a, Hashable a)
+ => HashMap [a] t -> [a] -> a -> Maybe (t, [a])
+singleLookup tm path name = fmap (\a -> (a,path)) $ Map.lookup (name:path) tm
+
+
+------------------------------------------------------------------------------
+-- | Searches for a template by looking in the full path then backing up into
+-- each of the parent directories until the template is found.
+traversePath :: (Eq a, Hashable a)
+ => HashMap [a] t -> [a] -> a -> Maybe (t, [a])
+traversePath tm [] name = fmap (\a -> (a,[])) (Map.lookup [name] tm)
+traversePath tm path name =
+ singleLookup tm path name `mplus`
+ traversePath tm (tail path) name
+
+
+------------------------------------------------------------------------------
+-- | Maps a splice generating function over a list and concatenates the
+-- results. This function now has a more general type signature so it works
+-- with both Heist and Caper splices. The old type signature was this:
+--
+-- > mapSplices :: (Monad n)
+-- > => (a -> Splice n n)
+-- > -> [a]
+-- > -> Splice n n
+mapSplices :: (Monad m, Monoid r)
+ => (a -> m r)
+ -- ^ Splice generating function
+ -> [a]
+ -- ^ List of items to generate splices for
+ -> m r
+ -- ^ The result of all splices concatenated together.
+mapSplices f vs = liftM mconcat $ mapM f vs
+{-# INLINE mapSplices #-}
+
+
View
321 src/Text/Templating/Heist/Internal.hs
@@ -8,12 +8,10 @@ module Text.Templating.Heist.Internal where
------------------------------------------------------------------------------
import Blaze.ByteString.Builder
-import Control.Applicative
import Control.Arrow hiding (loop)
import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.CatchIO
-import Control.Monad.Trans
import qualified Data.Attoparsec.Text as AP
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
@@ -28,16 +26,16 @@ import qualified Data.Text as T
import Data.Text (Text)
import Prelude hiding (catch)
import System.Directory.Tree hiding (name)
-import System.FilePath
import qualified Text.XmlHtml as X
------------------------------------------------------------------------------
+import Text.Templating.Heist.Common
import Text.Templating.Heist.Types
------------------------------------------------------------------------------
-- | Mappends a doctype to the state.
-addDoctype :: Monad m => [X.DocType] -> HeistT m ()
+addDoctype :: Monad m => [X.DocType] -> HeistT n m ()
addDoctype dt = do
modifyTS (\s -> s { _doctypes = _doctypes s `mappend` dt })
@@ -51,60 +49,34 @@ addDoctype dt = do
-- | Adds an on-load hook to a `HeistState`.
addOnLoadHook :: (Monad m) =>
(Template -> IO Template)
- -> HeistState m
- -> HeistState m
+ -> HeistState n m
+ -> HeistState n m
addOnLoadHook hook ts = ts { _onLoadHook = _onLoadHook ts >=> hook }
------------------------------------------------------------------------------
--- | Adds a pre-run hook to a `HeistState`.
-addPreRunHook :: (Monad m) =>
- (Template -> m Template)
- -> HeistState m
- -> HeistState m
-addPreRunHook hook ts = ts { _preRunHook = _preRunHook ts >=> hook }
-
-
-------------------------------------------------------------------------------
--- | Adds a post-run hook to a `HeistState`.
-addPostRunHook :: (Monad m) =>
- (Template -> m Template)
- -> HeistState m
- -> HeistState m
-addPostRunHook hook ts = ts { _postRunHook = _postRunHook ts >=> hook }
-
-
-------------------------------------------------------------------------------
-- | Binds a new splice declaration to a tag name within a 'HeistState'.
-bindSplice :: Monad m =>
- Text -- ^ tag name
- -> Splice m -- ^ splice action
- -> HeistState m -- ^ source state
- -> HeistState m
+bindSplice :: Text -- ^ tag name
+ -> Splice n n -- ^ splice action
+ -> HeistState n m -- ^ source state
+ -> HeistState n m
bindSplice n v ts = ts {_spliceMap = Map.insert n v (_spliceMap ts)}
------------------------------------------------------------------------------
-- | Binds a set of new splice declarations within a 'HeistState'.
bindSplices :: Monad m =>
- [(Text, Splice m)] -- ^ splices to bind
- -> HeistState m -- ^ start state
- -> HeistState m
+ [(Text, Splice n n)] -- ^ splices to bind
+ -> HeistState n m -- ^ start state
+ -> HeistState n m
bindSplices ss ts = foldl' (flip id) ts acts
where
acts = map (uncurry bindSplice) ss
------------------------------------------------------------------------------
--- | Sets the current template file.
-setCurTemplateFile :: Monad m
- => Maybe FilePath -> HeistState m -> HeistState m
-setCurTemplateFile fp ts = ts { _curTemplateFile = fp }
-
-
-------------------------------------------------------------------------------
-- | Converts 'Text' to a splice returning a single 'TextNode'.
-textSplice :: (Monad m) => Text -> Splice m
+textSplice :: Monad n => Text -> Splice n n
textSplice t = return [X.TextNode t]
@@ -113,17 +85,17 @@ textSplice t = return [X.TextNode t]
-- By itself this function is a simple passthrough splice that makes the
-- spliced node disappear. In combination with locally bound splices, this
-- function makes it easier to pass the desired view into your splices.
-runChildren :: Monad m => Splice m
+runChildren :: Monad n => Splice n n
runChildren = runNodeList . X.childNodes =<< getParamNode
------------------------------------------------------------------------------
-- | Binds a list of splices before using the children of the spliced node as
-- a view.
-runChildrenWith :: (Monad m)
- => [(Text, Splice m)]
+runChildrenWith :: (Monad n)
+ => [(Text, Splice n n)]
-- ^ List of splices to bind before running the param nodes.
- -> Splice m
+ -> Splice n n
-- ^ Returns the passed in view.
runChildrenWith splices = localTS (bindSplices splices) runChildren
@@ -131,128 +103,41 @@ runChildrenWith splices = localTS (bindSplices splices) runChildren
------------------------------------------------------------------------------
-- | Wrapper around runChildrenWith that applies a transformation function to
-- the second item in each of the tuples before calling runChildrenWith.
-runChildrenWithTrans :: (Monad m)
- => (b -> Splice m)
+runChildrenWithTrans :: (Monad n)
+ => (b -> Splice n n)
-- ^ Splice generating function
-> [(Text, b)]
-- ^ List of tuples to be bound
- -> Splice m
+ -> Splice n n
runChildrenWithTrans f = runChildrenWith . map (second f)
------------------------------------------------------------------------------
-- | Like runChildrenWith but using constant templates rather than dynamic
-- splices.
-runChildrenWithTemplates :: (Monad m) => [(Text, Template)] -> Splice m
+runChildrenWithTemplates :: (Monad n) => [(Text, Template)] -> Splice n n
runChildrenWithTemplates = runChildrenWithTrans return
------------------------------------------------------------------------------
-- | Like runChildrenWith but using literal text rather than dynamic splices.
-runChildrenWithText :: (Monad m) => [(Text, Text)] -> Splice m
+runChildrenWithText :: (Monad n) => [(Text, Text)] -> Splice n n
runChildrenWithText = runChildrenWithTrans textSplice
------------------------------------------------------------------------------
--- | Maps a splice generating function over a list and concatenates the
--- results.
-mapSplices :: (Monad m)
- => (a -> Splice m)
- -- ^ Splice generating function
- -> [a]
- -- ^ List of items to generate splices for
- -> Splice m
- -- ^ The result of all splices concatenated together.
-mapSplices f vs = liftM concat $ mapM f vs
-{-# INLINE mapSplices #-}
-
-
-------------------------------------------------------------------------------
-- | Convenience function for looking up a splice.
lookupSplice :: Monad m =>
Text
- -> HeistState m
- -> Maybe (Splice m)
+ -> HeistState n m
+ -> Maybe (Splice n n)
lookupSplice nm ts = Map.lookup nm $ _spliceMap ts
{-# INLINE lookupSplice #-}
------------------------------------------------------------------------------
--- | Converts a path into an array of the elements in reverse order. If the
--- path is absolute, we need to remove the leading slash so the split doesn't
--- leave @\"\"@ as the last element of the TPath.
---
--- FIXME @\"..\"@ currently doesn't work in paths, the solution is non-trivial
-splitPathWith :: Char -> ByteString -> TPath
-splitPathWith s p = if BC.null p then [] else (reverse $ BC.split s path)
- where
- path = if BC.head p == s then BC.tail p else p
-
--- | Converts a path into an array of the elements in reverse order using the
--- path separator of the local operating system. See 'splitPathWith' for more
--- details.
-splitLocalPath :: ByteString -> TPath
-splitLocalPath = splitPathWith pathSeparator
-
--- | Converts a path into an array of the elements in reverse order using a
--- forward slash (/) as the path separator. See 'splitPathWith' for more
--- details.
-splitTemplatePath :: ByteString -> TPath
-splitTemplatePath = splitPathWith '/'
-
-
-------------------------------------------------------------------------------
--- | Does a single template lookup without cascading up.
-singleLookup :: TemplateMap
- -> TPath
- -> ByteString
- -> Maybe (DocumentFile, TPath)
-singleLookup tm path name = fmap (\a -> (a,path)) $ Map.lookup (name:path) tm
-
-
-------------------------------------------------------------------------------
--- | Searches for a template by looking in the full path then backing up into
--- each of the parent directories until the template is found.
-traversePath :: TemplateMap
- -> TPath
- -> ByteString
- -> Maybe (DocumentFile, TPath)
-traversePath tm [] name = fmap (\a -> (a,[])) (Map.lookup [name] tm)
-traversePath tm path name =
- singleLookup tm path name `mplus`
- traversePath tm (tail path) name
-
-
-------------------------------------------------------------------------------
--- | Returns 'True' if the given template can be found in the heist state.
-hasTemplate :: Monad m =>
- ByteString
- -> HeistState m
- -> Bool
-hasTemplate nameStr ts = isJust $ lookupTemplate nameStr ts
-
-
-------------------------------------------------------------------------------
--- | Convenience function for looking up a template.
-lookupTemplate :: Monad m =>
- ByteString
- -> HeistState m
- -> Maybe (DocumentFile, TPath)
-lookupTemplate nameStr ts =
- f (_templateMap ts) path name
- where (name:p) = case splitTemplatePath nameStr of
- [] -> [""]
- ps -> ps
- ctx = if B.isPrefixOf "/" nameStr then [] else _curContext ts
- path = p ++ ctx
- f = if '/' `BC.elem` nameStr
- then singleLookup
- else traversePath
-
-
-------------------------------------------------------------------------------
-- | Sets the templateMap in a HeistState.
-setTemplates :: Monad m => TemplateMap -> HeistState m -> HeistState m
+setTemplates :: Monad m => TemplateMap -> HeistState n m -> HeistState n m
setTemplates m ts = ts { _templateMap = m }
@@ -261,8 +146,8 @@ setTemplates m ts = ts { _templateMap = m }
insertTemplate :: Monad m =>
TPath
-> DocumentFile
- -> HeistState m
- -> HeistState m
+ -> HeistState n m
+ -> HeistState n m
insertTemplate p t st =
setTemplates (Map.insert p t (_templateMap st)) st
@@ -277,8 +162,8 @@ addTemplate :: Monad m
-> Maybe FilePath
-- ^ An optional path to the actual file on disk where the
-- template is stored
- -> HeistState m
- -> HeistState m
+ -> HeistState n m
+ -> HeistState n m
addTemplate n t mfp st =
insertTemplate (splitTemplatePath n) doc st
where
@@ -295,8 +180,8 @@ addXMLTemplate :: Monad m
-> Maybe FilePath
-- ^ An optional path to the actual file on disk where the
-- template is stored
- -> HeistState m
- -> HeistState m
+ -> HeistState n m
+ -> HeistState n m
addXMLTemplate n t mfp st =
insertTemplate (splitTemplatePath n) doc st
where
@@ -317,19 +202,13 @@ addXMLTemplate n t mfp st =
-- splice will result in a list of nodes @L@. Normally @foo@ will recursively
-- scan @L@ for splices and run them. If @foo@ calls @stopRecursion@, @L@
-- will be included in the output verbatim without running any splices.
-stopRecursion :: Monad m => HeistT m ()
+stopRecursion :: Monad m => HeistT n m ()
stopRecursion = modifyTS (\st -> st { _recurse = False })
------------------------------------------------------------------------------
--- | Sets the current context
-setContext :: Monad m => TPath -> HeistT m ()
-setContext c = modifyTS (\st -> st { _curContext = c })
-
-
-------------------------------------------------------------------------------
-- | Gets the current context
-getContext :: Monad m => HeistT m TPath
+getContext :: Monad m => HeistT n m TPath
getContext = getsTS _curContext
@@ -337,13 +216,13 @@ getContext = getsTS _curContext
-- | Gets the full path to the file holding the template currently being
-- processed. Returns Nothing if the template is not associated with a file
-- on disk or if there is no template being processed.
-getTemplateFilePath :: Monad m => HeistT m (Maybe FilePath)
+getTemplateFilePath :: Monad m => HeistT n m (Maybe FilePath)
getTemplateFilePath = getsTS _curTemplateFile
------------------------------------------------------------------------------
-- | Performs splice processing on a single node.
-runNode :: Monad m => X.Node -> Splice m
+runNode :: Monad n => X.Node -> Splice n n
runNode (X.Element nm at ch) = do
newAtts <- mapM attSubst at
let n = X.Element nm newAtts ch
@@ -359,7 +238,7 @@ runNode n = return [n]
------------------------------------------------------------------------------
-- | Helper function for substituting a parsed attribute into an attribute
-- tuple.
-attSubst :: (Monad m) => (t, Text) -> HeistT m (t, Text)
+attSubst :: (Monad n) => (t, Text) -> HeistT n n (t, Text)
attSubst (n,v) = do
v' <- parseAtt v
return (n,v')
@@ -368,7 +247,7 @@ attSubst (n,v) = do
------------------------------------------------------------------------------
-- | Parses an attribute for any identifier expressions and performs
-- appropriate substitution.
-parseAtt :: (Monad m) => Text -> HeistT m Text
+parseAtt :: (Monad n) => Text -> HeistT n n Text
parseAtt bs = do
let ast = case AP.feed (AP.parse attParser bs) "" of
(AP.Done _ res) -> res
@@ -383,45 +262,6 @@ parseAtt bs = do
------------------------------------------------------------------------------
--- | AST to hold attribute parsing structure. This is necessary because
--- attoparsec doesn't support parsers running in another monad.
-data AttAST = Literal Text
- | Ident Text
- deriving (Show)
-
-
-------------------------------------------------------------------------------
--- | Parser for attribute variable substitution.
-attParser :: AP.Parser [AttAST]
-attParser = liftM ($! []) (loop id)
- where
- append !dl !x = dl . (x:)
-
- loop !dl = go id
- where
- finish subDL = let !txt = T.concat $! subDL []
- lit = Literal $! T.concat $! subDL []
- in return $! if T.null txt
- then dl
- else append dl lit
-
- go !subDL = (gobbleText >>= go . append subDL)
- <|> (AP.endOfInput *> finish subDL)
- <|> (escChar >>= go . append subDL)
- <|> (do
- idp <- identParser
- dl' <- finish subDL
- loop $! append dl' idp)
-
- gobbleText = AP.takeWhile1 (AP.notInClass "\\$")
-
- escChar = AP.char '\\' *> (T.singleton <$> AP.anyChar)
-
- identParser = AP.char '$' *> (ident <|> return (Literal "$"))
- ident = (AP.char '{' *> (Ident <$> AP.takeWhile (/='}')) <* AP.string "}")
-
-
-------------------------------------------------------------------------------
-- | Gets the attribute value. If the splice's result list contains non-text
-- nodes, this will translate them into text nodes with nodeText and
-- concatenate them together.
@@ -443,7 +283,7 @@ attParser = liftM ($! []) (loop id)
-- it would be for the former user to accept that
-- \"some \<b\>text\<\/b\> foobar\" is being rendered as \"some \" because
-- it's \"more intuitive\".
-getAttributeSplice :: Monad m => Text -> HeistT m Text
+getAttributeSplice :: Monad n => Text -> HeistT n n Text
getAttributeSplice name = do
s <- liftM (lookupSplice name) getTS
nodes <- maybe (return []) id s
@@ -451,7 +291,7 @@ getAttributeSplice name = do
------------------------------------------------------------------------------
-- | Performs splice processing on a list of nodes.
-runNodeList :: Monad m => [X.Node] -> Splice m
+runNodeList :: Monad n => [X.Node] -> Splice n n
runNodeList = mapSplices runNode
{-# INLINE runNodeList #-}
@@ -465,7 +305,7 @@ mAX_RECURSION_DEPTH = 50
------------------------------------------------------------------------------
-- | Checks the recursion flag and recurses accordingly. Does not recurse
-- deeper than mAX_RECURSION_DEPTH to avoid infinite loops.
-recurseSplice :: Monad m => X.Node -> Splice m -> Splice m
+recurseSplice :: Monad n => X.Node -> Splice n n -> Splice n n
recurseSplice node splice = do
result <- localParamNode (const node) splice
ts' <- getTS
@@ -476,7 +316,7 @@ recurseSplice node splice = do
return res
else return result
where
- modRecursionDepth :: Monad m => (Int -> Int) -> HeistT m ()
+ modRecursionDepth :: Monad m => (Int -> Int) -> HeistT n m ()
modRecursionDepth f =
modifyTS (\st -> st { _recursionDepth = f (_recursionDepth st) })
@@ -485,11 +325,11 @@ recurseSplice node splice = do
-- | Looks up a template name runs a 'HeistT' computation on it.
lookupAndRun :: Monad m
=> ByteString
- -> ((DocumentFile, TPath) -> HeistT m (Maybe a))
- -> HeistT m (Maybe a)
+ -> ((DocumentFile, TPath) -> HeistT n m (Maybe a))
+ -> HeistT n m (Maybe a)
lookupAndRun name k = do
ts <- getTS
- let mt = lookupTemplate name ts
+ let mt = lookupTemplate name ts _templateMap
let curPath = join $ fmap (dfFile . fst) mt
modifyTS (setCurTemplateFile curPath)
maybe (return Nothing) k mt
@@ -497,9 +337,9 @@ lookupAndRun name k = do
------------------------------------------------------------------------------
-- | Looks up a template name evaluates it by calling runNodeList.
-evalTemplate :: Monad m
- => ByteString
- -> HeistT m (Maybe Template)
+evalTemplate :: Monad n
+ => ByteString
+ -> HeistT n n (Maybe Template)
evalTemplate name = lookupAndRun name
(\(t,ctx) -> localTS (\ts -> ts {_curContext = ctx})
(liftM Just $ runNodeList $ X.docContent $ dfDoc t))
@@ -508,7 +348,7 @@ evalTemplate name = lookupAndRun name
------------------------------------------------------------------------------
-- | Sets the document type of a 'X.Document' based on the 'HeistT'
-- value.
-fixDocType :: Monad m => X.Document -> HeistT m X.Document
+fixDocType :: Monad m => X.Document -> HeistT n m X.Document
fixDocType d = do
dts <- getsTS _doctypes
return $ d { X.docType = listToMaybe dts }
@@ -518,17 +358,16 @@ fixDocType d = do
-- | Same as evalWithHooks, but returns the entire 'X.Document' rather than
-- just the nodes. This is the right thing to do if we are starting at the
-- top level.
-evalWithHooksInternal :: Monad m
+evalWithHooksInternal :: Monad n
=> ByteString
- -> HeistT m (Maybe X.Document)
+ -> HeistT n n (Maybe X.Document)
evalWithHooksInternal name = lookupAndRun name $ \(t,ctx) -> do
addDoctype $ maybeToList $ X.docType $ dfDoc t
ts <- getTS
- nodes <- lift $ _preRunHook ts $ X.docContent $ dfDoc t
+ let nodes = X.docContent $ dfDoc t
putTS (ts {_curContext = ctx})
- res <- runNodeList nodes
+ newNodes <- runNodeList nodes
restoreTS ts
- newNodes <- lift (_postRunHook ts res)
newDoc <- fixDocType $ (dfDoc t) { X.docContent = newNodes }
return (Just newDoc)
@@ -536,28 +375,28 @@ evalWithHooksInternal name = lookupAndRun name $ \(t,ctx) -> do
------------------------------------------------------------------------------
-- | Looks up a template name evaluates it by calling runNodeList. This also
-- executes pre- and post-run hooks and adds the doctype.
-evalWithHooks :: Monad m
- => ByteString
- -> HeistT m (Maybe Template)
+evalWithHooks :: Monad n
+ => ByteString
+ -> HeistT n n (Maybe Template)
evalWithHooks name = liftM (liftM X.docContent) (evalWithHooksInternal name)
------------------------------------------------------------------------------
-- | Binds a list of constant string splices.
-bindStrings :: Monad m
+bindStrings :: Monad n
=> [(Text, Text)]
- -> HeistState m
- -> HeistState m
+ -> HeistState n n
+ -> HeistState n n
bindStrings pairs ts = foldr (uncurry bindString) ts pairs
------------------------------------------------------------------------------
-- | Binds a single constant string splice.
-bindString :: Monad m
- => Text
- -> Text
- -> HeistState m
- -> HeistState m
+bindString :: Monad n
+ => Text
+ -> Text
+ -> HeistState n n
+ -> HeistState n n
bindString n = bindSplice n . textSplice
@@ -566,11 +405,11 @@ bindString n = bindSplice n . textSplice
-- to use when you want to "call" a template and pass in parameters from
-- inside a splice. If the template does not exist, this version simply
-- returns an empty list.
-callTemplate :: Monad m
+callTemplate :: Monad n
=> ByteString -- ^ The name of the template
- -> [(Text, Splice m)] -- ^ Association list of
+ -> [(Text, Splice n n)] -- ^ Association list of
-- (name,value) parameter pairs
- -> HeistT m Template
+ -> HeistT n n Template
callTemplate name params = do
modifyTS $ bindSplices params
liftM (maybe [] id) $ evalTemplate name
@@ -579,11 +418,11 @@ callTemplate name params = do
------------------------------------------------------------------------------
-- | Like callTemplate except the splices being bound are constant text
-- splices.
-callTemplateWithText :: Monad m
+callTemplateWithText :: Monad n
=> ByteString -- ^ The name of the template
-> [(Text, Text)] -- ^ Association list of
-- (name,value) parameter pairs
- -> HeistT m Template
+ -> HeistT n n Template
callTemplateWithText name params = do
modifyTS $ bindStrings params
liftM (maybe [] id) $ evalTemplate name
@@ -609,10 +448,10 @@ mimeType d = case d of
-- the root template was an HTML or XML format template. It will always be
-- @text/html@ or @text/xml@. If a more specific MIME type is needed for a
-- particular XML application, it must be provided by the application.
-renderTemplate :: Monad m
- => HeistState m
+renderTemplate :: Monad n
+ => HeistState n n
-> ByteString
- -> m (Maybe (Builder, MIMEType))
+ -> n (Maybe (Builder, MIMEType))
renderTemplate ts name = evalHeistT tpl (X.TextNode "") ts
where tpl = do mt <- evalWithHooksInternal name
case mt of
@@ -625,11 +464,11 @@ renderTemplate ts name = evalHeistT tpl (X.TextNode "") ts
-- convenience function for the common pattern of calling renderTemplate after
-- using bindString, bindStrings, or bindSplice to set up the arguments to the
-- template.
-renderWithArgs :: Monad m
- => [(Text, Text)]
- -> HeistState m
- -> ByteString
- -> m (Maybe (Builder, MIMEType))
+renderWithArgs :: Monad n
+ => [(Text, Text)]
+ -> HeistState n n
+ -> ByteString
+ -> n (Maybe (Builder, MIMEType))
renderWithArgs args ts = renderTemplate (bindStrings args ts)
@@ -694,8 +533,8 @@ loadTemplate templateRoot fname
------------------------------------------------------------------------------
-- | Traverses the specified directory structure and builds a HeistState by
-- loading all the files with a ".tpl" or ".xtpl" extension.
-loadTemplates :: Monad m => FilePath -> HeistState m
- -> IO (Either String (HeistState m))
+loadTemplates :: Monad m => FilePath -> HeistState n m
+ -> IO (Either String (HeistState n m))
loadTemplates dir ts = do
d <- readDirectoryWith (loadTemplate dir) dir
let tlist = F.fold (free d)
@@ -718,8 +557,8 @@ runHook f t = do
------------------------------------------------------------------------------
-- | Runs the onLoad hook on the template and returns the 'HeistState'
-- with the result inserted.
-loadHook :: Monad m => HeistState m -> (TPath, DocumentFile)
- -> IO (HeistState m)
+loadHook :: Monad m => HeistState n m -> (TPath, DocumentFile)
+ -> IO (HeistState n m)
loadHook ts (tp, t) = do
t' <- runHook (_onLoadHook ts) t
return $ insertTemplate tp t' ts
@@ -730,7 +569,7 @@ loadHook ts (tp, t) = do
-- 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
-- 'HeistState' unchanged.
-addTemplatePathPrefix :: ByteString -> HeistState m -> HeistState m
+addTemplatePathPrefix :: ByteString -> HeistState n m -> HeistState n m
addTemplatePathPrefix dir ts
| B.null dir = ts
| otherwise = ts { _templateMap = Map.fromList $
View
15 src/Text/Templating/Heist/Splices/Apply.hs
@@ -7,6 +7,7 @@ import qualified Data.Text.Encoding as T
import qualified Text.XmlHtml as X
------------------------------------------------------------------------------
+import Text.Templating.Heist.Common
import Text.Templating.Heist.Internal
import Text.Templating.Heist.Types
@@ -25,16 +26,16 @@ applyAttr = "template"
------------------------------------------------------------------------------
-- | Raw core of apply functionality. This is abstracted for use in other
-- places like an enhanced (from the original) bind
-rawApply :: (Monad m)
+rawApply :: (Monad n)
=> [X.Node]
-> TPath
-> [X.Node]
- -> HeistT m Template
+ -> Splice n n
rawApply calledNodes newContext paramNodes = do
st <- getTS -- Can't use localTS here because the modifier is not pure
processedParams <- runNodeList paramNodes
- modifyTS (bindSplice "content" $ return processedParams)
- setContext newContext
+ modifyTS (bindSplice "content" (return processedParams) .
+ setCurContext newContext)
result <- runNodeList calledNodes
restoreTS st
return result
@@ -43,19 +44,19 @@ rawApply calledNodes newContext paramNodes = do
------------------------------------------------------------------------------
-- | Applies a template as if the supplied nodes were the children of the
-- <apply> tag.
-applyNodes :: Monad m => Template -> Text -> Splice m
+applyNodes :: Monad n => Template -> Text -> Splice n n
applyNodes nodes template = do
st <- getTS
maybe (return []) -- TODO: error handling
(\(t,ctx) -> do
addDoctype $ maybeToList $ X.docType $ dfDoc t
rawApply (X.docContent $ dfDoc t) ctx nodes)
- (lookupTemplate (T.encodeUtf8 template) st)
+ (lookupTemplate (T.encodeUtf8 template) st _templateMap)
------------------------------------------------------------------------------
-- | Implementation of the apply splice.
-applyImpl :: Monad m => Splice m
+applyImpl :: Monad n => Splice n n
applyImpl = do
node <- getParamNode
case X.getAttribute applyAttr node of
View
2 src/Text/Templating/Heist/Splices/Bind.hs
@@ -22,7 +22,7 @@ bindAttr = "tag"
------------------------------------------------------------------------------
-- | Implementation of the bind splice.
-bindImpl :: Monad m => Splice m
+bindImpl :: Monad n => Splice n n
bindImpl = do
node <- getParamNode
maybe (return ())
View
2 src/Text/Templating/Heist/Splices/BindStrict.hs
@@ -17,7 +17,7 @@ bindStrictTag = "bindStrict"
------------------------------------------------------------------------------
-- | Implementation of the bind splice.
-bindStrictImpl :: Monad m => Splice m
+bindStrictImpl :: Monad n => Splice n n
bindStrictImpl = do
node <- getParamNode
cs <- runChildren
View
8 src/Text/Templating/Heist/Splices/Cache.hs
@@ -68,9 +68,9 @@ parseTTL s = value * multiplier
_ -> 0
------------------------------------------------------------------------------
-cacheImpl :: (MonadIO m)
+cacheImpl :: (MonadIO n)
=> CacheTagState
- -> HeistT m Template
+ -> Splice n n
cacheImpl (CTS mv) = do
tree <- getParamNode
let err = error $ unwords ["cacheImpl is bound to a tag"
@@ -106,8 +106,8 @@ cacheImpl (CTS mv) = do
-- tag. The cache tag is not bound automatically with the other default Heist
-- tags. This is because this function also returns CacheTagState, so the
-- user will be able to clear it with the 'clearCacheTagState' function.
-mkCacheTag :: MonadIO m
- => IO (HeistState m -> HeistState m, CacheTagState)
+mkCacheTag :: MonadIO n
+ => IO (HeistState n n -> HeistState n n, CacheTagState)
mkCacheTag = do
sr <- newIORef $ Set.empty
mv <- liftM CTS $ newMVar H.empty
View
2 src/Text/Templating/Heist/Splices/Html.hs
@@ -20,7 +20,7 @@ htmlTag = "html"
-- | The html splice runs all children and then traverses the returned node
-- forest removing all head nodes. Then it merges them all and prepends it to
-- the html tag's child list.
-htmlImpl :: Monad m => Splice m
+htmlImpl :: Monad n => Splice n n
htmlImpl = do
node <- getParamNode
children <- runNodeList $ X.childNodes node
View
2 src/Text/Templating/Heist/Splices/Ignore.hs
@@ -16,7 +16,7 @@ ignoreTag = "ignore"
------------------------------------------------------------------------------
-- | The ignore tag and everything it surrounds disappears in the
-- rendered output.
-ignoreImpl :: Monad m => Splice m
+ignoreImpl :: Monad m => Splice n m
ignoreImpl = return []
View
18 src/Text/Templating/Heist/Splices/Json.hs
@@ -53,7 +53,7 @@ import Text.XmlHtml
-- @\<value\/\>@ -- the given JSON value, as a string
-- @\<snippet\/\>@ -- the given JSON value, parsed and spliced in as HTML
--
-bindJson :: (ToJSON a, Monad m) => a -> Splice m
+bindJson :: (ToJSON a, Monad n) => a -> Splice n n
bindJson = runReaderT explodeTag . toJSON
@@ -69,11 +69,11 @@ errorMessage s = renderHtmlNodes $
------------------------------------------------------------------------------
-type JsonMonad m a = ReaderT Value (HeistT m) a
+type JsonMonad n m a = ReaderT Value (HeistT n m) a
------------------------------------------------------------------------------
-withValue :: (Monad m) => Value -> JsonMonad m a -> HeistT m a
+withValue :: (Monad m) => Value -> JsonMonad n m a -> HeistT n m a
withValue = flip runReaderT
@@ -108,7 +108,7 @@ asHtml t =
------------------------------------------------------------------------------
-snippetTag :: Monad m => JsonMonad m [Node]
+snippetTag :: Monad m => JsonMonad n m [Node]
snippetTag = ask >>= snip
where
txt t = lift $ asHtml t
@@ -127,7 +127,7 @@ snippetTag = ask >>= snip
------------------------------------------------------------------------------
-valueTag :: Monad m => JsonMonad m [Node]
+valueTag :: Monad m => JsonMonad n m [Node]
valueTag = ask >>= go
where
go Null = txt ""
@@ -147,7 +147,7 @@ valueTag = ask >>= go
------------------------------------------------------------------------------
-explodeTag :: (Monad m) => JsonMonad m [Node]
+explodeTag :: (Monad n) => JsonMonad n n [Node]
explodeTag = ask >>= go
where
--------------------------------------------------------------------------
@@ -164,7 +164,7 @@ explodeTag = ask >>= go
]
--------------------------------------------------------------------------
- goArray :: (Monad m) => V.Vector Value -> JsonMonad m [Node]
+ goArray :: (Monad n) => V.Vector Value -> JsonMonad n n [Node]
goArray a = do
lift stopRecursion
dl <- V.foldM f id a
@@ -178,7 +178,7 @@ explodeTag = ask >>= go
-- search the param node for attribute \"var=expr\", search the given JSON
-- object for the expression, and if it's found run the JsonMonad action m
-- using the restricted JSON object.
- varAttrTag :: (Monad m) => Value -> (JsonMonad m [Node]) -> Splice m
+ varAttrTag :: (Monad m) => Value -> (JsonMonad n m [Node]) -> Splice n m
varAttrTag v m = do
node <- getParamNode
maybe (noVar node) (hasVar node) $ getAttribute "var" node
@@ -201,7 +201,7 @@ explodeTag = ask >>= go
(findExpr expr v)
--------------------------------------------------------------------------
- genericBindings :: Monad m => JsonMonad m [(Text, Splice m)]
+ genericBindings :: Monad n => JsonMonad n n [(Text, Splice n n)]
genericBindings = ask >>= \v -> return [ ("with", varAttrTag v explodeTag)
, ("snippet", varAttrTag v snippetTag)
, ("value", varAttrTag v valueTag )
View
2 src/Text/Templating/Heist/Splices/Markdown.hs
@@ -75,7 +75,7 @@ markdownTag = "markdown"
------------------------------------------------------------------------------
-- | Implementation of the markdown splice.
-markdownSplice :: MonadIO m => Splice m
+markdownSplice :: MonadIO m => Splice n m
markdownSplice = do
templateDir <- liftM (fmap takeDirectory) getTemplateFilePath
pdMD <- liftIO $ findExecutable "pandoc"
View
24 src/Text/Templating/Heist/TemplateDirectory.hs
@@ -24,21 +24,21 @@ import Text.Templating.Heist.Splices.Cache
------------------------------------------------------------------------------
-- | Structure representing a template directory.
-data TemplateDirectory m
+data TemplateDirectory n m
= TemplateDirectory
FilePath
- (HeistState m)
- (MVar (HeistState m))
+ (HeistState n m)
+ (MVar (HeistState n m))
CacheTagState
------------------------------------------------------------------------------
-- | Creates and returns a new 'TemplateDirectory' wrapped in an Either for
-- error handling.
-newTemplateDirectory :: (MonadIO m, MonadIO n)
+newTemplateDirectory :: (MonadIO n)
=> FilePath
- -> HeistState m
- -> n (Either String (TemplateDirectory m))
+ -> HeistState n n
+ -> n (Either String (TemplateDirectory n n))
newTemplateDirectory dir templateState = liftIO $ do
(modTs,cts) <- mkCacheTag
let origTs = modTs templateState
@@ -51,25 +51,25 @@ newTemplateDirectory dir templateState = liftIO $ do
------------------------------------------------------------------------------
-- | Creates and returns a new 'TemplateDirectory', using the monad's fail
-- function on error.
-newTemplateDirectory' :: (MonadIO m, MonadIO n)
+newTemplateDirectory' :: (MonadIO n)
=> FilePath
- -> HeistState m
- -> n (TemplateDirectory m)
+ -> HeistState n n
+ -> n (TemplateDirectory n n)
newTemplateDirectory' = ((either fail return =<<) .) . newTemplateDirectory
------------------------------------------------------------------------------
-- | Gets the 'HeistState' from a TemplateDirectory.
getDirectoryTS :: (Monad m, MonadIO n)
- => TemplateDirectory m
- -> n (HeistState m)
+ => TemplateDirectory n m
+ -> n (HeistState n m)
getDirectoryTS (TemplateDirectory _ _ tsMVar _) = liftIO $ readMVar $ tsMVar
------------------------------------------------------------------------------
-- | Clears cached content and reloads templates from disk.
reloadTemplateDirectory :: (MonadIO m, MonadIO n)
- => TemplateDirectory m
+ => TemplateDirectory n m
-> n (Either String ())
reloadTemplateDirectory (TemplateDirectory p origTs tsMVar cts) = liftIO $ do
clearCacheTagState cts
View
294 src/Text/Templating/Heist/Types.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -21,21 +22,26 @@ liberating us from the unused writer portion of RWST.
module Text.Templating.Heist.Types where
------------------------------------------------------------------------------
-import Control.Applicative
-import Control.Arrow
-import Control.Monad.CatchIO
-import Control.Monad.Cont
-import Control.Monad.Error
-import Control.Monad.Reader
-import Control.Monad.State
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.HashMap.Strict as H
-import Data.HashMap.Strict (HashMap)
-import Data.Monoid
-import Data.Text (Text)
-import Data.Typeable
-import Prelude hiding (catch)
-import qualified Text.XmlHtml as X
+import Blaze.ByteString.Builder
+import Control.Applicative
+import Control.Arrow
+import Control.Monad.CatchIO
+import Control.Monad.Cont
+import Control.Monad.Error
+import Control.Monad.Reader
+import Control.Monad.State.Strict
+import Data.ByteString.Char8 (ByteString)
+import Data.DList (DList)
+import qualified Data.HashMap.Strict as H
+import Data.HashMap.Strict (HashMap)
+import Data.HeterogeneousEnvironment (HeterogeneousEnvironment)
+import qualified Data.HeterogeneousEnvironment as HE
+import Data.Monoid
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Typeable
+import Prelude hiding (catch)
+import qualified Text.XmlHtml as X
------------------------------------------------------------------------------
@@ -61,6 +67,69 @@ data DocumentFile = DocumentFile
, dfFile :: Maybe FilePath
} deriving (Eq)
+
+------------------------------------------------------------------------------
+-- Caper types
+------------------------------------------------------------------------------
+
+type CaperOutput m = DList (Chunk m)
+
+
+------------------------------------------------------------------------------
+newtype RuntimeSplice m a = RuntimeSplice {
+ unRT :: StateT HeterogeneousEnvironment m a
+ } deriving ( Applicative
+ , Functor
+ , Monad
+ , MonadIO
+ , MonadState HeterogeneousEnvironment
+ , MonadTrans )
+
+
+------------------------------------------------------------------------------
+instance (Monad m, Monoid a) => Monoid (RuntimeSplice m a) where
+ mempty = return mempty
+
+ a `mappend` b = do
+ !x <- a
+ !y <- b
+ return $! x `mappend` y
+
+
+------------------------------------------------------------------------------
+data Chunk m = Pure !Text
+ -- ^ output known at load time
+ | RuntimeHtml !(RuntimeSplice m Text)
+ -- ^ output computed at run time
+ | RuntimeAction !(RuntimeSplice m ())
+ -- ^ runtime action used only for its side-effect
+
+
+------------------------------------------------------------------------------
+instance Show (Chunk m) where
+ show (Pure a) = T.unpack $ T.concat ["Pure \"", a, "\""]
+ show (RuntimeHtml _) = "RuntimeHtml <m>"
+ show (RuntimeAction _) = "RuntimeAction <m>"
+
+
+data CaperDocumentFile m = CaperDocumentFile
+ { cdfDoc :: CaperOutput m
+ , cdfFile :: Maybe FilePath
+ }
+
+
+newtype CompiledTemplateMap m =
+ CompiledTemplateMap (HashMap ByteString (m Builder))
+
+
+------------------------------------------------------------------------------
+newtype Promise a = Promise (HE.Key a)
+
+
+------------------------------------------------------------------------------
+--
+------------------------------------------------------------------------------
+
------------------------------------------------------------------------------
-- | All documents representing templates are stored in a map.
type TemplateMap = HashMap TPath DocumentFile
@@ -68,78 +137,81 @@ type TemplateMap = HashMap TPath DocumentFile
------------------------------------------------------------------------------
-- | A Splice is a HeistT computation that returns a 'Template'.
-type Splice m = HeistT m Template
+type Splice n m = HeistT n m Template
+
+
+------------------------------------------------------------------------------
+-- | A Splice is a HeistT computation that returns a 'Template'.
+type CaperSplice n m = HeistT n m (DList (Chunk n))
------------------------------------------------------------------------------
-- | SpliceMap associates a name and a Splice.
-type SpliceMap m = HashMap Text (Splice m)
+type SpliceMap n m = HashMap Text (Splice n m)
------------------------------------------------------------------------------
-- | Holds all the state information needed for template processing. You will
--- build a @HeistState@ using any of Heist's @HeistState m -> HeistState m@
+-- build a @HeistState@ using any of Heist's @HeistState -> HeistState@
-- \"filter\" functions. Then you use the resulting @HeistState@ in calls to
-- @renderTemplate@.