heist 0.14.1.4 → 1.1.1.2
raw patch · 48 files changed
Files
- CHANGELOG.md +63/−0
- README.md +3/−1
- heist.cabal +170/−44
- src/Heist.hs +91/−67
- src/Heist/Common.hs +30/−18
- src/Heist/Compiled.hs +2/−0
- src/Heist/Compiled/Internal.hs +107/−68
- src/Heist/Internal/Types.hs +49/−13
- src/Heist/Internal/Types/HeistState.hs +156/−34
- src/Heist/Interpreted.hs +1/−0
- src/Heist/Interpreted/Internal.hs +11/−1
- src/Heist/SpliceAPI.hs +0/−102
- src/Heist/Splices.hs +29/−1
- src/Heist/Splices/Apply.hs +2/−4
- src/Heist/Splices/Bind.hs +1/−2
- src/Heist/Splices/BindStrict.hs +1/−2
- src/Heist/Splices/Cache.hs +5/−2
- src/Heist/Splices/Json.hs +37/−12
- src/Heist/Splices/Markdown.hs +179/−38
- src/Heist/TemplateDirectory.hs +11/−11
- test/.ghci +0/−5
- test/README +0/−1
- test/heist-testsuite.cabal +0/−101
- test/runTestsAndCoverage.sh +0/−48
- test/suite/Benchmark.hs +4/−4
- test/suite/Heist/Compiled/Tests.hs +228/−35
- test/suite/Heist/Interpreted/Tests.hs +32/−6
- test/suite/Heist/TestCommon.hs +32/−12
- test/suite/Heist/Tests.hs +22/−13
- test/suite/Heist/Tutorial/CompiledSplices.lhs +4/−5
- 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
+ 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.14.1.4+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,10 +121,40 @@ 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:@@ -119,7 +163,6 @@ Heist.Compiled.LowLevel, Heist.Internal.Types, Heist.Interpreted,- Heist.SpliceAPI, Heist.Splices, Heist.Splices.Apply, Heist.Splices.Bind,@@ -139,49 +182,36 @@ Heist.Interpreted.Internal build-depends:- MonadCatchIO-transformers >= 0.2.1 && < 0.4,- aeson >= 0.6 && < 0.12,- attoparsec >= 0.10 && < 0.14,- base >= 4.5 && < 5,+ aeson >= 0.6 && < 2.3,+ attoparsec >= 0.10 && < 0.15, blaze-builder >= 0.2 && < 0.5,- blaze-html >= 0.4 && < 0.9,- bytestring >= 0.9 && < 0.11,- containers >= 0.2 && < 0.6,- directory >= 1.1 && < 1.3,+ 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,- either >= 3.1 && < 4.5,+ dlist >= 0.5 && < 1.1, filepath >= 1.3 && < 1.5,- hashable >= 1.1 && < 1.3,- map-syntax >= 0.2 && < 0.3,- mtl >= 2.0 && < 2.3,- process >= 1.1 && < 1.3,- random >= 1.0.1.0 && < 1.2,- text >= 0.10 && < 1.3,- time >= 1.1 && < 1.6,- transformers >= 0.3 && < 0.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.12,- 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 @@ -189,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 #-} @@ -39,6 +40,8 @@ , RuntimeSplice , Chunk , HeistState+ , SpliceError(..)+ , CompileException(..) , HeistT -- * Lenses (can be used with lens or lens-family)@@ -47,6 +50,7 @@ , scCompiledSplices , scAttributeSplices , scTemplateLocations+ , scCompiledTemplateFilter , hcSpliceConfig , hcNamespace , hcErrorNotBound@@ -55,6 +59,7 @@ , hcCompiledSplices , hcAttributeSplices , hcTemplateLocations+ , hcCompiledTemplateFilter -- * HeistT functions , templateNames@@ -76,17 +81,21 @@ , getDoc , getXMLDoc , tellSpliceError+ , spliceErrorText , orError- , module Heist.SpliceAPI+ , Splices++ -- * TPath functions+ , lookupTemplate+ , splitTemplatePath ) where -------------------------------------------------------------------------------import Control.Exception (SomeException)-import Control.Monad.CatchIO+import Control.Exception.Lifted import Control.Monad.State-import Control.Monad.Trans.Either 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@@ -94,7 +103,9 @@ 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@@ -103,7 +114,6 @@ import Heist.Common import qualified Heist.Compiled.Internal as C import qualified Heist.Interpreted.Internal as I-import Heist.SpliceAPI import Heist.Splices import Heist.Internal.Types ------------------------------------------------------------------------------@@ -147,11 +157,11 @@ 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 @@ -160,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@@ -202,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 "" [] False 0+ True [] [] 0 [] Nothing kg False Html "" [] False 0 ------------------------------------------------------------------------------@@ -224,11 +238,13 @@ -- function. initHeist :: Monad n => HeistConfig n- -> EitherT [String] IO (HeistState n)+ -> IO (Either [String] (HeistState n)) initHeist hc = do- keyGen <- lift HE.newKeyGen+ keyGen <- HE.newKeyGen repos <- sequence $ _scTemplateLocations $ _hcSpliceConfig hc- initHeist' keyGen hc (Map.unions repos)+ case sequence repos of+ Left es -> return $ Left es+ Right rs -> initHeist' keyGen hc (Map.unions rs) ------------------------------------------------------------------------------@@ -243,29 +259,28 @@ => HE.KeyGen -> HeistConfig n -> TemplateRepo- -> EitherT [String] IO (HeistState n)+ -> IO (Either [String] (HeistState n)) initHeist' keyGen (HeistConfig sc ns enn) repo = do let empty = emptyHS keyGen- let (SpliceConfig i lt c a _) = sc- tmap <- preproc keyGen lt repo ns+ let (SpliceConfig i lt c a _ f) = sc+ etmap <- preproc keyGen lt repo ns let prefix = mkSplicePrefix ns- is <- runHashMap $ mapK (prefix<>) i- cs <- runHashMap $ mapK (prefix<>) c- as <- runHashMap $ mapK (prefix<>) a- let hs1 = empty { _spliceMap = is- , _templateMap = tmap- , _compiledSpliceMap = cs- , _attrSpliceMap = as- , _splicePrefix = prefix- , _errorNotBound = enn- }- EitherT $ C.compileTemplates hs1--- liftIO $ when (not $ null $ _spliceErrors hs2) $ do--- putStrLn "Finished compiling with errors..."--- mapM_ T.putStrLn $ _spliceErrors hs2--- case _spliceErrors hs2 of--- [] -> return hs2--- es -> left $ map T.unpack es+ 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 ------------------------------------------------------------------------------@@ -274,19 +289,22 @@ -> Splices (I.Splice IO) -> TemplateRepo -> Text- -> EitherT [String] IO TemplateRepo+ -> IO (Either [String] TemplateRepo) preproc keyGen splices templates ns = do- sm <- runHashMap splices- let hs = (emptyHS keyGen) { _spliceMap = sm- , _templateMap = templates- , _preprocessingMode = True- , _splicePrefix = mkSplicePrefix ns }- 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+ 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 ------------------------------------------------------------------------------@@ -295,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." ------------------------------------------------------------------------------@@ -311,22 +330,27 @@ -- implementation. initHeistWithCacheTag :: MonadIO n => HeistConfig n- -> EitherT [String] IO (HeistState n, CacheTagState)+ -> 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 $ _scTemplateLocations sc- -- 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) ns-- let sc' = SpliceConfig (tag #! cacheImpl cts) mempty- (tag #! cacheImplCompiled cts) mempty mempty- let hc = HeistConfig (mappend sc sc') ns enn- 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,15 +1,15 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Heist.Common where -------------------------------------------------------------------------------import Control.Applicative (Alternative (..), Applicative (..), (<$>))+import Control.Applicative (Alternative (..)) import Control.Exception (SomeException)-import qualified Control.Monad.CatchIO as C+import qualified Control.Exception.Lifted as C import Control.Monad (liftM, mplus)-import Control.Monad.Trans.Either import qualified Data.Attoparsec.Text as AP import Data.ByteString (ByteString) import qualified Data.ByteString as B@@ -17,27 +17,30 @@ import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map-import Data.List (isSuffixOf)+import Data.List (isSuffixOf, sort) import Data.Map.Syntax import Data.Maybe (isJust)-import Data.Monoid (Monoid (..), (<>))+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- :: (Monad m)- => Splices s- -> EitherT [String] m (HashMap T.Text s)+ :: 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+ Left keys -> Left $ map (T.unpack . mkMsg) keys+ Right hm -> Right hm where mkMsg k = "You tried to bind "<>k<>" more than once!" @@ -87,8 +90,16 @@ -- | Adds an error message to the list of splice processing errors. tellSpliceError :: Monad m => Text -> HeistT n m () tellSpliceError msg = do- fullMsg <- heistErrMsg msg- modifyHS (\hs -> hs { _spliceErrors = fullMsg : _spliceErrors hs })+ 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' }) ------------------------------------------------------------------------------@@ -179,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@@ -339,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" ------------------------------------------------------------------------------
src/Heist/Compiled.hs view
@@ -28,11 +28,13 @@ , 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,6 +14,7 @@ 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@@ -33,6 +35,11 @@ import qualified Text.XmlHtml as X import qualified Text.XmlHtml.HTML.Meta as X ------------------------------------------------------------------------------+#if !MIN_VERSION_base(4,8,0)+import Data.Foldable (Foldable)+#endif+import qualified Data.Foldable as Foldable+------------------------------------------------------------------------------ import Heist.Common import Heist.Internal.Types.HeistState ------------------------------------------------------------------------------@@ -45,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.@@ -159,17 +166,26 @@ ------------------------------------------------------------------------------ compileTemplates :: Monad n- => HeistState n+ => (TPath -> Bool)+ -> HeistState n -> IO (Either [String] (HeistState n))-compileTemplates hs = do- (tmap, hs') <- runHeistT compileTemplates' (X.TextNode "") hs+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 $ case _spliceErrors hs' of- [] -> nsErr >> (Right $! hs { _compiledTemplateMap = tmap })- es -> Left $ either (++) (const id) nsErr $ map T.unpack es+ 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+ }) ------------------------------------------------------------------------------@@ -187,11 +203,12 @@ ------------------------------------------------------------------------------ compileTemplates' :: Monad n- => HeistT n IO (H.HashMap TPath ([Chunk n], MIMEType))-compileTemplates' = do+ => (TPath -> Bool)+ -> HeistT n IO (H.HashMap TPath ([Chunk n], MIMEType))+compileTemplates' f = do hs <- getHS let tpathDocfiles :: [(TPath, DocumentFile)]- tpathDocfiles = map (\(a,b) -> (a, b))+ tpathDocfiles = filter (f . fst) (H.toList $ _templateMap hs) foldM runOne H.empty tpathDocfiles where@@ -238,7 +255,7 @@ --------------------------------------------------------------------------------- | 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@@ -257,11 +274,9 @@ lookupSplice nm = do pre <- getsHS _splicePrefix res <- getsHS (H.lookup nm . _compiledSpliceMap)- canError <- getsHS _errorNotBound if isNothing res && T.isPrefixOf pre nm && not (T.null pre) then do- when canError $- tellSpliceError $ "No splice bound for " `mappend` nm+ tellSpliceError $ "No splice bound for " `mappend` nm return Nothing else return res @@ -272,14 +287,37 @@ -- compileNode to generate the appropriate runtime computation. runNode :: Monad n => X.Node -> Splice n runNode node = localParamNode (const node) $ do- pre <- getsHS _splicePrefix+ hs <- getHS+ let pre = _splicePrefix hs let hasPrefix = (T.isPrefixOf pre `fmap` X.tagName node) == Just True when (not (T.null pre) && hasPrefix) incNamespacedTags- isStatic <- subtreeIsStatic node- markup <- getsHS _curMarkup- if isStatic- then return $! yieldPure $! renderFragment markup [parseAttrs node]- else compileNode node+ 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@@ -575,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@@ -588,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@@ -613,9 +656,11 @@ --------------------------------------------------------------------------------- | 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" #-} ------------------------------------------------------------------------------@@ -653,35 +698,38 @@ withSplices splice splices runtimeAction = withLocalSplices splices' mempty splice where- splices' = mapV ($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' = mapV ($ getPromise p) splices- chunks <- withLocalSplices splices' mempty 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@@ -690,68 +738,59 @@ 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
@@ -21,11 +21,16 @@ ) where -------------------------------------------------------------------------------import Control.Applicative-import Control.Monad.Trans.Either import Data.HashMap.Strict (HashMap)-import Data.Monoid 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@@ -41,7 +46,7 @@ -- | 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+type TemplateLocation = IO (Either [String] TemplateRepo) ------------------------------------------------------------------------------@@ -54,24 +59,28 @@ -- | 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)+ { _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)+ , _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)+ , _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)+ , _scAttributeSplices :: Splices (AttrSplice m) -- ^ Attribute splices are bound to attribute names and return a list -- of attributes.- , _scTemplateLocations :: [TemplateLocation]+ , _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. } @@ -135,11 +144,28 @@ 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- mappend (SpliceConfig a1 b1 c1 d1 e1) (SpliceConfig a2 b2 c2 d2 e2) =- SpliceConfig (mappend a1 a2) (mappend b1 b2) (mappend c1 c2)- (mappend d1 d2) (mappend e1 e2)+ mempty = SpliceConfig mempty mempty mempty mempty mempty (const True)+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif data HeistConfig m = HeistConfig@@ -239,5 +265,15 @@ => ([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
@@ -1,10 +1,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-|@@ -19,32 +21,53 @@ module Heist.Internal.Types.HeistState 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 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-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)+#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-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+#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 ------------------------------------------------------------------------------ @@ -105,15 +128,24 @@ -------------------------------------------------------------------------------instance (Monad m, Monoid a) => Monoid (RuntimeSplice m a) where- mempty = return mempty-- a `mappend` b = do+instance (Monad m, Semigroup a) => Semigroup (RuntimeSplice m a) where+ a <> b = do !x <- a !y <- b- return $! x `mappend` y+ 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@@ -151,6 +183,55 @@ ------------------------------------------------------------------------------+-- | 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@@@ -175,6 +256,8 @@ , _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@@ -198,7 +281,7 @@ , _splicePrefix :: Text -- | List of errors encountered during splice processing.- , _spliceErrors :: [Text]+ , _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@@ -318,7 +401,15 @@ {-# 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@@ -332,16 +423,45 @@ 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)+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@@ -453,7 +573,7 @@ -- 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"@.+-- return @Just \"Shakespeare\"@. getParamNode :: Monad m => HeistT n m X.Node getParamNode = HeistT $ curry return {-# INLINE getParamNode #-}@@ -508,6 +628,8 @@ -- 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 #-}
src/Heist/Interpreted.hs view
@@ -74,6 +74,7 @@ , callTemplate , callTemplateWithText , renderTemplate+ , renderTemplateToDoc , renderWithArgs ) where
src/Heist/Interpreted/Internal.hs view
@@ -192,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 ------------------------------------------------------------------------------@@ -387,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@@ -411,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,102 +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- {-# DEPRECATED "Use Data.Map.Syntax from the map-syntax package instead" #-}- ( SplicesM- , Splices- , noSplices- , mapS- , applyS- , ($$)- , mapNames- , prefixSplices- , namespaceSplices- , module Data.Map.Syntax- ) where---------------------------------------------------------------------------------import Data.Map.Syntax-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import Heist.Internal.Types.HeistState (Splices)----------------------------------------------------------------------------------{-# DEPRECATED SplicesM, applyS, ($$)- "Use functions from the map-syntax package instead" #-}--type SplicesM s a = MapSyntaxM Text s a--noSplices :: Splices s-noSplices = mempty-{-# DEPRECATED noSplices "Use mempty instead" #-}------------------------------------------------------------------------------------ | Maps a function over all the splices.-mapS :: (a -> b) -> Splices a -> Splices b-mapS = mapV-{-# DEPRECATED mapS "Use mapV from the map-syntax package instead" #-}------------------------------------------------------------------------------------ | Applies an argument to a splice function.-applyS :: a -> Splices (a -> b) -> Splices b-applyS a = mapS ($a)------------------------------------------------------------------------------------ | 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 = mapK-{-# DEPRECATED mapNames "Use mapK from the map-syntax package instead" #-}------------------------------------------------------------------------------------ | 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 = mapK 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@@ -19,6 +26,7 @@ import Heist.Splices.Ignore import Heist.Splices.Markdown import Heist.Internal.Types.HeistState+import qualified Text.XmlHtml as X ------------------------------------------------------------------------------ -- | Run the splice contents if given condition is True, make splice disappear@@ -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
@@ -1,10 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-} module Heist.Splices.Apply where -------------------------------------------------------------------------------import Control.Monad.Trans import Data.Maybe import Data.Text (Text) import qualified Data.Text as T@@ -69,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)@@ -84,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@@ -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@@ -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,10 +36,12 @@ 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
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,7 +13,13 @@ 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)@@ -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,7 +218,7 @@ (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@@ -213,13 +228,23 @@ -------------------------------------------------------------------------- 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 bindings >> newBindings+#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.Interpreted.Internal import Heist.Internal.Types.HeistState+import Heist.Interpreted.Internal data PandocMissingException = PandocMissingException deriving (Typeable) instance Show PandocMissingException where show PandocMissingException =- "Cannot find the \"pandoc\" executable; 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
@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleContexts #-} {-| This module defines a TemplateDirectory data structure for convenient@@ -20,7 +19,6 @@ import Control.Concurrent import Control.Monad import Control.Monad.Trans-import Control.Monad.Trans.Either import Heist import Heist.Internal.Types import Heist.Splices.Cache@@ -44,14 +42,17 @@ => FilePath -> HeistConfig n -- namespaced tag.- -> EitherT [String] IO (TemplateDirectory n)+ -> IO (Either [String] (TemplateDirectory n)) newTemplateDirectory dir hc = do let sc = (_hcSpliceConfig hc) { _scTemplateLocations = [loadTemplates dir] } let hc' = hc { _hcSpliceConfig = sc }- (hs,cts) <- initHeistWithCacheTag hc'- tsMVar <- liftIO $ newMVar hs- ctsMVar <- liftIO $ newMVar cts- return $ TemplateDirectory dir hc' tsMVar ctsMVar+ 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 ------------------------------------------------------------------------------@@ -63,7 +64,7 @@ -> HeistConfig n -> IO (TemplateDirectory n) newTemplateDirectory' dir hc = do- res <- runEitherT $ newTemplateDirectory dir hc+ res <- newTemplateDirectory dir hc either (error . concat) return res @@ -88,9 +89,8 @@ => TemplateDirectory n -> IO (Either String ()) reloadTemplateDirectory (TemplateDirectory p hc tsMVar ctsMVar) = do- ehs <- runEitherT $ do- let sc = (_hcSpliceConfig hc) { _scTemplateLocations = [loadTemplates p] }- initHeistWithCacheTag (hc { _hcSpliceConfig = sc })+ 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)
− 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,101 +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.12,- attoparsec >= 0.10 && < 0.14,- base >= 4.5 && < 5,- blaze-builder >= 0.2 && < 0.5,- blaze-html >= 0.4 && < 0.9,- 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,- either >= 3.1 && < 4.5,- errors >= 1.4 && < 1.5,- filepath >= 1.3 && < 1.5,- hashable >= 1.1 && < 1.3,- lens >= 4.3 && < 4.14,- mtl >= 2.0 && < 2.3,- process >= 1.1 && < 1.3,- random >= 1.0.1.0 && < 1.2,- text >= 0.10 && < 1.3,- time >= 1.1 && < 1.6,- transformers >= 0.2 && < 0.5,- unordered-containers >= 0.1.4 && < 0.3,- vector >= 0.9 && < 0.12,- 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 >= 1.0 && < 1.1,- test-framework >= 0.4 && < 0.9,- test-framework-hunit >= 0.2 && < 0.4,-- -- Copied from regular dependencies:-- aeson >= 0.6 && < 0.12,- attoparsec >= 0.10 && < 0.14,- base >= 4.5 && < 5,- blaze-builder >= 0.2 && < 0.5,- blaze-html >= 0.4 && < 0.9,- 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,- either >= 3.1 && < 4.5,- errors >= 1.4 && < 1.5,- filepath >= 1.3 && < 1.5,- hashable >= 1.1 && < 1.3,- map-syntax >= 0.1 && < 0.3,- mtl >= 2.0 && < 2.3,- process >= 1.1 && < 1.3,- random >= 1.0.1.0 && < 1.2,- statistics >= 0.11 && < 0.14,- text >= 0.10 && < 1.3,- time >= 1.1 && < 1.6,- transformers >= 0.2 && < 0.5,- unordered-containers >= 0.1.4 && < 0.3,- vector >= 0.9 && < 0.12,- 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
@@ -6,9 +6,9 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Control.Concurrent-import Control.Error import Control.Exception (evaluate) import Control.Monad+import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT) import Criterion import Criterion.Main import Criterion.Measurement hiding (getTime)@@ -32,10 +32,10 @@ ------------------------------------------------------------------------------ loadWithCache baseDir = do- etm <- runEitherT $ do+ etm <- runExceptT $ do let sc = SpliceConfig mempty defaultLoadTimeSplices mempty mempty- [loadTemplates baseDir]- initHeistWithCacheTag $ HeistConfig sc "" False+ [loadTemplates baseDir] (const True)+ ExceptT $ initHeistWithCacheTag $ HeistConfig sc "" False either (error . unlines) (return . fst) etm main = do
test/suite/Heist/Compiled/Tests.hs view
@@ -1,18 +1,29 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Heist.Compiled.Tests where import Blaze.ByteString.Builder-import Control.Error+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 ------------------------------------------------------------------------------@@ -37,9 +48,15 @@ , 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 ()@@ -48,7 +65,7 @@ H.assertEqual "compiled state splice" expected res where expected =- mappend doctype "\n <html> 3 </html> "+ mappend doctype "\n\n<html>\n3\n</html>\n" peopleTest :: IO () peopleTest = do@@ -56,7 +73,7 @@ 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@@ -67,8 +84,8 @@ genericTest :: String -> ByteString -> ByteString -> IO () genericTest nm template expected = do- res <- runEitherT $ do- hs <- initHeist templateHC+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist templateHC runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs template b <- lift $ fst runner@@ -80,12 +97,12 @@ doctypeTest = genericTest "doctype test" "rss" expected where expected = encodeUtf8- "<rss><channel><link>http://www.devalot.com/</link></channel></rss> "+ "<rss><channel><link>http://www.devalot.com/</link></channel></rss>\n" namespaceTest1 :: IO () namespaceTest1 = do- res <- runEitherT $ do- hs <- initHeist templateHC+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist templateHC runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "namespaces" b <- lift $ fst runner@@ -93,13 +110,13 @@ H.assertEqual "namespace test 1" (Right expected) res where- expected = "Alpha\naoeu Beta\n<h:foo aoeu='htns'>Inside h:foo</h:foo> End\n"+ expected = "Alpha\naoeu\nBeta\n<h:foo aoeu='htns'>Inside h:foo</h:foo>\nEnd\n" namespaceTest2 :: IO () namespaceTest2 = do- res <- runEitherT $ do- hs <- initHeist $ templateHC & hcErrorNotBound .~ True+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ templateHC & hcErrorNotBound .~ True runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "namespaces" b <- lift $ fst runner@@ -107,13 +124,13 @@ H.assertEqual "namespace test 2" (Right expected) res where- expected = "Alpha\naoeu Beta\n<h:foo aoeu='htns'>Inside h:foo</h:foo> End\n"+ expected = "Alpha\naoeu\nBeta\n<h:foo aoeu='htns'>Inside h:foo</h:foo>\nEnd\n" namespaceTest3 :: IO () namespaceTest3 = do- res <- runEitherT $ do- hs <- initHeist $ templateHC & hcNamespace .~ "h"+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h" runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "namespaces" b <- lift $ fst runner@@ -121,13 +138,13 @@ H.assertEqual "namespace test 3" (Right expected) res where- expected = "Alpha\n<foo aoeu='htns'>Inside foo</foo> Beta\naoeu End\n"+ expected = "Alpha\n<foo aoeu='htns'>Inside foo</foo>\nBeta\naoeu\nEnd\n" namespaceTest4 :: IO () namespaceTest4 = do- res <- runEitherT $ do- hs <- initHeist $ templateHC & hcNamespace .~ "h"+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h" & hcErrorNotBound .~ True runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "namespaces"@@ -136,13 +153,13 @@ H.assertEqual "namespace test 4" (Right expected) res where- expected = "Alpha\n<foo aoeu='htns'>Inside foo</foo> Beta\naoeu End\n"+ expected = "Alpha\n<foo aoeu='htns'>Inside foo</foo>\nBeta\naoeu\nEnd\n" namespaceTest5 :: IO () namespaceTest5 = do- res <- runEitherT $ do- hs <- initHeist $ templateHC & hcNamespace .~ "h"+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h" & hcCompiledSplices .~ mempty & hcErrorNotBound .~ True runner <- noteT ["Error rendering"] $ hoistMaybe $@@ -157,8 +174,8 @@ -- this test will throw an error. noNsSplices :: IO () noNsSplices = do- res <- runEitherT $ do- hs <- initHeist hc+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist hc runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "test" b <- lift $ fst runner@@ -172,27 +189,59 @@ & scTemplateLocations .~ [loadTemplates "templates-no-ns"] -nsBindTemplateHC :: HeistConfig IO-nsBindTemplateHC = HeistConfig sc "h" False+------------------------------------------------------------------------------+-- | 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 "templates-nsbind"]+ & scTemplateLocations .~ [loadTemplates dir] + nsBindTestSplices :: Splices (Splice IO)-nsBindTestSplices = "main" ## do+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 = mapV (pureSplice . textSplice) $- "sub" ## const "asdf"+nsBindSubSplices = do+ "sub" ## pureSplice . textSplice $ const "asdf"+ "recurse" ## nsBindSubImpl nsBindTest :: IO () nsBindTest = do- res <- runEitherT $ do- hs <- initHeist $ nsBindTemplateHC+ res <- runExceptT $ do+ hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind") runner <- noteT ["Error rendering"] $ hoistMaybe $ renderTemplate hs "nsbind" b <- lift $ fst runner@@ -200,17 +249,161 @@ H.assertEqual "namespace bind test" (Right expected) res where- expected = "Alpha\n Beta\nasdf Gamma\n<sub></sub> "+ expected = "Alpha\n\nBeta\nasdf\nGamma\n<sub></sub>\n\n" +------------------------------------------------------------------------------+-- | Test splice error reporting. nsBindErrorTest :: IO () nsBindErrorTest = do- res <- runEitherT $ do- hs <- initHeist $ nsBindTemplateHC- & hcErrorNotBound .~ True+ 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 ["templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid"]) res+ 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,7 +11,7 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder-import Control.Error+import Control.Monad import Control.Monad.State import Data.Aeson import Data.ByteString.Char8 (ByteString)@@ -36,13 +36,13 @@ ------------------------------------------------------------------------------ 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.Internal.Types import qualified Text.XmlHtml as X import qualified Text.XmlHtml.Cursor as X @@ -61,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@@ -139,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" 38 $ Map.size tm+ H.assertEqual "loadTest size" 41 $ Map.size tm ) ets @@ -183,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" ] ------------------------------------------------------------------------------@@ -240,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@@ -268,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@@ -602,7 +629,6 @@ Nothing)) hs evalHeistT (runNodeList $ buildApplyCaller apply) (X.TextNode "") hs'-
test/suite/Heist/TestCommon.hs view
@@ -2,11 +2,11 @@ ------------------------------------------------------------------------------ import Blaze.ByteString.Builder-import Control.Error import Control.Monad.Trans+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B-import Data.Map.Syntax import Data.Maybe import Data.Monoid @@ -35,11 +35,11 @@ -> Splices (C.Splice m) -> Splices (AttrSplice m) -> IO (Either [String] (HeistState m))-loadT baseDir a b c d = runEitherT $ do+loadT baseDir a b c d = runExceptT $ do let sc = SpliceConfig (defaultInterpretedSplices `mappend` a) (defaultLoadTimeSplices `mappend` b) c d- [loadTemplates baseDir]- initHeist $ HeistConfig sc "" False+ [loadTemplates baseDir] (const True)+ ExceptT $ initHeist $ HeistConfig sc "" False ------------------------------------------------------------------------------@@ -49,21 +49,21 @@ -> Splices (C.Splice IO) -> Splices (AttrSplice IO) -> IO (Either [String] (HeistState IO))-loadIO baseDir a b c d = runEitherT $ do+loadIO baseDir a b c d = runExceptT $ do let sc = SpliceConfig (defaultInterpretedSplices >> a) (defaultLoadTimeSplices >> b) c d- [loadTemplates baseDir]- initHeist $ HeistConfig sc "" False+ [loadTemplates baseDir] (const True)+ ExceptT $ initHeist $ HeistConfig sc "" False ------------------------------------------------------------------------------ loadHS :: FilePath -> IO (HeistState IO) loadHS baseDir = do- etm <- runEitherT $ do+ etm <- runExceptT $ do let sc = SpliceConfig defaultInterpretedSplices defaultLoadTimeSplices mempty mempty- [loadTemplates baseDir]- initHeist $ HeistConfig sc "" False+ [loadTemplates baseDir] (const True)+ ExceptT $ initHeist $ HeistConfig sc "" False either (error . concat) return etm @@ -75,7 +75,8 @@ loadEmpty a b c d = do let sc = SpliceConfig (defaultInterpretedSplices `mappend` a) (defaultLoadTimeSplices `mappend` b) c d mempty- res <- runEitherT $ initHeist $ HeistConfig sc "" False+ (const True)+ res <- initHeist $ HeistConfig sc "" False either (error . concat) return res @@ -112,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@@ -51,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 ()@@ -81,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@@ -94,7 +104,7 @@ tdirCacheTest = do let rSplices = ("foosplice" ## fooSplice) dSplices = ("foosplice" ## stateSplice)- sc = SpliceConfig rSplices mempty dSplices mempty mempty+ sc = SpliceConfig rSplices mempty dSplices mempty mempty (const True) hc = HeistConfig sc "" False td <- newTemplateDirectory' "templates" hc @@ -155,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 ()@@ -169,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"@@ -190,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
@@ -110,11 +110,11 @@ > -> Splices (C.Splice n) > -> IO (HeistState n) > load baseDir splices = do-> tmap <- runEitherT $ do+> tmap <- runExceptT $ do > let sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices > & scCompiledSplices .~ splices > & scTemplateLocations .~ [loadTemplates baseDir]-> initHeist $ emptyHeistConfig & hcNamespace .~ ""+> ExceptT $ initHeist $ emptyHeistConfig & hcNamespace .~ "" > & hcErrorNotBound .~ False > & hcSpliceConfig .~ sc > either (error . concat) return tmap@@ -148,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@@ -249,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 @@ -269,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>