This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "heist".
The branch, 0.2-dev has been updated
via 61ff831a56d64143cda11c324ed4d1250f0b6df5 (commit)
via fbd0b63e3c29c3ce419eb446c580b75f3f0d1729 (commit)
from 144e32b583b5c1ad847adebed73932a4344bb644 (commit)
Summary of changes:
src/Text/Templating/Heist.hs | 1 +
src/Text/Templating/Heist/Internal.hs | 227 ++++----------------
src/Text/Templating/Heist/Splices/Apply.hs | 5 +-
src/Text/Templating/Heist/Splices/Bind.hs | 3 +-
src/Text/Templating/Heist/Splices/Ignore.hs | 2 +-
src/Text/Templating/Heist/Splices/Markdown.hs | 6 +-
src/Text/Templating/Heist/Splices/Static.hs | 1 +
.../Heist/{TemplateMonad.hs => Types.hs} | 136 +++++++++++--
test/suite/Text/Templating/Heist/Tests.hs | 44 ++--
9 files changed, 197 insertions(+), 228 deletions(-)
rename src/Text/Templating/Heist/{TemplateMonad.hs => Types.hs} (60%)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 61ff831a56d64143cda11c324ed4d1250f0b6df5
Author: Mighty Byte <[email protected]>
Date: Tue Jun 1 21:57:20 2010 -0400
Fixed test suite to work with new TemplateMonad.
diff --git a/test/suite/Text/Templating/Heist/Tests.hs
b/test/suite/Text/Templating/Heist/Tests.hs
index d71042f..dd58318 100644
--- a/test/suite/Text/Templating/Heist/Tests.hs
+++ b/test/suite/Text/Templating/Heist/Tests.hs
@@ -4,26 +4,27 @@ module Text.Templating.Heist.Tests
, quickRender
) where
-import Test.Framework (Test)
-import Test.Framework.Providers.HUnit
-import Test.Framework.Providers.QuickCheck2
-import qualified Test.HUnit as H
-import Test.QuickCheck
-import Test.QuickCheck.Monadic
-
+------------------------------------------------------------------------------
import Control.Monad.State
-
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
-
import System.IO.Unsafe
+import Test.Framework (Test)
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck2
+import qualified Test.HUnit as H
+import Test.QuickCheck
+import Test.QuickCheck.Monadic
+
+------------------------------------------------------------------------------
import Text.Templating.Heist
import Text.Templating.Heist.Internal
+import Text.Templating.Heist.Types
import Text.Templating.Heist.Splices.Apply
import Text.XML.Expat.Cursor
import Text.XML.Expat.Format
@@ -46,8 +47,8 @@ tests = [ testProperty "simpleBindTest" $ monadicIO $ forAllM
arbitrary prop_sim
applyTest :: H.Assertion
applyTest = do
let es = emptyTemplateState :: TemplateState IO
- res <- runTemplateMonad es
- (X.Element "apply" [("template", "nonexistant")] []) applyImpl
+ res <- evalTemplateMonad applyImpl
+ (X.Element "apply" [("template", "nonexistant")] []) es
H.assertEqual "apply nothing" res []
monoidTest :: IO ()
@@ -236,8 +237,8 @@ instance Show Bind where
,L.unpack $ L.concat $ map formatNode $ buildResult b
,"Splice result:"
,L.unpack $ L.concat $ map formatNode $ unsafePerformIO $
- runTemplateMonad emptyTemplateState (X.Text "")$
- runNodeList $ buildBindTemplate b
+ evalTemplateMonad (runNodeList $ buildBindTemplate b)
+ (X.Text "") emptyTemplateState
,"Template:"
,L.unpack $ L.concat $ map formatNode $ buildBindTemplate b
]
@@ -279,8 +280,10 @@ prop_simpleBindTest :: Bind -> PropertyM IO ()
prop_simpleBindTest bind = do
let template = buildBindTemplate bind
result = buildResult bind
- spliceResult <- run $ runTemplateMonad emptyTemplateState (X.Text "") $
- runNodeList template
+ spliceResult <- run $ evalTemplateMonad (runNodeList template)
+ (X.Text "")
+ emptyTemplateState
+
assert $ result == spliceResult
{-
@@ -314,8 +317,9 @@ calcCorrect (Apply _ caller callee _ pos) = insertAt callee
pos caller
calcResult :: (MonadIO m) => Apply -> m [Node]
calcResult apply@(Apply name _ callee _ _) =
- runTemplateMonad ts (X.Text "") $
- runNodeList $ buildApplyCaller apply
+ evalTemplateMonad (runNodeList $ buildApplyCaller apply)
+ (X.Text "") ts
+
where ts = setTemplates (Map.singleton [unName name]
(InternalTemplate Nothing callee))
emptyTemplateState
@@ -327,8 +331,8 @@ prop_simpleApplyTest apply = do
assert $ correct == result
-getTS :: FilePath -> IO (TemplateState IO)
-getTS baseDir = do
+loadTS :: FilePath -> IO (TemplateState IO)
+loadTS baseDir = do
etm <- loadTemplates baseDir emptyTemplateState
return $ either error id etm
@@ -337,7 +341,7 @@ getTS baseDir = do
-- template. (Old convenience code.)
quickRender :: FilePath -> ByteString -> IO (Maybe ByteString)
quickRender baseDir name = do
- ts <- getTS baseDir
+ ts <- loadTS baseDir
renderTemplate ts name
commit fbd0b63e3c29c3ce419eb446c580b75f3f0d1729
Author: Mighty Byte <[email protected]>
Date: Tue Jun 1 21:31:44 2010 -0400
Switch to new TemplateMonad implementation.
diff --git a/src/Text/Templating/Heist.hs b/src/Text/Templating/Heist.hs
index fc0ba35..d19e338 100644
--- a/src/Text/Templating/Heist.hs
+++ b/src/Text/Templating/Heist.hs
@@ -105,6 +105,7 @@ import Control.Monad.Trans
import qualified Data.Map as Map
import Text.Templating.Heist.Internal
import Text.Templating.Heist.Splices
+import Text.Templating.Heist.Types
------------------------------------------------------------------------------
diff --git a/src/Text/Templating/Heist/Internal.hs
b/src/Text/Templating/Heist/Internal.hs
index f9738b6..1900ac1 100644
--- a/src/Text/Templating/Heist/Internal.hs
+++ b/src/Text/Templating/Heist/Internal.hs
@@ -17,9 +17,7 @@ import Data.Either
import qualified Data.Foldable as F
import Data.List
import qualified Data.Map as Map
-import Data.Map (Map)
import Data.Maybe
-import Data.Typeable
import Prelude hiding (catch)
import System.Directory.Tree hiding (name)
import System.FilePath
@@ -28,133 +26,18 @@ import qualified Text.XML.Expat.Tree as X
------------------------------------------------------------------------------
import Text.Templating.Heist.Constants
-
-------------------------------------------------------------------------------
--- Types
-------------------------------------------------------------------------------
-
-------------------------------------------------------------------------------
--- | Heist templates are XML documents. The hexpat library is polymorphic over
--- the type of strings, so here we define a 'Node' alias to fix the string
--- types of the tag names and tag bodies to 'ByteString'.
-type Node = X.Node ByteString ByteString
-
-
-------------------------------------------------------------------------------
--- | A 'Template' is a forest of XML nodes. Here we deviate from the "single
--- root node" constraint of well-formed XML because we want to allow templates
--- to contain fragments of a document that may not have a single root.
-type Template = [Node]
-
-
-------------------------------------------------------------------------------
--- | An 'InternalTemplate' carries a doctype with it that we get from the
--- template at load time. The tricks that we're playing so templates don't
--- have to have a single root node screw up doctypes, so we have to handle
--- them manually.
-data InternalTemplate = InternalTemplate {
- _itDoctype :: Maybe ByteString,
- _itNodes :: [Node]
-} deriving (Eq, Show)
-
-
-------------------------------------------------------------------------------
--- | Reversed list of directories. This holds the path to the template
--- currently being processed.
-type TPath = [ByteString]
-
-
-------------------------------------------------------------------------------
--- | All templates are stored in a map.
-type TemplateMap = Map TPath InternalTemplate
-
-
-------------------------------------------------------------------------------
--- | Holds all the state information needed for template processing. You will
--- build a @TemplateState@ using any of Heist's @TemplateState m ->
--- TemplateState m@ \"filter\" functions. Then you use the resulting
--- @TemplateState@ in calls to @rendertempl...@.
-data TemplateState m = TemplateState {
- -- | A mapping of splice names to splice actions
- _spliceMap :: SpliceMap m
- -- | A mapping of template names to templates
- , _templateMap :: TemplateMap
- -- | A flag to control splice recursion
- , _recurse :: Bool
- -- | The path to the template currently being processed.
- , _curContext :: TPath
- -- | A counter keeping track of the current recursion depth to prevent
- -- infinite loops.
- , _recursionDepth :: Int
- -- | A hook run on all templates at load time.
- , _onLoadHook :: Template -> IO Template
- -- | A hook run on all templates just before they are rendered.
- , _preRunHook :: Template -> m Template
- -- | A hook run on all templates just after they are rendered.
- , _postRunHook :: Template -> m Template
- -- | The doctypes encountered during template processing.
- , _doctypes :: [ByteString]
-}
-
-
-------------------------------------------------------------------------------
-instance Eq (TemplateState m) where
- a == b = (_recurse a == _recurse b) &&
- (_templateMap a == _templateMap b) &&
- (_curContext a == _curContext b)
-
-
-------------------------------------------------------------------------------
--- | 'TemplateMonad' is a monad transformer that gives you access to the 'Node'
--- being processed (using the 'MonadReader' instance) as well as holding the
--- 'TemplateState' that contains splice and template mappings (accessible
--- using the 'MonadState' instance.
-newtype TemplateMonad m a = TemplateMonad (RWST Node () (TemplateState m) m a)
- deriving ( Monad
- , MonadIO
- , MonadCatchIO
- , MonadReader Node
- , MonadState (TemplateState m) )
-
-
-------------------------------------------------------------------------------
-instance (Monad m) => Monoid (TemplateState m) where
- mempty = TemplateState Map.empty Map.empty True [] 0
- return return return []
-
- (TemplateState s1 t1 r1 _ d1 o1 b1 a1 dt1) `mappend`
- (TemplateState s2 t2 r2 c2 d2 o2 b2 a2 dt2) =
- TemplateState s t r c2 d (o1 >=> o2) (b1 >=> b2) (a1 >=> a2)
- (dt1 `mappend` dt2)
- where
- s = s1 `mappend` s2
- t = t1 `mappend` t2
- r = r1 && r2
- d = max d1 d2
-
-
-------------------------------------------------------------------------------
--- | Runs a splice in the underlying monad. Splices require two
--- parameters, the template state, and an input node.
-runTemplateMonad :: Monad m =>
- TemplateState m -- ^ The initial template state
- -> Node -- ^ The splice's input node
- -> TemplateMonad m a
- -> m a
-runTemplateMonad ts node (TemplateMonad tm) = do
- (result,_,_) <- runRWST tm node ts
- return result
+import Text.Templating.Heist.Types
------------------------------------------------------------------------------
-- | Restores the components of TemplateState that can get modified in
--- template calls. You should use this function instead of @put@ to restore
+-- template calls. You should use this function instead of @putTS@ to restore
-- an old state. Thas 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.
restoreState :: Monad m => TemplateState m -> TemplateMonad m ()
restoreState ts1 =
- modify (\ts2 -> ts2
+ modifyTS (\ts2 -> ts2
{ _recursionDepth = _recursionDepth ts1
, _curContext = _curContext ts1
, _spliceMap = _spliceMap ts1
@@ -165,32 +48,7 @@ restoreState ts1 =
-- | Mappends a doctype to the state.
addDoctype :: Monad m => [ByteString] -> TemplateMonad m ()
addDoctype dt = do
- modify (\s -> s { _doctypes = _doctypes s `mappend` dt })
-
-
-------------------------------------------------------------------------------
-instance MonadTrans TemplateMonad where
- lift = TemplateMonad . lift
-
-
-------------------------------------------------------------------------------
-instance (Typeable1 m, Typeable a) => Typeable (TemplateMonad m a) where
- typeOf _ = mkTyConApp tCon [mRep, aRep]
- where
- tCon = mkTyCon "TemplateMonad"
- maRep = typeOf (undefined :: m a)
- (mCon, [aRep]) = splitTyConApp maRep
- mRep = mkTyConApp mCon []
-
-
-------------------------------------------------------------------------------
--- | A Splice is a TemplateMonad computation that returns a 'Template'.
-type Splice m = TemplateMonad m Template
-
-
-------------------------------------------------------------------------------
--- | SpliceMap associates a name and a Splice.
-type SpliceMap m = Map ByteString (Splice m)
+ modifyTS (\s -> s { _doctypes = _doctypes s `mappend` dt })
------------------------------------------------------------------------------
@@ -335,22 +193,6 @@ addTemplate n t st = insertTemplate (splitTemplatePath n)
t st
------------------------------------------------------------------------------
--- | Gets the node currently being processed.
---
--- > <speech author="Shakespeare">
--- > To sleep, perchance to dream.
--- > </speech>
---
--- When you call @getParamNode@ inside the code for the @speech@ splice, it
--- returns the Node for the @speech@ tag and its children. @getParamNode >>=
--- getChildren@ returns a list containing one 'Text' node containing part of
--- Hamlet's speech. @getParamNode >>= getAttribute \"author\"@ would return
--- @Just "Shakespeare"@.
-getParamNode :: Monad m => TemplateMonad m Node
-getParamNode = ask
-
-
-------------------------------------------------------------------------------
-- | Stops the recursive processing of splices. Consider the following
-- example:
--
@@ -365,19 +207,19 @@ getParamNode = ask
-- scan @L@ for splices and run them. If @foo@ calls @stopRecursion@, @L@
-- will be included in the output verbatim without running any splices.
stopRecursion :: Monad m => TemplateMonad m ()
-stopRecursion = modify (\st -> st { _recurse = False })
+stopRecursion = modifyTS (\st -> st { _recurse = False })
------------------------------------------------------------------------------
-- | Sets the current context
setContext :: Monad m => TPath -> TemplateMonad m ()
-setContext c = modify (\st -> st { _curContext = c })
+setContext c = modifyTS (\st -> st { _curContext = c })
------------------------------------------------------------------------------
-- | Gets the current context
getContext :: Monad m => TemplateMonad m TPath
-getContext = gets _curContext
+getContext = getsTS _curContext
------------------------------------------------------------------------------
@@ -385,7 +227,7 @@ getContext = gets _curContext
runNode :: Monad m => Node -> Splice m
runNode n@(X.Text _) = return [n]
runNode n@(X.Element nm at ch) = do
- s <- liftM (lookupSplice nm) get
+ s <- liftM (lookupSplice nm) getTS
maybe runChildren (recurseSplice n) s
where
@@ -393,23 +235,31 @@ runNode n@(X.Element nm at ch) = do
newKids <- runNodeList ch
newAtts <- mapM attSubst at
return [X.Element nm newAtts newKids]
- attSubst (n,v) = do
- v' <- parseAtt v
- return (n,v')
+
+
+------------------------------------------------------------------------------
+-- | Helper function for substituting a parsed attribute into an attribute
+-- tuple.
+attSubst :: (Monad m) => (t, ByteString) -> TemplateMonad m (t, ByteString)
+attSubst (n,v) = do
+ v' <- parseAtt v
+ return (n,v')
------------------------------------------------------------------------------
-- | Parses an attribute for any identifier expressions and performs
-- appropriate substitution.
+parseAtt :: (Monad m) => ByteString -> TemplateMonad m ByteString
parseAtt bs = do
let ast = case AP.feed (AP.parse attParser bs) "" of
(AP.Fail _ _ _) -> []
(AP.Done _ res) -> res
+ (AP.Partial _) -> []
chunks <- mapM cvt ast
return $ B.concat chunks
where
- cvt (Literal bs) = return bs
- cvt (Ident bs) = getAttributeSplice bs
+ cvt (Literal x) = return x
+ cvt (Ident x) = getAttributeSplice x
------------------------------------------------------------------------------
@@ -422,6 +272,7 @@ data AttAST = Literal ByteString |
------------------------------------------------------------------------------
-- | Parser for attribute variable substitution.
+attParser :: AP.Parser [AttAST]
attParser = AP.many1 (identParser <|> litParser)
where
escChar = (AP.char '\\' *> AP.anyChar) <|>
@@ -437,7 +288,7 @@ attParser = AP.many1 (identParser <|> litParser)
-- text element. Otherwise the attribute evaluates to the empty string.
getAttributeSplice :: Monad m => ByteString -> TemplateMonad m ByteString
getAttributeSplice name = do
- s <- liftM (lookupSplice name) get
+ s <- liftM (lookupSplice name) getTS
nodes <- maybe (return []) id s
return $ check nodes
where
@@ -461,8 +312,8 @@ mAX_RECURSION_DEPTH = 50
-- deeper than mAX_RECURSION_DEPTH to avoid infinite loops.
recurseSplice :: Monad m => Node -> Splice m -> Splice m
recurseSplice node splice = do
- result <- local (const node) splice
- ts' <- get
+ result <- localParamNode (const node) splice
+ ts' <- getTS
if _recurse ts' && _recursionDepth ts' < mAX_RECURSION_DEPTH
then do modRecursionDepth (+1)
res <- runNodeList result
@@ -472,7 +323,7 @@ recurseSplice node splice = do
where
modRecursionDepth :: Monad m => (Int -> Int) -> TemplateMonad m ()
modRecursionDepth f =
- modify (\st -> st { _recursionDepth = f (_recursionDepth st) })
+ modifyTS (\st -> st { _recursionDepth = f (_recursionDepth st) })
------------------------------------------------------------------------------
@@ -482,7 +333,7 @@ lookupAndRun :: Monad m
-> ((InternalTemplate, TPath) -> TemplateMonad m (Maybe a))
-> TemplateMonad m (Maybe a)
lookupAndRun name k = do
- ts <- get
+ ts <- getTS
maybe (return Nothing) k
(lookupTemplate name ts)
@@ -494,8 +345,8 @@ evalTemplate :: Monad m
-> TemplateMonad m (Maybe Template)
evalTemplate name = lookupAndRun name
(\(t,ctx) -> do
- ts <- get
- put (ts {_curContext = ctx})
+ ts <- getTS
+ putTS (ts {_curContext = ctx})
res <- runNodeList $ _itNodes t
restoreState ts
return $ Just res)
@@ -510,9 +361,9 @@ evalWithHooks :: Monad m
evalWithHooks name = lookupAndRun name
(\(t,ctx) -> do
addDoctype $ maybeToList $ _itDoctype t
- ts <- get
+ ts <- getTS
nodes <- lift $ _preRunHook ts $ _itNodes t
- put (ts {_curContext = ctx})
+ putTS (ts {_curContext = ctx})
res <- runNodeList nodes
restoreState ts
return . Just =<< lift (_postRunHook ts res))
@@ -538,7 +389,7 @@ callTemplate :: Monad m
-- (name,value) parameter pairs
-> TemplateMonad m (Maybe Template)
callTemplate name params = do
- modify $ bindStrings params
+ modifyTS $ bindStrings params
evalTemplate name
@@ -547,7 +398,7 @@ callTemplate name params = do
-- TemplateMonad where the doctype is available.
toInternalTemplate :: Monad m => Template -> TemplateMonad m InternalTemplate
toInternalTemplate t = do
- dts <- gets _doctypes
+ dts <- getsTS _doctypes
return $ InternalTemplate {
_itDoctype = listToMaybe dts,
_itNodes = t
@@ -570,12 +421,12 @@ renderTemplate :: Monad m
-> ByteString
-> m (Maybe ByteString)
renderTemplate ts name = do
- runTemplateMonad ts (X.Text "") $ do
- mt <- evalWithHooks name
- maybe (return Nothing)
- (\t -> liftM Just $ renderInternal =<< toInternalTemplate t)
- mt
-
+ evalTemplateMonad
+ (do mt <- evalWithHooks name
+ maybe (return Nothing)
+ (\t -> liftM Just $ renderInternal =<< toInternalTemplate t)
+ mt
+ ) (X.Text "") ts
------------------------------------------------------------------------------
-- Template loading
diff --git a/src/Text/Templating/Heist/Splices/Apply.hs
b/src/Text/Templating/Heist/Splices/Apply.hs
index 6633753..3a95618 100644
--- a/src/Text/Templating/Heist/Splices/Apply.hs
+++ b/src/Text/Templating/Heist/Splices/Apply.hs
@@ -11,6 +11,7 @@ import qualified Text.XML.Expat.Tree as X
------------------------------------------------------------------------------
import Text.Templating.Heist.Internal
+import Text.Templating.Heist.Types
------------------------------------------------------------------------------
-- | Default name for the apply splice.
@@ -32,12 +33,12 @@ applyImpl = do
case X.getAttribute node applyAttr of
Nothing -> return [] -- TODO: error handling
Just attr -> do
- st <- get
+ st <- getTS
maybe (return []) -- TODO: error handling
(\(t,ctx) -> do
addDoctype $ maybeToList $ _itDoctype t
processedChildren <- runNodeList $ X.getChildren node
- modify (bindSplice "content" $ return processedChildren)
+ modifyTS (bindSplice "content" $ return
processedChildren)
setContext ctx
result <- runNodeList $ _itNodes t
restoreState st
diff --git a/src/Text/Templating/Heist/Splices/Bind.hs
b/src/Text/Templating/Heist/Splices/Bind.hs
index a25342c..37cd2a2 100644
--- a/src/Text/Templating/Heist/Splices/Bind.hs
+++ b/src/Text/Templating/Heist/Splices/Bind.hs
@@ -9,6 +9,7 @@ import qualified Text.XML.Expat.Tree as X
------------------------------------------------------------------------------
import Text.Templating.Heist.Internal
+import Text.Templating.Heist.Types
-- | Default name for the bind splice.
bindTag :: ByteString
@@ -32,6 +33,6 @@ bindImpl = do
return []
where
- add node nm = modify $ bindSplice nm (return $ X.getChildren node)
+ add node nm = modifyTS $ bindSplice nm (return $ X.getChildren node)
diff --git a/src/Text/Templating/Heist/Splices/Ignore.hs
b/src/Text/Templating/Heist/Splices/Ignore.hs
index 498305a..7008f5d 100644
--- a/src/Text/Templating/Heist/Splices/Ignore.hs
+++ b/src/Text/Templating/Heist/Splices/Ignore.hs
@@ -6,7 +6,7 @@ module Text.Templating.Heist.Splices.Ignore where
import Data.ByteString.Char8 (ByteString)
------------------------------------------------------------------------------
-import Text.Templating.Heist.Internal
+import Text.Templating.Heist.Types
------------------------------------------------------------------------------
diff --git a/src/Text/Templating/Heist/Splices/Markdown.hs
b/src/Text/Templating/Heist/Splices/Markdown.hs
index 83152aa..f612e6c 100644
--- a/src/Text/Templating/Heist/Splices/Markdown.hs
+++ b/src/Text/Templating/Heist/Splices/Markdown.hs
@@ -2,6 +2,7 @@
module Text.Templating.Heist.Splices.Markdown where
+------------------------------------------------------------------------------
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
@@ -17,10 +18,11 @@ import System.Directory
import System.Exit
import System.IO
import System.Process
-import Text.Templating.Heist.Constants
-import Text.Templating.Heist.Internal
import Text.XML.Expat.Tree hiding (Node)
+------------------------------------------------------------------------------
+import Text.Templating.Heist.Constants
+import Text.Templating.Heist.Types
data PandocMissingException = PandocMissingException
deriving (Typeable)
diff --git a/src/Text/Templating/Heist/Splices/Static.hs
b/src/Text/Templating/Heist/Splices/Static.hs
index bbaf41c..273f1a0 100644
--- a/src/Text/Templating/Heist/Splices/Static.hs
+++ b/src/Text/Templating/Heist/Splices/Static.hs
@@ -24,6 +24,7 @@ import Text.XML.Expat.Tree hiding (Node)
------------------------------------------------------------------------------
import Text.Templating.Heist.Internal
+import Text.Templating.Heist.Types
------------------------------------------------------------------------------
diff --git a/src/Text/Templating/Heist/TemplateMonad.hs
b/src/Text/Templating/Heist/Types.hs
similarity index 60%
rename from src/Text/Templating/Heist/TemplateMonad.hs
rename to src/Text/Templating/Heist/Types.hs
index 3b44efa..d6ae9af 100644
--- a/src/Text/Templating/Heist/TemplateMonad.hs
+++ b/src/Text/Templating/Heist/Types.hs
@@ -5,10 +5,12 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-module Text.Templating.Heist.TemplateMonad where
+module Text.Templating.Heist.Types where
------------------------------------------------------------------------------
import Control.Applicative
+import Control.Monad.Cont
+import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans
@@ -17,6 +19,7 @@ import qualified Data.ByteString.Char8 as B
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Monoid
+import Data.Typeable
import Prelude hiding (catch)
import qualified Text.XML.Expat.Tree as X
@@ -118,53 +121,101 @@ instance Eq (TemplateState m) where
(_curContext a == _curContext b)
+------------------------------------------------------------------------------
+-- | TemplateMonad is a combination of the reader and state monads. The
+-- reader environment is the contents of the node being spliced. The state is
+-- the TemplateState data structure.
newtype TemplateMonad m a = TemplateMonad {
runTemplateMonad :: Node
- -> (TemplateState m)
+ -> TemplateState m
-> m (a, TemplateState m)
}
+
+------------------------------------------------------------------------------
+-- | Helper function for the functor instance
+evalTemplateMonad :: Monad m
+ => TemplateMonad m a
+ -> Node
+ -> TemplateState m
+ -> m a
+evalTemplateMonad m r s = do
+ (a, _) <- runTemplateMonad m r s
+ return a
+
+------------------------------------------------------------------------------
+-- | Helper function for the functor instance
first :: (a -> b) -> (a, c) -> (b, c)
first f (a,b) = (f a, b)
+
+------------------------------------------------------------------------------
+-- | Functor instance
instance Functor m => Functor (TemplateMonad m) where
fmap f (TemplateMonad m) = TemplateMonad $ \r s -> first f <$> m r s
+
+------------------------------------------------------------------------------
+-- | Applicative instance
instance (Monad m, Functor m) => Applicative (TemplateMonad m) where
pure = return
(<*>) = ap
+
+------------------------------------------------------------------------------
+-- | Monad instance
instance Monad m => Monad (TemplateMonad m) where
return a = TemplateMonad (\_ s -> return (a, s))
TemplateMonad m >>= k = TemplateMonad $ \r s -> do
(a, s') <- m r s
runTemplateMonad (k a) r s'
+
+------------------------------------------------------------------------------
+-- | MonadIO instance
instance MonadIO m => MonadIO (TemplateMonad m) where
liftIO = lift . liftIO
+
+------------------------------------------------------------------------------
+-- | MonadTrans instance
instance MonadTrans TemplateMonad where
lift m = TemplateMonad $ \_ s -> do
a <- m
return (a, s)
+
+------------------------------------------------------------------------------
+-- | MonadFix passthrough instance
instance MonadFix m => MonadFix (TemplateMonad m) where
mfix f = TemplateMonad $ \r s ->
mfix $ \ (a, _) -> runTemplateMonad (f a) r s
+
+------------------------------------------------------------------------------
+-- | Alternative passthrough instance
instance (Functor m, MonadPlus m) => Alternative (TemplateMonad m) where
empty = mzero
(<|>) = mplus
+
+------------------------------------------------------------------------------
+-- | MonadPlus passthrough instance
instance MonadPlus m => MonadPlus (TemplateMonad m) where
mzero = lift mzero
m `mplus` n = TemplateMonad $ \r s ->
runTemplateMonad m r s `mplus` runTemplateMonad n r s
+
+------------------------------------------------------------------------------
+-- | MonadState passthrough instance
instance MonadState s m => MonadState s (TemplateMonad m) where
get = lift get
put = lift . put
+
+------------------------------------------------------------------------------
+-- | MonadReader passthrough instance
instance MonadReader r m => MonadReader r (TemplateMonad m) where
ask = TemplateMonad $ \_ s -> do
r <- ask
@@ -172,9 +223,56 @@ instance MonadReader r m => MonadReader r (TemplateMonad
m) where
local f (TemplateMonad m) =
TemplateMonad $ \r s -> local f (m r s)
---instance MonadError m => MonadError (TemplateMonad m) where
--- throwError = lift . throwError
--- catchError = liftCatch catchError
+
+------------------------------------------------------------------------------
+-- | Helper for MonadError instance.
+liftCatch :: (m (a,TemplateState m)
+ -> (e -> m (a,TemplateState m))
+ -> m (a,TemplateState m))
+ -> TemplateMonad m a
+ -> (e -> TemplateMonad m a)
+ -> TemplateMonad m a
+liftCatch ce m h =
+ TemplateMonad $ \r s ->
+ (runTemplateMonad m r s `ce`
+ (\e -> runTemplateMonad (h e) r s))
+
+
+------------------------------------------------------------------------------
+-- | MonadError passthrough instance
+instance (MonadError e m) => MonadError e (TemplateMonad m) where
+ throwError = lift . throwError
+ catchError = liftCatch catchError
+
+
+------------------------------------------------------------------------------
+-- | Helper for MonadCont instance.
+liftCallCC :: ((((a,TemplateState m) -> m (b, TemplateState m))
+ -> m (a, TemplateState m))
+ -> m (a, TemplateState m))
+ -> ((a -> TemplateMonad m b) -> TemplateMonad m a)
+ -> TemplateMonad m a
+liftCallCC ccc f = TemplateMonad $ \r s ->
+ ccc $ \c ->
+ runTemplateMonad (f (\a -> TemplateMonad $ \_ _ -> c (a, s))) r s
+
+
+------------------------------------------------------------------------------
+-- | MonadCont passthrough instance
+instance (MonadCont m) => MonadCont (TemplateMonad m) where
+ callCC = liftCallCC callCC
+
+
+------------------------------------------------------------------------------
+-- | The Typeable instance is here so Heist can be dynamically executed with
+-- Hint.
+instance (Typeable1 m, Typeable a) => Typeable (TemplateMonad m a) where
+ typeOf _ = mkTyConApp tCon [mRep, aRep]
+ where
+ tCon = mkTyCon "TemplateMonad"
+ maRep = typeOf (undefined :: m a)
+ (mCon, [aRep]) = splitTyConApp maRep
+ mRep = mkTyConApp mCon []
------------------------------------------------------------------------------
@@ -183,7 +281,17 @@ instance MonadReader r m => MonadReader r (TemplateMonad
m) where
------------------------------------------------------------------------------
--- |
+-- | Gets the node currently being processed.
+--
+-- > <speech author="Shakespeare">
+-- > To sleep, perchance to dream.
+-- > </speech>
+--
+-- When you call @getParamNode@ inside the code for the @speech@ splice, it
+-- returns the Node for the @speech@ tag and its children. @getParamNode >>=
+-- getChildren@ returns a list containing one 'Text' node containing part of
+-- Hamlet's speech. @getParamNode >>= getAttribute \"author\"@ would return
+-- @Just "Shakespeare"@.
getParamNode :: Monad m => TemplateMonad m Node
getParamNode = TemplateMonad $ \r s -> return (r,s)
@@ -199,27 +307,27 @@ localParamNode f m = TemplateMonad $ \r s ->
runTemplateMonad m (f r) s
------------------------------------------------------------------------------
-- |
-getsTemplateState :: Monad m => (TemplateState m -> r) -> TemplateMonad m r
-getsTemplateState f = TemplateMonad $ \_ s -> return (f s, s)
+getsTS :: Monad m => (TemplateState m -> r) -> TemplateMonad m r
+getsTS f = TemplateMonad $ \_ s -> return (f s, s)
------------------------------------------------------------------------------
-- |
-getTemplateState :: Monad m => TemplateMonad m (TemplateState m)
-getTemplateState = TemplateMonad $ \_ s -> return (s, s)
+getTS :: Monad m => TemplateMonad m (TemplateState m)
+getTS = TemplateMonad $ \_ s -> return (s, s)
------------------------------------------------------------------------------
-- |
-putTemplateState :: Monad m => TemplateState m -> TemplateMonad m ()
-putTemplateState s = TemplateMonad $ \_ _ -> return ((), s)
+putTS :: Monad m => TemplateState m -> TemplateMonad m ()
+putTS s = TemplateMonad $ \_ _ -> return ((), s)
------------------------------------------------------------------------------
-- |
-modifyTemplateState :: Monad m
+modifyTS :: Monad m
=> (TemplateState m -> TemplateState m)
-> TemplateMonad m ()
-modifyTemplateState f = TemplateMonad $ \_ s -> return ((), f s)
+modifyTS f = TemplateMonad $ \_ s -> return ((), f s)
-----------------------------------------------------------------------
hooks/post-receive
--
heist
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
