heist 0.8.2 → 0.10.0

raw patch · 71 files changed

+4962/−2962 lines, 71 filesdep +containersdep +dlistdep +errorsdep ~basedep ~bytestringdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, dlist, errors, hashable

Dependency ranges changed: base, bytestring, directory, directory-tree, filepath, process, random

API changes (from Hackage documentation)

Files

• heist.cabal +95/−38
• src/Data/HeterogeneousEnvironment.hs +84/−0
• src/Heist.hs +227/−0
• src/Heist/Common.hs +288/−0
• src/Heist/Compiled.hs +61/−0
• src/Heist/Compiled/Internal.hs +604/−0
• src/Heist/Interpreted.hs +80/−0
• src/Heist/Interpreted/Internal.hs +427/−0
• src/Heist/Splices.hs +16/−0
• src/Heist/Splices/Apply.hs +102/−0
• src/Heist/Splices/Bind.hs +43/−0
• src/Heist/Splices/BindStrict.hs +37/−0
• src/Heist/Splices/Cache.hs +202/−0
• src/Heist/Splices/Html.hs +47/−0
• src/Heist/Splices/Ignore.hs +22/−0
• src/Heist/Splices/Json.hs +224/−0
• src/Heist/Splices/Markdown.hs +184/−0
• src/Heist/TemplateDirectory.hs +100/−0
• src/Heist/Types.hs +489/−0
• src/Text/Templating/Heist.hs +0/−176
• src/Text/Templating/Heist/Internal.hs +0/−743
• src/Text/Templating/Heist/Splices.hs +0/−16
• src/Text/Templating/Heist/Splices/Apply.hs +0/−65
• src/Text/Templating/Heist/Splices/Bind.hs +0/−39
• src/Text/Templating/Heist/Splices/BindStrict.hs +0/−32
• src/Text/Templating/Heist/Splices/Cache.hs +0/−152
• src/Text/Templating/Heist/Splices/Html.hs +0/−47
• src/Text/Templating/Heist/Splices/Ignore.hs +0/−22
• src/Text/Templating/Heist/Splices/Json.hs +0/−222
• src/Text/Templating/Heist/Splices/Markdown.hs +0/−183
• src/Text/Templating/Heist/TemplateDirectory.hs +0/−85
• src/Text/Templating/Heist/Types.hs +0/−406
• test/heist-testsuite.cabal +77/−21
• test/runTestsAndCoverage.sh +7/−7
• test/suite/Benchmark.hs +116/−0
• test/suite/Heist/Compiled/Tests.hs +38/−0
• test/suite/Heist/Interpreted/Tests.hs +658/−0
• test/suite/Heist/TestCommon.hs +108/−0
• test/suite/Heist/Tests.hs +200/−0
• test/suite/Heist/Tutorial/AttributeSplices.lhs +58/−0
• test/suite/Heist/Tutorial/CompiledSplices.lhs +269/−0
• test/suite/Heist/Tutorial/Imports.hs +25/−0
• test/suite/TestSuite.hs +10/−4
• test/suite/Text/Templating/Heist/Tests.hs +0/−692
• test/templates-bad/apply-missing-attr.tpl +3/−0
• test/templates-bad/apply-template-not-found.tpl +3/−0
• test/templates-bad/bind-infinite-loop.tpl +2/−0
• test/templates-bad/bind-missing-attr.tpl +2/−0
• test/templates/attr_splice.tpl +2/−0
• test/templates/attrsubtest1.tpl +1/−0
• test/templates/attrsubtest2.tpl +1/−0
• test/templates/bind-apply-interaction/_outer.tpl +6/−0
• test/templates/bind-apply-interaction/caller.tpl +1/−0
• test/templates/bind_param.tpl +1/−0
• test/templates/cache.tpl +3/−0
• test/templates/div_expansion.tpl +1/−0
• test/templates/etc.tpl +0/−3
• test/templates/foo/markdown-chdir.tpl +5/−0
• test/templates/foo/markdown-origdir.tpl +3/−0
• test/templates/foo/test2.md +1/−0
• test/templates/head_merge/index.tpl +6/−0
• test/templates/head_merge/nav.tpl +4/−0
• test/templates/head_merge/wrap.tpl +9/−0
• test/templates/ioc.tpl +0/−3
• test/templates/noroot.tpl +0/−3
• test/templates/page.tpl +1/−1
• test/templates/people.tpl +3/−0
• test/templates/post.tpl +4/−0
• test/templates/textarea_expansion.tpl +1/−0
• test/templates/title_expansion.tpl +1/−0
• test/templates/user/admin/main.tpl +0/−2

@@ -1,7 +1,27 @@ name:           heist-version:        0.8.2-synopsis:       An (x)html templating system-description:    An (x)html templating system+version:        0.10.0+synopsis:       An Haskell template system supporting both HTML5 and XML.+description:+    Heist is a powerful template system that supports both HTML5 and XML.+    Some of Heist's features are:+    .+    * Designer-friendly HTML5 (or XML) syntax+    .+    * Templates can be reloaded to make changes visible without recompiling+      your Haskell code+    .+    * Enforces near-perfect separation of business logic and view+    .+    * Powerful abstraction primitives allowing you to eliminate repetition+    .+    * Easy creation of domain-specific markup languages+    .+    * Built-in support for including JSON and Markdown content in templates+    .+    * Simple mechanism for designer-specified template caching+    .+    * Optional merging of multiple \<head\> tags defined anywhere in the+      document license:        BSD3 license-file:   LICENSE author:         Doug Beardsley, Gregory Collins@@ -36,30 +56,57 @@   test/heist-testsuite.cabal,   test/README,   test/runTestsAndCoverage.sh,+  test/suite/Benchmark.hs,+  test/suite/Heist/Compiled/Tests.hs,+  test/suite/Heist/Interpreted/Tests.hs,+  test/suite/Heist/TestCommon.hs,+  test/suite/Heist/Tests.hs,+  test/suite/Heist/Tutorial/AttributeSplices.lhs,+  test/suite/Heist/Tutorial/CompiledSplices.lhs,+  test/suite/Heist/Tutorial/Imports.hs,   test/suite/TestSuite.hs,-  test/suite/Text/Templating/Heist/Tests.hs,   test/templates/a.tpl,+  test/templates/attr_splice.tpl,   test/templates/attrs.tpl,+  test/templates/attrsubtest1.tpl,+  test/templates/attrsubtest2.tpl,   test/templates/bar/a.tpl,   test/templates/bar/index.tpl,+  test/templates/bind-apply-interaction/_outer.tpl,+  test/templates/bind-apply-interaction/caller.tpl,   test/templates/bind-attrs.tpl,-  test/templates/etc.tpl,+  test/templates/bind_param.tpl,+  test/templates/cache.tpl,+  test/templates/div_expansion.tpl,   test/templates/foo/a.tpl,   test/templates/foo/b.tpl,+  test/templates/foo/markdown-chdir.tpl,+  test/templates/foo/markdown-origdir.tpl,+  test/templates/foo/test2.md,+  test/templates/head_merge/index.tpl,+  test/templates/head_merge/nav.tpl,+  test/templates/head_merge/wrap.tpl,   test/templates/index.tpl,   test/templates/ioc.tpl,   test/templates/json.tpl,   test/templates/json_object.tpl,   test/templates/json_snippet.tpl,   test/templates/markdown.tpl,-  test/templates/noroot.tpl,   test/templates/page.tpl,+  test/templates/people.tpl,+  test/templates/post.tpl,   test/templates/readme.txt,   test/templates/test.md,+  test/templates/textarea_expansion.tpl,+  test/templates/title_expansion.tpl,   test/templates/user/admin/main.tpl,   test/templates/user/admin/menu.tpl,   test/templates/user/main.tpl,   test/templates/user/menu.tpl,+  test/templates-bad/apply-missing-attr.tpl,+  test/templates-bad/apply-template-not-found.tpl,+  test/templates-bad/bind-infinite-loop.tpl,+  test/templates-bad/bind-missing-attr.tpl,   TODO  @@ -67,41 +114,50 @@   hs-source-dirs: src    exposed-modules:-    Text.Templating.Heist,-    Text.Templating.Heist.Splices,-    Text.Templating.Heist.Splices.Apply,-    Text.Templating.Heist.Splices.Bind,-    Text.Templating.Heist.Splices.BindStrict,-    Text.Templating.Heist.Splices.Cache,-    Text.Templating.Heist.Splices.Html,-    Text.Templating.Heist.Splices.Ignore,-    Text.Templating.Heist.Splices.Json,-    Text.Templating.Heist.Splices.Markdown,-    Text.Templating.Heist.TemplateDirectory+    Heist,+    Heist.Compiled,+    Heist.Interpreted,+    Heist.Splices,+    Heist.Splices.Apply,+    Heist.Splices.Bind,+    Heist.Splices.BindStrict,+    Heist.Splices.Cache,+    Heist.Splices.Html,+    Heist.Splices.Ignore,+    Heist.Splices.Json,+    Heist.Splices.Markdown,+    Heist.TemplateDirectory    other-modules:-    Text.Templating.Heist.Internal,-    Text.Templating.Heist.Types+    Data.HeterogeneousEnvironment,+    Heist.Common,+    Heist.Compiled.Internal,+    Heist.Interpreted.Internal,+    Heist.Types    build-depends:-    aeson                     >= 0.6   && < 0.7,-    attoparsec                >= 0.10  && < 0.11,-    base                      >= 4     && < 5,-    blaze-builder             >= 0.2   && < 0.4,-    blaze-html                >= 0.4   && < 0.6,-    bytestring,-    directory,-    directory-tree,-    filepath,-    MonadCatchIO-transformers >= 0.2.1 && < 0.4,-    mtl                       >= 2.0   && < 2.2,-    process,-    random,-    text                      >= 0.10  && < 0.12,-    time                      >= 1.1   && < 1.5,-    xmlhtml                   >= 0.1.6 && < 0.3,-    unordered-containers      >= 0.1.4 && < 0.3,-    vector                    >= 0.9   && < 0.11+    MonadCatchIO-transformers  >= 0.2.1   && < 0.4,+    aeson                      >= 0.6     && < 0.7,+    attoparsec                 >= 0.10    && < 0.11,+    base                       >= 4       && < 5,+    blaze-builder              >= 0.2     && < 0.4,+    blaze-html                 >= 0.4     && < 0.6,+    bytestring                 >= 0.9     && < 0.11,+    containers                 >= 0.2     && < 0.6,+    directory                  >= 1.1     && < 1.3,+    directory-tree             >= 0.10    && < 0.12,+    dlist                      >= 0.5     && < 0.6,+    errors                     >= 1.3     && < 1.4,+    filepath                   >= 1.3     && < 1.4,+    hashable                   >= 1.1     && < 1.2,+    mtl                        >= 2.0     && < 2.2,+    process                    >= 1.1     && < 1.2,+    random                     >= 1.0.1.0 && < 1.1,+    text                       >= 0.10    && < 0.12,+    time                       >= 1.1     && < 1.5,+    unordered-containers       >= 0.1.4   && < 0.3,+    vector                     >= 0.9     && < 0.11,+    xmlhtml                    >= 0.1.6   && < 0.3    if impl(ghc >= 6.12.0)     ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2@@ -126,4 +182,5 @@  source-repository head   type:     git-  location: http://git.snapframework.com/heist.git+  location: https://github.com/snapframework/heist.git+

@@ -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

@@ -0,0 +1,227 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}++{-|++This module defines the core data types used by Heist.  In practice you will+also want to import one or both of "Heist.Compiled" or "Heist.Interpreted" to+get functions needed for writing splices.++The Heist template system allows you to build custom HTML and XML based markup+languages.  With Heist you can define your own domain-specific tags+implemented with Haskell and use them in your templates.++-}++module Heist+  (+  -- * Primary Heist initialization functions+    loadTemplates+  , addTemplatePathPrefix+  , initHeist+  , initHeistWithCacheTag+  , defaultLoadTimeSplices++  -- * Core Heist data types+  , Template+  , TPath+  , HeistConfig(..)+  , MIMEType+  , DocumentFile(..)+  , AttrSplice+  , RuntimeSplice+  , Chunk+  , HeistState(..)+  , templateNames+  , compiledTemplateNames+  , hasTemplate+  , spliceNames+  , HeistT+  , evalHeistT+  , getParamNode+  , getContext+  , getTemplateFilePath+  , localParamNode+  , getsHS+  , getHS+  , putHS+  , modifyHS+  , restoreHS+  , localHS+  , getDoc+  , getXMLDoc+  , orError+  ) where++import           Control.Error+import           Control.Exception (SomeException)+import           Control.Monad.CatchIO+import           Control.Monad.Trans+import           Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.Foldable as F+import qualified Data.HeterogeneousEnvironment   as HE+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.Splices+import           Heist.Types+++data HeistConfig m = HeistConfig+    { hcInterpretedSplices :: [(Text, I.Splice m)]+    -- ^ Interpreted splices are the splices that Heist has always had.  They+    -- return a list of nodes and are processed at runtime.+    , hcLoadTimeSplices    :: [(Text, I.Splice IO)]+    -- ^ Load time splices are like interpreted splices because they return a+    -- list of nodes.  But they are like compiled splices because they are+    -- processed once at load time.  All of Heist's built-in splices should be+    -- used as load time splices.+    , hcCompiledSplices    :: [(Text, C.Splice m)]+    -- ^ Compiled splices return a DList of Chunks and are processed at load+    -- time to generate a runtime monad action that will be used to render the+    -- template.+    , hcAttributeSplices   :: [(Text, AttrSplice m)]+    -- ^ Attribute splices are bound to attribute names and return a list of+    -- attributes.+    , hcTemplates          :: HashMap TPath DocumentFile+    -- ^ Templates returned from the 'loadTemplates' function.+    }+++instance Monoid (HeistConfig m) where+    mempty = HeistConfig [] [] [] [] Map.empty+    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')+                    (e `mappend` e')+++------------------------------------------------------------------------------+-- | The built-in set of static splices.  All the splices that used to be+-- enabled by default are included here.  To get the normal Heist behavior you+-- should include these in the hcLoadTimeSplices list in your HeistConfig.+defaultLoadTimeSplices :: MonadIO m => [(Text, (I.Splice m))]+defaultLoadTimeSplices =+    [ (applyTag, applyImpl)+    , (bindTag, bindImpl)+    , (ignoreTag, ignoreImpl)+    , (markdownTag, markdownSplice)+    , ("content", deprecatedContentCheck) -- To be removed in later versions+    ]+++------------------------------------------------------------------------------+-- | Loads templates from disk.  This function returns just a template map so+-- you can load multiple directories and combine the maps before initializing+-- your HeistState.+loadTemplates :: FilePath -> EitherT [String] IO (HashMap TPath DocumentFile)+loadTemplates dir = do+    d <- lift $ readDirectoryWith (loadTemplate dir) dir+    let tlist = F.fold (free d)+        errs = lefts tlist+    case errs of+        [] -> right $ Map.fromList $ rights tlist+        _  -> left errs+++------------------------------------------------------------------------------+-- | Adds a path prefix to a templates in a map returned by loadTemplates.  If+-- you want to add multiple levels of directories, separate them with slashes+-- as in "foo/bar".  Using an empty string as a path prefix will leave the+-- map unchanged.+addTemplatePathPrefix :: ByteString+                      -> HashMap TPath DocumentFile+                      -> HashMap TPath DocumentFile+addTemplatePathPrefix dir ts+  | B.null dir = ts+  | otherwise  = Map.fromList $+                 map (\(x,y) -> (f x, y)) $+                 Map.toList ts+  where+    f ps = ps++splitTemplatePath dir+++------------------------------------------------------------------------------+-- | This is the main Heist initialization function.  You pass in a map of all+-- templates and all of your splices and it constructs and returns a+-- HeistState.+--+-- We don't provide functions to add either type of loadtime splices to your+-- HeistState after initHeist because it doesn't make any sense unless you+-- re-initialize all templates with the new splices.  If you add any old-style+-- runtime heist splices after calling this function, they will still work+-- fine if you use Heist.Interpreted.renderTemplate.  If you add any templates+-- later, then those templates will be available for interpreted rendering,+-- but not for compiled rendering.+--+-- In the past you could add templates to your HeistState after initialization+-- using its Monoid instance.  Due to implementation details, this is no+-- longer possible.  All of your templates must be known when you call this+-- function.+initHeist :: Monad n+          => HeistConfig n+          -> EitherT [String] IO (HeistState n)+initHeist (HeistConfig i lt c a rawTemplates) = do+    keyGen <- lift HE.newKeyGen+    let empty = HeistState Map.empty Map.empty Map.empty Map.empty+                           Map.empty True [] 0 [] Nothing keyGen False+        hs0 = empty { _spliceMap = Map.fromList lt+                    , _templateMap = rawTemplates+                    , _preprocessingMode = True }+    tPairs <- lift $ evalHeistT+        (mapM preprocess $ Map.toList rawTemplates) (X.TextNode "") hs0+    let bad = lefts tPairs+        tmap = Map.fromList $ rights tPairs+        hs1 = empty { _spliceMap = Map.fromList i+                    , _templateMap = tmap+                    , _compiledSpliceMap = Map.fromList c+                    , _attrSpliceMap = Map.fromList a+                    }+    if not (null bad)+      then left bad+      else lift $ C.compileTemplates hs1+++------------------------------------------------------------------------------+-- | +preprocess :: (TPath, DocumentFile)+           -> HeistT IO IO (Either String (TPath, DocumentFile))+preprocess (tpath, docFile) = do+        let tname = tpathName tpath+        !emdoc <- try $ I.evalWithDoctypes tname+                  :: HeistT IO IO (Either SomeException (Maybe X.Document))+        let f !doc = (tpath, docFile { dfDoc = doc })+        return $! either (Left . show) (Right . maybe die f) emdoc+  where+    die = error "Preprocess didn't succeed!  This should never happen."+++------------------------------------------------------------------------------+-- | Wrapper around initHeist that also sets up a cache tag.  It sets up both+-- compiled and interpreted versions of the cache tag splices.  If you need to+-- do configure the cache tag differently than how this function does it, you+-- will still probably want to pattern your approach after this function's+-- implementation.+initHeistWithCacheTag :: MonadIO n+                      => HeistConfig n+                      -> EitherT [String] IO (HeistState n, CacheTagState)+initHeistWithCacheTag (HeistConfig i lt c a rawTemplates) = do+    (ss, cts) <- liftIO mkCacheTag+    let tag = "cache"+        hc' = HeistConfig ((tag, cacheImpl cts) : i)+                          ((tag, ss) : lt)+                          ((tag, cacheImplCompiled cts) : c)+                          a rawTemplates+    hs <- initHeist hc'+    return (hs, cts)+

@@ -0,0 +1,288 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}++module Heist.Common where++import           Control.Applicative+import           Control.Exception (SomeException)+import           Control.Monad+import           Control.Monad.CatchIO+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+import           Data.List+import           Data.Maybe+import           Data.Monoid+import qualified Data.Text                       as T+import           Prelude hiding (catch)+import           System.FilePath+import           Heist.Types+import qualified Text.XmlHtml as X+++------------------------------------------------------------------------------+-- | If Heist is running in fail fast mode, then this function will throw an+-- exception with the second argument as the error message.  Otherwise, the+-- first argument will be executed to represent silent failure.+--+-- This behavior allows us to fail quickly if an error crops up during+-- load-time splice processing or degrade more gracefully if the error occurs+-- while a user request is being processed.+orError :: Monad m => HeistT n m b -> String -> HeistT n m b+orError silent msg = do+    hs <- getHS+    if _preprocessingMode hs+      then error $ (maybe "" (++": ") $ _curTemplateFile hs) ++ msg+      else silent+++------------------------------------------------------------------------------+-- | Function for showing a TPath.+showTPath :: TPath -> String+showTPath = BC.unpack . (`BC.append` ".tpl") . tpathName++tpathName :: TPath -> ByteString+tpathName = BC.intercalate "/" . reverse+++------------------------------------------------------------------------------+-- | Sets the current template file.+setCurTemplateFile :: Maybe FilePath -> HeistState n -> HeistState n+setCurTemplateFile Nothing ts = ts+setCurTemplateFile fp ts = ts { _curTemplateFile = fp }+++------------------------------------------------------------------------------+setCurContext :: TPath -> HeistState n -> HeistState n+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)+                    <|> (do+                            res <- escSequence+                            dl' <- finish subDL+                            loop $! append dl' res)+                    <|> (do+                            idp <- identParser+                            dl' <- finish subDL+                            loop $! append dl' idp)++    gobbleText = AP.takeWhile1 (AP.notInClass "\\$")++    escSequence = AP.char '\\' *> (Escaped <$> 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+               -> (HeistState n -> HashMap TPath t)+               -> Maybe (t, TPath)+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 -> 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 compiled and interpreted splices.  The old type signature was+-- this:+--+-- > mapSplices :: (Monad n)+-- >         => (a -> Splice n n)+-- >         -> [a]+-- >         -> Splice n n+mapSplices :: (Monad m, Monoid b)+           => (a -> m b)+           -- ^ Splice generating function+           -> [a]+           -- ^ List of items to generate splices for+           -> m b+           -- ^ The result of all splices concatenated together.+mapSplices f vs = liftM mconcat $ mapM f vs+{-# INLINE mapSplices #-}+++------------------------------------------------------------------------------+-- | Gets the current context+getContext :: Monad m => HeistT n m TPath+getContext = getsHS _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 = getsHS _curTemplateFile+++------------------------------------------------------------------------------+-- | Loads a template with the specified path and filename.  The+-- template is only loaded if it has a ".tpl" or ".xtpl" extension.+loadTemplate :: String -- ^ path of the template root+             -> String -- ^ full file path (includes the template root)+             -> IO [Either String (TPath, DocumentFile)] --TemplateMap+loadTemplate templateRoot fname+    | isHTMLTemplate = do+        c <- getDoc fname+        return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c]+    | isXMLTemplate = do+        c <- getXMLDoc fname+        return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c]+    | otherwise = return []+  where -- tName is path relative to the template root directory+        isHTMLTemplate = ".tpl"  `isSuffixOf` fname+        isXMLTemplate  = ".xtpl" `isSuffixOf` fname+        correction = if last templateRoot == '/' then 0 else 1+        extLen     = if isHTMLTemplate then 4 else 5+        tName = drop ((length templateRoot)+correction) $+                -- We're only dropping the template root, not the whole path+                take ((length fname) - extLen) fname+++------------------------------------------------------------------------------+-- | Type synonym for parsers.+type ParserFun = String -> ByteString -> Either String X.Document+++------------------------------------------------------------------------------+-- | 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)+                (\(e::SomeException) -> return $ Left $ show e)++    let eitherDoc = either Left (parser f) bs+    return $ either (\s -> Left $ f ++ " " ++ s)+                    (\d -> Right $ DocumentFile d (Just f)) eitherDoc+++------------------------------------------------------------------------------+-- | Reads an HTML template from disk.+getDoc :: String -> IO (Either String DocumentFile)+getDoc = getDocWith X.parseHTML+++------------------------------------------------------------------------------+-- | Reads an XML template from disk.+getXMLDoc :: String -> IO (Either String DocumentFile)+getXMLDoc = getDocWith X.parseXML+++------------------------------------------------------------------------------+-- | Sets the templateMap in a HeistState.+setTemplates :: HashMap TPath DocumentFile -> HeistState n -> HeistState n+setTemplates m ts = ts { _templateMap = m }+++------------------------------------------------------------------------------+-- | Adds a template to the heist state.+insertTemplate :: TPath+               -> DocumentFile+               -> HeistState n+               -> HeistState n+insertTemplate p t st =+    setTemplates (Map.insert p t (_templateMap st)) st+++------------------------------------------------------------------------------+-- Gives the MIME type for a 'X.Document'+mimeType :: X.Document -> MIMEType+mimeType d = case d of+    (X.HtmlDocument e _ _) -> "text/html;charset=" `BC.append` enc e+    (X.XmlDocument  e _ _) -> "text/xml;charset="  `BC.append` enc e+  where+    enc X.UTF8    = "utf-8"+    -- Should not include byte order designation for UTF-16 since+    -- rendering will include a byte order mark. (RFC 2781, Sec. 3.3)+    enc X.UTF16BE = "utf-16"+    enc X.UTF16LE = "utf-16"++

@@ -0,0 +1,61 @@+{-|++Compiled splices are similar to the original Heist (interpreted) splices, but+without the high performance costs of traversing a DOM at runtime.  Compiled+splices do all of their DOM processing at load time.  They are compiled to+produce a runtime computation that generates a ByteString Builder.  This+preserves the ability to write splices that access runtime information from+the HTTP request, database, etc.++If you import both this module and "Heist.Interpreted" in the same file, then+you will need to import them qualified.++-}++module Heist.Compiled+  (+  -- * High level compiled splice API+    Splice+  , renderTemplate+  , mapPromises+  , promiseChildren+  , promiseChildrenWith+  , promiseChildrenWithTrans+  , promiseChildrenWithText+  , promiseChildrenWithNodes++  -- * Constructing Chunks+  -- $yieldOverview+  , yieldPure+  , yieldRuntime+  , yieldRuntimeEffect+  , yieldPureText+  , yieldRuntimeText+  , yieldLater+  , addSplices++  -- * Lower level promise functions+  , Promise+  , newEmptyPromise++  -- * RuntimeSplice functions+  , getPromise+  , putPromise+  , adjustPromise+  , codeGen++  -- * Running nodes and splices+  , runNodeList+  , runNode+  , compileNode+  , runSplice++  ) where++import Heist.Compiled.Internal++-- $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.

@@ -0,0 +1,604 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeSynonymInstances       #-}++module Heist.Compiled.Internal where++import           Blaze.ByteString.Builder+import           Control.Arrow+import           Control.Monad.RWS.Strict+import           Control.Monad.State.Strict+import qualified Data.Attoparsec.Text            as AP+import           Data.ByteString (ByteString)+import           Data.DList                      (DList)+import qualified Data.DList                      as DL+import qualified Data.HashMap.Strict             as H+import qualified Data.HeterogeneousEnvironment   as HE+import           Data.Maybe+import           Data.Text                       (Text)+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           Heist.Common+import           Heist.Types++------------------------------------------------------------------------------+-- | A compiled Splice is a HeistT computation that returns a @DList+-- (Chunk m)@.+--+-- The more interesting part of the type signature is what comes before the+-- return value.  The first type parameter in @'HeistT' n IO@ is the runtime+-- monad.  This reveals that the Chunks know about the runtime monad.  The+-- second type parameter in @HeistT n IO@ is @IO@.  This tells is that the+-- compiled splices themselves are run in the IO monad, which will usually+-- mean at load time.  Compiled splices run at load time, and they return+-- computations that run at runtime.+type Splice n = HeistT n IO (DList (Chunk n))+++------------------------------------------------------------------------------+-- | 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.+            -> n [a]+            -- ^ Runtime computation returning a list of items+            -> Splice n+mapPromises f getList = do+    singlePromise <- newEmptyPromise+    runSingle <- f singlePromise+    return $ yieldRuntime $ do+        list <- lift 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 m => HeistT m IO (RuntimeSplice m Builder)+promiseChildren = do+    res <- runNodeList . X.childNodes =<< getParamNode+    return $! codeGen $! consolidate res+{-# 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 (fromByteString . T.encodeUtf8)+++------------------------------------------------------------------------------+-- | 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 =+    promiseChildrenWithTrans (X.renderHtmlFragment X.UTF8)+++------------------------------------------------------------------------------+-- | Yields pure text known at load time.+pureTextChunk :: Text -> Chunk n+pureTextChunk t = Pure $ T.encodeUtf8 t+{-# INLINE pureTextChunk #-}+++------------------------------------------------------------------------------+-- | Yields a pure Builder known at load time.  You should use this and+-- 'yieldPureText' as much as possible to maximize the parts of your page that+-- can be compiled to static ByteStrings.+yieldPure :: Builder -> DList (Chunk m)+yieldPure = DL.singleton . Pure . toByteString+{-# INLINE yieldPure #-}+++------------------------------------------------------------------------------+-- | Yields a runtime action that returns a builder.+yieldRuntime :: RuntimeSplice m Builder -> DList (Chunk m)+yieldRuntime = DL.singleton . RuntimeHtml+{-# INLINE yieldRuntime #-}+++------------------------------------------------------------------------------+-- | Yields a runtime action that returns no value and is only needed for its+-- side effect.+yieldRuntimeEffect :: Monad m => RuntimeSplice m () -> DList (Chunk m)+yieldRuntimeEffect = DL.singleton . RuntimeAction+{-# INLINE yieldRuntimeEffect #-}+++------------------------------------------------------------------------------+-- | A convenience wrapper around yieldPure for working with Text.  Roughly+-- equivalent to 'textSplice' from Heist.Interpreted.+yieldPureText :: Text -> DList (Chunk m)+yieldPureText = DL.singleton . pureTextChunk+{-# INLINE yieldPureText #-}+++------------------------------------------------------------------------------+-- | Convenience wrapper around yieldRuntime allowing you to work with Text.+yieldRuntimeText :: Monad m => RuntimeSplice m Text -> DList (Chunk m)+yieldRuntimeText = yieldRuntime .  liftM (fromByteString . T.encodeUtf8)+{-# INLINE yieldRuntimeText #-}+++------------------------------------------------------------------------------+-- | This lets you turn a plain runtime monad function returning a Builder+-- into a compiled splice.+yieldLater :: Monad m => m Builder -> DList (Chunk m)+yieldLater = yieldRuntime . RuntimeSplice . lift+{-# INLINE yieldLater #-}+++------------------------------------------------------------------------------+-- | Returns a computation that performs load-time splice processing on the+-- supplied list of nodes.+runNodeList :: Monad n => [X.Node] -> Splice n+runNodeList = mapSplices runNode+++------------------------------------------------------------------------------+-- | Runs a single splice and returns the builder computation.+runSplice :: (Monad n)+          => X.Node+          -> HeistState n+          -> Splice n+          -> IO [Chunk n]+runSplice node hs splice = do+    (!a,_) <- runHeistT splice node hs+    return $! consolidate a+++------------------------------------------------------------------------------+-- | Runs a DocumentFile with the appropriate template context set.+runDocumentFile :: Monad n+                => TPath+                -> DocumentFile+                -> Splice n+runDocumentFile tpath df = do+    modifyHS (setCurTemplateFile curPath .  setCurContext tpath)+    runNodeList nodes+  where+    curPath     = dfFile df+    nodes       = X.docContent $! dfDoc df+++------------------------------------------------------------------------------+compileTemplate :: Monad n+                => HeistState n+                -> TPath+                -> DocumentFile+                -> IO [Chunk n]+compileTemplate hs tpath df = do+    !chunks <- runSplice nullNode hs $! runDocumentFile tpath df+    return chunks+  where+    -- This gets overwritten in runDocumentFile+    nullNode = X.TextNode ""+++------------------------------------------------------------------------------+compileTemplates :: Monad n => HeistState n -> IO (HeistState n)+compileTemplates hs = do+    ctm <- compileTemplates' hs+    return $! hs { _compiledTemplateMap = ctm }+--    let f = flip evalStateT HE.empty . unRT . codeGen+--    return $! hs { _compiledTemplateMap = H.map (first f) ctm }+++------------------------------------------------------------------------------+compileTemplates' :: Monad m+                  => HeistState m+                  -> IO (H.HashMap TPath ([Chunk m], MIMEType))+compileTemplates' hs = do+    ctm <- foldM runOne H.empty tpathDocfiles+    return $! ctm+  where+    tpathDocfiles :: [(TPath, DocumentFile)]+    tpathDocfiles = map (\(a,b) -> (a, b))+                        (H.toList $ _templateMap hs)++    runOne tmap (tpath, df) = do+        !mHtml <- compileTemplate hs tpath df+        return $! H.insert tpath (mHtml, mimeType $! dfDoc df) tmap+++------------------------------------------------------------------------------+-- | Consolidate consecutive Pure Chunks.+consolidate :: (Monad m) => DList (Chunk m) -> [Chunk m]+consolidate = consolidateL . DL.toList+  where+    consolidateL []     = []+    consolidateL (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+    +        ----------------------------------------------------------------------+        boilDown soFar []              = soFar+    +        boilDown soFar ((Pure h) : xs) = boilDown ((Pure $! h) : soFar) xs+    +        boilDown soFar (x : xs) = boilDown (x : soFar) xs+++------------------------------------------------------------------------------+-- | 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 => [Chunk m] -> RuntimeSplice m Builder+codeGen l = V.foldr mappend mempty $! V.map toAct $! V.fromList l+  where+    toAct !(RuntimeHtml !m)   = m+    toAct !(Pure !h)          = return $! fromByteString h+    toAct !(RuntimeAction !m) = m >> return mempty+{-# INLINE codeGen #-}+++------------------------------------------------------------------------------+-- | Looks up a splice in the compiled splice map.+lookupSplice :: Text -> HeistT n IO (Maybe (Splice n))+lookupSplice nm = getsHS (H.lookup nm . _compiledSpliceMap)+++------------------------------------------------------------------------------+-- | Runs a single node.  If there is no splice referenced anywhere in the+-- subtree, then it is rendered as a pure chunk, otherwise it is compiled to+-- a runtime computation.+runNode :: Monad n => X.Node -> Splice n+runNode node = localParamNode (const node) $ do+    isStatic <- subtreeIsStatic node+    if isStatic+      then return $! yieldPure $!+             X.renderHtmlFragment X.UTF8 [parseAttrs node]+      else compileNode node+++parseAttrs :: X.Node -> X.Node+parseAttrs (X.Element nm attrs ch) = newAttrs `seq` X.Element nm newAttrs ch+  where+    newAttrs = map parseAttr attrs+parseAttrs !n = n++parseAttr :: (Text, Text) -> (Text, Text)+parseAttr (k,v) = (k, T.concat $! map cvt ast)+  where+    !ast = case AP.feed (AP.parse attParser v) "" of+            (AP.Done _ res) -> res+            (AP.Fail _ _ _) -> []+            (AP.Partial _ ) -> []+    cvt (Literal x) = x+    cvt (Escaped c) = T.singleton c+    cvt (Ident _) = error "parseAttrs: impossible case"++------------------------------------------------------------------------------+-- | Checks whether a node's subtree is static and can be rendered up front at+-- load time.+subtreeIsStatic :: X.Node -> HeistT n IO Bool+subtreeIsStatic (X.Element nm attrs ch) = do+    isNodeDynamic <- liftM isJust $ lookupSplice nm+    attrSplices <- getsHS _attrSpliceMap+    let hasSubstitutions (k,v) = hasAttributeSubstitutions v ||+                                 H.member k attrSplices+    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++subtreeIsStatic _ = return True+++------------------------------------------------------------------------------+-- | Checks whether a string has any attribute substitutions.+hasAttributeSubstitutions :: Text -> Bool+hasAttributeSubstitutions txt = any isIdent ast+  where+    ast = case AP.feed (AP.parse attParser txt) "" of+            (AP.Done _ res) -> res+            (AP.Fail _ _ _) -> []+            (AP.Partial _ ) -> []+++------------------------------------------------------------------------------+-- |+parseAtt :: Monad n => (Text, Text) -> HeistT n IO (DList (Chunk n))+parseAtt (k,v) = do+    mas <- getsHS (H.lookup k . _attrSpliceMap)+    maybe doInline (return . doAttrSplice) mas++  where+    cvt (Literal x) = return $ yieldPureText x+    cvt (Escaped c) = return $ yieldPureText $ T.singleton c+    cvt (Ident x) =+        localParamNode (const $ X.Element x [] []) $ getAttributeSplice x++    -- Handles inline parsing of $() splice syntax in attributes+    doInline = do+        let ast = case AP.feed (AP.parse attParser v) "" of+                    (AP.Done _ res) -> res+                    (AP.Fail _ _ _) -> []+                    (AP.Partial _ ) -> []+        chunks <- mapM cvt ast+        let value = DL.concat chunks+        return $ attrToChunk k value++    -- Handles attribute splices+    doAttrSplice splice = DL.singleton $ RuntimeHtml $ lift $ do+        res <- splice v+        return $ mconcat $ map attrToBuilder res++    +------------------------------------------------------------------------------+-- | 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 n => X.Node -> Splice n+compileNode (X.Element nm attrs ch) =+    -- Is this node a splice, or does it merely contain splices?+    lookupSplice 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+        compiledAttrs <- mapM parseAtt attrs++        childHtml <- runNodeList ch++        return $! if null (DL.toList childHtml)+          then DL.concat [ DL.singleton $! pureTextChunk $! tag0+                         , DL.concat compiledAttrs+                         , DL.singleton $! pureTextChunk " />"+                         ]+          else DL.concat [ DL.singleton $! pureTextChunk $! tag0+                         , DL.concat compiledAttrs+                         , DL.singleton $! pureTextChunk ">"+                         , childHtml+                         , DL.singleton $! pureTextChunk $! end+                         ]+compileNode _ = error "impossible"+++attrToChunk :: Text -> DList (Chunk n) -> DList (Chunk n)+attrToChunk !k !v = do+    DL.concat+        [ DL.singleton $! pureTextChunk $! T.concat [" ", k, "=\""]+        , v, DL.singleton $! pureTextChunk "\"" ]+    ++attrToBuilder :: (Text, Text) -> Builder+attrToBuilder (k,v)+  | T.null v  = mconcat+    [ fromByteString $! T.encodeUtf8 " "+    , fromByteString $! T.encodeUtf8 k+    ]+  | otherwise = mconcat+    [ fromByteString $! T.encodeUtf8 " "+    , fromByteString $! T.encodeUtf8 k+    , fromByteString $! T.encodeUtf8 "=\""+    , fromByteString $! T.encodeUtf8 v+    , fromByteString $! T.encodeUtf8 "\""+    ]+++------------------------------------------------------------------------------+getAttributeSplice :: Text -> HeistT n IO (DList (Chunk n))+getAttributeSplice name =+    lookupSplice name >>= fromMaybe (return DL.empty)+{-# INLINE getAttributeSplice #-}+++------------------------------------------------------------------------------+-- | Promises are used for referencing the results of future runtime+-- computations during load time splice processing.+newtype Promise a = Promise (HE.Key a)+++------------------------------------------------------------------------------+-- | Gets the result of a promised runtime computation.+getPromise :: (Monad m) => Promise a -> RuntimeSplice m a+getPromise (Promise k) = do+    mb <- gets (HE.lookup k)+    return $ fromMaybe e mb++  where+    e = error $ "getPromise: dereferenced empty key (id "+                ++ show (HE.getKeyId k) ++ ")"+{-# INLINE getPromise #-}+++------------------------------------------------------------------------------+-- | Adds a promise to the runtime splice context.+putPromise :: (Monad m) => Promise a -> a -> RuntimeSplice m ()+putPromise (Promise k) x = modify (HE.insert k x)+{-# INLINE putPromise #-}+++------------------------------------------------------------------------------+-- | Modifies a promise.+adjustPromise :: Monad m => Promise a -> (a -> a) -> RuntimeSplice m ()+adjustPromise (Promise k) f = modify (HE.adjust f k)+{-# INLINE adjustPromise #-}+++------------------------------------------------------------------------------+-- | Creates an empty promise.+newEmptyPromise :: HeistT n IO (Promise a)+newEmptyPromise = do+    keygen <- getsHS _keygen+    key    <- liftIO $ HE.makeKey keygen+    return $! Promise key+{-# INLINE newEmptyPromise #-}+++-- ------------------------------------------------------------------------------+-- -- | Creates an empty promise with some error checking to help with debugging.+-- newEmptyPromiseWithError :: (Monad n)+--                          => String -> HeistT n IO (Promise a)+-- newEmptyPromiseWithError from = do+--     keygen <- getsHS _keygen+--     prom   <- liftM Promise $ liftIO $ HE.makeKey keygen+--     yieldRuntimeEffect $ putPromise prom+--                        $ error+--                        $ "deferenced empty promise created at" ++ from+--     return prom+-- {-# INLINE newEmptyPromiseWithError #-}+-- +-- +-- ------------------------------------------------------------------------------+-- -- | Creates a promise for a future runtime computation.+-- promise :: (Monad n) => n a -> HeistT n IO (Promise a)+-- promise act = runtimeSplicePromise (lift act)+-- {-# INLINE promise #-}+-- +-- +-- ------------------------------------------------------------------------------+-- -- | Turns a RuntimeSplice computation into a promise.+-- runtimeSplicePromise :: (Monad n)+--                      => RuntimeSplice n a+--                      -> HeistT n IO (Promise a)+-- runtimeSplicePromise act = do+--     prom <- newEmptyPromiseWithError "runtimeSplicePromise"+-- +--     let m = do+--         x <- act+--         putPromise prom x+--         return ()+-- +--     yieldRuntimeEffect m+--     return prom+-- {-# INLINE runtimeSplicePromise #-}+-- +-- +-- ------------------------------------------------------------------------------+-- -- | Sets up a runtime transformation on a 'Promise'.+-- withPromise :: (Monad n)+--             => Promise a+--             -> (a -> n b)+--             -> HeistT n IO (Promise b)+-- withPromise promA f = do+--     promB <- newEmptyPromiseWithError "withPromise"+-- +--     let m = do+--         a <- getPromise promA+--         b <- lift $ f a+--         putPromise promB b+--         return ()+-- +--     yieldRuntimeEffect m+--     return promB+-- {-# INLINE withPromise #-}+++------------------------------------------------------------------------------+-- | Binds a compiled splice.  This function should not be exported.+bindSplice :: Text             -- ^ tag name+           -> Splice n         -- ^ splice action+           -> HeistState n     -- ^ source state+           -> HeistState n+bindSplice n v ts =+    ts { _compiledSpliceMap = H.insert n v (_compiledSpliceMap ts) }+++------------------------------------------------------------------------------+-- | Binds a list of compiled splices.  This function should not be exported.+bindSplices :: [(Text, Splice n)]  -- ^ splices to bind+            -> HeistState n        -- ^ source state+            -> HeistState n+bindSplices ss ts = foldr (uncurry bindSplice) ts 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.+addSplices :: Monad m => [(Text, Splice n)] -> HeistT n m ()+addSplices ss = modifyHS (bindSplices ss)+++------------------------------------------------------------------------------+-- | Looks up a compiled template and returns a runtime monad computation that+-- constructs a builder.+renderTemplate :: Monad n+               => HeistState n+               -> ByteString+               -> Maybe (n Builder, MIMEType)+renderTemplate hs nm =+    fmap (first interpret . fst) $! lookupTemplate nm hs _compiledTemplateMap++interpret :: Monad m => [Chunk m] -> m Builder+interpret = flip evalStateT HE.empty . unRT . codeGen++

@@ -0,0 +1,80 @@+{-|++This module defines the API for writing and working with interpreted splices.+It exports some of the same symbols as "Heist.Compiled", so you will probably+want to import it qualified.++Interpreted splices can be thought of as a function @Node -> m [Node]@.  Heist+then substitutes the resulting list of nodes into your template in place of+the input node.  'Splice' is implemented as a type synonym @type Splice m =+HeistT m [Node]@, and 'HeistT' has a function 'getParamNode' that lets you get+the input node.++Suppose you have a place on your page where you want to display a link with+the text \"Logout username\" if the user is currently logged in or a link to+the login page if no user is logged in.  Assume you have a function+@getUser :: MyAppMonad (Maybe Text)@ that gets the current user.+You can implement this functionality with a 'Splice' as follows:++> import           Blaze.ByteString.Builder+> import           Data.ByteString.Char8 (ByteString)+> import qualified Data.ByteString.Char8 as B+> import           Data.Text (Text)+> import qualified Data.Text as T+> import qualified Text.XmlHtml as X+>+> import qualified Heist.Interpreted as I+>+> link :: Text -> Text -> X.Node+> link target text = X.Element "a" [("href", target)] [X.TextNode text]+>+> loginLink :: X.Node+> loginLink = link "/login" "Login"+>+> logoutLink :: Text -> X.Node+> logoutLink user = link "/logout" (T.append "Logout " user)+>+> loginLogoutSplice :: I.Splice MyAppMonad+> loginLogoutSplice = do+>     user <- lift getUser+>     return [maybe loginLink logoutLink user]+>++-}++module Heist.Interpreted+  (+    Splice++  -- * HeistState Functions+  , addTemplate+  , addXMLTemplate+  , lookupSplice+  , bindSplice+  , bindSplices++  -- * Functions for creating splices+  , textSplice+  , runChildren+  , runChildrenWith+  , runChildrenWithTrans+  , runChildrenWithTemplates+  , runChildrenWithText+  , mapSplices++  -- * HeistT functions+  , stopRecursion+  , runNode+  , runNodeList+  , evalTemplate+  , bindStrings+  , bindString+  , callTemplate+  , callTemplateWithText+  , renderTemplate+  , renderWithArgs+  ) where++import Heist.Interpreted.Internal+import Heist.Common (mapSplices)+

@@ -0,0 +1,427 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PackageImports             #-}+{-# LANGUAGE ScopedTypeVariables        #-}++module Heist.Interpreted.Internal where++------------------------------------------------------------------------------+import           Blaze.ByteString.Builder+import           Control.Arrow hiding (loop)+import           Control.Monad+import           Control.Monad.Trans+import qualified Data.Attoparsec.Text as AP+import           Data.ByteString (ByteString)+import           Data.List+import qualified Data.HashMap.Strict as Map+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.Types+++type Splice n = HeistT n n Template+++------------------------------------------------------------------------------+-- | 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+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Binds a new splice declaration to a tag name within a 'HeistState'.+bindSplice :: Text            -- ^ tag name+           -> Splice n        -- ^ splice action+           -> HeistState n    -- ^ source state+           -> HeistState n+bindSplice n v ts = ts {_spliceMap = Map.insert n v (_spliceMap ts)}+++------------------------------------------------------------------------------+-- | Binds a set of new splice declarations within a 'HeistState'.+bindSplices :: [(Text, Splice n)] -- ^ splices to bind+            -> HeistState n       -- ^ start state+            -> HeistState n+bindSplices ss ts = foldl' (flip id) ts acts+  where+    acts = map (uncurry bindSplice) ss+++------------------------------------------------------------------------------+-- | Converts 'Text' to a splice returning a single 'TextNode'.+textSplice :: Monad n => Text -> Splice n+textSplice t = return [X.TextNode t]+++------------------------------------------------------------------------------+-- | Runs the parameter node's children and returns the resulting node list.+-- 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 n => Splice n+runChildren = runNodeList . X.childNodes =<< getParamNode+++------------------------------------------------------------------------------+-- | Binds a list of splices before using the children of the spliced node as+-- a view.+runChildrenWith :: (Monad n)+                => [(Text, Splice n)]+                -- ^ List of splices to bind before running the param nodes.+                -> Splice n+                -- ^ Returns the passed in view.+runChildrenWith splices = localHS (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 n)+          => (b -> Splice n)+          -- ^ Splice generating function+          -> [(Text, b)]+          -- ^ List of tuples to be bound+          -> Splice n+runChildrenWithTrans f = runChildrenWith . map (second f)+++------------------------------------------------------------------------------+-- | Like runChildrenWith but using constant templates rather than dynamic+-- splices.+runChildrenWithTemplates :: (Monad n) => [(Text, Template)] -> Splice n+runChildrenWithTemplates = runChildrenWithTrans return+++------------------------------------------------------------------------------+-- | Like runChildrenWith but using literal text rather than dynamic splices.+runChildrenWithText :: (Monad n) => [(Text, Text)] -> Splice n+runChildrenWithText = runChildrenWithTrans textSplice+++------------------------------------------------------------------------------+-- | Convenience function for looking up a splice.+lookupSplice :: Text+             -> HeistState n+             -> Maybe (Splice n)+lookupSplice nm ts = Map.lookup nm $ _spliceMap ts+{-# INLINE lookupSplice #-}+++------------------------------------------------------------------------------+-- | Adds an HTML format template to the heist state.+addTemplate :: ByteString+            -- ^ Path that the template will be referenced by+            -> Template+            -- ^ The template's DOM nodes+            -> Maybe FilePath+            -- ^ An optional path to the actual file on disk where the+            -- template is stored+            -> HeistState n+            -> HeistState n+addTemplate n t mfp st =+    insertTemplate (splitTemplatePath n) doc st+  where+    doc = DocumentFile (X.HtmlDocument X.UTF8 Nothing t) mfp+++------------------------------------------------------------------------------+-- | Adds an XML format template to the heist state.+addXMLTemplate :: ByteString+               -- ^ Path that the template will be referenced by+               -> Template+               -- ^ The template's DOM nodes+               -> Maybe FilePath+               -- ^ An optional path to the actual file on disk where the+               -- template is stored+               -> HeistState n+               -> HeistState n+addXMLTemplate n t mfp st =+    insertTemplate (splitTemplatePath n) doc st+  where+    doc = DocumentFile (X.XmlDocument X.UTF8 Nothing t) mfp+++------------------------------------------------------------------------------+-- | Stops the recursive processing of splices.  Consider the following+-- example:+--+--   > <foo>+--   >   <bar>+--   >     ...+--   >   </bar>+--   > </foo>+--+-- Assume that @\"foo\"@ is bound to a splice procedure. Running the @foo@+-- 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 n m ()+stopRecursion = modifyHS (\st -> st { _recurse = False })+++------------------------------------------------------------------------------+-- | Performs splice processing on a single node.+runNode :: Monad n => X.Node -> Splice n+runNode (X.Element nm at ch) = do+    newAtts <- (return . concat) =<< mapM runAttrSplice at+    let n = X.Element nm newAtts ch+    s <- liftM (lookupSplice nm) getHS+    maybe (runKids newAtts) (recurseSplice n) s+  where+    runKids newAtts = do+        newKids <- runNodeList ch+        return [X.Element nm newAtts newKids]+runNode n                    = return [n]+++------------------------------------------------------------------------------+-- | Runs the attribute splice if it exists, otherwise it does inline $()+-- substitution.+runAttrSplice :: (Monad n) => (Text, Text) -> HeistT n n [(Text, Text)]+runAttrSplice a@(k,v) = do+    splice <- getsHS (Map.lookup k . _attrSpliceMap)+    maybe (liftM (:[]) $ attSubst a) (lift . ($v)) splice+++------------------------------------------------------------------------------+-- | Helper function for substituting a parsed attribute into an attribute+-- tuple.+attSubst :: (Monad n) => (t, Text) -> HeistT n n (t, Text)+attSubst (n,v) = do+    v' <- parseAtt v+    return (n,v')+++------------------------------------------------------------------------------+-- | Parses an attribute for any identifier expressions and performs+-- appropriate substitution.+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+                (AP.Fail _ _ _) -> []+                (AP.Partial _)  -> []+    chunks <- mapM cvt ast+    return $ T.concat chunks+  where+    cvt (Literal x) = return x+    cvt (Escaped c) = renderEscaped c+    cvt (Ident x)   =+        localParamNode (const $ X.Element x [] []) $ getAttributeSplice x++    renderEscaped c = do+        hs <- getHS+        if _preprocessingMode hs+          then return $ T.snoc "\\" c+          else return $ T.singleton c+++------------------------------------------------------------------------------+-- | 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.+--+-- Originally, this only took the first node from the splices's result list,+-- and only if it was a text node. This caused problems when the splice's+-- result contained HTML entities, as they would split a text node. This was+-- then fixed to take the first consecutive bunch of text nodes, and return+-- their concatenation. This was seen as more useful than throwing an error,+-- and more intuitive than trying to render all the nodes as text.+--+-- However, it was decided in the end to render all the nodes as text, and+-- then concatenate them. If a splice returned+-- \"some \<b\>text\<\/b\> foobar\", the user would almost certainly want+-- \"some text foobar\" to be rendered, and Heist would probably seem+-- annoyingly limited for not being able to do this. If the user really did+-- want it to render \"some \", it would probably be easier for them to+-- accept that they were silly to pass more than that to be substituted than+-- 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 n => Text -> HeistT n n Text+getAttributeSplice name = do+    hs <- getHS+    let noSplice = if _preprocessingMode hs+                     then return $ T.concat ["${", name, "}"]+                     else return ""+    let s = lookupSplice name hs+    maybe noSplice (liftM (T.concat . map X.nodeText)) s++------------------------------------------------------------------------------+-- | Performs splice processing on a list of nodes.+runNodeList :: Monad n => [X.Node] -> Splice n+runNodeList = mapSplices runNode+{-# INLINE runNodeList #-}+++------------------------------------------------------------------------------+-- | The maximum recursion depth.  (Used to prevent infinite loops.)+mAX_RECURSION_DEPTH :: Int+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 n => X.Node -> Splice n -> Splice n+recurseSplice node splice = do+    result <- localParamNode (const node) splice+    hs <- getHS+    if _recurse hs+        then if _recursionDepth hs < mAX_RECURSION_DEPTH+               then do modRecursionDepth (+1)+                       res <- runNodeList result+                       restoreHS hs+                       return res+               else return result `orError` err+        else return result+  where+    err = unwords+        ["Recursion limit reached in node"+        ,"<"++(T.unpack $ X.elementTag node)++">.  You"+        ,"probably have infinite splice recursion!"+        ]+               +++------------------------------------------------------------------------------+-- | Looks up a template name runs a 'HeistT' computation on it.+lookupAndRun :: Monad m+             => ByteString+             -> ((DocumentFile, TPath) -> HeistT n m (Maybe a))+             -> HeistT n m (Maybe a)+lookupAndRun name k = do+    ts <- getHS+    let mt = lookupTemplate name ts _templateMap+    let curPath = join $ fmap (dfFile . fst) mt+    modifyHS (setCurTemplateFile curPath)+    maybe (return Nothing) k mt+++------------------------------------------------------------------------------+-- | Looks up a template name evaluates it by calling runNodeList.+evalTemplate :: Monad n+             => ByteString+             -> HeistT n n (Maybe Template)+evalTemplate name = lookupAndRun name+    (\(t,ctx) -> localHS (\ts -> ts {_curContext = ctx})+                         (liftM Just $ runNodeList $ X.docContent $ dfDoc t))+++------------------------------------------------------------------------------+-- | Sets the document type of a 'X.Document' based on the 'HeistT'+-- value.+fixDocType :: Monad m => X.Document -> HeistT n m X.Document+fixDocType d = do+    dts <- getsHS _doctypes+    return $ d { X.docType = listToMaybe dts }+++------------------------------------------------------------------------------+-- | Runs a template and sets the doctype properly.  This is the right thing+-- to do if we are starting at the top level.+evalWithDoctypes :: Monad n+                 => ByteString+                 -> HeistT n n (Maybe X.Document)+evalWithDoctypes name = lookupAndRun name $ \(t,ctx) -> do+    addDoctype $ maybeToList $ X.docType $ dfDoc t+    ts <- getHS+    let nodes = X.docContent $ dfDoc t+    putHS (ts {_curContext = ctx})+    newNodes <- runNodeList nodes+    restoreHS ts+    newDoc   <- fixDocType $ (dfDoc t) { X.docContent = newNodes }+    return (Just newDoc)+++------------------------------------------------------------------------------+-- | Binds a list of constant string splices.+bindStrings :: Monad n+            => [(Text, Text)]+            -> HeistState n+            -> HeistState n+bindStrings pairs ts = foldr (uncurry bindString) ts pairs+++------------------------------------------------------------------------------+-- | Binds a single constant string splice.+bindString :: Monad n+           => Text+           -> Text+           -> HeistState n+           -> HeistState n+bindString n = bindSplice n . textSplice+++------------------------------------------------------------------------------+-- | Renders a template with the specified parameters.  This is the function+-- 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 n+             => ByteString         -- ^ The name of the template+             -> [(Text, Splice n)] -- ^ Association list of+                                   -- (name,value) parameter pairs+             -> HeistT n n Template+callTemplate name params = do+    modifyHS $ bindSplices params+    liftM (maybe [] id) $ evalTemplate name+++------------------------------------------------------------------------------+-- | Like callTemplate except the splices being bound are constant text+-- splices.+callTemplateWithText :: Monad n+                     => ByteString     -- ^ The name of the template+                     -> [(Text, Text)] -- ^ Association list of+                                       -- (name,value) parameter pairs+                     -> HeistT n n Template+callTemplateWithText name params = do+    modifyHS $ bindStrings params+    liftM (maybe [] id) $ evalTemplate name+++------------------------------------------------------------------------------+-- | 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 n+               => HeistState n+               -> ByteString+               -> n (Maybe (Builder, MIMEType))+renderTemplate ts name = evalHeistT tpl (X.TextNode "") ts+  where tpl = do mt <- evalWithDoctypes name+                 case mt of+                    Nothing  -> return Nothing+                    Just doc -> return $ Just $ (X.render doc, mimeType doc)+++------------------------------------------------------------------------------+-- | 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 n+               => [(Text, Text)]+               -> HeistState n+               -> ByteString+               -> n (Maybe (Builder, MIMEType))+renderWithArgs args ts = renderTemplate (bindStrings args ts)++

@@ -0,0 +1,16 @@+module Heist.Splices+  ( module Heist.Splices.Apply+  , module Heist.Splices.Bind+  , module Heist.Splices.Cache+  , module Heist.Splices.Html+  , module Heist.Splices.Ignore+  , module Heist.Splices.Markdown+  ) where++import Heist.Splices.Apply+import Heist.Splices.Bind+import Heist.Splices.Cache+import Heist.Splices.Html+import Heist.Splices.Ignore+import Heist.Splices.Markdown+

@@ -0,0 +1,102 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+module Heist.Splices.Apply where++------------------------------------------------------------------------------+import           Control.Monad.Trans+import           Data.Maybe+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Text.XmlHtml as X++------------------------------------------------------------------------------+import           Heist.Common+import           Heist.Interpreted.Internal+import           Heist.Types+++------------------------------------------------------------------------------+-- | Default name for the apply splice.+applyTag :: Text+applyTag = "apply"+++------------------------------------------------------------------------------+-- | Default attribute name for the apply tag.+applyAttr :: Text+applyAttr = "template"+++------------------------------------------------------------------------------+-- | +rawApply :: (Monad n)+         => Text+         -> [X.Node]+         -> Maybe FilePath+         -> TPath+         -> [X.Node]+         -> Splice n+rawApply paramTag calledNodes templateFile newContext paramNodes = do+    hs <- getHS  -- Can't use localHS here because the modifier is not pure+    processedParams <- runNodeList paramNodes++    -- apply should do a bottom-up traversal, so we run the called nodes+    -- before doing <content/> substitution.+    modifyHS (setCurContext newContext . setCurTemplateFile templateFile)++    let process = concatMap (treeMap processedParams)+    if _recursionDepth hs < mAX_RECURSION_DEPTH+      then do modRecursionDepth (+1)+              res <- runNodeList calledNodes+              restoreHS hs+              return $! process res+      else do restoreHS hs+              (return []) `orError` err+  where+    err = "template recursion exceeded max depth, "+++          "you probably have infinite splice recursion!"+    treeMap :: [X.Node] -> X.Node -> [X.Node]+    treeMap ns n@(X.Element nm _ cs)+      | nm == paramTag = ns+      | otherwise = [n { X.elementChildren = cs' }]+      where+        !cs' = concatMap (treeMap ns) cs+    treeMap _ n = [n]+++------------------------------------------------------------------------------+-- | Applies a template as if the supplied nodes were the children of the+-- <apply> tag.+applyNodes :: MonadIO n => Template -> Text -> Splice n+applyNodes nodes template = do+    hs <- getHS+    maybe (return [] `orError` err)+          (\(t,ctx) -> do+              addDoctype $ maybeToList $ X.docType $ dfDoc t+              rawApply "apply-content" (X.docContent $ dfDoc t)+                       (dfFile t) ctx nodes)+          (lookupTemplate (T.encodeUtf8 template) hs _templateMap)+  where+    err = "apply tag cannot find template \""++(T.unpack template)++"\""+++------------------------------------------------------------------------------+-- | Implementation of the apply splice.+applyImpl :: MonadIO n => Splice n+applyImpl = do+    node <- getParamNode+    let err = "must supply \"" ++ T.unpack applyAttr +++              "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">"+    case X.getAttribute applyAttr node of+        Nothing   -> return [] `orError` err+        Just template -> applyNodes (X.childNodes node) template+++deprecatedContentCheck :: Monad m => Splice m+deprecatedContentCheck =+    return [] `orError` unwords+      ["<content> tag deprecated.  Use"+      ,"<apply-content> or <bind-content>"+      ]+

@@ -0,0 +1,43 @@+module Heist.Splices.Bind where++------------------------------------------------------------------------------+import           Control.Monad.Trans+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Text.XmlHtml as X++------------------------------------------------------------------------------+import           Heist.Common+import           Heist.Interpreted.Internal+import           Heist.Splices.Apply+import           Heist.Types++-- | Default name for the bind splice.+bindTag :: Text+bindTag = "bind"+++------------------------------------------------------------------------------+-- | Default attribute name for the bind tag.+bindAttr :: Text+bindAttr = "tag"+++------------------------------------------------------------------------------+-- | Implementation of the bind splice.+bindImpl :: MonadIO n => Splice n+bindImpl = do+    node <- getParamNode+    let err = "must supply \"" ++ T.unpack bindAttr +++              "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">"+    maybe (return () `orError` err)+          (add node)+          (X.getAttribute bindAttr node)+    return []+  where+    add node nm = modifyHS $ bindSplice nm $ do+        caller <- getParamNode+        ctx <- getContext+        rawApply "bind-content" (X.childNodes node)+                 Nothing ctx (X.childNodes caller)+

@@ -0,0 +1,37 @@+module Heist.Splices.BindStrict where++------------------------------------------------------------------------------+import           Control.Monad.Trans+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Text.XmlHtml as X++------------------------------------------------------------------------------+import           Heist.Common+import           Heist.Interpreted.Internal+import           Heist.Splices.Apply+import           Heist.Splices.Bind+import           Heist.Types++-- | Default name for the bind splice.+bindStrictTag :: Text+bindStrictTag = "bindStrict"+++------------------------------------------------------------------------------+-- | Implementation of the bind splice.+bindStrictImpl :: MonadIO n => Splice n+bindStrictImpl = do+    node <- getParamNode+    cs <- runChildren+    let err = "must supply \"" ++ T.unpack bindAttr +++              "\" attribute in <" ++ T.unpack (X.elementTag node) ++ ">"+    maybe (return () `orError` err) (add cs)+          (X.getAttribute bindAttr node)+    return []++  where+    add cs nm = modifyHS $ bindSplice nm $ do+        caller <- getParamNode+        ctx <- getContext+        rawApply "bindstrict-content" cs Nothing ctx (X.childNodes caller)

@@ -0,0 +1,202 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | The \"cache\" splice ensures that its contents are cached and only+-- evaluated periodically.  The cached contents are returned every time the+-- splice is referenced.+--+-- Use the ttl attribute to set the amount of time between reloads.  The ttl+-- value should be a positive integer followed by a single character+-- specifying the units.  Valid units are a single letter abbreviation for one+-- of seconds, minutes, hours, days, and weeks.  If the ttl string is invalid+-- or the ttl attribute is not specified, the cache is never refreshed unless+-- explicitly cleared with clearCacheTagState.  The compiled splice version of+-- the cache tag does not require a cache tag state, so clearCacheTagState+-- will not work for compiled cache tags.++module Heist.Splices.Cache+  ( CacheTagState+  , cacheImpl+  , cacheImplCompiled+  , mkCacheTag+  , clearCacheTagState+  ) where++------------------------------------------------------------------------------+import           Blaze.ByteString.Builder+import           Control.Concurrent+import           Control.Monad+import           Control.Monad.Trans+import           Data.IORef+import qualified Data.HashMap.Strict as H+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashSet as Set+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Text.Read+import           Data.Time.Clock+import           Data.Word+import           System.Random+import           Text.XmlHtml+++------------------------------------------------------------------------------+import qualified Heist.Compiled.Internal as C+import           Heist.Interpreted.Internal+import           Heist.Types+++------------------------------------------------------------------------------+cacheTagName :: Text+cacheTagName = "cache"+++------------------------------------------------------------------------------+-- | State for storing cache tag information+newtype CacheTagState =+    CTS (MVar ([IORef (Maybe (UTCTime, Builder))], HashMap Text (UTCTime, Template)))+++addCompiledRef :: IORef (Maybe (UTCTime, Builder)) -> CacheTagState -> IO ()+addCompiledRef ref (CTS mv) = do+    modifyMVar_ mv (\(a,b) -> return (ref:a, b))++    +------------------------------------------------------------------------------+-- | Clears the cache tag state.+clearCacheTagState :: CacheTagState -> IO ()+clearCacheTagState (CTS cacheMVar) = do+    refs <- modifyMVar cacheMVar (\(a,_) -> return ((a, H.empty), a))+    mapM_ (\ref -> writeIORef ref Nothing) refs+++------------------------------------------------------------------------------+-- | Converts a TTL string into an integer number of seconds.+parseTTL :: Text -> Int+parseTTL s = value * multiplier+  where+    (value,rest) = either (const (0::Int,"s")) id $ decimal s+    multiplier = case T.take 1 rest of+        "s" -> 1 :: Int+        "m" -> 60+        "h" -> 3600+        "d" -> 86400+        "w" -> 604800+        _   -> 1+++getTTL :: Node -> NominalDiffTime+getTTL tree = fromIntegral $ maybe 0 parseTTL $ getAttribute "ttl" tree+{-# INLINE getTTL #-}+++------------------------------------------------------------------------------+-- | This is the splice that actually does the work.  You should bind it to+-- the same tag name as you bound the splice returned by mkCacheTag otherwise+-- it won't work and you'll get runtime errors.+cacheImpl :: (MonadIO n) => CacheTagState -> Splice n+cacheImpl (CTS mv) = do+    tree <- getParamNode+    let err = error $ unwords ["cacheImpl is bound to a tag"+                              ,"that didn't get an id attribute."+                              ," This should never happen."]+    let i = maybe err id $ getAttribute "id" tree+        !ttl = getTTL tree+    mp <- liftIO $ readMVar mv++    ns <- do+        cur <- liftIO getCurrentTime+        let mbn = H.lookup i $ snd mp+            reload = do+                nodes' <- runNodeList $ childNodes tree+                let newMap = H.insert i (cur, nodes') $ snd mp+                liftIO $ modifyMVar_ mv (\(a,_) -> return (a, newMap))+                return $! nodes'+        case mbn of+            Nothing -> reload+            (Just (lastUpdate,n)) -> do+                if ttl > 0 && tagName tree == Just cacheTagName &&+                   diffUTCTime cur lastUpdate > ttl+                  then reload+                  else do+                      stopRecursion+                      return $! n++    return ns+++------------------------------------------------------------------------------+-- | This is the compiled splice version of cacheImpl.+cacheImplCompiled :: (MonadIO n) => CacheTagState -> C.Splice n+cacheImplCompiled cts = do+    tree <- getParamNode+    let !ttl = getTTL tree++    compiled <- C.runNodeList $ childNodes tree+    ref <- liftIO $ newIORef Nothing+    liftIO $ addCompiledRef ref cts+    let reload curTime = do+            builder <- C.codeGen $! C.consolidate compiled+            let out = fromByteString $! toByteString $! builder+            liftIO $ writeIORef ref (Just (curTime, out))+            return $! out+    return $ C.yieldRuntime $ do+        mbn <- liftIO $ readIORef ref+        cur <- liftIO getCurrentTime+        case mbn of+            Nothing -> reload cur+            (Just (lastUpdate,bs)) -> do+                if (ttl > 0 && diffUTCTime cur lastUpdate > ttl)+                  then reload cur+                  else return $! bs+++------------------------------------------------------------------------------+-- | Returns items necessary to set up a \"cache\" tag.  The cache tag cannot+-- be 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.+--+-- This function returns a splice and a CacheTagState.  The splice is of type+-- @Splice IO@ because it has to be bound as a load time preprocessing splice.+-- Haskell's type system won't allow you to screw up and pass this splice as+-- the wrong argument to initHeist.+mkCacheTag :: IO (Splice IO, CacheTagState)+mkCacheTag = do+    sr <- newIORef $ Set.empty+    mv <- liftM CTS $ newMVar ([], H.empty)++    return $ (setupSplice sr, mv)+++------------------------------------------------------------------------------+-- | Explicit type signature to avoid the Show polymorphism problem.+generateId :: IO Word+generateId = getStdRandom random+++------------------------------------------------------------------------------+-- | Gets a unique ID for use in the cache tags.+getId :: IORef (Set.HashSet Text) -> IO Text+getId setref = do+    i <- liftM (T.pack . show) generateId+    _set <- readIORef setref+    if Set.member i _set+      then getId setref+      else do+          writeIORef setref $ Set.insert i _set+          return $ T.append "cache-id-" i+++------------------------------------------------------------------------------+-- | A splice that sets the id attribute so that nodes can be cache-aware.+setupSplice :: IORef (Set.HashSet Text) -> Splice IO+setupSplice setref = do+    i <- liftIO $ getId setref+    node <- getParamNode++    newChildren <- runNodeList $ childNodes node+    stopRecursion+    return $ [setAttribute "id" i $ node { elementChildren = newChildren }]++

@@ -0,0 +1,47 @@+module Heist.Splices.Html where++------------------------------------------------------------------------------+import           Data.Maybe+import           Data.Text (Text)+import qualified Text.XmlHtml as X++------------------------------------------------------------------------------+import           Heist.Interpreted.Internal+import           Heist.Types+++------------------------------------------------------------------------------+-- | Name for the html splice.+htmlTag :: Text+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 n => Splice n+htmlImpl = do+    node <- getParamNode+    children <- runNodeList $ X.childNodes node+    let (heads, mnode) = extractHeads $ node { X.elementChildren = children }+        new (X.Element t a c) = X.Element t a $+            X.Element "head" [] heads : c+        new n = n+    stopRecursion+    return [maybe node new mnode]++------------------------------------------------------------------------------+-- | Extracts all heads from a node tree.+extractHeads :: X.Node+             -- ^ The root (html) node+             -> ([X.Node], Maybe X.Node)+             -- ^ A tuple of a list of head nodes and the original tree with+             --   heads removed.+extractHeads (X.Element t a c)+  | t == "head" = (c, Nothing)+  | otherwise   = (concat heads, Just $ X.Element t a (catMaybes mcs))+  where+    (heads, mcs) = unzip $ map extractHeads c+extractHeads n = ([], Just n)+

@@ -0,0 +1,22 @@+module Heist.Splices.Ignore where++------------------------------------------------------------------------------+import           Data.Text (Text)++------------------------------------------------------------------------------+import           Heist.Interpreted.Internal+++------------------------------------------------------------------------------+-- | Default name for the ignore splice.+ignoreTag :: Text+ignoreTag = "ignore"+++------------------------------------------------------------------------------+-- | The ignore tag and everything it surrounds disappears in the+-- rendered output.+ignoreImpl :: Monad m => Splice m+ignoreImpl = return []++

@@ -0,0 +1,224 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}++module Heist.Splices.Json (+  bindJson+) where++------------------------------------------------------------------------------+import           Control.Monad.Reader+import           Data.Aeson+import           Data.Attoparsec.Number+import qualified Data.ByteString.Char8       as S+import qualified Data.ByteString.Lazy.Char8  as L+import qualified Data.HashMap.Strict         as Map+import           Data.Maybe+import           Data.Text                   (Text)+import qualified Data.Text                   as T+import qualified Data.Text.Encoding          as T+import qualified Data.Vector                 as V+import qualified Text.Blaze.Html5            as B+import           Text.Blaze.Html5            ((!))+import           Text.Blaze.Renderer.XmlHtml+import           Text.XmlHtml+------------------------------------------------------------------------------++import           Heist.Interpreted.Internal+import           Heist.Types++                                 ------------+                                 -- public --+                                 ------------++------------------------------------------------------------------------------+-- | This splice binds convenience tags for the given JSON (or+-- JSON-convertible) value and runs the tag's child nodes using the new+-- bindings.+--+-- /Tags bound when you pass in an object/+--+-- Tags bound for an object looking like this:+--+-- > { "k_1": v_1, ..., "k_N": v_N }+--+-- @\<value:{k_i}\>@    -- treats v_i as text+-- @\<snippet:{k_i}\>@  -- treats v_i as HTML+-- @\<with:{k_i}\>@     -- explodes v_i and runs its children+--+-- @\<value var=\"foo.bar.baz\"\/>@ -- walks the JSON tree to find+-- \"foo.bar.baz\", and interprets it as a string+-- @\<snippet var=\"foo.bar.baz\"\/\>@+-- @\<with var=\"foo.bar.baz\"\>...\<with\>@+--+-- /Tags bound when you pass in anything else/+--+-- @\<value\/\>@    --  the given JSON value, as a string+-- @\<snippet\/\>@  --  the given JSON value, parsed and spliced in as HTML+--+bindJson :: (ToJSON a, Monad n) => a -> Splice n+bindJson = runReaderT explodeTag . toJSON+++                                 -------------+                                 -- private --+                                 -------------++------------------------------------------------------------------------------+errorMessage :: String -> [Node]+errorMessage s = renderHtmlNodes $+                     B.strong ! B.customAttribute "class" "error" $+                     B.toHtml s+++------------------------------------------------------------------------------+type JsonMonad n m a = ReaderT Value (HeistT n m) a+++------------------------------------------------------------------------------+withValue :: (Monad m) => Value -> JsonMonad n m a -> HeistT n m a+withValue = flip runReaderT+++------------------------------------------------------------------------------+boolToText :: Bool -> Text+boolToText b = if b then "true" else "false"+++------------------------------------------------------------------------------+numToText :: Number -> Text+numToText = T.decodeUtf8 . S.concat . L.toChunks . encode+++------------------------------------------------------------------------------+findExpr :: Text -> Value -> Maybe Value+findExpr t = go (T.split (=='.') t)+  where+    go [] !value     = Just value+    go (x:xs) !value = findIn value >>= go xs+      where+        findIn (Object obj) = Map.lookup x obj+        findIn _            = Nothing+++------------------------------------------------------------------------------+asHtml :: Monad m => Text -> m [Node]+asHtml t =+    case (parseHTML "" $ T.encodeUtf8 t) of+      Left e  -> return $ errorMessage $+                 "Template error turning JSON into HTML: " ++ e+      Right d -> return $! docContent d+++------------------------------------------------------------------------------+snippetTag :: Monad m => JsonMonad n m [Node]+snippetTag = ask >>= snip+  where+    txt t = lift $ asHtml t++    snip Null       = txt ""+    snip (Bool b)   = txt $ boolToText b+    snip (Number n) = txt $ numToText n+    snip (String t) = txt t+    snip _          = lift $ do+        node <- getParamNode+        return $ errorMessage $ concat [+                     "error processing tag <"+                   , T.unpack $ fromMaybe "???" $ tagName node+                   , ">: can't interpret JSON arrays or objects as HTML."+                   ]+++------------------------------------------------------------------------------+valueTag :: Monad m => JsonMonad n m [Node]+valueTag = ask >>= go+  where+    go Null       = txt ""+    go (Bool b)   = txt $ boolToText b+    go (Number n) = txt $ numToText n+    go (String t) = txt t+    go _          = lift $ do+        node <- getParamNode+        return $ errorMessage $ concat [+                     "error processing tag <"+                   , T.unpack $ fromMaybe "???" $ tagName node+                   , ">: can't interpret JSON arrays or objects as text."+                   ]+++    txt t = return [TextNode t]+++------------------------------------------------------------------------------+explodeTag :: (Monad n) => JsonMonad n n [Node]+explodeTag = ask >>= go+  where+    --------------------------------------------------------------------------+    go Null       = goText ""+    go (Bool b)   = goText $ boolToText b+    go (Number n) = goText $ numToText n+    go (String t) = goText t+    go (Array a)  = goArray a+    go (Object o) = goObject o++    --------------------------------------------------------------------------+    goText t = lift $ runChildrenWith [ ("value"   , return [TextNode t])+                                      , ("snippet" , asHtml t           )+                                      ]++    --------------------------------------------------------------------------+    goArray :: (Monad n) => V.Vector Value -> JsonMonad n n [Node]+    goArray a = do+        lift stopRecursion+        dl <- V.foldM f id a+        return $! dl []+      where+        f dl jsonValue = do+            tags <- go jsonValue+            return $! dl . (tags ++)++    --------------------------------------------------------------------------+    -- 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 m [Node]) -> Splice m+    varAttrTag v m = do+        node <- getParamNode+        maybe (noVar node) (hasVar node) $ getAttribute "var" node+      where+        noVar node = return $ errorMessage $+                     concat [ "expression error: no var attribute in <"+                            , T.unpack $ fromMaybe "???" $ tagName node+                            , "> tag"+                            ]++        hasVar node expr = maybe (return $ errorMessage $+                                  concat [+                                    "expression error: can't find \""+                                  , T.unpack expr+                                  , "\" in JSON object (<"+                                  , T.unpack $ fromMaybe "???" $ tagName node+                                  , "> tag)"+                                  ])+                                 (runReaderT m)+                                 (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  )+                                           ]++    --------------------------------------------------------------------------+    goObject obj = do+        start <- genericBindings+        let bindings = Map.foldlWithKey' bindKvp start obj+        lift $ runChildrenWith bindings++    --------------------------------------------------------------------------+    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

@@ -0,0 +1,184 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-| The \"markdown\" splice formats markdown content as HTML and inserts+it into the document.++If the file attribute is present the contents of the tag is ignored and+the file specified is converted to HTML.++Otherwise the non-markup children of the tag are processed as markdown+and converted to HTML.++This splice requires that the \"pandoc\" executable is in your path.+-}+module Heist.Splices.Markdown where++------------------------------------------------------------------------------+import           Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import           Data.Maybe+import           Control.Concurrent+import           Control.Exception (throwIO)+import           Control.Monad+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+import           System.IO+import           System.Process+import           Text.XmlHtml++------------------------------------------------------------------------------+import           Heist.Common+import           Heist.Interpreted.Internal+import           Heist.Types++data PandocMissingException = PandocMissingException+   deriving (Typeable)++instance Show PandocMissingException where+    show PandocMissingException =+        "Cannot find the \"pandoc\" executable; is it on your $PATH?"++instance Exception PandocMissingException+++data MarkdownException = MarkdownException ByteString+   deriving (Typeable)++instance Show MarkdownException where+    show (MarkdownException e) =+        "Markdown error: pandoc replied:\n\n" ++ BC.unpack e++instance Exception MarkdownException+++data NoMarkdownFileException = NoMarkdownFileException+    deriving (Typeable)++instance Show NoMarkdownFileException where+    show NoMarkdownFileException =+        "Markdown error: no file or template in context" +++        " during processing of markdown tag"++instance Exception NoMarkdownFileException where++------------------------------------------------------------------------------+-- | Default name for the markdown splice.+markdownTag :: Text+markdownTag = "markdown"++------------------------------------------------------------------------------+-- | Implementation of the markdown splice.+markdownSplice :: MonadIO m => Splice m+markdownSplice = do+    templateDir <- liftM (fmap takeDirectory) getTemplateFilePath+    pdMD <- liftIO $ findExecutable "pandoc"++    when (isNothing pdMD) $ liftIO $ throwIO PandocMissingException++    tree <- getParamNode+    (source,markup) <- liftIO $+        case getAttribute "file" tree of+            Just f  -> do+                m <- maybe (liftIO $ throwIO NoMarkdownFileException )+                           (\tp -> pandoc (fromJust pdMD) tp $ T.unpack f)+                           templateDir+                return (T.unpack f,m)+            Nothing -> do+                m <- pandocBS (fromJust pdMD) $ T.encodeUtf8 $ nodeText tree+                return ("inline_splice",m)++    let ee = parseHTML source markup+    case ee of+      Left e  -> throw $ MarkdownException+                       $ BC.pack ("Error parsing markdown output: " ++ e)+      Right d -> return (docContent d)+++pandoc :: FilePath -> FilePath -> FilePath -> IO ByteString+pandoc pandocPath templateDir inputFile = do+    (ex, sout, serr) <- readProcessWithExitCode' pandocPath args ""++    when (isFail ex) $ throw $ MarkdownException serr+    return $ BC.concat [ "<div class=\"markdown\">\n"+                         , sout+                         , "\n</div>" ]++  where+    isFail ExitSuccess = False+    isFail _           = True++    args = [ "-S", "--no-wrap", templateDir </> inputFile ]+++pandocBS :: FilePath -> ByteString -> IO ByteString+pandocBS pandocPath s = do+    -- using the crummy string functions for convenience here+    (ex, sout, serr) <- readProcessWithExitCode' pandocPath args s++    when (isFail ex) $ throw $ MarkdownException serr+    return $ BC.concat [ "<div class=\"markdown\">\n"+                       , sout+                       , "\n</div>" ]++  where+    isFail ExitSuccess = False+    isFail _           = True+    args = [ "-S", "--no-wrap" ]+++-- a version of readProcessWithExitCode that does I/O properly+readProcessWithExitCode'+    :: FilePath                 -- ^ command to run+    -> [String]                 -- ^ any arguments+    -> ByteString               -- ^ standard input+    -> IO (ExitCode,ByteString,ByteString) -- ^ exitcode, stdout, stderr+readProcessWithExitCode' cmd args input = do+    (Just inh, Just outh, Just errh, pid) <-+        createProcess (proc cmd args){ std_in  = CreatePipe,+                                       std_out = CreatePipe,+                                       std_err = CreatePipe }+    outMVar <- newEmptyMVar++    outM <- newEmptyMVar+    errM <- newEmptyMVar++    -- fork off a thread to start consuming stdout+    _ <- forkIO $ do+        out <- B.hGetContents outh+        putMVar outM out+        putMVar outMVar ()++    -- fork off a thread to start consuming stderr+    _ <- forkIO $ do+        err  <- B.hGetContents errh+        putMVar errM err+        putMVar outMVar ()++    -- now write and flush any input+    when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh+    hClose inh -- done with stdin++    -- wait on the output+    takeMVar outMVar+    takeMVar outMVar+    hClose outh++    -- wait on the process+    ex <- waitForProcess pid++    out <- readMVar outM+    err <- readMVar errM++    return (ex, out, err)++++

@@ -0,0 +1,100 @@+{-|++This module defines a TemplateDirectory data structure for convenient+interaction with templates within web apps.++-}++module Heist.TemplateDirectory+    ( TemplateDirectory+    , newTemplateDirectory+    , newTemplateDirectory'++    , getDirectoryHS+    , getDirectoryCTS+    , reloadTemplateDirectory+    ) where++------------------------------------------------------------------------------+import           Control.Concurrent+import           Control.Error+import           Control.Monad+import           Control.Monad.Trans+import           Heist+import           Heist.Splices.Cache+++------------------------------------------------------------------------------+-- | Structure representing a template directory.+data TemplateDirectory n+    = TemplateDirectory+        FilePath+        (HeistConfig n)+        (MVar (HeistState n))+        (MVar CacheTagState)+++------------------------------------------------------------------------------+-- | Creates and returns a new 'TemplateDirectory' wrapped in an Either for+-- error handling.+newTemplateDirectory :: MonadIO n+                     => FilePath+                     -> HeistConfig n+                     -> EitherT [String] IO (TemplateDirectory n)+newTemplateDirectory dir hc = do+    templates <- loadTemplates dir+    let hc' = hc { hcTemplates = templates }+    (hs,cts) <- initHeistWithCacheTag hc'+    tsMVar <- liftIO $ newMVar hs+    ctsMVar <- liftIO $ newMVar cts+    return $ TemplateDirectory dir hc' tsMVar ctsMVar+++------------------------------------------------------------------------------+-- | Creates and returns a new 'TemplateDirectory', using the monad's fail+-- function on error.+newTemplateDirectory' :: MonadIO n+                      => FilePath+                      -> HeistConfig n+                      -> IO (TemplateDirectory n)+newTemplateDirectory' dir hc = do+    res <- runEitherT $ newTemplateDirectory dir hc+    either (error . concat) return res+++------------------------------------------------------------------------------+-- | Gets the 'HeistState' from a TemplateDirectory.+getDirectoryHS :: (MonadIO n)+               => TemplateDirectory n+               -> IO (HeistState n)+getDirectoryHS (TemplateDirectory _ _ tsMVar _) =+    liftIO $ readMVar $ tsMVar+++------------------------------------------------------------------------------+-- | Clears the TemplateDirectory's cache tag state.+getDirectoryCTS :: TemplateDirectory n -> IO CacheTagState+getDirectoryCTS (TemplateDirectory _ _ _ ctsMVar) = readMVar ctsMVar+++------------------------------------------------------------------------------+-- | Clears cached content and reloads templates from disk.+reloadTemplateDirectory :: (MonadIO n)+                        => TemplateDirectory n+                        -> IO (Either String ())+reloadTemplateDirectory (TemplateDirectory p hc tsMVar ctsMVar) = do+    ehs <- runEitherT $ do+        templates <- loadTemplates p+        initHeistWithCacheTag (hc { hcTemplates = templates })+    leftPass ehs $ \(hs,cts) -> do+        modifyMVar_ tsMVar (const $ return hs)+        modifyMVar_ ctsMVar (const $ return cts)+++------------------------------------------------------------------------------+-- | Prepends an error onto a Left.+leftPass :: Monad m => Either [String] b -> (b -> m c) -> m (Either String c)+leftPass e m = either (return . Left . loadError . concat)+                      (liftM Right . m) e+  where+    loadError = (++) "Error loading templates: "

@@ -0,0 +1,489 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++{-|++This module contains the core Heist data types.  ++Edward Kmett wrote most of the HeistT monad code and associated instances,+liberating us from the unused writer portion of RWST.++-}++module Heist.Types where++------------------------------------------------------------------------------+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.Text.Encoding+import           Data.Typeable+import           Prelude hiding (catch)+import qualified Text.XmlHtml as X++import Debug.Trace++tr :: Show a => String -> a -> a+tr s x = trace (s++show x) x++------------------------------------------------------------------------------+-- | A 'Template' is a forest of XML nodes.  Here we deviate from the \"single+-- root node\" constraint of well-formed XML because we want to allow+-- templates to contain document fragments that may not have a single root.+type Template = [X.Node]+++------------------------------------------------------------------------------+-- | MIME Type.  The type alias is here to make the API clearer.+type MIMEType = ByteString+++------------------------------------------------------------------------------+-- | Reversed list of directories.  This holds the path to the template+-- currently being processed.+type TPath = [ByteString]+++------------------------------------------------------------------------------+-- | Holds data about templates read from disk.+data DocumentFile = DocumentFile+    { dfDoc  :: X.Document+    , dfFile :: Maybe FilePath+    } deriving (Eq)+++------------------------------------------------------------------------------+-- | Monad used for runtime splice execution.+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+++------------------------------------------------------------------------------+-- | Opaque type representing pieces of output from compiled splices.+data Chunk m = Pure !ByteString+               -- ^ output known at load time+             | RuntimeHtml !(RuntimeSplice m Builder)+               -- ^ output computed at run time+             | RuntimeAction !(RuntimeSplice m ())+               -- ^ runtime action used only for its side-effect+++instance Show (Chunk m) where+    show (Pure _) = "Pure"+    show (RuntimeHtml _) = "RuntimeHtml"+    show (RuntimeAction _) = "RuntimeAction"+++showChunk :: Chunk m -> String+showChunk (Pure b) = T.unpack $ decodeUtf8 b+showChunk (RuntimeHtml _) = "RuntimeHtml"+showChunk (RuntimeAction _) = "RuntimeAction"+++isPureChunk :: Chunk m -> Bool+isPureChunk (Pure _) = True+isPureChunk _ = False+++------------------------------------------------------------------------------+-- | Type alias for attribute splices.  The function parameter is the value of+-- the bound attribute splice.  The return value is a list of attribute+-- key/value pairs that get substituted in the place of the bound attribute.+type AttrSplice m = Text -> m [(Text, Text)]+++------------------------------------------------------------------------------+-- | Holds all the state information needed for template processing.  You will+-- build a @HeistState@ using 'initHeist' and any of Heist's @HeistState ->+-- HeistState@ \"filter\" functions.  Then you use the resulting @HeistState@+-- in calls to 'renderTemplate'.+--+-- m is the runtime monad+data HeistState m = HeistState {+    -- | A mapping of splice names to splice actions+      _spliceMap           :: HashMap Text (HeistT m m Template)+    -- | A mapping of template names to templates+    , _templateMap         :: HashMap TPath DocumentFile++    -- | A mapping of splice names to splice actions+    , _compiledSpliceMap   :: HashMap Text (HeistT m IO (DList (Chunk m)))+    -- | A mapping of template names to templates+    --, _compiledTemplateMap :: HashMap TPath (m Builder, MIMEType)+    , _compiledTemplateMap :: !(HashMap TPath ([Chunk m], MIMEType))++    , _attrSpliceMap       :: HashMap Text (AttrSplice m)++    -- | A flag to control splice recursion+    , _recurse             :: Bool+    -- | The path to the template currently being processed.+    , _curContext          :: TPath+    -- | A counter keeping track of the current recursion depth to prevent+    -- infinite loops.+    , _recursionDepth      :: Int+    -- | The doctypes encountered during template processing.+    , _doctypes            :: [X.DocType]+    -- | The full path to the current template's file on disk.+    , _curTemplateFile     :: Maybe FilePath+    -- | A key generator used to produce new unique Promises.+    , _keygen              :: HE.KeyGen++    -- | Flag indicating whether we're in preprocessing mode.  During+    -- preprocessing, errors should stop execution and be reported.  During+    -- template rendering, it's better to skip the errors and render the page.+    , _preprocessingMode   :: Bool+}+++-- NOTE: We got rid of the Monoid instance because it is absolutely not safe+-- to combine two compiledTemplateMaps.  All compiled templates must be known+-- at load time and processed in a single call to initHeist/loadTemplates or+-- whatever we end up calling it..++instance (Typeable1 m) => Typeable (HeistState m) where+    typeOf _ = mkTyConApp templateStateTyCon [typeOf1 (undefined :: m ())]+++------------------------------------------------------------------------------+-- | HeistT is the monad transformer used for splice processing.  HeistT+-- intentionally does not expose any of its functionality via MonadState or+-- MonadReader functions.  We define passthrough instances for the most common+-- types of monads.  These instances allow the user to use HeistT in a monad+-- stack without needing calls to `lift`.+--+-- @n@ is the runtime monad (the parameter to HeistState).+--+-- @m@ is the monad being run now.  In this case, \"now\" is a variable+-- concept.  The type @HeistT n n@ means that \"now\" is runtime.  The type+-- @HeistT n IO@ means that \"now\" is @IO@, and more importantly it is NOT+-- runtime. In Heist, the rule of thumb is that @IO@ means load time and @n@+-- means runtime.+newtype HeistT n m a = HeistT {+    runHeistT :: X.Node+              -> HeistState n+              -> m (a, HeistState n)+}+++------------------------------------------------------------------------------+-- | Gets the names of all the templates defined in a HeistState.+templateNames :: HeistState m -> [TPath]+templateNames ts = H.keys $ _templateMap ts+++------------------------------------------------------------------------------+-- | Gets the names of all the templates defined in a HeistState.+compiledTemplateNames :: HeistState m -> [TPath]+compiledTemplateNames ts = H.keys $ _compiledTemplateMap ts+++------------------------------------------------------------------------------+-- | Gets the names of all the splices defined in a HeistState.+spliceNames :: HeistState m -> [Text]+spliceNames ts = H.keys $ _spliceMap ts+++------------------------------------------------------------------------------+-- | The Typeable instance is here so Heist can be dynamically executed with+-- Hint.+templateStateTyCon :: TyCon+templateStateTyCon = mkTyCon "Heist.HeistState"+{-# NOINLINE templateStateTyCon #-}++------------------------------------------------------------------------------+-- | Evaluates a template monad as a computation in the underlying monad.+evalHeistT :: (Monad m)+           => HeistT n m a+           -> X.Node+           -> HeistState n+           -> m a+evalHeistT m r s = do+    (a, _) <- runHeistT m r s+    return a+{-# INLINE evalHeistT #-}+++------------------------------------------------------------------------------+-- | Functor instance+instance Functor m => Functor (HeistT n m) where+    fmap f (HeistT m) = HeistT $ \r s -> first f <$> m r s+++------------------------------------------------------------------------------+-- | Applicative instance+instance (Monad m, Functor m) => Applicative (HeistT n m) where+    pure = return+    (<*>) = ap+++------------------------------------------------------------------------------+-- | Monad instance+instance Monad m => Monad (HeistT n m) where+    return a = HeistT (\_ s -> return (a, s))+    {-# INLINE return #-}+    HeistT m >>= k = HeistT $ \r s -> do+        (a, s') <- m r s+        runHeistT (k a) r s'+    {-# INLINE (>>=) #-}+++------------------------------------------------------------------------------+-- | MonadIO instance+instance MonadIO m => MonadIO (HeistT n m) where+    liftIO = lift . liftIO+++------------------------------------------------------------------------------+-- | MonadTrans instance+instance MonadTrans (HeistT n) where+    lift m = HeistT $ \_ s -> do+        a <- m+        return (a, s)+++------------------------------------------------------------------------------+-- | MonadCatchIO instance+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)+++------------------------------------------------------------------------------+-- | MonadFix passthrough instance+instance MonadFix m => MonadFix (HeistT n m) where+    mfix f = HeistT $ \r s ->+        mfix $ \ (a, _) -> runHeistT (f a) r s+++------------------------------------------------------------------------------+-- | Alternative passthrough instance+instance (Functor m, MonadPlus m) => Alternative (HeistT n m) where+    empty = mzero+    (<|>) = mplus+++------------------------------------------------------------------------------+-- | MonadPlus passthrough instance+instance MonadPlus m => MonadPlus (HeistT n m) where+    mzero = lift mzero+    m `mplus` n = HeistT $ \r s ->+        runHeistT m r s `mplus` runHeistT n r s+++------------------------------------------------------------------------------+-- | MonadState passthrough instance+instance MonadState s m => MonadState s (HeistT n m) where+    get = lift get+    {-# INLINE get #-}+    put = lift . put+    {-# INLINE put #-}+++------------------------------------------------------------------------------+-- | MonadReader passthrough instance+instance MonadReader r m => MonadReader r (HeistT n m) where+    ask = HeistT $ \_ s -> do+            r <- ask+            return (r,s)+    local f (HeistT m) =+        HeistT $ \r s -> local f (m r s)+++------------------------------------------------------------------------------+-- | Helper for MonadError instance.+liftCatch :: (m (a,HeistState n)+              -> (e -> m (a,HeistState n))+              -> m (a,HeistState n))+          -> HeistT n m a+          -> (e -> HeistT n m a)+          -> HeistT n m a+liftCatch ce m h =+    HeistT $ \r s ->+        (runHeistT m r s `ce`+        (\e -> runHeistT (h e) r s))+++------------------------------------------------------------------------------+-- | MonadError passthrough instance+instance (MonadError e m) => MonadError e (HeistT n m) where+    throwError = lift . throwError+    catchError = liftCatch catchError+++------------------------------------------------------------------------------+-- | Helper for MonadCont instance.+liftCallCC :: ((((a,HeistState n) -> m (b, HeistState n))+                  -> m (a, HeistState n))+                -> m (a, HeistState n))+           -> ((a -> HeistT n m b) -> HeistT n m a)+           -> HeistT n m a+liftCallCC ccc f = HeistT $ \r s ->+    ccc $ \c ->+    runHeistT (f (\a -> HeistT $ \_ _ -> c (a, s))) r s+++------------------------------------------------------------------------------+-- | MonadCont passthrough instance+instance (MonadCont m) => MonadCont (HeistT n m) where+    callCC = liftCallCC callCC+++------------------------------------------------------------------------------+-- | The Typeable instance is here so Heist can be dynamically executed with+-- Hint.+templateMonadTyCon :: TyCon+templateMonadTyCon = mkTyCon "Heist.HeistT"+{-# NOINLINE templateMonadTyCon #-}++instance (Typeable1 m) => Typeable1 (HeistT n m) where+    typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())]+++------------------------------------------------------------------------------+-- Functions for our monad.+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Gets the node currently being processed.+--+--   > <speech author="Shakespeare">+--   >   To sleep, perchance to dream.+--   > </speech>+--+-- When you call @getParamNode@ inside the code for the @speech@ splice, it+-- returns the Node for the @speech@ tag and its children.  @getParamNode >>=+-- childNodes@ returns a list containing one 'TextNode' containing part of+-- Hamlet's speech.  @liftM (getAttribute \"author\") getParamNode@ would+-- return @Just "Shakespeare"@.+getParamNode :: Monad m => HeistT n m X.Node+getParamNode = HeistT $ \r s -> return (r,s)+{-# INLINE getParamNode #-}+++------------------------------------------------------------------------------+-- | HeistT's 'local'.+localParamNode :: Monad m+               => (X.Node -> X.Node)+               -> HeistT n m a+               -> HeistT n m a+localParamNode f m = HeistT $ \r s -> runHeistT m (f r) s+{-# INLINE localParamNode #-}+++------------------------------------------------------------------------------+-- | HeistT's 'gets'.+getsHS :: Monad m => (HeistState n -> r) -> HeistT n m r+getsHS f = HeistT $ \_ s -> return (f s, s)+{-# INLINE getsHS #-}+++------------------------------------------------------------------------------+-- | HeistT's 'get'.+getHS :: Monad m => HeistT n m (HeistState n)+getHS = HeistT $ \_ s -> return (s, s)+{-# INLINE getHS #-}+++------------------------------------------------------------------------------+-- | HeistT's 'put'.+putHS :: Monad m => HeistState n -> HeistT n m ()+putHS s = HeistT $ \_ _ -> return ((), s)+{-# INLINE putHS #-}+++------------------------------------------------------------------------------+-- | HeistT's 'modify'.+modifyHS :: Monad m+         => (HeistState n -> HeistState n)+         -> HeistT n m ()+modifyHS f = HeistT $ \_ s -> return ((), f s)+{-# INLINE modifyHS #-}+++------------------------------------------------------------------------------+-- | Restores the HeistState.  This function is almost like putHS except it+-- preserves the current doctypes.  You should use this function instead of+-- @putHS@ to restore an old state.  This was needed because doctypes needs to+-- be in a "global scope" as opposed to the template call "local scope" of+-- state items such as recursionDepth, curContext, and spliceMap.+restoreHS :: Monad m => HeistState n -> HeistT n m ()+restoreHS old = modifyHS (\cur -> old { _doctypes = _doctypes cur })+{-# INLINE restoreHS #-}+++------------------------------------------------------------------------------+-- | Abstracts the common pattern of running a HeistT computation with+-- a modified heist state.+localHS :: Monad m+        => (HeistState n -> HeistState n)+        -> HeistT n m a+        -> HeistT n m a+localHS f k = do+    ts <- getHS+    putHS $ f ts+    res <- k+    restoreHS ts+    return res+{-# INLINE localHS #-}+++------------------------------------------------------------------------------+-- | Modifies the recursion depth.+modRecursionDepth :: Monad m => (Int -> Int) -> HeistT n m ()+modRecursionDepth f =+    modifyHS (\st -> st { _recursionDepth = f (_recursionDepth st) })+++------------------------------------------------------------------------------+-- | 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+            | Escaped Char+  deriving (Show)+++------------------------------------------------------------------------------+isIdent :: AttAST -> Bool+isIdent (Ident _) = True+isIdent _         = False++

@@ -1,176 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{-|--  This module contains the core definitions for the Heist template system.--  The Heist template system is based on HTML and XML.  It allows you to build-  custom HTML and XML based markup languages.  With Heist you can define your-  own domain-specific HTML and XML tags implemented with Haskell and use them-  in your templates.--  The most important concept in Heist is the 'Splice'.  Splices can be thought-  of as functions that transform a node into a list of nodes.  Heist then-  substitutes the resulting list of nodes into your template in place of the-  input node.  'Splice' is implemented as a type synonym @type Splice m =-  HeistT m [Node]@, and 'HeistT' has a function 'getParamNode'-  that lets you get the input node.--  Suppose you have a place on your page where you want to display a link with-  the text \"Logout username\" if the user is currently logged in or a link to-  the login page if no user is logged in.  Assume you have a function-  @getUser :: MyAppMonad (Maybe Text)@ that gets the current user.-  You can implement this functionality with a 'Splice' as follows:--  > import             Blaze.ByteString.Builder-  > import             Data.ByteString.Char8 (ByteString)-  > import qualified   Data.ByteString.Char8 as B-  > import             Data.Text (Text)-  > import qualified   Data.Text as T-  > import qualified   Text.XmlHtml as X-  >-  > import             Text.Templating.Heist-  >-  > link :: Text -> Text -> X.Node-  > link target text = X.Element "a" [("href", target)] [X.TextNode text]-  >-  > loginLink :: X.Node-  > loginLink = link "/login" "Login"-  >-  > logoutLink :: Text -> X.Node-  > logoutLink user = link "/logout" (T.append "Logout " user)-  >-  > loginLogoutSplice :: Splice MyAppMonad-  > loginLogoutSplice = do-  >     user <- lift getUser-  >     return [maybe loginLink logoutLink user]-  >--  Next, you need to bind that splice to a tag.  Heist stores information-  about splices and templates in the 'HeistState' data structure.  The-  following code demonstrates how this splice would be used.--  > mySplices = [ ("loginLogout", loginLogoutSplice) ]-  >-  > main = do-  >     ets <- loadTemplates "templates" $-  >            bindSplices mySplices defaultHeistState-  >     let ts = either error id ets-  >     t <- runMyAppMonad $ renderTemplate ts "index"-  >     print $ maybe "Page not found" (toByteString . fst) t--  Here we build up our 'HeistState' by starting with defaultHeistState and-  applying bindSplice for all the splices we want to add.  Then we pass this-  to loadTemplates our final 'HeistState' wrapped in an Either to handle-  errors.  Then we use this 'HeistState' to render our templates.---}--module Text.Templating.Heist-  (-    -- * Types-    Template-  , MIMEType-  , Splice-  , HeistT-  , HeistState-  , evalHeistT-  , templateNames-  , spliceNames--    -- * Functions and declarations on HeistState values-  , addTemplate-  , addXMLTemplate-  , defaultHeistState-  , bindSplice-  , bindSplices-  , lookupSplice-  , 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           Control.Monad.Trans-import qualified Data.HashMap.Strict as Map-import           Text.Templating.Heist.Internal-import           Text.Templating.Heist.Splices-import           Text.Templating.Heist.Types------------------------------------------------------------------------------------ | The default set of built-in splices.-defaultSpliceMap :: MonadIO m => SpliceMap m-defaultSpliceMap = Map.fromList-    [(applyTag, applyImpl)-    ,(bindTag, bindImpl)-    ,(ignoreTag, ignoreImpl)-    ,(markdownTag, markdownSplice)-    ]------------------------------------------------------------------------------------ | 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 =-    HeistState (defaultSpliceMap) Map.empty True [] 0-               return return return [] Nothing----- $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.-

@@ -1,743 +0,0 @@-{-# LANGUAGE BangPatterns               #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE PackageImports             #-}-{-# LANGUAGE ScopedTypeVariables        #-}--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-import qualified   Data.ByteString.Char8 as BC-import             Data.Either-import qualified   Data.Foldable as F-import             Data.List-import qualified   Data.HashMap.Strict as Map-import             Data.Maybe-import             Data.Monoid-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.Types------------------------------------------------------------------------------------ | Mappends a doctype to the state.-addDoctype :: Monad m => [X.DocType] -> HeistT m ()-addDoctype dt = do-    modifyTS (\s -> s { _doctypes = _doctypes s `mappend` dt })------------------------------------------------------------------------------------ HeistState functions------------------------------------------------------------------------------------------------------------------------------------------------------------------- | Adds an on-load hook to a `HeistState`.-addOnLoadHook :: (Monad m) =>-                 (Template -> IO Template)-              -> HeistState m-              -> HeistState 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 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-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 t = return [X.TextNode t]------------------------------------------------------------------------------------ | Runs the parameter node's children and returns the resulting node list.--- 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 = 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)]-                -- ^ List of splices to bind before running the param nodes.-                -> Splice m-                -- ^ Returns the passed in view.-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)-          -- ^ Splice generating function-          -> [(Text, b)]-          -- ^ List of tuples to be bound-          -> Splice m-runChildrenWithTrans f = runChildrenWith . map (second f)------------------------------------------------------------------------------------ | Like runChildrenWith but using constant templates rather than dynamic--- splices.-runChildrenWithTemplates :: (Monad m) => [(Text, Template)] -> Splice m-runChildrenWithTemplates = runChildrenWithTrans return------------------------------------------------------------------------------------ | Like runChildrenWith but using literal text rather than dynamic splices.-runChildrenWithText :: (Monad m) => [(Text, Text)] -> Splice m-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)-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 m ts = ts { _templateMap = m }------------------------------------------------------------------------------------ | Adds a template to the heist state.-insertTemplate :: Monad m =>-               TPath-            -> DocumentFile-            -> HeistState m-            -> HeistState m-insertTemplate p t st =-    setTemplates (Map.insert p t (_templateMap st)) st------------------------------------------------------------------------------------ | Adds an HTML format template to the heist state.-addTemplate :: Monad m-            => ByteString-            -- ^ Path that the template will be referenced by-            -> Template-            -- ^ The template's DOM nodes-            -> Maybe FilePath-            -- ^ An optional path to the actual file on disk where the-            -- template is stored-            -> HeistState m-            -> HeistState m-addTemplate n t mfp st =-    insertTemplate (splitTemplatePath n) doc st-  where-    doc = DocumentFile (X.HtmlDocument X.UTF8 Nothing t) mfp------------------------------------------------------------------------------------ | Adds an XML format template to the heist state.-addXMLTemplate :: Monad m-               => ByteString-               -- ^ Path that the template will be referenced by-               -> Template-               -- ^ The template's DOM nodes-               -> Maybe FilePath-               -- ^ An optional path to the actual file on disk where the-               -- template is stored-               -> HeistState m-               -> HeistState m-addXMLTemplate n t mfp st =-    insertTemplate (splitTemplatePath n) doc st-  where-    doc = DocumentFile (X.XmlDocument X.UTF8 Nothing t) mfp------------------------------------------------------------------------------------ | Stops the recursive processing of splices.  Consider the following--- example:------   > <foo>---   >   <bar>---   >     ...---   >   </bar>---   > </foo>------ Assume that @\"foo\"@ is bound to a splice procedure. Running the @foo@--- 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 = 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 = 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 = getsTS _curTemplateFile------------------------------------------------------------------------------------ | Performs splice processing on a single node.-runNode :: Monad m => X.Node -> Splice m-runNode (X.Element nm at ch) = do-    newAtts <- mapM attSubst at-    let n = X.Element nm newAtts ch-    s <- liftM (lookupSplice nm) getTS-    maybe (runKids newAtts) (recurseSplice n) s-  where-    runKids newAtts = do-        newKids <- runNodeList ch-        return [X.Element nm newAtts newKids]-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 (n,v) = do-    v' <- parseAtt v-    return (n,v')------------------------------------------------------------------------------------ | Parses an attribute for any identifier expressions and performs--- appropriate substitution.-parseAtt :: (Monad m) => Text -> HeistT m Text-parseAtt bs = do-    let ast = case AP.feed (AP.parse attParser bs) "" of-                (AP.Done _ res) -> res-                (AP.Fail _ _ _) -> []-                (AP.Partial _)  -> []-    chunks <- mapM cvt ast-    return $ T.concat chunks-  where-    cvt (Literal x) = return x-    cvt (Ident x)   =-        localParamNode (const $ X.Element x [] []) $ getAttributeSplice x------------------------------------------------------------------------------------ | 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.------ Originally, this only took the first node from the splices's result list,--- and only if it was a text node. This caused problems when the splice's--- result contained HTML entities, as they would split a text node. This was--- then fixed to take the first consecutive bunch of text nodes, and return--- their concatenation. This was seen as more useful than throwing an error,--- and more intuitive than trying to render all the nodes as text.------ However, it was decided in the end to render all the nodes as text, and--- then concatenate them. If a splice returned--- \"some \<b\>text\<\/b\> foobar\", the user would almost certainly want--- \"some text foobar\" to be rendered, and Heist would probably seem--- annoyingly limited for not being able to do this. If the user really did--- want it to render \"some \", it would probably be easier for them to--- accept that they were silly to pass more than that to be substituted than--- 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 name = do-    s <- liftM (lookupSplice name) getTS-    nodes <- maybe (return []) id s-    return $ T.concat $ map X.nodeText nodes----------------------------------------------------------------------------------- | Performs splice processing on a list of nodes.-runNodeList :: Monad m => [X.Node] -> Splice m-runNodeList = mapSplices runNode-{-# INLINE runNodeList #-}------------------------------------------------------------------------------------ | The maximum recursion depth.  (Used to prevent infinite loops.)-mAX_RECURSION_DEPTH :: Int-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 node splice = do-    result <- localParamNode (const node) splice-    ts' <- getTS-    if _recurse ts' && _recursionDepth ts' < mAX_RECURSION_DEPTH-        then do modRecursionDepth (+1)-                res <- runNodeList result-                restoreTS ts'-                return res-        else return result-  where-    modRecursionDepth :: Monad m => (Int -> Int) -> HeistT m ()-    modRecursionDepth f =-        modifyTS (\st -> st { _recursionDepth = f (_recursionDepth st) })------------------------------------------------------------------------------------ | 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)-lookupAndRun name k = do-    ts <- getTS-    let mt = lookupTemplate name ts-    let curPath = join $ fmap (dfFile . fst) mt-    modifyTS (setCurTemplateFile curPath)-    maybe (return Nothing) k mt------------------------------------------------------------------------------------ | Looks up a template name evaluates it by calling runNodeList.-evalTemplate :: Monad m-            => ByteString-            -> HeistT m (Maybe Template)-evalTemplate name = lookupAndRun name-    (\(t,ctx) -> localTS (\ts -> ts {_curContext = ctx})-                         (liftM Just $ runNodeList $ X.docContent $ dfDoc t))------------------------------------------------------------------------------------ | Sets the document type of a 'X.Document' based on the 'HeistT'--- value.-fixDocType :: Monad m => X.Document -> HeistT m X.Document-fixDocType d = do-    dts <- getsTS _doctypes-    return $ d { X.docType = listToMaybe dts }------------------------------------------------------------------------------------ | 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-                      => ByteString-                      -> HeistT m (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-    putTS (ts {_curContext = ctx})-    res <- runNodeList nodes-    restoreTS ts-    newNodes <- lift (_postRunHook ts res)-    newDoc   <- fixDocType $ (dfDoc t) { X.docContent = newNodes }-    return (Just newDoc)------------------------------------------------------------------------------------ | 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 name = liftM (liftM X.docContent) (evalWithHooksInternal name)------------------------------------------------------------------------------------ | Binds a list of constant string splices.-bindStrings :: Monad m-            => [(Text, Text)]-            -> HeistState m-            -> HeistState m-bindStrings pairs ts = foldr (uncurry bindString) ts pairs------------------------------------------------------------------------------------ | Binds a single constant string splice.-bindString :: Monad m-            => Text-            -> Text-            -> HeistState m-            -> HeistState m-bindString n = bindSplice n . textSplice------------------------------------------------------------------------------------ | Renders a template with the specified parameters.  This is the function--- 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-             => ByteString         -- ^ The name of the template-             -> [(Text, Splice m)] -- ^ Association list of-                                   -- (name,value) parameter pairs-             -> HeistT m Template-callTemplate name params = do-    modifyTS $ bindSplices params-    liftM (maybe [] id) $ evalTemplate name------------------------------------------------------------------------------------ | Like callTemplate except the splices being bound are constant text--- splices.-callTemplateWithText :: Monad m-                     => ByteString     -- ^ The name of the template-                     -> [(Text, Text)] -- ^ Association list of-                                       -- (name,value) parameter pairs-                     -> HeistT m Template-callTemplateWithText name params = do-    modifyTS $ bindStrings params-    liftM (maybe [] id) $ evalTemplate name------------------------------------------------------------------------------------ Gives the MIME type for a 'X.Document'-mimeType :: X.Document -> ByteString-mimeType d = case d of-    (X.HtmlDocument e _ _) -> "text/html;charset=" `BC.append` enc e-    (X.XmlDocument  e _ _) -> "text/xml;charset="  `BC.append` enc e-  where-    enc X.UTF8    = "utf-8"-    -- Should not include byte order designation for UTF-16 since-    -- rendering will include a byte order mark. (RFC 2781, Sec. 3.3)-    enc X.UTF16BE = "utf-16"-    enc X.UTF16LE = "utf-16"------------------------------------------------------------------------------------ | 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 m-               -> ByteString-               -> m (Maybe (Builder, MIMEType))-renderTemplate ts name = evalHeistT tpl (X.TextNode "") ts-  where tpl = do mt <- evalWithHooksInternal name-                 case mt of-                    Nothing  -> return Nothing-                    Just doc -> return $ Just $ (X.render doc, mimeType doc)------------------------------------------------------------------------------------ | 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 m-                   -> ByteString-                   -> m (Maybe (Builder, MIMEType))-renderWithArgs args ts = renderTemplate (bindStrings args ts)------------------------------------------------------------------------------------ Template loading------------------------------------------------------------------------------------------------------------------------------------------------------------------- | Type synonym for parsers.-type ParserFun = String -> ByteString -> Either String X.Document------------------------------------------------------------------------------------ | 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)-                (\(e::SomeException) -> return $ Left $ show e)--    let eitherDoc = either Left (parser f) bs-    return $ either (\s -> Left $ f ++ " " ++ s)-                    (\d -> Right $ DocumentFile d (Just f)) eitherDoc------------------------------------------------------------------------------------ | Reads an HTML template from disk.-getDoc :: String -> IO (Either String DocumentFile)-getDoc = getDocWith X.parseHTML------------------------------------------------------------------------------------ | Reads an XML template from disk.-getXMLDoc :: String -> IO (Either String DocumentFile)-getXMLDoc = getDocWith X.parseXML------------------------------------------------------------------------------------ | Loads a template with the specified path and filename.  The--- template is only loaded if it has a ".tpl" or ".xtpl" extension.-loadTemplate :: String -- ^ path of the template root-             -> String -- ^ full file path (includes the template root)-             -> IO [Either String (TPath, DocumentFile)] --TemplateMap-loadTemplate templateRoot fname-    | isHTMLTemplate = do-        c <- getDoc fname-        return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c]-    | isXMLTemplate = do-        c <- getXMLDoc fname-        return [fmap (\t -> (splitLocalPath $ BC.pack tName, t)) c]-    | otherwise = return []-  where -- tName is path relative to the template root directory-        isHTMLTemplate = ".tpl"  `isSuffixOf` fname-        isXMLTemplate  = ".xtpl" `isSuffixOf` fname-        correction = if last templateRoot == '/' then 0 else 1-        extLen     = if isHTMLTemplate then 4 else 5-        tName = drop ((length templateRoot)+correction) $-                -- We're only dropping the template root, not the whole path-                take ((length fname) - extLen) fname------------------------------------------------------------------------------------ | 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 dir ts = do-    d <- readDirectoryWith (loadTemplate dir) dir-    let tlist = F.fold (free d)-        errs = lefts tlist-    case errs of-        [] -> liftM Right $ foldM loadHook ts $ rights tlist-        _  -> return $ Left $ unlines errs------------------------------------------------------------------------------------ | Runs a template modifying function on a DocumentFile.-runHook :: Monad m => (Template -> m Template)-        -> DocumentFile-        -> m DocumentFile-runHook f t = do-    n <- f $ X.docContent $ dfDoc t-    return $ t { dfDoc = (dfDoc t) { X.docContent = n } }------------------------------------------------------------------------------------ | 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 ts (tp, t) = do-    t' <- runHook (_onLoadHook ts) t-    return $ insertTemplate tp t' ts------------------------------------------------------------------------------------ | Adds a path prefix to all the templates in the 'HeistState'.  If you--- want to add multiple levels of directories, separate them with slashes as--- in "foo/bar".  Using an empty string as a path prefix will leave the--- 'HeistState' unchanged.-addTemplatePathPrefix :: ByteString -> HeistState m -> HeistState m-addTemplatePathPrefix dir ts-  | B.null dir = ts-  | otherwise  = ts { _templateMap = Map.fromList $-                                     map (\(x,y) -> (f x, y)) $-                                     Map.toList $-                                     _templateMap ts-                    }-  where-    f ps = ps++splitTemplatePath dir-

@@ -1,16 +0,0 @@-module Text.Templating.Heist.Splices-  ( module Text.Templating.Heist.Splices.Apply-  , module Text.Templating.Heist.Splices.Bind-  , module Text.Templating.Heist.Splices.Cache-  , module Text.Templating.Heist.Splices.Html-  , module Text.Templating.Heist.Splices.Ignore-  , module Text.Templating.Heist.Splices.Markdown-  ) where--import Text.Templating.Heist.Splices.Apply-import Text.Templating.Heist.Splices.Bind-import Text.Templating.Heist.Splices.Cache-import Text.Templating.Heist.Splices.Html-import Text.Templating.Heist.Splices.Ignore-import Text.Templating.Heist.Splices.Markdown-

@@ -1,65 +0,0 @@-module Text.Templating.Heist.Splices.Apply where---------------------------------------------------------------------------------import           Data.Maybe-import           Data.Text (Text)-import qualified Data.Text.Encoding as T-import qualified Text.XmlHtml as X---------------------------------------------------------------------------------import           Text.Templating.Heist.Internal-import           Text.Templating.Heist.Types----------------------------------------------------------------------------------- | Default name for the apply splice.-applyTag :: Text-applyTag = "apply"------------------------------------------------------------------------------------ | Default attribute name for the apply tag.-applyAttr :: Text-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)-         => [X.Node]-         -> TPath-         -> [X.Node]-         -> HeistT m Template-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-    result <- runNodeList calledNodes-    restoreTS st-    return result------------------------------------------------------------------------------------ | Applies a template as if the supplied nodes were the children of the--- <apply> tag.-applyNodes :: Monad m => Template -> Text -> Splice m-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)------------------------------------------------------------------------------------ | Implementation of the apply splice.-applyImpl :: Monad m => Splice m-applyImpl = do-    node <- getParamNode-    case X.getAttribute applyAttr node of-        Nothing   -> return [] -- TODO: error handling-        Just template -> applyNodes (X.childNodes node) template--

@@ -1,39 +0,0 @@-module Text.Templating.Heist.Splices.Bind where---------------------------------------------------------------------------------import           Data.Text (Text)-import qualified Text.XmlHtml as X---------------------------------------------------------------------------------import           Text.Templating.Heist.Internal-import           Text.Templating.Heist.Splices.Apply-import           Text.Templating.Heist.Types---- | Default name for the bind splice.-bindTag :: Text-bindTag = "bind"------------------------------------------------------------------------------------ | Default attribute name for the bind tag.-bindAttr :: Text-bindAttr = "tag"------------------------------------------------------------------------------------ | Implementation of the bind splice.-bindImpl :: Monad m => Splice m-bindImpl = do-    node <- getParamNode-    maybe (return ())-          (add node)-          (X.getAttribute bindAttr node)-    return []--  where-    add node nm = modifyTS $ bindSplice nm $ do-        caller <- getParamNode-        ctx <- getContext-        rawApply (X.childNodes node) ctx (X.childNodes caller)--

@@ -1,32 +0,0 @@-module Text.Templating.Heist.Splices.BindStrict where---------------------------------------------------------------------------------import           Data.Text (Text)-import qualified Text.XmlHtml as X---------------------------------------------------------------------------------import           Text.Templating.Heist.Internal-import           Text.Templating.Heist.Splices.Apply-import           Text.Templating.Heist.Splices.Bind-import           Text.Templating.Heist.Types---- | Default name for the bind splice.-bindStrictTag :: Text-bindStrictTag = "bindStrict"------------------------------------------------------------------------------------ | Implementation of the bind splice.-bindStrictImpl :: Monad m => Splice m-bindStrictImpl = do-    node <- getParamNode-    cs <- runChildren-    maybe (return ()) (add cs)-          (X.getAttribute bindAttr node)-    return []--  where-    add cs nm = modifyTS $ bindSplice nm $ do-        caller <- getParamNode-        ctx <- getContext-        rawApply cs ctx (X.childNodes caller)

@@ -1,152 +0,0 @@--- | The \"cache\" splice ensures that its contents are cached and only--- evaluated periodically.  The cached contents are returned every time the--- splice is referenced.------ Use the ttl attribute to set the amount of time between reloads.  The ttl--- value should be a positive integer followed by a single character--- specifying the units.  Valid units are seconds, minutes, hours, days, and--- weeks.  If the ttl string is invalid or the ttl attribute is not specified,--- the cache is never refreshed unless explicitly cleared with--- clearCacheTagState.-module Text.Templating.Heist.Splices.Cache-  ( CacheTagState-  , mkCacheTag-  , clearCacheTagState-  ) where---------------------------------------------------------------------------------import           Control.Concurrent-import           Control.Monad-import           Control.Monad.Trans-import           Data.IORef-import qualified Data.HashMap.Strict as H-import           Data.HashMap.Strict (HashMap)-import qualified Data.HashSet as Set-import           Data.Text (Text)-import qualified Data.Text as T-import           Data.Text.Read-import           Data.Time.Clock-import           System.Random-import           Text.XmlHtml.Cursor-import           Text.XmlHtml hiding (Node)----------------------------------------------------------------------------------import           Text.Templating.Heist.Internal-import           Text.Templating.Heist.Types----------------------------------------------------------------------------------cacheTagName :: Text-cacheTagName = "cache"------------------------------------------------------------------------------------ | State for storing cache tag information-newtype CacheTagState = CTS (MVar (HashMap Text (UTCTime, Template)))------------------------------------------------------------------------------------ | Clears the cache tag state.-clearCacheTagState :: CacheTagState -> IO ()-clearCacheTagState (CTS cacheMVar) =-    modifyMVar_ cacheMVar (const $ return H.empty)------------------------------------------------------------------------------------ | Converts a TTL string into an integer number of seconds.-parseTTL :: Text -> Int-parseTTL s = value * multiplier-  where-    value = either (const 0) fst $ decimal s-    multiplier = case T.last s of-        's' -> 1-        'm' -> 60-        'h' -> 3600-        'd' -> 86400-        'w' -> 604800-        _   -> 0---------------------------------------------------------------------------------cacheImpl :: (MonadIO m)-           => CacheTagState-           -> HeistT m Template-cacheImpl (CTS mv) = do-    tree <- getParamNode-    let err = error $ unwords ["cacheImpl is bound to a tag"-                              ,"that didn't get an id attribute."-                              ," This should never happen."]-    let i = maybe err id $ getAttribute "id" tree-        ttl = maybe 0 parseTTL $ getAttribute "ttl" tree-    mp <- liftIO $ readMVar mv--    (mp',ns) <- do-                   cur <- liftIO getCurrentTime-                   let mbn = H.lookup i mp-                       reload = do-                           nodes' <- runNodeList $ childNodes tree-                           return $! (H.insert i (cur,nodes') mp, nodes')-                   case mbn of-                       Nothing -> reload-                       (Just (lastUpdate,n)) -> do-                           if ttl > 0 && tagName tree == Just cacheTagName &&-                              diffUTCTime cur lastUpdate > fromIntegral ttl-                             then reload-                             else do-                                 stopRecursion-                                 return $! (mp,n)--    liftIO $ modifyMVar_ mv (const $ return mp')--    return ns------------------------------------------------------------------------------------ | Returns a function that modifies a HeistState to include a \"cache\"--- 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 = do-    sr <- newIORef $ Set.empty-    mv <- liftM CTS $ newMVar H.empty--    return $ ( addOnLoadHook (assignIds sr) .-               -- The cache tag allows the ttl attribute.-               bindSplice cacheTagName (cacheImpl mv) .-               -- Like the old static tag...does not allow ttl-               bindSplice "static" (cacheImpl mv)-             , mv)--  where-    generateId :: IO Int-    generateId = getStdRandom random--    assignIds setref = mapM f-        where-          f node = g $ fromNode node--          getId = do-              i  <- liftM (T.pack . show) generateId-              st <- readIORef setref-              if Set.member i st-                then getId-                else do-                    writeIORef setref $ Set.insert i st-                    return $ T.append "cache-id-" i--          g curs = do-              let node = current curs-              curs' <- if tagName node == Just cacheTagName ||-                          tagName node == Just "static"-                         then do-                             i <- getId-                             return $ modifyNode (setAttribute "id" i) curs-                         else return curs-              let mbc = nextDF curs'-              maybe (return $ topNode curs') g mbc----

@@ -1,47 +0,0 @@-module Text.Templating.Heist.Splices.Html where---------------------------------------------------------------------------------import           Data.Maybe-import           Data.Text (Text)-import qualified Text.XmlHtml as X---------------------------------------------------------------------------------import           Text.Templating.Heist.Internal-import           Text.Templating.Heist.Types------------------------------------------------------------------------------------ | Name for the html splice.-htmlTag :: Text-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 = do-    node <- getParamNode-    children <- runNodeList $ X.childNodes node-    let (heads, mnode) = extractHeads $ node { X.elementChildren = children }-        new (X.Element t a c) = X.Element t a $-            X.Element "head" [] heads : c-        new n = n-    stopRecursion-    return [maybe node new mnode]----------------------------------------------------------------------------------- | Extracts all heads from a node tree.-extractHeads :: X.Node-             -- ^ The root (html) node-             -> ([X.Node], Maybe X.Node)-             -- ^ A tuple of a list of head nodes and the original tree with-             --   heads removed.-extractHeads (X.Element t a c)-  | t == "head" = (c, Nothing)-  | otherwise   = (concat heads, Just $ X.Element t a (catMaybes mcs))-  where-    (heads, mcs) = unzip $ map extractHeads c-extractHeads n = ([], Just n)-

@@ -1,22 +0,0 @@-module Text.Templating.Heist.Splices.Ignore where---------------------------------------------------------------------------------import           Data.Text (Text)---------------------------------------------------------------------------------import           Text.Templating.Heist.Types------------------------------------------------------------------------------------ | Default name for the ignore splice.-ignoreTag :: Text-ignoreTag = "ignore"------------------------------------------------------------------------------------ | The ignore tag and everything it surrounds disappears in the--- rendered output.-ignoreImpl :: Monad m => Splice m-ignoreImpl = return []--

@@ -1,222 +0,0 @@-{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE OverloadedStrings #-}--module Text.Templating.Heist.Splices.Json (-  bindJson-) where---------------------------------------------------------------------------------import           Control.Monad.Reader-import           Data.Aeson-import           Data.Attoparsec.Number-import qualified Data.ByteString.Char8       as S-import qualified Data.ByteString.Lazy.Char8  as L-import qualified Data.HashMap.Strict         as Map-import           Data.Maybe-import           Data.Text                   (Text)-import qualified Data.Text                   as T-import qualified Data.Text.Encoding          as T-import qualified Data.Vector                 as V-import           Text.Templating.Heist-import qualified Text.Blaze.Html5            as B-import           Text.Blaze.Html5            ((!))-import           Text.Blaze.Renderer.XmlHtml-import           Text.XmlHtml---------------------------------------------------------------------------------                                 -------------                                 -- public ---                                 ----------------------------------------------------------------------------------------------- | This splice binds convenience tags for the given JSON (or--- JSON-convertible) value and runs the tag's child nodes using the new--- bindings.------ /Tags bound when you pass in an object/------ Tags bound for an object looking like this:------ > { "k_1": v_1, ..., "k_N": v_N }------ @\<value:{k_i}\>@    -- treats v_i as text--- @\<snippet:{k_i}\>@  -- treats v_i as HTML--- @\<with:{k_i}\>@     -- explodes v_i and runs its children------ @\<value var=\"foo.bar.baz\"\/>@ -- walks the JSON tree to find--- \"foo.bar.baz\", and interprets it as a string--- @\<snippet var=\"foo.bar.baz\"\/\>@--- @\<with var=\"foo.bar.baz\"\>...\<with\>@------ /Tags bound when you pass in anything else/------ @\<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 = runReaderT explodeTag . toJSON---                                 --------------                                 -- private ---                                 ----------------------------------------------------------------------------------------------errorMessage :: String -> [Node]-errorMessage s = renderHtmlNodes $-                     B.strong ! B.customAttribute "class" "error" $-                     B.toHtml s----------------------------------------------------------------------------------type JsonMonad m a = ReaderT Value (HeistT m) a----------------------------------------------------------------------------------withValue :: (Monad m) => Value -> JsonMonad m a -> HeistT m a-withValue = flip runReaderT----------------------------------------------------------------------------------boolToText :: Bool -> Text-boolToText b = if b then "true" else "false"----------------------------------------------------------------------------------numToText :: Number -> Text-numToText = T.decodeUtf8 . S.concat . L.toChunks . encode----------------------------------------------------------------------------------findExpr :: Text -> Value -> Maybe Value-findExpr t = go (T.split (=='.') t)-  where-    go [] !value     = Just value-    go (x:xs) !value = findIn value >>= go xs-      where-        findIn (Object obj) = Map.lookup x obj-        findIn _            = Nothing----------------------------------------------------------------------------------asHtml :: Monad m => Text -> m [Node]-asHtml t =-    case (parseHTML "" $ T.encodeUtf8 t) of-      Left e  -> return $ errorMessage $-                 "Template error turning JSON into HTML: " ++ e-      Right d -> return $! docContent d----------------------------------------------------------------------------------snippetTag :: Monad m => JsonMonad m [Node]-snippetTag = ask >>= snip-  where-    txt t = lift $ asHtml t--    snip Null       = txt ""-    snip (Bool b)   = txt $ boolToText b-    snip (Number n) = txt $ numToText n-    snip (String t) = txt t-    snip _          = lift $ do-        node <- getParamNode-        return $ errorMessage $ concat [-                     "error processing tag <"-                   , T.unpack $ fromMaybe "???" $ tagName node-                   , ">: can't interpret JSON arrays or objects as HTML."-                   ]----------------------------------------------------------------------------------valueTag :: Monad m => JsonMonad m [Node]-valueTag = ask >>= go-  where-    go Null       = txt ""-    go (Bool b)   = txt $ boolToText b-    go (Number n) = txt $ numToText n-    go (String t) = txt t-    go _          = lift $ do-        node <- getParamNode-        return $ errorMessage $ concat [-                     "error processing tag <"-                   , T.unpack $ fromMaybe "???" $ tagName node-                   , ">: can't interpret JSON arrays or objects as text."-                   ]---    txt t = return [TextNode t]----------------------------------------------------------------------------------explodeTag :: (Monad m) => JsonMonad m [Node]-explodeTag = ask >>= go-  where-    ---------------------------------------------------------------------------    go Null       = goText ""-    go (Bool b)   = goText $ boolToText b-    go (Number n) = goText $ numToText n-    go (String t) = goText t-    go (Array a)  = goArray a-    go (Object o) = goObject o--    ---------------------------------------------------------------------------    goText t = lift $ runChildrenWith [ ("value"   , return [TextNode t])-                                      , ("snippet" , asHtml t           )-                                      ]--    ---------------------------------------------------------------------------    goArray :: (Monad m) => V.Vector Value -> JsonMonad m [Node]-    goArray a = do-        lift stopRecursion-        dl <- V.foldM f id a-        return $! dl []-      where-        f dl jsonValue = do-            tags <- go jsonValue-            return $! dl . (tags ++)--    ---------------------------------------------------------------------------    -- 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 v m = do-        node <- getParamNode-        maybe (noVar node) (hasVar node) $ getAttribute "var" node-      where-        noVar node = return $ errorMessage $-                     concat [ "expression error: no var attribute in <"-                            , T.unpack $ fromMaybe "???" $ tagName node-                            , "> tag"-                            ]--        hasVar node expr = maybe (return $ errorMessage $-                                  concat [-                                    "expression error: can't find \""-                                  , T.unpack expr-                                  , "\" in JSON object (<"-                                  , T.unpack $ fromMaybe "???" $ tagName node-                                  , "> tag)"-                                  ])-                                 (runReaderT m)-                                 (findExpr expr v)--    ---------------------------------------------------------------------------    genericBindings :: Monad m => JsonMonad m [(Text, Splice m)]-    genericBindings = ask >>= \v -> return [ ("with",    varAttrTag v explodeTag)-                                           , ("snippet", varAttrTag v snippetTag)-                                           , ("value",   varAttrTag v valueTag  )-                                           ]--    ---------------------------------------------------------------------------    goObject obj = do-        start <- genericBindings-        let bindings = Map.foldlWithKey' bindKvp start obj-        lift $ runChildrenWith bindings--    ---------------------------------------------------------------------------    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

@@ -1,183 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-| The \"markdown\" splice formats markdown content as HTML and inserts-it into the document.--If the file attribute is present the contents of the tag is ignored and-the file specified is converted to HTML.--Otherwise the non-markup children of the tag are processed as markdown-and converted to HTML.--This splice requires that the \"pandoc\" executable is in your path.--}-module Text.Templating.Heist.Splices.Markdown where---------------------------------------------------------------------------------import           Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import           Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import           Data.Maybe-import           Control.Concurrent-import           Control.Exception (throwIO)-import           Control.Monad-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-import           System.IO-import           System.Process-import           Text.XmlHtml---------------------------------------------------------------------------------import           Text.Templating.Heist.Internal-import           Text.Templating.Heist.Types--data PandocMissingException = PandocMissingException-   deriving (Typeable)--instance Show PandocMissingException where-    show PandocMissingException =-        "Cannot find the \"pandoc\" executable; is it on your $PATH?"--instance Exception PandocMissingException---data MarkdownException = MarkdownException ByteString-   deriving (Typeable)--instance Show MarkdownException where-    show (MarkdownException e) =-        "Markdown error: pandoc replied:\n\n" ++ BC.unpack e--instance Exception MarkdownException---data NoMarkdownFileException = NoMarkdownFileException-    deriving (Typeable)--instance Show NoMarkdownFileException where-    show NoMarkdownFileException =-        "Markdown error: no file or template in context" ++-        " during processing of markdown tag"--instance Exception NoMarkdownFileException where----------------------------------------------------------------------------------- | Default name for the markdown splice.-markdownTag :: Text-markdownTag = "markdown"----------------------------------------------------------------------------------- | Implementation of the markdown splice.-markdownSplice :: MonadIO m => Splice m-markdownSplice = do-    templateDir <- liftM (fmap takeDirectory) getTemplateFilePath-    pdMD <- liftIO $ findExecutable "pandoc"--    when (isNothing pdMD) $ liftIO $ throwIO PandocMissingException--    tree <- getParamNode-    (source,markup) <- liftIO $-        case getAttribute "file" tree of-            Just f  -> do-                m <- maybe (liftIO $ throwIO NoMarkdownFileException )-                           (\tp -> pandoc (fromJust pdMD) tp $ T.unpack f)-                           templateDir-                return (T.unpack f,m)-            Nothing -> do-                m <- pandocBS (fromJust pdMD) $ T.encodeUtf8 $ nodeText tree-                return ("inline_splice",m)--    let ee = parseHTML source markup-    case ee of-      Left e  -> throw $ MarkdownException-                       $ BC.pack ("Error parsing markdown output: " ++ e)-      Right d -> return (docContent d)---pandoc :: FilePath -> FilePath -> FilePath -> IO ByteString-pandoc pandocPath templateDir inputFile = do-    (ex, sout, serr) <- readProcessWithExitCode' pandocPath args ""--    when (isFail ex) $ throw $ MarkdownException serr-    return $ BC.concat [ "<div class=\"markdown\">\n"-                         , sout-                         , "\n</div>" ]--  where-    isFail ExitSuccess = False-    isFail _           = True--    args = [ "-S", "--no-wrap", templateDir </> inputFile ]---pandocBS :: FilePath -> ByteString -> IO ByteString-pandocBS pandocPath s = do-    -- using the crummy string functions for convenience here-    (ex, sout, serr) <- readProcessWithExitCode' pandocPath args s--    when (isFail ex) $ throw $ MarkdownException serr-    return $ BC.concat [ "<div class=\"markdown\">\n"-                       , sout-                       , "\n</div>" ]--  where-    isFail ExitSuccess = False-    isFail _           = True-    args = [ "-S", "--no-wrap" ]----- a version of readProcessWithExitCode that does I/O properly-readProcessWithExitCode'-    :: FilePath                 -- ^ command to run-    -> [String]                 -- ^ any arguments-    -> ByteString               -- ^ standard input-    -> IO (ExitCode,ByteString,ByteString) -- ^ exitcode, stdout, stderr-readProcessWithExitCode' cmd args input = do-    (Just inh, Just outh, Just errh, pid) <--        createProcess (proc cmd args){ std_in  = CreatePipe,-                                       std_out = CreatePipe,-                                       std_err = CreatePipe }-    outMVar <- newEmptyMVar--    outM <- newEmptyMVar-    errM <- newEmptyMVar--    -- fork off a thread to start consuming stdout-    forkIO $ do-        out <- B.hGetContents outh-        putMVar outM out-        putMVar outMVar ()--    -- fork off a thread to start consuming stderr-    forkIO $ do-        err  <- B.hGetContents errh-        putMVar errM err-        putMVar outMVar ()--    -- now write and flush any input-    when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh-    hClose inh -- done with stdin--    -- wait on the output-    takeMVar outMVar-    takeMVar outMVar-    hClose outh--    -- wait on the process-    ex <- waitForProcess pid--    out <- readMVar outM-    err <- readMVar errM--    return (ex, out, err)----

@@ -1,85 +0,0 @@-{-|--This module defines a TemplateDirectory data structure for convenient-interaction with templates within web apps.---}--module Text.Templating.Heist.TemplateDirectory-    ( TemplateDirectory-    , newTemplateDirectory-    , newTemplateDirectory'--    , getDirectoryTS-    , reloadTemplateDirectory-    ) where---------------------------------------------------------------------------------import           Control.Concurrent-import           Control.Monad-import           Control.Monad.Trans-import           Text.Templating.Heist-import           Text.Templating.Heist.Splices.Cache------------------------------------------------------------------------------------ | Structure representing a template directory.-data TemplateDirectory m-    = TemplateDirectory-        FilePath-        (HeistState m)-        (MVar (HeistState m))-        CacheTagState------------------------------------------------------------------------------------ | Creates and returns a new 'TemplateDirectory' wrapped in an Either for--- error handling.-newTemplateDirectory :: (MonadIO m, MonadIO n)-                     => FilePath-                     -> HeistState m-                     -> n (Either String (TemplateDirectory m))-newTemplateDirectory dir templateState = liftIO $ do-    (modTs,cts) <- mkCacheTag-    let origTs = modTs templateState-    ets <- loadTemplates dir origTs-    leftPass ets $ \ts -> do-        tsMVar <- newMVar $ ts-        return $ TemplateDirectory dir origTs tsMVar cts------------------------------------------------------------------------------------ | Creates and returns a new 'TemplateDirectory', using the monad's fail--- function on error.-newTemplateDirectory' :: (MonadIO m, MonadIO n)-                      => FilePath-                      -> HeistState m-                      -> n (TemplateDirectory m)-newTemplateDirectory' = ((either fail return =<<) .) . newTemplateDirectory------------------------------------------------------------------------------------ | Gets the 'HeistState' from a TemplateDirectory.-getDirectoryTS :: (Monad m, MonadIO n)-               => TemplateDirectory m-               -> n (HeistState m)-getDirectoryTS (TemplateDirectory _ _ tsMVar _) = liftIO $ readMVar $ tsMVar------------------------------------------------------------------------------------ | Clears cached content and reloads templates from disk.-reloadTemplateDirectory :: (MonadIO m, MonadIO n)-                        => TemplateDirectory m-                        -> n (Either String ())-reloadTemplateDirectory (TemplateDirectory p origTs tsMVar cts) = liftIO $ do-    clearCacheTagState cts-    ets <- loadTemplates p origTs-    leftPass ets $ \ts -> modifyMVar_ tsMVar (const $ return ts)------------------------------------------------------------------------------------ | Prepends an error onto a Left.-leftPass :: Monad m => Either String b -> (b -> m c) -> m (Either String c)-leftPass e m = either (return . Left . loadError) (liftM Right . m) e-  where-    loadError = (++) "Error loading templates: "

@@ -1,406 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}--{-|--This module contains the core Heist data types.  HeistT intentionally-does not expose any of its functionality via MonadState or MonadReader-functions.  We define passthrough instances for the most common types of-monads.  These instances allow the user to use HeistT in a monad stack-without needing calls to `lift`.--Edward Kmett wrote most of the HeistT code and associated instances,-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------------------------------------------------------------------------------------ | A 'Template' is a forest of XML nodes.  Here we deviate from the "single--- root node" constraint of well-formed XML because we want to allow templates--- to contain fragments of a document that may not have a single root.-type Template = [X.Node]------------------------------------------------------------------------------------ | MIME Type.  The type alias is here to make the API clearer.-type MIMEType = ByteString------------------------------------------------------------------------------------ | Reversed list of directories.  This holds the path to the template--- currently being processed.-type TPath = [ByteString]---data DocumentFile = DocumentFile-    { dfDoc  :: X.Document-    , dfFile :: Maybe FilePath-    } deriving (Eq)----------------------------------------------------------------------------------- | All documents representing templates are stored in a map.-type TemplateMap = HashMap TPath DocumentFile------------------------------------------------------------------------------------ | A Splice is a HeistT computation that returns a 'Template'.-type Splice m = HeistT m Template------------------------------------------------------------------------------------ | SpliceMap associates a name and a Splice.-type SpliceMap m = HashMap Text (Splice m)------------------------------------------------------------------------------------ | Holds all the state information needed for template processing.  You will--- build a @HeistState@ using any of Heist's @HeistState m -> HeistState m@--- \"filter\" functions.  Then you use the resulting @HeistState@ in calls to--- @renderTemplate@.-data HeistState m = HeistState {-    -- | A mapping of splice names to splice actions-      _spliceMap       :: SpliceMap m-    -- | A mapping of template names to templates-    , _templateMap     :: TemplateMap-    -- | A flag to control splice recursion-    , _recurse         :: Bool-    -- | The path to the template currently being processed.-    , _curContext      :: TPath-    -- | A counter keeping track of the current recursion depth to prevent-    -- infinite loops.-    , _recursionDepth  :: Int-    -- | A hook run on all templates at load time.-    , _onLoadHook      :: Template -> IO Template-    -- | A hook run on all templates just before they are rendered.-    , _preRunHook      :: Template -> m Template-    -- | A hook run on all templates just after they are rendered.-    , _postRunHook     :: Template -> m Template-    -- | The doctypes encountered during template processing.-    , _doctypes        :: [X.DocType]-    -- | The full path to the current template's file on disk.-    , _curTemplateFile :: Maybe FilePath-}------------------------------------------------------------------------------------ | Gets the names of all the templates defined in a HeistState.-templateNames :: HeistState m -> [TPath]-templateNames ts = H.keys $ _templateMap ts------------------------------------------------------------------------------------ | Gets the names of all the splices defined in a HeistState.-spliceNames :: HeistState m -> [Text]-spliceNames ts = H.keys $ _spliceMap ts----------------------------------------------------------------------------------instance (Monad m) => Monoid (HeistState m) where-    mempty = HeistState H.empty H.empty True [] 0-                           return return return [] Nothing--    (HeistState s1 t1 r1 _ d1 o1 b1 a1 dt1 ctf1) `mappend`-        (HeistState s2 t2 r2 c2 d2 o2 b2 a2 dt2 ctf2) =-        HeistState s t r c2 d (o1 >=> o2) (b1 >=> b2) (a1 >=> a2)-            (dt1 `mappend` dt2) ctf-      where-        s = s1 `mappend` s2-        t = t1 `mappend` t2-        r = r1 && r2-        d = max d1 d2-        ctf = getLast $ Last ctf1 `mappend` Last ctf2----------------------------------------------------------------------------------instance Eq (HeistState m) where-    a == b = (_recurse a == _recurse b) &&-             (_templateMap a == _templateMap b) &&-             (_curContext a == _curContext b)------------------------------------------------------------------------------------ | The Typeable instance is here so Heist can be dynamically executed with--- Hint.-templateStateTyCon :: TyCon-templateStateTyCon = mkTyCon "Text.Templating.Heist.HeistState"-{-# NOINLINE templateStateTyCon #-}--instance (Typeable1 m) => Typeable (HeistState m) where-    typeOf _ = mkTyConApp templateStateTyCon [typeOf1 (undefined :: m ())]------------------------------------------------------------------------------------ | HeistT is the monad used for 'Splice' processing.  HeistT provides--- \"passthrough\" instances for many of the monads you might use in the inner--- monad.-newtype HeistT m a = HeistT {-    runHeistT :: X.Node-              -> HeistState m-              -> m (a, HeistState m)-}------------------------------------------------------------------------------------ | Evaluates a template monad as a computation in the underlying monad.-evalHeistT :: Monad m-           => HeistT m a-           -> X.Node-           -> HeistState m-           -> m a-evalHeistT m r s = do-    (a, _) <- runHeistT m r s-    return a-{-# INLINE evalHeistT #-}------------------------------------------------------------------------------------ | Functor instance-instance Functor m => Functor (HeistT m) where-    fmap f (HeistT m) = HeistT $ \r s -> first f <$> m r s------------------------------------------------------------------------------------ | Applicative instance-instance (Monad m, Functor m) => Applicative (HeistT m) where-    pure = return-    (<*>) = ap------------------------------------------------------------------------------------ | Monad instance-instance Monad m => Monad (HeistT m) where-    return a = HeistT (\_ s -> return (a, s))-    {-# INLINE return #-}-    HeistT m >>= k = HeistT $ \r s -> do-        (a, s') <- m r s-        runHeistT (k a) r s'-    {-# INLINE (>>=) #-}------------------------------------------------------------------------------------ | MonadIO instance-instance MonadIO m => MonadIO (HeistT m) where-    liftIO = lift . liftIO------------------------------------------------------------------------------------ | MonadTrans instance-instance MonadTrans HeistT where-    lift m = HeistT $ \_ s -> do-        a <- m-        return (a, s)------------------------------------------------------------------------------------ | MonadCatchIO instance-instance MonadCatchIO m => MonadCatchIO (HeistT 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)------------------------------------------------------------------------------------ | MonadFix passthrough instance-instance MonadFix m => MonadFix (HeistT m) where-    mfix f = HeistT $ \r s ->-        mfix $ \ (a, _) -> runHeistT (f a) r s------------------------------------------------------------------------------------ | Alternative passthrough instance-instance (Functor m, MonadPlus m) => Alternative (HeistT m) where-    empty = mzero-    (<|>) = mplus------------------------------------------------------------------------------------ | MonadPlus passthrough instance-instance MonadPlus m => MonadPlus (HeistT m) where-    mzero = lift mzero-    m `mplus` n = HeistT $ \r s ->-        runHeistT m r s `mplus` runHeistT n r s------------------------------------------------------------------------------------ | MonadState passthrough instance-instance MonadState s m => MonadState s (HeistT m) where-    get = lift get-    {-# INLINE get #-}-    put = lift . put-    {-# INLINE put #-}------------------------------------------------------------------------------------ | MonadReader passthrough instance-instance MonadReader r m => MonadReader r (HeistT m) where-    ask = HeistT $ \_ s -> do-            r <- ask-            return (r,s)-    local f (HeistT m) =-        HeistT $ \r s -> local f (m r s)------------------------------------------------------------------------------------ | Helper for MonadError instance.-liftCatch :: (m (a,HeistState m)-              -> (e -> m (a,HeistState m))-              -> m (a,HeistState m))-          -> HeistT m a-          -> (e -> HeistT m a)-          -> HeistT m a-liftCatch ce m h =-    HeistT $ \r s ->-        (runHeistT m r s `ce`-        (\e -> runHeistT (h e) r s))------------------------------------------------------------------------------------ | MonadError passthrough instance-instance (MonadError e m) => MonadError e (HeistT m) where-    throwError = lift . throwError-    catchError = liftCatch catchError------------------------------------------------------------------------------------ | Helper for MonadCont instance.-liftCallCC :: ((((a,HeistState m) -> m (b, HeistState m))-                  -> m (a, HeistState m))-                -> m (a, HeistState m))-           -> ((a -> HeistT m b) -> HeistT m a)-           -> HeistT m a-liftCallCC ccc f = HeistT $ \r s ->-    ccc $ \c ->-    runHeistT (f (\a -> HeistT $ \_ _ -> c (a, s))) r s------------------------------------------------------------------------------------ | MonadCont passthrough instance-instance (MonadCont m) => MonadCont (HeistT m) where-    callCC = liftCallCC callCC------------------------------------------------------------------------------------ | The Typeable instance is here so Heist can be dynamically executed with--- Hint.-templateMonadTyCon :: TyCon-templateMonadTyCon = mkTyCon "Text.Templating.Heist.HeistT"-{-# NOINLINE templateMonadTyCon #-}--instance (Typeable1 m) => Typeable1 (HeistT m) where-    typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())]------------------------------------------------------------------------------------ Functions for our monad.------------------------------------------------------------------------------------------------------------------------------------------------------------------- | Gets the node currently being processed.------   > <speech author="Shakespeare">---   >   To sleep, perchance to dream.---   > </speech>------ When you call @getParamNode@ inside the code for the @speech@ splice, it--- returns the Node for the @speech@ tag and its children.  @getParamNode >>=--- childNodes@ returns a list containing one 'TextNode' containing part of--- Hamlet's speech.  @liftM (getAttribute \"author\") getParamNode@ would--- return @Just "Shakespeare"@.-getParamNode :: Monad m => HeistT m X.Node-getParamNode = HeistT $ \r s -> return (r,s)-{-# INLINE getParamNode #-}------------------------------------------------------------------------------------ | HeistT's 'local'.-localParamNode :: Monad m-               => (X.Node -> X.Node)-               -> HeistT m a-               -> HeistT m a-localParamNode f m = HeistT $ \r s -> runHeistT m (f r) s-{-# INLINE localParamNode #-}------------------------------------------------------------------------------------ | HeistT's 'gets'.-getsTS :: Monad m => (HeistState m -> r) -> HeistT m r-getsTS f = HeistT $ \_ s -> return (f s, s)-{-# INLINE getsTS #-}------------------------------------------------------------------------------------ | HeistT's 'get'.-getTS :: Monad m => HeistT m (HeistState m)-getTS = HeistT $ \_ s -> return (s, s)-{-# INLINE getTS #-}------------------------------------------------------------------------------------ | HeistT's 'put'.-putTS :: Monad m => HeistState m -> HeistT m ()-putTS s = HeistT $ \_ _ -> return ((), s)-{-# INLINE putTS #-}------------------------------------------------------------------------------------ | HeistT's 'modify'.-modifyTS :: Monad m-                    => (HeistState m -> HeistState m)-                    -> HeistT m ()-modifyTS f = HeistT $ \_ s -> return ((), f s)-{-# INLINE modifyTS #-}------------------------------------------------------------------------------------ | Restores the HeistState.  This function is almost like putTS except it--- preserves the current doctypes.  You should use this function instead of--- @putTS@ to restore an old state.  This was needed because doctypes needs to--- be in a "global scope" as opposed to the template call "local scope" of--- state items such as recursionDepth, curContext, and spliceMap.-restoreTS :: Monad m => HeistState m -> HeistT m ()-restoreTS old = modifyTS (\cur -> old { _doctypes = _doctypes cur })-{-# INLINE restoreTS #-}------------------------------------------------------------------------------------ | Abstracts the common pattern of running a HeistT computation with--- a modified heist state.-localTS :: Monad m-        => (HeistState m -> HeistState m)-        -> HeistT m a-        -> HeistT m a-localTS f k = do-    ts <- getTS-    putTS $ f ts-    res <- k-    restoreTS ts-    return res-{-# INLINE localTS #-}-

@@ -8,33 +8,89 @@   main-is:         TestSuite.hs    build-depends:-    QuickCheck                 >= 2,-    aeson                      >= 0.4      && < 0.7,-    attoparsec                 >= 0.10     && < 0.11,-    base                       >= 4        && < 5,-    blaze-builder              >= 0.2      && < 0.4,-    blaze-html                 >= 0.4      && < 0.6,-    bytestring,-    containers,-    directory,-    directory-tree,-    process,-    filepath,-    xmlhtml                    >= 0.1.6    && < 0.3,     HUnit                      >= 1.2      && < 2,-    mtl                        >= 2,-    random,-    MonadCatchIO-transformers  >= 0.2.1    && < 0.3,+    QuickCheck                 >= 2,+    MonadCatchIO-transformers  >= 0.2.1    && < 0.4,     test-framework             >= 0.6      && <0.7,     test-framework-hunit       >= 0.2.7    && <0.3,     test-framework-quickcheck2 >= 0.2.12.1 && <0.3,-    text                       >= 0.10     && < 0.12,-    time,-    transformers,-    unordered-containers       >= 0.1.4    && < 0.3,-    vector                     >= 0.9      && < 0.10+    aeson                      >= 0.6     && < 0.7,+    attoparsec                 >= 0.10    && < 0.11,+    base                       >= 4       && < 5,+    blaze-builder              >= 0.2     && < 0.4,+    blaze-html                 >= 0.4     && < 0.6,+    bytestring                 >= 0.9     && < 0.11,+    containers                 >= 0.2     && < 0.6,+    directory                  >= 1.1     && < 1.3,+    directory-tree             >= 0.10    && < 0.12,+    dlist                      >= 0.5     && < 0.6,+    errors                     >= 1.3     && < 1.4,+    filepath                   >= 1.3     && < 1.4,+    hashable                   >= 1.1     && < 1.2,+    mtl                        >= 2.0     && < 2.2,+    process                    >= 1.1     && < 1.2,+    random                     >= 1.0.1.0 && < 1.1,+    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.1.6   && < 0.3     ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded   Extensions: OverloadedStrings++Executable benchmark+  hs-source-dirs: ../src suite+  main-is: Benchmark.hs++  build-depends:+    MonadCatchIO-transformers >= 0.3     && < 0.4,+    HUnit                     >= 1.2     && < 1.3,+    criterion                 >= 0.6     && < 0.7,+    test-framework            >= 0.4     && < 0.7,+    test-framework-hunit      >= 0.2     && < 0.3,++    -- Copied from regular dependencies:++    aeson                      >= 0.6     && < 0.7,+    attoparsec                 >= 0.10    && < 0.11,+    base                       >= 4       && < 5,+    blaze-builder              >= 0.2     && < 0.4,+    blaze-html                 >= 0.4     && < 0.6,+    bytestring                 >= 0.9     && < 0.11,+    containers                 >= 0.2     && < 0.6,+    directory                  >= 1.1     && < 1.3,+    directory-tree             >= 0.10    && < 0.12,+    dlist                      >= 0.5     && < 0.6,+    errors                     >= 1.3     && < 1.4,+    filepath                   >= 1.3     && < 1.4,+    hashable                   >= 1.1     && < 1.2,+    mtl                        >= 2.0     && < 2.2,+    process                    >= 1.1     && < 1.2,+    random                     >= 1.0.1.0 && < 1.1,+    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.1.6   && < 0.3++  ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded+               -fno-warn-unused-do-bind -rtsopts++  ghc-prof-options: -prof -auto-all++  Extensions:+    GeneralizedNewtypeDeriving,+    PackageImports,+    ScopedTypeVariables,+    DeriveDataTypeable,+    FlexibleInstances,+    MultiParamTypeClasses,+    UndecidableInstances,+    OverloadedStrings,+    TypeSynonymInstances,+    NoMonomorphismRestriction 

@@ -24,13 +24,13 @@ mkdir -p $DIR  EXCLUDES='Main-Data.CIByteString-Snap.Internal.Http.Parser.Tests-Snap.Internal.Http.Server.Tests-Snap.Internal.Http.Types.Tests-Snap.Internal.Iteratee.Tests-Text.Snap.Templates.Tests-Snap.Test.Common'+Heist.Compiled.Tests+Heist.Interpreted.Tests+Heist.Tutorial.AttributeSplices+Heist.Tutorial.CompiledSplices+Heist.Tutorial.Imports+Heist.TestCommon+Heist.Tests'  EXCL="" 

@@ -0,0 +1,116 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++------------------------------------------------------------------------------+import           Blaze.ByteString.Builder+import           Criterion+import           Criterion.Main+import           Criterion.Measurement hiding (getTime)+import           Control.Concurrent+import           Control.Error+import           Control.Exception (evaluate)+import           Control.Monad+import qualified Data.ByteString as B+import qualified Data.DList as DL+import qualified Data.Text as T+import           Data.Text.Encoding+import           Data.Time.Clock+import           Data.Maybe+import qualified Text.XmlHtml as X+import           System.Environment++import Heist+import Heist.Common+import qualified Heist.Compiled as C+import qualified Heist.Compiled.Internal as CI+import qualified Heist.Interpreted as I+import Heist.TestCommon+import Heist.Types++loadWithCache baseDir = do+    etm <- runEitherT $ do+        templates <- loadTemplates baseDir+        let hc = HeistConfig [] defaultLoadTimeSplices [] [] templates+        initHeistWithCacheTag hc+    either (error . unlines) (return . fst) etm++main = do+    (dir:file:_) <- getArgs+    applyComparison dir file++justRender dir = do+    let page = "faq"+        pageStr = T.unpack $ decodeUtf8 page+    hs <- loadWithCache dir+    let !compiledTemplate = fst $! fromJust $! C.renderTemplate hs page+        compiledAction = do+            res <- compiledTemplate+            return $! toByteString $! res+    out <- compiledAction+    putStrLn $ "Rendered ByteString of length "++(show $ B.length out)+    B.writeFile (pageStr++".out.compiled."++dir) $ out++    defaultMain+       [ bench (pageStr++"-compiled (just render)") (whnfIO compiledAction)+       ]++------------------------------------------------------------------------------+applyComparison :: FilePath -> String -> IO ()+applyComparison dir pageStr = do+    let page = encodeUtf8 $ T.pack pageStr+    hs <- loadWithCache dir+    let compiledAction = do+            res <- fst $ fromJust $ C.renderTemplate hs page+            return $! toByteString $! res+    out <- compiledAction+    B.writeFile (pageStr++".out.compiled."++dir) $ out++    let interpretedAction = do+            res <- I.renderTemplate hs page+            return $! toByteString $! fst $! fromJust res+    out2 <- interpretedAction+    B.writeFile (pageStr++".out.interpreted."++dir) $ out++    defaultMain+       [ bench (pageStr++"-compiled") (whnfIO compiledAction)+       , bench (pageStr++"-interpreted") (whnfIO interpretedAction)+       ]++cmdLineTemplate :: String -> String -> IO ()+cmdLineTemplate dir page = do+--    args <- getArgs+--    let page = head args+--    let dir = "test/snap-website"+    hs <- loadHS dir+    let action = fst $ fromJust $ C.renderTemplate hs+            (encodeUtf8 $ T.pack page)+    out <- action+    B.writeFile (page++".out.cur") $ toByteString out++--    reference <- B.readFile "faq.out"+--    if False+--      then do+--        putStrLn "Template didn't render properly"+--        error "Aborting"+--      else+--        putStrLn "Template rendered correctly"++    defaultMain [+         bench (page++"-speed") action+       ]+++testNode =+  X.Element "div" [("foo", "aoeu"), ("bar", "euid")] +    [X.Element "b" [] [X.TextNode "bolded text"]+    ,X.TextNode " not bolded"+    ,X.Element "a" [("href", "/path/to/page")] [X.TextNode "link"]+    ]++getChunks templateName = do+    hs <- loadHS "snap-website-nocache"+    let (Just t) = lookupTemplate templateName hs _compiledTemplateMap+    return $! fst $! fst t+

@@ -0,0 +1,38 @@+module Heist.Compiled.Tests+  ( tests+  ) where++import           Test.Framework (Test)+import           Test.Framework.Providers.HUnit+import qualified Test.HUnit as H+++------------------------------------------------------------------------------+import           Heist.Tutorial.CompiledSplices++-- NOTE: We can't test compiled templates on the templates directory as it+-- stands today because that directory contains some error conditions such as+-- infinite bind loops, apply tags with no template attribute, and apply tags+-- with ".." in the tag path (which doesn't currently work).++tests :: [Test]+tests = [ testCase     "compiled/simple"       simpleCompiledTest+        , testCase     "compiled/people"       peopleTest+        ]++simpleCompiledTest :: IO ()+simpleCompiledTest = do+    res <- runWithStateSplice "templates"+    H.assertEqual "compiled state splice" expected res+  where+    expected =+      "&#10;<html>&#10;3&#10;</html>&#10;"++peopleTest :: IO ()+peopleTest = do+    res <- personListTest "templates"+    H.assertEqual "people splice" expected res+  where+    expected =+      "&#10;<p>Doe, John: 42&#32;years old</p>&#10;&#10;<p>Smith, Jane: 21&#32;years old</p>&#10;&#10;"+

@@ -0,0 +1,658 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# OPTIONS_GHC -fno-warn-orphans       #-}++module Heist.Interpreted.Tests+  ( tests+  , quickRender+  ) where++------------------------------------------------------------------------------+import           Blaze.ByteString.Builder+import           Control.Error+import           Control.Monad.State+import           Data.Aeson+import           Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.HashMap.Strict as Map+import           Data.Maybe+import           Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import           Data.Text (Text)+import           System.IO.Unsafe+import           Test.Framework (Test)+import           Test.Framework.Providers.HUnit+import           Test.Framework.Providers.QuickCheck2+import qualified Test.HUnit as H+import           Test.QuickCheck+import           Test.QuickCheck.Monadic+++------------------------------------------------------------------------------+import           Heist+import           Heist.Common+import           Heist.Interpreted.Internal+import           Heist.Splices.Apply+import           Heist.Splices.Ignore+import           Heist.Splices.Json+import           Heist.Splices.Markdown+import           Heist.TestCommon+import           Heist.Types+import qualified Text.XmlHtml        as X+import qualified Text.XmlHtml.Cursor as X+++------------------------------------------------------------------------------+tests :: [Test]+tests = [ testProperty "heist/simpleBind"            simpleBindTest+        , testProperty "heist/simpleApply"           simpleApplyTest+        , testCase     "heist/templateAdd"           addTest+        , testCase     "heist/hasTemplate"           hasTemplateTest+        , testCase     "heist/getDoc"                getDocTest+        , testCase     "heist/load"                  loadTest+        , testCase     "heist/fsLoad"                fsLoadTest+        , testCase     "heist/renderNoName"          renderNoNameTest+        , testCase     "heist/doctype"               doctypeTest+        , testCase     "heist/attributeSubstitution" attrSubstTest+        , testCase     "heist/bindAttribute"         bindAttrTest+        , testCase     "heist/markdown"              markdownTest+        , testCase     "heist/title_expansion"       titleExpansion+        , testCase     "heist/textarea_expansion"    textareaExpansion+        , testCase     "heist/div_expansion"         divExpansion+        , testCase     "heist/bind_param"            bindParam+        , testCase     "heist/markdownText"          markdownTextTest+        , testCase     "heist/apply"                 applyTest+        , testCase     "heist/ignore"                ignoreTest+        , testCase     "heist/lookupTemplateContext" lookupTemplateTest+        , testCase     "heist/attrSpliceContext"     attrSpliceContext+        , testCase     "heist/json/values"           jsonValueTest+        , testCase     "heist/json/object"           jsonObjectTest+        ]+++------------------------------------------------------------------------------+simpleBindTest :: Property+simpleBindTest = monadicIO $ forAllM arbitrary prop+  where+    prop :: Bind -> PropertyM IO ()+    prop bind = do+        let template = buildBindTemplate bind+        let result   = buildResult bind++        spliceResult <- run $ do+            hs <- loadEmpty defaultLoadTimeSplices [] [] []+            evalHeistT (runNodeList template)+                       (X.TextNode "") hs++        assert $ result == spliceResult+++------------------------------------------------------------------------------+simpleApplyTest :: Property+simpleApplyTest = monadicIO $ forAllM arbitrary prop+  where+    prop :: Apply -> PropertyM IO ()+    prop apply = do+        let correct = calcCorrect apply+        result <- run $ calcResult apply+        assert $ correct == result+++------------------------------------------------------------------------------+addTest :: IO ()+addTest = do+    es <- loadEmpty [] [] [] []+    let hs = addTemplate "aoeu" [] Nothing es+    H.assertEqual "lookup test" (Just []) $+        fmap (X.docContent . dfDoc . fst) $+        lookupTemplate "aoeu" hs _templateMap+++------------------------------------------------------------------------------+hasTemplateTest :: H.Assertion+hasTemplateTest = do+    ets <- loadIO "templates" [] [] [] []+    let tm = either (error "Error loading templates") _templateMap ets+    hs <- loadEmpty [] [] [] []+    let hs's = setTemplates tm hs+    H.assertBool "hasTemplate hs's" (hasTemplate "index" hs's)+++------------------------------------------------------------------------------+getDocTest :: H.Assertion+getDocTest = do+    d <- getDoc "bkteoar"+    H.assertBool "non-existent doc" $ isLeft d+    f <- getDoc "templates/index.tpl"+    H.assertBool "index doc" $ not $ isLeft f+++------------------------------------------------------------------------------+loadTest :: H.Assertion+loadTest = do+    ets <- loadIO "templates" [] [] [] []+    either (error "Error loading templates")+           (\ts -> do let tm = _templateMap ts+                      H.assertEqual "loadTest size" 36 $ Map.size tm+           ) ets+++------------------------------------------------------------------------------+fsLoadTest :: H.Assertion+fsLoadTest = do+    ets <- loadIO "templates" [] [] [] []+    let tm = either (error "Error loading templates") _templateMap ets+    es <- loadEmpty [] [] [] []+    let hs = setTemplates tm es+    let f  = g hs++    f isNothing "abc/def/xyz"+    f isJust "a"+    f isJust "bar/a"+    f isJust "/bar/a"++  where+    g ts p n = H.assertBool ("loading template " ++ n) $ p $+               lookupTemplate (B.pack n) ts _templateMap++------------------------------------------------------------------------------+renderNoNameTest :: H.Assertion+renderNoNameTest = do+    ets <- loadT "templates" [] [] [] []+    either (error "Error loading templates")+           (\ts -> do t <- renderTemplate ts ""+                      H.assertBool "renderNoName" $ isNothing t+           ) ets+++------------------------------------------------------------------------------+doctypeTest :: H.Assertion+doctypeTest = do+    ets <- loadT "templates" [] [] [] []+    let ts = either (error "Error loading templates") id ets+    Just (indexDoc, _) <- renderTemplate ts "index"+    H.assertEqual "index doctype test" indexRes $ toByteString $ indexDoc+    Just (_, _) <- renderTemplate ts "ioc"+    H.assertEqual "ioc doctype test" indexRes $ toByteString $ indexDoc+  where+    indexRes = B.concat+        [doctype+        ,"\n&#10;<html>\n<div id='pre_{att}_post'>\n/index\n</div>\n</html>\n"+        ]++------------------------------------------------------------------------------+attrSubstTest :: H.Assertion+attrSubstTest = do+    ets <- loadT "templates" [] [] [] []+    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"])]+        +    check str ts expected = do+        Just (resDoc, _) <- renderTemplate ts "attrs"+        H.assertEqual str expected $ toByteString $ resDoc++    out1 = B.unlines+        [doctype+        ,"<mytag flag>Empty attribute</mytag>"+        ,"<mytag flag='abc${foo}'>No ident capture</mytag>"+        ,"<div id='pre_meaning_of_everything_post'></div>"+        ]+    out2 = B.unlines+        [doctype+        ,"<mytag flag>Empty attribute</mytag>"+        ,"<mytag flag='abc${foo}'>No ident capture</mytag>"+        ,"<div id='pre__post'></div>"+        ]+++------------------------------------------------------------------------------+bindAttrTest :: H.Assertion+bindAttrTest = do+    ets <- loadT "templates" [] [] [] []+    let ts = either (error "Error loading templates") id ets+    check ts "<div id=\'zzzzz\'"++  where+    check ts str = do+        Just (resDoc, _) <- renderTemplate ts "bind-attrs"+        H.assertBool ("attr subst " ++ (show str)) $ not $ B.null $+            snd $ B.breakSubstring str $ toByteString $ resDoc+        H.assertBool ("attr subst bar") $ B.null $+            snd $ B.breakSubstring "${bar}" $ toByteString $ resDoc+++------------------------------------------------------------------------------+markdownHtmlExpected :: ByteString+markdownHtmlExpected = B.concat+    [ doctype+    , "<div class='markdown'><p>This <em>is</em> a test.</p></div>"+    ]++------------------------------------------------------------------------------+-- | Markdown test on a file+markdownTest :: H.Assertion+markdownTest = renderTest "markdown" markdownHtmlExpected+++------------------------------------------------------------------------------+jsonValueTest :: H.Assertion+jsonValueTest = do+    renderTest "json" jsonExpected1+    renderTest "json_snippet" jsonExpected2++  where+    jsonExpected1 = B.concat [ doctype+                             , "<i>&lt;b&gt;ok&lt;/b&gt;</i><i>1</i>"+                             , "<i></i><i>false</i><i>foo</i>" ]+    jsonExpected2 = B.concat+        [doctype, "<i><b>ok</b></i><i>1</i><i></i><i>false</i><i>foo</i>"]++++------------------------------------------------------------------------------+jsonObjectTest :: H.Assertion+jsonObjectTest = do+    renderTest "json_object" jsonExpected+  where+    jsonExpected = B.concat+        [ doctype+        , "<i>1</i><i><b>ok</b></i>12quuxquux1<b>ok</b>" ]+++------------------------------------------------------------------------------+-- | Render a template and assert that it matches an expected result+renderTest  :: ByteString   -- ^ template name+            -> ByteString   -- ^ expected result+            -> H.Assertion+renderTest templateName expectedResult = do+    ets <- loadT "templates" [] [] [] []+    let ts = either (error "Error loading templates") id ets++    check ts expectedResult++  where+    bind txt = bindJson v+      where+        v :: Value+        v = fromJust $ decode txt++    check ts0 str = do+        let ts = bindSplices [+                      ("json", bind "[\"<b>ok</b>\", 1, null, false, \"foo\"]")+                    , ("jsonObject",+                       bind $ mconcat [+                                 "{\"foo\": 1, \"bar\": \"<b>ok</b>\", "+                                , "\"baz\": { \"baz1\": 1, \"baz2\": 2 }, "+                                , "\"quux\": \"quux\" }"+                                ])+                    ] ts0+        Just (doc, _) <- renderTemplate ts templateName+        let result = B.filter (/= '\n') (toByteString doc)+        H.assertEqual ("Should match " ++ (show str)) str result+++------------------------------------------------------------------------------+-- | Expansion of a bound name inside a title-tag+titleExpansion :: H.Assertion+titleExpansion = renderTest "title_expansion" expected+  where+    expected = B.concat+        [ doctype+        , "<title>foo</title>"+        ]+++------------------------------------------------------------------------------+-- | Expansion of a bound name inside a textarea-tag+textareaExpansion :: H.Assertion+textareaExpansion = renderTest "textarea_expansion" expected+  where+    expected = B.concat+        [ "<textarea>foo</textarea>" ]+++------------------------------------------------------------------------------+-- | Expansion of a bound name inside a div-tag+divExpansion :: H.Assertion+divExpansion = renderTest "div_expansion" expected+  where+    expected = B.concat+        [ doctype+        , "<div>foo</div>"+        ]+++------------------------------------------------------------------------------+-- | Handling of <content> and bound parameters in a bound tag.+bindParam :: H.Assertion+bindParam = renderTest "bind_param" $+    B.concat [doctype, "<li>Hi there world</li>"]+++------------------------------------------------------------------------------+-- | Handling of <content> and bound parameters in a bound tag.+attrSpliceContext :: H.Assertion+attrSpliceContext = renderTest "attrsubtest2" $+    B.append doctype "<a href='asdf'>link</a><a href='before$after'>foo</a>"+++------------------------------------------------------------------------------+-- | Markdown test on supplied text+markdownTextTest :: H.Assertion+markdownTextTest = do+    hs <- loadEmpty [] [] [] []+    result <- evalHeistT markdownSplice+                         (X.TextNode "This *is* a test.")+                         hs+    H.assertEqual "Markdown text" markdownHtmlExpected +      (B.filter (/= '\n') $ toByteString $+        X.render (X.HtmlDocument X.UTF8 (Just dt) result))+  where+    dt = X.DocType "html" (X.Public "-//W3C//DTD XHTML 1.0 Strict//EN"+                                    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd")+                        X.NoInternalSubset+++------------------------------------------------------------------------------+applyTest :: H.Assertion+applyTest = do+    es <- loadEmpty [] [] [] []+    res <- evalHeistT applyImpl+        (X.Element "apply" [("template", "nonexistant")] []) es++    H.assertEqual "apply nothing" [] res+++------------------------------------------------------------------------------+ignoreTest :: H.Assertion+ignoreTest = do+    es <- loadEmpty [] [] [] []+    res <- evalHeistT ignoreImpl+        (X.Element "ignore" [("tag", "ignorable")] +          [X.TextNode "This should be ignored"]) es+    H.assertEqual "<ignore> tag" [] res+++lookupTemplateTest :: IO ()+lookupTemplateTest = do+    hs <- loadHS "templates"+    let k = do+            modifyHS (\st -> st { _curContext = ["foo"] })+            getsHS $ (\hs' -> lookupTemplate "/user/menu" hs' _templateMap)+    res <- runHeistT k (X.TextNode "") hs+    H.assertBool "lookup context test" $ isJust $ fst res+++------------------------------------------------------------------------------+identStartChar :: [Char]+identStartChar = ['a'..'z']+++------------------------------------------------------------------------------+identChar :: [Char]+identChar = '_' : identStartChar+++------------------------------------------------------------------------------+textGen :: Gen [Char]+textGen = listOf $ elements ((replicate 5 ' ') ++ identStartChar)+++------------------------------------------------------------------------------+limitedDepth :: Int -> Gen X.Node+limitedDepth 0 = liftM (X.TextNode . T.pack) textGen+limitedDepth n =+    oneof [ liftM (X.TextNode . T.pack) textGen+          , liftM3 X.Element arbitrary+                       (liftM (take 2) arbitrary)+                       (liftM (take 3) $ listOf $ limitedDepth (n - 1))+          ]+++------------------------------------------------------------------------------+-- | Returns the number of unique insertion points in the tree.+-- If h = insertAt f n g", the following property holds:+-- insSize h == (insSize f) + (insSize g) - 1+insSize :: [X.Node] -> Int+insSize ns = 1 + (sum $ map nodeSize ns)+  where nodeSize (X.Element _ _ c) = 1 + (insSize c)+        nodeSize _                 = 1+++------------------------------------------------------------------------------+insertAt :: [X.Node] -> Int -> [X.Node] -> [X.Node]+insertAt elems 0 ns = elems ++ ns+insertAt elems _ [] = elems+insertAt elems n list = maybe [] X.topNodes $+    evalState (processNode elems $ fromJust $ X.fromNodes list) n+++------------------------------------------------------------------------------+move :: Insert ()+move = modify (\x -> x - 1)+++------------------------------------------------------------------------------+processNode :: [X.Node] -> X.Cursor -> Insert (Maybe X.Cursor)+processNode elems loc =+    liftM2 mplus (move >> goDown loc) (move >> goRight loc)++  where+    goDown l =+        case X.current l of+          X.TextNode _    -> modify (+1) >> return Nothing+          X.Element _ _ _ -> doneCheck (X.insertManyFirstChild elems)+                                       X.firstChild+                                       l+          X.Comment _     -> return Nothing++    goRight = doneCheck (Just . X.insertManyRight elems) X.right++    doneCheck insertFunc next l = do+      s <- get+      if s == 0+        then return $ insertFunc l+        else maybe (return Nothing) (processNode elems) $ next l+++------------------------------------------------------------------------------+newtype Name = Name { unName :: Text } deriving (Show)++instance Arbitrary Name where+  arbitrary = do+    x     <- elements identStartChar+    n     <- choose (4,10)+    rest  <- vectorOf n $ elements identChar+    return $ Name $ T.pack (x:rest)++instance Arbitrary X.Node where+  arbitrary = limitedDepth 3+  shrink (X.Element _ [] []) = []+  shrink (X.Element n [] (_:cs)) = [X.Element n [] cs]+  shrink (X.Element n (_:as) []) = [X.Element n as []]+  shrink (X.Element n as cs) = [X.Element n as (tail cs), X.Element n (tail as) cs]+  shrink _ = []++instance Arbitrary T.Text where+  arbitrary = liftM unName arbitrary++--+-- Code for inserting nodes into any point of a tree+--+type Insert a = State Int a+++------------------------------------------------------------------------------+-- <bind> tests++-- Data type encapsulating the parameters for a bind operation+data Bind = Bind+    { _bindElemName :: Name+    , _bindChildren :: [X.Node]+    , _bindDoc :: [X.Node]+    , _bindPos :: Int+    , _bindRefPos :: Int+    } -- deriving (Show)+++instance Arbitrary Bind where+  arbitrary = do+    name <- arbitrary+    kids <- liftM (take 3) arbitrary+    doc <- liftM (take 5) arbitrary+    let s = insSize doc+    loc <- choose (0, s - 1)+    loc2 <- choose (0, s - loc - 1)+    return $ Bind name kids doc loc loc2+  shrink (Bind e [c] (_:ds) p r) = [Bind e [c] ds p r]+  shrink (Bind e (_:cs) d p r) = [Bind e cs d p r]+  shrink _ = []+++instance Show Bind where+  show b@(Bind e c d p r) = unlines+    [ "\n"+    , "Bind element name: " ++ (show e)+    , "Bind pos: " ++ (show p)+    , "Bind ref pos: " ++ (show r)+    , "Bind document:"+    , L.unpack $ L.concat $ map formatNode d+    , "Bind children:"+    , L.unpack $ L.concat $ map formatNode c+    , "Result:"+    , L.unpack $ L.concat $ map formatNode $ buildResult b+    , "Splice result:"+    , L.unpack $ L.concat $ map formatNode $ unsafePerformIO $ do+        hs <- loadEmpty [] [] [] []+        evalHeistT (runNodeList $ buildBindTemplate b)+                          (X.TextNode "") hs+    , "Template:"+    , L.unpack $ L.concat $ map formatNode $ buildBindTemplate b+    ]+    where+      formatNode n = toLazyByteString $ X.render+                                      $ X.HtmlDocument X.UTF8 Nothing [n]++------------------------------------------------------------------------------+buildNode :: Text -> Text -> Bind -> X.Node+buildNode tag attr (Bind s c _ _ _) = X.Element tag [(attr, unName s)] c+++------------------------------------------------------------------------------+buildBind :: Bind -> X.Node+buildBind = buildNode "bind" "tag"+++------------------------------------------------------------------------------+empty :: Text -> X.Node+empty n = X.Element n [] []+++------------------------------------------------------------------------------+buildBindTemplate :: Bind -> [X.Node]+buildBindTemplate s@(Bind n _ d b r) =+    insertAt [empty $ unName $ n] pos $ withBind+  where bind = [buildBind s]+        bindSize = insSize bind+        withBind = insertAt bind b d+        pos = b + bindSize - 1 + r+++------------------------------------------------------------------------------+buildResult :: Bind -> [X.Node]+buildResult (Bind _ c d b r) = insertAt c (b + r) d+++------------------------------------------------------------------------------+-- <apply> tests++data Apply = Apply+    { _applyName :: Name+    , _applyCaller :: [X.Node]+    , _applyCallee :: Template+    , _applyChildren :: [X.Node]+    , _applyPos :: Int+    } deriving (Show)+++instance Arbitrary Apply where+    arbitrary = do+      name <- arbitrary+      kids <- liftM (take 3) $ listOf $ limitedDepth 2+      caller <- liftM (take 5) arbitrary+      callee <- liftM (take 1) $ listOf $ limitedDepth 3+      let s = insSize caller+      loc <- choose (0, s - 1)+      return $ Apply name caller callee kids loc+++------------------------------------------------------------------------------+buildApplyCaller :: Apply -> [X.Node]+buildApplyCaller (Apply name caller _ kids pos) =+    insertAt [X.Element "apply" [("template", unName name)] kids] pos caller+++------------------------------------------------------------------------------+calcCorrect :: Apply -> [X.Node]+calcCorrect (Apply _ caller callee _ pos) = insertAt callee pos caller+++------------------------------------------------------------------------------+calcResult :: Apply -> IO [X.Node]+calcResult apply@(Apply name _ callee _ _) = do+    hs <- loadEmpty defaultLoadTimeSplices [] [] []+    let hs' = setTemplates (Map.singleton [T.encodeUtf8 $ unName name]+                           (DocumentFile (X.HtmlDocument X.UTF8 Nothing callee)+                                         Nothing)) hs+    evalHeistT (runNodeList $ buildApplyCaller apply)+        (X.TextNode "") hs'+++++{-+ - Convenience code for manual ghci experimentation+ -}++--html :: [Node] -> Node+--html c = X.Element "html" [] [hhead, body c]+--hhead :: Node+--hhead = X.Element "head" [] [title, X.Element "script" [] []]+--title :: Node+--title = X.Element "title" [] [X.Text "Test Page"]+--body :: [Node] -> Node+--body = X.Element "body" []+--+--para :: Int -> Node+--para n = X.Element "p" [] [X.Text $ B.pack $ "This is paragraph " ++ show n]+--para2 :: B.ByteString -> Node+--para2 c = X.Element "p" [] [X.Text c]+--para3 :: Node+--para3 = X.Element "p" [] [X.Text "AHA!"]+--+--foo :: Int -> [Node]+--foo n = insertAt [X.Element "NEW" [] []] n [html [para 1, para 2]]+--+--tdoc :: [Node]+--tdoc = [para 1, para 2, para 3, para 4]+--+--bindElem :: [Node] -> Int -> Int -> Bind+--bindElem = Bind (Name "mytag") [para2 "bound paragraph"]+--+--addBind :: Bind -> [Node] -> [Node]+--addBind b = insertAt [buildBind b] 0 . insertAt [empty $ unName $ _bindElemName b] 2+--+--prn :: Node -> IO ()+--prn = L.putStrLn . formatNode+--runTests :: IO ()+--runTests = defaultMain tests+

@@ -0,0 +1,108 @@+module Heist.TestCommon where++------------------------------------------------------------------------------+import           Blaze.ByteString.Builder+import           Control.Error+import           Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import qualified Data.HashMap.Strict as Map+import           Data.Maybe+import           Data.Text (Text)+++------------------------------------------------------------------------------+import           Heist+import qualified Heist.Compiled as C+import qualified Heist.Interpreted as I+import qualified Heist.Interpreted.Internal as I+import qualified Text.XmlHtml        as X+++------------------------------------------------------------------------------+-- | The default doctype given to templates+doctype :: ByteString+doctype = B.concat+    [ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "+    , "'http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd'>" ]+++loadT :: Monad m+      => FilePath+      -> [(Text, I.Splice m)]+      -> [(Text, I.Splice IO)]+      -> [(Text, C.Splice m)]+      -> [(Text, AttrSplice m)]+      -> IO (Either [String] (HeistState m))+loadT baseDir a b c d = runEitherT $ do+    ts <- loadTemplates baseDir+    let hc = HeistConfig a (defaultLoadTimeSplices ++ b) c d ts+    initHeist hc+++------------------------------------------------------------------------------+loadIO :: FilePath+       -> [(Text, I.Splice IO)]+       -> [(Text, I.Splice IO)]+       -> [(Text, C.Splice IO)]+       -> [(Text, AttrSplice IO)]+       -> IO (Either [String] (HeistState IO))+loadIO baseDir a b c d = runEitherT $ do+    ts <- loadTemplates baseDir+    let hc = HeistConfig a (defaultLoadTimeSplices ++ b) c d ts+    initHeist hc+++------------------------------------------------------------------------------+loadHS :: FilePath -> IO (HeistState IO)+loadHS baseDir = do+    etm <- runEitherT $ do+        templates <- loadTemplates baseDir+        let hc = HeistConfig [] defaultLoadTimeSplices [] [] templates+        initHeist hc+    either (error . concat) return etm+++loadEmpty :: [(Text, I.Splice IO)]+          -> [(Text, I.Splice IO)]+          -> [(Text, C.Splice IO)]+          -> [(Text, AttrSplice IO)]+          -> IO (HeistState IO)+loadEmpty a b c d = do+    let hc = HeistConfig a (defaultLoadTimeSplices ++ b) c d Map.empty+    res <- runEitherT $ initHeist hc+    either (error . concat) return res+++testTemplate :: FilePath -> ByteString -> IO ByteString+testTemplate tdir tname = do+    ts <- loadHS tdir+    Just (resDoc, _) <- I.renderTemplate ts tname+    return $ toByteString resDoc+++testTemplateEval :: ByteString -> IO (Maybe Template)+testTemplateEval tname = do+    ts <- loadHS "templates"+    md <- evalHeistT (I.evalWithDoctypes tname) (X.TextNode "") ts+    return $ fmap X.docContent md+++------------------------------------------------------------------------------+-- | Reloads the templates from disk and renders the specified+-- template.  (Old convenience code.)+quickRender :: FilePath -> ByteString -> IO (Maybe ByteString)+quickRender baseDir name = do+    ts  <- loadHS baseDir+    res <- I.renderTemplate ts name+    return (fmap (toByteString . fst) res)++cRender :: HeistState IO -> ByteString -> IO ByteString+cRender hs name = do+    builder <- fst $ fromJust $ C.renderTemplate hs name+    return $ toByteString builder++iRender :: HeistState IO -> ByteString -> IO ByteString+iRender hs name = do+    builder <- I.renderTemplate hs name+    return $ toByteString $ fst $ fromJust builder+

@@ -0,0 +1,200 @@+{-# LANGUAGE FlexibleContexts #-}+module Heist.Tests+  ( tests+  ) where+++------------------------------------------------------------------------------+import           Blaze.ByteString.Builder+import           Control.Monad.State+import qualified Data.ByteString.Char8 as B+import           Data.List+import           Data.Maybe+import           Data.Monoid+import qualified Data.Text as T+import           Test.Framework (Test)+import           Test.Framework.Providers.HUnit+import qualified Test.HUnit as H+++------------------------------------------------------------------------------+import           Heist+import qualified Heist.Compiled as C+import           Heist.Tutorial.AttributeSplices+import           Heist.Tutorial.CompiledSplices+import qualified Heist.Interpreted as I+import           Heist.Splices.Cache+import           Heist.Splices.Html+import           Heist.TemplateDirectory++import           Heist.TestCommon++tests :: [Test]+tests = [ testCase     "loadErrors"            loadErrorsTest+        , testCase     "attrsplice/autocheck"  attrSpliceTest+        , testCase     "tdirCache"             tdirCacheTest+        , testCase     "headMerge"             headMergeTest+        , testCase     "bindApplyInteraction"  bindApplyInteractionTest +        , testCase     "backslashHandling"     backslashHandlingTest +        ]+++------------------------------------------------------------------------------+-- | Tests that load fails correctly on errors.+loadErrorsTest :: H.Assertion+loadErrorsTest = do+    ets <- loadIO "templates-bad" [] [] [] []+    either (H.assertEqual "load errors test" expected . sort)+           (const $ H.assertFailure "No failure when loading templates-bad")+           ets+  where+    expected = sort+        ["templates-bad/bind-infinite-loop.tpl: template recursion exceeded max depth, you probably have infinite splice recursion!"+        ,"templates-bad/apply-template-not-found.tpl: apply tag cannot find template \"/page\""+        ,"templates-bad/bind-missing-attr.tpl: must supply \"tag\" attribute in <bind>"+        ,"templates-bad/apply-missing-attr.tpl: must supply \"template\" attribute in <apply>"+        ]+++attrSpliceTest :: IO ()+attrSpliceTest = do+    ehs <- loadT "templates" [] [] [] [("autocheck", autocheckedSplice)]+    let hs = either (error . show) id ehs+        runtime = fromJust $ C.renderTemplate hs "attr_splice"++    mres <- evalStateT (I.renderTemplate hs "attr_splice") "foo"+    H.assertEqual "interpreted foo" expected1+      (toByteString $ fst $ fromJust mres)+    mres2 <- evalStateT (I.renderTemplate hs "attr_splice") "bar"+    H.assertEqual "interpreted bar" expected2+      (toByteString $ fst $ fromJust mres2)++    builder <- evalStateT (fst runtime) "foo"+    H.assertEqual "compiled foo" expected3+      (toByteString builder)+    builder2 <- evalStateT (fst runtime) "bar"+    H.assertEqual "compiled bar" expected4+      (toByteString builder2)+  where+    expected1 = doctype `B.append` "\n<input type='checkbox' value='foo' checked />\n<input type='checkbox' value='bar' />\n"+    expected2 = doctype `B.append` "\n<input type='checkbox' value='foo' />\n<input type='checkbox' value='bar' checked />\n"+    expected3 = "<input type=\"checkbox\" value=\"foo\" checked />&#10;<input type=\"checkbox\" value=\"bar\" />&#10;"+    expected4 = "<input type=\"checkbox\" value=\"foo\" />&#10;<input type=\"checkbox\" value=\"bar\" checked />&#10;"++fooSplice :: I.Splice (StateT Int IO)+fooSplice = do+    val <- get+    put val+    I.textSplice $ T.pack $ show val++tdirCacheTest :: IO ()+tdirCacheTest = do+    let rSplices = [ ("foosplice", fooSplice) ]+        dSplices = [ ("foosplice", stateSplice) ]+        hc = HeistConfig rSplices [] dSplices [] mempty+    td <- newTemplateDirectory' "templates" hc+            +    [a,b,c,d] <- evalStateT (testInterpreted td) 5+    H.assertBool "interpreted doesn't cache" $ a == b+    H.assertBool "interpreted doesn't clear" $ b /= c+    H.assertBool "interpreted doesn't reload" $ c /= d++    td' <- newTemplateDirectory' "templates" hc+    [e,f,g,h] <- evalStateT (testCompiled td') 5+    H.assertBool "compiled doesn't cache" $ e == f+    H.assertBool "compiled doesn't clear" $ f /= g+    H.assertBool "compiled doesn't reload" $ g /= h+  where+    testInterpreted td = do+        hs <- liftIO $ getDirectoryHS td+        cts <- liftIO $ getDirectoryCTS td+        a <- I.renderTemplate hs "cache"+        modify (+1)+        b <- I.renderTemplate hs "cache"+        liftIO $ clearCacheTagState cts+        c <- I.renderTemplate hs "cache"+        modify (+1)+        _ <- liftIO $ reloadTemplateDirectory td++        -- The reload changes the HeistState, so we have to get it again+        hs' <- liftIO $ getDirectoryHS td+        d <- I.renderTemplate hs' "cache"+        return $ map (toByteString . fst . fromJust) [a,b,c,d]++    testCompiled td = do+        hs <- liftIO $ getDirectoryHS td+        cts <- liftIO $ getDirectoryCTS td+        a <- fst $ fromJust $ C.renderTemplate hs "cache"+        modify (+1)+        b <- fst $ fromJust $ C.renderTemplate hs "cache"+        liftIO $ clearCacheTagState cts+        c <- fst $ fromJust $ C.renderTemplate hs "cache"+        modify (+1)+        _ <- liftIO $ reloadTemplateDirectory td++        -- The reload changes the HeistState, so we have to get it again+        hs' <- liftIO $ getDirectoryHS td+        d <- fst $ fromJust $ C.renderTemplate hs' "cache"+        return $ map toByteString [a,b,c,d]+++headMergeTest :: IO ()+headMergeTest = do+    ehs <- loadT "templates" [] [(htmlTag, htmlImpl)] [] []+    let hs = either (error . show) id ehs+        runtime = fromJust $ C.renderTemplate hs "head_merge/index"+    mres <- fst runtime+    H.assertEqual "assertion failed" expected+      (toByteString mres)+  where+    expected = B.intercalate "\n"+      ["<html><head>\n<link href='wrapper-link' />\n"+      ,"<link href='nav-link' />\n\n<link href='index-link' />"+      ,"</head>\n\n<body>\n\n<div>nav bar</div>\n\n\n"+      ,"<div>index page</div>\n\n</body>\n</html>&#10;&#10;"+      ]++bindApplyInteractionTest :: IO ()+bindApplyInteractionTest = do+    hs <- loadHS "templates"++    cOut <- cRender hs "bind-apply-interaction/caller"+    H.assertEqual "compiled failure" cExpected cOut++    iOut <- iRender hs "bind-apply-interaction/caller"+    H.assertEqual "interpreted failure" iExpected iOut+  where+    cExpected = B.intercalate "\n"+      ["&#10;This is a test."+      ,"===bind content===&#10;Another test line."+      ,"apply content&#10;Last test line."+      ,"&#10;"+      ]+    iExpected = B.unlines+      [doctype+      ,"&#10;This is a test."+      ,"===bind content==="+      ,"Another test line."+      ,"apply content"+      ,"Last test line."+      ,""+      ]+++------------------------------------------------------------------------------+-- | Test backslash escaping in the attribute parser.+backslashHandlingTest :: IO ()+backslashHandlingTest = do+    hs <- loadHS "templates"+    cOut <- cRender hs "backslash"+    H.assertEqual "compiled failure" cExpected cOut++    iOut <- iRender hs "backslash"+    H.assertEqual "interpreted failure" iExpected iOut+  where+    cExpected = "<foo regex='d+\\d'></foo>&#10;"+    iExpected = B.unlines+      [doctype+      ,"<foo regex='d+\\d'></foo>"+      ]+

@@ -0,0 +1,58 @@+Attribute Splices+=================++Attribute splices are new in Heist 0.10.  They solve the problem of wanting to+be able to dynamically make empty attributes appear or disappear with a splice+without binding a splice to the whole tag.  This issue comes up most+frequently when dealing with empty attributes such as HTML's "disabled" or+"checked".++> module Heist.Tutorial.AttributeSplices where+> import           Heist.Tutorial.Imports++Consider a page with several radio buttons.  You want the correct one to be+selected based on the value of a parameter in the HTTP request.  The HTML+would look something like this:++    <input type="radio" name="color" value="red" checked>Red</input>+    <input type="radio" name="color" value="green">Green</input>+    <input type="radio" name="color" value="blue">Blue</input>++We want to automatically generate the "checked" attribute appropriately.  This+could be done with a splice bound to the input tag, but there might be a+number of other input tags on the page, so your splice would at best be+executed on more tags than necessary and at worst not have the granularity+necessary to work properly.  The ${} syntax for splices inside of attribute+values also won't work because it can only affect an attribute's value.  It+can't make the attribute disappear entirely.  This problem can be solved+nicely with attribute splices that have the following type:++< type AttrSplice m = Text -> m [(Text, Text)]++An attribute splice is a computation in the runtime monad that takes the value+of the attribute it is bound to as its argument and returns a list of+attributes to substitute back into the tag.  Here's how we might implement a+splice to solve the above problem.++> autocheckedSplice :: Text -> StateT Text IO [(Text, Text)]+> autocheckedSplice v = do+>     val <- get -- app-specific retrieval of the appropriate value here+>     let checked = if v == val+>                     then [("checked","")]+>                     else []+>     return $ ("value", v) : checked++In this toy example we are using `StateT Text IO` as our "runtime" monad where+the Text state holds the value of the radio button that should be checked.  We+assume that the current value we're checking against is passed as the bound+attribute's value, so we compare that against the value to be checked.  Then+we return a list with the appropriate value and the checked attribute if+necessary.  We bind this splice to the "autocheck" attribute by adding it to+the hcAttributeSplices list in HeistConfig.++To make everything work we use the following markup for our radio buttons:++    <input type="radio" name="color" autocheck="red">Red</input>+    <input type="radio" name="color" autocheck="green">Green</input>+    <input type="radio" name="color" autocheck="blue">Blue</input>+

@@ -0,0 +1,269 @@+Introduction to Compiled Heist+==============================++Before version 0.10, Heist has essentially been an interpreter.  It loads your+templates and "runs" them whenever a page is served.  This is relatively+inefficient since a lot of document transformations happen every time the+template is requested.  For Heist version 0.10 we completely rethought+everything with performance in mind.  We call it "compiled Heist".  The main+idea is to do most of your splice processing up front at load time.  There is+still a mechanism for rendering dynamic information at runtime, but it is+faster than the fully interpreted approach that Heist started with.++It should also be mentioned that the old "interpreted Heist" is not gone.  You+can still use the old approach where all the transformations happen at+render time.  This allows you to upgrade without making sweeping changes to+your code, and gradually convert your application to the more performant+compiled approach as you see fit.++Before we continue it should be mentioned that you are reading real live+literate Haskell code from our test suite.  All the code you see here is+compiled into our test suite and the results automatically checked by our+buildbot.  So first we need to get some boilerplate and imports out of the way.++> {-# LANGUAGE NoMonomorphismRestriction #-}+> module Heist.Tutorial.CompiledSplices where+> import           Heist+> import qualified Heist.Compiled as C+> import           Heist.Tutorial.Imports++As a review, normal (interpreted) Heist splices are defined like this.++< type Splice m = HeistT m m [Node]++The type parameter `m` is the runtime execution monad (in a Snap application+this will usually be `Handler` or `Snap`).  Don't worry about why the `m` is+there twice right now.  We'll get to that later.  The splice's return value is+a list of nodes that is substituted back into the document wherever the+spliced node was.  ++This kind of splice proccessing involves traversing the DOM, which is+inefficient.  Compiled Heist is designed so that all the DOM traversals happen+once at load time in the IO monad.  This is the "compile" phase.  The type+signature for compiled splices is this.++< type Splice n = HeistT n IO (DList (Chunk n))++We see that where Heist splices ran in the m monad, compiled splices run in the+IO monad.  This also explains why HeistT now has two monad type parameters.+The first parameter is a placeholder for the runtime monad and the second+parameter is the monad that we're actually running in now.++But the key point of the compiled splice type signature is the return value.+They return a DList of Chunks.  DList is a list that supports efficient+insertion to both the front and back of the list.  The Chunk type is not+exposed publicly, but there are three ways to construct a Chunk.++< yieldPure :: Builder -> DList (Chunk m)+< yieldRuntime :: RuntimeSplice m Builder -> DList (Chunk m)+< yieldRuntimeEffect :: Monad m => RuntimeSplice m () -> DList (Chunk m)++If your splice output can be calculated at load time, then you should use+`yieldPure` or one of its variants.  When you do this, Heist can concatenate+all adjacent pure chunks into a single precalculated ByteString that can be+rendered very efficiently.  If your template needs a value that has to be+calculated at runtime, then you should use the `yieldRuntime` constructor and+supply a computation in the RuntimeSplice monad transformer that is+parameterized by `m` which we saw above is the runtime monad.  Occasionally+you might want to run a runtime side effect that doesn't actually insert any+data into your template.  The `yieldRuntimeEffect` function gives you that+capability.++An Example+==========++With that background, let's get to a real example.++> stateSplice :: C.Splice (StateT Int IO)+> stateSplice = return $ C.yieldRuntimeText $ do+>     val <- lift get+>     return $ pack $ show (val+1)++Here we see that our splice's runtime monad is `StateT Int IO`.  This makes+for a simple example that can clearly demonstrate the different contexts that+we are operating in.  To make things more clear, here's a version with some+print statements that clarify the details of which monad is executed when.++> stateSplice2 :: C.Splice (StateT Int IO)+> stateSplice2 = do+>     -- :: C.Splice (StateT Int IO)+>     lift $ putStrLn "This executed at load time"+>     let res = C.yieldRuntimeText $ do+>             -- :: RuntimeSplice (StateT Int IO) a+>             lift $ lift $ putStrLn "This executed at run/render time"+>             val <- lift get+>             return $ pack $ show (val+1)+>     lift $ putStrLn "This also executed at load time"+>     return res++Note here that even though the type parameter to C.Splice is a monad, it is not+a monad transformer.  RuntimeSplice, however, is.  Now let's look at a simple+load function that sets up a default HeistState and loads templates from a+directory with compiled splices.++> load :: MonadIO n+>      => FilePath+>      -> [(Text, C.Splice n)]+>      -> IO (HeistState n)+> load baseDir splices = do+>     tmap <- runEitherT $ do+>         templates <- loadTemplates baseDir+>         let hc = HeistConfig [] defaultLoadTimeSplices splices [] templates+>         initHeist hc+>     either (error . concat) return tmap++Here's a function demonstrating all of this in action.++> runWithStateSplice :: FilePath+>                    -> IO ByteString+> runWithStateSplice baseDir = do+>     hs <- load baseDir [ ("div", stateSplice) ]+>     let runtime = fromJust $ C.renderTemplate hs "index"+>     builder <- evalStateT (fst runtime) 2+>     return $ toByteString builder++First this function loads the templates with the above compiled splice.  You+have to specify all the compiled splices in the call to loadTemplates because+loadTemplates takes care of compiling all the templates up front.  If you were+able to bind compiled splices later, then all the templates would have to be+recompiled, a potentially expensive operation.  Next, the function renders the+template called "index" using a runtime (StateT Int IO) seeded with a value of+2 and returns the resulting ByteString.++Now let's look at a more complicated example.  We want to render a data+structure with a compiled splice.++> data Person = Person+>     { pFirstName :: Text+>     , pLastName  :: Text+>     , 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)+>     ]+> +> peopleSplice :: (Monad n)+>              => n [Person]+>              -> C.Splice n+> peopleSplice getPeople = C.mapPromises personSplice getPeople+> +> allPeopleSplice :: C.Splice (StateT [Person] IO)+> allPeopleSplice = peopleSplice get+> +> personListTest :: FilePath+>                -> IO ByteString+> personListTest baseDir = do+>     hs <- load baseDir [ ("people", allPeopleSplice) ]+>     let runtime = fromJust $ C.renderTemplate hs "people"+>     builder <- evalStateT (fst runtime)+>                  [ Person "John" "Doe" 42+>                  , Person "Jane" "Smith" 21+>                  ]+>     return $ toByteString builder+++Disadvantages of Compiled Heist+===============================++Compiled Heist is faster than the original interpreted approach, but as with+most things in computing there is a tradeoff.  Compiled Heist is strictly less+powerful than interpreted Heist.  There are two things that compiled Heist+loses: the ability to bind new splices on the fly at runtime and splice+recursion/composability.++The first point follows immediately from the definition of compiled Heist.+When you decide to do all your splice DOM traversals once at load time you're+unavoidably limited to only those splices that you defined at load time.  But+this seems to be a good pattern to use in general because debugging your+splices will be easier if you don't have to consider the possibility that+the handler that binds them didn't run.++The loss of recursion/composability happens because of the change in the type+signature of splices.  Interpreted splices are a essentially function `[Node]+-> m [Node]`.  This means that the output of one splice can be the input of+another splice (including itself).  Compiled splices are a function `[Node] ->+IO (DList (Chunk m))`.  Therefore, once a splice processes some nodes, the+output is no longer something that can be passed into other splices.  ++This composability turns out to be a very powerful feature.  Head merging is+one feature that can't be done without it.  Head merging allows you to put+<head> tags anyhere in any template and have them all merged into a single+<head> tag at the top of your HTML document.  This is useful because it allows+you to keep concerns localized.  For instance, you can have a template+represent a small piece of functionality that uses a less common javascript or+CSS file.  Instead of having to depend on that resource being included in the+top-level <head> tag, you can include it in a <head> tag right where you're+using it.  Then it will only be included on your pages when you are using the+markup that needs it.++Our implementation of head merging uses a splice bound to the <html> tag.+This splice removes all the <head> nodes from its children, combines them, and+inserts them as its first child.  This won't work unless the <html> splice+first runs all its children to make sure all <apply> and <bind> tags have+happened first.  And that is impossible to do with compiled splices.++To get around this problem we added the concept of load time splices.  Load+time splices are just interpreted splices that are completely executed at load+time.  If interpreted splices have type `[Node] -> m [Node]` where m is the+runtime monad, then load time splices have type `[Node] -> IO [Node]`, where+IO is the monad being executed at load time.  Load time splices give you the+power and composability of interpreted splices as long as they are performing+transformations that don't require runtime data.  All of the built-in splices+that we ship with Heist work as load time splices.  So you can still have head+merging by including our html splice in the load time splice list in your+HeistConfig.+++A More Involved Example+=======================++The person example above is a very common and useful pattern for using dynamic+data in splices.  But it has the simplification that it always generates+output the same way.  Sometimes you might want a splice's output to have one+form in some cases and a different form in other cases.  A simple example is a+splice that reads some kind of a key from a request parameter then looks that+key up in some kind of map.  If the key is present the splice uses its child+nodes as a view for the retrieved value, otherwise it outputs an error message.  ++This pattern is a little tricky because you're making decisions about what to+render based on runtime data, but the actual rendering of child nodes has to+be done at load time.  To bridge the gap and allow communication between load+time and runtime processing we provide the Promise data type.  A Promise is+kind of like an IORef except that operations on them are restricted to the+appropriate Heist context.  You create a new empty promise in the HeistT n IO+(load time) monad, and you operate on it in the RuntimeSplice monad.++Here's an example of how to use a promise manually to render a splice+differently in the case of failure.++< failingSplice :: MonadSnap m => C.Splice m+< failingSplice = do+<     children <- childNodes <$> getParamNode+<     promise <- C.newEmptyPromise+<     outputChildren <- C.promiseChildrenWithNodes splices 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+<                 either (return . fromByteString . encodeUtf8 . T.pack)+<                        doUser euser+<               where+<                 doUser value = do+<                   C.putPromise promise (name, value)+<                   outputChildren+<         maybe err single mname+<   +<   +< splices :: [(Text, (Text, Text) -> [Node])]+< splices = [ ("user", (:[]) . TextNode . T.pack . fst)+<           , ("value", (:[]) . TextNode . T.pack . snd)+<           ]                                                                                                                                             +

@@ -0,0 +1,25 @@+module Heist.Tutorial.Imports+  ( module Blaze.ByteString.Builder+  , module Control.Monad+  , module Control.Monad.Trans+  , module Data.Maybe+  , module Data.Monoid+  , ST.get+  , ST.StateT(..)+  , ST.evalStateT+  , T.Text+  , T.pack+  , ByteString+  , runEitherT+  ) where++import           Blaze.ByteString.Builder+import           Control.Error (runEitherT)+import           Control.Monad+import           Control.Monad.Trans+import qualified Control.Monad.Trans.State as ST+import           Data.ByteString.Char8 (ByteString)+import           Data.Maybe+import           Data.Monoid+import qualified Data.Text as T+

@@ -2,10 +2,16 @@  import Test.Framework (defaultMain, testGroup) -import qualified Text.Templating.Heist.Tests+import qualified Heist.Interpreted.Tests+import qualified Heist.Compiled.Tests+import qualified Heist.Tests+ main :: IO () main = defaultMain tests-  where tests = [-                  testGroup "Text.Templating.Heist.Tests"-                            Text.Templating.Heist.Tests.tests+  where tests = [ testGroup "Heist.Interpreted.Tests"+                            Heist.Interpreted.Tests.tests+                , testGroup "Heist.Compiled.Tests"+                            Heist.Compiled.Tests.tests+                , testGroup "Heist.Tests"+                            Heist.Tests.tests                 ]

@@ -1,692 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction  #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# OPTIONS_GHC -fno-warn-orphans       #-}--module Text.Templating.Heist.Tests-  ( tests-  , quickRender-  ) where---------------------------------------------------------------------------------import           Blaze.ByteString.Builder-import           Control.Monad.State-import           Data.Aeson-import           Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.HashMap.Strict as Map-import           Data.Maybe-import           Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import           Data.Text (Text)-import           System.IO.Unsafe-import           Test.Framework (Test)-import           Test.Framework.Providers.HUnit-import           Test.Framework.Providers.QuickCheck2-import qualified Test.HUnit as H-import           Test.QuickCheck-import           Test.QuickCheck.Monadic----------------------------------------------------------------------------------import           Text.Templating.Heist-import           Text.Templating.Heist.Internal-import           Text.Templating.Heist.Types-import           Text.Templating.Heist.Splices.Apply-import           Text.Templating.Heist.Splices.Ignore-import           Text.Templating.Heist.Splices.Json-import           Text.Templating.Heist.Splices.Markdown-import qualified Text.XmlHtml        as X-import qualified Text.XmlHtml.Cursor as X----------------------------------------------------------------------------------tests :: [Test]-tests = [ testProperty "heist/simpleBind"            simpleBindTest-        , testProperty "heist/simpleApply"           simpleApplyTest-        , testCase     "heist/stateMonoid"           monoidTest-        , testCase     "heist/templateAdd"           addTest-        , testCase     "heist/hasTemplate"           hasTemplateTest-        , testCase     "heist/getDoc"                getDocTest-        , testCase     "heist/load"                  loadTest-        , testCase     "heist/fsLoad"                fsLoadTest-        , testCase     "heist/renderNoName"          renderNoNameTest-        , testCase     "heist/doctype"               doctypeTest-        , testCase     "heist/attributeSubstitution" attrSubstTest-        , testCase     "heist/bindAttribute"         bindAttrTest-        , testCase     "heist/markdown"              markdownTest-        , testCase     "heist/title_expansion"       titleExpansion-        , testCase     "heist/textarea_expansion"    textareaExpansion-        , testCase     "heist/div_expansion"         divExpansion-        , testCase     "heist/bind_param"            bindParam-        , testCase     "heist/markdownText"          markdownTextTest-        , testCase     "heist/apply"                 applyTest-        , testCase     "heist/ignore"                ignoreTest-        , testCase     "heist/lookupTemplateContext" lookupTemplateTest-        , testCase     "heist/attrSpliceContext"     attrSpliceContext-        , testCase     "heist/json/values"           jsonValueTest-        , testCase     "heist/json/object"           jsonObjectTest-        ]----------------------------------------------------------------------------------simpleBindTest :: Property-simpleBindTest = monadicIO $ forAllM arbitrary prop-  where-    prop :: Bind -> PropertyM IO ()-    prop bind = do-        let template = buildBindTemplate bind-        let result   = buildResult bind--        spliceResult <- run $ evalHeistT (runNodeList template)-                                         (X.TextNode "")-                                         defaultHeistState-        assert $ result == spliceResult----------------------------------------------------------------------------------simpleApplyTest :: Property-simpleApplyTest = monadicIO $ forAllM arbitrary prop-  where-    prop :: Apply -> PropertyM IO ()-    prop apply = do-        let correct = calcCorrect apply-        result <- run $ calcResult apply-        assert $ correct == result----------------------------------------------------------------------------------monoidTest :: IO ()-monoidTest = do-    H.assertBool "left monoid identity" $ mempty `mappend` es == es-    H.assertBool "right monoid identity" $ es `mappend` mempty == es-  where es = defaultHeistState :: HeistState IO----------------------------------------------------------------------------------addTest :: IO ()-addTest = do-    H.assertEqual "lookup test" (Just []) $-        fmap (X.docContent . dfDoc . fst) $ lookupTemplate "aoeu" ts--    H.assertEqual "splice touched" 0 $ Map.size (_spliceMap ts)--  where-    ts = addTemplate "aoeu" [] Nothing (mempty::HeistState IO)----------------------------------------------------------------------------------hasTemplateTest :: H.Assertion-hasTemplateTest = do-    ets <- loadT "templates"-    let tm = either (error "Error loading templates") _templateMap ets-    let ts = setTemplates tm defaultHeistState :: HeistState IO-    H.assertBool "hasTemplate ts" (hasTemplate "index" ts)----------------------------------------------------------------------------------getDocTest :: H.Assertion-getDocTest = do-    d <- getDoc "bkteoar"-    H.assertBool "non-existent doc" $ isLeft d-    f <- getDoc "templates/index.tpl"-    H.assertBool "index doc" $ not $ isLeft f----------------------------------------------------------------------------------loadTest :: H.Assertion-loadTest = do-    ets <- loadT "templates"-    either (error "Error loading templates")-           (\ts -> do let tm = _templateMap ts-                      H.assertBool "loadTest size" $ Map.size tm == 26-           ) ets----------------------------------------------------------------------------------fsLoadTest :: H.Assertion-fsLoadTest = do-    ets <- loadT "templates"-    let tm = either (error "Error loading templates") _templateMap ets-    let ts = setTemplates tm defaultHeistState :: HeistState IO-    let f  = g ts--    f isNothing "abc/def/xyz"-    f isJust "a"-    f isJust "bar/a"-    f isJust "/bar/a"--  where-    g ts p n = H.assertBool ("loading template " ++ n) $ p $-               lookupTemplate (B.pack n) ts---------------------------------------------------------------------------------renderNoNameTest :: H.Assertion-renderNoNameTest = do-    ets <- loadT "templates"-    either (error "Error loading templates")-           (\ts -> do t <- renderTemplate ts ""-                      H.assertBool "renderNoName" $ isNothing t-           ) ets----------------------------------------------------------------------------------doctypeTest :: H.Assertion-doctypeTest = do-    ets <- loadT "templates"-    let ts = either (error "Error loading templates") id ets-    Just (indexDoc, indexMIME) <- renderTemplate ts "index"-    H.assertBool "doctype test index" $ isJust $ X.docType $-        fromRight $ (X.parseHTML "index") $ toByteString $ indexDoc-    Just (iocDoc, iocMIME) <- renderTemplate ts "ioc"-    H.assertBool "doctype test ioc" $ isJust $ X.docType $-        fromRight $ (X.parseHTML "index") $ toByteString $ iocDoc-  where fromRight (Right x) = x-        fromRight (Left  s) = error s---------------------------------------------------------------------------------attrSubstTest :: H.Assertion-attrSubstTest = do-    ets <- loadT "templates"-    let ts = either (error "Error loading templates") id ets-    check (setTs "meaning_of_everything" ts) "pre_meaning_of_everything_post"-    check ts "pre__post"--  where-    setTs val = bindSplice "foo" (return [X.TextNode val])-    check ts str = do-        Just (resDoc, resMIME) <- renderTemplate ts "attrs"-        H.assertBool ("attr subst " ++ (show str)) $ not $ B.null $-            snd $ B.breakSubstring str $ toByteString $ resDoc-        H.assertBool ("attr subst foo") $ not $ B.null $-            snd $ B.breakSubstring "${foo}" $ toByteString $ resDoc----------------------------------------------------------------------------------bindAttrTest :: H.Assertion-bindAttrTest = do-    ets <- loadT "templates"-    let ts = either (error "Error loading templates") id ets-    check ts "<div id=\'zzzzz\'"--  where-    check ts str = do-        Just (resDoc, resMIME) <- renderTemplate ts "bind-attrs"-        H.assertBool ("attr subst " ++ (show str)) $ not $ B.null $-            snd $ B.breakSubstring str $ toByteString $ resDoc-        H.assertBool ("attr subst bar") $ B.null $-            snd $ B.breakSubstring "${bar}" $ toByteString $ resDoc----------------------------------------------------------------------------------htmlExpected :: ByteString-htmlExpected = "<div class=\'markdown\'><p>This <em>is</em> a test.</p></div>"------------------------------------------------------------------------------------ | Markdown test on a file-markdownTest :: H.Assertion-markdownTest = renderTest "markdown" htmlExpected----------------------------------------------------------------------------------jsonValueTest :: H.Assertion-jsonValueTest = do-    renderTest "json" jsonExpected1-    renderTest "json_snippet" jsonExpected2--  where-    jsonExpected1 = B.concat [ "<i>&lt;b&gt;ok&lt;/b&gt;</i><i>1</i>"-                             , "<i></i><i>false</i><i>foo</i>" ]-    jsonExpected2 = "<i><b>ok</b></i><i>1</i><i></i><i>false</i><i>foo</i>"----------------------------------------------------------------------------------jsonObjectTest :: H.Assertion-jsonObjectTest = do-    renderTest "json_object" jsonExpected-  where-    jsonExpected = B.concat [ "<i>1</i><i><b>ok</b></i>12quuxquux1<b>ok</b>" ]------------------------------------------------------------------------------------ | Render a template and assert that it matches an expected result-renderTest  :: ByteString   -- ^ template name-            -> ByteString   -- ^ expected result-            -> H.Assertion-renderTest templateName expectedResult = do-    ets <- loadT "templates"-    let ts = either (error "Error loading templates") id ets--    check ts expectedResult--  where-    bind txt = bindJson v-      where-        v :: Value-        v = fromJust $ decode txt--    check ts0 str = do-        let ts = bindSplices [-                      ("json", bind "[\"<b>ok</b>\", 1, null, false, \"foo\"]")-                    , ("jsonObject",-                       bind $ mconcat [-                                 "{\"foo\": 1, \"bar\": \"<b>ok</b>\", "-                                , "\"baz\": { \"baz1\": 1, \"baz2\": 2 }, "-                                , "\"quux\": \"quux\" }"-                                ])-                    ] ts0-        Just (doc, _) <- renderTemplate ts templateName-        let result = B.filter (/= '\n') (toByteString doc)-        H.assertEqual ("Should match " ++ (show str)) str result------------------------------------------------------------------------------------ | Expansion of a bound name inside a title-tag-titleExpansion :: H.Assertion-titleExpansion = renderTest "title_expansion" "<title>foo</title>"------------------------------------------------------------------------------------ | Expansion of a bound name inside a textarea-tag-textareaExpansion :: H.Assertion-textareaExpansion = renderTest "textarea_expansion" "<textarea>foo</textarea>"------------------------------------------------------------------------------------ | Expansion of a bound name inside a div-tag-divExpansion :: H.Assertion-divExpansion = renderTest "div_expansion" "<div>foo</div>"------------------------------------------------------------------------------------ | Handling of <content> and bound parameters in a bound tag.-bindParam :: H.Assertion-bindParam = renderTest "bind_param" "<li>Hi there world</li>"------------------------------------------------------------------------------------ | Handling of <content> and bound parameters in a bound tag.-attrSpliceContext :: H.Assertion-attrSpliceContext = renderTest "attrsubtest2" "<a href='asdf'>link</a><a href='before$after'>foo</a>"------------------------------------------------------------------------------------ | Markdown test on supplied text-markdownTextTest :: H.Assertion-markdownTextTest = do-    result <- evalHeistT markdownSplice-                         (X.TextNode "This *is* a test.")-                         defaultHeistState-    H.assertEqual "Markdown text" htmlExpected -      (B.filter (/= '\n') $ toByteString $-        X.render (X.HtmlDocument X.UTF8 Nothing result))----------------------------------------------------------------------------------applyTest :: H.Assertion-applyTest = do-    let es = defaultHeistState :: HeistState IO-    res <- evalHeistT applyImpl-        (X.Element "apply" [("template", "nonexistant")] []) es--    H.assertEqual "apply nothing" [] res----------------------------------------------------------------------------------ignoreTest :: H.Assertion-ignoreTest = do-    let es = defaultHeistState :: HeistState IO-    res <- evalHeistT ignoreImpl-        (X.Element "ignore" [("tag", "ignorable")] -          [X.TextNode "This should be ignored"]) es-    H.assertEqual "<ignore> tag" [] res-----localTSTest :: H.Assertion---localTSTest = do---    let es = defaultHeistState :: HeistState IO--lookupTemplateTest = do-    ts <- loadTS "templates"-    let k = do-            setContext ["foo"]-            getsTS $ lookupTemplate "/user/menu"-    res <- runHeistT k (X.TextNode "") ts-    H.assertBool "lookup context test" $ isJust $ fst res------------------------------------------------------------------------------------ Utility functions--isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft (Right _) = False----------------------------------------------------------------------------------loadT :: String -> IO (Either String (HeistState IO))-loadT s = loadTemplates s defaultHeistState----------------------------------------------------------------------------------loadTS :: FilePath -> IO (HeistState IO)-loadTS baseDir = do-    etm <- loadTemplates baseDir defaultHeistState-    return $ either error id etm---testTemplate tname = do-    ts <- loadTS "templates"-    Just (resDoc, _) <- renderTemplate ts tname-    return $ toByteString resDoc---testTemplateEval tname = do-    ts <- loadTS "templates"-    evalHeistT (evalWithHooks tname) (X.TextNode "") ts----------------------------------------------------------------------------------identStartChar :: [Char]-identStartChar = ['a'..'z']----------------------------------------------------------------------------------identChar :: [Char]-identChar = '_' : identStartChar----------------------------------------------------------------------------------textGen :: Gen [Char]-textGen = listOf $ elements ((replicate 5 ' ') ++ identStartChar)----------------------------------------------------------------------------------limitedDepth :: Int -> Gen X.Node-limitedDepth 0 = liftM (X.TextNode . T.pack) textGen-limitedDepth n =-    oneof [ liftM (X.TextNode . T.pack) textGen-          , liftM3 X.Element arbitrary-                       (liftM (take 2) arbitrary)-                       (liftM (take 3) $ listOf $ limitedDepth (n - 1))-          ]------------------------------------------------------------------------------------ | Returns the number of unique insertion points in the tree.--- If h = insertAt f n g", the following property holds:--- insSize h == (insSize f) + (insSize g) - 1-insSize :: [X.Node] -> Int-insSize ns = 1 + (sum $ map nodeSize ns)-  where nodeSize (X.TextNode _)    = 1-        nodeSize (X.Element _ _ c) = 1 + (insSize c)----------------------------------------------------------------------------------insertAt :: [X.Node] -> Int -> [X.Node] -> [X.Node]-insertAt elems 0 ns = elems ++ ns-insertAt elems _ [] = elems-insertAt elems n list = maybe [] X.topNodes $-    evalState (processNode elems $ fromJust $ X.fromNodes list) n----------------------------------------------------------------------------------move :: Insert ()-move = modify (\x -> x - 1)----------------------------------------------------------------------------------processNode :: [X.Node] -> X.Cursor -> Insert (Maybe X.Cursor)-processNode elems loc =-    liftM2 mplus (move >> goDown loc) (move >> goRight loc)--  where-    goDown l =-        case X.current l of-          X.TextNode _    -> modify (+1) >> return Nothing-          X.Element _ _ _ -> doneCheck (X.insertManyFirstChild elems)-                                       X.firstChild-                                       l--    goRight = doneCheck (Just . X.insertManyRight elems) X.right--    doneCheck insertFunc next l = do-      s <- get-      if s == 0-        then return $ insertFunc l-        else maybe (return Nothing) (processNode elems) $ next l------------------------------------------------------------------------------------ | Reloads the templates from disk and renders the specified--- template.  (Old convenience code.)-quickRender :: FilePath -> ByteString -> IO (Maybe ByteString)-quickRender baseDir name = do-    ts  <- loadTS baseDir-    res <- renderTemplate ts name-    return (fmap (toByteString . fst) res)----------------------------------------------------------------------------------newtype Name = Name { unName :: Text } deriving (Show)--instance Arbitrary Name where-  arbitrary = do-    x     <- elements identStartChar-    n     <- choose (4,10)-    rest  <- vectorOf n $ elements identChar-    return $ Name $ T.pack (x:rest)--instance Arbitrary X.Node where-  arbitrary = limitedDepth 3-  shrink (X.TextNode _) = []-  shrink (X.Element _ [] []) = []-  shrink (X.Element n [] (_:cs)) = [X.Element n [] cs]-  shrink (X.Element n (_:as) []) = [X.Element n as []]-  shrink (X.Element n as cs) = [X.Element n as (tail cs), X.Element n (tail as) cs]--instance Arbitrary T.Text where-  arbitrary = liftM unName arbitrary------- Code for inserting nodes into any point of a tree----type Insert a = State Int a------------------------------------------------------------------------------------ <bind> tests---- Data type encapsulating the parameters for a bind operation-data Bind = Bind-    { _bindElemName :: Name-    , _bindChildren :: [X.Node]-    , _bindDoc :: [X.Node]-    , _bindPos :: Int-    , _bindRefPos :: Int-    } -- deriving (Show)---instance Arbitrary Bind where-  arbitrary = do-    name <- arbitrary-    kids <- liftM (take 3) arbitrary-    doc <- liftM (take 5) arbitrary-    let s = insSize doc-    loc <- choose (0, s - 1)-    loc2 <- choose (0, s - loc - 1)-    return $ Bind name kids doc loc loc2-  shrink (Bind e [c] (_:ds) p r) = [Bind e [c] ds p r]-  shrink (Bind e (_:cs) d p r) = [Bind e cs d p r]-  shrink _ = []---instance Show Bind where-  show b@(Bind e c d p r) = unlines-    [ "\n"-    , "Bind element name: " ++ (show e)-    , "Bind pos: " ++ (show p)-    , "Bind ref pos: " ++ (show r)-    , "Bind document:"-    , L.unpack $ L.concat $ map formatNode d-    , "Bind children:"-    , L.unpack $ L.concat $ map formatNode c-    , "Result:"-    , L.unpack $ L.concat $ map formatNode $ buildResult b-    , "Splice result:"-    , L.unpack $ L.concat $ map formatNode $ unsafePerformIO $-        evalHeistT (runNodeList $ buildBindTemplate b)-                          (X.TextNode "") defaultHeistState-    , "Template:"-    , L.unpack $ L.concat $ map formatNode $ buildBindTemplate b-    ]-    where-      formatNode n = toLazyByteString $ X.render-                                      $ X.HtmlDocument X.UTF8 Nothing [n]---------------------------------------------------------------------------------buildNode :: Text -> Text -> Bind -> X.Node-buildNode tag attr (Bind s c _ _ _) = X.Element tag [(attr, unName s)] c----------------------------------------------------------------------------------buildBind :: Bind -> X.Node-buildBind = buildNode "bind" "tag"----------------------------------------------------------------------------------empty :: Text -> X.Node-empty n = X.Element n [] []----------------------------------------------------------------------------------buildBindTemplate :: Bind -> [X.Node]-buildBindTemplate s@(Bind n _ d b r) =-    insertAt [empty $ unName $ n] pos $ withBind-  where bind = [buildBind s]-        bindSize = insSize bind-        withBind = insertAt bind b d-        pos = b + bindSize - 1 + r----------------------------------------------------------------------------------buildResult :: Bind -> [X.Node]-buildResult (Bind _ c d b r) = insertAt c (b + r) d------------------------------------------------------------------------------------ <apply> tests--data Apply = Apply-    { _applyName :: Name-    , _applyCaller :: [X.Node]-    , _applyCallee :: Template-    , _applyChildren :: [X.Node]-    , _applyPos :: Int-    } deriving (Show)---instance Arbitrary Apply where-    arbitrary = do-      name <- arbitrary-      kids <- liftM (take 3) $ listOf $ limitedDepth 2-      caller <- liftM (take 5) arbitrary-      callee <- liftM (take 1) $ listOf $ limitedDepth 3-      let s = insSize caller-      loc <- choose (0, s - 1)-      return $ Apply name caller callee kids loc----------------------------------------------------------------------------------buildApplyCaller :: Apply -> [X.Node]-buildApplyCaller (Apply name caller _ kids pos) =-    insertAt [X.Element "apply" [("template", unName name)] kids] pos caller----------------------------------------------------------------------------------calcCorrect :: Apply -> [X.Node]-calcCorrect (Apply _ caller callee _ pos) = insertAt callee pos caller----------------------------------------------------------------------------------calcResult :: (MonadIO m) => Apply -> m [X.Node]-calcResult apply@(Apply name _ callee _ _) =-    evalHeistT (runNodeList $ buildApplyCaller apply)-        (X.TextNode "") ts--  where ts = setTemplates (Map.singleton [T.encodeUtf8 $ unName name]-                          (DocumentFile (X.HtmlDocument X.UTF8 Nothing callee)-                                        Nothing))-                          defaultHeistState----{---- The beginning of some future tests for hook functions.--p :: ByteString -> Node-p t = X.Element "p" [] [X.Text t]--hookG :: Monad m => ByteString -> Template -> m Template-hookG str t = return $ (p str) : t--onLoad = hookG "Inserted on load"-preRun = hookG "Inserted on preRun"-postRun = hookG "Inserted on postRun"--ts :: IO (Either String (HeistState IO))-ts = loadTemplates "test/templates" $-    foldr ($) (defaultHeistState ".")-    [setOnLoadHook onLoad-    ,setPreRunHook preRun-    ,setPostRunHook postRun-    ]--r name etm = do-    let ts = either (error "Danger Will Robinson!") id etm-    ns <- runNodeList ts name-    return $ (Just . formatList') =<< ns--}---{-- - Convenience code for manual ghci experimentation- -}----html :: [Node] -> Node---html c = X.Element "html" [] [hhead, body c]---hhead :: Node---hhead = X.Element "head" [] [title, X.Element "script" [] []]---title :: Node---title = X.Element "title" [] [X.Text "Test Page"]---body :: [Node] -> Node---body = X.Element "body" []------para :: Int -> Node---para n = X.Element "p" [] [X.Text $ B.pack $ "This is paragraph " ++ show n]---para2 :: B.ByteString -> Node---para2 c = X.Element "p" [] [X.Text c]---para3 :: Node---para3 = X.Element "p" [] [X.Text "AHA!"]------foo :: Int -> [Node]---foo n = insertAt [X.Element "NEW" [] []] n [html [para 1, para 2]]------tdoc :: [Node]---tdoc = [para 1, para 2, para 3, para 4]------bindElem :: [Node] -> Int -> Int -> Bind---bindElem = Bind (Name "mytag") [para2 "bound paragraph"]------addBind :: Bind -> [Node] -> [Node]---addBind b = insertAt [buildBind b] 0 . insertAt [empty $ unName $ _bindElemName b] 2------prn :: Node -> IO ()---prn = L.putStrLn . formatNode---runTests :: IO ()---runTests = defaultMain tests-