--------------------------------------------------------------------------------
-- | Wraps pandocs bibiliography handling
--
-- In order to add a bibliography, you will need a bibliography file (e.g.
-- @.bib@) and a CSL file (@.csl@). Both need to be compiled with their
-- respective compilers ('biblioCompiler' and 'cslCompiler'). Then, you can
-- refer to these files when you use 'readPandocBiblio'. This function also
-- takes the reader options for completeness -- you can use
-- 'defaultHakyllReaderOptions' if you're unsure. If you already read the
-- source into a 'Pandoc' type and need to add processing for the bibliography,
-- you can use 'processPandocBiblio' instead.
-- 'pandocBiblioCompiler' is a convenience wrapper which works like 'pandocCompiler',
-- but also takes paths to compiled bibliography and csl files;
-- 'pandocBibliosCompiler' is similar but instead takes a glob pattern for bib files.
{-# LANGUAGE Arrows                     #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
module Hakyll.Web.Pandoc.Biblio
    ( CSL (..)
    , cslCompiler
    , Biblio (..)
    , biblioCompiler
    , readPandocBiblio
    , readPandocBiblios
    , processPandocBiblio
    , processPandocBiblios
    , pandocBiblioCompiler
    , pandocBibliosCompiler
    ) where


--------------------------------------------------------------------------------
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 qualified Data.Text                     as T (pack)
import           Data.Typeable                 (Typeable)
import           Hakyll.Core.Compiler
import           Hakyll.Core.Compiler.Internal
import           Hakyll.Core.Identifier
import           Hakyll.Core.Identifier.Pattern (fromGlob)
import           Hakyll.Core.Item
import           Hakyll.Core.Metadata          (getMetadataField)
import           Hakyll.Core.Writable
import           Hakyll.Web.Pandoc
import           Text.Pandoc                   (Extension (..), Pandoc,
                                                PandocPure, ReaderOptions (..),
                                                enableExtension)
import qualified Text.Pandoc                   as Pandoc
import           Text.Pandoc.Builder           (setMeta)
import qualified Text.Pandoc.Citeproc          as Pandoc (processCitations)
import           Text.Pandoc.Walk              (Walkable (query))
import           System.FilePath               (addExtension, takeExtension)


--------------------------------------------------------------------------------
newtype CSL = CSL {CSL -> ByteString
unCSL :: B.ByteString}
    deriving (Get CSL
[CSL] -> Put
CSL -> Put
(CSL -> Put) -> Get CSL -> ([CSL] -> Put) -> Binary CSL
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: CSL -> Put
put :: CSL -> Put
$cget :: Get CSL
get :: Get CSL
$cputList :: [CSL] -> Put
putList :: [CSL] -> Put
Binary, Int -> CSL -> ShowS
[CSL] -> ShowS
CSL -> String
(Int -> CSL -> ShowS)
-> (CSL -> String) -> ([CSL] -> ShowS) -> Show CSL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CSL -> ShowS
showsPrec :: Int -> CSL -> ShowS
$cshow :: CSL -> String
show :: CSL -> String
$cshowList :: [CSL] -> ShowS
showList :: [CSL] -> ShowS
Show, Typeable)



--------------------------------------------------------------------------------
instance Writable CSL where
    -- Shouldn't be written.
    write :: String -> Item CSL -> IO ()
write String
_ Item CSL
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


--------------------------------------------------------------------------------
cslCompiler :: Compiler (Item CSL)
cslCompiler :: Compiler (Item CSL)
cslCompiler = (LazyByteString -> CSL) -> Item LazyByteString -> Item CSL
forall a b. (a -> b) -> Item a -> Item b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> CSL
CSL (ByteString -> CSL)
-> (LazyByteString -> ByteString) -> LazyByteString -> CSL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> ByteString
BL.toStrict) (Item LazyByteString -> Item CSL)
-> Compiler (Item LazyByteString) -> Compiler (Item CSL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compiler (Item LazyByteString)
getResourceLBS


--------------------------------------------------------------------------------
newtype Biblio = Biblio {Biblio -> ByteString
unBiblio :: B.ByteString}
    deriving (Get Biblio
[Biblio] -> Put
Biblio -> Put
(Biblio -> Put) -> Get Biblio -> ([Biblio] -> Put) -> Binary Biblio
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: Biblio -> Put
put :: Biblio -> Put
$cget :: Get Biblio
get :: Get Biblio
$cputList :: [Biblio] -> Put
putList :: [Biblio] -> Put
Binary, Int -> Biblio -> ShowS
[Biblio] -> ShowS
Biblio -> String
(Int -> Biblio -> ShowS)
-> (Biblio -> String) -> ([Biblio] -> ShowS) -> Show Biblio
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Biblio -> ShowS
showsPrec :: Int -> Biblio -> ShowS
$cshow :: Biblio -> String
show :: Biblio -> String
$cshowList :: [Biblio] -> ShowS
showList :: [Biblio] -> ShowS
Show, Typeable)


--------------------------------------------------------------------------------
instance Writable Biblio where
    -- Shouldn't be written.
    write :: String -> Item Biblio -> IO ()
write String
_ Item Biblio
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


--------------------------------------------------------------------------------
biblioCompiler :: Compiler (Item Biblio)
biblioCompiler :: Compiler (Item Biblio)
biblioCompiler = (LazyByteString -> Biblio) -> Item LazyByteString -> Item Biblio
forall a b. (a -> b) -> Item a -> Item b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Biblio
Biblio (ByteString -> Biblio)
-> (LazyByteString -> ByteString) -> LazyByteString -> Biblio
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> ByteString
BL.toStrict) (Item LazyByteString -> Item Biblio)
-> Compiler (Item LazyByteString) -> Compiler (Item Biblio)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compiler (Item LazyByteString)
getResourceLBS


--------------------------------------------------------------------------------
readPandocBiblio :: ReaderOptions
                 -> Item CSL
                 -> Item Biblio
                 -> (Item String)
                 -> Compiler (Item Pandoc)
readPandocBiblio :: ReaderOptions
-> Item CSL -> Item Biblio -> Item String -> Compiler (Item Pandoc)
readPandocBiblio ReaderOptions
ropt Item CSL
csl Item Biblio
biblio = ReaderOptions
-> Item CSL
-> [Item Biblio]
-> Item String
-> Compiler (Item Pandoc)
readPandocBiblios ReaderOptions
ropt Item CSL
csl [Item Biblio
biblio]

readPandocBiblios :: ReaderOptions
                  -> Item CSL
                  -> [Item Biblio]
                  -> (Item String)
                  -> Compiler (Item Pandoc)
readPandocBiblios :: ReaderOptions
-> Item CSL
-> [Item Biblio]
-> Item String
-> Compiler (Item Pandoc)
readPandocBiblios ReaderOptions
ropt Item CSL
csl [Item Biblio]
biblios Item String
item = do
  pandoc <- ReaderOptions -> Item String -> Compiler (Item Pandoc)
readPandocWith ReaderOptions
ropt Item String
item
  processPandocBiblios csl biblios pandoc


--------------------------------------------------------------------------------

-- | Process a bibliography file with the given style.
--
-- This function supports pandoc's
-- <https://pandoc.org/chunkedhtml-demo/9.6-including-uncited-items-in-the-bibliography.html nocite>
-- functionality when there is a @nocite@ metadata field present.
--
-- ==== __Example__
--
-- In your main function, first compile the respective files:
--
-- > main = hakyll $ do
-- >   …
-- >   match "style.csl" $ compile cslCompiler
-- >   match "bib.bib"   $ compile biblioCompiler
--
-- Then, create a function like the following:
--
-- > processBib :: Item Pandoc -> Compiler (Item Pandoc)
-- > processBib pandoc = do
-- >   csl <- load @CSL    "bib/style.csl"
-- >   bib <- load @Biblio "bib/bibliography.bib"
-- >   processPandocBiblio csl bib pandoc
--
-- Now, feed this function to your pandoc compiler:
--
-- > myCompiler :: Compiler (Item String)
-- > myCompiler = pandocItemCompilerWithTransformM myReader myWriter processBib
processPandocBiblio :: Item CSL
                    -> Item Biblio
                    -> (Item Pandoc)
                    -> Compiler (Item Pandoc)
processPandocBiblio :: Item CSL -> Item Biblio -> Item Pandoc -> Compiler (Item Pandoc)
processPandocBiblio Item CSL
csl Item Biblio
biblio = Item CSL -> [Item Biblio] -> Item Pandoc -> Compiler (Item Pandoc)
processPandocBiblios Item CSL
csl [Item Biblio
biblio]

-- | Like 'processPandocBiblio', which see, but support multiple bibliography
-- files.
processPandocBiblios :: Item CSL
                     -> [Item Biblio]
                     -> (Item Pandoc)
                     -> Compiler (Item Pandoc)
processPandocBiblios :: Item CSL -> [Item Biblio] -> Item Pandoc -> Compiler (Item Pandoc)
processPandocBiblios Item CSL
csl [Item Biblio]
biblios Item Pandoc
item' = do
    -- 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.

    -- Honour nocite metadata fields
    item <- Compiler Identifier
getUnderlying Compiler Identifier
-> (Identifier -> Compiler (Maybe String))
-> Compiler (Maybe String)
forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Identifier -> String -> Compiler (Maybe String)
forall (m :: * -> *).
MonadMetadata m =>
Identifier -> String -> m (Maybe String)
`getMetadataField` String
"nocite") Compiler (Maybe String)
-> (Maybe String -> Compiler (Item Pandoc))
-> Compiler (Item Pandoc)
forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe String
Nothing -> Item Pandoc -> Compiler (Item Pandoc)
forall a. a -> Compiler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Item Pandoc
item'
        Just String
x  -> (Pandoc -> Compiler Pandoc)
-> Item Pandoc -> Compiler (Item Pandoc)
forall a b. (a -> Compiler b) -> Item a -> Compiler (Item b)
withItemBody (Pandoc -> Compiler Pandoc
forall a. a -> Compiler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pandoc -> Compiler Pandoc)
-> (Pandoc -> Pandoc) -> Pandoc -> Compiler Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String -> Pandoc -> Pandoc
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
forall b. ToMetaValue b => Text -> b -> Pandoc -> Pandoc
setMeta Text
"nocite" String
x) Item Pandoc
item'

    let Pandoc.Pandoc (Pandoc.Meta meta) blocks = itemBody item
        cslFile = UTCTime -> ByteString -> FileInfo
Pandoc.FileInfo UTCTime
zeroTime (ByteString -> FileInfo) -> (CSL -> ByteString) -> CSL -> FileInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSL -> ByteString
unCSL (CSL -> FileInfo) -> CSL -> FileInfo
forall a b. (a -> b) -> a -> b
$ Item CSL -> CSL
forall a. Item a -> a
itemBody Item CSL
csl
        bibFiles = (Integer -> Item Biblio -> (String, FileInfo))
-> [Integer] -> [Item Biblio] -> [(String, FileInfo)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Integer
x Item Biblio
y ->
            ( String -> ShowS
addExtension (String
"_hakyll/bibliography-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
x)
                           (ShowS
takeExtension ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Identifier -> String
toFilePath (Identifier -> String) -> Identifier -> String
forall a b. (a -> b) -> a -> b
$ Item Biblio -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item Biblio
y)
            , UTCTime -> ByteString -> FileInfo
Pandoc.FileInfo UTCTime
zeroTime (ByteString -> FileInfo)
-> (Item Biblio -> ByteString) -> Item Biblio -> FileInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Biblio -> ByteString
unBiblio (Biblio -> ByteString)
-> (Item Biblio -> Biblio) -> Item Biblio -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item Biblio -> Biblio
forall a. Item a -> a
itemBody (Item Biblio -> FileInfo) -> Item Biblio -> FileInfo
forall a b. (a -> b) -> a -> b
$ Item Biblio
y
            )
          )
          [Integer
0 :: Integer ..]
          [Item Biblio]
biblios

        stFiles = ((String, FileInfo)
 -> (FileTree -> FileTree) -> FileTree -> FileTree)
-> (FileTree -> FileTree)
-> [(String, FileInfo)]
-> FileTree
-> FileTree
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((FileTree -> FileTree)
-> (FileTree -> FileTree) -> FileTree -> FileTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((FileTree -> FileTree)
 -> (FileTree -> FileTree) -> FileTree -> FileTree)
-> ((String, FileInfo) -> FileTree -> FileTree)
-> (String, FileInfo)
-> (FileTree -> FileTree)
-> FileTree
-> FileTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> FileInfo -> FileTree -> FileTree)
-> (String, FileInfo) -> FileTree -> FileTree
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> FileInfo -> FileTree -> FileTree
Pandoc.insertInFileTree)
                    (String -> FileInfo -> FileTree -> FileTree
Pandoc.insertInFileTree String
"_hakyll/style.csl" FileInfo
cslFile)
                    [(String, FileInfo)]
bibFiles

        addBiblioFiles = \PureState
st -> PureState
st { Pandoc.stFiles = stFiles $ Pandoc.stFiles st }

        biblioMeta = Map Text MetaValue -> Meta
Pandoc.Meta (Map Text MetaValue -> Meta)
-> (Map Text MetaValue -> Map Text MetaValue)
-> Map Text MetaValue
-> Meta
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            Text -> MetaValue -> Map Text MetaValue -> Map Text MetaValue
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"csl" (Text -> MetaValue
Pandoc.MetaString Text
"_hakyll/style.csl") (Map Text MetaValue -> Map Text MetaValue)
-> (Map Text MetaValue -> Map Text MetaValue)
-> Map Text MetaValue
-> Map Text MetaValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            Text -> MetaValue -> Map Text MetaValue -> Map Text MetaValue
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"bibliography"
              ([MetaValue] -> MetaValue
Pandoc.MetaList ([MetaValue] -> MetaValue) -> [MetaValue] -> MetaValue
forall a b. (a -> b) -> a -> b
$ ((String, FileInfo) -> MetaValue)
-> [(String, FileInfo)] -> [MetaValue]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> MetaValue
Pandoc.MetaString (Text -> MetaValue)
-> ((String, FileInfo) -> Text) -> (String, FileInfo) -> MetaValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> ((String, FileInfo) -> String) -> (String, FileInfo) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, FileInfo) -> String
forall a b. (a, b) -> a
fst) [(String, FileInfo)]
bibFiles) (Map Text MetaValue -> Meta) -> Map Text MetaValue -> Meta
forall a b. (a -> b) -> a -> b
$
            Map Text MetaValue
meta

    pandoc <- do
        let p = Meta -> [Block] -> Pandoc
Pandoc.Pandoc Meta
biblioMeta [Block]
blocks
        p' <- case Pandoc.lookupMeta "nocite" biblioMeta of
            Just (Pandoc.MetaString Text
nocite) -> do
                Pandoc.Pandoc _ b <- PandocPure Pandoc -> Compiler Pandoc
forall a. PandocPure a -> Compiler a
runPandoc (PandocPure Pandoc -> Compiler Pandoc)
-> PandocPure Pandoc -> Compiler Pandoc
forall a b. (a -> b) -> a -> b
$
                    ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *) a.
(PandocMonad m, ToSources a) =>
ReaderOptions -> a -> m Pandoc
Pandoc.readMarkdown ReaderOptions
defaultHakyllReaderOptions Text
nocite
                let nocites = [Inline] -> MetaValue
Pandoc.MetaInlines ([Inline] -> MetaValue)
-> ((Inline -> [Inline]) -> [Inline])
-> (Inline -> [Inline])
-> MetaValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Inline -> [Inline]) -> [Block] -> [Inline])
-> [Block] -> (Inline -> [Inline]) -> [Inline]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Inline -> [Inline]) -> [Block] -> [Inline]
forall c. Monoid c => (Inline -> c) -> [Block] -> c
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
query [Block]
b ((Inline -> [Inline]) -> MetaValue)
-> (Inline -> [Inline]) -> MetaValue
forall a b. (a -> b) -> a -> b
$ \case
                        c :: Inline
c@Pandoc.Cite{} -> [Inline
c]
                        Inline
_               -> []
                return $ setMeta "nocite" nocites p
            Maybe MetaValue
_ -> Pandoc -> Compiler Pandoc
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
p
        runPandoc $ do
            Pandoc.modifyPureState addBiblioFiles
            Pandoc.processCitations p'
    return $ fmap (const pandoc) item

  where
    zeroTime :: UTCTime
zeroTime = Day -> DiffTime -> UTCTime
Time.UTCTime (Int -> Day
forall a. Enum a => Int -> a
toEnum Int
0) DiffTime
0

    runPandoc :: PandocPure a -> Compiler a
    runPandoc :: forall a. PandocPure a -> Compiler a
runPandoc PandocPure a
with = case PandocPure a -> Either PandocError a
forall a. PandocPure a -> Either PandocError a
Pandoc.runPure PandocPure a
with of
        Left  PandocError
e -> [String] -> Compiler a
forall a. [String] -> Compiler a
compilerThrow [String
"Error during processCitations: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PandocError -> String
forall a. Show a => a -> String
show PandocError
e]
        Right a
x -> a -> Compiler a
forall a. a -> Compiler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

--------------------------------------------------------------------------------
-- | 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 :: String -> String -> Compiler (Item String)
pandocBiblioCompiler String
cslFileName String
bibFileName = do
    csl <- Identifier -> Compiler (Item CSL)
forall a. (Binary a, Typeable a) => Identifier -> Compiler (Item a)
load (Identifier -> Compiler (Item CSL))
-> Identifier -> Compiler (Item CSL)
forall a b. (a -> b) -> a -> b
$ String -> Identifier
fromFilePath String
cslFileName
    bib <- load $ fromFilePath bibFileName
    liftM writePandoc
        (getResourceBody >>= readPandocBiblio ropt csl bib)
    where ropt :: ReaderOptions
ropt = ReaderOptions
defaultHakyllReaderOptions
            { -- The following option enables citation rendering
              readerExtensions = enableExtension Ext_citations $ readerExtensions defaultHakyllReaderOptions
            }

--------------------------------------------------------------------------------
-- | Compiles a markdown file via Pandoc. Requires the .csl and .bib files to be known to the compiler via match statements.
pandocBibliosCompiler :: String -> String -> Compiler (Item String)
pandocBibliosCompiler :: String -> String -> Compiler (Item String)
pandocBibliosCompiler String
cslFileName String
bibFileName = do
    csl  <- Identifier -> Compiler (Item CSL)
forall a. (Binary a, Typeable a) => Identifier -> Compiler (Item a)
load    (Identifier -> Compiler (Item CSL))
-> Identifier -> Compiler (Item CSL)
forall a b. (a -> b) -> a -> b
$ String -> Identifier
fromFilePath String
cslFileName
    bibs <- loadAll $ fromGlob bibFileName
    liftM writePandoc
        (getResourceBody >>= readPandocBiblios ropt csl bibs)
    where ropt :: ReaderOptions
ropt = ReaderOptions
defaultHakyllReaderOptions
            { -- The following option enables citation rendering
              readerExtensions = enableExtension Ext_citations $ readerExtensions defaultHakyllReaderOptions
            }