Merge branch 'master' of https://github.com/jaspervdj/hakyll

6 files changed, 110 insertions, 85 deletions

diff --git a/lib/Hakyll/Web/Html.hs b/lib/Hakyll/Web/Html.hs
index 8cbfaa3..7aa3804 100644
--- a/lib/Hakyll/Web/Html.hs
+++ b/lib/Hakyll/Web/Html.hs
@@ -7,6 +7,7 @@ module Hakyll.Web.Html
 
       -- * Headers
     , demoteHeaders
+    , demoteHeadersBy
 
       -- * Url manipulation
     , getUrls
@@ -50,13 +51,20 @@ withTagList f = renderTags' . f . parseTags'
 --------------------------------------------------------------------------------
 -- | Map every @h1@ to an @h2@, @h2@ to @h3@, etc.
 demoteHeaders :: String -> String
-demoteHeaders = withTags $ \tag -> case tag of
+demoteHeaders = demoteHeadersBy 1
+
+--------------------------------------------------------------------------------
+-- | Maps any @hN@ to an @hN+amount@ for any @amount > 0 && 1 <= N+amount <= 6@.
+demoteHeadersBy :: Int -> String -> String
+demoteHeadersBy amount
+  | amount < 1 = id
+  | otherwise = withTags $ \tag -> case tag of
     TS.TagOpen t a -> TS.TagOpen (demote t) a
     TS.TagClose t  -> TS.TagClose (demote t)
     t              -> t
   where
     demote t@['h', n]
-        | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + 1)]
+        | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + amount)]
         | otherwise = t
     demote t        = t
 
diff --git a/lib/Hakyll/Web/Pandoc.hs b/lib/Hakyll/Web/Pandoc.hs
index 5f04de4..372465b 100644
--- a/lib/Hakyll/Web/Pandoc.hs
+++ b/lib/Hakyll/Web/Pandoc.hs
@@ -8,6 +8,8 @@ module Hakyll.Web.Pandoc
     , writePandocWith
     , renderPandoc
     , renderPandocWith
+    , renderPandocWithTransform
+    , renderPandocWithTransformM
 
       -- * Derived compilers
     , pandocCompiler
@@ -104,6 +106,32 @@ renderPandocWith ropt wopt item =
 
 
 --------------------------------------------------------------------------------
+-- | An extension of `renderPandocWith`, which allows you to specify a custom
+-- Pandoc transformation on the input `Item`.
+-- Useful if you want to do your own transformations before running 
+-- custom Pandoc transformations, e.g. using a `funcField` to transform raw content.
+renderPandocWithTransform :: ReaderOptions -> WriterOptions
+                    -> (Pandoc -> Pandoc)
+                    -> Item String
+                    -> Compiler (Item String)
+renderPandocWithTransform ropt wopt f = 
+    renderPandocWithTransformM ropt wopt (return . f) 
+
+
+--------------------------------------------------------------------------------
+-- | Similar to `renderPandocWithTransform`, but the Pandoc transformation is
+-- monadic. This is useful when you want the pandoc
+-- transformation to use the `Compiler` information such as routes,
+-- metadata, etc. along with your own transformations beforehand.
+renderPandocWithTransformM :: ReaderOptions -> WriterOptions
+                    -> (Pandoc -> Compiler Pandoc)
+                    -> Item String
+                    -> Compiler (Item String)
+renderPandocWithTransformM ropt wopt f i = 
+    writePandocWith wopt <$> (traverse f =<< readPandocWith ropt i) 
+
+
+--------------------------------------------------------------------------------
 -- | Read a page render using pandoc
 pandocCompiler :: Compiler (Item String)
 pandocCompiler =
@@ -137,9 +165,8 @@ pandocCompilerWithTransform ropt wopt f =
 pandocCompilerWithTransformM :: ReaderOptions -> WriterOptions
                     -> (Pandoc -> Compiler Pandoc)
                     -> Compiler (Item String)
-pandocCompilerWithTransformM ropt wopt f =
-    writePandocWith wopt <$>
-        (traverse f =<< readPandocWith ropt =<< getResourceBody)
+pandocCompilerWithTransformM ropt wopt f = 
+    getResourceBody >>= renderPandocWithTransformM ropt wopt f
 
 
 --------------------------------------------------------------------------------
diff --git a/lib/Hakyll/Web/Pandoc/Biblio.hs b/lib/Hakyll/Web/Pandoc/Biblio.hs
index 5127d88..566c706 100644
--- a/lib/Hakyll/Web/Pandoc/Biblio.hs
+++ b/lib/Hakyll/Web/Pandoc/Biblio.hs
@@ -12,6 +12,7 @@
 {-# LANGUAGE Arrows                     #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
 module Hakyll.Web.Pandoc.Biblio
     ( CSL
     , cslCompiler
@@ -23,33 +24,31 @@ module Hakyll.Web.Pandoc.Biblio
 
 
 --------------------------------------------------------------------------------
-import           Control.Monad            (liftM, replicateM)
-import           Data.Binary              (Binary (..))
-import           Data.Typeable            (Typeable)
+import           Control.Monad                 (liftM)
+import           Data.Binary                   (Binary (..))
+import qualified Data.ByteString               as B
+import qualified Data.ByteString.Lazy          as BL
+import qualified Data.Map                      as Map
+import qualified Data.Time                     as Time
+import           Data.Typeable                 (Typeable)
 import           Hakyll.Core.Compiler
 import           Hakyll.Core.Compiler.Internal
 import           Hakyll.Core.Identifier
 import           Hakyll.Core.Item
-import           Hakyll.Core.Provider
 import           Hakyll.Core.Writable
 import           Hakyll.Web.Pandoc
-import           Hakyll.Web.Pandoc.Binary ()
-import qualified Text.CSL                 as CSL
-import           Text.CSL.Pandoc          (processCites)
-import           Text.Pandoc              (Pandoc, ReaderOptions (..),
-                                           enableExtension, Extension (..))
+import           Text.Pandoc                   (Extension (..), Pandoc,
+                                                ReaderOptions (..),
+                                                enableExtension)
+import qualified Text.Pandoc                   as Pandoc
+import qualified Text.Pandoc.Citeproc          as Pandoc (processCitations)
 
 
 --------------------------------------------------------------------------------
-data CSL = CSL
-    deriving (Show, Typeable)
+newtype CSL = CSL {unCSL :: B.ByteString}
+    deriving (Binary, Show, Typeable)
 
 
---------------------------------------------------------------------------------
-instance Binary CSL where
-    put CSL = return ()
-    get     = return CSL
-
 
 --------------------------------------------------------------------------------
 instance Writable CSL where
@@ -59,21 +58,12 @@ instance Writable CSL where
 
 --------------------------------------------------------------------------------
 cslCompiler :: Compiler (Item CSL)
-cslCompiler = makeItem CSL
-
-
---------------------------------------------------------------------------------
-newtype Biblio = Biblio [CSL.Reference]
-    deriving (Show, Typeable)
+cslCompiler = fmap (CSL . BL.toStrict) <$> getResourceLBS
 
 
 --------------------------------------------------------------------------------
-instance Binary Biblio where
-    -- Ugly.
-    get             = do
-        len <- get
-        Biblio <$> replicateM len get
-    put (Biblio rs) = put (length rs) >> mapM_ put rs
+newtype Biblio = Biblio {unBiblio :: B.ByteString}
+    deriving (Binary, Show, Typeable)
 
 
 --------------------------------------------------------------------------------
@@ -84,12 +74,7 @@ instance Writable Biblio where
 
 --------------------------------------------------------------------------------
 biblioCompiler :: Compiler (Item Biblio)
-biblioCompiler = do
-    filePath <- getResourceFilePath
-    makeItem =<< unsafeCompiler (Biblio <$> CSL.readBiblioFile idpred filePath)
-  where
-    -- This is a filter on citations.  We include all citations.
-    idpred = const True
+biblioCompiler = fmap (Biblio . BL.toStrict) <$> getResourceLBS
 
 
 --------------------------------------------------------------------------------
@@ -99,21 +84,45 @@ readPandocBiblio :: ReaderOptions
                  -> (Item String)
                  -> Compiler (Item Pandoc)
 readPandocBiblio ropt csl biblio item = do
-    -- Parse CSL file, if given
-    provider <- compilerProvider <$> compilerAsk
-    style <- unsafeCompiler $
-             CSL.readCSLFile Nothing . (resourceFilePath provider) . itemIdentifier $ csl
+    -- It's not straightforward to use the Pandoc API as of 2.11 to deal with
+    -- citations, since it doesn't export many things in 'Text.Pandoc.Citeproc'.
+    -- The 'citeproc' package is also hard to use.
+    --
+    -- So instead, we try treating Pandoc as a black box.  Pandoc can read
+    -- specific csl and bilbio files based on metadata keys.
+    --
+    -- So we load the CSL and Biblio files and pass them to Pandoc using the
+    -- ersatz filesystem.
+    Pandoc.Pandoc (Pandoc.Meta meta) blocks <- itemBody <$>
+        readPandocWith ropt item
+
+    let cslFile = Pandoc.FileInfo zeroTime . unCSL $ itemBody csl
+        bibFile = Pandoc.FileInfo zeroTime . unBiblio $ itemBody biblio
+        addBiblioFiles = \st -> st
+            { Pandoc.stFiles =
+                Pandoc.insertInFileTree "_hakyll/style.csl" cslFile .
+                Pandoc.insertInFileTree "_hakyll/refs.bib" bibFile $
+                Pandoc.stFiles st
+            }
+        biblioMeta = Pandoc.Meta .
+            Map.insert "csl" (Pandoc.MetaString "_hakyll/style.csl") .
+            Map.insert "bibliography" (Pandoc.MetaString "_hakyll/refs.bib") $
+            meta
+        errOrPandoc = Pandoc.runPure $ do
+            Pandoc.modifyPureState addBiblioFiles
+            Pandoc.processCitations $ Pandoc.Pandoc biblioMeta blocks
 
-    -- We need to know the citation keys, add then *before* actually parsing the
-    -- actual page. If we don't do this, pandoc won't even consider them
-    -- citations!
-    let Biblio refs = itemBody biblio
-    pandoc <- itemBody <$> readPandocWith ropt item
-    let pandoc' = processCites style refs pandoc
+    pandoc <- case errOrPandoc of
+        Left  e -> compilerThrow ["Error during processCitations: " ++ show e]
+        Right x -> return x
 
-    return $ fmap (const pandoc') item
+    return $ fmap (const pandoc) item
+
+  where
+    zeroTime = Time.UTCTime (toEnum 0) 0
 
 --------------------------------------------------------------------------------
+-- | Compiles a markdown file via Pandoc. Requires the .csl and .bib files to be known to the compiler via match statements.
 pandocBiblioCompiler :: String -> String -> Compiler (Item String)
 pandocBiblioCompiler cslFileName bibFileName = do
     csl <- load $ fromFilePath cslFileName
diff --git a/lib/Hakyll/Web/Pandoc/Binary.hs b/lib/Hakyll/Web/Pandoc/Binary.hs
index 033ca9a..3f7f4fb 100644
--- a/lib/Hakyll/Web/Pandoc/Binary.hs
+++ b/lib/Hakyll/Web/Pandoc/Binary.hs
@@ -1,21 +1,20 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE CPP           #-}
 {-# LANGUAGE DeriveGeneric #-}
 module Hakyll.Web.Pandoc.Binary where
 
-import           Data.Binary            (Binary (..))
+import           Data.Binary        (Binary (..))
 
-import qualified Text.CSL               as CSL
-import qualified Text.CSL.Reference     as REF
-import qualified Text.CSL.Style         as STY
-import           Text.Pandoc.Definition
+import           Text.Pandoc
 
 --------------------------------------------------------------------------------
 -- orphans
 
 instance Binary Alignment
 instance Binary Block
-instance Binary CSL.Reference
+instance Binary Caption
+instance Binary Cell
+instance Binary ColSpan
+instance Binary ColWidth
 instance Binary Citation
 instance Binary CitationMode
 instance Binary Format
@@ -24,25 +23,9 @@ instance Binary ListNumberDelim
 instance Binary ListNumberStyle
 instance Binary MathType
 instance Binary QuoteType
-instance Binary REF.CLabel
-instance Binary REF.CNum
-instance Binary REF.Literal
-instance Binary REF.RefDate
-instance Binary REF.RefType
-instance Binary REF.Season
-instance Binary STY.Agent
-instance Binary STY.Formatted
-
-#if MIN_VERSION_pandoc_types(1, 21, 0)
-instance Binary Caption
-instance Binary Cell
-instance Binary ColSpan
-instance Binary ColWidth
 instance Binary Row
 instance Binary RowHeadColumns
 instance Binary RowSpan
 instance Binary TableBody
 instance Binary TableFoot
 instance Binary TableHead
-#endif
-
diff --git a/lib/Hakyll/Web/Tags.hs b/lib/Hakyll/Web/Tags.hs
index aab5d34..ccf34a5 100644
--- a/lib/Hakyll/Web/Tags.hs
+++ b/lib/Hakyll/Web/Tags.hs
@@ -43,6 +43,7 @@
 module Hakyll.Web.Tags
     ( Tags (..)
     , getTags
+    , getTagsByField
     , getCategory
     , buildTagsWith
     , buildTags
@@ -105,11 +106,16 @@ data Tags = Tags
 -- | Obtain tags from a page in the default way: parse them from the @tags@
 -- metadata field. This can either be a list or a comma-separated string.
 getTags :: MonadMetadata m => Identifier -> m [String]
-getTags identifier = do
+getTags = getTagsByField "tags"
+
+-- | Obtain tags from a page by name of the metadata field. These can be a list
+-- or a comma-separated string
+getTagsByField :: MonadMetadata m => String -> Identifier -> m [String]
+getTagsByField fieldName identifier = do
     metadata <- getMetadata identifier
     return $ fromMaybe [] $
-        (lookupStringList "tags" metadata) `mplus`
-        (map trim . splitAll "," <$> lookupString "tags" metadata)
+        (lookupStringList fieldName metadata) `mplus`
+        (map trim . splitAll "," <$> lookupString fieldName metadata)
 
 
 --------------------------------------------------------------------------------
diff --git a/lib/Hakyll/Web/Template/Context.hs b/lib/Hakyll/Web/Template/Context.hs
index 9dd14ff..97f0930 100644
--- a/lib/Hakyll/Web/Template/Context.hs
+++ b/lib/Hakyll/Web/Template/Context.hs
@@ -60,8 +60,7 @@ import           Data.List                     (intercalate, tails)
 import           Data.Semigroup                (Semigroup (..))
 #endif
 import           Data.Time.Clock               (UTCTime (..))
-import           Data.Time.Format              (formatTime)
-import qualified Data.Time.Format              as TF
+import           Data.Time.Format              (formatTime, parseTimeM)
 import           Data.Time.Locale.Compat       (TimeLocale, defaultTimeLocale)
 import           Hakyll.Core.Compiler
 import           Hakyll.Core.Compiler.Internal
@@ -466,10 +465,3 @@ teaserFieldWithSeparator separator key snapshot = field key $ \item -> do
 missingField :: Context a
 missingField = Context $ \k _ _ -> noResult $
     "Missing field '" ++ k ++ "' in context"
-
-parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime
-#if MIN_VERSION_time(1,5,0)
-parseTimeM = TF.parseTimeM
-#else
-parseTimeM _ = TF.parseTime
-#endif