diff --git a/.ghci b/.ghci
--- a/.ghci
+++ b/.ghci
@@ -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
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -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
+
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,5 +1,7 @@
# Heist
+[](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,
special-id
-
very special
+
very special
gives you
diff --git a/heist.cabal b/heist.cabal
--- a/heist.cabal
+++ b/heist.cabal
@@ -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 \ 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
diff --git a/src/Data/HeterogeneousEnvironment.hs b/src/Data/HeterogeneousEnvironment.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/HeterogeneousEnvironment.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+
+------------------------------------------------------------------------------
+module Data.HeterogeneousEnvironment
+ ( KeyGen
+ , HeterogeneousEnvironment
+ , Key
+ , newKeyGen
+ , empty
+ , makeKey
+ , lookup
+ , insert
+ , delete
+ , adjust
+ , getKeyId
+ ) where
+
+------------------------------------------------------------------------------
+import Control.Monad
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IM
+import Data.IORef
+import GHC.Exts
+import Prelude hiding (lookup)
+import Unsafe.Coerce
+
+------------------------------------------------------------------------------
+data HeterogeneousEnvironment = HeterogeneousEnvironment (IntMap Any)
+newtype Key a = Key Int
+newtype KeyGen = KeyGen (IORef Int)
+
+
+------------------------------------------------------------------------------
+-- | If you use two different KeyGens to work with the same map, you deserve
+-- what you get.
+newKeyGen :: IO KeyGen
+newKeyGen = liftM KeyGen $ newIORef 0
+
+
+------------------------------------------------------------------------------
+getKeyId :: Key a -> Int
+getKeyId (Key x) = x
+
+
+------------------------------------------------------------------------------
+empty :: HeterogeneousEnvironment
+empty = HeterogeneousEnvironment $ IM.empty
+
+
+------------------------------------------------------------------------------
+makeKey :: KeyGen -> IO (Key a)
+makeKey (KeyGen gen) = do
+ k <- atomicModifyIORef gen nextKey
+ return $ Key k
+ where
+ nextKey !x = if x >= maxBound-1
+ then error "too many keys generated"
+ else let !x' = x+1 in (x',x)
+
+
+------------------------------------------------------------------------------
+lookup :: Key a -> HeterogeneousEnvironment -> Maybe a
+lookup (Key k) (HeterogeneousEnvironment m) = fmap unsafeCoerce $ IM.lookup k m
+
+
+------------------------------------------------------------------------------
+insert :: Key a -> a -> HeterogeneousEnvironment -> HeterogeneousEnvironment
+insert (Key k) v (HeterogeneousEnvironment m) = HeterogeneousEnvironment $
+ IM.insert k (unsafeCoerce v) m
+
+
+------------------------------------------------------------------------------
+delete :: Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment
+delete (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $
+ IM.delete k m
+
+
+------------------------------------------------------------------------------
+adjust :: (a -> a) -> Key a -> HeterogeneousEnvironment -> HeterogeneousEnvironment
+adjust f (Key k) (HeterogeneousEnvironment m) = HeterogeneousEnvironment $
+ IM.adjust f' k m
+ where
+ f' = unsafeCoerce . f . unsafeCoerce
diff --git a/src/Heist.hs b/src/Heist.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist.hs
@@ -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
diff --git a/src/Heist/Common.hs b/src/Heist/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Common.hs
@@ -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 })
+
+
diff --git a/src/Heist/Compiled.hs b/src/Heist/Compiled.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Compiled.hs
@@ -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.
diff --git a/src/Heist/Compiled/Internal.hs b/src/Heist/Compiled/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Compiled/Internal.hs
@@ -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 [ ""]
+ -- 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
+
+
diff --git a/src/Heist/Compiled/LowLevel.hs b/src/Heist/Compiled/LowLevel.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Compiled/LowLevel.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Heist.Compiled.LowLevel
+ (
+ -- * Lower level promise functions
+ Promise
+ , newEmptyPromise
+ , getPromise
+ , putPromise
+ , adjustPromise
+
+ ) where
+
+import Heist.Compiled.Internal
diff --git a/src/Heist/Internal/Types.hs b/src/Heist/Internal/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Internal/Types.hs
@@ -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
+
+
diff --git a/src/Heist/Internal/Types/HeistState.hs b/src/Heist/Internal/Types/HeistState.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Internal/Types/HeistState.hs
@@ -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.
+--
+-- >
+-- > To sleep, perchance to dream.
+-- >
+--
+-- 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
+
+
diff --git a/src/Heist/Interpreted.hs b/src/Heist/Interpreted.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Interpreted.hs
@@ -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)
+
diff --git a/src/Heist/Interpreted/Internal.hs b/src/Heist/Interpreted/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Interpreted/Internal.hs
@@ -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:
+--
+-- >
+-- >
+-- > ...
+-- >
+-- >
+--
+-- 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 \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 \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
diff --git a/src/Heist/Splices.hs b/src/Heist/Splices.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Splices.hs
@@ -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 \ 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 \ 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')
diff --git a/src/Heist/Splices/Apply.hs b/src/Heist/Splices/Apply.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Splices/Apply.hs
@@ -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 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
+-- 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
+ [" tag deprecated. Use"
+ ," or "
+ ]
+
diff --git a/src/Heist/Splices/Bind.hs b/src/Heist/Splices/Bind.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Splices/Bind.hs
@@ -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)
+
diff --git a/src/Heist/Splices/BindStrict.hs b/src/Heist/Splices/BindStrict.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Splices/BindStrict.hs
@@ -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)
diff --git a/src/Heist/Splices/Cache.hs b/src/Heist/Splices/Cache.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Splices/Cache.hs
@@ -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 }]
+
+
diff --git a/src/Heist/Splices/Html.hs b/src/Heist/Splices/Html.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Splices/Html.hs
@@ -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)
+
diff --git a/src/Heist/Splices/Ignore.hs b/src/Heist/Splices/Ignore.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Splices/Ignore.hs
@@ -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 []
+
+
diff --git a/src/Heist/Splices/Json.hs b/src/Heist/Splices/Json.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Splices/Json.hs
@@ -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 }
+--
+-- @\@ -- treats v_i as text
+-- @\@ -- treats v_i as HTML
+-- @\@ -- explodes v_i and runs its children
+--
+-- @\@ -- walks the JSON tree to find
+-- \"foo.bar.baz\", and interprets it as a string
+-- @\@
+-- @\...\@
+--
+-- /Tags bound when you pass in anything else/
+--
+-- @\@ -- the given JSON value, as a string
+-- @\@ -- 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
diff --git a/src/Heist/Splices/Markdown.hs b/src/Heist/Splices/Markdown.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Splices/Markdown.hs
@@ -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.
+
+>
+>
+> <pageTitle/>
+>
+>
+>
+>
+
+And pandoc template, which would bind @pageTitle@ and @pageToc@ splices and
+applies "_wrap" template.
+
+>
+>
+> $title$
+> $toc$
+> $body$
+>
+
+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
+
+
+>
+>
+>
+>
+>
+>
+>
+>
+>
+>
+
+-}
+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)
diff --git a/src/Heist/TemplateDirectory.hs b/src/Heist/TemplateDirectory.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/TemplateDirectory.hs
@@ -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)
diff --git a/src/Text/Templating/Heist.hs b/src/Text/Templating/Heist.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist.hs
+++ /dev/null
@@ -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 (@\@,
--- @\@, @\@, and @\@) 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.
-
diff --git a/src/Text/Templating/Heist/Internal.hs b/src/Text/Templating/Heist/Internal.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/Internal.hs
+++ /dev/null
@@ -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:
---
--- >
--- >
--- > ...
--- >
--- >
---
--- 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 \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 \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
-
diff --git a/src/Text/Templating/Heist/Splices.hs b/src/Text/Templating/Heist/Splices.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/Splices.hs
+++ /dev/null
@@ -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
-
diff --git a/src/Text/Templating/Heist/Splices/Apply.hs b/src/Text/Templating/Heist/Splices/Apply.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/Splices/Apply.hs
+++ /dev/null
@@ -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
--- 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
-
-
diff --git a/src/Text/Templating/Heist/Splices/Bind.hs b/src/Text/Templating/Heist/Splices/Bind.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/Splices/Bind.hs
+++ /dev/null
@@ -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)
-
-
diff --git a/src/Text/Templating/Heist/Splices/BindStrict.hs b/src/Text/Templating/Heist/Splices/BindStrict.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/Splices/BindStrict.hs
+++ /dev/null
@@ -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)
diff --git a/src/Text/Templating/Heist/Splices/Cache.hs b/src/Text/Templating/Heist/Splices/Cache.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/Splices/Cache.hs
+++ /dev/null
@@ -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
-
-
-
-
diff --git a/src/Text/Templating/Heist/Splices/Html.hs b/src/Text/Templating/Heist/Splices/Html.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/Splices/Html.hs
+++ /dev/null
@@ -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)
-
diff --git a/src/Text/Templating/Heist/Splices/Ignore.hs b/src/Text/Templating/Heist/Splices/Ignore.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/Splices/Ignore.hs
+++ /dev/null
@@ -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 []
-
-
diff --git a/src/Text/Templating/Heist/Splices/Json.hs b/src/Text/Templating/Heist/Splices/Json.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/Splices/Json.hs
+++ /dev/null
@@ -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 }
---
--- @\@ -- treats v_i as text
--- @\@ -- treats v_i as HTML
--- @\@ -- explodes v_i and runs its children
---
--- @\@ -- walks the JSON tree to find
--- \"foo.bar.baz\", and interprets it as a string
--- @\@
--- @\...\@
---
--- /Tags bound when you pass in anything else/
---
--- @\@ -- the given JSON value, as a string
--- @\@ -- 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
diff --git a/src/Text/Templating/Heist/Splices/Markdown.hs b/src/Text/Templating/Heist/Splices/Markdown.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/Splices/Markdown.hs
+++ /dev/null
@@ -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 [ "
\n"
- , sout
- , "\n
" ]
-
- 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 [ "
\n"
- , sout
- , "\n
" ]
-
- 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)
-
-
-
-
diff --git a/src/Text/Templating/Heist/TemplateDirectory.hs b/src/Text/Templating/Heist/TemplateDirectory.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/TemplateDirectory.hs
+++ /dev/null
@@ -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: "
diff --git a/src/Text/Templating/Heist/Types.hs b/src/Text/Templating/Heist/Types.hs
deleted file mode 100644
--- a/src/Text/Templating/Heist/Types.hs
+++ /dev/null
@@ -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.
---
--- >
--- > To sleep, perchance to dream.
--- >
---
--- 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 #-}
-
diff --git a/test/.ghci b/test/.ghci
deleted file mode 100644
--- a/test/.ghci
+++ /dev/null
@@ -1,5 +0,0 @@
-:set -XOverloadedStrings
-:set -Wall
-:set -i../src
-:set -isuite
-:set -hide-package MonadCatchIO-mtl
diff --git a/test/README b/test/README
deleted file mode 100644
--- a/test/README
+++ /dev/null
@@ -1,1 +0,0 @@
-Various test applications and such for the Snap Framework
diff --git a/test/heist-testsuite.cabal b/test/heist-testsuite.cabal
deleted file mode 100644
--- a/test/heist-testsuite.cabal
+++ /dev/null
@@ -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
-
diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh
deleted file mode 100644
--- a/test/runTestsAndCoverage.sh
+++ /dev/null
@@ -1,48 +0,0 @@
-#!/bin/sh
-
-set -e
-
-SUITE=./dist/build/testsuite/testsuite
-
-rm -f testsuite.tix
-
-if [ ! -f $SUITE ]; then
- cat </dev/null 2>&1
-
-rm -f testsuite.tix
-
-cat < 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
+
diff --git a/test/suite/Heist/Compiled/Tests.hs b/test/suite/Heist/Compiled/Tests.hs
new file mode 100644
--- /dev/null
+++ b/test/suite/Heist/Compiled/Tests.hs
@@ -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\n3\n\n"
+
+peopleTest :: IO ()
+peopleTest = do
+ res <- personListTest "templates"
+ H.assertEqual "people splice" expected res
+ where
+ expected =
+ "\n
Doe, John: 42 years old
\n\n
Smith, Jane: 21 years old
\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
+ "http://www.devalot.com/\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\nInside 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\nInside 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\nInside 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\nInside 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 "
aeou
\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\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 2\n1 1\n1 1\n\n1 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]
diff --git a/test/suite/Heist/Interpreted/Tests.hs b/test/suite/Heist/Interpreted/Tests.hs
new file mode 100644
--- /dev/null
+++ b/test/suite/Heist/Interpreted/Tests.hs
@@ -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\n
"
+ -- 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 [ "<b>ok</b>1"
+ , "falsefoo" ]
+ jsonExpected2 = "ok1falsefoo"
+
+
+
+------------------------------------------------------------------------------
+jsonObjectTest :: H.Assertion
+jsonObjectTest = do
+ renderTest "json_object" jsonExpected
+ where
+ jsonExpected = "1ok12quuxquux1ok"
+
+
+------------------------------------------------------------------------------
+-- | 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 "[\"ok\", 1, null, false, \"foo\"]"
+ "jsonObject" ##
+ (bind $ mconcat [
+ "{\"foo\": 1, \"bar\": \"ok\", "
+ , "\"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 = "foo"
+
+
+------------------------------------------------------------------------------
+-- | Expansion of a bound name inside a textarea-tag
+textareaExpansion :: H.Assertion
+textareaExpansion = renderTest "textarea_expansion" expected
+ where
+ expected = B.concat
+ [ "" ]
+
+
+------------------------------------------------------------------------------
+-- | Expansion of a bound name inside a div-tag
+divExpansion :: H.Assertion
+divExpansion = renderTest "div_expansion" expected
+ where
+ expected = "
foo
"
+
+
+------------------------------------------------------------------------------
+-- | Handling of and bound parameters in a bound tag.
+bindParam :: H.Assertion
+bindParam = renderTest "bind_param" "
Hi there world
"
+
+
+------------------------------------------------------------------------------
+-- | Handling of and bound parameters in a bound tag.
+attrSpliceContext :: H.Assertion
+attrSpliceContext = renderTest "attrsubtest2"
+ "linkfoo"
+
+
+------------------------------------------------------------------------------
+-- | 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 " 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 = "http://www.devalot.com/"
+
+------------------------------------------------------------------------------
+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
+
+
+------------------------------------------------------------------------------
+-- 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
+
+
+------------------------------------------------------------------------------
+-- 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
diff --git a/test/suite/Heist/TestCommon.hs b/test/suite/Heist/TestCommon.hs
new file mode 100644
--- /dev/null
+++ b/test/suite/Heist/TestCommon.hs
@@ -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
+ [ "" ]
+
+
+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
diff --git a/test/suite/Heist/Tests.hs b/test/suite/Heist/Tests.hs
new file mode 100644
--- /dev/null
+++ b/test/suite/Heist/Tests.hs
@@ -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 \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 \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 "
+ ,"templates-bad/apply-missing-attr.tpl: must supply \"template\" attribute in "
+ ]
+#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 = "\n\n"
+ expected2 = "\n\n"
+ expected3 = "\n\n"
+ expected4 = "\n\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"
+ ["\n\n"
+ ,"\n\n"
+ ,"\n\n\n\n
nav bar
\n\n\n"
+ ,"
index page
\n\n\n\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 = "\n"
+
diff --git a/test/suite/Heist/Tutorial/AttributeSplices.lhs b/test/suite/Heist/Tutorial/AttributeSplices.lhs
new file mode 100644
--- /dev/null
+++ b/test/suite/Heist/Tutorial/AttributeSplices.lhs
@@ -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:
+
+ Red
+ Green
+ Blue
+
+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:
+
+ Red
+ Green
+ Blue
+
diff --git a/test/suite/Heist/Tutorial/CompiledSplices.lhs b/test/suite/Heist/Tutorial/CompiledSplices.lhs
new file mode 100644
--- /dev/null
+++ b/test/suite/Heist/Tutorial/CompiledSplices.lhs
@@ -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
+`` tags anyhere in any template and have them all merged into a single
+`` 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 `` tag, you can include it in a `` 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 `` tag.
+This splice removes all the `` nodes from its children, combines them, and
+inserts them as its first child. This won't work unless the `` splice
+first runs all its children to make sure all `` and `` 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
+
diff --git a/test/suite/Heist/Tutorial/Imports.hs b/test/suite/Heist/Tutorial/Imports.hs
new file mode 100644
--- /dev/null
+++ b/test/suite/Heist/Tutorial/Imports.hs
@@ -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
+
diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs
--- a/test/suite/TestSuite.hs
+++ b/test/suite/TestSuite.hs
@@ -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
]
diff --git a/test/suite/Text/Templating/Heist/Tests.hs b/test/suite/Text/Templating/Heist/Tests.hs
deleted file mode 100644
--- a/test/suite/Text/Templating/Heist/Tests.hs
+++ /dev/null
@@ -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 "
<b>ok</b>1"
- , "falsefoo" ]
- jsonExpected2 = "ok1falsefoo"
-
-
-------------------------------------------------------------------------------
-jsonObjectTest :: H.Assertion
-jsonObjectTest = do
- renderTest "json_object" jsonExpected
- where
- jsonExpected = B.concat [ "1ok12quuxquux1ok" ]
-
-
-------------------------------------------------------------------------------
--- | 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 "[\"ok\", 1, null, false, \"foo\"]")
- , ("jsonObject",
- bind $ mconcat [
- "{\"foo\": 1, \"bar\": \"ok\", "
- , "\"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" "foo"
-
-
-------------------------------------------------------------------------------
--- | Expansion of a bound name inside a textarea-tag
-textareaExpansion :: H.Assertion
-textareaExpansion = renderTest "textarea_expansion" ""
-
-
-------------------------------------------------------------------------------
--- | Expansion of a bound name inside a div-tag
-divExpansion :: H.Assertion
-divExpansion = renderTest "div_expansion" "
foo
"
-
-
-------------------------------------------------------------------------------
--- | Handling of and bound parameters in a bound tag.
-bindParam :: H.Assertion
-bindParam = renderTest "bind_param" "
Hi there world
"
-
-
-------------------------------------------------------------------------------
--- | Handling of and bound parameters in a bound tag.
-attrSpliceContext :: H.Assertion
-attrSpliceContext = renderTest "attrsubtest2" "linkfoo"
-
-
-------------------------------------------------------------------------------
--- | 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 " 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
-
-
-------------------------------------------------------------------------------
--- 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
-
-
-------------------------------------------------------------------------------
--- 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
-
diff --git a/test/templates-bad/apply-missing-attr.tpl b/test/templates-bad/apply-missing-attr.tpl
new file mode 100644
--- /dev/null
+++ b/test/templates-bad/apply-missing-attr.tpl
@@ -0,0 +1,3 @@
+
+noroot
+
diff --git a/test/templates-bad/apply-template-not-found.tpl b/test/templates-bad/apply-template-not-found.tpl
new file mode 100644
--- /dev/null
+++ b/test/templates-bad/apply-template-not-found.tpl
@@ -0,0 +1,3 @@
+
+This template is missing
+
diff --git a/test/templates-bad/bind-infinite-loop.tpl b/test/templates-bad/bind-infinite-loop.tpl
new file mode 100644
--- /dev/null
+++ b/test/templates-bad/bind-infinite-loop.tpl
@@ -0,0 +1,2 @@
+