diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -1,4 +1,6 @@ Doug Beardsley Gregory Collins +Carl Howells Edward Kmett +Shane O'Brien James Sanders diff --git a/heist.cabal b/heist.cabal --- a/heist.cabal +++ b/heist.cabal @@ -1,5 +1,5 @@ name: heist -version: 0.2.0 +version: 0.2.1 synopsis: An xhtml templating system license: BSD3 license-file: LICENSE diff --git a/src/Text/Templating/Heist.hs b/src/Text/Templating/Heist.hs --- a/src/Text/Templating/Heist.hs +++ b/src/Text/Templating/Heist.hs @@ -97,6 +97,7 @@ -- * Misc functions , getDoc + , parseDoc , bindStaticTag ) where @@ -120,8 +121,9 @@ ------------------------------------------------------------------------------ --- | An empty template state, with Heist's default splices (@\@ and --- @\@) mapped. +-- | An empty template state, with Heist's default splices (@\@, +-- @\@, @\@, and @\@) mapped. The static tag is +-- not mapped here because it must be mapped manually in your application. emptyTemplateState :: MonadIO m => TemplateState m emptyTemplateState = TemplateState defaultSpliceMap Map.empty True [] 0 return return return [] diff --git a/src/Text/Templating/Heist/Internal.hs b/src/Text/Templating/Heist/Internal.hs --- a/src/Text/Templating/Heist/Internal.hs +++ b/src/Text/Templating/Heist/Internal.hs @@ -1,32 +1,33 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Text.Templating.Heist.Internal where ------------------------------------------------------------------------------ -import Control.Applicative -import Control.Exception (SomeException) -import Control.Monad.CatchIO -import Control.Monad.RWS.Strict -import qualified Data.Attoparsec.Char8 as AP -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy as L -import Data.Either -import qualified Data.Foldable as F -import Data.List -import qualified Data.Map as Map -import Data.Maybe -import Prelude hiding (catch) -import System.Directory.Tree hiding (name) -import System.FilePath -import Text.XML.Expat.Format -import qualified Text.XML.Expat.Tree as X +import Control.Applicative +import Control.Exception (SomeException) +import Control.Monad.CatchIO +import "monads-fd" Control.Monad.RWS.Strict +import qualified Data.Attoparsec.Char8 as AP +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as L +import Data.Either +import qualified Data.Foldable as F +import Data.List +import qualified Data.Map as Map +import Data.Maybe +import Prelude hiding (catch) +import System.Directory.Tree hiding (name) +import System.FilePath +import Text.XML.Expat.Format +import qualified Text.XML.Expat.Tree as X ------------------------------------------------------------------------------ -import Text.Templating.Heist.Constants -import Text.Templating.Heist.Types +import Text.Templating.Heist.Constants +import Text.Templating.Heist.Types ------------------------------------------------------------------------------ @@ -283,17 +284,32 @@ ------------------------------------------------------------------------------ --- | Get's the attribute value. This is just a normal splice lookup with the --- added restriction that the splice's result list has to contain a single --- text element. Otherwise the attribute evaluates to the empty string. +-- | Get's the attribute value. If the splice's result list contains non-text +-- nodes, this will translate them into text nodes with textContent and +-- concatenate them together. +-- +-- Originally, this only took the first node from the splices's result list, +-- and only if it was a text node. This caused problems when the splice's +-- result contained HTML entities, as they would split a text node. This was +-- then fixed to take the first consecutive bunch of text nodes, and return +-- their concatenation. This was seen as more useful than throwing an error, +-- and more intuitive than trying to render all the nodes as text. +-- +-- However, it was decided in the end to render all the nodes as text, and +-- then concatenate them. If a splice returned +-- \"some \text\<\/b\> foobar\", the user would almost certainly want +-- \"some text foobar\" to be rendered, and Heist would probably seem +-- annoyingly limited for not being able to do this. If the user really did +-- want it to render \"some \", it would probably be easier for them to +-- accept that they were silly to pass more than that to be substituted than +-- it would be for the former user to accept that +-- \"some \text\<\/b\> foobar\" is being rendered as \"some \" because +-- it's \"more intuitive\". getAttributeSplice :: Monad m => ByteString -> TemplateMonad m ByteString getAttributeSplice name = do s <- liftM (lookupSplice name) getTS nodes <- maybe (return []) id s - return $ check nodes - where - check ((X.Text t):_) = t - check _ = "" + return $ B.concat $ map X.textContent nodes ------------------------------------------------------------------------------ -- | Performs splice processing on a list of nodes. @@ -432,29 +448,47 @@ -- Template loading ------------------------------------------------------------------------------ --- | Reads an XML document from disk. -getDoc :: String -> IO (Either String InternalTemplate) -getDoc f = do - bs <- catch (liftM Right $ B.readFile f) - (\(e::SomeException) -> return $ Left $ show e) - return $ do - (doctype, rest) <- liftM extractDoctype bs - let wrap b = "\n" `B.append` b `B.append` "\n" - toTemplate t = InternalTemplate { - _itDoctype = doctype, - _itNodes = t - } - mapRight (toTemplate . X.getChildren) . - mapLeft genErrorMsg . - X.parse' heistExpatOptions . wrap $ rest +-- | Turns an in-memory XML/XHTML bytestring into a (doctype,'[Node]') pair. +parseDoc :: ByteString -> IO (Either String (Maybe ByteString,[Node])) +parseDoc bs = do + let (doctype,rest) = extractDoctype bs + let wrap b = B.concat ["\n", b, "\n"] + + return $ + mapRight (\n -> (doctype,X.getChildren n)) $ + mapLeft genErrorMsg $ + X.parse' heistExpatOptions (wrap rest) + where - genErrorMsg (X.XMLParseError str loc) = f ++ " " ++ locMsg loc ++ ": " ++ translate str + genErrorMsg (X.XMLParseError str loc) = locMsg loc ++ ": " ++ translate str + locMsg (X.XMLParseLocation line col _ _) = "(line " ++ show (line-1) ++ ", col " ++ show col ++ ")" + translate "junk after document element" = "document must have a single root element" translate s = s +-- | Reads an XML document from disk. +getDoc :: String -> IO (Either String InternalTemplate) +getDoc f = do + bs <- catch (liftM Right $ B.readFile f) + (\(e::SomeException) -> return $ Left $ show e) + + d' <- either (return . Left) + parseDoc + bs + + let d = mapLeft (\s -> f ++ " " ++ s) d' + + return $ either Left + (\(doctype, nodes) -> Right $ InternalTemplate { + _itDoctype = doctype, + _itNodes = nodes + }) + d + + ------------------------------------------------------------------------------ -- | Checks whether the bytestring has a doctype. hasDoctype :: ByteString -> Bool @@ -467,7 +501,7 @@ extractDoctype :: ByteString -> (Maybe ByteString, ByteString) extractDoctype bs = if hasDoctype bs - then (Just $ B.snoc (B.takeWhile p bs) '>', B.tail $ B.dropWhile p bs) + then (Just $ B.snoc (B.takeWhile p bs) '>',B.tail $ B.dropWhile p bs) else (Nothing, bs) where p = (/='>') diff --git a/src/Text/Templating/Heist/Splices/Static.hs b/src/Text/Templating/Heist/Splices/Static.hs --- a/src/Text/Templating/Heist/Splices/Static.hs +++ b/src/Text/Templating/Heist/Splices/Static.hs @@ -40,7 +40,7 @@ ------------------------------------------------------------------------------ --- | The "static" splice ensures that its contents are evaluated once and then +-- | The \"static\" splice ensures that its contents are evaluated once and then -- cached. The cached contents are returned every time the splice is -- referenced. staticImpl :: (MonadIO m) @@ -68,7 +68,10 @@ ------------------------------------------------------------------------------ --- | Modifies a TemplateState to include a "static" tag. +-- | Modifies a TemplateState to include a \"static\" tag. The static tag is +-- not bound automatically with the other default Heist tags. This is because +-- this function also returns StaticTagState, so the user will be able to +-- clear it with the 'clearStaticTagCache' function. bindStaticTag :: MonadIO m => TemplateState m -> IO (TemplateState m, StaticTagState) diff --git a/src/Text/Templating/Heist/Types.hs b/src/Text/Templating/Heist/Types.hs --- a/src/Text/Templating/Heist/Types.hs +++ b/src/Text/Templating/Heist/Types.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-| @@ -21,20 +22,19 @@ 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 -import Data.ByteString.Char8 (ByteString) -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 +import Control.Applicative +import "monads-fd" Control.Monad.Cont +import "monads-fd" Control.Monad.Error +import "monads-fd" Control.Monad.Reader +import "monads-fd" Control.Monad.State +import "monads-fd" Control.Monad.Trans +import Data.ByteString.Char8 (ByteString) +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 ------------------------------------------------------------------------------ @@ -135,9 +135,20 @@ ------------------------------------------------------------------------------ --- | 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. +-- | The Typeable instance is here so Heist can be dynamically executed with +-- Hint. +templateStateTyCon :: TyCon +templateStateTyCon = mkTyCon "Text.Templating.Heist.TemplateState" +{-# NOINLINE templateStateTyCon #-} + +instance (Typeable1 m) => Typeable (TemplateState m) where + typeOf _ = mkTyConApp templateStateTyCon [typeOf1 (undefined :: m ())] + + +------------------------------------------------------------------------------ +-- | TemplateMonad is the monad used for 'Splice' processing. TemplateMonad +-- provides \"passthrough\" instances for many of the monads you might use in +-- the inner monad. newtype TemplateMonad m a = TemplateMonad { runTemplateMonad :: Node -> TemplateState m @@ -146,7 +157,7 @@ ------------------------------------------------------------------------------ --- | Helper function for the functor instance +-- | Evaluates a template monad as a computation in the underlying monad. evalTemplateMonad :: Monad m => TemplateMonad m a -> Node @@ -155,7 +166,7 @@ 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) @@ -279,15 +290,14 @@ ------------------------------------------------------------------------------ -- | 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 [] +templateMonadTyCon :: TyCon +templateMonadTyCon = mkTyCon "Text.Templating.Heist.TemplateMonad" +{-# NOINLINE templateMonadTyCon #-} +instance (Typeable1 m) => Typeable1 (TemplateMonad m) where + typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())] + ------------------------------------------------------------------------------ -- Functions for our monad. ------------------------------------------------------------------------------ @@ -310,7 +320,7 @@ ------------------------------------------------------------------------------ --- | +-- | TemplateMonad's local localParamNode :: Monad m => (Node -> Node) -> TemplateMonad m a @@ -319,25 +329,25 @@ ------------------------------------------------------------------------------ --- | +-- | TemplateMonad's gets getsTS :: Monad m => (TemplateState m -> r) -> TemplateMonad m r getsTS f = TemplateMonad $ \_ s -> return (f s, s) ------------------------------------------------------------------------------ --- | +-- | TemplateMonad's get getTS :: Monad m => TemplateMonad m (TemplateState m) getTS = TemplateMonad $ \_ s -> return (s, s) ------------------------------------------------------------------------------ --- | +-- | TemplateMonad's put putTS :: Monad m => TemplateState m -> TemplateMonad m () putTS s = TemplateMonad $ \_ _ -> return ((), s) ------------------------------------------------------------------------------ --- | +-- | TemplateMonad's modify modifyTS :: Monad m => (TemplateState m -> TemplateState m) -> TemplateMonad m ()