{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
module Text.LaTeX.Packages.BibLaTeX
( biblatex
, addbibresource
, cite
, printbibliography
, documentWithDOIReferences
, PlainDOI
, citeDOI
, textc
, textC
, DOIReference
, ReferenceQueryT
, masterBibFile
) where
import Text.LaTeX.Base.Syntax hiding ((<>))
import Text.LaTeX.Base.Class (LaTeXC(..), liftL, fromLaTeX, comm0, raw)
import Text.LaTeX.Base.Render
import Text.LaTeX.Base.Types
import Text.LaTeX.Base.Commands (cite, footnote, document)
import Data.Char (toLower)
import qualified Data.Semigroup as SG
import GHC.Generics (Generic)
import qualified Data.Traversable as Tr
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import Data.Hashable (hash)
import Numeric (showHex)
import qualified Data.List as List
import Control.Applicative
import Control.Monad (forM)
import Control.Monad.IO.Class
import qualified Text.BibTeX.Entry as BibTeX
import qualified Text.BibTeX.Format as BibTeX
import qualified Text.BibTeX.Parse as BibTeX (file)
import qualified Text.Parsec.String as Parsec
biblatex :: PackageName
biblatex = "biblatex"
addbibresource :: LaTeXC l => FilePath -> l
addbibresource fp = fromLaTeX $ TeXComm "addbibresource" [FixArg $ TeXRaw $ fromString fp]
printbibliography :: LaTeXC l => l
printbibliography = comm0 "printbibliography"
documentWithDOIReferences :: (MonadIO m, LaTeXC (m ()), SG.Semigroup (m ()), r ~ DOIReference)
=> (r -> m (Maybe BibTeX.T))
-> ReferenceQueryT r m ()
-> m ()
documentWithDOIReferences resolver (ReferenceQueryT refq) = do
(allRefs, (), useRefs) <- refq
resolved <- fmap catMaybes . forM (allRefs[]) $ \r -> do
r' <- resolver r
return $ case r' of
Just entry -> Just (r, entry)
Nothing -> Nothing
let refsMap = Map.fromList resolved
bibfileConts = unlines $ BibTeX.entry . snd <$> Map.toList refsMap
bibfileName = showHex (abs $ hash bibfileConts) $ ".bib"
liftIO $ writeFile bibfileName bibfileConts
() <- addbibresource bibfileName
document . useRefs $ \r flavour -> case Map.lookup r refsMap of
Just a -> let citeC = liftL $ \l -> (`TeXComm`[FixArg l]) $ case flavour of
Flavour_cite -> "cite"
Flavour_Cite -> "Cite"
Flavour_parencite -> "parencite"
Flavour_Parencite -> "Parencite"
Flavour_footcite -> "footcite"
Flavour_Footcite -> "Footcite"
Flavour_textcite -> "textcite"
Flavour_Textcite -> "Textcite"
Flavour_smartcite -> "smartcite"
Flavour_Smartcite -> "Smartcite"
in citeC . raw . fromString $ BibTeX.identifier a
Nothing -> makeshift r
where makeshift :: (LaTeXC l, SG.Semigroup l) => DOIReference -> l
makeshift (DOIReference doi synops) = footnote $
fromLaTeX synops SG.<> ". DOI:" SG.<> fromString doi
type PlainDOI = String
data DOIReference = DOIReference {
_referenceDOI :: PlainDOI
, _referenceSynopsis :: LaTeX
} deriving (Generic)
instance Eq DOIReference where
DOIReference doi₀ _ == DOIReference doi₁ _ = doi₀ == doi₁
instance Ord DOIReference where
compare (DOIReference doi₀ _) (DOIReference doi₁ _) = compare doi₀ doi₁
type DList r = [r] -> [r]
data CitationFlavour
= Flavour_cite
| Flavour_Cite
| Flavour_parencite
| Flavour_Parencite
| Flavour_footcite
| Flavour_Footcite
| Flavour_textcite
| Flavour_Textcite
| Flavour_smartcite
| Flavour_Smartcite
deriving (Eq, Ord, Show)
newtype ReferenceQueryT r m a = ReferenceQueryT {
runReferenceQueryT :: m (DList r, a, (r -> CitationFlavour -> m ()) -> m ())
}
deriving (Generic, Functor)
instance Applicative m => Applicative (ReferenceQueryT r m) where
pure x = ReferenceQueryT . pure $ (id, x, const $ pure ())
ReferenceQueryT refqf <*> ReferenceQueryT refqx = ReferenceQueryT $
liftA2 (\(urefsf, f, refref)
(urefsx, x, refrex)
-> ( urefsf . urefsx
, f x
, \resolv -> mappend <$> refref resolv <*> refrex resolv ) )
refqf refqx
instance Monad m => Monad (ReferenceQueryT r m) where
return = pure
ReferenceQueryT refsx >>= f
= ReferenceQueryT $ refsx >>= \(urefsx, x, refrex)
-> case f x of
ReferenceQueryT refsfx
-> (\(urefsfx,fx,refrefx)
-> ( urefsx.urefsfx
, fx
, \resolve -> mappend <$> refrex resolve <*> refrefx resolve ))
<$> refsfx
instance MonadIO m => MonadIO (ReferenceQueryT r m) where
liftIO a = ReferenceQueryT $ (\r -> (id, r, const $ pure ())) <$> liftIO a
instance (Functor m, Monoid (m a), IsString (m ()), a ~ ())
=> IsString (ReferenceQueryT r m a) where
fromString s = ReferenceQueryT $ (\a -> (id, a, const $ fromString s)) <$> mempty
instance (Applicative m, SG.Semigroup (m a), a ~ ())
=> SG.Semigroup (ReferenceQueryT r m a) where
ReferenceQueryT p <> ReferenceQueryT q
= ReferenceQueryT $ liftA2 (\(rp,(),ρp) (rq,(),ρq)
-> (rp.rq,(),liftA2(liftA2 (SG.<>))ρp ρq)) p q
instance (Applicative m, SG.Semigroup (m a), Monoid (m a), a ~ ())
=> Monoid (ReferenceQueryT r m a) where
mempty = ReferenceQueryT $ (\a -> (id, a, mempty)) <$> mempty
mappend = (SG.<>)
instance (Applicative m, LaTeXC (m a), SG.Semigroup (m a), a ~ ())
=> LaTeXC (ReferenceQueryT r m a) where
liftListL f xs = ReferenceQueryT $
(\components -> case List.unzip3 components of
(refs, _, rebuilds) -> ( foldr (.) id refs
, ()
, \resolve -> liftListL f $ ($ resolve)<$>rebuilds )
) <$> Tr.traverse runReferenceQueryT xs
citeDOI :: (Functor m, Monoid (m ()), IsString (m ()))
=> PlainDOI
-> String
-> ReferenceQueryT DOIReference m ()
citeDOI doi synops = ReferenceQueryT $ (\a -> ( (r :), a, \f -> f r Flavour_cite ))
<$> mempty
where r = DOIReference doi $ fromString synops
textc :: Functor m => ReferenceQueryT DOIReference m () -> ReferenceQueryT DOIReference m ()
textc (ReferenceQueryT y) = ReferenceQueryT
$ (\(r,m,a) -> (r, m, \f -> a (\x _ -> f x Flavour_textcite))) <$> y
textC :: Functor m => ReferenceQueryT DOIReference m () -> ReferenceQueryT DOIReference m ()
textC (ReferenceQueryT y) = ReferenceQueryT
$ (\(r,m,a) -> (r, m, \f -> a (\x _ -> f x Flavour_Textcite))) <$> y
masterBibFile :: MonadIO m
=> FilePath
-> (DOIReference -> m (Maybe BibTeX.T))
masterBibFile master (DOIReference doi _) = do
entries <- liftIO $ BibTeX.file `Parsec.parseFromFile` master
return $ case entries of
Right bibs -> List.find hasThisDOI bibs
Left err -> error $ show err
where hasThisDOI bib = (map toLower <$> List.lookup "doi" (BibTeX.fields bib))
== Just (toLower<$>doi)