1 {-# LANGUAGE FlexibleInstances #-}
    2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    3 {-# LANGUAGE MultiParamTypeClasses #-}
    4 {-# LANGUAGE PackageImports #-}
    5 {-# LANGUAGE ScopedTypeVariables #-}
    6 {-# LANGUAGE UndecidableInstances #-}
    7 
    8 {-|
    9 
   10 This module contains the core Heist data types.  TemplateMonad intentionally
   11 does not expose any of its functionality via MonadState or MonadReader
   12 functions.  We define passthrough instances for the most common types of
   13 monads.  These instances allow the user to use TemplateMonad in a monad stack
   14 without needing calls to `lift`.
   15 
   16 Edward Kmett wrote most of the TemplateMonad code and associated instances,
   17 liberating us from the unused writer portion of RWST.
   18 
   19 -}
   20 
   21 module Text.Templating.Heist.Types where
   22 
   23 ------------------------------------------------------------------------------
   24 import             Control.Applicative
   25 import             Control.Arrow
   26 import             Control.Monad.Cont
   27 import             Control.Monad.Error
   28 import             Control.Monad.Reader
   29 import             Control.Monad.State
   30 import             Data.ByteString.Char8 (ByteString)
   31 import qualified   Data.Map as Map
   32 import             Data.Map (Map)
   33 import             Data.Monoid
   34 import             Data.Text (Text)
   35 import             Data.Typeable
   36 import             Prelude hiding (catch)
   37 import qualified   Text.XmlHtml as X
   38 
   39 
   40 ------------------------------------------------------------------------------
   41 -- | A 'Template' is a forest of XML nodes.  Here we deviate from the "single
   42 -- root node" constraint of well-formed XML because we want to allow templates
   43 -- to contain fragments of a document that may not have a single root.
   44 type Template = [X.Node]
   45 
   46 
   47 ------------------------------------------------------------------------------
   48 -- | MIME Type.  The type alias is here to make the API clearer.
   49 type MIMEType = ByteString
   50 
   51 
   52 ------------------------------------------------------------------------------
   53 -- | Reversed list of directories.  This holds the path to the template
   54 -- currently being processed.
   55 type TPath = [ByteString]
   56 
   57 
   58 data DocumentFile = DocumentFile
   59     { dfDoc  :: X.Document
   60     , dfFile :: Maybe FilePath
   61     } deriving (Eq)
   62 
   63 ------------------------------------------------------------------------------
   64 -- | All documents representing templates are stored in a map.
   65 type TemplateMap = Map TPath DocumentFile
   66 
   67 
   68 ------------------------------------------------------------------------------
   69 -- | A Splice is a TemplateMonad computation that returns a 'Template'.
   70 type Splice m = TemplateMonad m Template
   71 
   72 
   73 ------------------------------------------------------------------------------
   74 -- | SpliceMap associates a name and a Splice.
   75 type SpliceMap m = Map Text (Splice m)
   76 
   77 
   78 ------------------------------------------------------------------------------
   79 -- | Holds all the state information needed for template processing.  You will
   80 -- build a @TemplateState@ using any of Heist's @TemplateState m ->
   81 -- TemplateState m@ \"filter\" functions.  Then you use the resulting
   82 -- @TemplateState@ in calls to @renderTemplate@.
   83 data TemplateState m = TemplateState {
   84     -- | A mapping of splice names to splice actions
   85       _spliceMap       :: SpliceMap m
   86     -- | A mapping of template names to templates
   87     , _templateMap     :: TemplateMap
   88     -- | A flag to control splice recursion
   89     , _recurse         :: Bool
   90     -- | The path to the template currently being processed.
   91     , _curContext      :: TPath
   92     -- | A counter keeping track of the current recursion depth to prevent
   93     -- infinite loops.
   94     , _recursionDepth  :: Int
   95     -- | A hook run on all templates at load time.
   96     , _onLoadHook      :: Template -> IO Template
   97     -- | A hook run on all templates just before they are rendered.
   98     , _preRunHook      :: Template -> m Template
   99     -- | A hook run on all templates just after they are rendered.
  100     , _postRunHook     :: Template -> m Template
  101     -- | The doctypes encountered during template processing.
  102     , _doctypes        :: [X.DocType]
  103     -- | The full path to the current template's file on disk.
  104     , _curTemplateFile :: Maybe FilePath
  105 }
  106 
  107 
  108 ------------------------------------------------------------------------------
  109 instance (Monad m) => Monoid (TemplateState m) where
  110     mempty = TemplateState Map.empty Map.empty True [] 0
  111                            return return return [] Nothing
  112 
  113     (TemplateState s1 t1 r1 _ d1 o1 b1 a1 dt1 ctf1) `mappend`
  114         (TemplateState s2 t2 r2 c2 d2 o2 b2 a2 dt2 ctf2) =
  115         TemplateState s t r c2 d (o1 >=> o2) (b1 >=> b2) (a1 >=> a2)
  116             (dt1 `mappend` dt2) ctf
  117       where
  118         s = s1 `mappend` s2
  119         t = t1 `mappend` t2
  120         r = r1 && r2
  121         d = max d1 d2
  122         ctf = getLast $ Last ctf1 `mappend` Last ctf2
  123 
  124 
  125 ------------------------------------------------------------------------------
  126 instance Eq (TemplateState m) where
  127     a == b = (_recurse a == _recurse b) &&
  128              (_templateMap a == _templateMap b) &&
  129              (_curContext a == _curContext b)
  130 
  131 
  132 ------------------------------------------------------------------------------
  133 -- | The Typeable instance is here so Heist can be dynamically executed with
  134 -- Hint.
  135 templateStateTyCon :: TyCon
  136 templateStateTyCon = mkTyCon "Text.Templating.Heist.TemplateState"
  137 {-# NOINLINE templateStateTyCon #-}
  138 
  139 instance (Typeable1 m) => Typeable (TemplateState m) where
  140     typeOf _ = mkTyConApp templateStateTyCon [typeOf1 (undefined :: m ())]
  141 
  142 
  143 {-# DEPRECATED TemplateMonad "NOTICE: The name TemplateMonad is being phased out in favor of the more appropriate HeistT.  Change your code now to prevent breakage in the future!" #-}
  144 ------------------------------------------------------------------------------
  145 -- | TemplateMonad is the monad used for 'Splice' processing.  TemplateMonad
  146 -- provides \"passthrough\" instances for many of the monads you might use in
  147 -- the inner monad.
  148 newtype TemplateMonad m a = TemplateMonad {
  149     runTemplateMonad :: X.Node
  150                      -> TemplateState m
  151                      -> m (a, TemplateState m)
  152 }
  153 type HeistT = TemplateMonad
  154 
  155 
  156 ------------------------------------------------------------------------------
  157 -- | Evaluates a template monad as a computation in the underlying monad.
  158 evalTemplateMonad :: Monad m
  159                   => TemplateMonad m a
  160                   -> X.Node
  161                   -> TemplateState m
  162                   -> m a
  163 evalTemplateMonad m r s = do
  164     (a, _) <- runTemplateMonad m r s
  165     return a
  166 
  167 
  168 ------------------------------------------------------------------------------
  169 -- | Functor instance
  170 instance Functor m => Functor (TemplateMonad m) where
  171     fmap f (TemplateMonad m) = TemplateMonad $ \r s -> first f <$> m r s
  172 
  173 
  174 ------------------------------------------------------------------------------
  175 -- | Applicative instance
  176 instance (Monad m, Functor m) => Applicative (TemplateMonad m) where
  177     pure = return
  178     (<*>) = ap
  179 
  180 
  181 ------------------------------------------------------------------------------
  182 -- | Monad instance
  183 instance Monad m => Monad (TemplateMonad m) where
  184     return a = TemplateMonad (\_ s -> return (a, s))
  185     TemplateMonad m >>= k = TemplateMonad $ \r s -> do
  186         (a, s') <- m r s
  187         runTemplateMonad (k a) r s'
  188 
  189 
  190 ------------------------------------------------------------------------------
  191 -- | MonadIO instance
  192 instance MonadIO m => MonadIO (TemplateMonad m) where
  193     liftIO = lift . liftIO
  194 
  195 
  196 ------------------------------------------------------------------------------
  197 -- | MonadTrans instance
  198 instance MonadTrans TemplateMonad where
  199     lift m = TemplateMonad $ \_ s -> do
  200         a <- m
  201         return (a, s)
  202 
  203 
  204 ------------------------------------------------------------------------------
  205 -- | MonadFix passthrough instance
  206 instance MonadFix m => MonadFix (TemplateMonad m) where
  207     mfix f = TemplateMonad $ \r s ->
  208         mfix $ \ (a, _) -> runTemplateMonad (f a) r s
  209 
  210 
  211 ------------------------------------------------------------------------------
  212 -- | Alternative passthrough instance
  213 instance (Functor m, MonadPlus m) => Alternative (TemplateMonad m) where
  214     empty = mzero
  215     (<|>) = mplus
  216 
  217 
  218 ------------------------------------------------------------------------------
  219 -- | MonadPlus passthrough instance
  220 instance MonadPlus m => MonadPlus (TemplateMonad m) where
  221     mzero = lift mzero
  222     m `mplus` n = TemplateMonad $ \r s ->
  223         runTemplateMonad m r s `mplus` runTemplateMonad n r s
  224 
  225 
  226 ------------------------------------------------------------------------------
  227 -- | MonadState passthrough instance
  228 instance MonadState s m => MonadState s (TemplateMonad m) where
  229     get = lift get
  230     put = lift . put
  231 
  232 
  233 ------------------------------------------------------------------------------
  234 -- | MonadReader passthrough instance
  235 instance MonadReader r m => MonadReader r (TemplateMonad m) where
  236     ask = TemplateMonad $ \_ s -> do
  237             r <- ask
  238             return (r,s)
  239     local f (TemplateMonad m) =
  240         TemplateMonad $ \r s -> local f (m r s)
  241 
  242 
  243 ------------------------------------------------------------------------------
  244 -- | Helper for MonadError instance.
  245 liftCatch :: (m (a,TemplateState m)
  246               -> (e -> m (a,TemplateState m))
  247               -> m (a,TemplateState m))
  248           -> TemplateMonad m a
  249           -> (e -> TemplateMonad m a)
  250           -> TemplateMonad m a
  251 liftCatch ce m h =
  252     TemplateMonad $ \r s ->
  253         (runTemplateMonad m r s `ce`
  254         (\e -> runTemplateMonad (h e) r s))
  255 
  256 
  257 ------------------------------------------------------------------------------
  258 -- | MonadError passthrough instance
  259 instance (MonadError e m) => MonadError e (TemplateMonad m) where
  260     throwError = lift . throwError
  261     catchError = liftCatch catchError
  262 
  263 
  264 ------------------------------------------------------------------------------
  265 -- | Helper for MonadCont instance.
  266 liftCallCC :: ((((a,TemplateState m) -> m (b, TemplateState m))
  267                   -> m (a, TemplateState m))
  268                 -> m (a, TemplateState m))
  269            -> ((a -> TemplateMonad m b) -> TemplateMonad m a)
  270            -> TemplateMonad m a
  271 liftCallCC ccc f = TemplateMonad $ \r s ->
  272     ccc $ \c ->
  273     runTemplateMonad (f (\a -> TemplateMonad $ \_ _ -> c (a, s))) r s
  274 
  275 
  276 ------------------------------------------------------------------------------
  277 -- | MonadCont passthrough instance
  278 instance (MonadCont m) => MonadCont (TemplateMonad m) where
  279     callCC = liftCallCC callCC
  280 
  281 
  282 ------------------------------------------------------------------------------
  283 -- | The Typeable instance is here so Heist can be dynamically executed with
  284 -- Hint.
  285 templateMonadTyCon :: TyCon
  286 templateMonadTyCon = mkTyCon "Text.Templating.Heist.TemplateMonad"
  287 {-# NOINLINE templateMonadTyCon #-}
  288 
  289 instance (Typeable1 m) => Typeable1 (TemplateMonad m) where
  290     typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())]
  291 
  292 
  293 ------------------------------------------------------------------------------
  294 -- Functions for our monad.
  295 ------------------------------------------------------------------------------
  296 
  297 
  298 ------------------------------------------------------------------------------
  299 -- | Gets the node currently being processed.
  300 --
  301 --   > <speech author="Shakespeare">
  302 --   >   To sleep, perchance to dream.
  303 --   > </speech>
  304 --
  305 -- When you call @getParamNode@ inside the code for the @speech@ splice, it
  306 -- returns the Node for the @speech@ tag and its children.  @getParamNode >>=
  307 -- childNodes@ returns a list containing one 'TextNode' containing part of
  308 -- Hamlet's speech.  @liftM (getAttribute \"author\") getParamNode@ would
  309 -- return @Just "Shakespeare"@.
  310 getParamNode :: Monad m => TemplateMonad m X.Node
  311 getParamNode = TemplateMonad $ \r s -> return (r,s)
  312 
  313 
  314 ------------------------------------------------------------------------------
  315 -- | TemplateMonad's 'local'.
  316 localParamNode :: Monad m
  317                => (X.Node -> X.Node)
  318                -> TemplateMonad m a
  319                -> TemplateMonad m a
  320 localParamNode f m = TemplateMonad $ \r s -> runTemplateMonad m (f r) s
  321 
  322 
  323 ------------------------------------------------------------------------------
  324 -- | TemplateMonad's 'gets'.
  325 getsTS :: Monad m => (TemplateState m -> r) -> TemplateMonad m r
  326 getsTS f = TemplateMonad $ \_ s -> return (f s, s)
  327 
  328 
  329 ------------------------------------------------------------------------------
  330 -- | TemplateMonad's 'get'.
  331 getTS :: Monad m => TemplateMonad m (TemplateState m)
  332 getTS = TemplateMonad $ \_ s -> return (s, s)
  333 
  334 
  335 ------------------------------------------------------------------------------
  336 -- | TemplateMonad's 'put'.
  337 putTS :: Monad m => TemplateState m -> TemplateMonad m ()
  338 putTS s = TemplateMonad $ \_ _ -> return ((), s)
  339 
  340 
  341 ------------------------------------------------------------------------------
  342 -- | TemplateMonad's 'modify'.
  343 modifyTS :: Monad m
  344                     => (TemplateState m -> TemplateState m)
  345                     -> TemplateMonad m ()
  346 modifyTS f = TemplateMonad $ \_ s -> return ((), f s)
  347 
  348 
  349 ------------------------------------------------------------------------------
  350 -- | Restores the TemplateState.  This function is almost like putTS except it
  351 -- preserves the current doctypes.  You should use this function instead of
  352 -- @putTS@ to restore an old state.  This was needed because doctypes needs to
  353 -- be in a "global scope" as opposed to the template call "local scope" of
  354 -- state items such as recursionDepth, curContext, and spliceMap.
  355 restoreTS :: Monad m => TemplateState m -> TemplateMonad m ()
  356 restoreTS old = modifyTS (\cur -> old { _doctypes = _doctypes cur })
  357 
  358 
  359 ------------------------------------------------------------------------------
  360 -- | Abstracts the common pattern of running a TemplateMonad computation with
  361 -- a modified template state.
  362 localTS :: Monad m
  363         => (TemplateState m -> TemplateState m)
  364         -> TemplateMonad m a
  365         -> TemplateMonad m a
  366 localTS f k = do
  367     ts <- getTS
  368     putTS $ f ts
  369     res <- k
  370     restoreTS ts
  371     return res
  372