diff --git a/.ghci b/.ghci
--- a/.ghci
+++ b/.ghci
@@ -1,4 +1,5 @@
:set -XOverloadedStrings
+:set -XCPP
:set -Wall
:set -isrc
:set -itest/suite
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,63 @@
+# 1.1.1.2
+
+* Support GHC 9.8
+* Fix broken test
+
+# 1.1.1.1
+
+* Support GHC 9.6
+
+# 1.1.1.0
+
+* Expose `lookupTemplate` and `splitTemplatePath`
+
+* Bump dependency bounds for 9.4
+
+# 1.1
+
+* Remove pandoc and pandocBS
+
+* Stop exporting readProcessWithExitCode'
+
+* Remove -S and --no-wrap arguments to pandoc for compatibility with both 1.x
+ and 2.x versions of the pandoc command line tool
+
+* Bump map-syntax lower bound to fix 8.4 build problem
+
+# 1.0.1.3
+
+* Add Semigroup instances to support GHC 8.4
+
+# 1.0.1.0
+
+* Change benchmark from an executable section to a benchmark section in the
+ cabal file. This eliminates the criterion dependency when doing "cabal
+ install heist".
+* Export manyWith
+
+# 1.0.0.1
+
+* Drop the dependency on `errors` packages from heist testsuite and benchmark
+* Fix nested splice namespace warning bug (issue #85)
+
+# 1.0.0.0
+
+* Switch from MonadCatchIO-transformers to monad-control for Snap 1.0
+
+# 0.14.0
+
+See http://snapframework.com/blog/2014/09/24/heist-0.14-released
+
+* Add namespace support (hcNamespace and hcErrorNotBound)
+* Add tellSpliceError for generalized error reporting
+* Restructured HeistConfig, export lenses instead of field accessors
+* Moved old HeistConfig into SpliceConfig
+* Factored SpliceAPI module out into separate map-syntax package
+
+# 0.13.0
+
+See http://snapframework.com/blog/2013/09/09/snap-0.13-released
+
+* Simpler compiled splice API
+* New splice syntax
+
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,5 +1,7 @@
# Heist
+[](https://github.com/snapframework/heist/actions)
+
Heist, part of the [Snap Framework](http://www.snapframework.com/), is a
Haskell library for xml/html templating. It uses simple XML tags to bind
values to your templates in a straightforward way. For example, if you were to
@@ -15,7 +17,7 @@
Likewise, if you need to add text to an attribute,
special-id
-
very special
+
very special
gives you
diff --git a/heist.cabal b/heist.cabal
--- a/heist.cabal
+++ b/heist.cabal
@@ -1,5 +1,6 @@
+cabal-version: 2.2
name: heist
-version: 0.13.1.2
+version: 1.1.1.2
synopsis: An Haskell template system supporting both HTML5 and XML.
description:
Heist is a powerful template system that supports both HTML5 and XML.
@@ -22,15 +23,26 @@
.
* Optional merging of multiple \ tags defined anywhere in the
document
-license: BSD3
+license: BSD-3-Clause
license-file: LICENSE
author: Doug Beardsley, Gregory Collins
maintainer: snap@snapframework.com
build-type: Simple
-cabal-version: >= 1.6
homepage: http://snapframework.com/
category: Web, Snap
+tested-with:
+ GHC == 8.8.4
+ GHC == 8.10.7
+ GHC == 9.0.2
+ GHC == 9.2.8
+ GHC == 9.4.7
+ GHC == 9.6.3
+ GHC == 9.8.1
+
+extra-doc-files:
+ CHANGELOG.md
+
extra-source-files:
.ghci,
CONTRIBUTORS,
@@ -52,10 +64,6 @@
LICENSE,
README.md,
README.SNAP.md,
- test/.ghci,
- test/heist-testsuite.cabal,
- test/README,
- test/runTestsAndCoverage.sh,
test/suite/Benchmark.hs,
test/suite/Heist/Compiled/Tests.hs,
test/suite/Heist/Interpreted/Tests.hs,
@@ -70,6 +78,7 @@
test/templates/attrs.tpl,
test/templates/attrsubtest1.tpl,
test/templates/attrsubtest2.tpl,
+ test/templates/backslash.tpl
test/templates/bar/a.tpl,
test/templates/bar/index.tpl,
test/templates/bind-apply-interaction/_outer.tpl,
@@ -89,13 +98,18 @@
test/templates/index.tpl,
test/templates/ioc.tpl,
test/templates/json.tpl,
+ test/templates/json_array.tpl
test/templates/json_object.tpl,
test/templates/json_snippet.tpl,
test/templates/markdown.tpl,
+ test/templates/namespaces.tpl
test/templates/page.tpl,
+ test/templates/pandoc.tpl
+ test/templates/pandocdiv.tpl
test/templates/people.tpl,
test/templates/post.tpl,
test/templates/readme.txt,
+ test/templates/rss.xtpl
test/templates/test.md,
test/templates/textarea_expansion.tpl,
test/templates/title_expansion.tpl,
@@ -107,18 +121,48 @@
test/templates-bad/apply-template-not-found.tpl,
test/templates-bad/bind-infinite-loop.tpl,
test/templates-bad/bind-missing-attr.tpl,
+ test/templates-defer/test.tpl,
+ test/templates-loaderror/_error.tpl,
+ test/templates-loaderror/_ok.tpl,
+ test/templates-loaderror/test.tpl,
+ test/templates-nsbind/nsbind.tpl,
+ test/templates-nsbind/nsbinderror.tpl,
+ test/templates-ns-nested/test.tpl,
+ test/templates-nscall/_call.tpl,
+ test/templates-nscall/_invalid.tpl,
+ test/templates-nscall/nscall.tpl,
TODO
+common universal
+ default-language: Haskell2010
+ default-extensions:
+ DeriveDataTypeable
+ FlexibleInstances
+ GeneralizedNewtypeDeriving
+ MultiParamTypeClasses
+ OverloadedStrings
+ PackageImports
+ ScopedTypeVariables
+ TypeSynonymInstances
+
+ build-depends:
+ , base >= 4.5 && < 5
+
+ if !impl(ghc >= 8.0)
+ build-depends:
+ semigroups >= 0.16 && < 0.19,
+
Library
+ import: universal
hs-source-dirs: src
exposed-modules:
Heist,
Heist.Compiled,
Heist.Compiled.LowLevel,
+ Heist.Internal.Types,
Heist.Interpreted,
- Heist.SpliceAPI,
Heist.Splices,
Heist.Splices.Apply,
Heist.Splices.Bind,
@@ -134,52 +178,40 @@
Data.HeterogeneousEnvironment,
Heist.Common,
Heist.Compiled.Internal,
- Heist.Interpreted.Internal,
- Heist.Types
+ Heist.Internal.Types.HeistState,
+ Heist.Interpreted.Internal
build-depends:
- MonadCatchIO-transformers >= 0.2.1 && < 0.4,
- aeson >= 0.6 && < 0.8,
- attoparsec >= 0.10 && < 0.13,
- base >= 4 && < 5,
- blaze-builder >= 0.2 && < 0.4,
- blaze-html >= 0.4 && < 0.8,
- bytestring >= 0.9 && < 0.11,
- containers >= 0.2 && < 0.6,
- directory >= 1.1 && < 1.3,
+ aeson >= 0.6 && < 2.3,
+ attoparsec >= 0.10 && < 0.15,
+ blaze-builder >= 0.2 && < 0.5,
+ blaze-html >= 0.4 && < 0.10,
+ bytestring >= 0.9 && < 0.13,
+ containers >= 0.2 && < 1.0,
+ directory >= 1.1 && < 1.4,
directory-tree >= 0.10 && < 0.13,
- dlist >= 0.5 && < 0.8,
- errors >= 1.4 && < 1.5,
- filepath >= 1.3 && < 1.4,
- hashable >= 1.1 && < 1.3,
- mtl >= 2.0 && < 2.2,
- process >= 1.1 && < 1.3,
- random >= 1.0.1.0 && < 1.1,
- text >= 0.10 && < 1.2,
- time >= 1.1 && < 1.5,
- transformers >= 0.3 && < 0.4,
+ dlist >= 0.5 && < 1.1,
+ filepath >= 1.3 && < 1.5,
+ hashable >= 1.1 && < 1.5,
+ lifted-base >= 0.2 && < 0.3,
+ map-syntax >= 0.3 && < 0.4,
+ monad-control >= 0.3 && < 1.1,
+ mtl >= 2.0 && < 2.4,
+ process >= 1.1 && < 1.7,
+ random >= 1.0.1.0 && < 1.3,
+ text >= 0.10 && < 2.2,
+ time >= 1.1 && < 1.13,
+ transformers >= 0.3 && < 0.7,
+ transformers-base >= 0.4 && < 0.5,
unordered-containers >= 0.1.4 && < 0.3,
- vector >= 0.9 && < 0.11,
- xmlhtml >= 0.2.3 && < 0.3
-
- if impl(ghc >= 6.12.0)
- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
- -fno-warn-unused-do-bind
- else
- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+ vector >= 0.9 && < 0.14,
+ xmlhtml >= 0.2.3.5 && < 0.4,
+ indexed-traversable >= 0.1.1 && < 0.2
- ghc-prof-options: -prof -auto-all
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
- Extensions:
- GeneralizedNewtypeDeriving,
- PackageImports,
- ScopedTypeVariables,
- DeriveDataTypeable,
- FlexibleInstances,
- MultiParamTypeClasses,
+ default-extensions:
UndecidableInstances,
- OverloadedStrings,
- TypeSynonymInstances,
NoMonomorphismRestriction
@@ -187,3 +219,99 @@
type: git
location: https://github.com/snapframework/heist.git
+Test-suite testsuite
+ import: universal
+ hs-source-dirs: src test/suite
+ type: exitcode-stdio-1.0
+ main-is: TestSuite.hs
+
+ build-depends:
+ HUnit >= 1.2 && < 2,
+ QuickCheck >= 2 && < 2.15,
+ lens >= 4.3 && < 5.3,
+ test-framework >= 0.4 && < 0.9,
+ test-framework-hunit >= 0.2.7 && < 0.4,
+ test-framework-quickcheck2 >= 0.2.12.1 && < 0.4,
+ aeson,
+ attoparsec,
+ bifunctors >= 5.3 && < 5.7,
+ blaze-builder,
+ blaze-html,
+ bytestring,
+ containers,
+ directory,
+ directory-tree,
+ dlist,
+ filepath,
+ hashable,
+ lifted-base,
+ map-syntax,
+ monad-control,
+ mtl,
+ process,
+ random,
+ text,
+ time,
+ transformers,
+ transformers-base,
+ unordered-containers,
+ vector,
+ xmlhtml,
+ indexed-traversable
+
+ if impl(ghc >= 7.8) && impl(ghc < 7.10)
+ build-depends: transformers-compat >= 0.3 && < 0.7
+
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded
+
+Benchmark benchmark
+ import: universal
+ hs-source-dirs: src test/suite
+ type: exitcode-stdio-1.0
+ main-is: Benchmark.hs
+
+ build-depends:
+ HUnit,
+ criterion >= 1.0,
+ criterion-measurement >= 0.1,
+ test-framework,
+ test-framework-hunit,
+
+ -- Copied from regular dependencies:
+
+ aeson,
+ attoparsec,
+ blaze-builder,
+ blaze-html,
+ bytestring,
+ containers,
+ directory,
+ directory-tree,
+ dlist,
+ filepath,
+ hashable,
+ lifted-base,
+ map-syntax,
+ monad-control,
+ mtl,
+ process,
+ random,
+ statistics >= 0.11,
+ text,
+ time,
+ transformers,
+ transformers-base,
+ unordered-containers,
+ vector,
+ xmlhtml,
+ indexed-traversable
+
+ if impl(ghc >= 7.8) && impl(ghc < 7.10)
+ build-depends: transformers-compat
+
+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded
+ -fno-warn-unused-do-bind -rtsopts
+
+ default-extensions:
+ UndecidableInstances,
+ NoMonomorphismRestriction
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 #-}
@@ -24,9 +25,11 @@
, initHeistWithCacheTag
, defaultInterpretedSplices
, defaultLoadTimeSplices
+ , emptyHeistConfig
-- * Core Heist data types
- , HeistConfig(..)
+ , SpliceConfig
+ , HeistConfig
, TemplateRepo
, TemplateLocation
, Template
@@ -37,12 +40,33 @@
, RuntimeSplice
, Chunk
, HeistState
+ , SpliceError(..)
+ , CompileException(..)
+ , HeistT
+
+ -- * Lenses (can be used with lens or lens-family)
+ , scInterpretedSplices
+ , scLoadTimeSplices
+ , scCompiledSplices
+ , scAttributeSplices
+ , scTemplateLocations
+ , scCompiledTemplateFilter
+ , hcSpliceConfig
+ , hcNamespace
+ , hcErrorNotBound
+ , hcInterpretedSplices
+ , hcLoadTimeSplices
+ , hcCompiledSplices
+ , hcAttributeSplices
+ , hcTemplateLocations
+ , hcCompiledTemplateFilter
+
+ -- * HeistT functions
, templateNames
, compiledTemplateNames
, hasTemplate
, spliceNames
, compiledSpliceNames
- , HeistT
, evalHeistT
, getParamNode
, getContext
@@ -56,76 +80,45 @@
, localHS
, getDoc
, getXMLDoc
+ , tellSpliceError
+ , spliceErrorText
, orError
+ , Splices
- -- * Splice API
- , module Heist.SpliceAPI
+ -- * TPath functions
+ , lookupTemplate
+ , splitTemplatePath
) where
-import Control.Error
-import Control.Exception (SomeException)
-import Control.Monad.CatchIO
+
+------------------------------------------------------------------------------
+import Control.Exception.Lifted
import Control.Monad.State
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as B
-import qualified Data.Foldable as F
-import qualified Data.HeterogeneousEnvironment as HE
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as Map
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString as B
+import Data.Either
+import qualified Data.Foldable as F
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as Map
+import qualified Data.HeterogeneousEnvironment as HE
+import Data.Map.Syntax
+#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
+#endif
+import Data.Text (Text)
+import qualified Data.Text as T
import System.Directory.Tree
-import qualified Text.XmlHtml as X
-
+import qualified Text.XmlHtml as X
+------------------------------------------------------------------------------
import Heist.Common
-import qualified Heist.Compiled.Internal as C
-import qualified Heist.Interpreted.Internal as I
-import Heist.SpliceAPI
+import qualified Heist.Compiled.Internal as C
+import qualified Heist.Interpreted.Internal as I
import Heist.Splices
-import Heist.Types
-
-
-type TemplateRepo = HashMap TPath DocumentFile
-
-
+import Heist.Internal.Types
------------------------------------------------------------------------------
--- | An IO action for getting a template repo from this location. By not just
--- using a directory path here, we support templates loaded from a database,
--- retrieved from the network, or anything else you can think of.
-type TemplateLocation = EitherT [String] IO TemplateRepo
-data HeistConfig m = HeistConfig
- { hcInterpretedSplices :: Splices (I.Splice m)
- -- ^ Interpreted splices are the splices that Heist has always had. They
- -- return a list of nodes and are processed at runtime.
- , hcLoadTimeSplices :: Splices (I.Splice IO)
- -- ^ Load time splices are like interpreted splices because they return a
- -- list of nodes. But they are like compiled splices because they are
- -- processed once at load time. All of Heist's built-in splices should be
- -- used as load time splices.
- , hcCompiledSplices :: Splices (C.Splice m)
- -- ^ Compiled splices return a DList of Chunks and are processed at load
- -- time to generate a runtime monad action that will be used to render the
- -- template.
- , hcAttributeSplices :: Splices (AttrSplice m)
- -- ^ Attribute splices are bound to attribute names and return a list of
- -- attributes.
- , hcTemplateLocations :: [TemplateLocation]
- -- ^ A list of all the locations that Heist should get its templates
- -- from.
- }
-
-
-instance Monoid (HeistConfig m) where
- mempty = HeistConfig (put mempty) (put mempty) (put mempty) (put mempty) mempty
- mappend (HeistConfig a b c d e) (HeistConfig a' b' c' d' e') =
- HeistConfig (unionWithS const a a')
- (unionWithS const b b')
- (unionWithS const c c')
- (unionWithS const d d')
- (e `mappend` e')
-
-
------------------------------------------------------------------------------
-- | The built-in set of splices that you should use in compiled splice mode.
-- This list includes everything from 'defaultInterpretedSplices' plus a
@@ -133,18 +126,20 @@
-- old content tag, which has now been moved to two separate tags called
-- apply-content and bind-content.
defaultLoadTimeSplices :: MonadIO m => Splices (I.Splice m)
-defaultLoadTimeSplices =
+defaultLoadTimeSplices = do
-- To be removed in later versions
- insertS "content" deprecatedContentCheck defaultInterpretedSplices
-
+ defaultInterpretedSplices
+ "content" #! deprecatedContentCheck
+
------------------------------------------------------------------------------
-- | The built-in set of static splices. All the splices that used to be
-- enabled by default are included here. To get the normal Heist behavior you
--- should include these in the hcLoadTimeSplices list in your HeistConfig. If
--- you are using interpreted splice mode, then you might also want to bind the
--- 'deprecatedContentCheck' splice to the content tag as a load time splice.
+-- should include these in the scLoadTimeSplices list in your SpliceConfig.
+-- If you are using interpreted splice mode, then you might also want to bind
+-- the 'deprecatedContentCheck' splice to the content tag as a load time
+-- splice.
defaultInterpretedSplices :: MonadIO m => Splices (I.Splice m)
defaultInterpretedSplices = do
applyTag ## applyImpl
@@ -154,12 +149,19 @@
+------------------------------------------------------------------------------
+-- | An empty HeistConfig that uses the \"h\" namespace with error checking
+-- turned on.
+emptyHeistConfig :: HeistConfig m
+emptyHeistConfig = HeistConfig mempty "h" True
+
+
allErrors :: [Either String (TPath, v)]
- -> EitherT [String] IO (HashMap TPath v)
+ -> Either [String] (HashMap TPath v)
allErrors tlist =
case errs of
- [] -> right $ Map.fromList $ rights tlist
- _ -> left errs
+ [] -> Right $ Map.fromList $ rights tlist
+ _ -> Left errs
where
errs = lefts tlist
@@ -168,18 +170,22 @@
-- | Loads templates from disk. This function returns just a template map so
-- you can load multiple directories and combine the maps before initializing
-- your HeistState.
-loadTemplates :: FilePath -> EitherT [String] IO TemplateRepo
+loadTemplates :: FilePath -> IO (Either [String] TemplateRepo)
loadTemplates dir = do
- d <- lift $ readDirectoryWith (loadTemplate dir) dir
- allErrors $ F.fold (free d)
+ d <- readDirectoryWith (loadTemplate dir) dir
+#if MIN_VERSION_directory_tree(0,11,0)
+ return $ allErrors $ F.fold (dirTree d)
+#else
+ return $ allErrors $ F.fold (free d)
+#endif
------------------------------------------------------------------------------
-- | Reloads all the templates an an existing TemplateRepo.
-reloadTemplates :: TemplateRepo -> EitherT [String] IO TemplateRepo
+reloadTemplates :: TemplateRepo -> IO (Either [String] TemplateRepo)
reloadTemplates repo = do
- tlist <- lift $ mapM loadOrKeep $ Map.toList repo
- allErrors tlist
+ tlist <- mapM loadOrKeep $ Map.toList repo
+ return $ allErrors tlist
where
loadOrKeep (p,df) =
case dfFile df of
@@ -210,7 +216,7 @@
-- | Creates an empty HeistState.
emptyHS :: HE.KeyGen -> HeistState m
emptyHS kg = HeistState Map.empty Map.empty Map.empty Map.empty Map.empty
- True [] 0 [] Nothing kg False Html
+ True [] [] 0 [] Nothing kg False Html "" [] False 0
------------------------------------------------------------------------------
@@ -232,27 +238,49 @@
-- function.
initHeist :: Monad n
=> HeistConfig n
- -> EitherT [String] IO (HeistState n)
+ -> IO (Either [String] (HeistState n))
initHeist hc = do
- keyGen <- lift HE.newKeyGen
- repos <- sequence $ hcTemplateLocations hc
- initHeist' keyGen hc (Map.unions repos)
+ keyGen <- HE.newKeyGen
+ repos <- sequence $ _scTemplateLocations $ _hcSpliceConfig hc
+ case sequence repos of
+ Left es -> return $ Left es
+ Right rs -> initHeist' keyGen hc (Map.unions rs)
+------------------------------------------------------------------------------
+mkSplicePrefix :: Text -> Text
+mkSplicePrefix ns
+ | T.null ns = ""
+ | otherwise = ns `mappend` ":"
+
+
+------------------------------------------------------------------------------
initHeist' :: Monad n
=> HE.KeyGen
-> HeistConfig n
-> TemplateRepo
- -> EitherT [String] IO (HeistState n)
-initHeist' keyGen (HeistConfig i lt c a _) repo = do
+ -> IO (Either [String] (HeistState n))
+initHeist' keyGen (HeistConfig sc ns enn) repo = do
let empty = emptyHS keyGen
- tmap <- preproc keyGen lt repo
- let hs1 = empty { _spliceMap = Map.fromList $ splicesToList i
- , _templateMap = tmap
- , _compiledSpliceMap = Map.fromList $ splicesToList c
- , _attrSpliceMap = Map.fromList $ splicesToList a
- }
- lift $ C.compileTemplates hs1
+ let (SpliceConfig i lt c a _ f) = sc
+ etmap <- preproc keyGen lt repo ns
+ let prefix = mkSplicePrefix ns
+ let eis = runHashMap $ mapK (prefix<>) i
+ ecs = runHashMap $ mapK (prefix<>) c
+ eas = runHashMap $ mapK (prefix<>) a
+ let hs1 = do
+ tmap <- etmap
+ is <- eis
+ cs <- ecs
+ as <- eas
+ return $ empty { _spliceMap = is
+ , _templateMap = tmap
+ , _compiledSpliceMap = cs
+ , _attrSpliceMap = as
+ , _splicePrefix = prefix
+ , _errorNotBound = enn
+ }
+ either (return . Left) (C.compileTemplates f) hs1
------------------------------------------------------------------------------
@@ -260,17 +288,23 @@
preproc :: HE.KeyGen
-> Splices (I.Splice IO)
-> TemplateRepo
- -> EitherT [String] IO TemplateRepo
-preproc keyGen splices templates = do
- let hs = (emptyHS keyGen) { _spliceMap = Map.fromList $ splicesToList splices
- , _templateMap = templates
- , _preprocessingMode = True }
- let eval a = evalHeistT a (X.TextNode "") hs
- tPairs <- lift $ mapM (eval . preprocess) $ Map.toList templates
- let bad = lefts tPairs
- if not (null bad)
- then left bad
- else right $ Map.fromList $ rights tPairs
+ -> Text
+ -> IO (Either [String] TemplateRepo)
+preproc keyGen splices templates ns = do
+ let esm = runHashMap splices
+ case esm of
+ Left errs -> return $ Left errs
+ Right sm -> do
+ let hs = (emptyHS keyGen) { _spliceMap = sm
+ , _templateMap = templates
+ , _preprocessingMode = True
+ , _splicePrefix = mkSplicePrefix ns }
+ let eval a = evalHeistT a (X.TextNode "") hs
+ tPairs <- mapM (eval . preprocess) $ Map.toList templates
+ let bad = lefts tPairs
+ return $ if not (null bad)
+ then Left bad
+ else Right $ Map.fromList $ rights tPairs
------------------------------------------------------------------------------
@@ -279,12 +313,13 @@
-> HeistT IO IO (Either String (TPath, DocumentFile))
preprocess (tpath, docFile) = do
let tname = tpathName tpath
+ die = error $ "Preprocess failed because the template `"
+ ++ BC.unpack tname
+ ++ "` was not found in the template repository."
!emdoc <- try $ I.evalWithDoctypes tname
:: HeistT IO IO (Either SomeException (Maybe X.Document))
let f !doc = (tpath, docFile { dfDoc = doc })
return $! either (Left . show) (Right . maybe die f) emdoc
- where
- die = error "Preprocess didn't succeed! This should never happen."
------------------------------------------------------------------------------
@@ -295,22 +330,27 @@
-- implementation.
initHeistWithCacheTag :: MonadIO n
=> HeistConfig n
- -> EitherT [String] IO (HeistState n, CacheTagState)
-initHeistWithCacheTag (HeistConfig i lt c a locations) = do
+ -> IO (Either [String] (HeistState n, CacheTagState))
+initHeistWithCacheTag (HeistConfig sc ns enn) = do
(ss, cts) <- liftIO mkCacheTag
let tag = "cache"
- keyGen <- lift HE.newKeyGen
-
- repos <- sequence locations
- -- We have to do one preprocessing pass with the cache setup splice. This
- -- has to happen for both interpreted and compiled templates, so we do it
- -- here by itself because interpreted templates don't get the same load
- -- time splices as compiled templates.
- rawWithCache <- preproc keyGen (tag ## ss) $ Map.unions repos
-
- let hc' = HeistConfig (insertS tag (cacheImpl cts) i) lt
- (insertS tag (cacheImplCompiled cts) c)
- a locations
- hs <- initHeist' keyGen hc' rawWithCache
- return (hs, cts)
+ keyGen <- HE.newKeyGen
+ erepos <- sequence $ _scTemplateLocations sc
+ case sequence erepos of
+ Left es -> return $ Left es
+ Right repos -> do
+ -- We have to do one preprocessing pass with the cache setup splice. This
+ -- has to happen for both interpreted and compiled templates, so we do it
+ -- here by itself because interpreted templates don't get the same load
+ -- time splices as compiled templates.
+ eRawWithCache <- preproc keyGen (tag ## ss) (Map.unions repos) ns
+ case eRawWithCache of
+ Left es -> return $ Left es
+ Right rawWithCache -> do
+ let sc' = SpliceConfig (tag #! cacheImpl cts) mempty
+ (tag #! cacheImplCompiled cts)
+ mempty mempty (const True)
+ let hc = HeistConfig (mappend sc sc') ns enn
+ hs <- initHeist' keyGen hc rawWithCache
+ return $ fmap (,cts) hs
diff --git a/src/Heist/Common.hs b/src/Heist/Common.hs
--- a/src/Heist/Common.hs
+++ b/src/Heist/Common.hs
@@ -1,31 +1,66 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Heist.Common where
-import Control.Applicative
-import Control.Exception (SomeException)
-import Control.Monad
-import qualified Control.Monad.CatchIO as C
-import qualified Data.Attoparsec.Text as AP
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as BC
-import Data.Hashable
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as Map
-import Data.List
-import Data.Maybe
-import Data.Monoid
-import qualified Data.Text as T
-import System.FilePath
-import Heist.SpliceAPI
-import Heist.Types
-import qualified Text.XmlHtml as X
+------------------------------------------------------------------------------
+import Control.Applicative (Alternative (..))
+import Control.Exception (SomeException)
+import qualified Control.Exception.Lifted as C
+import Control.Monad (liftM, mplus)
+import qualified Data.Attoparsec.Text as AP
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import Data.Hashable (Hashable)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as Map
+import Data.List (isSuffixOf, sort)
+import Data.Map.Syntax
+import Data.Maybe (isJust)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Heist.Internal.Types.HeistState
+import System.FilePath (pathSeparator)
+import qualified Text.XmlHtml as X
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative (Applicative (..), (<$>))
+import Data.Monoid (Monoid (..))
+#endif
+------------------------------------------------------------------------------
------------------------------------------------------------------------------
+runHashMap
+ :: Splices s
+ -> Either [String] (HashMap T.Text s)
+runHashMap ms =
+ case runMapSyntax Map.lookup Map.insert ms of
+ Left keys -> Left $ map (T.unpack . mkMsg) keys
+ Right hm -> Right hm
+ where
+ mkMsg k = "You tried to bind "<>k<>" more than once!"
+
+
+------------------------------------------------------------------------------
+runMapNoErrors :: (Eq k, Hashable k) => MapSyntaxM k v a -> HashMap k v
+runMapNoErrors = either (const mempty) id .
+ runMapSyntax' (\_ new _ -> Just new) Map.lookup Map.insert
+
+applySpliceMap :: HeistState n
+ -> (HeistState n -> HashMap Text v)
+ -> MapSyntaxM Text v a
+ -> HashMap Text v
+applySpliceMap hs f = (flip Map.union (f hs)) .
+ runMapNoErrors .
+ mapK (mappend pre)
+ where
+ pre = _splicePrefix hs
+
+------------------------------------------------------------------------------
-- | If Heist is running in fail fast mode, then this function will throw an
-- exception with the second argument as the error message. Otherwise, the
-- first argument will be executed to represent silent failure.
@@ -37,15 +72,44 @@
orError silent msg = do
hs <- getHS
if _preprocessingMode hs
- then error $ (maybe "" (++": ") $ _curTemplateFile hs) ++ msg
+ then do fullMsg <- heistErrMsg (T.pack msg)
+ error $ T.unpack fullMsg
else silent
------------------------------------------------------------------------------
+-- | Prepends the location of the template currently being processed to an
+-- error message.
+heistErrMsg :: Monad m => Text -> HeistT n m Text
+heistErrMsg msg = do
+ tf <- getsHS _curTemplateFile
+ return $ (maybe "" ((`mappend` ": ") . T.pack) tf) `mappend` msg
+
+
+------------------------------------------------------------------------------
+-- | Adds an error message to the list of splice processing errors.
+tellSpliceError :: Monad m => Text -> HeistT n m ()
+tellSpliceError msg = do
+ hs <- getHS
+ node <- getParamNode
+ let spliceError = SpliceError
+ { spliceHistory = _splicePath hs
+ , spliceTemplateFile = _curTemplateFile hs
+ , visibleSplices = sort $ Map.keys $ _compiledSpliceMap hs
+ , contextNode = node
+ , spliceMsg = msg
+ }
+ modifyHS (\hs' -> hs { _spliceErrors = spliceError : _spliceErrors hs' })
+
+
+------------------------------------------------------------------------------
-- | Function for showing a TPath.
showTPath :: TPath -> String
showTPath = BC.unpack . (`BC.append` ".tpl") . tpathName
+
+------------------------------------------------------------------------------
+-- | Convert a TPath into a ByteString path.
tpathName :: TPath -> ByteString
tpathName = BC.intercalate "/" . reverse
@@ -126,9 +190,9 @@
-> Maybe (t, TPath)
lookupTemplate nameStr ts tm = f (tm ts) path name
where
- (name:p) = case splitTemplatePath nameStr of
- [] -> [""]
- ps -> ps
+ (name, p) = case splitTemplatePath nameStr of
+ [] -> ("", [])
+ x:xs -> (x, xs)
ctx = if B.isPrefixOf "/" nameStr then [] else _curContext ts
path = p ++ ctx
f = if '/' `BC.elem` nameStr
@@ -286,6 +350,7 @@
-- rendering will include a byte order mark. (RFC 2781, Sec. 3.3)
enc X.UTF16BE = "utf-16"
enc X.UTF16LE = "utf-16"
+ enc X.ISO_8859_1 = "iso-8859-1"
------------------------------------------------------------------------------
@@ -294,9 +359,7 @@
-> HeistState n -- ^ start state
-> HeistState n
bindAttributeSplices ss hs =
- hs { _attrSpliceMap = Map.union (Map.fromList $ splicesToList ss)
- (_attrSpliceMap hs) }
-
+ hs { _attrSpliceMap = applySpliceMap hs _attrSpliceMap ss }
------------------------------------------------------------------------------
-- | Mappends a doctype to the state.
diff --git a/src/Heist/Compiled.hs b/src/Heist/Compiled.hs
--- a/src/Heist/Compiled.hs
+++ b/src/Heist/Compiled.hs
@@ -23,14 +23,18 @@
-- * Functions for manipulating lists of compiled splices
, textSplice
, nodeSplice
+ , xmlNodeSplice
+ , htmlNodeSplice
, pureSplice
, deferMany
+ , defer
, deferMap
, mayDeferMap
, bindLater
, withSplices
, manyWithSplices
+ , manyWith
, withLocalSplices
-- * Constructing Chunks
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,27 +14,34 @@
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char.Utf8
import Control.Arrow
+import Control.Exception
import Control.Monad
import Control.Monad.RWS.Strict
import Control.Monad.State.Strict
-import qualified Data.Attoparsec.Text as AP
-import Data.ByteString (ByteString)
-import Data.DList (DList)
-import qualified Data.DList as DL
-import qualified Data.HashMap.Strict as H
-import qualified Data.HashSet as S
-import qualified Data.HeterogeneousEnvironment as HE
+import qualified Data.Attoparsec.Text as AP
+import Data.ByteString (ByteString)
+import Data.DList (DList)
+import qualified Data.DList as DL
+import qualified Data.HashMap.Strict as H
+import qualified Data.HashSet as S
+import qualified Data.HeterogeneousEnvironment as HE
+import Data.Map.Syntax
import Data.Maybe
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import qualified Data.Vector as V
-import qualified Text.XmlHtml as X
-import qualified Text.XmlHtml.HTML.Meta as X
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Vector as V
+import Text.Printf
+import qualified Text.XmlHtml as X
+import qualified Text.XmlHtml.HTML.Meta as X
------------------------------------------------------------------------------
+#if !MIN_VERSION_base(4,8,0)
+import Data.Foldable (Foldable)
+#endif
+import qualified Data.Foldable as Foldable
+------------------------------------------------------------------------------
import Heist.Common
-import Heist.SpliceAPI
-import Heist.Types
+import Heist.Internal.Types.HeistState
------------------------------------------------------------------------------
@@ -44,7 +52,7 @@
-- The more interesting part of the type signature is what comes before the
-- return value. The first type parameter in @'HeistT' n IO@ is the runtime
-- monad. This reveals that the Chunks know about the runtime monad. The
--- second type parameter in @HeistT n IO@ is @IO@. This tells is that the
+-- second type parameter in @HeistT n IO@ is @IO@. This tells us that the
-- compiled splices themselves are run in the IO monad, which will usually
-- mean at load time. Compiled splices run at load time, and they return
-- computations that run at runtime.
@@ -122,25 +130,18 @@
------------------------------------------------------------------------------
--- | Runs a single splice and returns the builder computation.
-runSplice :: (Monad n)
- => X.Node
- -> HeistState n
- -> Splice n
- -> IO [Chunk n]
-runSplice node hs splice = do
- !a <- evalHeistT splice node hs
- return $! consolidate a
-
-
-------------------------------------------------------------------------------
-- | Runs a DocumentFile with the appropriate template context set.
runDocumentFile :: Monad n
=> TPath
-> DocumentFile
-> Splice n
runDocumentFile tpath df = do
- addDoctype $ maybeToList $ X.docType $ dfDoc df
+ let markup = case dfDoc df of
+ X.XmlDocument _ _ _ -> Xml
+ X.HtmlDocument _ _ _ -> Html
+ modifyHS (\hs -> hs { _curMarkup = markup })
+ let inDoctype = X.docType $ dfDoc df
+ addDoctype $ maybeToList inDoctype
modifyHS (setCurTemplateFile curPath . setCurContext tpath)
res <- runNodeList nodes
dt <- getsHS (listToMaybe . _doctypes)
@@ -152,46 +153,68 @@
------------------------------------------------------------------------------
-compileTemplate :: Monad n
- => HeistState n
- -> TPath
- -> DocumentFile
- -> IO [Chunk n]
-compileTemplate hs tpath df = do
- let markup = case dfDoc df of
- X.XmlDocument _ _ _ -> Xml
- X.HtmlDocument _ _ _ -> Html
- hs' = hs { _curMarkup = markup }
- !chunks <- runSplice nullNode hs' $! runDocumentFile tpath df
- return chunks
- where
- -- This gets overwritten in runDocumentFile
- nullNode = X.TextNode ""
+compileTemplate
+ :: Monad n
+ => TPath
+ -> DocumentFile
+ -> HeistT n IO [Chunk n]
+compileTemplate tpath df = do
+ !chunks <- runDocumentFile tpath df
+ return $! consolidate chunks
------------------------------------------------------------------------------
-compileTemplates :: Monad n => HeistState n -> IO (HeistState n)
-compileTemplates hs = do
- ctm <- compileTemplates' hs
- return $! hs { _compiledTemplateMap = ctm }
--- let f = flip evalStateT HE.empty . unRT . codeGen
--- return $! hs { _compiledTemplateMap = H.map (first f) ctm }
+compileTemplates
+ :: Monad n
+ => (TPath -> Bool)
+ -> HeistState n
+ -> IO (Either [String] (HeistState n))
+compileTemplates f hs = do
+ (tmap, hs') <- runHeistT (compileTemplates' f) (X.TextNode "") hs
+ let pre = _splicePrefix hs'
+ let canError = _errorNotBound hs'
+ let errs = _spliceErrors hs'
+ let nsErr = if not (T.null pre) && (_numNamespacedTags hs' == 0)
+ then Left [noNamespaceSplicesMsg $ T.unpack pre]
+ else Right ()
+ return $ if canError
+ then case errs of
+ [] -> nsErr >>
+ (Right $! hs { _compiledTemplateMap = tmap })
+ es -> Left $ either (++) (const id) nsErr $
+ map (T.unpack . spliceErrorText) es
+ else nsErr >> (Right $! hs { _compiledTemplateMap = tmap
+ , _spliceErrors = errs
+ })
------------------------------------------------------------------------------
-compileTemplates' :: Monad n
- => HeistState n
- -> IO (H.HashMap TPath ([Chunk n], MIMEType))
-compileTemplates' hs = do
- ctm <- foldM runOne H.empty tpathDocfiles
- return $! ctm
+noNamespaceSplicesMsg :: String -> String
+noNamespaceSplicesMsg pre = unwords
+ [ printf "You are using a namespace of '%s', but you don't have any" ns
+ , printf "tags starting with '%s'. If you have not defined any" pre
+ , "splices, then change your namespace to the empty string to get rid"
+ , "of this message."
+ ]
where
- tpathDocfiles :: [(TPath, DocumentFile)]
- tpathDocfiles = map (\(a,b) -> (a, b))
- (H.toList $ _templateMap hs)
+ ns = reverse $ drop 1 $ reverse pre
+
+------------------------------------------------------------------------------
+compileTemplates'
+ :: Monad n
+ => (TPath -> Bool)
+ -> HeistT n IO (H.HashMap TPath ([Chunk n], MIMEType))
+compileTemplates' f = do
+ hs <- getHS
+ let tpathDocfiles :: [(TPath, DocumentFile)]
+ tpathDocfiles = filter (f . fst)
+ (H.toList $ _templateMap hs)
+ foldM runOne H.empty tpathDocfiles
+ where
runOne tmap (tpath, df) = do
- !mHtml <- compileTemplate hs tpath df
+ modifyHS (\hs -> hs { _doctypes = []})
+ !mHtml <- compileTemplate tpath df
return $! H.insert tpath (mHtml, mimeType $! dfDoc df) tmap
@@ -205,34 +228,34 @@
where
----------------------------------------------------------------------
go soFar x [] = x : soFar
-
+
go soFar (Pure a) ((Pure b) : xs) =
go soFar (Pure $! a `mappend` b) xs
-
+
go soFar (RuntimeHtml a) ((RuntimeHtml b) : xs) =
go soFar (RuntimeHtml $! a `mappend` b) xs
-
+
go soFar (RuntimeHtml a) ((RuntimeAction b) : xs) =
go soFar (RuntimeHtml $! a >>= \x -> b >> return x) xs
-
+
go soFar (RuntimeAction a) ((RuntimeHtml b) : xs) =
go soFar (RuntimeHtml $! a >> b) xs
-
+
go soFar (RuntimeAction a) ((RuntimeAction b) : xs) =
go soFar (RuntimeAction $! a >> b) xs
-
+
go soFar a (b : xs) = go (a : soFar) b xs
-
+
----------------------------------------------------------------------
boilDown soFar [] = soFar
-
+
boilDown soFar ((Pure h) : xs) = boilDown ((Pure $! h) : soFar) xs
-
+
boilDown soFar (x : xs) = boilDown (x : soFar) xs
------------------------------------------------------------------------------
--- | Given a list of output chunks, consolidate turns consecutive runs of
+-- | Given a list of output chunks, codeGen turns consecutive runs of
-- @Pure Html@ values into maximally-efficient pre-rendered strict
-- 'ByteString' chunks.
codeGen :: Monad n => DList (Chunk n) -> RuntimeSplice n Builder
@@ -248,7 +271,14 @@
------------------------------------------------------------------------------
-- | Looks up a splice in the compiled splice map.
lookupSplice :: Text -> HeistT n IO (Maybe (Splice n))
-lookupSplice nm = getsHS (H.lookup nm . _compiledSpliceMap)
+lookupSplice nm = do
+ pre <- getsHS _splicePrefix
+ res <- getsHS (H.lookup nm . _compiledSpliceMap)
+ if isNothing res && T.isPrefixOf pre nm && not (T.null pre)
+ then do
+ tellSpliceError $ "No splice bound for " `mappend` nm
+ return Nothing
+ else return res
------------------------------------------------------------------------------
@@ -257,11 +287,37 @@
-- compileNode to generate the appropriate runtime computation.
runNode :: Monad n => X.Node -> Splice n
runNode node = localParamNode (const node) $ do
- isStatic <- subtreeIsStatic node
- markup <- getsHS _curMarkup
- if isStatic
- then return $! yieldPure $! renderFragment markup [parseAttrs node]
- else compileNode node
+ hs <- getHS
+ let pre = _splicePrefix hs
+ let hasPrefix = (T.isPrefixOf pre `fmap` X.tagName node) == Just True
+ when (not (T.null pre) && hasPrefix) incNamespacedTags
+ hs' <- getHS
+ -- Plain rethrows for CompileException to avoid multiple annotations.
+ (res, hs'') <- liftIO $ catches (compileIO hs')
+ [ Handler (\(ex :: CompileException) -> throwIO ex)
+ , Handler (\(ex :: SomeException) -> handleError ex hs')]
+ putHS hs''
+ return res
+ where
+ localSplicePath =
+ localHS (\hs -> hs {_splicePath = (_curContext hs,
+ _curTemplateFile hs,
+ X.elementTag node):
+ (_splicePath hs)})
+ compileIO hs = runHeistT compile node hs
+ compile = do
+ isStatic <- subtreeIsStatic node
+ dl <- compile' isStatic
+ liftIO $ evaluate $ DL.fromList $! consolidate dl
+ compile' True = do
+ markup <- getsHS _curMarkup
+ return $! yieldPure $! renderFragment markup [parseAttrs node]
+ compile' False = localSplicePath $ compileNode node
+ handleError ex hs = do
+ errs <- evalHeistT (do localSplicePath $ tellSpliceError $ T.pack $
+ "Exception in splice compile: " ++ show ex
+ getsHS _spliceErrors) node hs
+ throwIO $ CompileException ex errs
parseAttrs :: X.Node -> X.Node
@@ -317,9 +373,9 @@
-- | Given a 'X.Node' in the DOM tree, produces a \"runtime splice\" that will
-- generate html at runtime.
compileNode :: Monad n => X.Node -> Splice n
-compileNode (X.Element nm attrs ch) =
- -- Is this node a splice, or does it merely contain splices?
- lookupSplice nm >>= fromMaybe compileStaticElement
+compileNode (X.Element nm attrs ch) = do
+ msplice <- lookupSplice nm
+ fromMaybe compileStaticElement msplice
where
tag0 = T.append "<" nm
end = T.concat [ ""]
@@ -429,8 +485,8 @@
DL.concat
[ DL.singleton $! pureTextChunk $! T.concat [" ", k, "=\""]
, v, DL.singleton $! pureTextChunk "\"" ]
-
+
attrToBuilder :: (Text, Text) -> Builder
attrToBuilder (k,v)
| T.null v = mconcat
@@ -530,15 +586,17 @@
-> HeistState n -- ^ source state
-> HeistState n
bindSplice n v ts =
- ts { _compiledSpliceMap = H.insert n v (_compiledSpliceMap ts) }
-
+ ts { _compiledSpliceMap = H.insert n' v (_compiledSpliceMap ts) }
+ where
+ n' = _splicePrefix ts `mappend` n
------------------------------------------------------------------------------
-- | Binds a list of compiled splices. This function should not be exported.
bindSplices :: Splices (Splice n) -- ^ splices to bind
-> HeistState n -- ^ source state
-> HeistState n
-bindSplices ss ts = foldr (uncurry bindSplice) ts $ splicesToList ss
+bindSplices ss hs =
+ hs { _compiledSpliceMap = applySpliceMap hs _compiledSpliceMap ss }
------------------------------------------------------------------------------
@@ -555,6 +613,10 @@
------------------------------------------------------------------------------
-- | Looks up a compiled template and returns a runtime monad computation that
-- constructs a builder.
+--
+-- Note that template names should not include the .tpl extension:
+--
+-- @renderTemplate hs "index"@
renderTemplate :: Monad n
=> HeistState n
-> ByteString
@@ -568,13 +630,14 @@
-- | Looks up a compiled template and returns a compiled splice.
callTemplate :: Monad n
=> ByteString
- -> HeistT n IO (DList (Chunk n))
+ -> Splice n
callTemplate nm = do
hs <- getHS
- runNodeList $ maybe (error err) (X.docContent . dfDoc . fst) $
- lookupTemplate nm hs _templateMap
+ maybe (error err) call $ lookupTemplate nm hs _templateMap
where
err = "callTemplate: "++(T.unpack $ T.decodeUtf8 nm)++(" does not exist")
+ call (df,_) = localHS (\hs' -> hs' {_curTemplateFile = dfFile df}) $
+ runNodeList $ X.docContent $ dfDoc df
interpret :: Monad n => DList (Chunk n) -> n Builder
@@ -593,12 +656,28 @@
------------------------------------------------------------------------------
--- | Converts a pure Node splice function to a pure Builder splice function.
+-- | This is the same as htmlNodeSplice.
nodeSplice :: (a -> [X.Node]) -> a -> Builder
nodeSplice f = X.renderHtmlFragment X.UTF8 . f
+{-# DEPRECATED nodeSplice
+ "Use xmlNodeSplice or htmlNodeSplice, will be removed in Heist 1.1" #-}
------------------------------------------------------------------------------
+-- | Converts a pure XML Node splice function to a pure Builder splice
+-- function.
+xmlNodeSplice :: (a -> [X.Node]) -> a -> Builder
+xmlNodeSplice f = X.renderXmlFragment X.UTF8 . f
+
+
+------------------------------------------------------------------------------
+-- | Converts a pure HTML Node splice function to a pure Builder splice
+-- function.
+htmlNodeSplice :: (a -> [X.Node]) -> a -> Builder
+htmlNodeSplice f = X.renderHtmlFragment X.UTF8 . f
+
+
+------------------------------------------------------------------------------
-- | Converts a pure Builder splice function into a monadic splice function
-- of a RuntimeSplice.
pureSplice :: Monad n => (a -> Builder) -> RuntimeSplice n a -> Splice n
@@ -617,107 +696,101 @@
-- ^ Runtime data needed by the above splices
-> Splice n
withSplices splice splices runtimeAction =
- withLocalSplices splices' noSplices splice
+ withLocalSplices splices' mempty splice
where
- splices' = mapS ($runtimeAction) splices
+ splices' = mapV ($ runtimeAction) splices
------------------------------------------------------------------------------
+{-# INLINE foldMapM #-}
+foldMapM :: (Monad f, Monoid m, Foldable list)
+ => (a -> f m)
+ -> list a
+ -> f m
+foldMapM f =
+ Foldable.foldlM (\xs x -> xs `seq` liftM (xs <>) (f x)) mempty
+
+------------------------------------------------------------------------------
-- | Like withSplices, but evaluates the splice repeatedly for each element in
-- a list generated at runtime.
-manyWithSplices :: Monad n
+manyWithSplices :: (Foldable f, Monad n)
=> Splice n
-> Splices (RuntimeSplice n a -> Splice n)
- -> RuntimeSplice n [a]
+ -> RuntimeSplice n (f a)
-> Splice n
-manyWithSplices splice splices runtimeAction = do
- p <- newEmptyPromise
- let splices' = mapS ($ getPromise p) splices
- chunks <- withLocalSplices splices' noSplices splice
- return $ yieldRuntime $ do
- items <- runtimeAction
- res <- forM items $ \item -> putPromise p item >> codeGen chunks
- return $ mconcat res
+manyWithSplices splice splices runtimeAction =
+ manyWith splice splices mempty runtimeAction
------------------------------------------------------------------------------
-- | More powerful version of manyWithSplices that lets you also define
-- attribute splices.
-manyWith :: (Monad n)
+manyWith :: (Foldable f, Monad n)
=> Splice n
-> Splices (RuntimeSplice n a -> Splice n)
-> Splices (RuntimeSplice n a -> AttrSplice n)
- -> RuntimeSplice n [a]
+ -> RuntimeSplice n (f a)
-> Splice n
manyWith splice splices attrSplices runtimeAction = do
p <- newEmptyPromise
- let splices' = mapS ($ getPromise p) splices
- let attrSplices' = mapS ($ getPromise p) attrSplices
+ let splices' = mapV ($ getPromise p) splices
+ let attrSplices' = mapV ($ getPromise p) attrSplices
chunks <- withLocalSplices splices' attrSplices' splice
return $ yieldRuntime $ do
items <- runtimeAction
- res <- forM items $ \item -> putPromise p item >> codeGen chunks
- return $ mconcat res
+ foldMapM (\item -> putPromise p item >> codeGen chunks) items
------------------------------------------------------------------------------
-- | Similar to 'mapSplices' in interpreted mode. Gets a runtime list of
-- items and applies a compiled runtime splice function to each element of the
-- list.
-deferMany :: Monad n
+deferMany :: (Foldable f, Monad n)
=> (RuntimeSplice n a -> Splice n)
- -> RuntimeSplice n [a]
+ -> RuntimeSplice n (f a)
-> Splice n
deferMany f getItems = do
promise <- newEmptyPromise
chunks <- f $ getPromise promise
return $ yieldRuntime $ do
items <- getItems
- res <- forM items $ \item -> do
- putPromise promise item
- codeGen chunks
- return $ mconcat res
+ foldMapM (\item -> putPromise promise item >> codeGen chunks) items
------------------------------------------------------------------------------
--- | Saves the results of a runtme computation in a 'Promise' so they don't
+-- | Saves the results of a runtime computation in a 'Promise' so they don't
-- get recalculated if used more than once.
+--
+-- Note that this is just a specialized version of function application ($)
+-- done for the side effect in runtime splice.
+defer :: Monad n
+ => (RuntimeSplice n a -> Splice n)
+ -> RuntimeSplice n a -> Splice n
+defer pf n = do
+ p2 <- newEmptyPromise
+ let action = yieldRuntimeEffect $ putPromise p2 =<< n
+ res <- pf $ getPromise p2
+ return $ action `mappend` res
+
+
+------------------------------------------------------------------------------
+-- | A version of defer which applies a function on the runtime value.
deferMap :: Monad n
=> (a -> RuntimeSplice n b)
-> (RuntimeSplice n b -> Splice n)
-> RuntimeSplice n a -> Splice n
-deferMap f pf n = do
- p2 <- newEmptyPromise
- let action = yieldRuntimeEffect $ putPromise p2 =<< f =<< n
- res <- pf $ getPromise p2
- return $ action `mappend` res
+deferMap f pf n = defer pf $ f =<< n
------------------------------------------------------------------------------
-- | Like deferMap, but only runs the result if a Maybe function of the
-- runtime value returns Just. If it returns Nothing, then no output is
-- generated.
---
--- This is a good example of how to do more complex flow control with
--- promises. The generalization of this abstraction is too complex to be
--- distilled to elegant high-level combinators. If you need to implement your
--- own special flow control, then you should use functions from the
--- `Heist.Compiled.LowLevel` module similarly to how it is done in the
--- implementation of this function.
mayDeferMap :: Monad n
=> (a -> RuntimeSplice n (Maybe b))
-> (RuntimeSplice n b -> Splice n)
-> RuntimeSplice n a -> Splice n
-mayDeferMap f pf n = do
- p2 <- newEmptyPromise
- action <- pf $ getPromise p2
- return $ yieldRuntime $ do
- mb <- f =<< n
- case mb of
- Nothing -> return mempty
- Just b -> do
- putPromise p2 b
- codeGen action
+mayDeferMap f pf n = deferMany pf $ f =<< n
------------------------------------------------------------------------------
diff --git a/src/Heist/Internal/Types.hs b/src/Heist/Internal/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Internal/Types.hs
@@ -0,0 +1,279 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-|
+
+Internal types and accessors. There are no guarantees that heist will
+preserve backwards compatibility for symbols in this module. If you use them,
+no complaining when your code breaks.
+
+-}
+
+module Heist.Internal.Types
+ ( module Heist.Internal.Types.HeistState
+ , module Heist.Internal.Types
+ ) where
+
+------------------------------------------------------------------------------
+import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative
+#endif
+#if !MIN_VERSION_base(4,11,0)
+import Data.Semigroup
+#endif
+
+------------------------------------------------------------------------------
+import qualified Heist.Compiled.Internal as C
+import qualified Heist.Interpreted.Internal as I
+import Heist.Internal.Types.HeistState
+------------------------------------------------------------------------------
+
+
+------------------------------------------------------------------------------
+type TemplateRepo = HashMap TPath DocumentFile
+
+
+------------------------------------------------------------------------------
+-- | An IO action for getting a template repo from this location. By not just
+-- using a directory path here, we support templates loaded from a database,
+-- retrieved from the network, or anything else you can think of.
+type TemplateLocation = IO (Either [String] TemplateRepo)
+
+
+------------------------------------------------------------------------------
+-- | My lens creation function to avoid a dependency on lens.
+lens :: Functor f => (t1 -> t) -> (t1 -> a -> b) -> (t -> f a) -> t1 -> f b
+lens sa sbt afb s = sbt s <$> afb (sa s)
+
+
+------------------------------------------------------------------------------
+-- | The splices and templates Heist will use. To bind a splice simply
+-- include it in the appropriate place here.
+data SpliceConfig m = SpliceConfig
+ { _scInterpretedSplices :: Splices (I.Splice m)
+ -- ^ Interpreted splices are the splices that Heist has always had.
+ -- They return a list of nodes and are processed at runtime.
+ , _scLoadTimeSplices :: Splices (I.Splice IO)
+ -- ^ Load time splices are like interpreted splices because they
+ -- return a list of nodes. But they are like compiled splices because
+ -- they are processed once at load time. All of Heist's built-in
+ -- splices should be used as load time splices.
+ , _scCompiledSplices :: Splices (C.Splice m)
+ -- ^ Compiled splices return a DList of Chunks and are processed at
+ -- load time to generate a runtime monad action that will be used to
+ -- render the template.
+ , _scAttributeSplices :: Splices (AttrSplice m)
+ -- ^ Attribute splices are bound to attribute names and return a list
+ -- of attributes.
+ , _scTemplateLocations :: [TemplateLocation]
+ -- ^ A list of all the locations that Heist should get its templates
+ -- from.
+ , _scCompiledTemplateFilter :: TPath -> Bool
+ -- ^ Predicate function to control which templates to compile. Using
+ -- templates filtered out with this is still possible via
+ -- callTemplate.
+ }
+
+
+------------------------------------------------------------------------------
+-- | Lens for interpreted splices
+-- :: Simple Lens (SpliceConfig m) (Splices (I.Splice m))
+scInterpretedSplices
+ :: Functor f
+ => (Splices (I.Splice m) -> f (Splices (I.Splice m)))
+ -> SpliceConfig m -> f (SpliceConfig m)
+scInterpretedSplices = lens _scInterpretedSplices setter
+ where
+ setter sc v = sc { _scInterpretedSplices = v }
+
+
+------------------------------------------------------------------------------
+-- | Lens for load time splices
+-- :: Simple Lens (SpliceConfig m) (Splices (I.Splice IO))
+scLoadTimeSplices
+ :: Functor f
+ => (Splices (I.Splice IO) -> f (Splices (I.Splice IO)))
+ -> SpliceConfig m -> f (SpliceConfig m)
+scLoadTimeSplices = lens _scLoadTimeSplices setter
+ where
+ setter sc v = sc { _scLoadTimeSplices = v }
+
+
+------------------------------------------------------------------------------
+-- | Lens for complied splices
+-- :: Simple Lens (SpliceConfig m) (Splices (C.Splice m))
+scCompiledSplices
+ :: Functor f
+ => (Splices (C.Splice m) -> f (Splices (C.Splice m)))
+ -> SpliceConfig m -> f (SpliceConfig m)
+scCompiledSplices = lens _scCompiledSplices setter
+ where
+ setter sc v = sc { _scCompiledSplices = v }
+
+
+------------------------------------------------------------------------------
+-- | Lens for attribute splices
+-- :: Simple Lens (SpliceConfig m) (Splices (AttrSplice m))
+scAttributeSplices
+ :: Functor f
+ => (Splices (AttrSplice m) -> f (Splices (AttrSplice m)))
+ -> SpliceConfig m -> f (SpliceConfig m)
+scAttributeSplices = lens _scAttributeSplices setter
+ where
+ setter sc v = sc { _scAttributeSplices = v }
+
+
+------------------------------------------------------------------------------
+-- | Lens for template locations
+-- :: Simple Lens (SpliceConfig m) [TemplateLocation]
+scTemplateLocations
+ :: Functor f
+ => ([TemplateLocation] -> f [TemplateLocation])
+ -> SpliceConfig m -> f (SpliceConfig m)
+scTemplateLocations = lens _scTemplateLocations setter
+ where
+ setter sc v = sc { _scTemplateLocations = v }
+
+
+------------------------------------------------------------------------------
+-- | Lens for compiled template filter
+-- :: Simple Lens (SpliceConfig m) (TBool -> Bool)
+scCompiledTemplateFilter
+ :: Functor f
+ => ((TPath -> Bool) -> f (TPath -> Bool))
+ -> SpliceConfig m -> f (SpliceConfig m)
+scCompiledTemplateFilter = lens _scCompiledTemplateFilter setter
+ where
+ setter sc v = sc { _scCompiledTemplateFilter = v }
+
+
+instance Semigroup (SpliceConfig m) where
+ SpliceConfig a1 b1 c1 d1 e1 f1 <> SpliceConfig a2 b2 c2 d2 e2 f2 =
+ SpliceConfig (a1 <> a2) (b1 <> b2) (c1 <> c2)
+ (d1 <> d2) (e1 <> e2) (\x -> f1 x && f2 x)
+
+instance Monoid (SpliceConfig m) where
+ mempty = SpliceConfig mempty mempty mempty mempty mempty (const True)
+#if !MIN_VERSION_base(4,11,0)
+ mappend = (<>)
+#endif
+
+
+data HeistConfig m = HeistConfig
+ { _hcSpliceConfig :: SpliceConfig m
+ -- ^ Splices and templates
+ , _hcNamespace :: Text
+ -- ^ A namespace to use for all tags that are bound to splices. Use
+ -- empty string for no namespace.
+ , _hcErrorNotBound :: Bool
+ -- ^ Whether to throw an error when a tag wih the heist namespace does
+ -- not correspond to a bound splice. When not using a namespace, this
+ -- flag is ignored.
+ }
+
+
+------------------------------------------------------------------------------
+-- | Lens for the SpliceConfig
+-- :: Simple Lens (HeistConfig m) (SpliceConfig m)
+hcSpliceConfig
+ :: Functor f
+ => ((SpliceConfig m) -> f (SpliceConfig m))
+ -> HeistConfig m -> f (HeistConfig m)
+hcSpliceConfig = lens _hcSpliceConfig setter
+ where
+ setter hc v = hc { _hcSpliceConfig = v }
+
+
+------------------------------------------------------------------------------
+-- | Lens for the namespace
+-- :: Simple Lens (HeistConfig m) Text
+hcNamespace
+ :: Functor f
+ => (Text -> f Text)
+ -> HeistConfig m -> f (HeistConfig m)
+hcNamespace = lens _hcNamespace setter
+ where
+ setter hc v = hc { _hcNamespace = v }
+
+
+------------------------------------------------------------------------------
+-- | Lens for the namespace error flag
+-- :: Simple Lens (HeistConfig m) Bool
+hcErrorNotBound
+ :: Functor f
+ => (Bool -> f Bool)
+ -> HeistConfig m -> f (HeistConfig m)
+hcErrorNotBound = lens _hcErrorNotBound setter
+ where
+ setter hc v = hc { _hcErrorNotBound = v }
+
+
+------------------------------------------------------------------------------
+-- | Lens for interpreted splices
+-- :: Simple Lens (HeistConfig m) (Splices (I.Splice m))
+hcInterpretedSplices
+ :: Functor f
+ => (Splices (I.Splice m) -> f (Splices (I.Splice m)))
+ -> HeistConfig m -> f (HeistConfig m)
+hcInterpretedSplices = hcSpliceConfig . scInterpretedSplices
+
+
+------------------------------------------------------------------------------
+-- | Lens for load time splices
+-- :: Simple Lens (HeistConfig m) (Splices (I.Splice IO))
+hcLoadTimeSplices
+ :: Functor f
+ => (Splices (I.Splice IO) -> f (Splices (I.Splice IO)))
+ -> HeistConfig m -> f (HeistConfig m)
+hcLoadTimeSplices = hcSpliceConfig . scLoadTimeSplices
+
+
+------------------------------------------------------------------------------
+-- | Lens for compiled splices
+-- :: Simple Lens (HeistConfig m) (Splices (C.Splice m))
+hcCompiledSplices
+ :: Functor f
+ => (Splices (C.Splice m) -> f (Splices (C.Splice m)))
+ -> HeistConfig m -> f (HeistConfig m)
+hcCompiledSplices = hcSpliceConfig . scCompiledSplices
+
+
+------------------------------------------------------------------------------
+-- | Lens for attribute splices
+-- :: Simple Lens (HeistConfig m) (Splices (AttrSplice m))
+hcAttributeSplices
+ :: Functor f
+ => (Splices (AttrSplice m) -> f (Splices (AttrSplice m)))
+ -> HeistConfig m -> f (HeistConfig m)
+hcAttributeSplices = hcSpliceConfig . scAttributeSplices
+
+
+------------------------------------------------------------------------------
+-- | Lens for template locations
+-- :: Simple Lens (HeistConfig m) [TemplateLocation]
+hcTemplateLocations
+ :: Functor f
+ => ([TemplateLocation] -> f [TemplateLocation])
+ -> HeistConfig m -> f (HeistConfig m)
+hcTemplateLocations = hcSpliceConfig . scTemplateLocations
+
+
+------------------------------------------------------------------------------
+-- | Lens for compiled template filter
+-- :: Simple Lens (SpliceConfig m) (TBool -> Bool)
+hcCompiledTemplateFilter
+ :: Functor f
+ => ((TPath -> Bool) -> f (TPath -> Bool))
+ -> HeistConfig m -> f (HeistConfig m)
+hcCompiledTemplateFilter = hcSpliceConfig . scCompiledTemplateFilter
+
+
diff --git a/src/Heist/Internal/Types/HeistState.hs b/src/Heist/Internal/Types/HeistState.hs
new file mode 100644
--- /dev/null
+++ b/src/Heist/Internal/Types/HeistState.hs
@@ -0,0 +1,680 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-|
+
+This module contains the core Heist data types.
+
+Edward Kmett wrote most of the HeistT monad code and associated instances,
+liberating us from the unused writer portion of RWST.
+
+-}
+
+module Heist.Internal.Types.HeistState where
+
+------------------------------------------------------------------------------
+import Blaze.ByteString.Builder (Builder)
+import Control.Applicative (Alternative (..))
+import Control.Arrow (first)
+import Control.Exception (Exception)
+import Control.Monad (MonadPlus (..), ap)
+import Control.Monad.Base
+import Control.Monad.Cont (MonadCont (..))
+#if MIN_VERSION_mtl(2,2,1)
+import Control.Monad.Except (MonadError (..))
+#else
+import Control.Monad.Error (MonadError (..))
+#endif
+#if MIN_VERSION_base(4,9,0)
+import qualified Control.Monad.Fail as Fail
+#endif
+import Control.Monad.Fix (MonadFix (..))
+import Control.Monad.Reader (MonadReader (..))
+import Control.Monad.State.Strict (MonadState (..), StateT)
+import Control.Monad.Trans (MonadIO (..), MonadTrans (..))
+import Control.Monad.Trans.Control
+import Data.ByteString.Char8 (ByteString)
+import Data.DList (DList)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as H
+import Data.HeterogeneousEnvironment (HeterogeneousEnvironment)
+import qualified Data.HeterogeneousEnvironment as HE
+import Data.Map.Syntax
+#if !MIN_VERSION_base(4,11,0)
+import Data.Semigroup
+#endif
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8)
+#if MIN_VERSION_base (4,7,0)
+import Data.Typeable (Typeable)
+#else
+import Data.Typeable (TyCon, Typeable(..),
+ Typeable1(..), mkTyCon,
+ mkTyConApp)
+#endif
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative (Applicative (..), (<$>))
+import Data.Monoid (Monoid(..))
+#endif
+
+import qualified Text.XmlHtml as X
+------------------------------------------------------------------------------
+
+
+------------------------------------------------------------------------------
+-- | Convenient type alies for splices.
+type Splices s = MapSyntax Text s
+
+
+------------------------------------------------------------------------------
+-- | A 'Template' is a forest of XML nodes. Here we deviate from the \"single
+-- root node\" constraint of well-formed XML because we want to allow
+-- templates to contain document fragments that may not have a single root.
+type Template = [X.Node]
+
+
+------------------------------------------------------------------------------
+-- | MIME Type. The type alias is here to make the API clearer.
+type MIMEType = ByteString
+
+
+------------------------------------------------------------------------------
+-- | Reversed list of directories. This holds the path to the template
+-- currently being processed.
+type TPath = [ByteString]
+
+
+------------------------------------------------------------------------------
+-- | Holds data about templates read from disk.
+data DocumentFile = DocumentFile
+ { dfDoc :: X.Document
+ , dfFile :: Maybe FilePath
+ } deriving ( Eq, Show
+#if MIN_VERSION_base(4,7,0)
+ , Typeable
+#endif
+ )
+
+
+------------------------------------------------------------------------------
+-- | Designates whether a document should be treated as XML or HTML.
+data Markup = Xml | Html
+
+
+------------------------------------------------------------------------------
+-- | Monad used for runtime splice execution.
+newtype RuntimeSplice m a = RuntimeSplice {
+ unRT :: StateT HeterogeneousEnvironment m a
+ } deriving ( Applicative
+ , Functor
+ , Monad
+ , MonadIO
+ , MonadState HeterogeneousEnvironment
+ , MonadTrans
+#if MIN_VERSION_base(4,7,0)
+ , Typeable
+#endif
+ )
+
+
+------------------------------------------------------------------------------
+instance (Monad m, Semigroup a) => Semigroup (RuntimeSplice m a) where
+ a <> b = do
+ !x <- a
+ !y <- b
+ return $! x <> y
+
+
+#if !MIN_VERSION_base(4,11,0)
+instance (Monad m, Semigroup a, Monoid a) => Monoid (RuntimeSplice m a) where
+#else
+instance (Monad m, Monoid a) => Monoid (RuntimeSplice m a) where
+#endif
+ mempty = return mempty
+#if !MIN_VERSION_base(4,11,0)
+ mappend = (<>)
+#endif
+
+
+------------------------------------------------------------------------------
+-- | Opaque type representing pieces of output from compiled splices.
+data Chunk m = Pure !ByteString
+ -- ^ output known at load time
+ | RuntimeHtml !(RuntimeSplice m Builder)
+ -- ^ output computed at run time
+ | RuntimeAction !(RuntimeSplice m ())
+ -- ^ runtime action used only for its side-effect
+#if MIN_VERSION_base(4,7,0)
+ deriving Typeable
+#endif
+
+instance Show (Chunk m) where
+ show (Pure _) = "Pure"
+ show (RuntimeHtml _) = "RuntimeHtml"
+ show (RuntimeAction _) = "RuntimeAction"
+
+
+showChunk :: Chunk m -> String
+showChunk (Pure b) = T.unpack $ decodeUtf8 b
+showChunk (RuntimeHtml _) = "RuntimeHtml"
+showChunk (RuntimeAction _) = "RuntimeAction"
+
+
+isPureChunk :: Chunk m -> Bool
+isPureChunk (Pure _) = True
+isPureChunk _ = False
+
+
+------------------------------------------------------------------------------
+-- | Type alias for attribute splices. The function parameter is the value of
+-- the bound attribute splice. The return value is a list of attribute
+-- key/value pairs that get substituted in the place of the bound attribute.
+type AttrSplice m = Text -> RuntimeSplice m [(Text, Text)]
+
+
+------------------------------------------------------------------------------
+-- | Detailed information about a splice error.
+data SpliceError = SpliceError
+ { spliceHistory :: [(TPath, Maybe FilePath, Text)]
+ , spliceTemplateFile :: Maybe FilePath
+ , visibleSplices :: [Text]
+ , contextNode :: X.Node
+ , spliceMsg :: Text
+ } deriving ( Show, Eq )
+
+
+------------------------------------------------------------------------------
+-- | Transform a SpliceError record to a Text message.
+spliceErrorText :: SpliceError -> Text
+spliceErrorText (SpliceError hist tf splices node msg) =
+ (maybe "" ((`mappend` ": ") . T.pack) tf) `T.append` msg `T.append`
+ foldr (\(_, tf', tag) -> (("\n ... via " `T.append`
+ (maybe "" ((`mappend` ": ") . T.pack) tf')
+ `T.append` tag) `T.append`)) T.empty hist
+ `T.append`
+ if null splices
+ then T.empty
+ else "\nBound splices:" `T.append`
+ foldl (\x y -> x `T.append` " " `T.append` y) T.empty splices
+ `T.append`
+ (T.pack $ "\nNode: " ++ (show node))
+
+
+------------------------------------------------------------------------------
+-- | Exception type for splice compile errors. Wraps the original
+-- exception and provides context.
+--data (Exception e) => CompileException e = CompileException
+data CompileException = forall e . Exception e => CompileException
+ { originalException :: e
+ -- The list of splice errors. The head of it has the context
+ -- related to the exception.
+ , exceptionContext :: [SpliceError]
+ } deriving ( Typeable )
+
+
+instance Show CompileException where
+ show (CompileException e []) =
+ "Heist load exception (unknown context): " ++ (show e)
+ show (CompileException _ (c:_)) = (T.unpack $ spliceErrorText c)
+
+
+instance Exception CompileException
+
+
+------------------------------------------------------------------------------
+-- | Holds all the state information needed for template processing. You will
+-- build a @HeistState@ using 'initHeist' and any of Heist's @HeistState ->
+-- HeistState@ \"filter\" functions. Then you use the resulting @HeistState@
+-- in calls to 'renderTemplate'.
+--
+-- m is the runtime monad
+data HeistState m = HeistState {
+ -- | A mapping of splice names to splice actions
+ _spliceMap :: HashMap Text (HeistT m m Template)
+ -- | A mapping of template names to templates
+ , _templateMap :: HashMap TPath DocumentFile
+
+ -- | A mapping of splice names to splice actions
+ , _compiledSpliceMap :: HashMap Text (HeistT m IO (DList (Chunk m)))
+ -- | A mapping of template names to templates
+ --, _compiledTemplateMap :: HashMap TPath (m Builder, MIMEType)
+ , _compiledTemplateMap :: !(HashMap TPath ([Chunk m], MIMEType))
+
+ , _attrSpliceMap :: HashMap Text (AttrSplice m)
+
+ -- | A flag to control splice recursion
+ , _recurse :: Bool
+ -- | The path to the template currently being processed.
+ , _curContext :: TPath
+ -- | Stack of the splices used.
+ , _splicePath :: [(TPath, Maybe FilePath, Text)]
+ -- | A counter keeping track of the current recursion depth to prevent
+ -- infinite loops.
+ , _recursionDepth :: Int
+ -- | The doctypes encountered during template processing.
+ , _doctypes :: [X.DocType]
+ -- | The full path to the current template's file on disk.
+ , _curTemplateFile :: Maybe FilePath
+ -- | A key generator used to produce new unique Promises.
+ , _keygen :: HE.KeyGen
+
+ -- | Flag indicating whether we're in preprocessing mode. During
+ -- preprocessing, errors should stop execution and be reported. During
+ -- template rendering, it's better to skip the errors and render the page.
+ , _preprocessingMode :: Bool
+
+ -- | This is needed because compiled templates are generated with a bunch
+ -- of calls to renderFragment rather than a single call to render.
+ , _curMarkup :: Markup
+
+ -- | A prefix for all splices (namespace ++ ":").
+ , _splicePrefix :: Text
+
+ -- | List of errors encountered during splice processing.
+ , _spliceErrors :: [SpliceError]
+
+ -- | Whether to throw an error when a tag wih the heist namespace does not
+ -- correspond to a bound splice. When not using a namespace, this flag is
+ -- ignored.
+ , _errorNotBound :: Bool
+ , _numNamespacedTags :: Int
+#if MIN_VERSION_base(4,7,0)
+} deriving (Typeable)
+#else
+}
+#endif
+
+#if !MIN_VERSION_base(4,7,0)
+-- NOTE: We got rid of the Monoid instance because it is absolutely not safe
+-- to combine two compiledTemplateMaps. All compiled templates must be known
+-- at load time and processed in a single call to initHeist/loadTemplates or
+-- whatever we end up calling it..
+
+instance (Typeable1 m) => Typeable (HeistState m) where
+ typeOf _ = mkTyConApp templateStateTyCon [typeOf1 (undefined :: m ())]
+
+#endif
+
+------------------------------------------------------------------------------
+-- | HeistT is the monad transformer used for splice processing. HeistT
+-- intentionally does not expose any of its functionality via MonadState or
+-- MonadReader functions. We define passthrough instances for the most common
+-- types of monads. These instances allow the user to use HeistT in a monad
+-- stack without needing calls to `lift`.
+--
+-- @n@ is the runtime monad (the parameter to HeistState).
+--
+-- @m@ is the monad being run now. In this case, \"now\" is a variable
+-- concept. The type @HeistT n n@ means that \"now\" is runtime. The type
+-- @HeistT n IO@ means that \"now\" is @IO@, and more importantly it is NOT
+-- runtime. In Heist, the rule of thumb is that @IO@ means load time and @n@
+-- means runtime.
+newtype HeistT n m a = HeistT {
+ runHeistT :: X.Node
+ -> HeistState n
+ -> m (a, HeistState n)
+#if MIN_VERSION_base(4,7,0)
+} deriving Typeable
+#else
+}
+#endif
+
+
+------------------------------------------------------------------------------
+-- | Gets the names of all the templates defined in a HeistState.
+templateNames :: HeistState m -> [TPath]
+templateNames ts = H.keys $ _templateMap ts
+
+
+------------------------------------------------------------------------------
+-- | Gets the names of all the templates defined in a HeistState.
+compiledTemplateNames :: HeistState m -> [TPath]
+compiledTemplateNames ts = H.keys $ _compiledTemplateMap ts
+
+
+------------------------------------------------------------------------------
+-- | Gets the names of all the interpreted splices defined in a HeistState.
+spliceNames :: HeistState m -> [Text]
+spliceNames ts = H.keys $ _spliceMap ts
+
+
+------------------------------------------------------------------------------
+-- | Gets the names of all the compiled splices defined in a HeistState.
+compiledSpliceNames :: HeistState m -> [Text]
+compiledSpliceNames ts = H.keys $ _compiledSpliceMap ts
+
+
+#if !MIN_VERSION_base(4,7,0)
+------------------------------------------------------------------------------
+-- | The Typeable instance is here so Heist can be dynamically executed with
+-- Hint.
+templateStateTyCon :: TyCon
+templateStateTyCon = mkTyCon "Heist.HeistState"
+{-# NOINLINE templateStateTyCon #-}
+#endif
+
+
+------------------------------------------------------------------------------
+-- | Evaluates a template monad as a computation in the underlying monad.
+evalHeistT :: (Monad m)
+ => HeistT n m a
+ -> X.Node
+ -> HeistState n
+ -> m a
+evalHeistT m r s = do
+ (a, _) <- runHeistT m r s
+ return a
+{-# INLINE evalHeistT #-}
+
+
+------------------------------------------------------------------------------
+-- | Functor instance
+instance Functor m => Functor (HeistT n m) where
+ fmap f (HeistT m) = HeistT $ \r s -> first f <$> m r s
+
+
+------------------------------------------------------------------------------
+-- | Applicative instance
+instance (Monad m, Functor m) => Applicative (HeistT n m) where
+ pure = return
+ (<*>) = ap
+
+
+------------------------------------------------------------------------------
+-- | Monad instance
+instance Monad m => Monad (HeistT n m) where
+ return a = HeistT (\_ s -> return (a, s))
+ {-# INLINE return #-}
+ HeistT m >>= k = HeistT $ \r s -> do
+ (a, s') <- m r s
+ runHeistT (k a) r s'
+ {-# INLINE (>>=) #-}
+
+
+#if MIN_VERSION_base(4,9,0)
+------------------------------------------------------------------------------
+-- | MonadFail instance
+instance Fail.MonadFail m => Fail.MonadFail (HeistT n m) where
+ fail = lift . Fail.fail
+#endif
+
+
+------------------------------------------------------------------------------
+-- | MonadIO instance
+instance MonadIO m => MonadIO (HeistT n m) where
+ liftIO = lift . liftIO
+
+
+------------------------------------------------------------------------------
+-- | MonadTrans instance
+instance MonadTrans (HeistT n) where
+ lift m = HeistT $ \_ s -> do
+ a <- m
+ return (a, s)
+
+
+instance MonadBase b m => MonadBase b (HeistT n m) where
+ liftBase = lift . liftBase
+
+#if MIN_VERSION_monad_control(1,0,0)
+instance MonadTransControl (HeistT n) where
+ type StT (HeistT n) a = (a, HeistState n)
+ liftWith f = HeistT $ \n s -> do
+ res <- f $ \(HeistT g) -> g n s
+ return (res, s)
+ restoreT k = HeistT $ \_ _ -> k
+ {-# INLINE liftWith #-}
+ {-# INLINE restoreT #-}
+
+
+instance MonadBaseControl b m => MonadBaseControl b (HeistT n m) where
+ type StM (HeistT n m) a = ComposeSt (HeistT n) m a
+ liftBaseWith = defaultLiftBaseWith
+ restoreM = defaultRestoreM
+ {-# INLINE liftBaseWith #-}
+ {-# INLINE restoreM #-}
+#else
+instance MonadTransControl (HeistT n) where
+ newtype StT (HeistT n) a = StHeistT {unStHeistT :: (a, HeistState n)}
+ liftWith f = HeistT $ \n s -> do
+ res <- f $ \(HeistT g) -> liftM StHeistT $ g n s
+ return (res, s)
+ restoreT k = HeistT $ \_ _ -> liftM unStHeistT k
+ {-# INLINE liftWith #-}
+ {-# INLINE restoreT #-}
+
+
+instance MonadBaseControl b m => MonadBaseControl b (HeistT n m) where
+ newtype StM (HeistT n m) a = StMHeist {unStMHeist :: ComposeSt (HeistT n) m a}
+ liftBaseWith = defaultLiftBaseWith StMHeist
+ restoreM = defaultRestoreM unStMHeist
+ {-# INLINE liftBaseWith #-}
+ {-# INLINE restoreM #-}
+#endif
+
+------------------------------------------------------------------------------
+-- | MonadFix passthrough instance
+instance MonadFix m => MonadFix (HeistT n m) where
+ mfix f = HeistT $ \r s ->
+ mfix $ \ (a, _) -> runHeistT (f a) r s
+
+
+------------------------------------------------------------------------------
+-- | Alternative passthrough instance
+instance (Functor m, MonadPlus m) => Alternative (HeistT n m) where
+ empty = mzero
+ (<|>) = mplus
+
+
+------------------------------------------------------------------------------
+-- | MonadPlus passthrough instance
+instance MonadPlus m => MonadPlus (HeistT n m) where
+ mzero = lift mzero
+ m `mplus` n = HeistT $ \r s ->
+ runHeistT m r s `mplus` runHeistT n r s
+
+
+------------------------------------------------------------------------------
+-- | MonadState passthrough instance
+instance MonadState s m => MonadState s (HeistT n m) where
+ get = lift get
+ {-# INLINE get #-}
+ put = lift . put
+ {-# INLINE put #-}
+
+
+------------------------------------------------------------------------------
+-- | MonadReader passthrough instance
+instance MonadReader r m => MonadReader r (HeistT n m) where
+ ask = HeistT $ \_ s -> do
+ r <- ask
+ return (r,s)
+ local f (HeistT m) =
+ HeistT $ \r s -> local f (m r s)
+
+
+------------------------------------------------------------------------------
+-- | Helper for MonadError instance.
+_liftCatch
+ :: (m (a,HeistState n)
+ -> (e -> m (a,HeistState n))
+ -> m (a,HeistState n))
+ -> HeistT n m a
+ -> (e -> HeistT n m a)
+ -> HeistT n m a
+_liftCatch ce m h =
+ HeistT $ \r s ->
+ (runHeistT m r s `ce`
+ (\e -> runHeistT (h e) r s))
+
+
+------------------------------------------------------------------------------
+-- | MonadError passthrough instance
+instance (MonadError e m) => MonadError e (HeistT n m) where
+ throwError = lift . throwError
+ catchError = _liftCatch catchError
+
+
+------------------------------------------------------------------------------
+-- | Helper for MonadCont instance.
+_liftCallCC
+ :: ((((a,HeistState n) -> m (b, HeistState n))
+ -> m (a, HeistState n))
+ -> m (a, HeistState n))
+ -> ((a -> HeistT n m b) -> HeistT n m a)
+ -> HeistT n m a
+_liftCallCC ccc f = HeistT $ \r s ->
+ ccc $ \c ->
+ runHeistT (f (\a -> HeistT $ \_ _ -> c (a, s))) r s
+
+
+------------------------------------------------------------------------------
+-- | MonadCont passthrough instance
+instance (MonadCont m) => MonadCont (HeistT n m) where
+ callCC = _liftCallCC callCC
+
+
+#if !MIN_VERSION_base(4,7,0)
+------------------------------------------------------------------------------
+-- | The Typeable instance is here so Heist can be dynamically executed with
+-- Hint.
+templateMonadTyCon :: TyCon
+templateMonadTyCon = mkTyCon "Heist.HeistT"
+{-# NOINLINE templateMonadTyCon #-}
+
+instance (Typeable1 m) => Typeable1 (HeistT n m) where
+ typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())]
+#endif
+
+
+------------------------------------------------------------------------------
+-- Functions for our monad.
+------------------------------------------------------------------------------
+
+
+------------------------------------------------------------------------------
+-- | Gets the node currently being processed.
+--
+-- >
+-- > To sleep, perchance to dream.
+-- >
+--
+-- When you call @getParamNode@ inside the code for the @speech@ splice, it
+-- returns the Node for the @speech@ tag and its children. @getParamNode >>=
+-- childNodes@ returns a list containing one 'TextNode' containing part of
+-- Hamlet's speech. @liftM (getAttribute \"author\") getParamNode@ would
+-- return @Just \"Shakespeare\"@.
+getParamNode :: Monad m => HeistT n m X.Node
+getParamNode = HeistT $ curry return
+{-# INLINE getParamNode #-}
+
+
+------------------------------------------------------------------------------
+-- | HeistT's 'local'.
+localParamNode :: Monad m
+ => (X.Node -> X.Node)
+ -> HeistT n m a
+ -> HeistT n m a
+localParamNode f m = HeistT $ \r s -> runHeistT m (f r) s
+{-# INLINE localParamNode #-}
+
+
+------------------------------------------------------------------------------
+-- | HeistT's 'gets'.
+getsHS :: Monad m => (HeistState n -> r) -> HeistT n m r
+getsHS f = HeistT $ \_ s -> return (f s, s)
+{-# INLINE getsHS #-}
+
+
+------------------------------------------------------------------------------
+-- | HeistT's 'get'.
+getHS :: Monad m => HeistT n m (HeistState n)
+getHS = HeistT $ \_ s -> return (s, s)
+{-# INLINE getHS #-}
+
+
+------------------------------------------------------------------------------
+-- | HeistT's 'put'.
+putHS :: Monad m => HeistState n -> HeistT n m ()
+putHS s = HeistT $ \_ _ -> return ((), s)
+{-# INLINE putHS #-}
+
+
+------------------------------------------------------------------------------
+-- | HeistT's 'modify'.
+modifyHS :: Monad m
+ => (HeistState n -> HeistState n)
+ -> HeistT n m ()
+modifyHS f = HeistT $ \_ s -> return ((), f s)
+{-# INLINE modifyHS #-}
+
+
+------------------------------------------------------------------------------
+-- | Restores the HeistState. This function is almost like putHS except it
+-- preserves the current doctypes and splice errors. You should use this
+-- function instead of @putHS@ to restore an old state. This was needed
+-- because doctypes needs to be in a "global scope" as opposed to the template
+-- call "local scope" of state items such as recursionDepth, curContext, and
+-- spliceMap.
+restoreHS :: Monad m => HeistState n -> HeistT n m ()
+restoreHS old = modifyHS (\cur -> old { _doctypes = _doctypes cur
+ , _numNamespacedTags =
+ _numNamespacedTags cur
+ , _spliceErrors = _spliceErrors cur })
+{-# INLINE restoreHS #-}
+
+
+------------------------------------------------------------------------------
+-- | Abstracts the common pattern of running a HeistT computation with
+-- a modified heist state.
+localHS :: Monad m
+ => (HeistState n -> HeistState n)
+ -> HeistT n m a
+ -> HeistT n m a
+localHS f k = do
+ ts <- getHS
+ putHS $ f ts
+ res <- k
+ restoreHS ts
+ return res
+{-# INLINE localHS #-}
+
+
+------------------------------------------------------------------------------
+-- | Modifies the recursion depth.
+modRecursionDepth :: Monad m => (Int -> Int) -> HeistT n m ()
+modRecursionDepth f =
+ modifyHS (\st -> st { _recursionDepth = f (_recursionDepth st) })
+
+
+------------------------------------------------------------------------------
+-- | Increments the namespaced tag count
+incNamespacedTags :: Monad m => HeistT n m ()
+incNamespacedTags =
+ modifyHS (\st -> st { _numNamespacedTags = _numNamespacedTags st + 1 })
+
+
+------------------------------------------------------------------------------
+-- | AST to hold attribute parsing structure. This is necessary because
+-- attoparsec doesn't support parsers running in another monad.
+data AttAST = Literal Text
+ | Ident Text
+ deriving (Show)
+
+
+------------------------------------------------------------------------------
+isIdent :: AttAST -> Bool
+isIdent (Ident _) = True
+isIdent _ = False
+
+
diff --git a/src/Heist/Interpreted.hs b/src/Heist/Interpreted.hs
--- 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
@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
@@ -10,20 +9,19 @@
import Blaze.ByteString.Builder
import Control.Monad
import Control.Monad.State.Strict
-import qualified Data.Attoparsec.Text as AP
-import Data.ByteString (ByteString)
-import Data.List
-import qualified Data.HashMap.Strict as Map
-import qualified Data.HeterogeneousEnvironment as HE
+import qualified Data.Attoparsec.Text as AP
+import Data.ByteString (ByteString)
+import qualified Data.HashMap.Strict as Map
+import qualified Data.HeterogeneousEnvironment as HE
+import Data.Map.Syntax
import Data.Maybe
-import qualified Data.Text as T
-import Data.Text (Text)
-import qualified Text.XmlHtml as X
-
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Text.XmlHtml as X
------------------------------------------------------------------------------
import Heist.Common
-import Heist.SpliceAPI
-import Heist.Types
+import Heist.Internal.Types.HeistState
+------------------------------------------------------------------------------
type Splice n = HeistT n n Template
@@ -48,9 +46,8 @@
bindSplices :: Splices (Splice n) -- ^ splices to bind
-> HeistState n -- ^ start state
-> HeistState n
-bindSplices ss hs = foldl' (flip id) hs acts
- where
- acts = map (uncurry bindSplice) $ splicesToList ss
+bindSplices ss hs =
+ hs { _spliceMap = applySpliceMap hs _spliceMap ss }
------------------------------------------------------------------------------
@@ -88,7 +85,7 @@
-> Splices b
-- ^ List of tuples to be bound
-> Splice n
-runChildrenWithTrans f = runChildrenWith . mapS f
+runChildrenWithTrans f = runChildrenWith . mapV f
------------------------------------------------------------------------------
@@ -195,7 +192,7 @@
runAttrSplice a@(k,v) = do
splice <- getsHS (Map.lookup k . _attrSpliceMap)
maybe (liftM (:[]) $ attSubst a)
- (lift . flip evalStateT HE.empty . unRT . ($v)) splice
+ (lift . flip evalStateT HE.empty . unRT . ($ v)) splice
------------------------------------------------------------------------------
@@ -288,9 +285,9 @@
,"<"++(T.unpack $ X.elementTag node)++">. You"
,"probably have infinite splice recursion!"
]
-
+
------------------------------------------------------------------------------
-- | Looks up a template name runs a 'HeistT' computation on it.
lookupAndRun :: Monad m
@@ -347,7 +344,7 @@
=> Splices Text
-> HeistState n
-> HeistState n
-bindStrings splices hs = foldr (uncurry bindString) hs $ splicesToList splices
+bindStrings splices = bindSplices (mapV textSplice splices)
------------------------------------------------------------------------------
@@ -381,7 +378,7 @@
=> ByteString -- ^ The name of the template
-> Splices Text -- ^ Splices to call the template with
-> HeistT n n Template
-callTemplateWithText name splices = callTemplate name $ mapS textSplice splices
+callTemplateWithText name splices = callTemplate name $ mapV textSplice splices
------------------------------------------------------------------------------
@@ -390,6 +387,10 @@
-- the root template was an HTML or XML format template. It will always be
-- @text/html@ or @text/xml@. If a more specific MIME type is needed for a
-- particular XML application, it must be provided by the application.
+--
+-- Note that template names should not include the .tpl extension:
+--
+-- @renderTemplate hs "index"@
renderTemplate :: Monad n
=> HeistState n
-> ByteString
@@ -414,3 +415,9 @@
renderWithArgs args hs = renderTemplate (bindStrings args hs)
+renderTemplateToDoc :: Monad n
+ => HeistState n
+ -> ByteString
+ -> n (Maybe X.Document)
+renderTemplateToDoc hs name =
+ evalHeistT (evalWithDoctypes name) (X.TextNode "") hs
diff --git a/src/Heist/SpliceAPI.hs b/src/Heist/SpliceAPI.hs
deleted file mode 100644
--- a/src/Heist/SpliceAPI.hs
+++ /dev/null
@@ -1,170 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
-{-|
-
-An API implementing a convenient syntax for defining and manipulating splices.
-This module was born from the observation that a list of tuples is
-semantically ambiguous about how duplicate keys should be handled.
-Additionally, the syntax is inherently rather cumbersome and difficult to work
-with. This API takes advantage of do notation to provide a very light syntax
-for defining splices while at the same time eliminating the semantic ambiguity
-of alists.
-
-Here's how you can define splices:
-
-> mySplices :: Splices Text
-> mySplices = do
-> "firstName" ## "John"
-> "lastName" ## "Smith"
-
--}
-
-module Heist.SpliceAPI where
-
-import Control.Applicative
-import Control.Monad.State (State, MonadState, execState, modify)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Monoid
-import Data.Text (Text)
-import qualified Data.Text as T
-
-
-------------------------------------------------------------------------------
--- | A monad providing convenient syntax for defining splices.
-newtype SplicesM s a = SplicesM { unSplices :: State (Map Text s) a }
- deriving (Functor, Applicative, Monad, MonadState (Map Text s))
-
-
-------------------------------------------------------------------------------
--- | Monoid instance does a union of the two maps with the second map
--- overwriting any duplicates.
-instance Monoid (Splices s) where
- mempty = noSplices
- mappend = unionWithS (\_ b -> b)
-
-
-------------------------------------------------------------------------------
--- | Convenient type alias that will probably be used most of the time.
-type Splices s = SplicesM s ()
-
-
-------------------------------------------------------------------------------
--- | Forces a splice to be added. If the key already exists, its value is
--- overwritten.
-(##) :: Text -> s -> Splices s
-(##) tag splice = modify $ M.insert tag splice
-infixr 0 ##
-
-
-------------------------------------------------------------------------------
--- | Tries to add a splice, but if the key already exists, then it throws an
--- error message. This may be useful if name collisions are bad and you want
--- to crash when they occur.
-(#!) :: Text -> s -> Splices s
-(#!) tag splice = modify $ M.insertWithKey err tag splice
- where
- err k _ _ = error $ "Key "++show k++" already exists in the splice map"
-infixr 0 #!
-
-
-------------------------------------------------------------------------------
--- | Inserts into the map only if the key does not already exist.
-(#?) :: Text -> s -> Splices s
-(#?) tag splice = modify $ M.insertWith (const id) tag splice
-infixr 0 #?
-
-
-------------------------------------------------------------------------------
--- | A `Splices` with nothing in it.
-noSplices :: Splices s
-noSplices = return ()
-
-
-------------------------------------------------------------------------------
--- | Runs the SplicesM monad, generating a map of splices.
-runSplices :: SplicesM s a -> Map Text s
-runSplices splices = execState (unSplices splices) M.empty
-
-
-------------------------------------------------------------------------------
--- | Constructs an alist representation.
-splicesToList :: SplicesM s a -> [(Text, s)]
-splicesToList = M.toList . runSplices
-
-
-------------------------------------------------------------------------------
--- | Internal helper function for adding a map.
-add :: Map Text s -> Splices s
-add m = modify (\s -> M.unionWith (\_ b -> b) s m)
-
-
-------------------------------------------------------------------------------
--- | Maps a function over all the splices.
-mapS :: (a -> b) -> Splices a -> Splices b
-mapS f ss = add $ M.map f $ runSplices ss
-
-
-------------------------------------------------------------------------------
--- | Applies an argument to a splice function.
-applyS :: a -> Splices (a -> b) -> Splices b
-applyS a = mapS ($a)
-
-
-------------------------------------------------------------------------------
--- | Inserts a splice into the 'Splices'.
-insertS :: Text -> s -> Splices s -> Splices s
-insertS = insertWithS const
-
-
-------------------------------------------------------------------------------
--- | Inserts a splice with a function combining new value and old value.
-insertWithS :: (s -> s -> s) -> Text -> s -> SplicesM s a2 -> SplicesM s ()
-insertWithS f k v b = add $ M.insertWith f k v (runSplices b)
-
-
-------------------------------------------------------------------------------
--- | Union of `Splices` with a combining function.
-unionWithS :: (s -> s -> s) -> SplicesM s a1 -> SplicesM s a2 -> SplicesM s ()
-unionWithS f a b = add $ M.unionWith f (runSplices a) (runSplices b)
-
-
-------------------------------------------------------------------------------
--- | Infix operator for @flip applyS@
-($$) :: Splices (a -> b) -> a -> Splices b
-($$) = flip applyS
-infixr 0 $$
-
-
-------------------------------------------------------------------------------
--- | Maps a function over all the splice names.
-mapNames :: (Text -> Text) -> Splices a -> Splices a
-mapNames f = add . M.mapKeys f . runSplices
-
-
--- The following two functions are formulated as functions of Splices instead
--- of a single splice because they operate on the splice names instead of the
--- splices themselves.
-
-
-------------------------------------------------------------------------------
--- | Adds a prefix to the tag names for a list of splices. If the existing
--- tag name is empty, then the new tag name is just the prefix. Otherwise the
--- new tag name is the prefix followed by the separator followed by the
--- existing name.
-prefixSplices :: Text -> Text -> Splices a -> Splices a
-prefixSplices sep pre = mapNames f
- where
- f t = if T.null t then pre else T.concat [pre,sep,t]
-
-
-------------------------------------------------------------------------------
--- | 'prefixSplices' specialized to use a colon as separator in the style of
--- XML namespaces.
-namespaceSplices :: Text -> Splices a -> Splices a
-namespaceSplices = prefixSplices ":"
-
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
@@ -18,7 +25,8 @@
import Heist.Splices.Html
import Heist.Splices.Ignore
import Heist.Splices.Markdown
-import Heist.Types
+import Heist.Internal.Types.HeistState
+import qualified Text.XmlHtml as X
------------------------------------------------------------------------------
-- | Run the splice contents if given condition is True, make splice disappear
@@ -47,3 +55,23 @@
else
return mempty
+
+------------------------------------------------------------------------------
+-- | Implements an if\/then\/else conditional splice. It splits its children
+-- around the \ 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
@@ -3,7 +3,6 @@
module Heist.Splices.Apply where
------------------------------------------------------------------------------
-import Control.Monad.Trans
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
@@ -13,7 +12,7 @@
------------------------------------------------------------------------------
import Heist.Common
import Heist.Interpreted.Internal
-import Heist.Types
+import Heist.Internal.Types.HeistState
------------------------------------------------------------------------------
@@ -55,7 +54,7 @@
(return []) `orError` err
where
err = "template recursion exceeded max depth, "++
- "you probably have infinite splice recursion!"
+ "you probably have infinite splice recursion!" :: String
treeMap :: [X.Node] -> X.Node -> [X.Node]
treeMap ns n@(X.Element nm _ cs)
| nm == paramTag = ns
@@ -68,7 +67,7 @@
------------------------------------------------------------------------------
-- | Applies a template as if the supplied nodes were the children of the
-- tag.
-applyNodes :: MonadIO n => Template -> Text -> Splice n
+applyNodes :: Monad n => Template -> Text -> Splice n
applyNodes nodes template = do
hs <- getHS
maybe (return [] `orError` err)
@@ -83,7 +82,7 @@
------------------------------------------------------------------------------
-- | Implementation of the apply splice.
-applyImpl :: MonadIO n => Splice n
+applyImpl :: Monad n => Splice n
applyImpl = do
node <- getParamNode
let err = "must supply \"" ++ T.unpack applyAttr ++
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
@@ -10,7 +9,7 @@
import Heist.Common
import Heist.Interpreted.Internal
import Heist.Splices.Apply
-import Heist.Types
+import Heist.Internal.Types.HeistState
-- | Default name for the bind splice.
bindTag :: Text
@@ -25,7 +24,7 @@
------------------------------------------------------------------------------
-- | Implementation of the bind splice.
-bindImpl :: MonadIO n => Splice n
+bindImpl :: Monad n => Splice n
bindImpl = do
node <- getParamNode
let err = "must supply \"" ++ T.unpack bindAttr ++
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
@@ -11,7 +10,7 @@
import Heist.Interpreted.Internal
import Heist.Splices.Apply
import Heist.Splices.Bind
-import Heist.Types
+import Heist.Internal.Types.HeistState
-- | Default name for the bind splice.
bindStrictTag :: Text
@@ -20,7 +19,7 @@
------------------------------------------------------------------------------
-- | Implementation of the bind splice.
-bindStrictImpl :: MonadIO n => Splice n
+bindStrictImpl :: Monad n => Splice n
bindStrictImpl = do
node <- getParamNode
cs <- runChildren
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,15 +36,17 @@
import qualified Data.Text as T
import Data.Text.Read
import Data.Time.Clock
-import Data.Word
import System.Random
import Text.XmlHtml
+#if !MIN_VERSION_base(4,8,0)
+import Data.Word (Word)
+#endif
------------------------------------------------------------------------------
import qualified Heist.Compiled.Internal as C
import Heist.Interpreted.Internal
-import Heist.Types
+import Heist.Internal.Types.HeistState
------------------------------------------------------------------------------
diff --git a/src/Heist/Splices/Html.hs b/src/Heist/Splices/Html.hs
--- a/src/Heist/Splices/Html.hs
+++ b/src/Heist/Splices/Html.hs
@@ -7,7 +7,7 @@
------------------------------------------------------------------------------
import Heist.Interpreted.Internal
-import Heist.Types
+import Heist.Internal.Types.HeistState
------------------------------------------------------------------------------
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,21 +13,27 @@
import Data.Aeson
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap as KM
+import qualified Data.Aeson.Key as K
+import qualified Data.Foldable.WithIndex as FI
+#else
import qualified Data.HashMap.Strict as Map
+#endif
+import Data.Map.Syntax
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as V
-import qualified Text.Blaze.Html5 as B
import Text.Blaze.Html5 ((!))
+import qualified Text.Blaze.Html5 as B
import Text.Blaze.Renderer.XmlHtml
import Text.XmlHtml
------------------------------------------------------------------------------
-
import Heist.Interpreted.Internal
-import Heist.SpliceAPI
-import Heist.Types
+import Heist.Internal.Types.HeistState
+------------------------------------------------------------------------------
------------
-- public --
@@ -88,7 +97,6 @@
numToText :: ToJSON a => a -> Text
numToText = T.decodeUtf8 . S.concat . L.toChunks . encode
-
------------------------------------------------------------------------------
findExpr :: Text -> Value -> Maybe Value
findExpr t = go (T.split (=='.') t)
@@ -96,10 +104,17 @@
go [] !value = Just value
go (x:xs) !value = findIn value >>= go xs
where
+#if MIN_VERSION_aeson(2,0,0)
+ findIn (Object obj) = KM.lookup (K.fromText x) obj
+#else
findIn (Object obj) = Map.lookup x obj
+#endif
+ findIn (Array arr) = tryReadIndex >>= \i -> arr V.!? i
findIn _ = Nothing
+ tryReadIndex = fmap fst . listToMaybe . reads . T.unpack $ x
+
------------------------------------------------------------------------------
asHtml :: Monad m => Text -> m [Node]
asHtml t =
@@ -149,7 +164,7 @@
------------------------------------------------------------------------------
-explodeTag :: (Monad n) => JsonMonad n n [Node]
+explodeTag :: forall n. (Monad n) => JsonMonad n n [Node]
explodeTag = ask >>= go
where
--------------------------------------------------------------------------
@@ -166,7 +181,7 @@
"snippet" ## asHtml t
--------------------------------------------------------------------------
- goArray :: (Monad n) => V.Vector Value -> JsonMonad n n [Node]
+ goArray :: V.Vector Value -> JsonMonad n n [Node]
goArray a = do
lift stopRecursion
dl <- V.foldM f id a
@@ -180,7 +195,7 @@
-- search the param node for attribute \"var=expr\", search the given JSON
-- object for the expression, and if it's found run the JsonMonad action m
-- using the restricted JSON object.
- varAttrTag :: (Monad m) => Value -> (JsonMonad m m [Node]) -> Splice m
+ varAttrTag :: Value -> (JsonMonad n n [Node]) -> Splice n
varAttrTag v m = do
node <- getParamNode
maybe (noVar node) (hasVar node) $ getAttribute "var" node
@@ -203,23 +218,33 @@
(findExpr expr v)
--------------------------------------------------------------------------
- genericBindings :: Monad n => JsonMonad n n (Splices (Splice n))
+ genericBindings :: JsonMonad n n (Splices (Splice n))
genericBindings = ask >>= \v -> return $ do
"with" ## varAttrTag v explodeTag
"snippet" ## varAttrTag v snippetTag
"value" ## varAttrTag v valueTag
-
+
--------------------------------------------------------------------------
goObject obj = do
start <- genericBindings
+#if MIN_VERSION_aeson(2,0,0)
+ let bindings = FI.ifoldl' (flip bindKvp) start obj
+#else
let bindings = Map.foldlWithKey' bindKvp start obj
+#endif
lift $ runChildrenWith bindings
--------------------------------------------------------------------------
+
bindKvp bindings k v =
- let newBindings = do
- T.append "with:" k ## withValue v explodeTag
- T.append "snippet:" k ## withValue v snippetTag
- T.append "value:" k ## withValue v valueTag
- in unionWithS (\a _ -> a) newBindings bindings
+#if MIN_VERSION_aeson(2,0,0)
+ let k' = K.toText k
+#else
+ let k' = k
+#endif
+ newBindings = do
+ T.append "with:" k' ## withValue v explodeTag
+ T.append "snippet:" k' ## withValue v snippetTag
+ T.append "value:" k' ## withValue v valueTag
+ in bindings >> newBindings
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.Internal.Types.HeistState
import Heist.Interpreted.Internal
-import Heist.Types
data PandocMissingException = PandocMissingException
deriving (Typeable)
instance Show PandocMissingException where
show PandocMissingException =
- "Cannot find the \"pandoc\" executable; is it on your $PATH?"
+ "Cannot find the \"pandoc\" executable. If you have Haskell, then install it with \"cabal install\". Otherwise you can download it from http://johnmacfarlane.net/pandoc/installing.html. Then make sure it is in your $PATH."
instance Exception PandocMissingException
@@ -68,69 +148,134 @@
instance Exception NoMarkdownFileException where
+--------------------------------------------------------------------------------
+
+data PandocOptions = PandocOptions
+ { _pandocExecutable :: FilePath
+ , _pandocArgs :: [String] -- ^ Arguments to pandoc
+ , _pandocBaseDir :: Maybe FilePath -- ^ Base directory for input files
+ -- defaults to template path
+ , _pandocWrapDiv :: Maybe Text -- ^ Wrap content in div with class
+ } deriving (Eq, Ord, Show)
+
+-- | Default options
+defaultPandocOptions :: PandocOptions
+defaultPandocOptions = PandocOptions "pandoc"
+ []
+ Nothing
+ (Just "markdown")
+
+-- | Name of pandoc executable
+setPandocExecutable :: FilePath -> PandocOptions -> PandocOptions
+setPandocExecutable e opt = opt { _pandocExecutable = e }
+
+-- | Arguments passed to pandoc
+setPandocArgs :: [String] -> PandocOptions -> PandocOptions
+setPandocArgs args opt = opt { _pandocArgs = args }
+
+-- | Base directory for input files, defaults to current template dir
+setPandocBaseDir :: Maybe FilePath -> PandocOptions -> PandocOptions
+setPandocBaseDir bd opt = opt { _pandocBaseDir = bd }
+
+-- | Wrap pandoc output in div with class. Appends node attributes to
+-- div and appends class to ones specified on node.
+setPandocWrapDiv :: Maybe Text -> PandocOptions -> PandocOptions
+setPandocWrapDiv wd opt = opt { _pandocWrapDiv = wd }
+
+pandocExecutable :: Functor f =>
+ (FilePath -> f FilePath) -> PandocOptions -> f PandocOptions
+pandocExecutable f po = (\e -> po { _pandocExecutable = e})
+ <$> f (_pandocExecutable po)
+
+pandocArgs :: Functor f =>
+ ([String] -> f [String]) -> PandocOptions -> f PandocOptions
+pandocArgs f po = (\a -> po { _pandocArgs = a}) <$> f (_pandocArgs po)
+
+pandocBaseDir :: Functor f =>
+ (Maybe FilePath -> f (Maybe FilePath)) -> PandocOptions -> f PandocOptions
+pandocBaseDir f po = (\b -> po {_pandocBaseDir = b }) <$> f (_pandocBaseDir po)
+
+pandocWrapDiv :: Functor f =>
+ (Maybe Text -> f (Maybe Text)) -> PandocOptions -> f PandocOptions
+pandocWrapDiv f po = (\w -> po {_pandocWrapDiv = w}) <$> f (_pandocWrapDiv po)
+
------------------------------------------------------------------------------
-- | Default name for the markdown splice.
markdownTag :: Text
markdownTag = "markdown"
------------------------------------------------------------------------------
--- | Implementation of the markdown splice.
+-- | Default markdown splice with executable "pandoc"
markdownSplice :: MonadIO m => Splice m
-markdownSplice = do
- templateDir <- liftM (fmap takeDirectory) getTemplateFilePath
- pdMD <- liftIO $ findExecutable "pandoc"
+markdownSplice= pandocSplice defaultPandocOptions
- when (isNothing pdMD) $ liftIO $ throwIO PandocMissingException
+-- | Implementation of the markdown splice.
+pandocSplice :: MonadIO m => PandocOptions -> Splice m
+pandocSplice PandocOptions{..} = do
+ templateDir <- liftM (fmap takeDirectory) getTemplateFilePath
+ pdMD <- liftIO $ findExecutable _pandocExecutable
+ pandocExe <- case pdMD of
+ Nothing -> liftIO $ throwIO PandocMissingException
+ Just pd -> return pd
+ let withDir tp = fromMaybe tp _pandocBaseDir
+ pandocFile f tp = pandocWith pandocExe _pandocArgs (withDir tp) f
tree <- getParamNode
(source,markup) <- liftIO $
case getAttribute "file" tree of
Just f -> do
m <- maybe (liftIO $ throwIO NoMarkdownFileException )
- (\tp -> pandoc (fromJust pdMD) tp $ T.unpack f)
+ (pandocFile (T.unpack f))
templateDir
return (T.unpack f,m)
Nothing -> do
- m <- pandocBS (fromJust pdMD) $ T.encodeUtf8 $ nodeText tree
+ m <- pandocWithBS pandocExe _pandocArgs $ T.encodeUtf8 $ nodeText tree
return ("inline_splice",m)
let ee = parseHTML source markup
+ nodeAttrs = case tree of
+ Element _ a _ -> a
+ _ -> []
+ nodeClass = lookup "class" nodeAttrs
+ attrs = filter (\(name, _) -> name /= "class" && name /= "file") nodeAttrs
case ee of
Left e -> throw $ MarkdownException
$ BC.pack ("Error parsing markdown output: " ++ e)
- Right d -> return (docContent d)
+ Right d -> return $ wrapResult nodeClass attrs (docContent d)
+ where
+ wrapResult nodeClass attrs body = case _pandocWrapDiv of
+ Nothing -> body
+ Just cls -> let finalAttrs = ("class", appendClass nodeClass cls):attrs
+ in [Element "div" finalAttrs body]
+ appendClass Nothing cls = cls
+ appendClass (Just orig) cls = T.concat [orig, " ", cls]
-pandoc :: FilePath -> FilePath -> FilePath -> IO ByteString
-pandoc pandocPath templateDir inputFile = do
- (ex, sout, serr) <- readProcessWithExitCode' pandocPath args ""
+pandocWith :: FilePath -> [String] -> FilePath -> FilePath -> IO ByteString
+pandocWith path args templateDir inputFile = do
+ (ex, sout, serr) <- readProcessWithExitCode' path args' ""
+
when (isFail ex) $ throw $ MarkdownException serr
- return $ BC.concat [ "
\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
@@ -17,10 +17,10 @@
------------------------------------------------------------------------------
import Control.Concurrent
-import Control.Error
import Control.Monad
import Control.Monad.Trans
import Heist
+import Heist.Internal.Types
import Heist.Splices.Cache
@@ -37,27 +37,34 @@
------------------------------------------------------------------------------
-- | Creates and returns a new 'TemplateDirectory' wrapped in an Either for
-- error handling.
-newTemplateDirectory :: MonadIO n
- => FilePath
- -> HeistConfig n
- -> EitherT [String] IO (TemplateDirectory n)
+newTemplateDirectory
+ :: MonadIO n
+ => FilePath
+ -> HeistConfig n
+ -- namespaced tag.
+ -> IO (Either [String] (TemplateDirectory n))
newTemplateDirectory dir hc = do
- let hc' = hc { hcTemplateLocations = [loadTemplates dir] }
- (hs,cts) <- initHeistWithCacheTag hc'
- tsMVar <- liftIO $ newMVar hs
- ctsMVar <- liftIO $ newMVar cts
- return $ TemplateDirectory dir hc' tsMVar ctsMVar
+ let sc = (_hcSpliceConfig hc) { _scTemplateLocations = [loadTemplates dir] }
+ let hc' = hc { _hcSpliceConfig = sc }
+ epair <- initHeistWithCacheTag hc'
+ case epair of
+ Left es -> return $ Left es
+ Right (hs,cts) -> do
+ tsMVar <- liftIO $ newMVar hs
+ ctsMVar <- liftIO $ newMVar cts
+ return $ Right $ TemplateDirectory dir hc' tsMVar ctsMVar
------------------------------------------------------------------------------
-- | Creates and returns a new 'TemplateDirectory', using the monad's fail
-- function on error.
-newTemplateDirectory' :: MonadIO n
- => FilePath
- -> HeistConfig n
- -> IO (TemplateDirectory n)
+newTemplateDirectory'
+ :: MonadIO n
+ => FilePath
+ -> HeistConfig n
+ -> IO (TemplateDirectory n)
newTemplateDirectory' dir hc = do
- res <- runEitherT $ newTemplateDirectory dir hc
+ res <- newTemplateDirectory dir hc
either (error . concat) return res
@@ -82,8 +89,8 @@
=> TemplateDirectory n
-> IO (Either String ())
reloadTemplateDirectory (TemplateDirectory p hc tsMVar ctsMVar) = do
- ehs <- runEitherT $ do
- initHeistWithCacheTag (hc { hcTemplateLocations = [loadTemplates p] })
+ let sc = (_hcSpliceConfig hc) { _scTemplateLocations = [loadTemplates p] }
+ ehs <- initHeistWithCacheTag (hc { _hcSpliceConfig = sc })
leftPass ehs $ \(hs,cts) -> do
modifyMVar_ tsMVar (const $ return hs)
modifyMVar_ ctsMVar (const $ return cts)
@@ -95,4 +102,4 @@
leftPass e m = either (return . Left . loadError . concat)
(liftM Right . m) e
where
- loadError = (++) "Error loading templates: "
+ loadError = (++) ("Error loading templates: " :: String)
diff --git a/src/Heist/Types.hs b/src/Heist/Types.hs
deleted file mode 100644
--- a/src/Heist/Types.hs
+++ /dev/null
@@ -1,528 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-{-|
-
-This module contains the core Heist data types.
-
-Edward Kmett wrote most of the HeistT monad code and associated instances,
-liberating us from the unused writer portion of RWST.
-
--}
-
-module Heist.Types where
-
-------------------------------------------------------------------------------
-import Blaze.ByteString.Builder
-import Control.Applicative
-import Control.Arrow
-import Control.Monad.CatchIO (MonadCatchIO)
-import qualified Control.Monad.CatchIO as C
-import Control.Monad.Cont
-import Control.Monad.Error
-import Control.Monad.Reader
-import Control.Monad.State.Strict
-import Data.ByteString.Char8 (ByteString)
-import Data.DList (DList)
-import qualified Data.HashMap.Strict as H
-import Data.HashMap.Strict (HashMap)
-import Data.HeterogeneousEnvironment (HeterogeneousEnvironment)
-import qualified Data.HeterogeneousEnvironment as HE
-import Data.Monoid
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Text.Encoding
-import Data.Typeable
-import qualified Text.XmlHtml as X
-
-import Debug.Trace
-
-tr :: Show a => String -> a -> a
-tr s x = trace (s++show x) x
-
-------------------------------------------------------------------------------
--- | A 'Template' is a forest of XML nodes. Here we deviate from the \"single
--- root node\" constraint of well-formed XML because we want to allow
--- templates to contain document fragments that may not have a single root.
-type Template = [X.Node]
-
-
-------------------------------------------------------------------------------
--- | MIME Type. The type alias is here to make the API clearer.
-type MIMEType = ByteString
-
-
-------------------------------------------------------------------------------
--- | Reversed list of directories. This holds the path to the template
--- currently being processed.
-type TPath = [ByteString]
-
-
-------------------------------------------------------------------------------
--- | Holds data about templates read from disk.
-data DocumentFile = DocumentFile
- { dfDoc :: X.Document
- , dfFile :: Maybe FilePath
- } deriving ( Eq
-#if MIN_VERSION_base(4,7,0)
- , Typeable
-#endif
- )
-
-
-------------------------------------------------------------------------------
--- | Designates whether a document should be treated as XML or HTML.
-data Markup = Xml | Html
-
-
-------------------------------------------------------------------------------
--- | Monad used for runtime splice execution.
-newtype RuntimeSplice m a = RuntimeSplice {
- unRT :: StateT HeterogeneousEnvironment m a
- } deriving ( Applicative
- , Functor
- , Monad
- , MonadIO
- , MonadState HeterogeneousEnvironment
- , MonadTrans
-#if MIN_VERSION_base(4,7,0)
- , Typeable
-#endif
- )
-
-
-------------------------------------------------------------------------------
-instance (Monad m, Monoid a) => Monoid (RuntimeSplice m a) where
- mempty = return mempty
-
- a `mappend` b = do
- !x <- a
- !y <- b
- return $! x `mappend` y
-
-
-------------------------------------------------------------------------------
--- | Opaque type representing pieces of output from compiled splices.
-data Chunk m = Pure !ByteString
- -- ^ output known at load time
- | RuntimeHtml !(RuntimeSplice m Builder)
- -- ^ output computed at run time
- | RuntimeAction !(RuntimeSplice m ())
- -- ^ runtime action used only for its side-effect
-#if MIN_VERSION_base(4,7,0)
- deriving Typeable
-#endif
-
-instance Show (Chunk m) where
- show (Pure _) = "Pure"
- show (RuntimeHtml _) = "RuntimeHtml"
- show (RuntimeAction _) = "RuntimeAction"
-
-
-showChunk :: Chunk m -> String
-showChunk (Pure b) = T.unpack $ decodeUtf8 b
-showChunk (RuntimeHtml _) = "RuntimeHtml"
-showChunk (RuntimeAction _) = "RuntimeAction"
-
-
-isPureChunk :: Chunk m -> Bool
-isPureChunk (Pure _) = True
-isPureChunk _ = False
-
-
-------------------------------------------------------------------------------
--- | Type alias for attribute splices. The function parameter is the value of
--- the bound attribute splice. The return value is a list of attribute
--- key/value pairs that get substituted in the place of the bound attribute.
-type AttrSplice m = Text -> RuntimeSplice m [(Text, Text)]
-
-
-------------------------------------------------------------------------------
--- | Holds all the state information needed for template processing. You will
--- build a @HeistState@ using 'initHeist' and any of Heist's @HeistState ->
--- HeistState@ \"filter\" functions. Then you use the resulting @HeistState@
--- in calls to 'renderTemplate'.
---
--- m is the runtime monad
-data HeistState m = HeistState {
- -- | A mapping of splice names to splice actions
- _spliceMap :: HashMap Text (HeistT m m Template)
- -- | A mapping of template names to templates
- , _templateMap :: HashMap TPath DocumentFile
-
- -- | A mapping of splice names to splice actions
- , _compiledSpliceMap :: HashMap Text (HeistT m IO (DList (Chunk m)))
- -- | A mapping of template names to templates
- --, _compiledTemplateMap :: HashMap TPath (m Builder, MIMEType)
- , _compiledTemplateMap :: !(HashMap TPath ([Chunk m], MIMEType))
-
- , _attrSpliceMap :: HashMap Text (AttrSplice m)
-
- -- | A flag to control splice recursion
- , _recurse :: Bool
- -- | The path to the template currently being processed.
- , _curContext :: TPath
- -- | A counter keeping track of the current recursion depth to prevent
- -- infinite loops.
- , _recursionDepth :: Int
- -- | The doctypes encountered during template processing.
- , _doctypes :: [X.DocType]
- -- | The full path to the current template's file on disk.
- , _curTemplateFile :: Maybe FilePath
- -- | A key generator used to produce new unique Promises.
- , _keygen :: HE.KeyGen
-
- -- | Flag indicating whether we're in preprocessing mode. During
- -- preprocessing, errors should stop execution and be reported. During
- -- template rendering, it's better to skip the errors and render the page.
- , _preprocessingMode :: Bool
-
- -- | This is needed because compiled templates are generated with a bunch
- -- of calls to renderFragment rather than a single call to render.
- , _curMarkup :: Markup
-#if MIN_VERSION_base(4,7,0)
-} deriving (Typeable)
-#else
-}
-#endif
-
-#if !MIN_VERSION_base(4,7,0)
--- NOTE: We got rid of the Monoid instance because it is absolutely not safe
--- to combine two compiledTemplateMaps. All compiled templates must be known
--- at load time and processed in a single call to initHeist/loadTemplates or
--- whatever we end up calling it..
-
-instance (Typeable1 m) => Typeable (HeistState m) where
- typeOf _ = mkTyConApp templateStateTyCon [typeOf1 (undefined :: m ())]
-
-#endif
-
-------------------------------------------------------------------------------
--- | HeistT is the monad transformer used for splice processing. HeistT
--- intentionally does not expose any of its functionality via MonadState or
--- MonadReader functions. We define passthrough instances for the most common
--- types of monads. These instances allow the user to use HeistT in a monad
--- stack without needing calls to `lift`.
---
--- @n@ is the runtime monad (the parameter to HeistState).
---
--- @m@ is the monad being run now. In this case, \"now\" is a variable
--- concept. The type @HeistT n n@ means that \"now\" is runtime. The type
--- @HeistT n IO@ means that \"now\" is @IO@, and more importantly it is NOT
--- runtime. In Heist, the rule of thumb is that @IO@ means load time and @n@
--- means runtime.
-newtype HeistT n m a = HeistT {
- runHeistT :: X.Node
- -> HeistState n
- -> m (a, HeistState n)
-#if MIN_VERSION_base(4,7,0)
-} deriving Typeable
-#else
-}
-#endif
-
-
-------------------------------------------------------------------------------
--- | Gets the names of all the templates defined in a HeistState.
-templateNames :: HeistState m -> [TPath]
-templateNames ts = H.keys $ _templateMap ts
-
-
-------------------------------------------------------------------------------
--- | Gets the names of all the templates defined in a HeistState.
-compiledTemplateNames :: HeistState m -> [TPath]
-compiledTemplateNames ts = H.keys $ _compiledTemplateMap ts
-
-
-------------------------------------------------------------------------------
--- | Gets the names of all the interpreted splices defined in a HeistState.
-spliceNames :: HeistState m -> [Text]
-spliceNames ts = H.keys $ _spliceMap ts
-
-
-------------------------------------------------------------------------------
--- | Gets the names of all the compiled splices defined in a HeistState.
-compiledSpliceNames :: HeistState m -> [Text]
-compiledSpliceNames ts = H.keys $ _compiledSpliceMap ts
-
-
-#if !MIN_VERSION_base(4,7,0)
-------------------------------------------------------------------------------
--- | The Typeable instance is here so Heist can be dynamically executed with
--- Hint.
-templateStateTyCon :: TyCon
-templateStateTyCon = mkTyCon "Heist.HeistState"
-{-# NOINLINE templateStateTyCon #-}
-#endif
-
-
-------------------------------------------------------------------------------
--- | Evaluates a template monad as a computation in the underlying monad.
-evalHeistT :: (Monad m)
- => HeistT n m a
- -> X.Node
- -> HeistState n
- -> m a
-evalHeistT m r s = do
- (a, _) <- runHeistT m r s
- return a
-{-# INLINE evalHeistT #-}
-
-
-------------------------------------------------------------------------------
--- | Functor instance
-instance Functor m => Functor (HeistT n m) where
- fmap f (HeistT m) = HeistT $ \r s -> first f <$> m r s
-
-
-------------------------------------------------------------------------------
--- | Applicative instance
-instance (Monad m, Functor m) => Applicative (HeistT n m) where
- pure = return
- (<*>) = ap
-
-
-------------------------------------------------------------------------------
--- | Monad instance
-instance Monad m => Monad (HeistT n m) where
- return a = HeistT (\_ s -> return (a, s))
- {-# INLINE return #-}
- HeistT m >>= k = HeistT $ \r s -> do
- (a, s') <- m r s
- runHeistT (k a) r s'
- {-# INLINE (>>=) #-}
-
-
-------------------------------------------------------------------------------
--- | MonadIO instance
-instance MonadIO m => MonadIO (HeistT n m) where
- liftIO = lift . liftIO
-
-
-------------------------------------------------------------------------------
--- | MonadTrans instance
-instance MonadTrans (HeistT n) where
- lift m = HeistT $ \_ s -> do
- a <- m
- return (a, s)
-
-
-------------------------------------------------------------------------------
--- | MonadCatchIO instance
-instance MonadCatchIO m => MonadCatchIO (HeistT n m) where
- catch (HeistT a) h = HeistT $ \r s -> do
- let handler e = runHeistT (h e) r s
- C.catch (a r s) handler
- block (HeistT m) = HeistT $ \r s -> C.block (m r s)
- unblock (HeistT m) = HeistT $ \r s -> C.unblock (m r s)
-
-
-------------------------------------------------------------------------------
--- | MonadFix passthrough instance
-instance MonadFix m => MonadFix (HeistT n m) where
- mfix f = HeistT $ \r s ->
- mfix $ \ (a, _) -> runHeistT (f a) r s
-
-
-------------------------------------------------------------------------------
--- | Alternative passthrough instance
-instance (Functor m, MonadPlus m) => Alternative (HeistT n m) where
- empty = mzero
- (<|>) = mplus
-
-
-------------------------------------------------------------------------------
--- | MonadPlus passthrough instance
-instance MonadPlus m => MonadPlus (HeistT n m) where
- mzero = lift mzero
- m `mplus` n = HeistT $ \r s ->
- runHeistT m r s `mplus` runHeistT n r s
-
-
-------------------------------------------------------------------------------
--- | MonadState passthrough instance
-instance MonadState s m => MonadState s (HeistT n m) where
- get = lift get
- {-# INLINE get #-}
- put = lift . put
- {-# INLINE put #-}
-
-
-------------------------------------------------------------------------------
--- | MonadReader passthrough instance
-instance MonadReader r m => MonadReader r (HeistT n m) where
- ask = HeistT $ \_ s -> do
- r <- ask
- return (r,s)
- local f (HeistT m) =
- HeistT $ \r s -> local f (m r s)
-
-
-------------------------------------------------------------------------------
--- | Helper for MonadError instance.
-liftCatch :: (m (a,HeistState n)
- -> (e -> m (a,HeistState n))
- -> m (a,HeistState n))
- -> HeistT n m a
- -> (e -> HeistT n m a)
- -> HeistT n m a
-liftCatch ce m h =
- HeistT $ \r s ->
- (runHeistT m r s `ce`
- (\e -> runHeistT (h e) r s))
-
-
-------------------------------------------------------------------------------
--- | MonadError passthrough instance
-instance (MonadError e m) => MonadError e (HeistT n m) where
- throwError = lift . throwError
- catchError = liftCatch catchError
-
-
-------------------------------------------------------------------------------
--- | Helper for MonadCont instance.
-liftCallCC :: ((((a,HeistState n) -> m (b, HeistState n))
- -> m (a, HeistState n))
- -> m (a, HeistState n))
- -> ((a -> HeistT n m b) -> HeistT n m a)
- -> HeistT n m a
-liftCallCC ccc f = HeistT $ \r s ->
- ccc $ \c ->
- runHeistT (f (\a -> HeistT $ \_ _ -> c (a, s))) r s
-
-
-------------------------------------------------------------------------------
--- | MonadCont passthrough instance
-instance (MonadCont m) => MonadCont (HeistT n m) where
- callCC = liftCallCC callCC
-
-
-#if !MIN_VERSION_base(4,7,0)
-------------------------------------------------------------------------------
--- | The Typeable instance is here so Heist can be dynamically executed with
--- Hint.
-templateMonadTyCon :: TyCon
-templateMonadTyCon = mkTyCon "Heist.HeistT"
-{-# NOINLINE templateMonadTyCon #-}
-
-instance (Typeable1 m) => Typeable1 (HeistT n m) where
- typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())]
-#endif
-
-
-------------------------------------------------------------------------------
--- Functions for our monad.
-------------------------------------------------------------------------------
-
-
-------------------------------------------------------------------------------
--- | Gets the node currently being processed.
---
--- >
--- > To sleep, perchance to dream.
--- >
---
--- When you call @getParamNode@ inside the code for the @speech@ splice, it
--- returns the Node for the @speech@ tag and its children. @getParamNode >>=
--- childNodes@ returns a list containing one 'TextNode' containing part of
--- Hamlet's speech. @liftM (getAttribute \"author\") getParamNode@ would
--- return @Just "Shakespeare"@.
-getParamNode :: Monad m => HeistT n m X.Node
-getParamNode = HeistT $ curry return
-{-# INLINE getParamNode #-}
-
-
-------------------------------------------------------------------------------
--- | HeistT's 'local'.
-localParamNode :: Monad m
- => (X.Node -> X.Node)
- -> HeistT n m a
- -> HeistT n m a
-localParamNode f m = HeistT $ \r s -> runHeistT m (f r) s
-{-# INLINE localParamNode #-}
-
-
-------------------------------------------------------------------------------
--- | HeistT's 'gets'.
-getsHS :: Monad m => (HeistState n -> r) -> HeistT n m r
-getsHS f = HeistT $ \_ s -> return (f s, s)
-{-# INLINE getsHS #-}
-
-
-------------------------------------------------------------------------------
--- | HeistT's 'get'.
-getHS :: Monad m => HeistT n m (HeistState n)
-getHS = HeistT $ \_ s -> return (s, s)
-{-# INLINE getHS #-}
-
-
-------------------------------------------------------------------------------
--- | HeistT's 'put'.
-putHS :: Monad m => HeistState n -> HeistT n m ()
-putHS s = HeistT $ \_ _ -> return ((), s)
-{-# INLINE putHS #-}
-
-
-------------------------------------------------------------------------------
--- | HeistT's 'modify'.
-modifyHS :: Monad m
- => (HeistState n -> HeistState n)
- -> HeistT n m ()
-modifyHS f = HeistT $ \_ s -> return ((), f s)
-{-# INLINE modifyHS #-}
-
-
-------------------------------------------------------------------------------
--- | Restores the HeistState. This function is almost like putHS except it
--- preserves the current doctypes. You should use this function instead of
--- @putHS@ to restore an old state. This was needed because doctypes needs to
--- be in a "global scope" as opposed to the template call "local scope" of
--- state items such as recursionDepth, curContext, and spliceMap.
-restoreHS :: Monad m => HeistState n -> HeistT n m ()
-restoreHS old = modifyHS (\cur -> old { _doctypes = _doctypes cur })
-{-# INLINE restoreHS #-}
-
-
-------------------------------------------------------------------------------
--- | Abstracts the common pattern of running a HeistT computation with
--- a modified heist state.
-localHS :: Monad m
- => (HeistState n -> HeistState n)
- -> HeistT n m a
- -> HeistT n m a
-localHS f k = do
- ts <- getHS
- putHS $ f ts
- res <- k
- restoreHS ts
- return res
-{-# INLINE localHS #-}
-
-
-------------------------------------------------------------------------------
--- | Modifies the recursion depth.
-modRecursionDepth :: Monad m => (Int -> Int) -> HeistT n m ()
-modRecursionDepth f =
- modifyHS (\st -> st { _recursionDepth = f (_recursionDepth st) })
-
-
-------------------------------------------------------------------------------
--- | AST to hold attribute parsing structure. This is necessary because
--- attoparsec doesn't support parsers running in another monad.
-data AttAST = Literal Text
- | Ident Text
- deriving (Show)
-
-
-------------------------------------------------------------------------------
-isIdent :: AttAST -> Bool
-isIdent (Ident _) = True
-isIdent _ = False
-
-
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,97 +0,0 @@
-name: heist-testsuite
-version: 0.1.1
-build-type: Simple
-cabal-version: >= 1.6
-
-Executable testsuite
- hs-source-dirs: ../src suite
- main-is: TestSuite.hs
-
- build-depends:
- HUnit >= 1.2 && < 2,
- QuickCheck >= 2 && < 2.8,
- MonadCatchIO-transformers >= 0.2.1 && < 0.4,
- test-framework >= 0.4 && < 0.9,
- test-framework-hunit >= 0.2.7 && < 0.4,
- test-framework-quickcheck2 >= 0.2.12.1 && < 0.4,
- aeson >= 0.6 && < 0.8,
- attoparsec >= 0.10 && < 0.13,
- base >= 4 && < 5,
- blaze-builder >= 0.2 && < 0.4,
- blaze-html >= 0.4 && < 0.8,
- bytestring >= 0.9 && < 0.11,
- containers >= 0.2 && < 0.6,
- directory >= 1.1 && < 1.3,
- directory-tree >= 0.10 && < 0.13,
- dlist >= 0.5 && < 0.8,
- errors >= 1.4 && < 1.5,
- filepath >= 1.3 && < 1.4,
- hashable >= 1.1 && < 1.3,
- mtl >= 2.0 && < 2.2,
- process >= 1.1 && < 1.3,
- random >= 1.0.1.0 && < 1.1,
- text >= 0.10 && < 1.2,
- time >= 1.1 && < 1.5,
- transformers >= 0.2 && < 0.4,
- unordered-containers >= 0.1.4 && < 0.3,
- vector >= 0.9 && < 0.11,
- xmlhtml >= 0.2.3 && < 0.3
-
-
- ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded
- Extensions: OverloadedStrings
-
-Executable benchmark
- hs-source-dirs: ../src suite
- main-is: Benchmark.hs
-
- build-depends:
- MonadCatchIO-transformers >= 0.3 && < 0.4,
- HUnit >= 1.2 && < 1.3,
- criterion >= 0.6 && < 0.9,
- test-framework >= 0.4 && < 0.9,
- test-framework-hunit >= 0.2 && < 0.4,
-
- -- Copied from regular dependencies:
-
- aeson >= 0.6 && < 0.8,
- attoparsec >= 0.10 && < 0.13,
- base >= 4 && < 5,
- blaze-builder >= 0.2 && < 0.4,
- blaze-html >= 0.4 && < 0.8,
- bytestring >= 0.9 && < 0.11,
- containers >= 0.2 && < 0.6,
- directory >= 1.1 && < 1.3,
- directory-tree >= 0.10 && < 0.13,
- dlist >= 0.5 && < 0.8,
- errors >= 1.4 && < 1.5,
- filepath >= 1.3 && < 1.4,
- hashable >= 1.1 && < 1.3,
- mtl >= 2.0 && < 2.2,
- process >= 1.1 && < 1.3,
- random >= 1.0.1.0 && < 1.1,
- statistics >= 0.11 && < 0.12,
- text >= 0.10 && < 1.2,
- time >= 1.1 && < 1.5,
- transformers >= 0.2 && < 0.4,
- unordered-containers >= 0.1.4 && < 0.3,
- vector >= 0.9 && < 0.11,
- xmlhtml >= 0.2.3 && < 0.3
-
- ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded
- -fno-warn-unused-do-bind -rtsopts
-
- ghc-prof-options: -prof -auto-all
-
- Extensions:
- GeneralizedNewtypeDeriving,
- PackageImports,
- ScopedTypeVariables,
- DeriveDataTypeable,
- FlexibleInstances,
- MultiParamTypeClasses,
- UndecidableInstances,
- OverloadedStrings,
- TypeSynonymInstances,
- NoMonomorphismRestriction
-
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 <\n
3
"
+ mappend doctype "\n\n\n3\n\n"
peopleTest :: IO ()
peopleTest = do
@@ -35,5 +73,337 @@
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
+ where
+ sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices
+ & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu"))
+ & scTemplateLocations .~ [loadTemplates "templates"]
+
+genericTest :: String -> ByteString -> ByteString -> IO ()
+genericTest nm template expected = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist templateHC
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs template
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual nm (Right expected) res
+
+doctypeTest :: IO ()
+doctypeTest = genericTest "doctype test" "rss" expected
+ where
+ expected = encodeUtf8
+ "http://www.devalot.com/\n"
+
+namespaceTest1 :: IO ()
+namespaceTest1 = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist templateHC
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "namespaces"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual "namespace test 1" (Right expected) res
+ where
+ expected = "Alpha\naoeu\nBeta\nInside h:foo\nEnd\n"
+
+
+namespaceTest2 :: IO ()
+namespaceTest2 = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist $ templateHC & hcErrorNotBound .~ True
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "namespaces"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual "namespace test 2" (Right expected) res
+ where
+ expected = "Alpha\naoeu\nBeta\nInside h:foo\nEnd\n"
+
+
+namespaceTest3 :: IO ()
+namespaceTest3 = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "namespaces"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual "namespace test 3" (Right expected) res
+ where
+ expected = "Alpha\nInside foo\nBeta\naoeu\nEnd\n"
+
+
+namespaceTest4 :: IO ()
+namespaceTest4 = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"
+ & hcErrorNotBound .~ True
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "namespaces"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual "namespace test 4" (Right expected) res
+ where
+ expected = "Alpha\nInside foo\nBeta\naoeu\nEnd\n"
+
+
+namespaceTest5 :: IO ()
+namespaceTest5 = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"
+ & hcCompiledSplices .~ mempty
+ & hcErrorNotBound .~ True
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "namespaces"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual "namespace test 5" (Left ["templates/namespaces.tpl: No splice bound for h:foo"]) res
+
+------------------------------------------------------------------------------
+-- | The templates-no-ns directory should have no tags beginning with h: so
+-- this test will throw an error.
+noNsSplices :: IO ()
+noNsSplices = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist hc
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "test"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual "noNsSplices" (Left [noNamespaceSplicesMsg "h:"]) res
+ where
+ hc = HeistConfig sc "h" True
+ sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices
+ & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu"))
+ & scTemplateLocations .~ [loadTemplates "templates-no-ns"]
+
+
+------------------------------------------------------------------------------
+-- | Test that no namespace splice message works correctly when there are no
+-- top level splices used
+nsNestedUnused :: IO ()
+nsNestedUnused = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist hc
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "test"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual "ns nested unused warn test" (Right "
aeou
\n") res
+ where
+ hc = HeistConfig sc "h" False
+ sc = mempty & scCompiledSplices .~ ("foo" ## return $ yieldPureText "aeou")
+ & scTemplateLocations .~ [loadTemplates "templates-ns-nested"]
+
+
+nsBindTemplateHC :: String -> HeistConfig IO
+nsBindTemplateHC dir = HeistConfig sc "h" False
+ where
+ sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices
+ & scCompiledSplices .~ nsBindTestSplices
+ & scTemplateLocations .~ [loadTemplates dir]
+
+
+nsBindTestSplices :: Splices (Splice IO)
+nsBindTestSplices = do
+ "call" ## do
+ tpl <- withSplices (callTemplate "_call")
+ nsBindSubSplices (return ())
+ return $ yieldRuntime $ codeGen tpl
+ "main" ## nsBindSubImpl (return ())
+ "main2" ## nsBindSubImpl (return ())
+
+
+nsBindSubImpl :: RuntimeSplice IO b -> Splice IO
+nsBindSubImpl _ = do
+ tpl <- withSplices runChildren nsBindSubSplices (return ())
+ return $ yieldRuntime $ codeGen tpl
+
+
+nsBindSubSplices :: Splices (RuntimeSplice IO () -> Splice IO)
+nsBindSubSplices = do
+ "sub" ## pureSplice . textSplice $ const "asdf"
+ "recurse" ## nsBindSubImpl
+
+
+nsBindTest :: IO ()
+nsBindTest = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind")
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "nsbind"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual "namespace bind test" (Right expected) res
+ where
+ expected = "Alpha\n\nBeta\nasdf\nGamma\n\n\n"
+
+
+------------------------------------------------------------------------------
+-- | Test splice error reporting.
+nsBindErrorTest :: IO ()
+nsBindErrorTest = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind")
+ & hcErrorNotBound .~ True
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "nsbinderror"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual "namespace bind error test" (Left [ err1, err2, err3 ]) res
+ where
+ err1 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid3\n ... via templates-nsbind/nsbinderror.tpl: h:main2\nBound splices: h:call h:main h:main2 h:recurse h:sub\nNode: Element {elementTag = \"h:invalid3\", elementAttrs = [], elementChildren = []}"
+ err2 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid2\n ... via templates-nsbind/nsbinderror.tpl: h:recurse\n ... via templates-nsbind/nsbinderror.tpl: h:main\nBound splices: h:call h:main h:main2 h:recurse h:sub\nNode: Element {elementTag = \"h:invalid2\", elementAttrs = [], elementChildren = []}"
+ err3 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid1\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:invalid1\", elementAttrs = [], elementChildren = []}"
+
+
+------------------------------------------------------------------------------
+-- | Test splice error data structure.
+nsBindStackTest :: IO ()
+nsBindStackTest = do
+ res <- initHeist (nsBindTemplateHC "templates-nsbind") >>=
+ return . (either Left (Right . _spliceErrors))
+
+ H.assertEqual "namespace bind stack test" (Right [ err1, err2, err3 ]) res
+ where
+ err1 = SpliceError [ ( ["nsbinderror"]
+ , Just "templates-nsbind/nsbinderror.tpl"
+ , "h:main2") ]
+ (Just "templates-nsbind/nsbinderror.tpl")
+ ["h:call","h:main","h:main2","h:recurse","h:sub"]
+ (X.Element "h:invalid3" [] [])
+ "No splice bound for h:invalid3"
+ err2 = SpliceError [ ( ["nsbinderror"]
+ , Just "templates-nsbind/nsbinderror.tpl"
+ , "h:recurse")
+ , ( ["nsbinderror"]
+ , Just "templates-nsbind/nsbinderror.tpl"
+ ,"h:main") ]
+ (Just "templates-nsbind/nsbinderror.tpl")
+ ["h:call","h:main","h:main2","h:recurse","h:sub"]
+ (X.Element "h:invalid2" [] [])
+ "No splice bound for h:invalid2"
+ err3 = SpliceError []
+ (Just "templates-nsbind/nsbinderror.tpl")
+ ["h:call","h:main","h:main2"]
+ (X.Element "h:invalid1" [] [])
+ "No splice bound for h:invalid1"
+
+
+nsCallTest :: IO ()
+nsCallTest = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall")
+ & hcErrorNotBound .~ True
+ & hcCompiledTemplateFilter .~ nsFilter
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "nscall"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual "namespace call test" (Right "Top\n\nInside 1\nCalled\nasdf\n\nInside 2\n\n") res
+ where
+ nsFilter = (/=) (fromIntegral $ ord '_') . B.head . head
+
+
+nsCallErrTest :: IO ()
+nsCallErrTest = do
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall")
+ & hcErrorNotBound .~ True
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "nscall"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ H.assertEqual "namespace call error test"
+ (Left $ Set.fromList [ err1, err2 ])
+ (first Set.fromList res)
+ where
+ err1 = "templates-nscall/_call.tpl: No splice bound for h:sub\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:sub\", elementAttrs = [], elementChildren = []}"
+ err2 = "templates-nscall/_invalid.tpl: No splice bound for h:invalid\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:invalid\", elementAttrs = [], elementChildren = []}"
+
+
+------------------------------------------------------------------------------
+-- | Test exception handling in template load.
+exceptionsTest :: IO ()
+exceptionsTest = do
+ res <- Control.Exception.catch
+ (runExceptT $ do
+ hs <- ExceptT $ initHeist hc
+ -- The rest needed only for type inference.
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs ""
+ _ <- lift $ fst runner
+ throwE ["Unexpected success"])
+ (\(e :: CompileException) -> return $ case lines (show e) of
+ l:ls -> Right l
+ _ -> Left [show e])
+ H.assertEqual "exceptions" (Right firstLine) res
+
+ where
+ firstLine = "templates-loaderror/_error.tpl: Exception in splice compile: Prelude.read: no parse"
+
+ hc = HeistConfig sc "h" True
+ sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices
+ & scCompiledSplices .~ splices
+ & scTemplateLocations .~ [loadTemplates "templates-loaderror"]
+ splices = do
+ "call1" ## callTemplate "_ok"
+ "call2" ## callTemplate "_error"
+ "adder" ## do
+ value :: Int <- read . T.unpack . fromJust .
+ X.getAttribute "value" <$> getParamNode
+ return $ yieldPureText $ T.pack $ show $ 1 + value
+
+
+------------------------------------------------------------------------------
+-- | Test for defer functions to see that they correctly save the result of
+-- a runtime computation.
+deferTest :: IO ()
+deferTest = do
+ rs <- mapM newIORef $ replicate 5 (0 :: Int)
+ res <- runExceptT $ do
+ hs <- ExceptT $ initHeist $ hc rs
+ runner <- noteT ["Error rendering"] $ hoistMaybe $
+ renderTemplate hs "test"
+ b <- lift $ fst runner
+ return $ toByteString b
+
+ vs <- mapM readIORef rs
+ H.assertEqual "defer test" ([2, 1, 1, 1, 1], Right msg) (vs, res)
+ where
+ msg = "1 2\n1 1\n1 1\n\n1 1\n"
+ hc rs = HeistConfig (sc rs) "h" True
+ sc rs = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices
+ & scCompiledSplices .~ (splices rs)
+ & scTemplateLocations .~ [loadTemplates "templates-defer"]
+ splices [r1, r2, r3, r4, r5] = do
+ "plain" ## subSplice $ addAndReturn r1
+ "defer" ## deferMap return subSplice $ addAndReturn r2
+ "maydefer" ## mayDeferMap (return . Just) subSplice $ addAndReturn r3
+ "maydefer2" ## mayDeferMap (const $ return Nothing) subSplice $
+ addAndReturn r4
+ "defermany" ## deferMany subSplice $ addAndReturn' r5
+ subSplice =
+ withSplices runChildren
+ ("use" ## \n -> return $ yieldRuntimeText $ return . T.pack . show =<< n)
+ addAndReturn r = liftIO $ modifyIORef r (+1) >> readIORef r
+ addAndReturn' r = liftIO $ do
+ modifyIORef r (+1)
+ val <- readIORef r
+ return [val]
diff --git a/test/suite/Heist/Interpreted/Tests.hs b/test/suite/Heist/Interpreted/Tests.hs
--- a/test/suite/Heist/Interpreted/Tests.hs
+++ b/test/suite/Heist/Interpreted/Tests.hs
@@ -11,23 +11,24 @@
------------------------------------------------------------------------------
import Blaze.ByteString.Builder
-import Control.Error
+import Control.Monad
import Control.Monad.State
import Data.Aeson
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as L
-import qualified Data.HashMap.Strict as Map
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.HashMap.Strict as Map
+import Data.Map.Syntax
import Data.Maybe
import Data.Monoid
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import Data.Text (Text)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
import System.IO.Unsafe
-import Test.Framework (Test)
+import Test.Framework (Test)
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
-import qualified Test.HUnit as H
+import qualified Test.HUnit as H
import Test.QuickCheck
import Test.QuickCheck.Monadic
@@ -35,15 +36,15 @@
------------------------------------------------------------------------------
import Heist
import Heist.Common
+import Heist.Internal.Types
import Heist.Interpreted.Internal
import Heist.Splices.Apply
import Heist.Splices.Ignore
import Heist.Splices.Json
import Heist.Splices.Markdown
import Heist.TestCommon
-import Heist.Types
-import qualified Text.XmlHtml as X
-import qualified Text.XmlHtml.Cursor as X
+import qualified Text.XmlHtml as X
+import qualified Text.XmlHtml.Cursor as X
------------------------------------------------------------------------------
@@ -60,6 +61,8 @@
, testCase "heist/attributeSubstitution" attrSubstTest
, testCase "heist/bindAttribute" bindAttrTest
, testCase "heist/markdown" markdownTest
+ , testCase "heist/pandoc" pandocTest
+ , testCase "heist/pandoc_div" pandocDivTest
, testCase "heist/title_expansion" titleExpansion
, testCase "heist/textarea_expansion" textareaExpansion
, testCase "heist/div_expansion" divExpansion
@@ -117,7 +120,7 @@
hasTemplateTest :: H.Assertion
hasTemplateTest = do
ets <- loadIO "templates" mempty mempty mempty mempty
- let tm = either (error "Error loading templates") _templateMap ets
+ let tm = either (error . unlines) _templateMap ets
hs <- loadEmpty mempty mempty mempty mempty
let hs's = setTemplates tm hs
H.assertBool "hasTemplate hs's" (hasTemplate "index" hs's)
@@ -138,7 +141,7 @@
ets <- loadIO "templates" mempty mempty mempty mempty
either (error "Error loading templates")
(\ts -> do let tm = _templateMap ts
- H.assertEqual "loadTest size" 37 $ Map.size tm
+ H.assertEqual "loadTest size" 41 $ Map.size tm
) ets
@@ -182,7 +185,7 @@
where
indexRes = B.concat
[doctype
- ,"\n
\n