heist 0.13.1.2 → 1.1.1.2
raw patch · 51 files changed
Files
- .ghci +1/−0
- CHANGELOG.md +63/−0
- README.md +3/−1
- heist.cabal +175/−47
- src/Heist.hs +158/−118
- src/Heist/Common.hs +92/−29
- src/Heist/Compiled.hs +4/−0
- src/Heist/Compiled/Internal.hs +207/−134
- src/Heist/Internal/Types.hs +279/−0
- src/Heist/Internal/Types/HeistState.hs +680/−0
- src/Heist/Interpreted.hs +1/−0
- src/Heist/Interpreted/Internal.hs +27/−20
- src/Heist/SpliceAPI.hs +0/−170
- src/Heist/Splices.hs +30/−2
- src/Heist/Splices/Apply.hs +4/−5
- src/Heist/Splices/Bind.hs +2/−3
- src/Heist/Splices/BindStrict.hs +2/−3
- src/Heist/Splices/Cache.hs +6/−3
- src/Heist/Splices/Html.hs +1/−1
- src/Heist/Splices/Json.hs +42/−17
- src/Heist/Splices/Markdown.hs +179/−38
- src/Heist/TemplateDirectory.hs +25/−18
- src/Heist/Types.hs +0/−528
- test/.ghci +0/−5
- test/README +0/−1
- test/heist-testsuite.cabal +0/−97
- test/runTestsAndCoverage.sh +0/−48
- test/suite/Benchmark.hs +25/−23
- test/suite/Heist/Compiled/Tests.hs +377/−7
- test/suite/Heist/Interpreted/Tests.hs +45/−18
- test/suite/Heist/TestCommon.hs +46/−21
- test/suite/Heist/Tests.hs +36/−24
- test/suite/Heist/Tutorial/CompiledSplices.lhs +11/−11
- test/suite/Heist/Tutorial/Imports.hs +3/−2
- test/suite/TestSuite.hs +5/−1
- test/templates-defer/test.tpl +5/−0
- test/templates-loaderror/_error.tpl +1/−0
- test/templates-loaderror/_ok.tpl +1/−0
- test/templates-loaderror/test.tpl +3/−0
- test/templates-ns-nested/test.tpl +1/−0
- test/templates-nsbind/nsbind.tpl +7/−0
- test/templates-nsbind/nsbinderror.tpl +10/−0
- test/templates-nscall/_call.tpl +2/−0
- test/templates-nscall/_invalid.tpl +1/−0
- test/templates-nscall/nscall.tpl +6/−0
- test/templates/backslash.tpl +1/−0
- test/templates/json_array.tpl +1/−0
- test/templates/namespaces.tpl +5/−0
- test/templates/pandoc.tpl +1/−0
- test/templates/pandocdiv.tpl +1/−0
- test/templates/rss.xtpl +1/−0
.ghci view
@@ -1,4 +1,5 @@ :set -XOverloadedStrings+:set -XCPP :set -Wall :set -isrc :set -itest/suite
+ CHANGELOG.md view
@@ -0,0 +1,63 @@+# 1.1.1.2++* Support GHC 9.8+* Fix broken test++# 1.1.1.1++* Support GHC 9.6++# 1.1.1.0++* Expose `lookupTemplate` and `splitTemplatePath`++* Bump dependency bounds for 9.4++# 1.1++* Remove pandoc and pandocBS++* Stop exporting readProcessWithExitCode'++* Remove -S and --no-wrap arguments to pandoc for compatibility with both 1.x+ and 2.x versions of the pandoc command line tool++* Bump map-syntax lower bound to fix 8.4 build problem++# 1.0.1.3++* Add Semigroup instances to support GHC 8.4++# 1.0.1.0++* Change benchmark from an executable section to a benchmark section in the+ cabal file. This eliminates the criterion dependency when doing "cabal+ install heist".+* Export manyWith++# 1.0.0.1++* Drop the dependency on `errors` packages from heist testsuite and benchmark+* Fix nested splice namespace warning bug (issue #85)++# 1.0.0.0++* Switch from MonadCatchIO-transformers to monad-control for Snap 1.0++# 0.14.0++See http://snapframework.com/blog/2014/09/24/heist-0.14-released++* Add namespace support (hcNamespace and hcErrorNotBound)+* Add tellSpliceError for generalized error reporting+* Restructured HeistConfig, export lenses instead of field accessors+* Moved old HeistConfig into SpliceConfig+* Factored SpliceAPI module out into separate map-syntax package++# 0.13.0++See http://snapframework.com/blog/2013/09/09/snap-0.13-released++* Simpler compiled splice API+* New splice syntax+
README.md view
@@ -1,5 +1,7 @@ # Heist +[](https://github.com/snapframework/heist/actions)+ Heist, part of the [Snap Framework](http://www.snapframework.com/), is a Haskell library for xml/html templating. It uses simple XML tags to bind values to your templates in a straightforward way. For example, if you were to@@ -15,7 +17,7 @@ Likewise, if you need to add text to an attribute, <bind tag="special">special-id</bind>- <div id="$(special)">very special</div>+ <div id="${special}">very special</div> gives you
heist.cabal view
@@ -1,5 +1,6 @@+cabal-version: 2.2 name: heist-version: 0.13.1.2+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.@@ -22,15 +23,26 @@ . * Optional merging of multiple \<head\> tags defined anywhere in the document-license: BSD3+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,@@ -52,10 +64,6 @@ 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,@@ -70,6 +78,7 @@ 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,@@ -89,13 +98,18 @@ 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/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,@@ -107,18 +121,48 @@ 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: Heist, Heist.Compiled, Heist.Compiled.LowLevel,+ Heist.Internal.Types, Heist.Interpreted,- Heist.SpliceAPI, Heist.Splices, Heist.Splices.Apply, Heist.Splices.Bind,@@ -134,52 +178,40 @@ Data.HeterogeneousEnvironment, Heist.Common, Heist.Compiled.Internal,- Heist.Interpreted.Internal,- Heist.Types+ Heist.Internal.Types.HeistState,+ Heist.Interpreted.Internal build-depends:- MonadCatchIO-transformers >= 0.2.1 && < 0.4,- aeson >= 0.6 && < 0.8,- attoparsec >= 0.10 && < 0.13,- base >= 4 && < 5,- blaze-builder >= 0.2 && < 0.4,- blaze-html >= 0.4 && < 0.8,- bytestring >= 0.9 && < 0.11,- containers >= 0.2 && < 0.6,- directory >= 1.1 && < 1.3,+ 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 && < 0.8,- errors >= 1.4 && < 1.5,- filepath >= 1.3 && < 1.4,- hashable >= 1.1 && < 1.3,- mtl >= 2.0 && < 2.2,- process >= 1.1 && < 1.3,- random >= 1.0.1.0 && < 1.1,- text >= 0.10 && < 1.2,- time >= 1.1 && < 1.5,- transformers >= 0.3 && < 0.4,+ 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.11,- xmlhtml >= 0.2.3 && < 0.3-- 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+ vector >= 0.9 && < 0.14,+ xmlhtml >= 0.2.3.5 && < 0.4,+ indexed-traversable >= 0.1.1 && < 0.2 - ghc-prof-options: -prof -auto-all+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - Extensions:- GeneralizedNewtypeDeriving,- PackageImports,- ScopedTypeVariables,- DeriveDataTypeable,- FlexibleInstances,- MultiParamTypeClasses,+ default-extensions: UndecidableInstances,- OverloadedStrings,- TypeSynonymInstances, NoMonomorphismRestriction @@ -187,3 +219,99 @@ 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,+ hashable,+ lifted-base,+ map-syntax,+ monad-control,+ mtl,+ process,+ random,+ text,+ time,+ transformers,+ transformers-base,+ unordered-containers,+ vector,+ xmlhtml,+ indexed-traversable++ if impl(ghc >= 7.8) && impl(ghc < 7.10)+ build-depends: transformers-compat >= 0.3 && < 0.7++ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded++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,++ -- Copied from regular dependencies:++ aeson,+ attoparsec,+ blaze-builder,+ blaze-html,+ bytestring,+ containers,+ directory,+ directory-tree,+ dlist,+ filepath,+ hashable,+ lifted-base,+ map-syntax,+ monad-control,+ mtl,+ process,+ random,+ statistics >= 0.11,+ text,+ time,+ transformers,+ transformers-base,+ unordered-containers,+ vector,+ xmlhtml,+ indexed-traversable++ if impl(ghc >= 7.8) && impl(ghc < 7.10)+ build-depends: transformers-compat++ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded+ -fno-warn-unused-do-bind -rtsopts++ default-extensions:+ UndecidableInstances,+ NoMonomorphismRestriction
src/Heist.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -24,9 +25,11 @@ , initHeistWithCacheTag , defaultInterpretedSplices , defaultLoadTimeSplices+ , emptyHeistConfig -- * Core Heist data types- , HeistConfig(..)+ , SpliceConfig+ , HeistConfig , TemplateRepo , TemplateLocation , Template@@ -37,12 +40,33 @@ , 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- , HeistT , evalHeistT , getParamNode , getContext@@ -56,76 +80,45 @@ , localHS , getDoc , getXMLDoc+ , tellSpliceError+ , spliceErrorText , orError+ , Splices - -- * Splice API- , module Heist.SpliceAPI+ -- * TPath functions+ , lookupTemplate+ , splitTemplatePath ) where -import Control.Error-import Control.Exception (SomeException)-import Control.Monad.CatchIO++------------------------------------------------------------------------------+import Control.Exception.Lifted import Control.Monad.State-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.Foldable as F-import qualified Data.HeterogeneousEnvironment as HE-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as Map+import Data.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 qualified Text.XmlHtml as X+------------------------------------------------------------------------------ import Heist.Common-import qualified Heist.Compiled.Internal as C-import qualified Heist.Interpreted.Internal as I-import Heist.SpliceAPI+import qualified Heist.Compiled.Internal as C+import qualified Heist.Interpreted.Internal as I import Heist.Splices-import Heist.Types---type TemplateRepo = HashMap TPath DocumentFile--+import Heist.Internal.Types --------------------------------------------------------------------------------- | 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 = EitherT [String] IO TemplateRepo -data HeistConfig m = HeistConfig- { hcInterpretedSplices :: Splices (I.Splice m)- -- ^ Interpreted splices are the splices that Heist has always had. They- -- return a list of nodes and are processed at runtime.- , hcLoadTimeSplices :: Splices (I.Splice IO)- -- ^ Load time splices are like interpreted splices because they return a- -- list of nodes. But they are like compiled splices because they are- -- processed once at load time. All of Heist's built-in splices should be- -- used as load time splices.- , hcCompiledSplices :: Splices (C.Splice m)- -- ^ Compiled splices return a DList of Chunks and are processed at load- -- time to generate a runtime monad action that will be used to render the- -- template.- , hcAttributeSplices :: Splices (AttrSplice m)- -- ^ Attribute splices are bound to attribute names and return a list of- -- attributes.- , hcTemplateLocations :: [TemplateLocation]- -- ^ A list of all the locations that Heist should get its templates- -- from. - }---instance Monoid (HeistConfig m) where- mempty = HeistConfig (put mempty) (put mempty) (put mempty) (put mempty) mempty- mappend (HeistConfig a b c d e) (HeistConfig a' b' c' d' e') =- HeistConfig (unionWithS const a a')- (unionWithS const b b')- (unionWithS const c c')- (unionWithS const d d')- (e `mappend` e')-- ------------------------------------------------------------------------------ -- | The built-in set of splices that you should use in compiled splice mode. -- This list includes everything from 'defaultInterpretedSplices' plus a@@ -133,18 +126,20 @@ -- 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 =+defaultLoadTimeSplices = do -- To be removed in later versions- insertS "content" deprecatedContentCheck defaultInterpretedSplices- + 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 hcLoadTimeSplices list in your HeistConfig. If--- you are using interpreted splice mode, then you might also want to bind the--- 'deprecatedContentCheck' splice to the content tag as a load time splice.+-- 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@@ -154,12 +149,19 @@ +------------------------------------------------------------------------------+-- | 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)]- -> EitherT [String] IO (HashMap TPath v)+ -> Either [String] (HashMap TPath v) allErrors tlist = case errs of- [] -> right $ Map.fromList $ rights tlist- _ -> left errs+ [] -> Right $ Map.fromList $ rights tlist+ _ -> Left errs where errs = lefts tlist @@ -168,18 +170,22 @@ -- | Loads templates from disk. This function returns just a template map so -- you can load multiple directories and combine the maps before initializing -- your HeistState.-loadTemplates :: FilePath -> EitherT [String] IO TemplateRepo+loadTemplates :: FilePath -> IO (Either [String] TemplateRepo) loadTemplates dir = do- d <- lift $ readDirectoryWith (loadTemplate dir) dir- allErrors $ F.fold (free d)+ 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 -> EitherT [String] IO TemplateRepo+reloadTemplates :: TemplateRepo -> IO (Either [String] TemplateRepo) reloadTemplates repo = do- tlist <- lift $ mapM loadOrKeep $ Map.toList repo- allErrors tlist+ tlist <- mapM loadOrKeep $ Map.toList repo+ return $ allErrors tlist where loadOrKeep (p,df) = case dfFile df of@@ -210,7 +216,7 @@ -- | 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+ True [] [] 0 [] Nothing kg False Html "" [] False 0 ------------------------------------------------------------------------------@@ -232,27 +238,49 @@ -- function. initHeist :: Monad n => HeistConfig n- -> EitherT [String] IO (HeistState n)+ -> IO (Either [String] (HeistState n)) initHeist hc = do- keyGen <- lift HE.newKeyGen- repos <- sequence $ hcTemplateLocations hc- initHeist' keyGen hc (Map.unions repos)+ 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- -> EitherT [String] IO (HeistState n)-initHeist' keyGen (HeistConfig i lt c a _) repo = do+ -> IO (Either [String] (HeistState n))+initHeist' keyGen (HeistConfig sc ns enn) repo = do let empty = emptyHS keyGen- tmap <- preproc keyGen lt repo- let hs1 = empty { _spliceMap = Map.fromList $ splicesToList i- , _templateMap = tmap- , _compiledSpliceMap = Map.fromList $ splicesToList c- , _attrSpliceMap = Map.fromList $ splicesToList a- }- lift $ C.compileTemplates hs1+ 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 ------------------------------------------------------------------------------@@ -260,17 +288,23 @@ preproc :: HE.KeyGen -> Splices (I.Splice IO) -> TemplateRepo- -> EitherT [String] IO TemplateRepo-preproc keyGen splices templates = do- let hs = (emptyHS keyGen) { _spliceMap = Map.fromList $ splicesToList splices- , _templateMap = templates- , _preprocessingMode = True }- let eval a = evalHeistT a (X.TextNode "") hs- tPairs <- lift $ mapM (eval . preprocess) $ Map.toList templates- let bad = lefts tPairs- if not (null bad)- then left bad- else right $ Map.fromList $ rights tPairs+ -> 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 ------------------------------------------------------------------------------@@ -279,12 +313,13 @@ -> 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- where- die = error "Preprocess didn't succeed! This should never happen." ------------------------------------------------------------------------------@@ -295,22 +330,27 @@ -- implementation. initHeistWithCacheTag :: MonadIO n => HeistConfig n- -> EitherT [String] IO (HeistState n, CacheTagState)-initHeistWithCacheTag (HeistConfig i lt c a locations) = do+ -> IO (Either [String] (HeistState n, CacheTagState))+initHeistWithCacheTag (HeistConfig sc ns enn) = do (ss, cts) <- liftIO mkCacheTag let tag = "cache"- keyGen <- lift HE.newKeyGen-- repos <- sequence locations- -- 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.- rawWithCache <- preproc keyGen (tag ## ss) $ Map.unions repos-- let hc' = HeistConfig (insertS tag (cacheImpl cts) i) lt- (insertS tag (cacheImplCompiled cts) c)- a locations- hs <- initHeist' keyGen hc' rawWithCache- return (hs, cts)+ keyGen <- HE.newKeyGen + erepos <- sequence $ _scTemplateLocations sc+ case sequence erepos of+ Left es -> return $ Left es+ Right repos -> do+ -- We have to do one preprocessing pass with the cache setup splice. This+ -- has to happen for both interpreted and compiled templates, so we do it+ -- here by itself because interpreted templates don't get the same load+ -- time splices as compiled templates.+ eRawWithCache <- preproc keyGen (tag ## ss) (Map.unions repos) ns+ case eRawWithCache of+ Left es -> return $ Left es+ Right rawWithCache -> do+ let sc' = SpliceConfig (tag #! cacheImpl cts) mempty+ (tag #! cacheImplCompiled cts)+ mempty mempty (const True)+ let hc = HeistConfig (mappend sc sc') ns enn+ hs <- initHeist' keyGen hc rawWithCache+ return $ fmap (,cts) hs
src/Heist/Common.hs view
@@ -1,31 +1,66 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Heist.Common where -import Control.Applicative-import Control.Exception (SomeException)-import Control.Monad-import qualified Control.Monad.CatchIO as C-import qualified Data.Attoparsec.Text as AP-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import Data.Hashable-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as Map-import Data.List-import Data.Maybe-import Data.Monoid-import qualified Data.Text as T-import System.FilePath-import Heist.SpliceAPI-import Heist.Types-import qualified Text.XmlHtml as X+------------------------------------------------------------------------------+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.@@ -37,15 +72,44 @@ orError silent msg = do hs <- getHS if _preprocessingMode hs- then error $ (maybe "" (++": ") $ _curTemplateFile hs) ++ msg+ 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 @@ -126,9 +190,9 @@ -> Maybe (t, TPath) lookupTemplate nameStr ts tm = f (tm ts) path name where- (name:p) = case splitTemplatePath nameStr of- [] -> [""]- ps -> ps+ (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@@ -286,6 +350,7 @@ -- 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" ------------------------------------------------------------------------------@@ -294,9 +359,7 @@ -> HeistState n -- ^ start state -> HeistState n bindAttributeSplices ss hs =- hs { _attrSpliceMap = Map.union (Map.fromList $ splicesToList ss)- (_attrSpliceMap hs) }-+ hs { _attrSpliceMap = applySpliceMap hs _attrSpliceMap ss } ------------------------------------------------------------------------------ -- | Mappends a doctype to the state.
src/Heist/Compiled.hs view
@@ -23,14 +23,18 @@ -- * Functions for manipulating lists of compiled splices , textSplice , nodeSplice+ , xmlNodeSplice+ , htmlNodeSplice , pureSplice , deferMany+ , defer , deferMap , mayDeferMap , bindLater , withSplices , manyWithSplices+ , manyWith , withLocalSplices -- * Constructing Chunks
src/Heist/Compiled/Internal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-}@@ -13,27 +14,34 @@ 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 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 qualified Text.XmlHtml as X-import qualified Text.XmlHtml.HTML.Meta as X+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.SpliceAPI-import Heist.Types+import Heist.Internal.Types.HeistState ------------------------------------------------------------------------------ @@ -44,7 +52,7 @@ -- The more interesting part of the type signature is what comes before the -- return value. The first type parameter in @'HeistT' n IO@ is the runtime -- monad. This reveals that the Chunks know about the runtime monad. The--- second type parameter in @HeistT n IO@ is @IO@. This tells is that the+-- 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.@@ -122,25 +130,18 @@ --------------------------------------------------------------------------------- | Runs a single splice and returns the builder computation.-runSplice :: (Monad n)- => X.Node- -> HeistState n- -> Splice n- -> IO [Chunk n]-runSplice node hs splice = do- !a <- evalHeistT splice node hs- return $! consolidate a--------------------------------------------------------------------------------- -- | Runs a DocumentFile with the appropriate template context set. runDocumentFile :: Monad n => TPath -> DocumentFile -> Splice n runDocumentFile tpath df = do- addDoctype $ maybeToList $ X.docType $ dfDoc df+ 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)@@ -152,46 +153,68 @@ -------------------------------------------------------------------------------compileTemplate :: Monad n- => HeistState n- -> TPath- -> DocumentFile- -> IO [Chunk n]-compileTemplate hs tpath df = do- let markup = case dfDoc df of- X.XmlDocument _ _ _ -> Xml- X.HtmlDocument _ _ _ -> Html- hs' = hs { _curMarkup = markup }- !chunks <- runSplice nullNode hs' $! runDocumentFile tpath df- return chunks- where- -- This gets overwritten in runDocumentFile- nullNode = X.TextNode ""+compileTemplate+ :: Monad n+ => TPath+ -> DocumentFile+ -> HeistT n IO [Chunk n]+compileTemplate tpath df = do+ !chunks <- runDocumentFile tpath df+ return $! consolidate chunks -------------------------------------------------------------------------------compileTemplates :: Monad n => HeistState n -> IO (HeistState n)-compileTemplates hs = do- ctm <- compileTemplates' hs- return $! hs { _compiledTemplateMap = ctm }--- let f = flip evalStateT HE.empty . unRT . codeGen--- return $! hs { _compiledTemplateMap = H.map (first f) ctm }+compileTemplates+ :: Monad 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+ }) -------------------------------------------------------------------------------compileTemplates' :: Monad n- => HeistState n- -> IO (H.HashMap TPath ([Chunk n], MIMEType))-compileTemplates' hs = do- ctm <- foldM runOne H.empty tpathDocfiles- return $! ctm+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- tpathDocfiles :: [(TPath, DocumentFile)]- tpathDocfiles = map (\(a,b) -> (a, b))- (H.toList $ _templateMap hs)+ 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- !mHtml <- compileTemplate hs tpath df+ modifyHS (\hs -> hs { _doctypes = []})+ !mHtml <- compileTemplate tpath df return $! H.insert tpath (mHtml, mimeType $! dfDoc df) tmap @@ -205,34 +228,34 @@ where ---------------------------------------------------------------------- go soFar x [] = x : soFar- + go soFar (Pure a) ((Pure b) : xs) = go soFar (Pure $! a `mappend` b) xs- + go soFar (RuntimeHtml a) ((RuntimeHtml b) : xs) = go soFar (RuntimeHtml $! a `mappend` b) xs- + go soFar (RuntimeHtml a) ((RuntimeAction b) : xs) = go soFar (RuntimeHtml $! a >>= \x -> b >> return x) xs- + go soFar (RuntimeAction a) ((RuntimeHtml b) : xs) = go soFar (RuntimeHtml $! a >> b) xs- + go soFar (RuntimeAction a) ((RuntimeAction b) : xs) = go soFar (RuntimeAction $! a >> b) xs- + go soFar a (b : xs) = go (a : soFar) b xs- + ---------------------------------------------------------------------- boilDown soFar [] = soFar- + boilDown soFar ((Pure h) : xs) = boilDown ((Pure $! h) : soFar) xs- + boilDown soFar (x : xs) = boilDown (x : soFar) xs --------------------------------------------------------------------------------- | Given a list of output chunks, consolidate turns consecutive runs of+-- | 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@@ -248,7 +271,14 @@ ------------------------------------------------------------------------------ -- | Looks up a splice in the compiled splice map. lookupSplice :: Text -> HeistT n IO (Maybe (Splice n))-lookupSplice nm = getsHS (H.lookup nm . _compiledSpliceMap)+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 ------------------------------------------------------------------------------@@ -257,11 +287,37 @@ -- compileNode to generate the appropriate runtime computation. runNode :: Monad n => X.Node -> Splice n runNode node = localParamNode (const node) $ do- isStatic <- subtreeIsStatic node- markup <- getsHS _curMarkup- if isStatic- then return $! yieldPure $! renderFragment markup [parseAttrs node]- else compileNode node+ 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@@ -317,9 +373,9 @@ -- | 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) =- -- Is this node a splice, or does it merely contain splices?- lookupSplice nm >>= fromMaybe compileStaticElement+compileNode (X.Element nm attrs ch) = do+ msplice <- lookupSplice nm+ fromMaybe compileStaticElement msplice where tag0 = T.append "<" nm end = T.concat [ "</" , nm , ">"]@@ -429,8 +485,8 @@ DL.concat [ DL.singleton $! pureTextChunk $! T.concat [" ", k, "=\""] , v, DL.singleton $! pureTextChunk "\"" ]- + attrToBuilder :: (Text, Text) -> Builder attrToBuilder (k,v) | T.null v = mconcat@@ -530,15 +586,17 @@ -> HeistState n -- ^ source state -> HeistState n bindSplice n v ts =- ts { _compiledSpliceMap = H.insert n v (_compiledSpliceMap 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 ts = foldr (uncurry bindSplice) ts $ splicesToList ss+bindSplices ss hs =+ hs { _compiledSpliceMap = applySpliceMap hs _compiledSpliceMap ss } ------------------------------------------------------------------------------@@ -555,6 +613,10 @@ ------------------------------------------------------------------------------ -- | 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@@ -568,13 +630,14 @@ -- | Looks up a compiled template and returns a compiled splice. callTemplate :: Monad n => ByteString- -> HeistT n IO (DList (Chunk n))+ -> Splice n callTemplate nm = do hs <- getHS- runNodeList $ maybe (error err) (X.docContent . dfDoc . fst) $- lookupTemplate nm hs _templateMap+ 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@@ -593,12 +656,28 @@ --------------------------------------------------------------------------------- | Converts a pure Node splice function to a pure Builder splice function.+-- | 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@@ -617,107 +696,101 @@ -- ^ Runtime data needed by the above splices -> Splice n withSplices splice splices runtimeAction =- withLocalSplices splices' noSplices splice+ withLocalSplices splices' mempty splice where- splices' = mapS ($runtimeAction) splices+ 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 :: Monad n+manyWithSplices :: (Foldable f, Monad n) => Splice n -> Splices (RuntimeSplice n a -> Splice n)- -> RuntimeSplice n [a]+ -> RuntimeSplice n (f a) -> Splice n-manyWithSplices splice splices runtimeAction = do- p <- newEmptyPromise- let splices' = mapS ($ getPromise p) splices- chunks <- withLocalSplices splices' noSplices splice- return $ yieldRuntime $ do- items <- runtimeAction- res <- forM items $ \item -> putPromise p item >> codeGen chunks- return $ mconcat res+manyWithSplices splice splices runtimeAction =+ manyWith splice splices mempty runtimeAction ------------------------------------------------------------------------------ -- | More powerful version of manyWithSplices that lets you also define -- attribute splices.-manyWith :: (Monad n)+manyWith :: (Foldable f, Monad n) => Splice n -> Splices (RuntimeSplice n a -> Splice n) -> Splices (RuntimeSplice n a -> AttrSplice n)- -> RuntimeSplice n [a]+ -> RuntimeSplice n (f a) -> Splice n manyWith splice splices attrSplices runtimeAction = do p <- newEmptyPromise- let splices' = mapS ($ getPromise p) splices- let attrSplices' = mapS ($ getPromise p) attrSplices+ let splices' = mapV ($ getPromise p) splices+ let attrSplices' = mapV ($ getPromise p) attrSplices chunks <- withLocalSplices splices' attrSplices' splice return $ yieldRuntime $ do items <- runtimeAction- res <- forM items $ \item -> putPromise p item >> codeGen chunks- return $ mconcat res+ 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 :: Monad n+deferMany :: (Foldable f, Monad n) => (RuntimeSplice n a -> Splice n)- -> RuntimeSplice n [a]+ -> RuntimeSplice n (f a) -> Splice n deferMany f getItems = do promise <- newEmptyPromise chunks <- f $ getPromise promise return $ yieldRuntime $ do items <- getItems- res <- forM items $ \item -> do- putPromise promise item- codeGen chunks- return $ mconcat res+ foldMapM (\item -> putPromise promise item >> codeGen chunks) items --------------------------------------------------------------------------------- | Saves the results of a runtme computation in a 'Promise' so they don't+-- | 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 = do- p2 <- newEmptyPromise- let action = yieldRuntimeEffect $ putPromise p2 =<< f =<< n- res <- pf $ getPromise p2- return $ action `mappend` res+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.--- --- This is a good example of how to do more complex flow control with--- promises. The generalization of this abstraction is too complex to be--- distilled to elegant high-level combinators. If you need to implement your--- own special flow control, then you should use functions from the--- `Heist.Compiled.LowLevel` module similarly to how it is done in the--- implementation of this function. mayDeferMap :: Monad n => (a -> RuntimeSplice n (Maybe b)) -> (RuntimeSplice n b -> Splice n) -> RuntimeSplice n a -> Splice n-mayDeferMap f pf n = do- p2 <- newEmptyPromise- action <- pf $ getPromise p2- return $ yieldRuntime $ do- mb <- f =<< n- case mb of- Nothing -> return mempty- Just b -> do- putPromise p2 b- codeGen action+mayDeferMap f pf n = deferMany pf $ f =<< n ------------------------------------------------------------------------------
+ src/Heist/Internal/Types.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++{-|++Internal types and accessors. There are no guarantees that heist will+preserve backwards compatibility for symbols in this module. If you use them,+no complaining when your code breaks.++-}++module Heist.Internal.Types+ ( module Heist.Internal.Types.HeistState+ , module Heist.Internal.Types+ ) where++------------------------------------------------------------------------------+import Data.HashMap.Strict (HashMap)+import Data.Text (Text)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#endif++------------------------------------------------------------------------------+import qualified Heist.Compiled.Internal as C+import qualified Heist.Interpreted.Internal as I+import Heist.Internal.Types.HeistState+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+type TemplateRepo = HashMap TPath DocumentFile+++------------------------------------------------------------------------------+-- | An IO action for getting a template repo from this location. By not just+-- using a directory path here, we support templates loaded from a database,+-- retrieved from the network, or anything else you can think of.+type TemplateLocation = IO (Either [String] TemplateRepo)+++------------------------------------------------------------------------------+-- | My lens creation function to avoid a dependency on lens.+lens :: Functor f => (t1 -> t) -> (t1 -> a -> b) -> (t -> f a) -> t1 -> f b+lens sa sbt afb s = sbt s <$> afb (sa s)+++------------------------------------------------------------------------------+-- | The splices and templates Heist will use. To bind a splice simply+-- include it in the appropriate place here.+data SpliceConfig m = SpliceConfig+ { _scInterpretedSplices :: Splices (I.Splice m)+ -- ^ Interpreted splices are the splices that Heist has always had.+ -- They return a list of nodes and are processed at runtime.+ , _scLoadTimeSplices :: Splices (I.Splice IO)+ -- ^ Load time splices are like interpreted splices because they+ -- return a list of nodes. But they are like compiled splices because+ -- they are processed once at load time. All of Heist's built-in+ -- splices should be used as load time splices.+ , _scCompiledSplices :: Splices (C.Splice m)+ -- ^ Compiled splices return a DList of Chunks and are processed at+ -- load time to generate a runtime monad action that will be used to+ -- render the template.+ , _scAttributeSplices :: Splices (AttrSplice m)+ -- ^ Attribute splices are bound to attribute names and return a list+ -- of attributes.+ , _scTemplateLocations :: [TemplateLocation]+ -- ^ A list of all the locations that Heist should get its templates+ -- from.+ , _scCompiledTemplateFilter :: TPath -> Bool+ -- ^ Predicate function to control which templates to compile. Using+ -- templates filtered out with this is still possible via+ -- callTemplate.+ }+++------------------------------------------------------------------------------+-- | Lens for interpreted splices+-- :: Simple Lens (SpliceConfig m) (Splices (I.Splice m))+scInterpretedSplices+ :: Functor f+ => (Splices (I.Splice m) -> f (Splices (I.Splice m)))+ -> SpliceConfig m -> f (SpliceConfig m)+scInterpretedSplices = lens _scInterpretedSplices setter+ where+ setter sc v = sc { _scInterpretedSplices = v }+++------------------------------------------------------------------------------+-- | Lens for load time splices+-- :: Simple Lens (SpliceConfig m) (Splices (I.Splice IO))+scLoadTimeSplices+ :: Functor f+ => (Splices (I.Splice IO) -> f (Splices (I.Splice IO)))+ -> SpliceConfig m -> f (SpliceConfig m)+scLoadTimeSplices = lens _scLoadTimeSplices setter+ where+ setter sc v = sc { _scLoadTimeSplices = v }+++------------------------------------------------------------------------------+-- | Lens for complied splices+-- :: Simple Lens (SpliceConfig m) (Splices (C.Splice m))+scCompiledSplices+ :: Functor f+ => (Splices (C.Splice m) -> f (Splices (C.Splice m)))+ -> SpliceConfig m -> f (SpliceConfig m)+scCompiledSplices = lens _scCompiledSplices setter+ where+ setter sc v = sc { _scCompiledSplices = v }+++------------------------------------------------------------------------------+-- | Lens for attribute splices+-- :: Simple Lens (SpliceConfig m) (Splices (AttrSplice m))+scAttributeSplices+ :: Functor f+ => (Splices (AttrSplice m) -> f (Splices (AttrSplice m)))+ -> SpliceConfig m -> f (SpliceConfig m)+scAttributeSplices = lens _scAttributeSplices setter+ where+ setter sc v = sc { _scAttributeSplices = v }+++------------------------------------------------------------------------------+-- | Lens for template locations+-- :: Simple Lens (SpliceConfig m) [TemplateLocation]+scTemplateLocations+ :: Functor f+ => ([TemplateLocation] -> f [TemplateLocation])+ -> SpliceConfig m -> f (SpliceConfig m)+scTemplateLocations = lens _scTemplateLocations setter+ where+ setter sc v = sc { _scTemplateLocations = v }+++------------------------------------------------------------------------------+-- | Lens for compiled template filter+-- :: Simple Lens (SpliceConfig m) (TBool -> Bool)+scCompiledTemplateFilter+ :: Functor f+ => ((TPath -> Bool) -> f (TPath -> Bool))+ -> SpliceConfig m -> f (SpliceConfig m)+scCompiledTemplateFilter = lens _scCompiledTemplateFilter setter+ where+ setter sc v = sc { _scCompiledTemplateFilter = v }+++instance Semigroup (SpliceConfig m) where+ SpliceConfig a1 b1 c1 d1 e1 f1 <> SpliceConfig a2 b2 c2 d2 e2 f2 =+ SpliceConfig (a1 <> a2) (b1 <> b2) (c1 <> c2)+ (d1 <> d2) (e1 <> e2) (\x -> f1 x && f2 x)++instance Monoid (SpliceConfig m) where+ mempty = SpliceConfig mempty mempty mempty mempty mempty (const True)+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif+++data HeistConfig m = HeistConfig+ { _hcSpliceConfig :: SpliceConfig m+ -- ^ Splices and templates+ , _hcNamespace :: Text+ -- ^ A namespace to use for all tags that are bound to splices. Use+ -- empty string for no namespace.+ , _hcErrorNotBound :: Bool+ -- ^ Whether to throw an error when a tag wih the heist namespace does+ -- not correspond to a bound splice. When not using a namespace, this+ -- flag is ignored.+ }+++------------------------------------------------------------------------------+-- | Lens for the SpliceConfig+-- :: Simple Lens (HeistConfig m) (SpliceConfig m)+hcSpliceConfig+ :: Functor f+ => ((SpliceConfig m) -> f (SpliceConfig m))+ -> HeistConfig m -> f (HeistConfig m)+hcSpliceConfig = lens _hcSpliceConfig setter+ where+ setter hc v = hc { _hcSpliceConfig = v }+++------------------------------------------------------------------------------+-- | Lens for the namespace+-- :: Simple Lens (HeistConfig m) Text+hcNamespace+ :: Functor f+ => (Text -> f Text)+ -> HeistConfig m -> f (HeistConfig m)+hcNamespace = lens _hcNamespace setter+ where+ setter hc v = hc { _hcNamespace = v }+++------------------------------------------------------------------------------+-- | Lens for the namespace error flag+-- :: Simple Lens (HeistConfig m) Bool+hcErrorNotBound+ :: Functor f+ => (Bool -> f Bool)+ -> HeistConfig m -> f (HeistConfig m)+hcErrorNotBound = lens _hcErrorNotBound setter+ where+ setter hc v = hc { _hcErrorNotBound = v }+++------------------------------------------------------------------------------+-- | Lens for interpreted splices+-- :: Simple Lens (HeistConfig m) (Splices (I.Splice m))+hcInterpretedSplices+ :: Functor f+ => (Splices (I.Splice m) -> f (Splices (I.Splice m)))+ -> HeistConfig m -> f (HeistConfig m)+hcInterpretedSplices = hcSpliceConfig . scInterpretedSplices+++------------------------------------------------------------------------------+-- | Lens for load time splices+-- :: Simple Lens (HeistConfig m) (Splices (I.Splice IO))+hcLoadTimeSplices+ :: Functor f+ => (Splices (I.Splice IO) -> f (Splices (I.Splice IO)))+ -> HeistConfig m -> f (HeistConfig m)+hcLoadTimeSplices = hcSpliceConfig . scLoadTimeSplices +++------------------------------------------------------------------------------+-- | Lens for compiled splices+-- :: Simple Lens (HeistConfig m) (Splices (C.Splice m))+hcCompiledSplices+ :: Functor f+ => (Splices (C.Splice m) -> f (Splices (C.Splice m)))+ -> HeistConfig m -> f (HeistConfig m)+hcCompiledSplices = hcSpliceConfig . scCompiledSplices +++------------------------------------------------------------------------------+-- | Lens for attribute splices+-- :: Simple Lens (HeistConfig m) (Splices (AttrSplice m))+hcAttributeSplices+ :: Functor f+ => (Splices (AttrSplice m) -> f (Splices (AttrSplice m)))+ -> HeistConfig m -> f (HeistConfig m)+hcAttributeSplices = hcSpliceConfig . scAttributeSplices +++------------------------------------------------------------------------------+-- | Lens for template locations+-- :: Simple Lens (HeistConfig m) [TemplateLocation]+hcTemplateLocations+ :: Functor f+ => ([TemplateLocation] -> f [TemplateLocation])+ -> HeistConfig m -> f (HeistConfig m)+hcTemplateLocations = hcSpliceConfig . scTemplateLocations +++------------------------------------------------------------------------------+-- | Lens for compiled template filter+-- :: Simple Lens (SpliceConfig m) (TBool -> Bool)+hcCompiledTemplateFilter+ :: Functor f+ => ((TPath -> Bool) -> f (TPath -> Bool))+ -> HeistConfig m -> f (HeistConfig m)+hcCompiledTemplateFilter = hcSpliceConfig . scCompiledTemplateFilter++
+ src/Heist/Internal/Types/HeistState.hs view
@@ -0,0 +1,680 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-|++This module contains the core Heist data types.++Edward Kmett wrote most of the HeistT monad code and associated instances,+liberating us from the unused writer portion of RWST.++-}++module Heist.Internal.Types.HeistState where++------------------------------------------------------------------------------+import Blaze.ByteString.Builder (Builder)+import Control.Applicative (Alternative (..))+import Control.Arrow (first)+import Control.Exception (Exception)+import Control.Monad (MonadPlus (..), ap)+import Control.Monad.Base+import Control.Monad.Cont (MonadCont (..))+#if MIN_VERSION_mtl(2,2,1)+import Control.Monad.Except (MonadError (..))+#else+import Control.Monad.Error (MonadError (..))+#endif+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import Control.Monad.Fix (MonadFix (..))+import Control.Monad.Reader (MonadReader (..))+import Control.Monad.State.Strict (MonadState (..), StateT)+import Control.Monad.Trans (MonadIO (..), MonadTrans (..))+import Control.Monad.Trans.Control+import Data.ByteString.Char8 (ByteString)+import Data.DList (DList)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import Data.HeterogeneousEnvironment (HeterogeneousEnvironment)+import qualified Data.HeterogeneousEnvironment as HE+import Data.Map.Syntax+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#endif+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+#if MIN_VERSION_base (4,7,0)+import Data.Typeable (Typeable)+#else+import Data.Typeable (TyCon, Typeable(..),+ Typeable1(..), mkTyCon,+ mkTyConApp)+#endif++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative (..), (<$>))+import Data.Monoid (Monoid(..))+#endif++import qualified Text.XmlHtml as X+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Convenient type alies for splices.+type Splices s = MapSyntax Text s+++------------------------------------------------------------------------------+-- | A 'Template' is a forest of XML nodes. Here we deviate from the \"single+-- root node\" constraint of well-formed XML because we want to allow+-- templates to contain document fragments that may not have a single root.+type Template = [X.Node]+++------------------------------------------------------------------------------+-- | MIME Type. The type alias is here to make the API clearer.+type MIMEType = ByteString+++------------------------------------------------------------------------------+-- | Reversed list of directories. This holds the path to the template+-- currently being processed.+type TPath = [ByteString]+++------------------------------------------------------------------------------+-- | Holds data about templates read from disk.+data DocumentFile = DocumentFile+ { dfDoc :: X.Document+ , dfFile :: Maybe FilePath+ } deriving ( Eq, Show+#if MIN_VERSION_base(4,7,0)+ , Typeable+#endif+ )+++------------------------------------------------------------------------------+-- | Designates whether a document should be treated as XML or HTML.+data Markup = Xml | Html+++------------------------------------------------------------------------------+-- | Monad used for runtime splice execution.+newtype RuntimeSplice m a = RuntimeSplice {+ unRT :: StateT HeterogeneousEnvironment m a+ } deriving ( Applicative+ , Functor+ , Monad+ , MonadIO+ , MonadState HeterogeneousEnvironment+ , MonadTrans+#if MIN_VERSION_base(4,7,0)+ , Typeable+#endif+ )+++------------------------------------------------------------------------------+instance (Monad m, Semigroup a) => Semigroup (RuntimeSplice m a) where+ a <> b = do+ !x <- a+ !y <- b+ return $! x <> y+++#if !MIN_VERSION_base(4,11,0)+instance (Monad m, Semigroup a, Monoid a) => Monoid (RuntimeSplice m a) where+#else+instance (Monad m, Monoid a) => Monoid (RuntimeSplice m a) where+#endif+ mempty = return mempty+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif+++------------------------------------------------------------------------------+-- | Opaque type representing pieces of output from compiled splices.+data Chunk m = Pure !ByteString+ -- ^ output known at load time+ | RuntimeHtml !(RuntimeSplice m Builder)+ -- ^ output computed at run time+ | RuntimeAction !(RuntimeSplice m ())+ -- ^ runtime action used only for its side-effect+#if MIN_VERSION_base(4,7,0)+ deriving Typeable+#endif++instance Show (Chunk m) where+ show (Pure _) = "Pure"+ show (RuntimeHtml _) = "RuntimeHtml"+ show (RuntimeAction _) = "RuntimeAction"+++showChunk :: Chunk m -> String+showChunk (Pure b) = T.unpack $ decodeUtf8 b+showChunk (RuntimeHtml _) = "RuntimeHtml"+showChunk (RuntimeAction _) = "RuntimeAction"+++isPureChunk :: Chunk m -> Bool+isPureChunk (Pure _) = True+isPureChunk _ = False+++------------------------------------------------------------------------------+-- | Type alias for attribute splices. The function parameter is the value of+-- the bound attribute splice. The return value is a list of attribute+-- key/value pairs that get substituted in the place of the bound attribute.+type AttrSplice m = Text -> RuntimeSplice m [(Text, Text)]+++------------------------------------------------------------------------------+-- | Detailed information about a splice error.+data SpliceError = SpliceError+ { spliceHistory :: [(TPath, Maybe FilePath, Text)]+ , spliceTemplateFile :: Maybe FilePath+ , visibleSplices :: [Text]+ , contextNode :: X.Node+ , spliceMsg :: Text+ } deriving ( Show, Eq )+++------------------------------------------------------------------------------+-- | Transform a SpliceError record to a Text message.+spliceErrorText :: SpliceError -> Text+spliceErrorText (SpliceError hist tf splices node msg) =+ (maybe "" ((`mappend` ": ") . T.pack) tf) `T.append` msg `T.append`+ foldr (\(_, tf', tag) -> (("\n ... via " `T.append`+ (maybe "" ((`mappend` ": ") . T.pack) tf')+ `T.append` tag) `T.append`)) T.empty hist+ `T.append`+ if null splices+ then T.empty+ else "\nBound splices:" `T.append`+ foldl (\x y -> x `T.append` " " `T.append` y) T.empty splices+ `T.append`+ (T.pack $ "\nNode: " ++ (show node))+++------------------------------------------------------------------------------+-- | Exception type for splice compile errors. Wraps the original+-- exception and provides context.+--data (Exception e) => CompileException e = CompileException+data CompileException = forall e . Exception e => CompileException+ { originalException :: e+ -- The list of splice errors. The head of it has the context+ -- related to the exception.+ , exceptionContext :: [SpliceError]+ } deriving ( Typeable )+++instance Show CompileException where+ show (CompileException e []) =+ "Heist load exception (unknown context): " ++ (show e)+ show (CompileException _ (c:_)) = (T.unpack $ spliceErrorText c)+++instance Exception CompileException+++------------------------------------------------------------------------------+-- | Holds all the state information needed for template processing. You will+-- build a @HeistState@ using 'initHeist' and any of Heist's @HeistState ->+-- HeistState@ \"filter\" functions. Then you use the resulting @HeistState@+-- in calls to 'renderTemplate'.+--+-- m is the runtime monad+data HeistState m = HeistState {+ -- | A mapping of splice names to splice actions+ _spliceMap :: HashMap Text (HeistT m m Template)+ -- | A mapping of template names to templates+ , _templateMap :: HashMap TPath DocumentFile++ -- | A mapping of splice names to splice actions+ , _compiledSpliceMap :: HashMap Text (HeistT m IO (DList (Chunk m)))+ -- | A mapping of template names to templates+ --, _compiledTemplateMap :: HashMap TPath (m Builder, MIMEType)+ , _compiledTemplateMap :: !(HashMap TPath ([Chunk m], MIMEType))++ , _attrSpliceMap :: HashMap Text (AttrSplice m)++ -- | A flag to control splice recursion+ , _recurse :: Bool+ -- | The path to the template currently being processed.+ , _curContext :: TPath+ -- | Stack of the splices used.+ , _splicePath :: [(TPath, Maybe FilePath, Text)]+ -- | A counter keeping track of the current recursion depth to prevent+ -- infinite loops.+ , _recursionDepth :: Int+ -- | The doctypes encountered during template processing.+ , _doctypes :: [X.DocType]+ -- | The full path to the current template's file on disk.+ , _curTemplateFile :: Maybe FilePath+ -- | A key generator used to produce new unique Promises.+ , _keygen :: HE.KeyGen++ -- | Flag indicating whether we're in preprocessing mode. During+ -- preprocessing, errors should stop execution and be reported. During+ -- template rendering, it's better to skip the errors and render the page.+ , _preprocessingMode :: Bool++ -- | This is needed because compiled templates are generated with a bunch+ -- of calls to renderFragment rather than a single call to render.+ , _curMarkup :: Markup++ -- | A prefix for all splices (namespace ++ ":").+ , _splicePrefix :: Text++ -- | List of errors encountered during splice processing.+ , _spliceErrors :: [SpliceError]++ -- | Whether to throw an error when a tag wih the heist namespace does not+ -- correspond to a bound splice. When not using a namespace, this flag is+ -- ignored.+ , _errorNotBound :: Bool+ , _numNamespacedTags :: Int+#if MIN_VERSION_base(4,7,0)+} deriving (Typeable)+#else+}+#endif++#if !MIN_VERSION_base(4,7,0)+-- NOTE: We got rid of the Monoid instance because it is absolutely not safe+-- to combine two compiledTemplateMaps. All compiled templates must be known+-- at load time and processed in a single call to initHeist/loadTemplates or+-- whatever we end up calling it..++instance (Typeable1 m) => Typeable (HeistState m) where+ typeOf _ = mkTyConApp templateStateTyCon [typeOf1 (undefined :: m ())]++#endif++------------------------------------------------------------------------------+-- | HeistT is the monad transformer used for splice processing. HeistT+-- intentionally does not expose any of its functionality via MonadState or+-- MonadReader functions. We define passthrough instances for the most common+-- types of monads. These instances allow the user to use HeistT in a monad+-- stack without needing calls to `lift`.+--+-- @n@ is the runtime monad (the parameter to HeistState).+--+-- @m@ is the monad being run now. In this case, \"now\" is a variable+-- concept. The type @HeistT n n@ means that \"now\" is runtime. The type+-- @HeistT n IO@ means that \"now\" is @IO@, and more importantly it is NOT+-- runtime. In Heist, the rule of thumb is that @IO@ means load time and @n@+-- means runtime.+newtype HeistT n m a = HeistT {+ runHeistT :: X.Node+ -> HeistState n+ -> m (a, HeistState n)+#if MIN_VERSION_base(4,7,0)+} deriving Typeable+#else+}+#endif+++------------------------------------------------------------------------------+-- | Gets the names of all the templates defined in a HeistState.+templateNames :: HeistState m -> [TPath]+templateNames ts = H.keys $ _templateMap ts+++------------------------------------------------------------------------------+-- | Gets the names of all the templates defined in a HeistState.+compiledTemplateNames :: HeistState m -> [TPath]+compiledTemplateNames ts = H.keys $ _compiledTemplateMap ts+++------------------------------------------------------------------------------+-- | Gets the names of all the interpreted splices defined in a HeistState.+spliceNames :: HeistState m -> [Text]+spliceNames ts = H.keys $ _spliceMap ts+++------------------------------------------------------------------------------+-- | Gets the names of all the compiled splices defined in a HeistState.+compiledSpliceNames :: HeistState m -> [Text]+compiledSpliceNames ts = H.keys $ _compiledSpliceMap ts+++#if !MIN_VERSION_base(4,7,0)+------------------------------------------------------------------------------+-- | The Typeable instance is here so Heist can be dynamically executed with+-- Hint.+templateStateTyCon :: TyCon+templateStateTyCon = mkTyCon "Heist.HeistState"+{-# NOINLINE templateStateTyCon #-}+#endif+++------------------------------------------------------------------------------+-- | Evaluates a template monad as a computation in the underlying monad.+evalHeistT :: (Monad m)+ => HeistT n m a+ -> X.Node+ -> HeistState n+ -> m a+evalHeistT m r s = do+ (a, _) <- runHeistT m r s+ return a+{-# INLINE evalHeistT #-}+++------------------------------------------------------------------------------+-- | Functor instance+instance Functor m => Functor (HeistT n m) where+ fmap f (HeistT m) = HeistT $ \r s -> first f <$> m r s+++------------------------------------------------------------------------------+-- | Applicative instance+instance (Monad m, Functor m) => Applicative (HeistT n m) where+ pure = return+ (<*>) = ap+++------------------------------------------------------------------------------+-- | Monad instance+instance Monad m => Monad (HeistT n m) where+ return a = HeistT (\_ s -> return (a, s))+ {-# INLINE return #-}+ HeistT m >>= k = HeistT $ \r s -> do+ (a, s') <- m r s+ runHeistT (k a) r s'+ {-# INLINE (>>=) #-}+++#if MIN_VERSION_base(4,9,0)+------------------------------------------------------------------------------+-- | MonadFail instance+instance Fail.MonadFail m => Fail.MonadFail (HeistT n m) where+ fail = lift . Fail.fail+#endif+++------------------------------------------------------------------------------+-- | MonadIO instance+instance MonadIO m => MonadIO (HeistT n m) where+ liftIO = lift . liftIO+++------------------------------------------------------------------------------+-- | MonadTrans instance+instance MonadTrans (HeistT n) where+ lift m = HeistT $ \_ s -> do+ a <- m+ return (a, s)+++instance MonadBase b m => MonadBase b (HeistT n m) where+ liftBase = lift . liftBase++#if MIN_VERSION_monad_control(1,0,0)+instance MonadTransControl (HeistT n) where+ type StT (HeistT n) a = (a, HeistState n)+ liftWith f = HeistT $ \n s -> do+ res <- f $ \(HeistT g) -> g n s+ return (res, s)+ restoreT k = HeistT $ \_ _ -> k+ {-# INLINE liftWith #-}+ {-# INLINE restoreT #-}+++instance MonadBaseControl b m => MonadBaseControl b (HeistT n m) where+ type StM (HeistT n m) a = ComposeSt (HeistT n) m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM+ {-# INLINE liftBaseWith #-}+ {-# INLINE restoreM #-}+#else+instance MonadTransControl (HeistT n) where+ newtype StT (HeistT n) a = StHeistT {unStHeistT :: (a, HeistState n)}+ liftWith f = HeistT $ \n s -> do+ res <- f $ \(HeistT g) -> liftM StHeistT $ g n s+ return (res, s)+ restoreT k = HeistT $ \_ _ -> liftM unStHeistT k+ {-# INLINE liftWith #-}+ {-# INLINE restoreT #-}+++instance MonadBaseControl b m => MonadBaseControl b (HeistT n m) where+ newtype StM (HeistT n m) a = StMHeist {unStMHeist :: ComposeSt (HeistT n) m a}+ liftBaseWith = defaultLiftBaseWith StMHeist+ restoreM = defaultRestoreM unStMHeist+ {-# INLINE liftBaseWith #-}+ {-# INLINE restoreM #-}+#endif++------------------------------------------------------------------------------+-- | MonadFix passthrough instance+instance MonadFix m => MonadFix (HeistT n m) where+ mfix f = HeistT $ \r s ->+ mfix $ \ (a, _) -> runHeistT (f a) r s+++------------------------------------------------------------------------------+-- | Alternative passthrough instance+instance (Functor m, MonadPlus m) => Alternative (HeistT n m) where+ empty = mzero+ (<|>) = mplus+++------------------------------------------------------------------------------+-- | MonadPlus passthrough instance+instance MonadPlus m => MonadPlus (HeistT n m) where+ mzero = lift mzero+ m `mplus` n = HeistT $ \r s ->+ runHeistT m r s `mplus` runHeistT n r s+++------------------------------------------------------------------------------+-- | MonadState passthrough instance+instance MonadState s m => MonadState s (HeistT n m) where+ get = lift get+ {-# INLINE get #-}+ put = lift . put+ {-# INLINE put #-}+++------------------------------------------------------------------------------+-- | MonadReader passthrough instance+instance MonadReader r m => MonadReader r (HeistT n m) where+ ask = HeistT $ \_ s -> do+ r <- ask+ return (r,s)+ local f (HeistT m) =+ HeistT $ \r s -> local f (m r s)+++------------------------------------------------------------------------------+-- | Helper for MonadError instance.+_liftCatch+ :: (m (a,HeistState n)+ -> (e -> m (a,HeistState n))+ -> m (a,HeistState n))+ -> HeistT n m a+ -> (e -> HeistT n m a)+ -> HeistT n m a+_liftCatch ce m h =+ HeistT $ \r s ->+ (runHeistT m r s `ce`+ (\e -> runHeistT (h e) r s))+++------------------------------------------------------------------------------+-- | MonadError passthrough instance+instance (MonadError e m) => MonadError e (HeistT n m) where+ throwError = lift . throwError+ catchError = _liftCatch catchError+++------------------------------------------------------------------------------+-- | Helper for MonadCont instance.+_liftCallCC+ :: ((((a,HeistState n) -> m (b, HeistState n))+ -> m (a, HeistState n))+ -> m (a, HeistState n))+ -> ((a -> HeistT n m b) -> HeistT n m a)+ -> HeistT n m a+_liftCallCC ccc f = HeistT $ \r s ->+ ccc $ \c ->+ runHeistT (f (\a -> HeistT $ \_ _ -> c (a, s))) r s+++------------------------------------------------------------------------------+-- | MonadCont passthrough instance+instance (MonadCont m) => MonadCont (HeistT n m) where+ callCC = _liftCallCC callCC+++#if !MIN_VERSION_base(4,7,0)+------------------------------------------------------------------------------+-- | The Typeable instance is here so Heist can be dynamically executed with+-- Hint.+templateMonadTyCon :: TyCon+templateMonadTyCon = mkTyCon "Heist.HeistT"+{-# NOINLINE templateMonadTyCon #-}++instance (Typeable1 m) => Typeable1 (HeistT n m) where+ typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())]+#endif+++------------------------------------------------------------------------------+-- Functions for our monad.+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Gets the node currently being processed.+--+-- > <speech author="Shakespeare">+-- > To sleep, perchance to dream.+-- > </speech>+--+-- When you call @getParamNode@ inside the code for the @speech@ splice, it+-- returns the Node for the @speech@ tag and its children. @getParamNode >>=+-- childNodes@ returns a list containing one 'TextNode' containing part of+-- Hamlet's speech. @liftM (getAttribute \"author\") getParamNode@ would+-- return @Just \"Shakespeare\"@.+getParamNode :: Monad m => HeistT n m X.Node+getParamNode = HeistT $ curry return+{-# INLINE getParamNode #-}+++------------------------------------------------------------------------------+-- | HeistT's 'local'.+localParamNode :: Monad m+ => (X.Node -> X.Node)+ -> HeistT n m a+ -> HeistT n m a+localParamNode f m = HeistT $ \r s -> runHeistT m (f r) s+{-# INLINE localParamNode #-}+++------------------------------------------------------------------------------+-- | HeistT's 'gets'.+getsHS :: Monad m => (HeistState n -> r) -> HeistT n m r+getsHS f = HeistT $ \_ s -> return (f s, s)+{-# INLINE getsHS #-}+++------------------------------------------------------------------------------+-- | HeistT's 'get'.+getHS :: Monad m => HeistT n m (HeistState n)+getHS = HeistT $ \_ s -> return (s, s)+{-# INLINE getHS #-}+++------------------------------------------------------------------------------+-- | HeistT's 'put'.+putHS :: Monad m => HeistState n -> HeistT n m ()+putHS s = HeistT $ \_ _ -> return ((), s)+{-# INLINE putHS #-}+++------------------------------------------------------------------------------+-- | HeistT's 'modify'.+modifyHS :: Monad m+ => (HeistState n -> HeistState n)+ -> HeistT n m ()+modifyHS f = HeistT $ \_ s -> return ((), f s)+{-# INLINE modifyHS #-}+++------------------------------------------------------------------------------+-- | Restores the HeistState. This function is almost like putHS except it+-- preserves the current doctypes and splice errors. You should use this+-- function instead of @putHS@ to restore an old state. This was needed+-- because doctypes needs to be in a "global scope" as opposed to the template+-- call "local scope" of state items such as recursionDepth, curContext, and+-- spliceMap.+restoreHS :: Monad m => HeistState n -> HeistT n m ()+restoreHS old = modifyHS (\cur -> old { _doctypes = _doctypes cur+ , _numNamespacedTags =+ _numNamespacedTags cur+ , _spliceErrors = _spliceErrors cur })+{-# INLINE restoreHS #-}+++------------------------------------------------------------------------------+-- | Abstracts the common pattern of running a HeistT computation with+-- a modified heist state.+localHS :: Monad m+ => (HeistState n -> HeistState n)+ -> HeistT n m a+ -> HeistT n m a+localHS f k = do+ ts <- getHS+ putHS $ f ts+ res <- k+ restoreHS ts+ return res+{-# INLINE localHS #-}+++------------------------------------------------------------------------------+-- | Modifies the recursion depth.+modRecursionDepth :: Monad m => (Int -> Int) -> HeistT n m ()+modRecursionDepth f =+ modifyHS (\st -> st { _recursionDepth = f (_recursionDepth st) })+++------------------------------------------------------------------------------+-- | Increments the namespaced tag count+incNamespacedTags :: Monad m => HeistT n m ()+incNamespacedTags =+ modifyHS (\st -> st { _numNamespacedTags = _numNamespacedTags st + 1 })+++------------------------------------------------------------------------------+-- | AST to hold attribute parsing structure. This is necessary because+-- attoparsec doesn't support parsers running in another monad.+data AttAST = Literal Text+ | Ident Text+ deriving (Show)+++------------------------------------------------------------------------------+isIdent :: AttAST -> Bool+isIdent (Ident _) = True+isIdent _ = False++
src/Heist/Interpreted.hs view
@@ -74,6 +74,7 @@ , callTemplate , callTemplateWithText , renderTemplate+ , renderTemplateToDoc , renderWithArgs ) where
src/Heist/Interpreted/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-}@@ -10,20 +9,19 @@ import Blaze.ByteString.Builder import Control.Monad import Control.Monad.State.Strict-import qualified Data.Attoparsec.Text as AP-import Data.ByteString (ByteString)-import Data.List-import qualified Data.HashMap.Strict as Map-import qualified Data.HeterogeneousEnvironment as HE+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 qualified Data.Text as T-import Data.Text (Text)-import qualified Text.XmlHtml as X-+import Data.Text (Text)+import qualified Data.Text as T+import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ import Heist.Common-import Heist.SpliceAPI-import Heist.Types+import Heist.Internal.Types.HeistState+------------------------------------------------------------------------------ type Splice n = HeistT n n Template@@ -48,9 +46,8 @@ bindSplices :: Splices (Splice n) -- ^ splices to bind -> HeistState n -- ^ start state -> HeistState n-bindSplices ss hs = foldl' (flip id) hs acts- where- acts = map (uncurry bindSplice) $ splicesToList ss+bindSplices ss hs =+ hs { _spliceMap = applySpliceMap hs _spliceMap ss } ------------------------------------------------------------------------------@@ -88,7 +85,7 @@ -> Splices b -- ^ List of tuples to be bound -> Splice n-runChildrenWithTrans f = runChildrenWith . mapS f+runChildrenWithTrans f = runChildrenWith . mapV f ------------------------------------------------------------------------------@@ -195,7 +192,7 @@ runAttrSplice a@(k,v) = do splice <- getsHS (Map.lookup k . _attrSpliceMap) maybe (liftM (:[]) $ attSubst a)- (lift . flip evalStateT HE.empty . unRT . ($v)) splice+ (lift . flip evalStateT HE.empty . unRT . ($ v)) splice ------------------------------------------------------------------------------@@ -288,9 +285,9 @@ ,"<"++(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@@ -347,7 +344,7 @@ => Splices Text -> HeistState n -> HeistState n-bindStrings splices hs = foldr (uncurry bindString) hs $ splicesToList splices+bindStrings splices = bindSplices (mapV textSplice splices) ------------------------------------------------------------------------------@@ -381,7 +378,7 @@ => ByteString -- ^ The name of the template -> Splices Text -- ^ Splices to call the template with -> HeistT n n Template-callTemplateWithText name splices = callTemplate name $ mapS textSplice splices+callTemplateWithText name splices = callTemplate name $ mapV textSplice splices ------------------------------------------------------------------------------@@ -390,6 +387,10 @@ -- 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@@ -414,3 +415,9 @@ renderWithArgs args hs = renderTemplate (bindStrings args hs) +renderTemplateToDoc :: Monad n+ => HeistState n+ -> ByteString+ -> n (Maybe X.Document)+renderTemplateToDoc hs name =+ evalHeistT (evalWithDoctypes name) (X.TextNode "") hs
− src/Heist/SpliceAPI.hs
@@ -1,170 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-}--{-|--An API implementing a convenient syntax for defining and manipulating splices.-This module was born from the observation that a list of tuples is-semantically ambiguous about how duplicate keys should be handled.-Additionally, the syntax is inherently rather cumbersome and difficult to work-with. This API takes advantage of do notation to provide a very light syntax-for defining splices while at the same time eliminating the semantic ambiguity-of alists.--Here's how you can define splices:--> mySplices :: Splices Text-> mySplices = do-> "firstName" ## "John"-> "lastName" ## "Smith"---}--module Heist.SpliceAPI where--import Control.Applicative-import Control.Monad.State (State, MonadState, execState, modify)-import Data.Map (Map)-import qualified Data.Map as M-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T------------------------------------------------------------------------------------ | A monad providing convenient syntax for defining splices.-newtype SplicesM s a = SplicesM { unSplices :: State (Map Text s) a }- deriving (Functor, Applicative, Monad, MonadState (Map Text s))------------------------------------------------------------------------------------ | Monoid instance does a union of the two maps with the second map--- overwriting any duplicates.-instance Monoid (Splices s) where- mempty = noSplices- mappend = unionWithS (\_ b -> b)------------------------------------------------------------------------------------ | Convenient type alias that will probably be used most of the time.-type Splices s = SplicesM s ()------------------------------------------------------------------------------------ | Forces a splice to be added. If the key already exists, its value is--- overwritten.-(##) :: Text -> s -> Splices s-(##) tag splice = modify $ M.insert tag splice-infixr 0 ##------------------------------------------------------------------------------------ | Tries to add a splice, but if the key already exists, then it throws an--- error message. This may be useful if name collisions are bad and you want--- to crash when they occur.-(#!) :: Text -> s -> Splices s-(#!) tag splice = modify $ M.insertWithKey err tag splice- where- err k _ _ = error $ "Key "++show k++" already exists in the splice map"-infixr 0 #!------------------------------------------------------------------------------------ | Inserts into the map only if the key does not already exist.-(#?) :: Text -> s -> Splices s-(#?) tag splice = modify $ M.insertWith (const id) tag splice-infixr 0 #?------------------------------------------------------------------------------------ | A `Splices` with nothing in it.-noSplices :: Splices s-noSplices = return ()------------------------------------------------------------------------------------ | Runs the SplicesM monad, generating a map of splices.-runSplices :: SplicesM s a -> Map Text s-runSplices splices = execState (unSplices splices) M.empty------------------------------------------------------------------------------------ | Constructs an alist representation.-splicesToList :: SplicesM s a -> [(Text, s)]-splicesToList = M.toList . runSplices------------------------------------------------------------------------------------ | Internal helper function for adding a map.-add :: Map Text s -> Splices s-add m = modify (\s -> M.unionWith (\_ b -> b) s m)------------------------------------------------------------------------------------ | Maps a function over all the splices.-mapS :: (a -> b) -> Splices a -> Splices b-mapS f ss = add $ M.map f $ runSplices ss ------------------------------------------------------------------------------------ | Applies an argument to a splice function.-applyS :: a -> Splices (a -> b) -> Splices b-applyS a = mapS ($a)------------------------------------------------------------------------------------ | Inserts a splice into the 'Splices'.-insertS :: Text -> s -> Splices s -> Splices s-insertS = insertWithS const------------------------------------------------------------------------------------ | Inserts a splice with a function combining new value and old value.-insertWithS :: (s -> s -> s) -> Text -> s -> SplicesM s a2 -> SplicesM s ()-insertWithS f k v b = add $ M.insertWith f k v (runSplices b)------------------------------------------------------------------------------------ | Union of `Splices` with a combining function.-unionWithS :: (s -> s -> s) -> SplicesM s a1 -> SplicesM s a2 -> SplicesM s ()-unionWithS f a b = add $ M.unionWith f (runSplices a) (runSplices b)------------------------------------------------------------------------------------ | Infix operator for @flip applyS@-($$) :: Splices (a -> b) -> a -> Splices b-($$) = flip applyS-infixr 0 $$------------------------------------------------------------------------------------ | Maps a function over all the splice names.-mapNames :: (Text -> Text) -> Splices a -> Splices a-mapNames f = add . M.mapKeys f . runSplices----- The following two functions are formulated as functions of Splices instead--- of a single splice because they operate on the splice names instead of the--- splices themselves.------------------------------------------------------------------------------------ | Adds a prefix to the tag names for a list of splices. If the existing--- tag name is empty, then the new tag name is just the prefix. Otherwise the--- new tag name is the prefix followed by the separator followed by the--- existing name.-prefixSplices :: Text -> Text -> Splices a -> Splices a-prefixSplices sep pre = mapNames f- where- f t = if T.null t then pre else T.concat [pre,sep,t]------------------------------------------------------------------------------------ | 'prefixSplices' specialized to use a colon as separator in the style of--- XML namespaces.-namespaceSplices :: Text -> Splices a -> Splices a-namespaceSplices = prefixSplices ":"-
src/Heist/Splices.hs view
@@ -1,6 +1,10 @@+{-# LANGUAGE CPP #-}+ module Heist.Splices ( ifISplice , ifCSplice+ , ifElseISplice+ , ifElseCSplice , module Heist.Splices.Apply , module Heist.Splices.Bind , module Heist.Splices.Cache@@ -9,7 +13,10 @@ , module Heist.Splices.Markdown ) where -import Data.Monoid+#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@@ -18,7 +25,8 @@ import Heist.Splices.Html import Heist.Splices.Ignore import Heist.Splices.Markdown-import Heist.Types+import Heist.Internal.Types.HeistState+import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ -- | Run the splice contents if given condition is True, make splice disappear@@ -47,3 +55,23 @@ else return mempty ++------------------------------------------------------------------------------+-- | Implements an if\/then\/else conditional splice. It splits its children+-- around the \<else\/\> element to get the markup to be used for the two cases.+ifElseISplice :: Monad m => Bool -> I.Splice m+ifElseISplice cond = getParamNode >>= (rewrite . X.childNodes)+ where+ rewrite nodes = + let (ns, ns') = break (\n -> X.tagName n==Just "else") nodes+ in I.runNodeList $ if cond then ns else (drop 1 ns') +++------------------------------------------------------------------------------+-- | Implements an if\/then\/else conditional splice. It splits its children+-- around the \<else\/\> element to get the markup to be used for the two cases.+ifElseCSplice :: Monad m => Bool -> C.Splice m+ifElseCSplice cond = getParamNode >>= (rewrite . X.childNodes)+ where rewrite nodes = + let (ns, ns') = break (\n -> X.tagName n==Just "else") nodes+ in C.runNodeList $ if cond then ns else (drop 1 ns')
src/Heist/Splices/Apply.hs view
@@ -3,7 +3,6 @@ module Heist.Splices.Apply where -------------------------------------------------------------------------------import Control.Monad.Trans import Data.Maybe import Data.Text (Text) import qualified Data.Text as T@@ -13,7 +12,7 @@ ------------------------------------------------------------------------------ import Heist.Common import Heist.Interpreted.Internal-import Heist.Types+import Heist.Internal.Types.HeistState ------------------------------------------------------------------------------@@ -55,7 +54,7 @@ (return []) `orError` err where err = "template recursion exceeded max depth, "++- "you probably have infinite splice recursion!"+ "you probably have infinite splice recursion!" :: String treeMap :: [X.Node] -> X.Node -> [X.Node] treeMap ns n@(X.Element nm _ cs) | nm == paramTag = ns@@ -68,7 +67,7 @@ ------------------------------------------------------------------------------ -- | Applies a template as if the supplied nodes were the children of the -- <apply> tag.-applyNodes :: MonadIO n => Template -> Text -> Splice n+applyNodes :: Monad n => Template -> Text -> Splice n applyNodes nodes template = do hs <- getHS maybe (return [] `orError` err)@@ -83,7 +82,7 @@ ------------------------------------------------------------------------------ -- | Implementation of the apply splice.-applyImpl :: MonadIO n => Splice n+applyImpl :: Monad n => Splice n applyImpl = do node <- getParamNode let err = "must supply \"" ++ T.unpack applyAttr ++
src/Heist/Splices/Bind.hs view
@@ -1,7 +1,6 @@ module Heist.Splices.Bind where -------------------------------------------------------------------------------import Control.Monad.Trans import Data.Text (Text) import qualified Data.Text as T import qualified Text.XmlHtml as X@@ -10,7 +9,7 @@ import Heist.Common import Heist.Interpreted.Internal import Heist.Splices.Apply-import Heist.Types+import Heist.Internal.Types.HeistState -- | Default name for the bind splice. bindTag :: Text@@ -25,7 +24,7 @@ ------------------------------------------------------------------------------ -- | Implementation of the bind splice.-bindImpl :: MonadIO n => Splice n+bindImpl :: Monad n => Splice n bindImpl = do node <- getParamNode let err = "must supply \"" ++ T.unpack bindAttr ++
src/Heist/Splices/BindStrict.hs view
@@ -1,7 +1,6 @@ module Heist.Splices.BindStrict where -------------------------------------------------------------------------------import Control.Monad.Trans import Data.Text (Text) import qualified Data.Text as T import qualified Text.XmlHtml as X@@ -11,7 +10,7 @@ import Heist.Interpreted.Internal import Heist.Splices.Apply import Heist.Splices.Bind-import Heist.Types+import Heist.Internal.Types.HeistState -- | Default name for the bind splice. bindStrictTag :: Text@@ -20,7 +19,7 @@ ------------------------------------------------------------------------------ -- | Implementation of the bind splice.-bindStrictImpl :: MonadIO n => Splice n+bindStrictImpl :: Monad n => Splice n bindStrictImpl = do node <- getParamNode cs <- runChildren
src/Heist/Splices/Cache.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -- | The \"cache\" splice ensures that its contents are cached and only@@ -35,15 +36,17 @@ import qualified Data.Text as T import Data.Text.Read import Data.Time.Clock-import Data.Word 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.Types+import Heist.Internal.Types.HeistState ------------------------------------------------------------------------------
src/Heist/Splices/Html.hs view
@@ -7,7 +7,7 @@ ------------------------------------------------------------------------------ import Heist.Interpreted.Internal-import Heist.Types+import Heist.Internal.Types.HeistState ------------------------------------------------------------------------------
src/Heist/Splices/Json.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-} module Heist.Splices.Json ( bindJson@@ -10,21 +13,27 @@ 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 qualified Text.Blaze.Html5 as B 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.SpliceAPI-import Heist.Types+import Heist.Internal.Types.HeistState+------------------------------------------------------------------------------ ------------ -- public --@@ -88,7 +97,6 @@ numToText :: ToJSON a => a -> Text numToText = T.decodeUtf8 . S.concat . L.toChunks . encode - ------------------------------------------------------------------------------ findExpr :: Text -> Value -> Maybe Value findExpr t = go (T.split (=='.') t)@@ -96,10 +104,17 @@ 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 =@@ -149,7 +164,7 @@ -------------------------------------------------------------------------------explodeTag :: (Monad n) => JsonMonad n n [Node]+explodeTag :: forall n. (Monad n) => JsonMonad n n [Node] explodeTag = ask >>= go where --------------------------------------------------------------------------@@ -166,7 +181,7 @@ "snippet" ## asHtml t --------------------------------------------------------------------------- goArray :: (Monad n) => V.Vector Value -> JsonMonad n n [Node]+ goArray :: V.Vector Value -> JsonMonad n n [Node] goArray a = do lift stopRecursion dl <- V.foldM f id a@@ -180,7 +195,7 @@ -- search the param node for attribute \"var=expr\", search the given JSON -- object for the expression, and if it's found run the JsonMonad action m -- using the restricted JSON object.- varAttrTag :: (Monad m) => Value -> (JsonMonad m m [Node]) -> Splice m+ varAttrTag :: Value -> (JsonMonad n n [Node]) -> Splice n varAttrTag v m = do node <- getParamNode maybe (noVar node) (hasVar node) $ getAttribute "var" node@@ -203,23 +218,33 @@ (findExpr expr v) --------------------------------------------------------------------------- genericBindings :: Monad n => JsonMonad n n (Splices (Splice n))+ 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 =- let newBindings = do- T.append "with:" k ## withValue v explodeTag- T.append "snippet:" k ## withValue v snippetTag- T.append "value:" k ## withValue v valueTag- in unionWithS (\a _ -> a) newBindings bindings+#if MIN_VERSION_aeson(2,0,0)+ let k' = K.toText k+#else+ let k' = k+#endif+ newBindings = do+ T.append "with:" k' ## withValue v explodeTag+ T.append "snippet:" k' ## withValue v snippetTag+ T.append "value:" k' ## withValue v valueTag+ in bindings >> newBindings
src/Heist/Splices/Markdown.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-} {-| The \"markdown\" splice formats markdown content as HTML and inserts it into the document. @@ -9,22 +11,96 @@ and converted to HTML. This splice requires that the \"pandoc\" executable is in your path.++You can add custom pandoc splice with 'pandocSplice'. It is not limited to+markdown input, and can process anything pandoc can.++For example you can create a page with generated table of contents, using+heist template as pandoc template.++> <!-- _wrap.tpl -->+> <html>+> <head> <title> <pageTitle/> </title> </head>+>+> <div class="nav"> <pageToc/> </div>+> <apply-content/>+> </html>++And pandoc template, which would bind @pageTitle@ and @pageToc@ splices and+applies "_wrap" template.++> <!-- _pandoc.tpl -->+> <apply template="_wrap.tpl">+> <bind tag="pageTitle"> $title$</bind>+> <bind tag="pageToc"> $toc$</bind>+> $body$+> </apply>++Bind splice pandoc splice. Set it to not wrap in div, or it will break html+from _wrap.tpl++> splices = "docmarkdown" ## pandocSplice opts+> where+> opts = setPandocArgs ["-S", "--no-wrap", "--toc"+> , "--standalone"+> , "--template", "_pandoc.tpl"+> , "--html5"]+> $ setPandocWrapDiv Nothing+> $ defaultPandocOptions+>++And then use it to render your markdown file+++> <!-- apidocs.tpl -->+> <DOCTYPE html>+> <html lang="en">+> <head>+> <link href="/static/css/site.css rel="stylesheet">+> </head>+> <body>+> <apply template="_navbar.tpl" />+> <docmarkdown file="apidocs.md"/>+> </body>+ -}-module Heist.Splices.Markdown where+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 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.Exception.Lifted import Control.Monad-import Control.Monad.CatchIO 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@@ -33,17 +109,21 @@ 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-import Heist.Types data PandocMissingException = PandocMissingException deriving (Typeable) instance Show PandocMissingException where show PandocMissingException =- "Cannot find the \"pandoc\" executable; is it on your $PATH?"+ "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 @@ -68,69 +148,134 @@ 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" --------------------------------------------------------------------------------- | Implementation of the markdown splice.+-- | Default markdown splice with executable "pandoc" markdownSplice :: MonadIO m => Splice m-markdownSplice = do- templateDir <- liftM (fmap takeDirectory) getTemplateFilePath- pdMD <- liftIO $ findExecutable "pandoc"+markdownSplice= pandocSplice defaultPandocOptions - when (isNothing pdMD) $ liftIO $ throwIO PandocMissingException+-- | 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 )- (\tp -> pandoc (fromJust pdMD) tp $ T.unpack f)+ (pandocFile (T.unpack f)) templateDir return (T.unpack f,m) Nothing -> do- m <- pandocBS (fromJust pdMD) $ T.encodeUtf8 $ nodeText tree+ 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 (docContent d)+ 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] -pandoc :: FilePath -> FilePath -> FilePath -> IO ByteString-pandoc pandocPath templateDir inputFile = do- (ex, sout, serr) <- readProcessWithExitCode' pandocPath args "" +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 $ BC.concat [ "<div class=\"markdown\">\n"- , sout- , "\n</div>" ]+ return sout where isFail ExitSuccess = False isFail _ = True - args = [ "-S", "--no-wrap", templateDir </> inputFile ]-+ args' = args ++ [templateDir </> inputFile ] -pandocBS :: FilePath -> ByteString -> IO ByteString-pandocBS pandocPath s = do+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 $ BC.concat [ "<div class=\"markdown\">\n"- , sout- , "\n</div>" ]+ return sout where isFail ExitSuccess = False isFail _ = True- args = [ "-S", "--no-wrap" ] -- a version of readProcessWithExitCode that does I/O properly@@ -177,7 +322,3 @@ err <- readMVar errM return (ex, out, err)----
src/Heist/TemplateDirectory.hs view
@@ -17,10 +17,10 @@ ------------------------------------------------------------------------------ import Control.Concurrent-import Control.Error import Control.Monad import Control.Monad.Trans import Heist+import Heist.Internal.Types import Heist.Splices.Cache @@ -37,27 +37,34 @@ ------------------------------------------------------------------------------ -- | Creates and returns a new 'TemplateDirectory' wrapped in an Either for -- error handling.-newTemplateDirectory :: MonadIO n- => FilePath- -> HeistConfig n- -> EitherT [String] IO (TemplateDirectory n)+newTemplateDirectory+ :: MonadIO n+ => FilePath+ -> HeistConfig n+ -- namespaced tag.+ -> IO (Either [String] (TemplateDirectory n)) newTemplateDirectory dir hc = do- let hc' = hc { hcTemplateLocations = [loadTemplates dir] }- (hs,cts) <- initHeistWithCacheTag hc'- tsMVar <- liftIO $ newMVar hs- ctsMVar <- liftIO $ newMVar cts- return $ TemplateDirectory dir hc' tsMVar ctsMVar+ 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'+ :: MonadIO n+ => FilePath+ -> HeistConfig n+ -> IO (TemplateDirectory n) newTemplateDirectory' dir hc = do- res <- runEitherT $ newTemplateDirectory dir hc+ res <- newTemplateDirectory dir hc either (error . concat) return res @@ -82,8 +89,8 @@ => TemplateDirectory n -> IO (Either String ()) reloadTemplateDirectory (TemplateDirectory p hc tsMVar ctsMVar) = do- ehs <- runEitherT $ do- initHeistWithCacheTag (hc { hcTemplateLocations = [loadTemplates p] })+ 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)@@ -95,4 +102,4 @@ leftPass e m = either (return . Left . loadError . concat) (liftM Right . m) e where- loadError = (++) "Error loading templates: "+ loadError = (++) ("Error loading templates: " :: String)
− src/Heist/Types.hs
@@ -1,528 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}--{-|--This module contains the core Heist data types.--Edward Kmett wrote most of the HeistT monad code and associated instances,-liberating us from the unused writer portion of RWST.---}--module Heist.Types where---------------------------------------------------------------------------------import Blaze.ByteString.Builder-import Control.Applicative-import Control.Arrow-import Control.Monad.CatchIO (MonadCatchIO)-import qualified Control.Monad.CatchIO as C-import Control.Monad.Cont-import Control.Monad.Error-import Control.Monad.Reader-import Control.Monad.State.Strict-import Data.ByteString.Char8 (ByteString)-import Data.DList (DList)-import qualified Data.HashMap.Strict as H-import Data.HashMap.Strict (HashMap)-import Data.HeterogeneousEnvironment (HeterogeneousEnvironment)-import qualified Data.HeterogeneousEnvironment as HE-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding-import Data.Typeable-import qualified Text.XmlHtml as X--import Debug.Trace--tr :: Show a => String -> a -> a-tr s x = trace (s++show x) x----------------------------------------------------------------------------------- | A 'Template' is a forest of XML nodes. Here we deviate from the \"single--- root node\" constraint of well-formed XML because we want to allow--- templates to contain document fragments that may not have a single root.-type Template = [X.Node]------------------------------------------------------------------------------------ | MIME Type. The type alias is here to make the API clearer.-type MIMEType = ByteString------------------------------------------------------------------------------------ | Reversed list of directories. This holds the path to the template--- currently being processed.-type TPath = [ByteString]------------------------------------------------------------------------------------ | Holds data about templates read from disk.-data DocumentFile = DocumentFile- { dfDoc :: X.Document- , dfFile :: Maybe FilePath- } deriving ( Eq-#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, Monoid a) => Monoid (RuntimeSplice m a) where- mempty = return mempty-- a `mappend` b = do- !x <- a- !y <- b- return $! x `mappend` y------------------------------------------------------------------------------------ | Opaque type representing pieces of output from compiled splices.-data Chunk m = Pure !ByteString- -- ^ output known at load time- | RuntimeHtml !(RuntimeSplice m Builder)- -- ^ output computed at run time- | RuntimeAction !(RuntimeSplice m ())- -- ^ runtime action used only for its side-effect-#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)]------------------------------------------------------------------------------------ | Holds all the state information needed for template processing. You will--- build a @HeistState@ using 'initHeist' and any of Heist's @HeistState ->--- HeistState@ \"filter\" functions. Then you use the resulting @HeistState@--- in calls to 'renderTemplate'.------ m is the runtime monad-data HeistState m = HeistState {- -- | A mapping of splice names to splice actions- _spliceMap :: HashMap Text (HeistT m m Template)- -- | A mapping of template names to templates- , _templateMap :: HashMap TPath DocumentFile-- -- | A mapping of splice names to splice actions- , _compiledSpliceMap :: HashMap Text (HeistT m IO (DList (Chunk m)))- -- | A mapping of template names to templates- --, _compiledTemplateMap :: HashMap TPath (m Builder, MIMEType)- , _compiledTemplateMap :: !(HashMap TPath ([Chunk m], MIMEType))-- , _attrSpliceMap :: HashMap Text (AttrSplice m)-- -- | A flag to control splice recursion- , _recurse :: Bool- -- | The path to the template currently being processed.- , _curContext :: TPath- -- | A counter keeping track of the current recursion depth to prevent- -- infinite loops.- , _recursionDepth :: Int- -- | The doctypes encountered during template processing.- , _doctypes :: [X.DocType]- -- | The full path to the current template's file on disk.- , _curTemplateFile :: Maybe FilePath- -- | A key generator used to produce new unique Promises.- , _keygen :: HE.KeyGen-- -- | Flag indicating whether we're in preprocessing mode. During- -- preprocessing, errors should stop execution and be reported. During- -- template rendering, it's better to skip the errors and render the page.- , _preprocessingMode :: Bool-- -- | This is needed because compiled templates are generated with a bunch- -- of calls to renderFragment rather than a single call to render.- , _curMarkup :: Markup-#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 (>>=) #-}------------------------------------------------------------------------------------ | MonadIO instance-instance MonadIO m => MonadIO (HeistT n m) where- liftIO = lift . liftIO------------------------------------------------------------------------------------ | MonadTrans instance-instance MonadTrans (HeistT n) where- lift m = HeistT $ \_ s -> do- a <- m- return (a, s)------------------------------------------------------------------------------------ | MonadCatchIO instance-instance MonadCatchIO m => MonadCatchIO (HeistT n m) where- catch (HeistT a) h = HeistT $ \r s -> do- let handler e = runHeistT (h e) r s- C.catch (a r s) handler- block (HeistT m) = HeistT $ \r s -> C.block (m r s)- unblock (HeistT m) = HeistT $ \r s -> C.unblock (m r s)------------------------------------------------------------------------------------ | MonadFix passthrough instance-instance MonadFix m => MonadFix (HeistT n m) where- mfix f = HeistT $ \r s ->- mfix $ \ (a, _) -> runHeistT (f a) r s------------------------------------------------------------------------------------ | Alternative passthrough instance-instance (Functor m, MonadPlus m) => Alternative (HeistT n m) where- empty = mzero- (<|>) = mplus------------------------------------------------------------------------------------ | MonadPlus passthrough instance-instance MonadPlus m => MonadPlus (HeistT n m) where- mzero = lift mzero- m `mplus` n = HeistT $ \r s ->- runHeistT m r s `mplus` runHeistT n r s------------------------------------------------------------------------------------ | MonadState passthrough instance-instance MonadState s m => MonadState s (HeistT n m) where- get = lift get- {-# INLINE get #-}- put = lift . put- {-# INLINE put #-}------------------------------------------------------------------------------------ | MonadReader passthrough instance-instance MonadReader r m => MonadReader r (HeistT n m) where- ask = HeistT $ \_ s -> do- r <- ask- return (r,s)- local f (HeistT m) =- HeistT $ \r s -> local f (m r s)------------------------------------------------------------------------------------ | Helper for MonadError instance.-liftCatch :: (m (a,HeistState n)- -> (e -> m (a,HeistState n))- -> m (a,HeistState n))- -> HeistT n m a- -> (e -> HeistT n m a)- -> HeistT n m a-liftCatch ce m h =- HeistT $ \r s ->- (runHeistT m r s `ce`- (\e -> runHeistT (h e) r s))------------------------------------------------------------------------------------ | MonadError passthrough instance-instance (MonadError e m) => MonadError e (HeistT n m) where- throwError = lift . throwError- catchError = liftCatch catchError------------------------------------------------------------------------------------ | Helper for MonadCont instance.-liftCallCC :: ((((a,HeistState n) -> m (b, HeistState n))- -> m (a, HeistState n))- -> m (a, HeistState n))- -> ((a -> HeistT n m b) -> HeistT n m a)- -> HeistT n m a-liftCallCC ccc f = HeistT $ \r s ->- ccc $ \c ->- runHeistT (f (\a -> HeistT $ \_ _ -> c (a, s))) r s------------------------------------------------------------------------------------ | MonadCont passthrough instance-instance (MonadCont m) => MonadCont (HeistT n m) where- callCC = liftCallCC callCC---#if !MIN_VERSION_base(4,7,0)---------------------------------------------------------------------------------- | The Typeable instance is here so Heist can be dynamically executed with--- Hint.-templateMonadTyCon :: TyCon-templateMonadTyCon = mkTyCon "Heist.HeistT"-{-# NOINLINE templateMonadTyCon #-}--instance (Typeable1 m) => Typeable1 (HeistT n m) where- typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())]-#endif------------------------------------------------------------------------------------ Functions for our monad.------------------------------------------------------------------------------------------------------------------------------------------------------------------- | Gets the node currently being processed.------ > <speech author="Shakespeare">--- > To sleep, perchance to dream.--- > </speech>------ When you call @getParamNode@ inside the code for the @speech@ splice, it--- returns the Node for the @speech@ tag and its children. @getParamNode >>=--- childNodes@ returns a list containing one 'TextNode' containing part of--- Hamlet's speech. @liftM (getAttribute \"author\") getParamNode@ would--- return @Just "Shakespeare"@.-getParamNode :: Monad m => HeistT n m X.Node-getParamNode = HeistT $ curry return-{-# INLINE getParamNode #-}------------------------------------------------------------------------------------ | HeistT's 'local'.-localParamNode :: Monad m- => (X.Node -> X.Node)- -> HeistT n m a- -> HeistT n m a-localParamNode f m = HeistT $ \r s -> runHeistT m (f r) s-{-# INLINE localParamNode #-}------------------------------------------------------------------------------------ | HeistT's 'gets'.-getsHS :: Monad m => (HeistState n -> r) -> HeistT n m r-getsHS f = HeistT $ \_ s -> return (f s, s)-{-# INLINE getsHS #-}------------------------------------------------------------------------------------ | HeistT's 'get'.-getHS :: Monad m => HeistT n m (HeistState n)-getHS = HeistT $ \_ s -> return (s, s)-{-# INLINE getHS #-}------------------------------------------------------------------------------------ | HeistT's 'put'.-putHS :: Monad m => HeistState n -> HeistT n m ()-putHS s = HeistT $ \_ _ -> return ((), s)-{-# INLINE putHS #-}------------------------------------------------------------------------------------ | HeistT's 'modify'.-modifyHS :: Monad m- => (HeistState n -> HeistState n)- -> HeistT n m ()-modifyHS f = HeistT $ \_ s -> return ((), f s)-{-# INLINE modifyHS #-}------------------------------------------------------------------------------------ | Restores the HeistState. This function is almost like putHS except it--- preserves the current doctypes. You should use this function instead of--- @putHS@ to restore an old state. This was needed because doctypes needs to--- be in a "global scope" as opposed to the template call "local scope" of--- state items such as recursionDepth, curContext, and spliceMap.-restoreHS :: Monad m => HeistState n -> HeistT n m ()-restoreHS old = modifyHS (\cur -> old { _doctypes = _doctypes cur })-{-# INLINE restoreHS #-}------------------------------------------------------------------------------------ | Abstracts the common pattern of running a HeistT computation with--- a modified heist state.-localHS :: Monad m- => (HeistState n -> HeistState n)- -> HeistT n m a- -> HeistT n m a-localHS f k = do- ts <- getHS- putHS $ f ts- res <- k- restoreHS ts- return res-{-# INLINE localHS #-}------------------------------------------------------------------------------------ | Modifies the recursion depth.-modRecursionDepth :: Monad m => (Int -> Int) -> HeistT n m ()-modRecursionDepth f =- modifyHS (\st -> st { _recursionDepth = f (_recursionDepth st) })------------------------------------------------------------------------------------ | AST to hold attribute parsing structure. This is necessary because--- attoparsec doesn't support parsers running in another monad.-data AttAST = Literal Text- | Ident Text- deriving (Show)----------------------------------------------------------------------------------isIdent :: AttAST -> Bool-isIdent (Ident _) = True-isIdent _ = False--
− test/.ghci
@@ -1,5 +0,0 @@-:set -XOverloadedStrings-:set -Wall-:set -i../src-:set -isuite-:set -hide-package MonadCatchIO-mtl
− test/README
@@ -1,1 +0,0 @@-Various test applications and such for the Snap Framework
− test/heist-testsuite.cabal
@@ -1,97 +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:- HUnit >= 1.2 && < 2,- QuickCheck >= 2 && < 2.8,- MonadCatchIO-transformers >= 0.2.1 && < 0.4,- test-framework >= 0.4 && < 0.9,- test-framework-hunit >= 0.2.7 && < 0.4,- test-framework-quickcheck2 >= 0.2.12.1 && < 0.4,- aeson >= 0.6 && < 0.8,- attoparsec >= 0.10 && < 0.13,- base >= 4 && < 5,- blaze-builder >= 0.2 && < 0.4,- blaze-html >= 0.4 && < 0.8,- bytestring >= 0.9 && < 0.11,- containers >= 0.2 && < 0.6,- directory >= 1.1 && < 1.3,- directory-tree >= 0.10 && < 0.13,- dlist >= 0.5 && < 0.8,- errors >= 1.4 && < 1.5,- filepath >= 1.3 && < 1.4,- hashable >= 1.1 && < 1.3,- mtl >= 2.0 && < 2.2,- process >= 1.1 && < 1.3,- random >= 1.0.1.0 && < 1.1,- text >= 0.10 && < 1.2,- time >= 1.1 && < 1.5,- transformers >= 0.2 && < 0.4,- unordered-containers >= 0.1.4 && < 0.3,- vector >= 0.9 && < 0.11,- xmlhtml >= 0.2.3 && < 0.3--- ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded- Extensions: OverloadedStrings--Executable benchmark- hs-source-dirs: ../src suite- main-is: Benchmark.hs-- build-depends:- MonadCatchIO-transformers >= 0.3 && < 0.4,- HUnit >= 1.2 && < 1.3,- criterion >= 0.6 && < 0.9,- test-framework >= 0.4 && < 0.9,- test-framework-hunit >= 0.2 && < 0.4,-- -- Copied from regular dependencies:-- aeson >= 0.6 && < 0.8,- attoparsec >= 0.10 && < 0.13,- base >= 4 && < 5,- blaze-builder >= 0.2 && < 0.4,- blaze-html >= 0.4 && < 0.8,- bytestring >= 0.9 && < 0.11,- containers >= 0.2 && < 0.6,- directory >= 1.1 && < 1.3,- directory-tree >= 0.10 && < 0.13,- dlist >= 0.5 && < 0.8,- errors >= 1.4 && < 1.5,- filepath >= 1.3 && < 1.4,- hashable >= 1.1 && < 1.3,- mtl >= 2.0 && < 2.2,- process >= 1.1 && < 1.3,- random >= 1.0.1.0 && < 1.1,- statistics >= 0.11 && < 0.12,- text >= 0.10 && < 1.2,- time >= 1.1 && < 1.5,- transformers >= 0.2 && < 0.4,- unordered-containers >= 0.1.4 && < 0.3,- vector >= 0.9 && < 0.11,- xmlhtml >= 0.2.3 && < 0.3-- ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded- -fno-warn-unused-do-bind -rtsopts-- ghc-prof-options: -prof -auto-all-- Extensions:- GeneralizedNewtypeDeriving,- PackageImports,- ScopedTypeVariables,- DeriveDataTypeable,- FlexibleInstances,- MultiParamTypeClasses,- UndecidableInstances,- OverloadedStrings,- TypeSynonymInstances,- NoMonomorphismRestriction-
− test/runTestsAndCoverage.sh
@@ -1,48 +0,0 @@-#!/bin/sh--set -e--SUITE=./dist/build/testsuite/testsuite--rm -f testsuite.tix--if [ ! -f $SUITE ]; then- cat <<EOF-Testsuite executable not found, please run:- cabal configure -ftest-then- cabal build-EOF- exit;-fi--./dist/build/testsuite/testsuite -j4 -a1000 $*--DIR=dist/hpc--rm -Rf $DIR-mkdir -p $DIR--EXCLUDES='Main-Heist.Compiled.Tests-Heist.Interpreted.Tests-Heist.Tutorial.AttributeSplices-Heist.Tutorial.CompiledSplices-Heist.Tutorial.Imports-Heist.TestCommon-Heist.Tests'--EXCL=""--for m in $EXCLUDES; do- EXCL="$EXCL --exclude=$m"-done--hpc markup $EXCL --destdir=$DIR testsuite >/dev/null 2>&1--rm -f testsuite.tix--cat <<EOF--Test coverage report written to $DIR.-EOF
test/suite/Benchmark.hs view
@@ -5,35 +5,37 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder-import Criterion-import Criterion.Main-import Criterion.Measurement hiding (getTime) import Control.Concurrent-import Control.Error-import Control.Exception (evaluate)+import Control.Exception (evaluate) import Control.Monad-import qualified Data.ByteString as B-import qualified Data.DList as DL+import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT)+import Criterion+import Criterion.Main+import Criterion.Measurement hiding (getTime)+import qualified Data.ByteString as B+import qualified Data.DList as DL+import Data.Maybe import Data.Monoid-import qualified Data.Text as T+import qualified Data.Text as T import Data.Text.Encoding import Data.Time.Clock-import Data.Maybe-import qualified Text.XmlHtml as X import System.Environment--import Heist-import Heist.Common-import qualified Heist.Compiled as C-import qualified Heist.Compiled.Internal as CI-import qualified Heist.Interpreted as I-import Heist.TestCommon-import Heist.Types+import qualified Text.XmlHtml as X+------------------------------------------------------------------------------+import Heist+import Heist.Common+import qualified Heist.Compiled as C+import qualified Heist.Compiled.Internal as CI+import qualified Heist.Interpreted as I+import Heist.TestCommon+import Heist.Internal.Types+------------------------------------------------------------------------------ loadWithCache baseDir = do- etm <- runEitherT $ do- let hc = HeistConfig mempty defaultLoadTimeSplices mempty mempty [loadTemplates baseDir]- initHeistWithCacheTag hc+ etm <- runExceptT $ do+ let sc = SpliceConfig mempty defaultLoadTimeSplices mempty mempty+ [loadTemplates baseDir] (const True)+ ExceptT $ initHeistWithCacheTag $ HeistConfig sc "" False either (error . unlines) (return . fst) etm main = do@@ -98,12 +100,12 @@ -- putStrLn "Template rendered correctly" defaultMain [- bench (page++"-speed") action+ bench (page++"-speed") (whnfIO action) ] testNode =- X.Element "div" [("foo", "aoeu"), ("bar", "euid")] + 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"]
test/suite/Heist/Compiled/Tests.hs view
@@ -1,13 +1,36 @@-module Heist.Compiled.Tests- ( tests- ) where+{-# 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 @@ -17,8 +40,23 @@ -- with ".." in the tag path (which doesn't currently work). tests :: [Test]-tests = [ testCase "compiled/simple" simpleCompiledTest- , testCase "compiled/people" peopleTest+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 ()@@ -27,7 +65,7 @@ H.assertEqual "compiled state splice" expected res where expected =- "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd'>\n <html> 3 </html> "+ mappend doctype "\n\n<html>\n3\n</html>\n" peopleTest :: IO () peopleTest = do@@ -35,5 +73,337 @@ H.assertEqual "people splice" expected res where expected =- " <p>Doe, John: 42 years old</p> <p>Smith, Jane: 21 years old</p> "+ "\n<p>Doe, John: 42 years old</p>\n\n<p>Smith, Jane: 21 years old</p>\n\n" +templateHC :: HeistConfig IO+templateHC = HeistConfig sc "" False+ where+ sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices+ & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu"))+ & scTemplateLocations .~ [loadTemplates "templates"]++genericTest :: String -> ByteString -> ByteString -> IO ()+genericTest nm template expected = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist templateHC+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs template+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual nm (Right expected) res++doctypeTest :: IO ()+doctypeTest = genericTest "doctype test" "rss" expected+ where+ expected = encodeUtf8+ "<rss><channel><link>http://www.devalot.com/</link></channel></rss>\n"++namespaceTest1 :: IO ()+namespaceTest1 = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist templateHC+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "namespaces"+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual "namespace test 1" (Right expected) res+ where+ expected = "Alpha\naoeu\nBeta\n<h:foo aoeu='htns'>Inside h:foo</h:foo>\nEnd\n"+++namespaceTest2 :: IO ()+namespaceTest2 = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ templateHC & hcErrorNotBound .~ True+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "namespaces"+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual "namespace test 2" (Right expected) res+ where+ expected = "Alpha\naoeu\nBeta\n<h:foo aoeu='htns'>Inside h:foo</h:foo>\nEnd\n"+++namespaceTest3 :: IO ()+namespaceTest3 = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "namespaces"+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual "namespace test 3" (Right expected) res+ where+ expected = "Alpha\n<foo aoeu='htns'>Inside foo</foo>\nBeta\naoeu\nEnd\n"+++namespaceTest4 :: IO ()+namespaceTest4 = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"+ & hcErrorNotBound .~ True+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "namespaces"+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual "namespace test 4" (Right expected) res+ where+ expected = "Alpha\n<foo aoeu='htns'>Inside foo</foo>\nBeta\naoeu\nEnd\n"+++namespaceTest5 :: IO ()+namespaceTest5 = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"+ & hcCompiledSplices .~ mempty+ & hcErrorNotBound .~ True+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "namespaces"+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual "namespace test 5" (Left ["templates/namespaces.tpl: No splice bound for h:foo"]) res++------------------------------------------------------------------------------+-- | The templates-no-ns directory should have no tags beginning with h: so+-- this test will throw an error.+noNsSplices :: IO ()+noNsSplices = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist hc+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "test"+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual "noNsSplices" (Left [noNamespaceSplicesMsg "h:"]) res+ where+ hc = HeistConfig sc "h" True+ sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices+ & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu"))+ & scTemplateLocations .~ [loadTemplates "templates-no-ns"]+++------------------------------------------------------------------------------+-- | Test that no namespace splice message works correctly when there are no+-- top level splices used+nsNestedUnused :: IO ()+nsNestedUnused = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist hc+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "test"+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual "ns nested unused warn test" (Right "<div>aeou</div>\n") res+ where+ hc = HeistConfig sc "h" False+ sc = mempty & scCompiledSplices .~ ("foo" ## return $ yieldPureText "aeou")+ & scTemplateLocations .~ [loadTemplates "templates-ns-nested"]+++nsBindTemplateHC :: String -> HeistConfig IO+nsBindTemplateHC dir = HeistConfig sc "h" False+ where+ sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices+ & scCompiledSplices .~ nsBindTestSplices+ & scTemplateLocations .~ [loadTemplates dir]+++nsBindTestSplices :: Splices (Splice IO)+nsBindTestSplices = do+ "call" ## do+ tpl <- withSplices (callTemplate "_call")+ nsBindSubSplices (return ())+ return $ yieldRuntime $ codeGen tpl+ "main" ## nsBindSubImpl (return ())+ "main2" ## nsBindSubImpl (return ())+++nsBindSubImpl :: RuntimeSplice IO b -> Splice IO+nsBindSubImpl _ = do+ tpl <- withSplices runChildren nsBindSubSplices (return ())+ return $ yieldRuntime $ codeGen tpl+++nsBindSubSplices :: Splices (RuntimeSplice IO () -> Splice IO)+nsBindSubSplices = do+ "sub" ## pureSplice . textSplice $ const "asdf"+ "recurse" ## nsBindSubImpl+++nsBindTest :: IO ()+nsBindTest = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind")+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "nsbind"+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual "namespace bind test" (Right expected) res+ where+ expected = "Alpha\n\nBeta\nasdf\nGamma\n<sub></sub>\n\n"+++------------------------------------------------------------------------------+-- | Test splice error reporting.+nsBindErrorTest :: IO ()+nsBindErrorTest = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind")+ & hcErrorNotBound .~ True+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "nsbinderror"+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual "namespace bind error test" (Left [ err1, err2, err3 ]) res+ where+ err1 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid3\n ... via templates-nsbind/nsbinderror.tpl: h:main2\nBound splices: h:call h:main h:main2 h:recurse h:sub\nNode: Element {elementTag = \"h:invalid3\", elementAttrs = [], elementChildren = []}"+ err2 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid2\n ... via templates-nsbind/nsbinderror.tpl: h:recurse\n ... via templates-nsbind/nsbinderror.tpl: h:main\nBound splices: h:call h:main h:main2 h:recurse h:sub\nNode: Element {elementTag = \"h:invalid2\", elementAttrs = [], elementChildren = []}"+ err3 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid1\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:invalid1\", elementAttrs = [], elementChildren = []}"+++------------------------------------------------------------------------------+-- | Test splice error data structure.+nsBindStackTest :: IO ()+nsBindStackTest = do+ res <- initHeist (nsBindTemplateHC "templates-nsbind") >>=+ return . (either Left (Right . _spliceErrors))++ H.assertEqual "namespace bind stack test" (Right [ err1, err2, err3 ]) res+ where+ err1 = SpliceError [ ( ["nsbinderror"]+ , Just "templates-nsbind/nsbinderror.tpl"+ , "h:main2") ]+ (Just "templates-nsbind/nsbinderror.tpl")+ ["h:call","h:main","h:main2","h:recurse","h:sub"]+ (X.Element "h:invalid3" [] [])+ "No splice bound for h:invalid3"+ err2 = SpliceError [ ( ["nsbinderror"]+ , Just "templates-nsbind/nsbinderror.tpl"+ , "h:recurse")+ , ( ["nsbinderror"]+ , Just "templates-nsbind/nsbinderror.tpl"+ ,"h:main") ]+ (Just "templates-nsbind/nsbinderror.tpl")+ ["h:call","h:main","h:main2","h:recurse","h:sub"]+ (X.Element "h:invalid2" [] [])+ "No splice bound for h:invalid2"+ err3 = SpliceError []+ (Just "templates-nsbind/nsbinderror.tpl")+ ["h:call","h:main","h:main2"]+ (X.Element "h:invalid1" [] [])+ "No splice bound for h:invalid1"+++nsCallTest :: IO ()+nsCallTest = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall")+ & hcErrorNotBound .~ True+ & hcCompiledTemplateFilter .~ nsFilter+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "nscall"+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual "namespace call test" (Right "Top\n\nInside 1\nCalled\nasdf\n\nInside 2\n\n") res+ where+ nsFilter = (/=) (fromIntegral $ ord '_') . B.head . head+++nsCallErrTest :: IO ()+nsCallErrTest = do+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall")+ & hcErrorNotBound .~ True+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "nscall"+ b <- lift $ fst runner+ return $ toByteString b++ H.assertEqual "namespace call error test"+ (Left $ Set.fromList [ err1, err2 ])+ (first Set.fromList res)+ where+ err1 = "templates-nscall/_call.tpl: No splice bound for h:sub\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:sub\", elementAttrs = [], elementChildren = []}"+ err2 = "templates-nscall/_invalid.tpl: No splice bound for h:invalid\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:invalid\", elementAttrs = [], elementChildren = []}"+++------------------------------------------------------------------------------+-- | Test exception handling in template load.+exceptionsTest :: IO ()+exceptionsTest = do+ res <- Control.Exception.catch+ (runExceptT $ do+ hs <- ExceptT $ initHeist hc+ -- The rest needed only for type inference.+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs ""+ _ <- lift $ fst runner+ throwE ["Unexpected success"])+ (\(e :: CompileException) -> return $ case lines (show e) of+ l:ls -> Right l+ _ -> Left [show e])+ H.assertEqual "exceptions" (Right firstLine) res++ where+ firstLine = "templates-loaderror/_error.tpl: Exception in splice compile: Prelude.read: no parse"++ hc = HeistConfig sc "h" True+ sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices+ & scCompiledSplices .~ splices+ & scTemplateLocations .~ [loadTemplates "templates-loaderror"]+ splices = do+ "call1" ## callTemplate "_ok"+ "call2" ## callTemplate "_error"+ "adder" ## do+ value :: Int <- read . T.unpack . fromJust .+ X.getAttribute "value" <$> getParamNode+ return $ yieldPureText $ T.pack $ show $ 1 + value+++------------------------------------------------------------------------------+-- | Test for defer functions to see that they correctly save the result of+-- a runtime computation.+deferTest :: IO ()+deferTest = do+ rs <- mapM newIORef $ replicate 5 (0 :: Int)+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ hc rs+ runner <- noteT ["Error rendering"] $ hoistMaybe $+ renderTemplate hs "test"+ b <- lift $ fst runner+ return $ toByteString b++ vs <- mapM readIORef rs+ H.assertEqual "defer test" ([2, 1, 1, 1, 1], Right msg) (vs, res)+ where+ msg = "1 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]
test/suite/Heist/Interpreted/Tests.hs view
@@ -11,23 +11,24 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder-import Control.Error+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.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 qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Text (Text)+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 (Test) import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2-import qualified Test.HUnit as H+import qualified Test.HUnit as H import Test.QuickCheck import Test.QuickCheck.Monadic @@ -35,15 +36,15 @@ ------------------------------------------------------------------------------ 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 Heist.Types-import qualified Text.XmlHtml as X-import qualified Text.XmlHtml.Cursor as X+import qualified Text.XmlHtml as X+import qualified Text.XmlHtml.Cursor as X ------------------------------------------------------------------------------@@ -60,6 +61,8 @@ , 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@@ -117,7 +120,7 @@ hasTemplateTest :: H.Assertion hasTemplateTest = do ets <- loadIO "templates" mempty mempty mempty mempty- let tm = either (error "Error loading templates") _templateMap ets+ 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)@@ -138,7 +141,7 @@ ets <- loadIO "templates" mempty mempty mempty mempty either (error "Error loading templates") (\ts -> do let tm = _templateMap ts- H.assertEqual "loadTest size" 37 $ Map.size tm+ H.assertEqual "loadTest size" 41 $ Map.size tm ) ets @@ -182,7 +185,7 @@ where indexRes = B.concat [doctype- ,"\n <html>\n<div id='pre_{att}_post'>\n/index\n</div>\n</html>\n"+ ,"\n\n<html>\n<div id='pre_{att}_post'>\n/index\n</div>\n</html>\n" ] ------------------------------------------------------------------------------@@ -239,7 +242,32 @@ markdownTest :: H.Assertion markdownTest = renderTest "markdown" markdownHtmlExpected +----------------------------------------------------------------------------- +-- | Pandoc test on a file+pandocTest :: H.Assertion+pandocTest = renderTest "pandoc" pandocNoDivHtmlExpected++pandocDivTest :: H.Assertion+pandocDivTest = renderTest "pandocdiv" pandocDivHtmlExpected++pandocNoDivHtmlExpected :: ByteString+pandocNoDivHtmlExpected = "<p>This <em>is</em> a test.</p>"++pandocDivHtmlExpected :: ByteString+pandocDivHtmlExpected =+ "<div class='foo test' id='pandoc'><p>This <em>is</em> a test.</p></div>"+ -- Implementaton dependent. Class is prepended in current implementation,+ -- it will be first attribute++pandocTestSplices :: Splices (Splice IO)+pandocTestSplices = do+ "pandocnodiv" ## pandocSplice optsNoDiv+ "pandocdiv" ## pandocSplice optsDiv+ where+ optsNoDiv = setPandocWrapDiv Nothing defaultPandocOptions+ optsDiv = setPandocWrapDiv (Just "test") defaultPandocOptions+ ------------------------------------------------------------------------------ jsonValueTest :: H.Assertion jsonValueTest = do@@ -267,7 +295,7 @@ -> ByteString -- ^ expected result -> H.Assertion renderTest templateName expectedResult = do- ets <- loadT "templates" mempty mempty mempty mempty+ ets <- loadT "templates" mempty pandocTestSplices mempty mempty let ts = either (error "Error loading templates") id ets check ts expectedResult@@ -601,7 +629,6 @@ Nothing)) hs evalHeistT (runNodeList $ buildApplyCaller apply) (X.TextNode "") hs'-
test/suite/Heist/TestCommon.hs view
@@ -2,20 +2,22 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder-import Control.Error import Control.Monad.Trans-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B+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 qualified Heist.Interpreted as I+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+import qualified Text.XmlHtml as X ------------------------------------------------------------------------------@@ -33,10 +35,11 @@ -> Splices (C.Splice m) -> Splices (AttrSplice m) -> IO (Either [String] (HeistState m))-loadT baseDir a b c d = runEitherT $ do- let hc = HeistConfig (defaultInterpretedSplices `mappend` a)- (defaultLoadTimeSplices `mappend` b) c d [loadTemplates baseDir]- initHeist hc+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 ------------------------------------------------------------------------------@@ -46,19 +49,21 @@ -> Splices (C.Splice IO) -> Splices (AttrSplice IO) -> IO (Either [String] (HeistState IO))-loadIO baseDir a b c d = runEitherT $ do- let hc = HeistConfig (defaultInterpretedSplices `mappend` a)- (defaultLoadTimeSplices `mappend` b) c d [loadTemplates baseDir]- initHeist hc+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 <- runEitherT $ do- let hc = HeistConfig defaultInterpretedSplices- defaultLoadTimeSplices mempty mempty [loadTemplates baseDir]- initHeist hc+ etm <- runExceptT $ do+ let sc = SpliceConfig defaultInterpretedSplices+ defaultLoadTimeSplices mempty mempty+ [loadTemplates baseDir] (const True)+ ExceptT $ initHeist $ HeistConfig sc "" False either (error . concat) return etm @@ -68,9 +73,10 @@ -> Splices (AttrSplice IO) -> IO (HeistState IO) loadEmpty a b c d = do- let hc = HeistConfig (defaultInterpretedSplices `mappend` a)- (defaultLoadTimeSplices `mappend` b) c d mempty- res <- runEitherT $ initHeist hc+ let sc = SpliceConfig (defaultInterpretedSplices `mappend` a)+ (defaultLoadTimeSplices `mappend` b) c d mempty+ (const True)+ res <- initHeist $ HeistConfig sc "" False either (error . concat) return res @@ -107,3 +113,22 @@ builder <- I.renderTemplate hs name return $ toByteString $ fst $ fromJust builder ++------------------------------------------------------------------------------+isLeft :: Either e a -> Bool+isLeft (Left _) = True+isLeft _ = False+++------------------------------------------------------------------------------+noteT :: Monad m => e -> MaybeT m a -> ExceptT e m a+noteT e ma = do+ x <- lift $ runMaybeT ma+ case x of+ Nothing -> ExceptT $ return (Left e)+ Just a -> ExceptT $ return (Right a)+++------------------------------------------------------------------------------+hoistMaybe :: Monad m => Maybe a -> MaybeT m a+hoistMaybe = MaybeT . return
test/suite/Heist/Tests.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+ module Heist.Tests ( tests ) where@@ -7,25 +9,27 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Monad.State-import qualified Data.ByteString.Char8 as B+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 qualified Data.Text as T+import Test.Framework (Test) import Test.Framework.Providers.HUnit-import qualified Test.HUnit as H+import qualified Test.HUnit as H ------------------------------------------------------------------------------ import Heist-import qualified Heist.Compiled as C-import Heist.Tutorial.AttributeSplices-import Heist.Tutorial.CompiledSplices-import qualified Heist.Interpreted as I+import 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 @@ -34,8 +38,8 @@ , testCase "attrsplice/autocheck" attrSpliceTest , testCase "tdirCache" tdirCacheTest , testCase "headMerge" headMergeTest- , testCase "bindApplyInteraction" bindApplyInteractionTest - , testCase "backslashHandling" backslashHandlingTest + , testCase "bindApplyInteraction" bindApplyInteractionTest+ , testCase "backslashHandling" backslashHandlingTest ] @@ -49,11 +53,19 @@ ets where expected = sort+#if MIN_VERSION_base(4,9,0)+ ["templates-bad/apply-missing-attr.tpl: must supply \"template\" attribute in <apply>\nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common"+ ,"templates-bad/apply-template-not-found.tpl: apply tag cannot find template \"/page\"\nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common"+ ,"templates-bad/bind-infinite-loop.tpl: template recursion exceeded max depth, you probably have infinite splice recursion!\nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common"+ ,"templates-bad/bind-missing-attr.tpl: must supply \"tag\" attribute in <bind>\nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common"+ ]+#else ["templates-bad/bind-infinite-loop.tpl: template recursion exceeded max depth, you probably have infinite splice recursion!" ,"templates-bad/apply-template-not-found.tpl: apply tag cannot find template \"/page\"" ,"templates-bad/bind-missing-attr.tpl: must supply \"tag\" attribute in <bind>" ,"templates-bad/apply-missing-attr.tpl: must supply \"template\" attribute in <apply>" ]+#endif attrSpliceTest :: IO ()@@ -79,8 +91,8 @@ where expected1 = "<input type='checkbox' value='foo' checked />\n<input type='checkbox' value='bar' />\n" expected2 = "<input type='checkbox' value='foo' />\n<input type='checkbox' value='bar' checked />\n"- expected3 = "<input type=\"checkbox\" value=\"foo\" checked /> <input type=\"checkbox\" value=\"bar\" /> "- expected4 = "<input type=\"checkbox\" value=\"foo\" /> <input type=\"checkbox\" value=\"bar\" checked /> "+ expected3 = "<input type=\"checkbox\" value=\"foo\" checked />\n<input type=\"checkbox\" value=\"bar\" />\n"+ expected4 = "<input type=\"checkbox\" value=\"foo\" />\n<input type=\"checkbox\" value=\"bar\" checked />\n" fooSplice :: I.Splice (StateT Int IO) fooSplice = do@@ -92,9 +104,10 @@ tdirCacheTest = do let rSplices = ("foosplice" ## fooSplice) dSplices = ("foosplice" ## stateSplice)- hc = HeistConfig rSplices mempty dSplices mempty mempty+ 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@@ -152,7 +165,7 @@ ["<html><head>\n<link href='wrapper-link' />\n" ,"<link href='nav-link' />\n\n<link href='index-link' />" ,"</head>\n\n<body>\n\n<div>nav bar</div>\n\n\n"- ,"<div>index page</div>\n\n</body>\n</html> "+ ,"<div>index page</div>\n\n</body>\n</html>\n\n" ] bindApplyInteractionTest :: IO ()@@ -166,13 +179,13 @@ H.assertEqual "interpreted failure" iExpected iOut where cExpected = B.intercalate "\n"- [" This is a test."- ,"===bind content=== Another test line."- ,"apply content Last test line."- ," "+ ["\nThis is a test."+ ,"===bind content===\nAnother test line."+ ,"apply content\nLast test line."+ ,"\n" ] iExpected = B.unlines- [" This is a test."+ ["\nThis is a test." ,"===bind content===" ,"Another test line." ,"apply content"@@ -187,11 +200,10 @@ backslashHandlingTest = do hs <- loadHS "templates" cOut <- cRender hs "backslash"- H.assertEqual "compiled failure" cExpected cOut+ H.assertEqual "compiled failure" expected cOut iOut <- iRender hs "backslash"- H.assertEqual "interpreted failure" iExpected iOut+ H.assertEqual "interpreted failure" expected iOut where- cExpected = "<foo regex='abc\\d+\\\\e'></foo> "- iExpected = "<foo regex='abc\\d+\\\\e'></foo>\n"+ expected = "<foo regex='abc\\d+\\\\e'></foo>\n"
test/suite/Heist/Tutorial/CompiledSplices.lhs view
@@ -28,10 +28,8 @@ > import Heist.Tutorial.Imports > import Control.Applicative-> import qualified Data.Text as T-> import Data.Text.Encoding-> import qualified Heist.Compiled.LowLevel as C-> import Text.XmlHtml+> import Control.Lens+> import Data.Map.Syntax As a review, normal (interpreted) Heist splices are defined like this. @@ -112,10 +110,13 @@ > -> Splices (C.Splice n) > -> IO (HeistState n) > load baseDir splices = do-> tmap <- runEitherT $ do-> let hc = HeistConfig mempty defaultLoadTimeSplices splices mempty-> [loadTemplates baseDir]-> initHeist hc+> 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.@@ -147,7 +148,7 @@ > > personSplices :: Monad n > => Splices (RuntimeSplice n Person -> C.Splice n)-> personSplices = mapS (C.pureSplice . C.textSplice) $ do+> personSplices = mapV (C.pureSplice . C.textSplice) $ do > "firstName" ## pFirstName > "lastName" ## pLastName > "age" ## pack . show . pAge@@ -248,7 +249,6 @@ < failingSplice :: MonadSnap m => C.Splice m < failingSplice = do-< children <- childNodes <$> getParamNode < promise <- C.newEmptyPromise < outputChildren <- C.withSplices C.runChildren splices (C.getPromise promise) < return $ C.yieldRuntime $ do @@ -268,7 +268,7 @@ < < splices :: Monad n < => Splices (RuntimeSplice n (Text, Text) -> C.Splice n)-< splices = mapS (C.pureSplice . C.nodeSplice) $ do+< splices = mapS (C.pureSplice . C.htmlNodeSplice) $ do < "user" ## (:[]) . TextNode . fst < "value" ## (:[]) . TextNode . snd
test/suite/Heist/Tutorial/Imports.hs view
@@ -10,13 +10,14 @@ , T.Text , T.pack , ByteString- , runEitherT+ , runExceptT+ , ExceptT(..) ) where import Blaze.ByteString.Builder-import Control.Error (runEitherT) 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
test/suite/TestSuite.hs view
@@ -1,5 +1,6 @@ module Main where +import System.Directory import Test.Framework (defaultMain, testGroup) import qualified Heist.Interpreted.Tests@@ -7,7 +8,10 @@ import qualified Heist.Tests main :: IO ()-main = defaultMain 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"
+ test/templates-defer/test.tpl view
@@ -0,0 +1,5 @@+<h:plain><h:use/> <h:use/></h:plain>+<h:defer><h:use/> <h:use/></h:defer>+<h:maydefer><h:use/> <h:use/></h:maydefer>+<h:maydefer2><h:use/> <h:use/></h:maydefer2>+<h:defermany><h:use/> <h:use/></h:defermany>
+ test/templates-loaderror/_error.tpl view
@@ -0,0 +1,1 @@+<h:adder value="noparse"/>
+ test/templates-loaderror/_ok.tpl view
@@ -0,0 +1,1 @@+<h:adder value="1"/>
+ test/templates-loaderror/test.tpl view
@@ -0,0 +1,3 @@+<h:call1/>+<h:call2/>+<h:call1/>
+ test/templates-ns-nested/test.tpl view
@@ -0,0 +1,1 @@+<div><h:foo/></div>
+ test/templates-nsbind/nsbind.tpl view
@@ -0,0 +1,7 @@+Alpha+<h:main>+Beta+<h:sub/>+Gamma+<sub/>+</h:main>
+ test/templates-nsbind/nsbinderror.tpl view
@@ -0,0 +1,10 @@+Alpha+<h:invalid1/>+<h:main>+<h:recurse>+<h:invalid2/>+</h:recurse>+</h:main>+<h:main2>+<h:invalid3/>+</h:main2>
+ test/templates-nscall/_call.tpl view
@@ -0,0 +1,2 @@+Called+<h:sub/>
+ test/templates-nscall/_invalid.tpl view
@@ -0,0 +1,1 @@+<h:invalid/>
+ test/templates-nscall/nscall.tpl view
@@ -0,0 +1,6 @@+Top+<h:main>+Inside 1+<h:call/>+Inside 2+</h:main>
+ test/templates/backslash.tpl view
@@ -0,0 +1,1 @@+<foo regex='abc\d+\\e'/>
+ test/templates/json_array.tpl view
@@ -0,0 +1,1 @@+<jsonArray><value var="ctx.0"/>, <value var="ctx.1"/> and <with var="ctx.2"><value:deep/> <value:inside/></with></jsonArray>
+ test/templates/namespaces.tpl view
@@ -0,0 +1,5 @@+Alpha+<foo aoeu="htns">Inside foo</foo>+Beta+<h:foo aoeu="htns">Inside h:foo</h:foo>+End
+ test/templates/pandoc.tpl view
@@ -0,0 +1,1 @@+<pandocnodiv file="test.md"/>
+ test/templates/pandocdiv.tpl view
@@ -0,0 +1,1 @@+<pandocdiv file="test.md" id="pandoc" class="foo"/>
+ test/templates/rss.xtpl view
@@ -0,0 +1,1 @@+<rss><channel><link>http://www.devalot.com/</link></channel></rss>