packages feed

heist 0.8.2 → 1.1.1.2

raw patch · 95 files changed

Files

.ghci view
@@ -1,5 +1,7 @@ :set -XOverloadedStrings+:set -XCPP :set -Wall :set -isrc :set -itest/suite :set -hide-package MonadCatchIO-mtl+:set -hide-package monads-tf
+ CHANGELOG.md view
@@ -0,0 +1,63 @@+# 1.1.1.2++* Support GHC 9.8+* Fix broken test++# 1.1.1.1++* Support GHC 9.6++# 1.1.1.0++* Expose `lookupTemplate` and `splitTemplatePath`++* Bump dependency bounds for 9.4++# 1.1++* Remove pandoc and pandocBS++* Stop exporting readProcessWithExitCode'++* Remove -S and --no-wrap arguments to pandoc for compatibility with both 1.x+  and 2.x versions of the pandoc command line tool++* Bump map-syntax lower bound to fix 8.4 build problem++# 1.0.1.3++* Add Semigroup instances to support GHC 8.4++# 1.0.1.0++* Change benchmark from an executable section to a benchmark section in the+  cabal file.  This eliminates the criterion dependency when doing "cabal+  install heist".+* Export manyWith++# 1.0.0.1++* Drop the dependency on `errors` packages from heist testsuite and benchmark+* Fix nested splice namespace warning bug (issue #85)++# 1.0.0.0++* Switch from MonadCatchIO-transformers to monad-control for Snap 1.0++# 0.14.0++See http://snapframework.com/blog/2014/09/24/heist-0.14-released++* Add namespace support (hcNamespace and hcErrorNotBound)+* Add tellSpliceError for generalized error reporting+* Restructured HeistConfig, export lenses instead of field accessors+* Moved old HeistConfig into SpliceConfig+* Factored SpliceAPI module out into separate map-syntax package++# 0.13.0++See http://snapframework.com/blog/2013/09/09/snap-0.13-released++* Simpler compiled splice API+* New splice syntax+
README.md view
@@ -1,5 +1,7 @@ # Heist +[![GitHub CI](https://github.com/snapframework/heist/workflows/CI/badge.svg)](https://github.com/snapframework/heist/actions)+ Heist, part of the [Snap Framework](http://www.snapframework.com/), is a Haskell library for xml/html templating. It uses simple XML tags to bind values to your templates in a straightforward way. For example, if you were to@@ -15,7 +17,7 @@ Likewise, if you need to add text to an attribute,      <bind tag="special">special-id</bind>-    <div id="$(special)">very special</div>+    <div id="${special}">very special</div>  gives you
heist.cabal view
@@ -1,16 +1,48 @@+cabal-version:  2.2 name:           heist-version:        0.8.2-synopsis:       An (x)html templating system-description:    An (x)html templating system-license:        BSD3+version:        1.1.1.2+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:        BSD-3-Clause license-file:   LICENSE author:         Doug Beardsley, Gregory Collins maintainer:     snap@snapframework.com build-type:     Simple-cabal-version:  >= 1.6 homepage:       http://snapframework.com/ category:       Web, Snap +tested-with:+  GHC == 8.8.4+  GHC == 8.10.7+  GHC == 9.0.2+  GHC == 9.2.8+  GHC == 9.4.7+  GHC == 9.6.3+  GHC == 9.8.1++extra-doc-files:+  CHANGELOG.md+ extra-source-files:   .ghci,   CONTRIBUTORS,@@ -32,98 +64,254 @@   LICENSE,   README.md,   README.SNAP.md,-  test/.ghci,-  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/backslash.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_array.tpl   test/templates/json_object.tpl,   test/templates/json_snippet.tpl,   test/templates/markdown.tpl,-  test/templates/noroot.tpl,+  test/templates/namespaces.tpl   test/templates/page.tpl,+  test/templates/pandoc.tpl+  test/templates/pandocdiv.tpl+  test/templates/people.tpl,+  test/templates/post.tpl,   test/templates/readme.txt,+  test/templates/rss.xtpl   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,+  test/templates-defer/test.tpl,+  test/templates-loaderror/_error.tpl,+  test/templates-loaderror/_ok.tpl,+  test/templates-loaderror/test.tpl,+  test/templates-nsbind/nsbind.tpl,+  test/templates-nsbind/nsbinderror.tpl,+  test/templates-ns-nested/test.tpl,+  test/templates-nscall/_call.tpl,+  test/templates-nscall/_invalid.tpl,+  test/templates-nscall/nscall.tpl,   TODO +common universal+  default-language: Haskell2010 +  default-extensions:+    DeriveDataTypeable+    FlexibleInstances+    GeneralizedNewtypeDeriving+    MultiParamTypeClasses+    OverloadedStrings+    PackageImports+    ScopedTypeVariables+    TypeSynonymInstances++  build-depends:+    , base >= 4.5 && < 5++  if !impl(ghc >= 8.0)+    build-depends:+      semigroups >= 0.16 && < 0.19,+ Library+  import: universal   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.Compiled.LowLevel,+    Heist.Internal.Types,+    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.Internal.Types.HeistState,+    Heist.Interpreted.Internal    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,+    aeson                      >= 0.6     && < 2.3,+    attoparsec                 >= 0.10    && < 0.15,+    blaze-builder              >= 0.2     && < 0.5,+    blaze-html                 >= 0.4     && < 0.10,+    bytestring                 >= 0.9     && < 0.13,+    containers                 >= 0.2     && < 1.0,+    directory                  >= 1.1     && < 1.4,+    directory-tree             >= 0.10    && < 0.13,+    dlist                      >= 0.5     && < 1.1,+    filepath                   >= 1.3     && < 1.5,+    hashable                   >= 1.1     && < 1.5,+    lifted-base                >= 0.2     && < 0.3,+    map-syntax                 >= 0.3     && < 0.4,+    monad-control              >= 0.3     && < 1.1,+    mtl                        >= 2.0     && < 2.4,+    process                    >= 1.1     && < 1.7,+    random                     >= 1.0.1.0 && < 1.3,+    text                       >= 0.10    && < 2.2,+    time                       >= 1.1     && < 1.13,+    transformers               >= 0.3     && < 0.7,+    transformers-base          >= 0.4     && < 0.5,+    unordered-containers       >= 0.1.4   && < 0.3,+    vector                     >= 0.9     && < 0.14,+    xmlhtml                    >= 0.2.3.5 && < 0.4,+    indexed-traversable        >= 0.1.1   && < 0.2++  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields++  default-extensions:+    UndecidableInstances,+    NoMonomorphismRestriction+++source-repository head+  type:     git+  location: https://github.com/snapframework/heist.git++Test-suite testsuite+  import: universal+  hs-source-dirs: src test/suite+  type: exitcode-stdio-1.0+  main-is: TestSuite.hs++  build-depends:+    HUnit                      >= 1.2      && < 2,+    QuickCheck                 >= 2        && < 2.15,+    lens                       >= 4.3      && < 5.3,+    test-framework             >= 0.4      && < 0.9,+    test-framework-hunit       >= 0.2.7    && < 0.4,+    test-framework-quickcheck2 >= 0.2.12.1 && < 0.4,+    aeson,+    attoparsec,+    bifunctors >= 5.3 && < 5.7,+    blaze-builder,+    blaze-html,     bytestring,+    containers,     directory,     directory-tree,+    dlist,     filepath,-    MonadCatchIO-transformers >= 0.2.1 && < 0.4,-    mtl                       >= 2.0   && < 2.2,+    hashable,+    lifted-base,+    map-syntax,+    monad-control,+    mtl,     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+    text,+    time,+    transformers,+    transformers-base,+    unordered-containers,+    vector,+    xmlhtml,+    indexed-traversable -  if impl(ghc >= 6.12.0)-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-unused-do-bind-  else-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+  if impl(ghc >= 7.8) && impl(ghc < 7.10)+    build-depends: transformers-compat >= 0.3 && < 0.7 -  ghc-prof-options:    -prof -auto-all+  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded -  Extensions:-    GeneralizedNewtypeDeriving,-    PackageImports,-    ScopedTypeVariables,-    DeriveDataTypeable,-    FlexibleInstances,-    MultiParamTypeClasses,-    UndecidableInstances,-    OverloadedStrings,-    TypeSynonymInstances,-    NoMonomorphismRestriction+Benchmark benchmark+  import: universal+  hs-source-dirs: src test/suite+  type: exitcode-stdio-1.0+  main-is: Benchmark.hs +  build-depends:+    HUnit,+    criterion                 >= 1.0,+    criterion-measurement     >= 0.1,+    test-framework,+    test-framework-hunit, -source-repository head-  type:     git-  location: http://git.snapframework.com/heist.git+    -- Copied from regular dependencies:++    aeson,+    attoparsec,+    blaze-builder,+    blaze-html,+    bytestring,+    containers,+    directory,+    directory-tree,+    dlist,+    filepath,+    hashable,+    lifted-base,+    map-syntax,+    monad-control,+    mtl,+    process,+    random,+    statistics                 >= 0.11,+    text,+    time,+    transformers,+    transformers-base,+    unordered-containers,+    vector,+    xmlhtml,+    indexed-traversable++  if impl(ghc >= 7.8) && impl(ghc < 7.10)+    build-depends: transformers-compat++  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded+               -fno-warn-unused-do-bind -rtsopts++  default-extensions:+    UndecidableInstances,+    NoMonomorphismRestriction
+ src/Data/HeterogeneousEnvironment.hs view
@@ -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
+ src/Heist.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++{-|++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+  , reloadTemplates+  , addTemplatePathPrefix+  , initHeist+  , initHeistWithCacheTag+  , defaultInterpretedSplices+  , defaultLoadTimeSplices+  , emptyHeistConfig++  -- * Core Heist data types+  , SpliceConfig+  , HeistConfig+  , TemplateRepo+  , TemplateLocation+  , Template+  , TPath+  , MIMEType+  , DocumentFile(..)+  , AttrSplice+  , RuntimeSplice+  , Chunk+  , HeistState+  , SpliceError(..)+  , CompileException(..)+  , HeistT++  -- * Lenses (can be used with lens or lens-family)+  , scInterpretedSplices+  , scLoadTimeSplices+  , scCompiledSplices+  , scAttributeSplices+  , scTemplateLocations+  , scCompiledTemplateFilter+  , hcSpliceConfig+  , hcNamespace+  , hcErrorNotBound+  , hcInterpretedSplices+  , hcLoadTimeSplices+  , hcCompiledSplices+  , hcAttributeSplices+  , hcTemplateLocations+  , hcCompiledTemplateFilter++  -- * HeistT functions+  , templateNames+  , compiledTemplateNames+  , hasTemplate+  , spliceNames+  , compiledSpliceNames+  , evalHeistT+  , getParamNode+  , getContext+  , getTemplateFilePath+  , localParamNode+  , getsHS+  , getHS+  , putHS+  , modifyHS+  , restoreHS+  , localHS+  , getDoc+  , getXMLDoc+  , tellSpliceError+  , spliceErrorText+  , orError+  , Splices++  -- * TPath functions+  , lookupTemplate+  , splitTemplatePath+  ) where+++------------------------------------------------------------------------------+import           Control.Exception.Lifted+import           Control.Monad.State+import           Data.ByteString               (ByteString)+import qualified Data.ByteString.Char8         as BC+import qualified Data.ByteString               as B+import           Data.Either+import qualified Data.Foldable                 as F+import           Data.HashMap.Strict           (HashMap)+import qualified Data.HashMap.Strict           as Map+import qualified Data.HeterogeneousEnvironment as HE+import           Data.Map.Syntax+#if !MIN_VERSION_base(4,11,0)+import           Data.Monoid+#endif+import           Data.Text                     (Text)+import qualified Data.Text                     as T+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.Internal.Types+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | The built-in set of splices that you should use in compiled splice mode.+-- This list includes everything from 'defaultInterpretedSplices' plus a+-- splice for the content tag that errors out when it sees any instance of the+-- old content tag, which has now been moved to two separate tags called+-- apply-content and bind-content.+defaultLoadTimeSplices :: MonadIO m => Splices (I.Splice m)+defaultLoadTimeSplices = do+    -- To be removed in later versions+    defaultInterpretedSplices+    "content" #! deprecatedContentCheck++++------------------------------------------------------------------------------+-- | 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 scLoadTimeSplices list in your SpliceConfig.+-- If you are using interpreted splice mode, then you might also want to bind+-- the 'deprecatedContentCheck' splice to the content tag as a load time+-- splice.+defaultInterpretedSplices :: MonadIO m => Splices (I.Splice m)+defaultInterpretedSplices = do+    applyTag ## applyImpl+    bindTag ## bindImpl+    ignoreTag ## ignoreImpl+    markdownTag ## markdownSplice++++------------------------------------------------------------------------------+-- | An empty HeistConfig that uses the \"h\" namespace with error checking+-- turned on.+emptyHeistConfig :: HeistConfig m+emptyHeistConfig = HeistConfig mempty "h" True+++allErrors :: [Either String (TPath, v)]+          -> Either [String] (HashMap TPath v)+allErrors tlist =+    case errs of+        [] -> Right $ Map.fromList $ rights tlist+        _  -> Left errs+  where+    errs = lefts tlist+++------------------------------------------------------------------------------+-- | Loads templates from disk.  This function returns just a template map so+-- you can load multiple directories and combine the maps before initializing+-- your HeistState.+loadTemplates :: FilePath -> IO (Either [String] TemplateRepo)+loadTemplates dir = do+    d <- readDirectoryWith (loadTemplate dir) dir+#if MIN_VERSION_directory_tree(0,11,0)+    return $ allErrors $ F.fold (dirTree d)+#else+    return $ allErrors $ F.fold (free d)+#endif+++------------------------------------------------------------------------------+-- | Reloads all the templates an an existing TemplateRepo.+reloadTemplates :: TemplateRepo -> IO (Either [String] TemplateRepo)+reloadTemplates repo = do+    tlist <- mapM loadOrKeep $ Map.toList repo+    return $ allErrors tlist+  where+    loadOrKeep (p,df) =+      case dfFile df of+        Nothing -> return $ Right (p, df)+        Just fp -> do+          df' <- loadTemplate' fp+          return $ fmap (p,) $ case df' of+            [t] -> t+            _ -> Left "Template repo has non-templates"+++------------------------------------------------------------------------------+-- | Adds a path prefix to a templates in a map returned by loadTemplates.  If+-- you want to add multiple levels of directories, separate them with slashes+-- as in "foo/bar".  Using an empty string as a path prefix will leave the+-- map unchanged.+addTemplatePathPrefix :: ByteString -> TemplateRepo -> TemplateRepo+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+++------------------------------------------------------------------------------+-- | Creates an empty HeistState.+emptyHS :: HE.KeyGen -> HeistState m+emptyHS kg = HeistState Map.empty Map.empty Map.empty Map.empty Map.empty+                        True [] [] 0 [] Nothing kg False Html "" [] False 0+++------------------------------------------------------------------------------+-- | 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+          -> IO (Either [String] (HeistState n))+initHeist hc = do+    keyGen <- HE.newKeyGen+    repos <- sequence $ _scTemplateLocations $ _hcSpliceConfig hc+    case sequence repos of+      Left es -> return $ Left es+      Right rs -> initHeist' keyGen hc (Map.unions rs)+++------------------------------------------------------------------------------+mkSplicePrefix :: Text -> Text+mkSplicePrefix ns+  | T.null ns = ""+  | otherwise = ns `mappend` ":"+++------------------------------------------------------------------------------+initHeist' :: Monad n+           => HE.KeyGen+           -> HeistConfig n+           -> TemplateRepo+           -> IO (Either [String] (HeistState n))+initHeist' keyGen (HeistConfig sc ns enn) repo = do+    let empty = emptyHS keyGen+    let (SpliceConfig i lt c a _ f) = sc+    etmap <- preproc keyGen lt repo ns+    let prefix = mkSplicePrefix ns+    let eis = runHashMap $ mapK (prefix<>) i+        ecs = runHashMap $ mapK (prefix<>) c+        eas = runHashMap $ mapK (prefix<>) a+    let hs1 = do+          tmap <- etmap+          is <- eis+          cs <- ecs+          as <- eas+          return $ empty { _spliceMap = is+                         , _templateMap = tmap+                         , _compiledSpliceMap = cs+                         , _attrSpliceMap = as+                         , _splicePrefix = prefix+                         , _errorNotBound = enn+                         }+    either (return . Left) (C.compileTemplates f) hs1+++------------------------------------------------------------------------------+-- | Runs preprocess on a TemplateRepo and returns the modified templates.+preproc :: HE.KeyGen+        -> Splices (I.Splice IO)+        -> TemplateRepo+        -> Text+        -> IO (Either [String] TemplateRepo)+preproc keyGen splices templates ns = do+    let esm = runHashMap splices+    case esm of+      Left errs -> return $ Left errs+      Right sm -> do+        let hs = (emptyHS keyGen) { _spliceMap = sm+                                  , _templateMap = templates+                                  , _preprocessingMode = True+                                  , _splicePrefix = mkSplicePrefix ns }+        let eval a = evalHeistT a (X.TextNode "") hs+        tPairs <- mapM (eval . preprocess) $ Map.toList templates+        let bad = lefts tPairs+        return $ if not (null bad)+                   then Left bad+                   else Right $ Map.fromList $ rights tPairs+++------------------------------------------------------------------------------+-- | Processes a single template, running load time splices.+preprocess :: (TPath, DocumentFile)+           -> HeistT IO IO (Either String (TPath, DocumentFile))+preprocess (tpath, docFile) = do+    let tname = tpathName tpath+        die   = error $ "Preprocess failed because the template `"+                     ++ BC.unpack tname+                     ++ "` was not found in the template repository."+    !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+++------------------------------------------------------------------------------+-- | 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+-- 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+                      -> IO (Either [String] (HeistState n, CacheTagState))+initHeistWithCacheTag (HeistConfig sc ns enn) = do+    (ss, cts) <- liftIO mkCacheTag+    let tag = "cache"+    keyGen <- HE.newKeyGen++    erepos <- sequence $ _scTemplateLocations sc+    case sequence erepos of+      Left es -> return $ Left es+      Right repos -> do+        -- We have to do one preprocessing pass with the cache setup splice.  This+        -- has to happen for both interpreted and compiled templates, so we do it+        -- here by itself because interpreted templates don't get the same load+        -- time splices as compiled templates.+        eRawWithCache <- preproc keyGen (tag ## ss) (Map.unions repos) ns+        case eRawWithCache of+          Left es -> return $ Left es+          Right rawWithCache -> do+            let sc' = SpliceConfig (tag #! cacheImpl cts) mempty+                                   (tag #! cacheImplCompiled cts)+                                   mempty mempty (const True)+            let hc = HeistConfig (mappend sc sc') ns enn+            hs <- initHeist' keyGen hc rawWithCache+            return $ fmap (,cts) hs
+ src/Heist/Common.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Heist.Common where++------------------------------------------------------------------------------+import           Control.Applicative      (Alternative (..))+import           Control.Exception        (SomeException)+import qualified Control.Exception.Lifted as C+import           Control.Monad            (liftM, mplus)+import qualified Data.Attoparsec.Text     as AP+import           Data.ByteString          (ByteString)+import qualified Data.ByteString          as B+import qualified Data.ByteString.Char8    as BC+import           Data.Hashable            (Hashable)+import           Data.HashMap.Strict      (HashMap)+import qualified Data.HashMap.Strict      as Map+import           Data.List                (isSuffixOf, sort)+import           Data.Map.Syntax+import           Data.Maybe               (isJust)+import           Data.Monoid              ((<>))+import           Data.Text                (Text)+import qualified Data.Text                as T+import           Heist.Internal.Types.HeistState+import           System.FilePath          (pathSeparator)+import qualified Text.XmlHtml             as X+#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative      (Applicative (..), (<$>))+import           Data.Monoid              (Monoid (..))+#endif+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+runHashMap+    :: Splices s+    -> Either [String] (HashMap T.Text s)+runHashMap ms =+    case runMapSyntax Map.lookup Map.insert ms of+      Left keys -> Left $ map (T.unpack . mkMsg) keys+      Right hm -> Right hm+  where+    mkMsg k = "You tried to bind "<>k<>" more than once!"+++------------------------------------------------------------------------------+runMapNoErrors :: (Eq k, Hashable k) => MapSyntaxM k v a -> HashMap k v+runMapNoErrors = either (const mempty) id .+    runMapSyntax' (\_ new _ -> Just new) Map.lookup Map.insert++applySpliceMap :: HeistState n+                -> (HeistState n -> HashMap Text v)+                -> MapSyntaxM Text v a+                -> HashMap Text v+applySpliceMap hs f =  (flip Map.union (f hs)) .+    runMapNoErrors .+    mapK (mappend pre)+  where+    pre = _splicePrefix hs++------------------------------------------------------------------------------+-- | 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 do fullMsg <- heistErrMsg (T.pack msg)+              error $ T.unpack fullMsg+      else silent+++------------------------------------------------------------------------------+-- | Prepends the location of the template currently being processed to an+-- error message.+heistErrMsg :: Monad m => Text -> HeistT n m Text+heistErrMsg msg = do+    tf <- getsHS _curTemplateFile+    return $ (maybe "" ((`mappend` ": ") . T.pack) tf) `mappend` msg+++------------------------------------------------------------------------------+-- | Adds an error message to the list of splice processing errors.+tellSpliceError :: Monad m => Text -> HeistT n m ()+tellSpliceError msg = do+    hs <- getHS+    node <- getParamNode+    let spliceError = SpliceError+                      { spliceHistory = _splicePath hs+                      , spliceTemplateFile = _curTemplateFile hs+                      , visibleSplices = sort $ Map.keys $ _compiledSpliceMap hs+                      , contextNode = node+                      , spliceMsg = msg+                      }+    modifyHS (\hs' -> hs { _spliceErrors = spliceError : _spliceErrors hs' })+++------------------------------------------------------------------------------+-- | Function for showing a TPath.+showTPath :: TPath -> String+showTPath = BC.unpack . (`BC.append` ".tpl") . tpathName+++------------------------------------------------------------------------------+-- | Convert a TPath into a ByteString path.+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+                            idp <- identParser+                            dl' <- finish subDL+                            loop $! append dl' idp)++    gobbleText = AP.takeWhile1 (AP.notInClass "$")++    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+                   []   -> ("", [])+                   x:xs -> (x, xs)+    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 = do+    c <- loadTemplate' fname+    return $ map (fmap (\t -> (splitLocalPath $ BC.pack tName, t))) c+  where -- tName is path relative to the template root directory+    isHTMLTemplate = ".tpl"  `isSuffixOf` fname+    correction = if last templateRoot == '/' then 0 else 1+    extLen     = if isHTMLTemplate then 4 else 5+    tName = drop ((length templateRoot)+correction) $+            -- We're only dropping the template root, not the whole path+            take ((length fname) - extLen) fname+++------------------------------------------------------------------------------+-- | Loads a template at the specified path, choosing the appropriate parser+-- based on the file extension.  The template is only loaded if it has a+-- \".tpl\" or \".xtpl\" extension.  Returns an empty list if the extension+-- doesn't match.+loadTemplate' :: String -> IO [Either String DocumentFile]+loadTemplate' fullDiskPath+    | isHTMLTemplate = liftM (:[]) $ getDoc fullDiskPath+    | isXMLTemplate = liftM (:[]) $ getXMLDoc fullDiskPath+    | otherwise = return []+  where+    isHTMLTemplate = ".tpl"  `isSuffixOf` fullDiskPath+    isXMLTemplate  = ".xtpl" `isSuffixOf` fullDiskPath+++------------------------------------------------------------------------------+-- | 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 <- C.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"+    enc X.ISO_8859_1 = "iso-8859-1"+++------------------------------------------------------------------------------+-- | Binds a set of new splice declarations within a 'HeistState'.+bindAttributeSplices :: Splices (AttrSplice n) -- ^ splices to bind+                     -> HeistState n           -- ^ start state+                     -> HeistState n+bindAttributeSplices ss hs =+    hs { _attrSpliceMap = applySpliceMap hs _attrSpliceMap ss }++------------------------------------------------------------------------------+-- | 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 })++
+ src/Heist/Compiled.hs view
@@ -0,0 +1,66 @@+{-|++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+  , codeGen+  , runChildren++  -- * Functions for manipulating lists of compiled splices+  , textSplice+  , nodeSplice+  , xmlNodeSplice+  , htmlNodeSplice+  , pureSplice++  , deferMany+  , defer+  , deferMap+  , mayDeferMap+  , bindLater+  , withSplices+  , manyWithSplices+  , manyWith+  , withLocalSplices++  -- * Constructing Chunks+  -- $yieldOverview+  , yieldPure+  , yieldRuntime+  , yieldRuntimeEffect+  , yieldPureText+  , yieldRuntimeText++  -- * Running nodes and splices+  , runNodeList+  , runNode+  , runAttributes+  , runAttributesRaw+  , callTemplate++  ) 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 level construction of DLists of Chunks.+--+-- Most of the time you will use these functions composed with return to+-- generate a Splice.  But we decided not to include the return in these+-- functions to allow you to work with the DLists purely.
+ src/Heist/Compiled/Internal.hs view
@@ -0,0 +1,805 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeSynonymInstances       #-}++module Heist.Compiled.Internal where+++------------------------------------------------------------------------------+import           Blaze.ByteString.Builder+import           Blaze.ByteString.Builder.Char.Utf8+import           Control.Arrow+import           Control.Exception+import           Control.Monad+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.HashSet                       as S+import qualified Data.HeterogeneousEnvironment      as HE+import           Data.Map.Syntax+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.Printf+import qualified Text.XmlHtml                       as X+import qualified Text.XmlHtml.HTML.Meta             as X+------------------------------------------------------------------------------+#if !MIN_VERSION_base(4,8,0)+import           Data.Foldable                      (Foldable)+#endif+import qualified Data.Foldable                      as Foldable+------------------------------------------------------------------------------+import           Heist.Common+import           Heist.Internal.Types.HeistState+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | 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 us 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))+++------------------------------------------------------------------------------+-- | Runs the parameter node's children and returns the resulting compiled+-- chunks.  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+{-# INLINE runChildren #-}+++renderFragment :: Markup -> [X.Node] -> Builder+renderFragment markup ns =+    case markup of+      Html -> X.renderHtmlFragment X.UTF8 ns+      Xml  -> X.renderXmlFragment X.UTF8 ns+++------------------------------------------------------------------------------+-- | Yields pure text known at load time.+pureTextChunk :: Text -> Chunk n+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 n)+yieldPure = DL.singleton . Pure . toByteString+{-# INLINE yieldPure #-}+++------------------------------------------------------------------------------+-- | Yields a runtime action that returns a builder.+yieldRuntime :: RuntimeSplice n Builder -> DList (Chunk n)+yieldRuntime = DL.singleton . RuntimeHtml+{-# INLINE yieldRuntime #-}+++------------------------------------------------------------------------------+-- | Yields a runtime action that returns no value and is only needed for its+-- side effect.+yieldRuntimeEffect :: Monad n => RuntimeSplice n () -> DList (Chunk n)+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 n)+yieldPureText = DL.singleton . pureTextChunk+{-# INLINE yieldPureText #-}+++------------------------------------------------------------------------------+-- | Convenience wrapper around yieldRuntime allowing you to work with Text.+yieldRuntimeText :: Monad n => RuntimeSplice n Text -> DList (Chunk n)+yieldRuntimeText = yieldRuntime .  liftM fromText+{-# INLINE yieldRuntimeText #-}+++------------------------------------------------------------------------------+-- | 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 DocumentFile with the appropriate template context set.+runDocumentFile :: Monad n+                => TPath+                -> DocumentFile+                -> Splice n+runDocumentFile tpath df = do+    let markup = case dfDoc df of+                   X.XmlDocument _ _ _ -> Xml+                   X.HtmlDocument _ _ _ -> Html+    modifyHS (\hs -> hs { _curMarkup = markup })+    let inDoctype = X.docType $ dfDoc df+    addDoctype $ maybeToList inDoctype+    modifyHS (setCurTemplateFile curPath .  setCurContext tpath)+    res <- runNodeList nodes+    dt <- getsHS (listToMaybe . _doctypes)+    let enc = X.docEncoding $ dfDoc df+    return $! (yieldPure (X.renderDocType enc dt) `mappend` res)+  where+    curPath     = dfFile df+    nodes       = X.docContent $! dfDoc df+++------------------------------------------------------------------------------+compileTemplate+    :: Monad n+    => TPath+    -> DocumentFile+    -> HeistT n IO [Chunk n]+compileTemplate tpath df = do+    !chunks <- runDocumentFile tpath df+    return $! consolidate chunks+++------------------------------------------------------------------------------+compileTemplates+    :: Monad n+    => (TPath -> Bool)+    -> HeistState n+    -> IO (Either [String] (HeistState n))+compileTemplates f hs = do+    (tmap, hs') <- runHeistT (compileTemplates' f) (X.TextNode "") hs+    let pre = _splicePrefix hs'+    let canError = _errorNotBound hs'+    let errs = _spliceErrors hs'+    let nsErr = if not (T.null pre) && (_numNamespacedTags hs' == 0)+                  then Left [noNamespaceSplicesMsg $ T.unpack pre]+                  else Right ()+    return $ if canError+               then case errs of+                     [] -> nsErr >>+                           (Right $! hs { _compiledTemplateMap = tmap })+                     es -> Left $ either (++) (const id) nsErr $+                           map (T.unpack . spliceErrorText) es+               else nsErr >> (Right $! hs { _compiledTemplateMap = tmap+                                          , _spliceErrors = errs+                                          })+++------------------------------------------------------------------------------+noNamespaceSplicesMsg :: String -> String+noNamespaceSplicesMsg pre = unwords+    [ printf "You are using a namespace of '%s', but you don't have any" ns+    , printf "tags starting with '%s'.  If you have not defined any" pre+    , "splices, then change your namespace to the empty string to get rid"+    , "of this message."+    ]+  where+    ns = reverse $ drop 1 $ reverse pre+++------------------------------------------------------------------------------+compileTemplates'+    :: Monad n+    => (TPath -> Bool)+    -> HeistT n IO (H.HashMap TPath ([Chunk n], MIMEType))+compileTemplates' f = do+    hs <- getHS+    let tpathDocfiles :: [(TPath, DocumentFile)]+        tpathDocfiles = filter (f . fst)+                            (H.toList $ _templateMap hs)+    foldM runOne H.empty tpathDocfiles+  where+    runOne tmap (tpath, df) = do+        modifyHS (\hs -> hs { _doctypes = []})+        !mHtml <- compileTemplate tpath df+        return $! H.insert tpath (mHtml, mimeType $! dfDoc df) tmap+++------------------------------------------------------------------------------+-- | Consolidate consecutive Pure Chunks.+consolidate :: (Monad n) => DList (Chunk n) -> [Chunk n]+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, codeGen turns consecutive runs of+-- @Pure Html@ values into maximally-efficient pre-rendered strict+-- 'ByteString' chunks.+codeGen :: Monad n => DList (Chunk n) -> RuntimeSplice n Builder+codeGen l = V.foldr mappend mempty $!+            V.map toAct $! V.fromList $! consolidate 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 = do+    pre <- getsHS _splicePrefix+    res <- getsHS (H.lookup nm . _compiledSpliceMap)+    if isNothing res && T.isPrefixOf pre nm && not (T.null pre)+      then do+          tellSpliceError $ "No splice bound for " `mappend` nm+          return Nothing+      else return res+++------------------------------------------------------------------------------+-- | Runs a single node.  If there is no splice referenced anywhere in the+-- subtree, then it is rendered as a pure chunk, otherwise it calls+-- compileNode to generate the appropriate runtime computation.+runNode :: Monad n => X.Node -> Splice n+runNode node = localParamNode (const node) $ do+    hs <- getHS+    let pre = _splicePrefix hs+    let hasPrefix = (T.isPrefixOf pre `fmap` X.tagName node) == Just True+    when (not (T.null pre) && hasPrefix) incNamespacedTags+    hs' <- getHS+    -- Plain rethrows for CompileException to avoid multiple annotations.+    (res, hs'') <- liftIO $ catches (compileIO hs')+                     [ Handler (\(ex :: CompileException) -> throwIO ex)+                     , Handler (\(ex :: SomeException) -> handleError ex hs')]+    putHS hs''+    return res+  where+    localSplicePath =+        localHS (\hs -> hs {_splicePath = (_curContext hs,+                                           _curTemplateFile hs,+                                           X.elementTag node):+                                          (_splicePath hs)})+    compileIO hs = runHeistT compile node hs+    compile = do+        isStatic <- subtreeIsStatic node+        dl <- compile' isStatic+        liftIO $ evaluate $ DL.fromList $! consolidate dl+    compile' True = do+        markup <- getsHS _curMarkup+        return $! yieldPure $! renderFragment markup [parseAttrs node]+    compile' False = localSplicePath $ compileNode node+    handleError ex hs = do+        errs <- evalHeistT (do localSplicePath $ tellSpliceError $ T.pack $+                                 "Exception in splice compile: " ++ show ex+                               getsHS _spliceErrors) node hs+        throwIO $ CompileException ex errs+++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 (Ident i) = T.concat ["${", i, "}"]++------------------------------------------------------------------------------+-- | 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 _ ) -> []+++------------------------------------------------------------------------------+-- | Given a 'X.Node' in the DOM tree, produces a \"runtime splice\" that will+-- generate html at runtime.+compileNode :: Monad n => X.Node -> Splice n+compileNode (X.Element nm attrs ch) = do+    msplice <- lookupSplice nm+    fromMaybe compileStaticElement msplice+  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 <- runAttributes attrs++        childHtml <- runNodeList ch++        return $! if null (DL.toList childHtml) && nm `S.member` X.voidTags+          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"+++------------------------------------------------------------------------------+-- |+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 (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 $ do+        res <- splice v+        return $ mconcat $ map attrToBuilder res+++------------------------------------------------------------------------------+-- |+parseAtt2 :: Monad n+          => (Text, Text)+          -> HeistT n IO (RuntimeSplice n [(Text, Text)])+parseAtt2 (k,v) = do+    mas <- getsHS (H.lookup k . _attrSpliceMap)+    maybe doInline (return . doAttrSplice) mas++  where+    cvt (Literal x) = return $ return x+    cvt (Ident x) =+        localParamNode (const $ X.Element x [] []) $ getAttributeSplice2 x++    -- Handles inline parsing of $() splice syntax in attributes+    doInline = do+        let ast = case AP.feed (AP.parse attParser v) "" of+                    (AP.Done _ res) -> res+                    (AP.Fail _ _ _) -> []+                    (AP.Partial _ ) -> []+        chunks <- mapM cvt ast+        return $ do+            list <- sequence chunks+            return [(k, T.concat list)]++    -- Handles attribute splices+    doAttrSplice splice = splice v+++------------------------------------------------------------------------------+-- | Performs splice processing on a list of attributes.  This is useful in+-- situations where you need to stop recursion, but still run splice+-- processing on the node's attributes.+runAttributes :: Monad n+              => [(Text, Text)] -- ^ List of attributes+              -> HeistT n IO [DList (Chunk n)]+runAttributes = mapM parseAtt+++------------------------------------------------------------------------------+-- | Performs splice processing on a list of attributes.  This is useful in+-- situations where you need to stop recursion, but still run splice+-- processing on the node's attributes.+runAttributesRaw :: Monad n+                 -- Note that this parameter should not be changed to Splices+                 => [(Text, Text)] -- ^ List of attributes+                 -> HeistT n IO (RuntimeSplice n [(Text, Text)])+runAttributesRaw attrs = do+    arrs <- mapM parseAtt2 attrs+    return $ liftM concat $ sequence arrs+++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+    [ fromText " "+    , fromText k+    ]+  | otherwise = mconcat+    [ fromText " "+    , fromText k+    , fromText "=\""+    , fromText v+    , fromText "\""+    ]+++------------------------------------------------------------------------------+getAttributeSplice :: Text -> HeistT n IO (DList (Chunk n))+getAttributeSplice name =+    lookupSplice name >>= fromMaybe+      (return $ DL.singleton $ Pure $ T.encodeUtf8 $+       T.concat ["${", name, "}"])+{-# INLINE getAttributeSplice #-}+++getAttributeSplice2 :: Monad n => Text -> HeistT n IO (RuntimeSplice n Text)+getAttributeSplice2 name = do+    mSplice <- lookupSplice name+    case mSplice of+      Nothing -> return $ return $ T.concat ["${", name, "}"]+      Just splice -> do+        res <- splice+        return $ liftM (T.decodeUtf8 . toByteString) $ codeGen res+{-# INLINE getAttributeSplice2 #-}+++------------------------------------------------------------------------------+-- | Promises are used for referencing the results of future runtime+-- computations during load time splice processing.+newtype Promise a = Promise (HE.Key a)+++------------------------------------------------------------------------------+-- | Gets the result of a promised runtime computation.+getPromise :: (Monad n) => Promise a -> RuntimeSplice n 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 n) => Promise a -> a -> RuntimeSplice n ()+putPromise (Promise k) x = modify (HE.insert k x)+{-# INLINE putPromise #-}+++------------------------------------------------------------------------------+-- | Modifies a promise.+adjustPromise :: Monad n => Promise a -> (a -> a) -> RuntimeSplice n ()+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 #-}+++------------------------------------------------------------------------------+-- | 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) }+  where+    n' = _splicePrefix ts `mappend` n++------------------------------------------------------------------------------+-- | Binds a list of compiled splices.  This function should not be exported.+bindSplices :: Splices (Splice n)  -- ^ splices to bind+            -> HeistState n        -- ^ source state+            -> HeistState n+bindSplices ss hs =+    hs { _compiledSpliceMap = applySpliceMap hs _compiledSpliceMap ss }+++------------------------------------------------------------------------------+-- | Adds a list of compiled splices to the splice map.  This function is+-- useful because it allows compiled splices to bind other compiled splices+-- during load-time splice processing.+withLocalSplices :: Splices (Splice n)+                 -> Splices (AttrSplice n)+                 -> HeistT n IO a+                 -> HeistT n IO a+withLocalSplices ss as = localHS (bindSplices ss . bindAttributeSplices as)+++------------------------------------------------------------------------------+-- | Looks up a compiled template and returns a runtime monad computation that+-- constructs a builder.+--+-- Note that template names should not include the .tpl extension:+--+-- @renderTemplate hs "index"@+renderTemplate :: Monad n+               => HeistState n+               -> ByteString+               -> Maybe (n Builder, MIMEType)+renderTemplate hs nm =+    fmap (first (interpret . DL.fromList) . fst) $!+      lookupTemplate nm hs _compiledTemplateMap+++------------------------------------------------------------------------------+-- | Looks up a compiled template and returns a compiled splice.+callTemplate :: Monad n+             => ByteString+             -> Splice n+callTemplate nm = do+    hs <- getHS+    maybe (error err) call $ lookupTemplate nm hs _templateMap+  where+    err = "callTemplate: "++(T.unpack $ T.decodeUtf8 nm)++(" does not exist")+    call (df,_) = localHS (\hs' -> hs' {_curTemplateFile = dfFile df}) $+                    runNodeList $ X.docContent $ dfDoc df+++interpret :: Monad n => DList (Chunk n) -> n Builder+interpret = flip evalStateT HE.empty . unRT . codeGen+++------------------------------------------------------------------------------+-- | Converts a pure text splice function to a pure Builder splice function.+textSplice :: (a -> Text) -> a -> Builder+textSplice f = fromText . f+++                               ---------------+                               -- New Stuff --+                               ---------------+++------------------------------------------------------------------------------+-- | This is the same as htmlNodeSplice.  +nodeSplice :: (a -> [X.Node]) -> a -> Builder+nodeSplice f = X.renderHtmlFragment X.UTF8 . f+{-# DEPRECATED nodeSplice+   "Use xmlNodeSplice or htmlNodeSplice, will be removed in Heist 1.1" #-}+++------------------------------------------------------------------------------+-- | Converts a pure XML Node splice function to a pure Builder splice+-- function.+xmlNodeSplice :: (a -> [X.Node]) -> a -> Builder+xmlNodeSplice f = X.renderXmlFragment X.UTF8 . f+++------------------------------------------------------------------------------+-- | Converts a pure HTML Node splice function to a pure Builder splice+-- function.+htmlNodeSplice :: (a -> [X.Node]) -> a -> Builder+htmlNodeSplice f = X.renderHtmlFragment X.UTF8 . f+++------------------------------------------------------------------------------+-- | Converts a pure Builder splice function into a monadic splice function+-- of a RuntimeSplice.+pureSplice :: Monad n => (a -> Builder) -> RuntimeSplice n a -> Splice n+pureSplice f n = return $ yieldRuntime (return . f =<< n)+++------------------------------------------------------------------------------+-- | Runs a splice, but first binds splices given by splice functions that+-- need some runtime data.+withSplices :: Monad n+            => Splice n+            -- ^ Splice to be run+            -> Splices (RuntimeSplice n a -> Splice n)+            -- ^ Splices to be bound first+            -> RuntimeSplice n a+            -- ^ Runtime data needed by the above splices+            -> Splice n+withSplices splice splices runtimeAction =+    withLocalSplices splices' mempty splice+  where+    splices' = mapV ($ runtimeAction) splices+++------------------------------------------------------------------------------+{-# INLINE foldMapM #-}+foldMapM :: (Monad f, Monoid m, Foldable list)+         => (a -> f m)+         -> list a+         -> f m+foldMapM f =+  Foldable.foldlM (\xs x -> xs `seq` liftM (xs <>) (f x)) mempty++------------------------------------------------------------------------------+-- | Like withSplices, but evaluates the splice repeatedly for each element in+-- a list generated at runtime.+manyWithSplices :: (Foldable f, Monad n)+                => Splice n+                -> Splices (RuntimeSplice n a -> Splice n)+                -> RuntimeSplice n (f a)+                -> Splice n+manyWithSplices splice splices runtimeAction =+    manyWith splice splices mempty runtimeAction+++------------------------------------------------------------------------------+-- | More powerful version of manyWithSplices that lets you also define+-- attribute splices.+manyWith :: (Foldable f, Monad n)+         => Splice n+         -> Splices (RuntimeSplice n a -> Splice n)+         -> Splices (RuntimeSplice n a -> AttrSplice n)+         -> RuntimeSplice n (f a)+         -> Splice n+manyWith splice splices attrSplices runtimeAction = do+    p <- newEmptyPromise+    let splices' = mapV ($ getPromise p) splices+    let attrSplices' = mapV ($ getPromise p) attrSplices+    chunks <- withLocalSplices splices' attrSplices' splice+    return $ yieldRuntime $ do+        items <- runtimeAction+        foldMapM (\item -> putPromise p item >> codeGen chunks) items+++------------------------------------------------------------------------------+-- | Similar to 'mapSplices' in interpreted mode.  Gets a runtime list of+-- items and applies a compiled runtime splice function to each element of the+-- list.+deferMany :: (Foldable f, Monad n)+          => (RuntimeSplice n a -> Splice n)+          -> RuntimeSplice n (f a)+          -> Splice n+deferMany f getItems = do+    promise <- newEmptyPromise+    chunks <- f $ getPromise promise+    return $ yieldRuntime $ do+        items <- getItems+        foldMapM (\item -> putPromise promise item >> codeGen chunks) items+++------------------------------------------------------------------------------+-- | Saves the results of a runtime computation in a 'Promise' so they don't+-- get recalculated if used more than once.+--+-- Note that this is just a specialized version of function application ($)+-- done for the side effect in runtime splice.+defer :: Monad n+      => (RuntimeSplice n a -> Splice n)+      -> RuntimeSplice n a -> Splice n+defer pf n = do+    p2 <- newEmptyPromise+    let action = yieldRuntimeEffect $ putPromise p2 =<< n+    res <- pf $ getPromise p2+    return $ action `mappend` res+++------------------------------------------------------------------------------+-- | A version of defer which applies a function on the runtime value.+deferMap :: Monad n+         => (a -> RuntimeSplice n b)+         -> (RuntimeSplice n b -> Splice n)+         -> RuntimeSplice n a -> Splice n+deferMap f pf n = defer pf $ f =<< n+++------------------------------------------------------------------------------+-- | Like deferMap, but only runs the result if a Maybe function of the+-- runtime value returns Just.  If it returns Nothing, then no output is+-- generated.+mayDeferMap :: Monad n+            => (a -> RuntimeSplice n (Maybe b))+            -> (RuntimeSplice n b -> Splice n)+            -> RuntimeSplice n a -> Splice n+mayDeferMap f pf n = deferMany pf $ f =<< n+++------------------------------------------------------------------------------+-- | Converts an RuntimeSplice into a Splice, given a helper function that+-- generates a Builder.+bindLater :: (Monad n)+          => (a -> RuntimeSplice n Builder)+          -> RuntimeSplice n a+          -> Splice n+bindLater f p = return $ yieldRuntime $ f =<< p++
+ src/Heist/Compiled/LowLevel.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeSynonymInstances       #-}++module Heist.Compiled.LowLevel+  (+  -- * Lower level promise functions+    Promise+  , newEmptyPromise+  , getPromise+  , putPromise+  , adjustPromise++  ) where++import           Heist.Compiled.Internal
+ src/Heist/Internal/Types.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE UndecidableInstances       #-}++{-|++Internal types and accessors.  There are no guarantees that heist will+preserve backwards compatibility for symbols in this module.  If you use them,+no complaining when your code breaks.++-}++module Heist.Internal.Types+  ( module Heist.Internal.Types.HeistState+  , module Heist.Internal.Types+  ) where++------------------------------------------------------------------------------+import           Data.HashMap.Strict (HashMap)+import           Data.Text (Text)++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif+#if !MIN_VERSION_base(4,11,0)+import           Data.Semigroup+#endif++------------------------------------------------------------------------------+import qualified Heist.Compiled.Internal       as C+import qualified Heist.Interpreted.Internal    as I+import           Heist.Internal.Types.HeistState+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+type TemplateRepo = HashMap TPath DocumentFile+++------------------------------------------------------------------------------+-- | An IO action for getting a template repo from this location.  By not just+-- using a directory path here, we support templates loaded from a database,+-- retrieved from the network, or anything else you can think of.+type TemplateLocation = IO (Either [String] TemplateRepo)+++------------------------------------------------------------------------------+-- | My lens creation function to avoid a dependency on lens.+lens :: Functor f => (t1 -> t) -> (t1 -> a -> b) -> (t -> f a) -> t1 -> f b+lens sa sbt afb s = sbt s <$> afb (sa s)+++------------------------------------------------------------------------------+-- | The splices and templates Heist will use.  To bind a splice simply+-- include it in the appropriate place here.+data SpliceConfig m = SpliceConfig+    { _scInterpretedSplices     :: Splices (I.Splice m)+        -- ^ Interpreted splices are the splices that Heist has always had.+        -- They return a list of nodes and are processed at runtime.+    , _scLoadTimeSplices        :: Splices (I.Splice IO)+        -- ^ Load time splices are like interpreted splices because they+        -- return a list of nodes.  But they are like compiled splices because+        -- they are processed once at load time.  All of Heist's built-in+        -- splices should be used as load time splices.+    , _scCompiledSplices        :: Splices (C.Splice m)+        -- ^ Compiled splices return a DList of Chunks and are processed at+        -- load time to generate a runtime monad action that will be used to+        -- render the template.+    , _scAttributeSplices       :: Splices (AttrSplice m)+        -- ^ Attribute splices are bound to attribute names and return a list+        -- of attributes.+    , _scTemplateLocations      :: [TemplateLocation]+        -- ^ A list of all the locations that Heist should get its templates+        -- from.+    , _scCompiledTemplateFilter :: TPath -> Bool+        -- ^ Predicate function to control which templates to compile.  Using+        -- templates filtered out with this is still possible via+        -- callTemplate.+    }+++------------------------------------------------------------------------------+-- | Lens for interpreted splices+-- :: Simple Lens (SpliceConfig m) (Splices (I.Splice m))+scInterpretedSplices+    :: Functor f+    => (Splices (I.Splice m) -> f (Splices (I.Splice m)))+    -> SpliceConfig m -> f (SpliceConfig m)+scInterpretedSplices = lens _scInterpretedSplices setter+  where+    setter sc v = sc { _scInterpretedSplices = v }+++------------------------------------------------------------------------------+-- | Lens for load time splices+-- :: Simple Lens (SpliceConfig m) (Splices (I.Splice IO))+scLoadTimeSplices+    :: Functor f+    => (Splices (I.Splice IO) -> f (Splices (I.Splice IO)))+    -> SpliceConfig m -> f (SpliceConfig m)+scLoadTimeSplices = lens _scLoadTimeSplices setter+  where+    setter sc v = sc { _scLoadTimeSplices = v }+++------------------------------------------------------------------------------+-- | Lens for complied splices+-- :: Simple Lens (SpliceConfig m) (Splices (C.Splice m))+scCompiledSplices+    :: Functor f+    => (Splices (C.Splice m) -> f (Splices (C.Splice m)))+    -> SpliceConfig m -> f (SpliceConfig m)+scCompiledSplices = lens _scCompiledSplices setter+  where+    setter sc v = sc { _scCompiledSplices = v }+++------------------------------------------------------------------------------+-- | Lens for attribute splices+-- :: Simple Lens (SpliceConfig m) (Splices (AttrSplice m))+scAttributeSplices+    :: Functor f+    => (Splices (AttrSplice m) -> f (Splices (AttrSplice m)))+    -> SpliceConfig m -> f (SpliceConfig m)+scAttributeSplices = lens _scAttributeSplices setter+  where+    setter sc v = sc { _scAttributeSplices = v }+++------------------------------------------------------------------------------+-- | Lens for template locations+-- :: Simple Lens (SpliceConfig m) [TemplateLocation]+scTemplateLocations+    :: Functor f+    => ([TemplateLocation] -> f [TemplateLocation])+    -> SpliceConfig m -> f (SpliceConfig m)+scTemplateLocations = lens _scTemplateLocations setter+  where+    setter sc v = sc { _scTemplateLocations = v }+++------------------------------------------------------------------------------+-- | Lens for compiled template filter+-- :: Simple Lens (SpliceConfig m) (TBool -> Bool)+scCompiledTemplateFilter+    :: Functor f+    => ((TPath -> Bool) -> f (TPath -> Bool))+    -> SpliceConfig m -> f (SpliceConfig m)+scCompiledTemplateFilter = lens _scCompiledTemplateFilter setter+  where+    setter sc v = sc { _scCompiledTemplateFilter = v }+++instance Semigroup (SpliceConfig m) where+    SpliceConfig a1 b1 c1 d1 e1 f1 <> SpliceConfig a2 b2 c2 d2 e2 f2 =+      SpliceConfig (a1 <> a2) (b1 <> b2) (c1 <> c2)+                   (d1 <> d2) (e1 <> e2) (\x -> f1 x && f2 x)++instance Monoid (SpliceConfig m) where+    mempty = SpliceConfig mempty mempty mempty mempty mempty (const True)+#if !MIN_VERSION_base(4,11,0)+    mappend = (<>)+#endif+++data HeistConfig m = HeistConfig+    { _hcSpliceConfig  :: SpliceConfig m+        -- ^ Splices and templates+    , _hcNamespace     :: Text+        -- ^ A namespace to use for all tags that are bound to splices.  Use+        -- empty string for no namespace.+    , _hcErrorNotBound :: Bool+        -- ^ Whether to throw an error when a tag wih the heist namespace does+        -- not correspond to a bound splice.  When not using a namespace, this+        -- flag is ignored.+    }+++------------------------------------------------------------------------------+-- | Lens for the SpliceConfig+-- :: Simple Lens (HeistConfig m) (SpliceConfig m)+hcSpliceConfig+    :: Functor f+    => ((SpliceConfig m) -> f (SpliceConfig m))+    -> HeistConfig m -> f (HeistConfig m)+hcSpliceConfig = lens _hcSpliceConfig setter+  where+    setter hc v = hc { _hcSpliceConfig = v }+++------------------------------------------------------------------------------+-- | Lens for the namespace+-- :: Simple Lens (HeistConfig m) Text+hcNamespace+    :: Functor f+    => (Text -> f Text)+    -> HeistConfig m -> f (HeistConfig m)+hcNamespace = lens _hcNamespace setter+  where+    setter hc v = hc { _hcNamespace = v }+++------------------------------------------------------------------------------+-- | Lens for the namespace error flag+-- :: Simple Lens (HeistConfig m) Bool+hcErrorNotBound+    :: Functor f+    => (Bool -> f Bool)+    -> HeistConfig m -> f (HeistConfig m)+hcErrorNotBound = lens _hcErrorNotBound setter+  where+    setter hc v = hc { _hcErrorNotBound = v }+++------------------------------------------------------------------------------+-- | Lens for interpreted splices+-- :: Simple Lens (HeistConfig m) (Splices (I.Splice m))+hcInterpretedSplices+    :: Functor f+    => (Splices (I.Splice m) -> f (Splices (I.Splice m)))+    -> HeistConfig m -> f (HeistConfig m)+hcInterpretedSplices = hcSpliceConfig . scInterpretedSplices+++------------------------------------------------------------------------------+-- | Lens for load time splices+-- :: Simple Lens (HeistConfig m) (Splices (I.Splice IO))+hcLoadTimeSplices+    :: Functor f+    => (Splices (I.Splice IO) -> f (Splices (I.Splice IO)))+    -> HeistConfig m -> f (HeistConfig m)+hcLoadTimeSplices = hcSpliceConfig . scLoadTimeSplices +++------------------------------------------------------------------------------+-- | Lens for compiled splices+-- :: Simple Lens (HeistConfig m) (Splices (C.Splice m))+hcCompiledSplices+    :: Functor f+    => (Splices (C.Splice m) -> f (Splices (C.Splice m)))+    -> HeistConfig m -> f (HeistConfig m)+hcCompiledSplices = hcSpliceConfig . scCompiledSplices +++------------------------------------------------------------------------------+-- | Lens for attribute splices+-- :: Simple Lens (HeistConfig m) (Splices (AttrSplice m))+hcAttributeSplices+    :: Functor f+    => (Splices (AttrSplice m) -> f (Splices (AttrSplice m)))+    -> HeistConfig m -> f (HeistConfig m)+hcAttributeSplices = hcSpliceConfig . scAttributeSplices +++------------------------------------------------------------------------------+-- | Lens for template locations+-- :: Simple Lens (HeistConfig m) [TemplateLocation]+hcTemplateLocations+    :: Functor f+    => ([TemplateLocation] -> f [TemplateLocation])+    -> HeistConfig m -> f (HeistConfig m)+hcTemplateLocations = hcSpliceConfig . scTemplateLocations +++------------------------------------------------------------------------------+-- | Lens for compiled template filter+-- :: Simple Lens (SpliceConfig m) (TBool -> Bool)+hcCompiledTemplateFilter+    :: Functor f+    => ((TPath -> Bool) -> f (TPath -> Bool))+    -> HeistConfig m -> f (HeistConfig m)+hcCompiledTemplateFilter = hcSpliceConfig . scCompiledTemplateFilter++
+ src/Heist/Internal/Types/HeistState.hs view
@@ -0,0 +1,680 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# 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.Internal.Types.HeistState where++------------------------------------------------------------------------------+import           Blaze.ByteString.Builder      (Builder)+import           Control.Applicative           (Alternative (..))+import           Control.Arrow                 (first)+import           Control.Exception             (Exception)+import           Control.Monad                 (MonadPlus (..), ap)+import           Control.Monad.Base+import           Control.Monad.Cont            (MonadCont (..))+#if MIN_VERSION_mtl(2,2,1)+import           Control.Monad.Except          (MonadError (..))+#else+import           Control.Monad.Error           (MonadError (..))+#endif+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import           Control.Monad.Fix             (MonadFix (..))+import           Control.Monad.Reader          (MonadReader (..))+import           Control.Monad.State.Strict    (MonadState (..), StateT)+import           Control.Monad.Trans           (MonadIO (..), MonadTrans (..))+import           Control.Monad.Trans.Control+import           Data.ByteString.Char8         (ByteString)+import           Data.DList                    (DList)+import           Data.HashMap.Strict           (HashMap)+import qualified Data.HashMap.Strict           as H+import           Data.HeterogeneousEnvironment (HeterogeneousEnvironment)+import qualified Data.HeterogeneousEnvironment as HE+import           Data.Map.Syntax+#if !MIN_VERSION_base(4,11,0)+import           Data.Semigroup+#endif+import           Data.Text                     (Text)+import qualified Data.Text                     as T+import           Data.Text.Encoding            (decodeUtf8)+#if MIN_VERSION_base (4,7,0)+import           Data.Typeable                 (Typeable)+#else+import           Data.Typeable                 (TyCon, Typeable(..),+                                                Typeable1(..), mkTyCon,+                                                mkTyConApp)+#endif++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative           (Applicative (..), (<$>))+import           Data.Monoid                   (Monoid(..))+#endif++import qualified Text.XmlHtml                  as X+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Convenient type alies for splices.+type Splices s = MapSyntax Text s+++------------------------------------------------------------------------------+-- | 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, Show+#if MIN_VERSION_base(4,7,0)+               , Typeable+#endif+               )+++------------------------------------------------------------------------------+-- | Designates whether a document should be treated as XML or HTML.+data Markup = Xml | Html+++------------------------------------------------------------------------------+-- | Monad used for runtime splice execution.+newtype RuntimeSplice m a = RuntimeSplice {+      unRT :: StateT HeterogeneousEnvironment m a+    } deriving ( Applicative+               , Functor+               , Monad+               , MonadIO+               , MonadState HeterogeneousEnvironment+               , MonadTrans+#if MIN_VERSION_base(4,7,0)+               , Typeable+#endif+               )+++------------------------------------------------------------------------------+instance (Monad m, Semigroup a) => Semigroup (RuntimeSplice m a) where+    a <> b = do+        !x <- a+        !y <- b+        return $! x <> y+++#if !MIN_VERSION_base(4,11,0)+instance (Monad m, Semigroup a, Monoid a) => Monoid (RuntimeSplice m a) where+#else+instance (Monad m, Monoid a) => Monoid (RuntimeSplice m a) where+#endif+    mempty = return mempty+#if !MIN_VERSION_base(4,11,0)+    mappend = (<>)+#endif+++------------------------------------------------------------------------------+-- | 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+#if MIN_VERSION_base(4,7,0)+             deriving Typeable+#endif++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 -> RuntimeSplice m [(Text, Text)]+++------------------------------------------------------------------------------+-- | Detailed information about a splice error.+data SpliceError = SpliceError+    { spliceHistory      :: [(TPath, Maybe FilePath, Text)]+    , spliceTemplateFile :: Maybe FilePath+    , visibleSplices     :: [Text]+    , contextNode        :: X.Node+    , spliceMsg          :: Text+    } deriving ( Show, Eq )+++------------------------------------------------------------------------------+-- | Transform a SpliceError record to a Text message.+spliceErrorText :: SpliceError -> Text+spliceErrorText (SpliceError hist tf splices node msg) =+    (maybe "" ((`mappend` ": ") . T.pack) tf) `T.append` msg `T.append`+    foldr (\(_, tf', tag) -> (("\n   ... via " `T.append`+                               (maybe "" ((`mappend` ": ") . T.pack) tf')+                               `T.append` tag) `T.append`)) T.empty hist+    `T.append`+    if null splices+      then T.empty+      else "\nBound splices:" `T.append`+         foldl (\x y -> x `T.append` " " `T.append` y) T.empty splices+    `T.append`+    (T.pack $ "\nNode: " ++ (show node))+++------------------------------------------------------------------------------+-- | Exception type for splice compile errors.  Wraps the original+-- exception and provides context.+--data (Exception e) => CompileException e = CompileException+data CompileException = forall e . Exception e => CompileException+    { originalException :: e+    -- The list of splice errors.  The head of it has the context+    -- related to the exception.+    , exceptionContext :: [SpliceError]+    } deriving ( Typeable )+++instance Show CompileException where+    show (CompileException e []) =+      "Heist load exception (unknown context): " ++ (show e)+    show (CompileException _ (c:_)) = (T.unpack $ spliceErrorText c)+++instance Exception CompileException+++------------------------------------------------------------------------------+-- | 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+    -- | Stack of the splices used.+    , _splicePath          :: [(TPath, Maybe FilePath, Text)]+    -- | 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++    -- | This is needed because compiled templates are generated with a bunch+    -- of calls to renderFragment rather than a single call to render.+    , _curMarkup           :: Markup++    -- | A prefix for all splices (namespace ++ ":").+    , _splicePrefix        :: Text++    -- | List of errors encountered during splice processing.+    , _spliceErrors        :: [SpliceError]++    -- | Whether to throw an error when a tag wih the heist namespace does not+    -- correspond to a bound splice.  When not using a namespace, this flag is+    -- ignored.+    , _errorNotBound       :: Bool+    , _numNamespacedTags   :: Int+#if MIN_VERSION_base(4,7,0)+} deriving (Typeable)+#else+}+#endif++#if !MIN_VERSION_base(4,7,0)+-- 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 ())]++#endif++------------------------------------------------------------------------------+-- | 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)+#if MIN_VERSION_base(4,7,0)+} deriving Typeable+#else+}+#endif+++------------------------------------------------------------------------------+-- | 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 interpreted splices defined in a HeistState.+spliceNames :: HeistState m -> [Text]+spliceNames ts = H.keys $ _spliceMap ts+++------------------------------------------------------------------------------+-- | Gets the names of all the compiled splices defined in a HeistState.+compiledSpliceNames :: HeistState m -> [Text]+compiledSpliceNames ts = H.keys $ _compiledSpliceMap ts+++#if !MIN_VERSION_base(4,7,0)+------------------------------------------------------------------------------+-- | The Typeable instance is here so Heist can be dynamically executed with+-- Hint.+templateStateTyCon :: TyCon+templateStateTyCon = mkTyCon "Heist.HeistState"+{-# NOINLINE templateStateTyCon #-}+#endif+++------------------------------------------------------------------------------+-- | 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 (>>=) #-}+++#if MIN_VERSION_base(4,9,0)+------------------------------------------------------------------------------+-- | MonadFail instance+instance Fail.MonadFail m => Fail.MonadFail (HeistT n m) where+    fail = lift . Fail.fail+#endif+++------------------------------------------------------------------------------+-- | 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)+++instance MonadBase b m => MonadBase b (HeistT n m) where+    liftBase = lift . liftBase++#if MIN_VERSION_monad_control(1,0,0)+instance MonadTransControl (HeistT n) where+    type StT (HeistT n) a = (a, HeistState n)+    liftWith f = HeistT $ \n s -> do+        res <- f $ \(HeistT g) -> g n s+        return (res, s)+    restoreT k = HeistT $ \_ _ -> k+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}+++instance MonadBaseControl b m => MonadBaseControl b (HeistT n m) where+     type StM (HeistT n m) a = ComposeSt (HeistT n) m a+     liftBaseWith = defaultLiftBaseWith+     restoreM = defaultRestoreM+     {-# INLINE liftBaseWith #-}+     {-# INLINE restoreM #-}+#else+instance MonadTransControl (HeistT n) where+    newtype StT (HeistT n) a = StHeistT {unStHeistT :: (a, HeistState n)}+    liftWith f = HeistT $ \n s -> do+        res <- f $ \(HeistT g) -> liftM StHeistT $ g n s+        return (res, s)+    restoreT k = HeistT $ \_ _ -> liftM unStHeistT k+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}+++instance MonadBaseControl b m => MonadBaseControl b (HeistT n m) where+     newtype StM (HeistT n m) a = StMHeist {unStMHeist :: ComposeSt (HeistT n) m a}+     liftBaseWith = defaultLiftBaseWith StMHeist+     restoreM = defaultRestoreM unStMHeist+     {-# INLINE liftBaseWith #-}+     {-# INLINE restoreM #-}+#endif++------------------------------------------------------------------------------+-- | 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+++#if !MIN_VERSION_base(4,7,0)+------------------------------------------------------------------------------+-- | 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 ())]+#endif+++------------------------------------------------------------------------------+-- 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 $ curry return+{-# 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 and splice errors.  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+                                      , _numNamespacedTags =+                                        _numNamespacedTags cur+                                      , _spliceErrors = _spliceErrors 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) })+++------------------------------------------------------------------------------+-- | Increments the namespaced tag count+incNamespacedTags :: Monad m => HeistT n m ()+incNamespacedTags =+    modifyHS (\st -> st { _numNamespacedTags = _numNamespacedTags st + 1 })+++------------------------------------------------------------------------------+-- | 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)+++------------------------------------------------------------------------------+isIdent :: AttAST -> Bool+isIdent (Ident _) = True+isIdent _         = False++
+ src/Heist/Interpreted.hs view
@@ -0,0 +1,83 @@+{-|++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+  , bindAttributeSplices++  -- * Functions for creating splices+  , textSplice+  , runChildren+  , runChildrenWith+  , runChildrenWithTrans+  , runChildrenWithTemplates+  , runChildrenWithText+  , mapSplices++  -- * HeistT functions+  , stopRecursion+  , runNode+  , runAttributes+  , runNodeList+  , evalTemplate+  , bindStrings+  , bindString+  , callTemplate+  , callTemplateWithText+  , renderTemplate+  , renderTemplateToDoc+  , renderWithArgs+  ) where++import Heist.Interpreted.Internal+import Heist.Common (mapSplices, bindAttributeSplices)+
+ src/Heist/Interpreted/Internal.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PackageImports             #-}+{-# LANGUAGE ScopedTypeVariables        #-}++module Heist.Interpreted.Internal where++------------------------------------------------------------------------------+import           Blaze.ByteString.Builder+import           Control.Monad+import           Control.Monad.State.Strict+import qualified Data.Attoparsec.Text          as AP+import           Data.ByteString               (ByteString)+import qualified Data.HashMap.Strict           as Map+import qualified Data.HeterogeneousEnvironment as HE+import           Data.Map.Syntax+import           Data.Maybe+import           Data.Text                     (Text)+import qualified Data.Text                     as T+import qualified Text.XmlHtml                  as X+------------------------------------------------------------------------------+import           Heist.Common+import           Heist.Internal.Types.HeistState+------------------------------------------------------------------------------+++type Splice n = HeistT n n Template+++------------------------------------------------------------------------------+-- 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 hs = hs {_spliceMap = Map.insert n v (_spliceMap hs)}+++------------------------------------------------------------------------------+-- | Binds a set of new splice declarations within a 'HeistState'.+bindSplices :: Splices (Splice n) -- ^ splices to bind+            -> HeistState n       -- ^ start state+            -> HeistState n+bindSplices ss hs =+    hs { _spliceMap = applySpliceMap hs _spliceMap ss }+++------------------------------------------------------------------------------+-- | Converts 'Text' to a splice returning a single 'TextNode'.+textSplice :: Monad m => Text -> HeistT n m Template+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)+                => Splices (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+          -> Splices b+          -- ^ List of tuples to be bound+          -> Splice n+runChildrenWithTrans f = runChildrenWith . mapV f+++------------------------------------------------------------------------------+-- | Like runChildrenWith but using constant templates rather than dynamic+-- splices.+runChildrenWithTemplates :: (Monad n) => Splices Template -> Splice n+runChildrenWithTemplates = runChildrenWithTrans return+++------------------------------------------------------------------------------+-- | Like runChildrenWith but using literal text rather than dynamic splices.+runChildrenWithText :: (Monad n) => Splices Text -> Splice n+runChildrenWithText = runChildrenWithTrans textSplice+++------------------------------------------------------------------------------+-- | Convenience function for looking up a splice.+lookupSplice :: Text+             -> HeistState n+             -> Maybe (Splice n)+lookupSplice nm hs = Map.lookup nm $ _spliceMap hs+{-# 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 <- runAttributes 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]+++------------------------------------------------------------------------------+-- | Performs splice processing on a list of attributes.  This is useful in+-- situations where you need to stop recursion, but still run splice+-- processing on the node's attributes.+runAttributes :: Monad n => [(Text, Text)] -> HeistT n n [(Text, Text)]+runAttributes attrs = (return . concat) =<< mapM runAttrSplice attrs+++------------------------------------------------------------------------------+-- | 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 . flip evalStateT HE.empty . unRT . ($ 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 (Ident x)   =+        localParamNode (const $ X.Element x [] []) $ getAttributeSplice x+++------------------------------------------------------------------------------+-- | 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 = return $ T.concat ["${", name, "}"]+        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 do modifyHS (\st -> st { _recurse = True })+                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+    hs <- getHS+    let mt = lookupTemplate name hs _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 (\hs -> hs {_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+    hs <- getHS+    let nodes = X.docContent $ dfDoc t+    putHS (hs {_curContext = ctx})+    newNodes <- runNodeList nodes+    restoreHS hs+    newDoc   <- fixDocType $ (dfDoc t) { X.docContent = newNodes }+    return (Just newDoc)+++------------------------------------------------------------------------------+-- | Binds a list of constant string splices.+bindStrings :: Monad n+            => Splices Text+            -> HeistState n+            -> HeistState n+bindStrings splices = bindSplices (mapV textSplice splices)+++------------------------------------------------------------------------------+-- | 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+             -> Splices (Splice n) -- ^ Splices to call the template with+             -> HeistT n n Template+callTemplate name splices = do+    modifyHS $ bindSplices splices+    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+                     -> Splices Text -- ^ Splices to call the template with+                     -> HeistT n n Template+callTemplateWithText name splices = callTemplate name $ mapV textSplice splices+++------------------------------------------------------------------------------+-- | 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.+--+-- Note that template names should not include the .tpl extension:+--+-- @renderTemplate hs "index"@+renderTemplate :: Monad n+               => HeistState n+               -> ByteString+               -> n (Maybe (Builder, MIMEType))+renderTemplate hs name = evalHeistT tpl (X.TextNode "") hs+  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+               => Splices Text+               -> HeistState n+               -> ByteString+               -> n (Maybe (Builder, MIMEType))+renderWithArgs args hs = renderTemplate (bindStrings args hs)+++renderTemplateToDoc :: Monad n+            => HeistState n+            -> ByteString+            -> n (Maybe X.Document)+renderTemplateToDoc hs name =+    evalHeistT (evalWithDoctypes name) (X.TextNode "") hs
+ src/Heist/Splices.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP               #-}++module Heist.Splices+  ( ifISplice+  , ifCSplice+  , ifElseISplice+  , ifElseCSplice+  , 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++#if !MIN_VERSION_base(4,8,0)+import           Data.Monoid (Monoid(..))+#endif++import qualified Heist.Compiled as C+import qualified Heist.Interpreted as I+import           Heist.Splices.Apply+import           Heist.Splices.Bind+import           Heist.Splices.Cache+import           Heist.Splices.Html+import           Heist.Splices.Ignore+import           Heist.Splices.Markdown+import           Heist.Internal.Types.HeistState+import qualified Text.XmlHtml as X++------------------------------------------------------------------------------+-- | Run the splice contents if given condition is True, make splice disappear+-- if not.+ifISplice :: Monad m => Bool -> I.Splice m+ifISplice cond =+    case cond of+      False -> return []+      True -> I.runChildren+++------------------------------------------------------------------------------+-- | Function for constructing if splices that use a runtime predicate+-- function to determine whether the node's children should be rendered.+ifCSplice :: Monad m+          => (t -> Bool)+          -> RuntimeSplice m t+          -> C.Splice m+ifCSplice predicate runtime = do+    chunks <- C.runChildren+    return $ C.yieldRuntime $ do+        a <- runtime+        if predicate a+          then+            C.codeGen chunks+          else+            return mempty+++------------------------------------------------------------------------------+-- | Implements an if\/then\/else conditional splice.  It splits its children+-- around the \<else\/\> element to get the markup to be used for the two cases.+ifElseISplice :: Monad m => Bool -> I.Splice m+ifElseISplice cond = getParamNode >>= (rewrite . X.childNodes)+  where+    rewrite nodes = +      let (ns, ns') = break (\n -> X.tagName n==Just "else") nodes+      in I.runNodeList $ if cond then ns else (drop 1 ns') +++------------------------------------------------------------------------------+-- | Implements an if\/then\/else conditional splice.  It splits its children+-- around the \<else\/\> element to get the markup to be used for the two cases.+ifElseCSplice :: Monad m => Bool -> C.Splice m+ifElseCSplice cond = getParamNode >>= (rewrite . X.childNodes)+  where rewrite nodes = +          let (ns, ns') = break (\n -> X.tagName n==Just "else") nodes+          in C.runNodeList $ if cond then ns else (drop 1 ns')
+ src/Heist/Splices/Apply.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+module Heist.Splices.Apply where++------------------------------------------------------------------------------+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.Internal.Types.HeistState+++------------------------------------------------------------------------------+-- | 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!" :: String+    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 :: Monad 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 :: Monad 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+++------------------------------------------------------------------------------+-- | This splice crashes with an error message.  Its purpose is to provide a+-- load-time warning to anyone still using the old content tag in their+-- templates.  In Heist 0.10, tho content tag was replaced by two separate+-- apply-content and bind-content tags used by the apply and bind splices+-- respectively.+deprecatedContentCheck :: Monad m => Splice m+deprecatedContentCheck =+    return [] `orError` unwords+      ["<content> tag deprecated.  Use"+      ,"<apply-content> or <bind-content>"+      ]+
+ src/Heist/Splices/Bind.hs view
@@ -0,0 +1,42 @@+module Heist.Splices.Bind where++------------------------------------------------------------------------------+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.Internal.Types.HeistState++-- | 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 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)+
+ src/Heist/Splices/BindStrict.hs view
@@ -0,0 +1,36 @@+module Heist.Splices.BindStrict where++------------------------------------------------------------------------------+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.Internal.Types.HeistState++-- | Default name for the bind splice.+bindStrictTag :: Text+bindStrictTag = "bindStrict"+++------------------------------------------------------------------------------+-- | Implementation of the bind splice.+bindStrictImpl :: Monad 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)
+ src/Heist/Splices/Cache.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE CPP               #-}+{-# 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           System.Random+import           Text.XmlHtml++#if !MIN_VERSION_base(4,8,0)+import           Data.Word (Word)+#endif++------------------------------------------------------------------------------+import qualified Heist.Compiled.Internal as C+import           Heist.Interpreted.Internal+import           Heist.Internal.Types.HeistState+++------------------------------------------------------------------------------+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 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 }]++
+ src/Heist/Splices/Html.hs view
@@ -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.Internal.Types.HeistState+++------------------------------------------------------------------------------+-- | 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)+
+ src/Heist/Splices/Ignore.hs view
@@ -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 []++
+ src/Heist/Splices/Json.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++module Heist.Splices.Json (+  bindJson+) where++------------------------------------------------------------------------------+import           Control.Monad.Reader+import           Data.Aeson+import qualified Data.ByteString.Char8       as S+import qualified Data.ByteString.Lazy.Char8  as L+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap           as KM+import qualified Data.Aeson.Key              as K+import qualified Data.Foldable.WithIndex     as FI+#else+import qualified Data.HashMap.Strict         as Map+#endif+import           Data.Map.Syntax+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.Blaze.Html5            ((!))+import qualified Text.Blaze.Html5            as B+import           Text.Blaze.Renderer.XmlHtml+import           Text.XmlHtml+------------------------------------------------------------------------------+import           Heist.Interpreted.Internal+import           Heist.Internal.Types.HeistState+------------------------------------------------------------------------------++                                 ------------+                                 -- 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 :: ToJSON a => a -> 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+#if MIN_VERSION_aeson(2,0,0)+        findIn (Object obj) = KM.lookup (K.fromText x) obj+#else+        findIn (Object obj) = Map.lookup x obj+#endif+        findIn (Array arr)  = tryReadIndex >>= \i -> arr V.!? i+        findIn _            = Nothing++        tryReadIndex = fmap fst . listToMaybe . reads . T.unpack $ x+++------------------------------------------------------------------------------+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 :: forall n. (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 $ do+        "value"   ## return [TextNode t]+        "snippet" ## asHtml t++    --------------------------------------------------------------------------+    goArray :: 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 :: Value -> (JsonMonad n n [Node]) -> Splice n+    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 :: JsonMonad n n (Splices (Splice n))+    genericBindings = ask >>= \v -> return $ do+        "with"     ## varAttrTag v explodeTag+        "snippet"  ## varAttrTag v snippetTag+        "value"    ## varAttrTag v valueTag+++    --------------------------------------------------------------------------+    goObject obj = do+        start <- genericBindings+#if MIN_VERSION_aeson(2,0,0)+        let bindings = FI.ifoldl' (flip bindKvp) start  obj+#else+        let bindings = Map.foldlWithKey' bindKvp start obj+#endif+        lift $ runChildrenWith bindings++    --------------------------------------------------------------------------+    +    bindKvp bindings k v =+#if MIN_VERSION_aeson(2,0,0)+        let k' = K.toText k+#else+        let k' = k+#endif+            newBindings = do+                T.append "with:" k'    ## withValue v explodeTag+                T.append "snippet:" k' ## withValue v snippetTag+                T.append "value:" k'   ## withValue v valueTag+        in  bindings >> newBindings
+ src/Heist/Splices/Markdown.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards    #-}+{-| 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.++You can add custom pandoc splice with 'pandocSplice'. It is not limited to+markdown input, and can process anything pandoc can.++For example you can create a page with generated table of contents, using+heist template as pandoc template.++>  <!-- _wrap.tpl -->+>  <html>+>    <head> <title> <pageTitle/> </title> </head>+>+>    <div class="nav"> <pageToc/> </div>+>    <apply-content/>+>  </html>++And pandoc template, which would bind @pageTitle@ and @pageToc@ splices and+applies "_wrap" template.++>  <!-- _pandoc.tpl -->+>  <apply template="_wrap.tpl">+>    <bind tag="pageTitle"> $title$</bind>+>    <bind tag="pageToc"> $toc$</bind>+>    $body$+>  </apply>++Bind splice pandoc splice. Set it to not wrap in div, or it will break html+from _wrap.tpl++>  splices = "docmarkdown" ## pandocSplice opts+>    where+>      opts = setPandocArgs  ["-S", "--no-wrap", "--toc"+>                            , "--standalone"+>                            , "--template", "_pandoc.tpl"+>                            , "--html5"]+>             $ setPandocWrapDiv Nothing+>             $ defaultPandocOptions+>++And then use it to render your markdown file+++>  <!-- apidocs.tpl -->+>  <DOCTYPE html>+>  <html lang="en">+>  <head>+>    <link href="/static/css/site.css rel="stylesheet">+>  </head>+>  <body>+>    <apply template="_navbar.tpl" />+>    <docmarkdown file="apidocs.md"/>+>  </body>++-}+module Heist.Splices.Markdown+  (+  -- * Exceptions+    PandocMissingException+  , MarkdownException+  , NoMarkdownFileException+  -- * Markdown Splice+  , markdownTag+  , markdownSplice+  -- * Generic pandoc splice+  , pandocSplice+  -- ** Pandoc Options+  , PandocOptions+  , defaultPandocOptions+  , setPandocExecutable+  , setPandocArgs+  , setPandocBaseDir+  , setPandocWrapDiv+  -- ** Lens for 'PandocOptions'+  , pandocExecutable+  , pandocArgs+  , pandocBaseDir+  , pandocWrapDiv+  ) where++------------------------------------------------------------------------------+import           Control.Concurrent+import           Control.Exception.Lifted+import           Control.Monad+import           Control.Monad.Trans+import           Data.ByteString                 (ByteString)+import qualified Data.ByteString                 as B+import qualified Data.ByteString.Char8           as BC+import           Data.Maybe                      (fromMaybe)+import           Data.Text                       (Text)+import qualified Data.Text                       as T+import qualified Data.Text.Encoding              as T+import           Data.Typeable+import           System.Directory+import           System.Exit+import           System.FilePath.Posix+import           System.IO+import           System.Process+import           Text.XmlHtml++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative             ((<$>))+#endif++------------------------------------------------------------------------------+import           Heist.Common+import           Heist.Internal.Types.HeistState+import           Heist.Interpreted.Internal++data PandocMissingException = PandocMissingException+   deriving (Typeable)++instance Show PandocMissingException where+    show PandocMissingException =+        "Cannot find the \"pandoc\" executable.  If you have Haskell, then install it with \"cabal install\".  Otherwise you can download it from http://johnmacfarlane.net/pandoc/installing.html.  Then make sure it is in 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++--------------------------------------------------------------------------------++data PandocOptions = PandocOptions+     { _pandocExecutable :: FilePath+     , _pandocArgs       :: [String]         -- ^ Arguments to pandoc+     , _pandocBaseDir    :: Maybe FilePath   -- ^ Base directory for input files+                                             --   defaults to template path+     , _pandocWrapDiv    :: Maybe Text       -- ^ Wrap content in div with class+     } deriving (Eq, Ord, Show)++-- | Default options+defaultPandocOptions :: PandocOptions+defaultPandocOptions = PandocOptions "pandoc"+                                     []+                                     Nothing+                                     (Just "markdown")++-- | Name of pandoc executable+setPandocExecutable :: FilePath -> PandocOptions -> PandocOptions+setPandocExecutable e opt = opt { _pandocExecutable = e }++-- | Arguments passed to pandoc+setPandocArgs :: [String] -> PandocOptions -> PandocOptions+setPandocArgs args opt = opt { _pandocArgs = args }++-- | Base directory for input files, defaults to current template dir+setPandocBaseDir :: Maybe FilePath -> PandocOptions -> PandocOptions+setPandocBaseDir bd opt = opt { _pandocBaseDir = bd }++-- | Wrap pandoc output in div with class. Appends node attributes to+--   div and appends class to ones specified on node.+setPandocWrapDiv :: Maybe Text -> PandocOptions -> PandocOptions+setPandocWrapDiv wd opt = opt { _pandocWrapDiv = wd }++pandocExecutable :: Functor f =>+     (FilePath -> f FilePath) -> PandocOptions -> f PandocOptions+pandocExecutable f po = (\e -> po { _pandocExecutable = e})+                       <$> f (_pandocExecutable po)++pandocArgs :: Functor f =>+     ([String] -> f [String]) -> PandocOptions -> f PandocOptions+pandocArgs f po = (\a -> po { _pandocArgs = a}) <$> f (_pandocArgs po)++pandocBaseDir :: Functor f =>+     (Maybe FilePath -> f (Maybe FilePath)) -> PandocOptions -> f PandocOptions+pandocBaseDir f po = (\b -> po {_pandocBaseDir = b }) <$> f (_pandocBaseDir po)++pandocWrapDiv :: Functor f =>+     (Maybe Text -> f (Maybe Text)) -> PandocOptions -> f PandocOptions+pandocWrapDiv f po = (\w -> po {_pandocWrapDiv = w}) <$> f (_pandocWrapDiv po)++------------------------------------------------------------------------------+-- | Default name for the markdown splice.+markdownTag :: Text+markdownTag = "markdown"++------------------------------------------------------------------------------+-- | Default markdown splice with executable "pandoc"+markdownSplice :: MonadIO m => Splice m+markdownSplice= pandocSplice defaultPandocOptions++-- | Implementation of the markdown splice.+pandocSplice :: MonadIO m => PandocOptions -> Splice m+pandocSplice PandocOptions{..} = do+    templateDir <- liftM (fmap takeDirectory) getTemplateFilePath+    pdMD <- liftIO $ findExecutable _pandocExecutable++    pandocExe <- case pdMD of+       Nothing -> liftIO $ throwIO PandocMissingException+       Just pd -> return pd+    let withDir tp = fromMaybe tp _pandocBaseDir+        pandocFile f tp = pandocWith pandocExe _pandocArgs (withDir tp) f+    tree <- getParamNode+    (source,markup) <- liftIO $+        case getAttribute "file" tree of+            Just f  -> do+                m <- maybe (liftIO $ throwIO NoMarkdownFileException )+                           (pandocFile (T.unpack f))+                           templateDir+                return (T.unpack f,m)+            Nothing -> do+                m <- pandocWithBS pandocExe _pandocArgs $ T.encodeUtf8 $ nodeText tree+                return ("inline_splice",m)++    let ee = parseHTML source markup+        nodeAttrs = case tree of+          Element _ a _ -> a+          _ -> []+        nodeClass = lookup "class" nodeAttrs+        attrs = filter (\(name, _) -> name /= "class" && name /= "file") nodeAttrs+    case ee of+      Left e  -> throw $ MarkdownException+                       $ BC.pack ("Error parsing markdown output: " ++ e)+      Right d -> return $ wrapResult nodeClass attrs (docContent d)++  where+    wrapResult nodeClass attrs body = case _pandocWrapDiv of+        Nothing -> body+        Just cls -> let finalAttrs = ("class", appendClass nodeClass cls):attrs+                    in [Element "div" finalAttrs  body]+    appendClass Nothing cls = cls+    appendClass (Just orig) cls = T.concat [orig, " ", cls]+++pandocWith :: FilePath -> [String] -> FilePath -> FilePath -> IO ByteString+pandocWith path args templateDir inputFile = do+    (ex, sout, serr) <- readProcessWithExitCode' path args' ""++    when (isFail ex) $ throw $ MarkdownException serr+    return sout++  where+    isFail ExitSuccess = False+    isFail _           = True++    args' = args ++ [templateDir </> inputFile ]++pandocWithBS :: FilePath -> [String] -> ByteString -> IO ByteString+pandocWithBS pandocPath args s = do+    -- using the crummy string functions for convenience here+    (ex, sout, serr) <- readProcessWithExitCode' pandocPath args s++    when (isFail ex) $ throw $ MarkdownException serr+    return sout++  where+    isFail ExitSuccess = False+    isFail _           = True+++-- 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)
+ src/Heist/TemplateDirectory.hs view
@@ -0,0 +1,105 @@+{-|++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.Monad+import           Control.Monad.Trans+import           Heist+import           Heist.Internal.Types+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+    -- namespaced tag.+    -> IO (Either [String] (TemplateDirectory n))+newTemplateDirectory dir hc = do+    let sc = (_hcSpliceConfig hc) { _scTemplateLocations = [loadTemplates dir] }+    let hc' = hc { _hcSpliceConfig = sc }+    epair <- initHeistWithCacheTag hc'+    case epair of+      Left es -> return $ Left es+      Right (hs,cts) -> do+        tsMVar <- liftIO $ newMVar hs+        ctsMVar <- liftIO $ newMVar cts+        return $ Right $ 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 <- 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+    let sc = (_hcSpliceConfig hc) { _scTemplateLocations = [loadTemplates p] }+    ehs <- initHeistWithCacheTag (hc { _hcSpliceConfig = sc })+    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: " :: String)
− src/Text/Templating/Heist.hs 
@@ -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.-
− src/Text/Templating/Heist/Internal.hs 
@@ -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-
− src/Text/Templating/Heist/Splices.hs 
@@ -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-
− src/Text/Templating/Heist/Splices/Apply.hs 
@@ -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--
− src/Text/Templating/Heist/Splices/Bind.hs 
@@ -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)--
− src/Text/Templating/Heist/Splices/BindStrict.hs 
@@ -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)
− src/Text/Templating/Heist/Splices/Cache.hs 
@@ -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----
− src/Text/Templating/Heist/Splices/Html.hs 
@@ -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)-
− src/Text/Templating/Heist/Splices/Ignore.hs 
@@ -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 []--
− src/Text/Templating/Heist/Splices/Json.hs 
@@ -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
− src/Text/Templating/Heist/Splices/Markdown.hs 
@@ -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)----
− src/Text/Templating/Heist/TemplateDirectory.hs 
@@ -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: "
− src/Text/Templating/Heist/Types.hs 
@@ -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 #-}-
− test/.ghci 
@@ -1,5 +0,0 @@-:set -XOverloadedStrings-:set -Wall-:set -i../src-:set -isuite-:set -hide-package MonadCatchIO-mtl
− test/README 
@@ -1,1 +0,0 @@-Various test applications and such for the Snap Framework
− test/heist-testsuite.cabal 
@@ -1,40 +0,0 @@-name:           heist-testsuite-version:        0.1.1-build-type:     Simple-cabal-version:  >= 1.6--Executable testsuite-  hs-source-dirs:  ../src suite-  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,-    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---  ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded-  Extensions: OverloadedStrings-
− test/runTestsAndCoverage.sh 
@@ -1,48 +0,0 @@-#!/bin/sh--set -e--SUITE=./dist/build/testsuite/testsuite--rm -f testsuite.tix--if [ ! -f $SUITE ]; then-    cat <<EOF-Testsuite executable not found, please run:-    cabal configure -ftest-then-    cabal build-EOF-    exit;-fi--./dist/build/testsuite/testsuite -j4 -a1000 $*--DIR=dist/hpc--rm -Rf $DIR-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'--EXCL=""--for m in $EXCLUDES; do-    EXCL="$EXCL --exclude=$m"-done--hpc markup $EXCL --destdir=$DIR testsuite >/dev/null 2>&1--rm -f testsuite.tix--cat <<EOF--Test coverage report written to $DIR.-EOF
+ test/suite/Benchmark.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++------------------------------------------------------------------------------+import           Blaze.ByteString.Builder+import           Control.Concurrent+import           Control.Exception        (evaluate)+import           Control.Monad+import           Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT)+import           Criterion+import           Criterion.Main+import           Criterion.Measurement    hiding (getTime)+import qualified Data.ByteString          as B+import qualified Data.DList               as DL+import           Data.Maybe+import           Data.Monoid+import qualified Data.Text                as T+import           Data.Text.Encoding+import           Data.Time.Clock+import           System.Environment+import qualified Text.XmlHtml             as X+------------------------------------------------------------------------------+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.Internal.Types+------------------------------------------------------------------------------++loadWithCache baseDir = do+    etm <- runExceptT $ do+        let sc = SpliceConfig mempty defaultLoadTimeSplices mempty mempty+                              [loadTemplates baseDir] (const True)+        ExceptT $ initHeistWithCacheTag $ HeistConfig sc "" False+    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") (whnfIO 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+
+ test/suite/Heist/Compiled/Tests.hs view
@@ -0,0 +1,409 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Heist.Compiled.Tests where++import           Blaze.ByteString.Builder+import           Control.Applicative+import           Control.Exception+import           Control.Monad.Trans.Except+import           Control.Lens+import           Control.Monad.Trans+import           Data.Bifunctor (first)+import           Data.ByteString (ByteString)+import qualified Data.ByteString as B+import           Data.Char+import           Data.IORef+import           Data.Maybe+import           Data.Map.Syntax+import           Data.Monoid+import qualified Data.Set as Set+import qualified Data.Text as T+import           Data.Text.Encoding+import           Test.Framework (Test)+import           Test.Framework.Providers.HUnit+import qualified Test.HUnit as H+import qualified Text.XmlHtml as X+++------------------------------------------------------------------------------+import           Heist+import           Heist.Compiled+import           Heist.Compiled.Internal+import           Heist.Internal.Types+import           Heist.Tutorial.CompiledSplices+import           Heist.TestCommon++-- NOTE: We can't test compiled templates on the templates directory as it+-- stands today because that directory contains some error conditions such as+-- 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+        , testCase     "compiled/namespace1"    namespaceTest1+        , testCase     "compiled/namespace2"    namespaceTest2+        , testCase     "compiled/namespace3"    namespaceTest3+        , testCase     "compiled/namespace4"    namespaceTest4+        , testCase     "compiled/namespace5"    namespaceTest5+        , testCase     "compiled/no-ns-splices" noNsSplices+        , testCase     "compiled/ns-nested"     nsNestedUnused+        , testCase     "compiled/nsbind"        nsBindTest+        , testCase     "compiled/nsbinderr"     nsBindErrorTest+        , testCase     "compiled/nscall"        nsCallTest+        , testCase     "compiled/nscallerr"     nsCallErrTest+        , testCase     "compiled/nsbindstack"   nsBindStackTest+        , testCase     "compiled/doctype"       doctypeTest+        , testCase     "compiled/exceptions"    exceptionsTest+        , testCase     "compiled/defer"         deferTest+        ]++simpleCompiledTest :: IO ()+simpleCompiledTest = do+    res <- runWithStateSplice "templates"+    H.assertEqual "compiled state splice" expected res+  where+    expected =+      mappend doctype "\n\n<html>\n3\n</html>\n"++peopleTest :: IO ()+peopleTest = do+    res <- personListTest "templates"+    H.assertEqual "people splice" expected res+  where+    expected =+      "\n<p>Doe, John: 42&#32;years old</p>\n\n<p>Smith, Jane: 21&#32;years old</p>\n\n"++templateHC :: HeistConfig IO+templateHC = HeistConfig sc "" False+  where+    sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices+                & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu"))+                & scTemplateLocations .~ [loadTemplates "templates"]++genericTest :: String -> ByteString -> ByteString -> IO ()+genericTest nm template expected = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist templateHC+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs template+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual nm (Right expected) res++doctypeTest :: IO ()+doctypeTest = genericTest "doctype test" "rss" expected+  where+    expected = encodeUtf8+      "<rss><channel><link>http://www.devalot.com/</link></channel></rss>\n"++namespaceTest1 :: IO ()+namespaceTest1 = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist templateHC+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "namespaces"+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual "namespace test 1" (Right expected) res+  where+    expected = "Alpha\naoeu\nBeta\n<h:foo aoeu='htns'>Inside h:foo</h:foo>\nEnd\n"+++namespaceTest2 :: IO ()+namespaceTest2 = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist $ templateHC & hcErrorNotBound .~ True+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "namespaces"+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual "namespace test 2" (Right expected) res+  where+    expected = "Alpha\naoeu\nBeta\n<h:foo aoeu='htns'>Inside h:foo</h:foo>\nEnd\n"+++namespaceTest3 :: IO ()+namespaceTest3 = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "namespaces"+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual "namespace test 3" (Right expected) res+  where+    expected = "Alpha\n<foo aoeu='htns'>Inside foo</foo>\nBeta\naoeu\nEnd\n"+++namespaceTest4 :: IO ()+namespaceTest4 = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"+                                     & hcErrorNotBound .~ True+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "namespaces"+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual "namespace test 4" (Right expected) res+  where+    expected = "Alpha\n<foo aoeu='htns'>Inside foo</foo>\nBeta\naoeu\nEnd\n"+++namespaceTest5 :: IO ()+namespaceTest5 = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"+                                     & hcCompiledSplices .~ mempty+                                     & hcErrorNotBound .~ True+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "namespaces"+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual "namespace test 5" (Left ["templates/namespaces.tpl: No splice bound for h:foo"]) res++------------------------------------------------------------------------------+-- | The templates-no-ns directory should have no tags beginning with h: so+-- this test will throw an error.+noNsSplices :: IO ()+noNsSplices = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist hc+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "test"+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual "noNsSplices" (Left [noNamespaceSplicesMsg "h:"]) res+  where+    hc = HeistConfig sc "h" True+    sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices+                & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu"))+                & scTemplateLocations .~ [loadTemplates "templates-no-ns"]+++------------------------------------------------------------------------------+-- | Test that no namespace splice message works correctly when there are no+-- top level splices used+nsNestedUnused :: IO ()+nsNestedUnused = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist hc+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "test"+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual "ns nested unused warn test" (Right "<div>aeou</div>\n") res+  where+    hc = HeistConfig sc "h" False+    sc = mempty & scCompiledSplices .~ ("foo" ## return $ yieldPureText "aeou")+                & scTemplateLocations .~ [loadTemplates "templates-ns-nested"]+++nsBindTemplateHC :: String -> HeistConfig IO+nsBindTemplateHC dir = HeistConfig sc "h" False+  where+    sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices+                & scCompiledSplices .~ nsBindTestSplices+                & scTemplateLocations .~ [loadTemplates dir]+++nsBindTestSplices :: Splices (Splice IO)+nsBindTestSplices = do+    "call" ## do+        tpl <- withSplices (callTemplate "_call")+               nsBindSubSplices (return ())+        return $ yieldRuntime $ codeGen tpl+    "main" ## nsBindSubImpl (return ())+    "main2" ## nsBindSubImpl (return ())+++nsBindSubImpl :: RuntimeSplice IO b -> Splice IO+nsBindSubImpl _ = do+    tpl <- withSplices runChildren nsBindSubSplices (return ())+    return $ yieldRuntime $ codeGen tpl+++nsBindSubSplices :: Splices (RuntimeSplice IO () -> Splice IO)+nsBindSubSplices = do+    "sub" ## pureSplice . textSplice $ const "asdf"+    "recurse" ## nsBindSubImpl+++nsBindTest :: IO ()+nsBindTest = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind")+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "nsbind"+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual "namespace bind test" (Right expected)  res+  where+    expected = "Alpha\n\nBeta\nasdf\nGamma\n<sub></sub>\n\n"+++------------------------------------------------------------------------------+-- | Test splice error reporting.+nsBindErrorTest :: IO ()+nsBindErrorTest = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind")+                                     & hcErrorNotBound .~ True+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "nsbinderror"+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual "namespace bind error test" (Left [ err1, err2, err3 ])  res+  where+    err1 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid3\n   ... via templates-nsbind/nsbinderror.tpl: h:main2\nBound splices: h:call h:main h:main2 h:recurse h:sub\nNode: Element {elementTag = \"h:invalid3\", elementAttrs = [], elementChildren = []}"+    err2 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid2\n   ... via templates-nsbind/nsbinderror.tpl: h:recurse\n   ... via templates-nsbind/nsbinderror.tpl: h:main\nBound splices: h:call h:main h:main2 h:recurse h:sub\nNode: Element {elementTag = \"h:invalid2\", elementAttrs = [], elementChildren = []}"+    err3 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid1\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:invalid1\", elementAttrs = [], elementChildren = []}"+++------------------------------------------------------------------------------+-- | Test splice error data structure.+nsBindStackTest :: IO ()+nsBindStackTest = do+    res <- initHeist (nsBindTemplateHC "templates-nsbind") >>=+           return . (either Left (Right . _spliceErrors))++    H.assertEqual "namespace bind stack test" (Right [ err1, err2, err3 ]) res+  where+    err1 = SpliceError [ ( ["nsbinderror"]+                         , Just "templates-nsbind/nsbinderror.tpl"+                         , "h:main2") ]+               (Just "templates-nsbind/nsbinderror.tpl")+               ["h:call","h:main","h:main2","h:recurse","h:sub"]+               (X.Element "h:invalid3" [] [])+               "No splice bound for h:invalid3"+    err2 = SpliceError [ ( ["nsbinderror"]+                         , Just "templates-nsbind/nsbinderror.tpl"+                         , "h:recurse")+                       , ( ["nsbinderror"]+                         , Just "templates-nsbind/nsbinderror.tpl"+                         ,"h:main") ]+               (Just "templates-nsbind/nsbinderror.tpl")+               ["h:call","h:main","h:main2","h:recurse","h:sub"]+               (X.Element "h:invalid2" [] [])+               "No splice bound for h:invalid2"+    err3 = SpliceError []+               (Just "templates-nsbind/nsbinderror.tpl")+               ["h:call","h:main","h:main2"]+               (X.Element "h:invalid1" [] [])+               "No splice bound for h:invalid1"+++nsCallTest :: IO ()+nsCallTest = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall")+                                     & hcErrorNotBound .~ True+                                     & hcCompiledTemplateFilter .~ nsFilter+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "nscall"+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual "namespace call test" (Right "Top\n\nInside 1\nCalled\nasdf\n\nInside 2\n\n") res+  where+    nsFilter = (/=) (fromIntegral $ ord '_') . B.head . head+++nsCallErrTest :: IO ()+nsCallErrTest = do+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall")+                                     & hcErrorNotBound .~ True+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "nscall"+        b <- lift $ fst runner+        return $ toByteString b++    H.assertEqual "namespace call error test"+      (Left $ Set.fromList [ err1, err2 ])+      (first Set.fromList res)+  where+    err1 = "templates-nscall/_call.tpl: No splice bound for h:sub\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:sub\", elementAttrs = [], elementChildren = []}"+    err2 = "templates-nscall/_invalid.tpl: No splice bound for h:invalid\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:invalid\", elementAttrs = [], elementChildren = []}"+++------------------------------------------------------------------------------+-- | Test exception handling in template load.+exceptionsTest :: IO ()+exceptionsTest = do+    res <- Control.Exception.catch+             (runExceptT $ do+                  hs <- ExceptT $ initHeist hc+                  -- The rest needed only for type inference.+                  runner <- noteT ["Error rendering"] $ hoistMaybe $+                              renderTemplate hs ""+                  _ <- lift $ fst runner+                  throwE ["Unexpected success"])+             (\(e :: CompileException) -> return $ case lines (show e) of+                 l:ls -> Right l+                 _ -> Left [show e])+    H.assertEqual "exceptions" (Right firstLine) res++  where+    firstLine = "templates-loaderror/_error.tpl: Exception in splice compile: Prelude.read: no parse"++    hc = HeistConfig sc "h" True+    sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices+                & scCompiledSplices .~ splices+                & scTemplateLocations .~ [loadTemplates "templates-loaderror"]+    splices = do+        "call1" ## callTemplate "_ok"+        "call2" ## callTemplate "_error"+        "adder" ## do+            value :: Int <- read . T.unpack . fromJust .+                              X.getAttribute "value" <$> getParamNode+            return $ yieldPureText $ T.pack $ show $ 1 + value+++------------------------------------------------------------------------------+-- | Test for defer functions to see that they correctly save the result of+-- a runtime computation.+deferTest :: IO ()+deferTest = do+    rs <- mapM newIORef $ replicate 5 (0 :: Int)+    res <- runExceptT $ do+        hs <- ExceptT $ initHeist $ hc rs+        runner <- noteT ["Error rendering"] $ hoistMaybe $+                    renderTemplate hs "test"+        b <- lift $ fst runner+        return $ toByteString b++    vs <- mapM readIORef rs+    H.assertEqual "defer test" ([2, 1, 1, 1, 1], Right msg) (vs, res)+  where+    msg = "1&#32;2\n1&#32;1\n1&#32;1\n\n1&#32;1\n"+    hc rs = HeistConfig (sc rs) "h" True+    sc rs = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices+                   & scCompiledSplices .~ (splices rs)+                   & scTemplateLocations .~ [loadTemplates "templates-defer"]+    splices [r1, r2, r3, r4, r5] = do+        "plain" ## subSplice $ addAndReturn r1+        "defer" ## deferMap return subSplice $ addAndReturn r2+        "maydefer" ## mayDeferMap (return . Just) subSplice $ addAndReturn r3+        "maydefer2" ## mayDeferMap (const $ return Nothing) subSplice $+                         addAndReturn r4+        "defermany" ## deferMany subSplice $ addAndReturn' r5+    subSplice =+        withSplices runChildren+          ("use" ## \n -> return $ yieldRuntimeText $ return . T.pack . show =<< n)+    addAndReturn r = liftIO $ modifyIORef r (+1) >> readIORef r+    addAndReturn' r = liftIO $ do+        modifyIORef r (+1)+        val <- readIORef r+        return [val]
+ test/suite/Heist/Interpreted/Tests.hs view
@@ -0,0 +1,670 @@+{-# 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.Monad+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.Map.Syntax+import           Data.Maybe+import           Data.Monoid+import           Data.Text                            (Text)+import qualified Data.Text                            as T+import qualified Data.Text.Encoding                   as T+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.Internal.Types+import           Heist.Interpreted.Internal+import           Heist.Splices.Apply+import           Heist.Splices.Ignore+import           Heist.Splices.Json+import           Heist.Splices.Markdown+import           Heist.TestCommon+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/pandoc"                pandocTest+        , testCase     "heist/pandoc_div"            pandocDivTest+        , 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+        , testCase     "heist/renderXML"             xmlNotHtmlTest+        ]+++------------------------------------------------------------------------------+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 mempty mempty mempty+            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 mempty mempty mempty mempty+    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" mempty mempty mempty mempty+    let tm = either (error . unlines) _templateMap ets+    hs <- loadEmpty mempty mempty mempty mempty+    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" mempty mempty mempty mempty+    either (error "Error loading templates")+           (\ts -> do let tm = _templateMap ts+                      H.assertEqual "loadTest size" 41 $ Map.size tm+           ) ets+++------------------------------------------------------------------------------+fsLoadTest :: H.Assertion+fsLoadTest = do+    ets <- loadIO "templates" mempty mempty mempty mempty+    let tm = either (error "Error loading templates") _templateMap ets+    es <- loadEmpty mempty mempty mempty mempty+    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" mempty mempty mempty mempty+    either (error "Error loading templates")+           (\ts -> do t <- renderTemplate ts ""+                      H.assertBool "renderNoName" $ isNothing t+           ) ets+++------------------------------------------------------------------------------+doctypeTest :: H.Assertion+doctypeTest = do+    ets <- loadT "templates" mempty mempty mempty mempty+    let ts = either (error "Error loading templates") id ets+    Just (indexDoc, _) <- renderTemplate ts "index"+    H.assertEqual "index doctype test" indexRes $ toByteString $ indexDoc+    Just (_, _) <- renderTemplate ts "ioc"+    H.assertEqual "ioc doctype test" indexRes $ toByteString $ indexDoc+  where+    indexRes = B.concat+        [doctype+        ,"\n\n<html>\n<div id='pre_{att}_post'>\n/index\n</div>\n</html>\n"+        ]++------------------------------------------------------------------------------+attrSubstTest :: H.Assertion+attrSubstTest = do+    ets <- loadT "templates" mempty mempty mempty mempty+    let ts = either (error "Error loading templates") id ets+    check "attr subst 1" (bindSplices splices ts) out1+    check "attr subst 2" ts out2++  where+    splices = defaultLoadTimeSplices `mappend`+        ("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+        ["<mytag flag>Empty attribute</mytag>"+        ,"<mytag flag='abc${bar}'>No ident capture</mytag>"+        ,"<div id='pre_meaning_of_everything_post'></div>"+        ]+    out2 = B.unlines+        ["<mytag flag>Empty attribute</mytag>"+        ,"<mytag flag='abc${bar}'>No ident capture</mytag>"+        ,"<div id='pre_${foo}_post'></div>"+        ]+++------------------------------------------------------------------------------+bindAttrTest :: H.Assertion+bindAttrTest = do+    ets <- loadT "templates" mempty mempty mempty mempty+    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 =+    "<div class='markdown'><p>This <em>is</em> a test.</p></div>"++------------------------------------------------------------------------------+-- | Markdown test on a file+markdownTest :: H.Assertion+markdownTest = renderTest "markdown" markdownHtmlExpected++-----------------------------------------------------------------------------++-- | Pandoc test on a file+pandocTest :: H.Assertion+pandocTest = renderTest "pandoc" pandocNoDivHtmlExpected++pandocDivTest :: H.Assertion+pandocDivTest = renderTest "pandocdiv" pandocDivHtmlExpected++pandocNoDivHtmlExpected :: ByteString+pandocNoDivHtmlExpected = "<p>This <em>is</em> a test.</p>"++pandocDivHtmlExpected :: ByteString+pandocDivHtmlExpected =+  "<div class='foo test' id='pandoc'><p>This <em>is</em> a test.</p></div>"+  -- Implementaton dependent. Class is prepended in current implementation,+  -- it will be first attribute++pandocTestSplices :: Splices (Splice IO)+pandocTestSplices = do+    "pandocnodiv" ## pandocSplice optsNoDiv+    "pandocdiv"   ## pandocSplice optsDiv+  where+    optsNoDiv = setPandocWrapDiv Nothing defaultPandocOptions+    optsDiv = setPandocWrapDiv (Just "test") defaultPandocOptions++------------------------------------------------------------------------------+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 = "<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" mempty pandocTestSplices mempty mempty+    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 splices = do+                "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\" }"+                                ])+        let ts = bindSplices splices ts0+        Just (doc, _) <- renderTemplate ts templateName+        let result = B.filter (/= '\n') (toByteString doc)+        H.assertEqual ("Should match " ++ (show str)) str result+++------------------------------------------------------------------------------+-- | Expansion of a bound name inside a title-tag+titleExpansion :: H.Assertion+titleExpansion = renderTest "title_expansion" expected+  where+    expected = "<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 = "<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+    hs <- loadEmpty mempty mempty mempty mempty+    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 Nothing result))+++------------------------------------------------------------------------------+applyTest :: H.Assertion+applyTest = do+    es <- loadEmpty mempty mempty mempty mempty+    res <- evalHeistT applyImpl+        (X.Element "apply" [("template", "nonexistant")] []) es++    H.assertEqual "apply nothing" [] res+++------------------------------------------------------------------------------+ignoreTest :: H.Assertion+ignoreTest = do+    es <- loadEmpty mempty mempty mempty mempty+    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++------------------------------------------------------------------------------+xmlNotHtmlTest :: H.Assertion+xmlNotHtmlTest = renderTest "rss" expected where+  expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><rss><channel><link>http://www.devalot.com/</link></channel></rss>"++------------------------------------------------------------------------------+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 mempty mempty mempty mempty+        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 mempty mempty mempty+    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
+ test/suite/Heist/TestCommon.hs view
@@ -0,0 +1,134 @@+module Heist.TestCommon where++------------------------------------------------------------------------------+import           Blaze.ByteString.Builder+import           Control.Monad.Trans+import           Control.Monad.Trans.Maybe  (MaybeT(..), runMaybeT)+import           Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT)+import           Data.ByteString.Char8      (ByteString)+import qualified Data.ByteString.Char8      as B+import           Data.Maybe+import           Data.Monoid+++------------------------------------------------------------------------------+import           Heist+import qualified Heist.Compiled             as C+import           Heist.Internal.Types+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 :: MonadIO m+      => FilePath+      -> Splices (I.Splice m)+      -> Splices (I.Splice IO)+      -> Splices (C.Splice m)+      -> Splices (AttrSplice m)+      -> IO (Either [String] (HeistState m))+loadT baseDir a b c d = runExceptT $ do+    let sc = SpliceConfig (defaultInterpretedSplices `mappend` a)+                          (defaultLoadTimeSplices `mappend` b) c d+                          [loadTemplates baseDir] (const True)+    ExceptT $ initHeist $ HeistConfig sc "" False+++------------------------------------------------------------------------------+loadIO :: FilePath+       -> Splices (I.Splice IO)+       -> Splices (I.Splice IO)+       -> Splices (C.Splice IO)+       -> Splices (AttrSplice IO)+       -> IO (Either [String] (HeistState IO))+loadIO baseDir a b c d = runExceptT $ do+    let sc = SpliceConfig (defaultInterpretedSplices >> a)+                          (defaultLoadTimeSplices >> b) c d+                          [loadTemplates baseDir] (const True)+    ExceptT $ initHeist $ HeistConfig sc "" False+++------------------------------------------------------------------------------+loadHS :: FilePath -> IO (HeistState IO)+loadHS baseDir = do+    etm <- runExceptT $ do+        let sc = SpliceConfig defaultInterpretedSplices+                              defaultLoadTimeSplices mempty mempty+                              [loadTemplates baseDir] (const True)+        ExceptT $ initHeist $ HeistConfig sc "" False+    either (error . concat) return etm+++loadEmpty :: Splices (I.Splice IO)+          -> Splices (I.Splice IO)+          -> Splices (C.Splice IO)+          -> Splices (AttrSplice IO)+          -> IO (HeistState IO)+loadEmpty a b c d = do+    let sc = SpliceConfig (defaultInterpretedSplices `mappend` a)+                          (defaultLoadTimeSplices `mappend` b) c d mempty+                          (const True)+    res <- initHeist $ HeistConfig sc "" False+    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+++------------------------------------------------------------------------------+isLeft :: Either e a -> Bool+isLeft (Left _) = True+isLeft _        = False+++------------------------------------------------------------------------------+noteT :: Monad m => e -> MaybeT m a -> ExceptT e m a+noteT e ma = do+  x <- lift $ runMaybeT ma+  case x of+    Nothing -> ExceptT $ return (Left  e)+    Just a  -> ExceptT $ return (Right a)+++------------------------------------------------------------------------------+hoistMaybe :: Monad m => Maybe a -> MaybeT m a+hoistMaybe = MaybeT . return
+ test/suite/Heist/Tests.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE CPP              #-}+{-# 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.Map.Syntax+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.Internal.Types+import qualified Heist.Interpreted               as I+import           Heist.Splices.Cache+import           Heist.Splices.Html+import           Heist.TemplateDirectory+import           Heist.Tutorial.AttributeSplices+import           Heist.Tutorial.CompiledSplices++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" mempty mempty mempty mempty+    either (H.assertEqual "load errors test" expected . sort)+           (const $ H.assertFailure "No failure when loading templates-bad")+           ets+  where+    expected = sort+#if MIN_VERSION_base(4,9,0)+        ["templates-bad/apply-missing-attr.tpl: must supply \"template\" attribute in <apply>\nCallStack (from HasCallStack):\n  error, called at src/Heist/Common.hs:76:15 in main:Heist.Common"+        ,"templates-bad/apply-template-not-found.tpl: apply tag cannot find template \"/page\"\nCallStack (from HasCallStack):\n  error, called at src/Heist/Common.hs:76:15 in main:Heist.Common"+        ,"templates-bad/bind-infinite-loop.tpl: template recursion exceeded max depth, you probably have infinite splice recursion!\nCallStack (from HasCallStack):\n  error, called at src/Heist/Common.hs:76:15 in main:Heist.Common"+        ,"templates-bad/bind-missing-attr.tpl: must supply \"tag\" attribute in <bind>\nCallStack (from HasCallStack):\n  error, called at src/Heist/Common.hs:76:15 in main:Heist.Common"+        ]+#else+        ["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>"+        ]+#endif+++attrSpliceTest :: IO ()+attrSpliceTest = do+    ehs <- loadT "templates" mempty mempty mempty+                 ("autocheck" ## lift . 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 = "<input type='checkbox' value='foo' checked />\n<input type='checkbox' value='bar' />\n"+    expected2 = "<input type='checkbox' value='foo' />\n<input type='checkbox' value='bar' checked />\n"+    expected3 = "<input type=\"checkbox\" value=\"foo\" checked />\n<input type=\"checkbox\" value=\"bar\" />\n"+    expected4 = "<input type=\"checkbox\" value=\"foo\" />\n<input type=\"checkbox\" value=\"bar\" checked />\n"++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)+        sc = SpliceConfig rSplices mempty dSplices mempty mempty (const True)+        hc = HeistConfig sc "" False+    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" mempty (htmlTag ## htmlImpl) mempty mempty+    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>\n\n"+      ]++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"+      ["\nThis is a test."+      ,"===bind content===\nAnother test line."+      ,"apply content\nLast test line."+      ,"\n"+      ]+    iExpected = B.unlines+      ["\nThis 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" expected cOut++    iOut <- iRender hs "backslash"+    H.assertEqual "interpreted failure" expected iOut+  where+    expected = "<foo regex='abc\\d+\\\\e'></foo>\n"+
+ test/suite/Heist/Tutorial/AttributeSplices.lhs view
@@ -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>+
+ test/suite/Heist/Tutorial/CompiledSplices.lhs view
@@ -0,0 +1,274 @@+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++> import           Control.Applicative+> import           Control.Lens+> import           Data.Map.Syntax++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+>      -> Splices (C.Splice n)+>      -> IO (HeistState n)+> load baseDir splices = do+>     tmap <- runExceptT $ do+>         let sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices+>                         & scCompiledSplices .~ splices+>                         & scTemplateLocations .~ [loadTemplates baseDir]+>         ExceptT $ initHeist $ emptyHeistConfig & hcNamespace .~ ""+>                                      & hcErrorNotBound .~ False+>                                      & hcSpliceConfig .~ sc+>     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+>     }+> +> personSplices :: Monad n+>              => Splices (RuntimeSplice n Person -> C.Splice n)+> personSplices = mapV (C.pureSplice . C.textSplice) $ do+>     "firstName" ## pFirstName+>     "lastName" ## pLastName+>     "age" ## pack . show . pAge+> +> peopleSplice :: (Monad n)+>              => RuntimeSplice n [Person]+>              -> C.Splice n+> peopleSplice = C.manyWithSplices C.runChildren personSplices+> +> allPeopleSplice :: C.Splice (StateT [Person] IO)+> allPeopleSplice = peopleSplice (lift 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+<     promise <- C.newEmptyPromise+<     outputChildren <- C.withSplices C.runChildren splices (C.getPromise promise)+<     return $ C.yieldRuntime $ do         +<         -- :: RuntimeSplice m Builder+<         mname <- lift $ getParam "username"+<         let err = return $ fromByteString "Must supply a username"+<             single name = do          +<                 euser <- lift $ lookupUser name+<                 either (return . fromByteString . encodeUtf8 . T.pack)+<                        doUser euser+<               where+<                 doUser value = do+<                   C.putPromise promise (name, value)+<                   C.codeGen outputChildren+<         maybe err single mname+<   +<   +< splices :: Monad n+<         => Splices (RuntimeSplice n (Text, Text) -> C.Splice n)+< splices = mapS (C.pureSplice . C.htmlNodeSplice) $ do+<   "user"  ## (:[]) . TextNode . fst+<   "value" ## (:[]) . TextNode . snd+
+ test/suite/Heist/Tutorial/Imports.hs view
@@ -0,0 +1,26 @@+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+  , runExceptT+  , ExceptT(..)+  ) where++import           Blaze.ByteString.Builder+import           Control.Monad+import           Control.Monad.Trans+import           Control.Monad.Trans.Except (ExceptT(..), runExceptT)+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+
test/suite/TestSuite.hs view
@@ -1,11 +1,21 @@ module Main where +import System.Directory 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+main = do+    -- Need to change directory after we switched to cabal test infra+    setCurrentDirectory "test"+    defaultMain 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                 ]
− test/suite/Text/Templating/Heist/Tests.hs 
@@ -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-
+ test/templates-bad/apply-missing-attr.tpl view
@@ -0,0 +1,3 @@+<apply>+noroot+</apply>
+ test/templates-bad/apply-template-not-found.tpl view
@@ -0,0 +1,3 @@+<apply template="/page">+This template is missing+</apply>
+ test/templates-bad/bind-infinite-loop.tpl view
@@ -0,0 +1,2 @@+<bind tag="foo"><p>line</p><foo/></bind>+<foo/>
+ test/templates-bad/bind-missing-attr.tpl view
@@ -0,0 +1,2 @@+<bind><p>line</p></bind>+<foo/>
+ test/templates-defer/test.tpl view
@@ -0,0 +1,5 @@+<h:plain><h:use/> <h:use/></h:plain>+<h:defer><h:use/> <h:use/></h:defer>+<h:maydefer><h:use/> <h:use/></h:maydefer>+<h:maydefer2><h:use/> <h:use/></h:maydefer2>+<h:defermany><h:use/> <h:use/></h:defermany>
+ test/templates-loaderror/_error.tpl view
@@ -0,0 +1,1 @@+<h:adder value="noparse"/>
+ test/templates-loaderror/_ok.tpl view
@@ -0,0 +1,1 @@+<h:adder value="1"/>
+ test/templates-loaderror/test.tpl view
@@ -0,0 +1,3 @@+<h:call1/>+<h:call2/>+<h:call1/>
+ test/templates-ns-nested/test.tpl view
@@ -0,0 +1,1 @@+<div><h:foo/></div>
+ test/templates-nsbind/nsbind.tpl view
@@ -0,0 +1,7 @@+Alpha+<h:main>+Beta+<h:sub/>+Gamma+<sub/>+</h:main>
+ test/templates-nsbind/nsbinderror.tpl view
@@ -0,0 +1,10 @@+Alpha+<h:invalid1/>+<h:main>+<h:recurse>+<h:invalid2/>+</h:recurse>+</h:main>+<h:main2>+<h:invalid3/>+</h:main2>
+ test/templates-nscall/_call.tpl view
@@ -0,0 +1,2 @@+Called+<h:sub/>
+ test/templates-nscall/_invalid.tpl view
@@ -0,0 +1,1 @@+<h:invalid/>
+ test/templates-nscall/nscall.tpl view
@@ -0,0 +1,6 @@+Top+<h:main>+Inside 1+<h:call/>+Inside 2+</h:main>
+ test/templates/attr_splice.tpl view
@@ -0,0 +1,2 @@+<input type="checkbox" autocheck="foo"/>+<input type="checkbox" autocheck="bar"/>
test/templates/attrs.tpl view
@@ -1,3 +1,3 @@ <mytag flag="">Empty attribute</mytag>-<mytag flag="abc\${foo}">No ident capture</mytag>+<mytag flag="abc${bar}">No ident capture</mytag> <div id="pre_${foo}_post"/>
+ test/templates/attrsubtest1.tpl view
@@ -0,0 +1,1 @@+<apply-content />
+ test/templates/attrsubtest2.tpl view
@@ -0,0 +1,1 @@+<bind tag="randName284">asdf</bind><apply template="attrsubtest1"><a href="${randName284}">link</a></apply><a href="before$after">foo</a>
+ test/templates/backslash.tpl view
@@ -0,0 +1,1 @@+<foo regex='abc\d+\\e'/>
+ test/templates/bind-apply-interaction/_outer.tpl view
@@ -0,0 +1,6 @@+<bind tag="foo">===<bind-content/>===</bind>+This is a test.+<foo>bind content</foo>+Another test line.+<apply-content/>+Last test line.
+ test/templates/bind-apply-interaction/caller.tpl view
@@ -0,0 +1,1 @@+<apply template="_outer">apply content</apply>
+ test/templates/bind_param.tpl view
@@ -0,0 +1,1 @@+<bind tag="item"><li><bind-content/> <foo/></li></bind><item><bind tag="foo">world</bind>Hi there<bind tag="bar">hello</bind></item>
+ test/templates/cache.tpl view
@@ -0,0 +1,3 @@+<cache ttl="0">+<foosplice/>+</cache>
+ test/templates/div_expansion.tpl view
@@ -0,0 +1,1 @@+<bind tag="mytext">foo</bind><div><mytext/></div>
− test/templates/etc.tpl 
@@ -1,3 +0,0 @@-/etc-<bind tag="foo"><p>line</p><foo/></bind>-<foo/>
+ test/templates/foo/markdown-chdir.tpl view
@@ -0,0 +1,5 @@+Different directory markdown+<apply template="markdown"/>+This file doesn't have any actual test code referring to it because compiled+Heist will automatically fail the whole test suite if the case tested by this+template isn't tested correctly.
+ test/templates/foo/markdown-origdir.tpl view
@@ -0,0 +1,3 @@+<apply template="page">+<markdown file="test2.md"/>+</apply>
+ test/templates/foo/test2.md view
@@ -0,0 +1,1 @@+This *is* another test.
+ test/templates/head_merge/index.tpl view
@@ -0,0 +1,6 @@+<apply template="wrap">+<head>+<link href="index-link">+</head>+<div>index page</div>+</apply>
+ test/templates/head_merge/nav.tpl view
@@ -0,0 +1,4 @@+<head>+<link href="nav-link">+</head>+<div>nav bar</div>
+ test/templates/head_merge/wrap.tpl view
@@ -0,0 +1,9 @@+<html>+<head>+<link href="wrapper-link">+</head>+<body>+<apply template="nav"/>+<apply-content/>+</body>+</html>
test/templates/ioc.tpl view
@@ -1,6 +1,3 @@-<apply>-Apply with no parameter.-</apply> <apply template="/page"> Inversion of control content </apply>
+ test/templates/json_array.tpl view
@@ -0,0 +1,1 @@+<jsonArray><value var="ctx.0"/>, <value var="ctx.1"/> and <with var="ctx.2"><value:deep/> <value:inside/></with></jsonArray>
+ test/templates/namespaces.tpl view
@@ -0,0 +1,5 @@+Alpha+<foo aoeu="htns">Inside foo</foo>+Beta+<h:foo aoeu="htns">Inside h:foo</h:foo>+End
− test/templates/noroot.tpl 
@@ -1,3 +0,0 @@-<apply>-noroot-</apply>
test/templates/page.tpl view
@@ -1,5 +1,5 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <wrapper>-<content/>+<apply-content/> </wrapper>
+ test/templates/pandoc.tpl view
@@ -0,0 +1,1 @@+<pandocnodiv file="test.md"/>
+ test/templates/pandocdiv.tpl view
@@ -0,0 +1,1 @@+<pandocdiv file="test.md" id="pandoc" class="foo"/>
+ test/templates/people.tpl view
@@ -0,0 +1,3 @@+<people>+<p><lastName/>, <firstName/>: <age/> years old</p>+</people>
+ test/templates/post.tpl view
@@ -0,0 +1,4 @@+<post>+<h1><postTitle/></h1>+<p><postBody/></p>+</post>
+ test/templates/rss.xtpl view
@@ -0,0 +1,1 @@+<rss><channel><link>http://www.devalot.com/</link></channel></rss>
+ test/templates/textarea_expansion.tpl view
@@ -0,0 +1,1 @@+<bind tag="mytext">foo</bind><textarea><mytext/></textarea>
+ test/templates/title_expansion.tpl view
@@ -0,0 +1,1 @@+<bind tag="mytext">foo</bind><title><mytext/></title>
test/templates/user/admin/main.tpl view
@@ -1,6 +1,4 @@ <html> Admin Page <apply template="menu"/>-<apply template="../menu"/>-<apply template="../../a"/> </html>