1 files changed, 58 insertions, 3 deletions
diff --git a/src/Text/Pandoc/Templates.hs b/src/Text/Pandoc/Templates.hs
index 8d92e306b..daf9c02fb 100644
--- a/src/Text/Pandoc/Templates.hs
+++ b/src/Text/Pandoc/Templates.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -14,18 +15,61 @@ Utility functions for working with pandoc templates.
 -}
 
 module Text.Pandoc.Templates ( Template
+                             , WithDefaultPartials(..)
+                             , WithPartials(..)
                              , compileTemplate
                              , renderTemplate
+                             , getTemplate
                              , getDefaultTemplate
+                             , compileDefaultTemplate
                              ) where
 
 import Prelude
 import System.FilePath ((<.>), (</>))
-import Text.DocTemplates (Template, compileTemplate, renderTemplate)
-import Text.Pandoc.Class (PandocMonad, readDataFile)
+import Text.DocTemplates (Template, TemplateMonad(..), compileTemplate, renderTemplate)
+import Text.Pandoc.Class (PandocMonad, readDataFile, fetchItem,
+                          CommonState(..), getCommonState, modifyCommonState)
 import qualified Text.Pandoc.UTF8 as UTF8
+import Control.Monad.Except (catchError, throwError)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Text.Pandoc.Error
+
+-- | Wrap a Monad in this if you want partials to
+-- be taken only from the default data files.
+newtype WithDefaultPartials m a = WithDefaultPartials { runWithDefaultPartials :: m a }
+ deriving (Functor, Applicative, Monad)
+
+-- | Wrap a Monad in this if you want partials to
+-- be looked for locally (or, when the main template
+-- is at a URL, via HTTP), falling back to default data files.
+newtype WithPartials m a = WithPartials { runWithPartials :: m a }
+ deriving (Functor, Applicative, Monad)
+
+instance PandocMonad m => TemplateMonad (WithDefaultPartials m) where
+  getPartial fp = WithDefaultPartials $
+    UTF8.toText <$> readDataFile fp
+
+instance PandocMonad m => TemplateMonad (WithPartials m) where
+  getPartial fp = WithPartials $ getTemplate fp
+
+-- | Retrieve text for a template.
+getTemplate :: PandocMonad m => FilePath -> m Text
+getTemplate tp = UTF8.toText <$>
+  ((do surl <- stSourceURL <$> getCommonState
+       -- we don't want to look for templates remotely
+       -- unless the full URL is specified:
+       modifyCommonState $ \st -> st{
+         stSourceURL = Nothing }
+       (bs, _) <- fetchItem $ T.pack tp
+       modifyCommonState $ \st -> st{
+         stSourceURL = surl }
+       return bs)
+   `catchError`
+   (\e -> case e of
+             PandocResourceNotFound _ ->
+                readDataFile ("templates" </> tp)
+             _ -> throwError e))
 
 -- | Get default template for the specified writer.
 getDefaultTemplate :: PandocMonad m
@@ -55,4 +99,15 @@ getDefaultTemplate writer = do
          let fname = "templates" </> "default" <.> T.unpack format
          UTF8.toText <$> readDataFile fname
 
-
+-- | Get and compile default template for the specified writer.
+-- Raise an error on compilation failure.
+compileDefaultTemplate :: PandocMonad m
+                       => Text
+                       -> m (Template Text)
+compileDefaultTemplate writer = do
+  res <- getDefaultTemplate writer >>=
+          runWithDefaultPartials .
+           compileTemplate ("templates/default." <> T.unpack writer)
+  case res of
+    Left e   -> throwError $ PandocTemplateError (T.pack e)
+    Right t  -> return t