{-# 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
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 = (ByteString -> CSL) -> Item ByteString -> 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)
-> (ByteString -> ByteString) -> ByteString -> CSL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict) (Item ByteString -> Item CSL)
-> Compiler (Item ByteString) -> Compiler (Item CSL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compiler (Item ByteString)
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
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 = (ByteString -> Biblio) -> Item ByteString -> 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)
-> (ByteString -> ByteString) -> ByteString -> Biblio
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict) (Item ByteString -> Item Biblio)
-> Compiler (Item ByteString) -> Compiler (Item Biblio)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compiler (Item ByteString)
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
Item Pandoc
pandoc <- ReaderOptions -> Item String -> Compiler (Item Pandoc)
readPandocWith ReaderOptions
ropt Item String
item
Item CSL -> [Item Biblio] -> Item Pandoc -> Compiler (Item Pandoc)
processPandocBiblios Item CSL
csl [Item Biblio]
biblios Item Pandoc
pandoc
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]
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
Item Pandoc
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 Map Text MetaValue
meta) [Block]
blocks = Item Pandoc -> Pandoc
forall a. Item a -> a
itemBody Item Pandoc
item
cslFile :: FileInfo
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 :: [(String, FileInfo)]
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 :: FileTree -> FileTree
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 -> PureState
addBiblioFiles = \PureState
st -> PureState
st { Pandoc.stFiles = stFiles $ Pandoc.stFiles st }
biblioMeta :: Meta
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
pandoc <- do
let p :: Pandoc
p = Meta -> [Block] -> Pandoc
Pandoc.Pandoc Meta
biblioMeta [Block]
blocks
Pandoc
p' <- case Text -> Meta -> Maybe MetaValue
Pandoc.lookupMeta Text
"nocite" Meta
biblioMeta of
Just (Pandoc.MetaString Text
nocite) -> do
Pandoc.Pandoc Meta
_ [Block]
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 :: MetaValue
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
_ -> []
Pandoc -> Compiler Pandoc
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pandoc -> Compiler Pandoc) -> Pandoc -> Compiler Pandoc
forall a b. (a -> b) -> a -> b
$ Text -> MetaValue -> Pandoc -> Pandoc
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
forall b. ToMetaValue b => Text -> b -> Pandoc -> Pandoc
setMeta Text
"nocite" MetaValue
nocites Pandoc
p
Maybe MetaValue
_ -> Pandoc -> Compiler Pandoc
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
p
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
$ do
(PureState -> PureState) -> PandocPure ()
Pandoc.modifyPureState PureState -> PureState
addBiblioFiles
Pandoc -> PandocPure Pandoc
forall (m :: * -> *). PandocMonad m => Pandoc -> m Pandoc
Pandoc.processCitations Pandoc
p'
Item Pandoc -> Compiler (Item Pandoc)
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Item Pandoc -> Compiler (Item Pandoc))
-> Item Pandoc -> Compiler (Item Pandoc)
forall a b. (a -> b) -> a -> b
$ (Pandoc -> Pandoc) -> Item Pandoc -> Item Pandoc
forall a b. (a -> b) -> Item a -> Item b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pandoc -> Pandoc -> Pandoc
forall a b. a -> b -> a
const Pandoc
pandoc) Item 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
pandocBiblioCompiler :: String -> String -> Compiler (Item String)
pandocBiblioCompiler :: String -> String -> Compiler (Item String)
pandocBiblioCompiler String
cslFileName String
bibFileName = do
Item CSL
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
Item Biblio
bib <- Identifier -> Compiler (Item Biblio)
forall a. (Binary a, Typeable a) => Identifier -> Compiler (Item a)
load (Identifier -> Compiler (Item Biblio))
-> Identifier -> Compiler (Item Biblio)
forall a b. (a -> b) -> a -> b
$ String -> Identifier
fromFilePath String
bibFileName
(Item Pandoc -> Item String)
-> Compiler (Item Pandoc) -> Compiler (Item String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Item Pandoc -> Item String
writePandoc
(Compiler (Item String)
getResourceBody Compiler (Item String)
-> (Item 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
>>= ReaderOptions
-> Item CSL -> Item Biblio -> Item String -> Compiler (Item Pandoc)
readPandocBiblio ReaderOptions
ropt Item CSL
csl Item Biblio
bib)
where ropt :: ReaderOptions
ropt = ReaderOptions
defaultHakyllReaderOptions
{
readerExtensions = enableExtension Ext_citations $ readerExtensions defaultHakyllReaderOptions
}
pandocBibliosCompiler :: String -> String -> Compiler (Item String)
pandocBibliosCompiler :: String -> String -> Compiler (Item String)
pandocBibliosCompiler String
cslFileName String
bibFileName = do
Item CSL
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
[Item Biblio]
bibs <- Pattern -> Compiler [Item Biblio]
forall a. (Binary a, Typeable a) => Pattern -> Compiler [Item a]
loadAll (Pattern -> Compiler [Item Biblio])
-> Pattern -> Compiler [Item Biblio]
forall a b. (a -> b) -> a -> b
$ String -> Pattern
fromGlob String
bibFileName
(Item Pandoc -> Item String)
-> Compiler (Item Pandoc) -> Compiler (Item String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Item Pandoc -> Item String
writePandoc
(Compiler (Item String)
getResourceBody Compiler (Item String)
-> (Item 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
>>= ReaderOptions
-> Item CSL
-> [Item Biblio]
-> Item String
-> Compiler (Item Pandoc)
readPandocBiblios ReaderOptions
ropt Item CSL
csl [Item Biblio]
bibs)
where ropt :: ReaderOptions
ropt = ReaderOptions
defaultHakyllReaderOptions
{
readerExtensions = enableExtension Ext_citations $ readerExtensions defaultHakyllReaderOptions
}