diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,63 @@ +# 1.1.1.2 + +* Support GHC 9.8 +* Fix broken test + +# 1.1.1.1 + +* Support GHC 9.6 + +# 1.1.1.0 + +* Expose `lookupTemplate` and `splitTemplatePath` + +* Bump dependency bounds for 9.4 + +# 1.1 + +* Remove pandoc and pandocBS + +* Stop exporting readProcessWithExitCode' + +* Remove -S and --no-wrap arguments to pandoc for compatibility with both 1.x + and 2.x versions of the pandoc command line tool + +* Bump map-syntax lower bound to fix 8.4 build problem + +# 1.0.1.3 + +* Add Semigroup instances to support GHC 8.4 + +# 1.0.1.0 + +* Change benchmark from an executable section to a benchmark section in the + cabal file. This eliminates the criterion dependency when doing "cabal + install heist". +* Export manyWith + +# 1.0.0.1 + +* Drop the dependency on `errors` packages from heist testsuite and benchmark +* Fix nested splice namespace warning bug (issue #85) + +# 1.0.0.0 + +* Switch from MonadCatchIO-transformers to monad-control for Snap 1.0 + +# 0.14.0 + +See http://snapframework.com/blog/2014/09/24/heist-0.14-released + +* Add namespace support (hcNamespace and hcErrorNotBound) +* Add tellSpliceError for generalized error reporting +* Restructured HeistConfig, export lenses instead of field accessors +* Moved old HeistConfig into SpliceConfig +* Factored SpliceAPI module out into separate map-syntax package + +# 0.13.0 + +See http://snapframework.com/blog/2013/09/09/snap-0.13-released + +* Simpler compiled splice API +* New splice syntax + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # Heist +[![GitHub CI](https://github.com/snapframework/heist/workflows/CI/badge.svg)](https://github.com/snapframework/heist/actions) + Heist, part of the [Snap Framework](http://www.snapframework.com/), is a Haskell library for xml/html templating. It uses simple XML tags to bind values to your templates in a straightforward way. For example, if you were to @@ -15,7 +17,7 @@ Likewise, if you need to add text to an attribute, special-id -
very special
+
very special
gives you diff --git a/heist.cabal b/heist.cabal --- a/heist.cabal +++ b/heist.cabal @@ -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 \ 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 diff --git a/src/Heist.hs b/src/Heist.hs --- a/src/Heist.hs +++ b/src/Heist.hs @@ -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 diff --git a/src/Heist/Common.hs b/src/Heist/Common.hs --- a/src/Heist/Common.hs +++ b/src/Heist/Common.hs @@ -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" ------------------------------------------------------------------------------ diff --git a/src/Heist/Compiled.hs b/src/Heist/Compiled.hs --- a/src/Heist/Compiled.hs +++ b/src/Heist/Compiled.hs @@ -28,11 +28,13 @@ , pureSplice , deferMany + , defer , deferMap , mayDeferMap , bindLater , withSplices , manyWithSplices + , manyWith , withLocalSplices -- * Constructing Chunks diff --git a/src/Heist/Compiled/Internal.hs b/src/Heist/Compiled/Internal.hs --- a/src/Heist/Compiled/Internal.hs +++ b/src/Heist/Compiled/Internal.hs @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Heist/Internal/Types.hs b/src/Heist/Internal/Types.hs --- a/src/Heist/Internal/Types.hs +++ b/src/Heist/Internal/Types.hs @@ -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 diff --git a/src/Heist/Internal/Types/HeistState.hs b/src/Heist/Internal/Types/HeistState.hs --- a/src/Heist/Internal/Types/HeistState.hs +++ b/src/Heist/Internal/Types/HeistState.hs @@ -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 #-} diff --git a/src/Heist/Interpreted.hs b/src/Heist/Interpreted.hs --- a/src/Heist/Interpreted.hs +++ b/src/Heist/Interpreted.hs @@ -74,6 +74,7 @@ , callTemplate , callTemplateWithText , renderTemplate + , renderTemplateToDoc , renderWithArgs ) where diff --git a/src/Heist/Interpreted/Internal.hs b/src/Heist/Interpreted/Internal.hs --- a/src/Heist/Interpreted/Internal.hs +++ b/src/Heist/Interpreted/Internal.hs @@ -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 diff --git a/src/Heist/SpliceAPI.hs b/src/Heist/SpliceAPI.hs deleted file mode 100644 --- a/src/Heist/SpliceAPI.hs +++ /dev/null @@ -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 ":" - diff --git a/src/Heist/Splices.hs b/src/Heist/Splices.hs --- a/src/Heist/Splices.hs +++ b/src/Heist/Splices.hs @@ -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 \ element to get the markup to be used for the two cases. +ifElseISplice :: Monad m => Bool -> I.Splice m +ifElseISplice cond = getParamNode >>= (rewrite . X.childNodes) + where + rewrite nodes = + let (ns, ns') = break (\n -> X.tagName n==Just "else") nodes + in I.runNodeList $ if cond then ns else (drop 1 ns') + + +------------------------------------------------------------------------------ +-- | Implements an if\/then\/else conditional splice. It splits its children +-- around the \ element to get the markup to be used for the two cases. +ifElseCSplice :: Monad m => Bool -> C.Splice m +ifElseCSplice cond = getParamNode >>= (rewrite . X.childNodes) + where rewrite nodes = + let (ns, ns') = break (\n -> X.tagName n==Just "else") nodes + in C.runNodeList $ if cond then ns else (drop 1 ns') diff --git a/src/Heist/Splices/Apply.hs b/src/Heist/Splices/Apply.hs --- a/src/Heist/Splices/Apply.hs +++ b/src/Heist/Splices/Apply.hs @@ -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 -- 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 ++ diff --git a/src/Heist/Splices/Bind.hs b/src/Heist/Splices/Bind.hs --- a/src/Heist/Splices/Bind.hs +++ b/src/Heist/Splices/Bind.hs @@ -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 ++ diff --git a/src/Heist/Splices/BindStrict.hs b/src/Heist/Splices/BindStrict.hs --- a/src/Heist/Splices/BindStrict.hs +++ b/src/Heist/Splices/BindStrict.hs @@ -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 diff --git a/src/Heist/Splices/Cache.hs b/src/Heist/Splices/Cache.hs --- a/src/Heist/Splices/Cache.hs +++ b/src/Heist/Splices/Cache.hs @@ -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 diff --git a/src/Heist/Splices/Json.hs b/src/Heist/Splices/Json.hs --- a/src/Heist/Splices/Json.hs +++ b/src/Heist/Splices/Json.hs @@ -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 diff --git a/src/Heist/Splices/Markdown.hs b/src/Heist/Splices/Markdown.hs --- a/src/Heist/Splices/Markdown.hs +++ b/src/Heist/Splices/Markdown.hs @@ -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. + +> +> +> <pageTitle/> +> +>
+> +> + +And pandoc template, which would bind @pageTitle@ and @pageToc@ splices and +applies "_wrap" template. + +> +> +> $title$ +> $toc$ +> $body$ +> + +Bind splice pandoc splice. Set it to not wrap in div, or it will break html +from _wrap.tpl + +> splices = "docmarkdown" ## pandocSplice opts +> where +> opts = setPandocArgs ["-S", "--no-wrap", "--toc" +> , "--standalone" +> , "--template", "_pandoc.tpl" +> , "--html5"] +> $ setPandocWrapDiv Nothing +> $ defaultPandocOptions +> + +And then use it to render your markdown file + + +> +> +> +> +> +> +> +> +> +> + -} -module Heist.Splices.Markdown 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 [ "
\n" - , sout - , "\n
" ] + 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 [ "
\n" - , sout - , "\n
" ] + 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) - - - - diff --git a/src/Heist/TemplateDirectory.hs b/src/Heist/TemplateDirectory.hs --- a/src/Heist/TemplateDirectory.hs +++ b/src/Heist/TemplateDirectory.hs @@ -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) diff --git a/test/.ghci b/test/.ghci deleted file mode 100644 --- a/test/.ghci +++ /dev/null @@ -1,5 +0,0 @@ -:set -XOverloadedStrings -:set -Wall -:set -i../src -:set -isuite -:set -hide-package MonadCatchIO-mtl diff --git a/test/README b/test/README deleted file mode 100644 --- a/test/README +++ /dev/null @@ -1,1 +0,0 @@ -Various test applications and such for the Snap Framework diff --git a/test/heist-testsuite.cabal b/test/heist-testsuite.cabal deleted file mode 100644 --- a/test/heist-testsuite.cabal +++ /dev/null @@ -1,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 - diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh deleted file mode 100644 --- a/test/runTestsAndCoverage.sh +++ /dev/null @@ -1,48 +0,0 @@ -#!/bin/sh - -set -e - -SUITE=./dist/build/testsuite/testsuite - -rm -f testsuite.tix - -if [ ! -f $SUITE ]; then - cat </dev/null 2>&1 - -rm -f testsuite.tix - -cat < 3 " + mappend doctype "\n\n\n3\n\n" peopleTest :: IO () peopleTest = do @@ -56,7 +73,7 @@ H.assertEqual "people splice" expected res where expected = - "

Doe, John: 42 years old

Smith, Jane: 21 years old

" + "\n

Doe, John: 42 years old

\n\n

Smith, Jane: 21 years old

\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 - "http://www.devalot.com/ " + "http://www.devalot.com/\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\nInside h:foo End\n" + expected = "Alpha\naoeu\nBeta\nInside 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\nInside h:foo End\n" + expected = "Alpha\naoeu\nBeta\nInside 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\nInside foo Beta\naoeu End\n" + expected = "Alpha\nInside 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\nInside foo Beta\naoeu End\n" + expected = "Alpha\nInside 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 "
aeou
\n") res where + hc = HeistConfig sc "h" False + sc = mempty & scCompiledSplices .~ ("foo" ## return $ yieldPureText "aeou") + & scTemplateLocations .~ [loadTemplates "templates-ns-nested"] + + +nsBindTemplateHC :: String -> HeistConfig IO +nsBindTemplateHC dir = HeistConfig sc "h" False + where sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices & scCompiledSplices .~ nsBindTestSplices - & scTemplateLocations .~ [loadTemplates "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 " + expected = "Alpha\n\nBeta\nasdf\nGamma\n\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] diff --git a/test/suite/Heist/Interpreted/Tests.hs b/test/suite/Heist/Interpreted/Tests.hs --- a/test/suite/Heist/Interpreted/Tests.hs +++ b/test/suite/Heist/Interpreted/Tests.hs @@ -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 \n
\n/index\n
\n\n" + ,"\n\n\n
\n/index\n
\n\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 = "

This is a test.

" + +pandocDivHtmlExpected :: ByteString +pandocDivHtmlExpected = + "

This is a test.

" + -- 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' - diff --git a/test/suite/Heist/TestCommon.hs b/test/suite/Heist/TestCommon.hs --- a/test/suite/Heist/TestCommon.hs +++ b/test/suite/Heist/TestCommon.hs @@ -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 diff --git a/test/suite/Heist/Tests.hs b/test/suite/Heist/Tests.hs --- a/test/suite/Heist/Tests.hs +++ b/test/suite/Heist/Tests.hs @@ -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 \nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common" + ,"templates-bad/apply-template-not-found.tpl: apply tag cannot find template \"/page\"\nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common" + ,"templates-bad/bind-infinite-loop.tpl: template recursion exceeded max depth, you probably have infinite splice recursion!\nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common" + ,"templates-bad/bind-missing-attr.tpl: must supply \"tag\" attribute in \nCallStack (from HasCallStack):\n error, called at src/Heist/Common.hs:76:15 in main:Heist.Common" + ] +#else ["templates-bad/bind-infinite-loop.tpl: template recursion exceeded max depth, you probably have infinite splice recursion!" ,"templates-bad/apply-template-not-found.tpl: apply tag cannot find template \"/page\"" ,"templates-bad/bind-missing-attr.tpl: must supply \"tag\" attribute in " ,"templates-bad/apply-missing-attr.tpl: must supply \"template\" attribute in " ] +#endif attrSpliceTest :: IO () @@ -81,8 +91,8 @@ where expected1 = "\n\n" expected2 = "\n\n" - expected3 = " " - expected4 = " " + expected3 = "\n\n" + expected4 = "\n\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 @@ ["\n\n" ,"\n\n" ,"\n\n\n\n
nav bar
\n\n\n" - ,"
index page
\n\n\n " + ,"
index page
\n\n\n\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 = " " - iExpected = "\n" + expected = "\n" diff --git a/test/suite/Heist/Tutorial/CompiledSplices.lhs b/test/suite/Heist/Tutorial/CompiledSplices.lhs --- a/test/suite/Heist/Tutorial/CompiledSplices.lhs +++ b/test/suite/Heist/Tutorial/CompiledSplices.lhs @@ -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 diff --git a/test/suite/Heist/Tutorial/Imports.hs b/test/suite/Heist/Tutorial/Imports.hs --- a/test/suite/Heist/Tutorial/Imports.hs +++ b/test/suite/Heist/Tutorial/Imports.hs @@ -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 diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -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" diff --git a/test/templates-defer/test.tpl b/test/templates-defer/test.tpl new file mode 100644 --- /dev/null +++ b/test/templates-defer/test.tpl @@ -0,0 +1,5 @@ + + + + + diff --git a/test/templates-loaderror/_error.tpl b/test/templates-loaderror/_error.tpl new file mode 100644 --- /dev/null +++ b/test/templates-loaderror/_error.tpl @@ -0,0 +1,1 @@ + diff --git a/test/templates-loaderror/_ok.tpl b/test/templates-loaderror/_ok.tpl new file mode 100644 --- /dev/null +++ b/test/templates-loaderror/_ok.tpl @@ -0,0 +1,1 @@ + diff --git a/test/templates-loaderror/test.tpl b/test/templates-loaderror/test.tpl new file mode 100644 --- /dev/null +++ b/test/templates-loaderror/test.tpl @@ -0,0 +1,3 @@ + + + diff --git a/test/templates-ns-nested/test.tpl b/test/templates-ns-nested/test.tpl new file mode 100644 --- /dev/null +++ b/test/templates-ns-nested/test.tpl @@ -0,0 +1,1 @@ +
diff --git a/test/templates-nsbind/nsbind.tpl b/test/templates-nsbind/nsbind.tpl new file mode 100644 --- /dev/null +++ b/test/templates-nsbind/nsbind.tpl @@ -0,0 +1,7 @@ +Alpha + +Beta + +Gamma + + diff --git a/test/templates-nsbind/nsbinderror.tpl b/test/templates-nsbind/nsbinderror.tpl new file mode 100644 --- /dev/null +++ b/test/templates-nsbind/nsbinderror.tpl @@ -0,0 +1,10 @@ +Alpha + + + + + + + + + diff --git a/test/templates-nscall/_call.tpl b/test/templates-nscall/_call.tpl new file mode 100644 --- /dev/null +++ b/test/templates-nscall/_call.tpl @@ -0,0 +1,2 @@ +Called + diff --git a/test/templates-nscall/_invalid.tpl b/test/templates-nscall/_invalid.tpl new file mode 100644 --- /dev/null +++ b/test/templates-nscall/_invalid.tpl @@ -0,0 +1,1 @@ + diff --git a/test/templates-nscall/nscall.tpl b/test/templates-nscall/nscall.tpl new file mode 100644 --- /dev/null +++ b/test/templates-nscall/nscall.tpl @@ -0,0 +1,6 @@ +Top + +Inside 1 + +Inside 2 + diff --git a/test/templates/backslash.tpl b/test/templates/backslash.tpl new file mode 100644 --- /dev/null +++ b/test/templates/backslash.tpl @@ -0,0 +1,1 @@ + diff --git a/test/templates/json_array.tpl b/test/templates/json_array.tpl new file mode 100644 --- /dev/null +++ b/test/templates/json_array.tpl @@ -0,0 +1,1 @@ +, and diff --git a/test/templates/namespaces.tpl b/test/templates/namespaces.tpl new file mode 100644 --- /dev/null +++ b/test/templates/namespaces.tpl @@ -0,0 +1,5 @@ +Alpha +Inside foo +Beta +Inside h:foo +End diff --git a/test/templates/pandoc.tpl b/test/templates/pandoc.tpl new file mode 100644 --- /dev/null +++ b/test/templates/pandoc.tpl @@ -0,0 +1,1 @@ + diff --git a/test/templates/pandocdiv.tpl b/test/templates/pandocdiv.tpl new file mode 100644 --- /dev/null +++ b/test/templates/pandocdiv.tpl @@ -0,0 +1,1 @@ + diff --git a/test/templates/rss.xtpl b/test/templates/rss.xtpl new file mode 100644 --- /dev/null +++ b/test/templates/rss.xtpl @@ -0,0 +1,1 @@ +http://www.devalot.com/