BibLaTeX.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE FlexibleContexts  #-}

-- | <https://ctan.org/tex-archive/macros/latex/contrib/biblatex BibLaTeX>
--   is a reference-citation package using @.bib@ files (BibTeX) but no extra style-files.
--
module Text.LaTeX.Packages.BibLaTeX
 ( biblatex
 , addbibresource
 , cite
 , printbibliography
 -- * Automatic bibliography retrieval
 , documentWithDOIReferences
 , PlainDOI
 , citeDOI
 , textc
 , textC
 , DOIReference
 , ReferenceQueryT
 , applyDOIReferenceResolves
 , 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 (liftA2)
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 package. Use it to import it like this:
--
-- > usepackage [] biblatex
biblatex :: PackageName
biblatex = "biblatex"

-- | Use a bibliography file as resource for reference information.
addbibresource :: LaTeXC l => FilePath -> l
addbibresource fp = fromLaTeX $ TeXComm "addbibresource" [FixArg $ TeXRaw $ fromString fp]

printbibliography :: LaTeXC l => l
printbibliography = comm0 "printbibliography"


-- | All-inclusive preparation of a document containing DOI references.
--   Uses 'applyDOIReferenceResolves' under the hood.
documentWithDOIReferences :: (MonadIO m, LaTeXC (m ()), SG.Semigroup (m ()), r ~ DOIReference)
  => (r -> m (Maybe BibTeX.T)) -- ^ Reference-resolver function, for looking up BibTeX
                               --   entries for a given DOI.
                               --   If the DOI cannot be looked up (@Nothing@), we just
                               --   include a footnote with a synopsis and the DOI in
                               --   literal form. (Mostly intended to ease offline editing.)
  -> ReferenceQueryT r m ()    -- ^ The document content, possibly containing citations
                               --   in DOI-only form.
  -> m ()                      -- ^ LaTeX rendition. The content will already be wrapped
                               --   in @\\begin…end{document}@ here and an
                               --   automatically-generated @.bib@ file included, but
                               --   you still need to 'usepackage' 'biblatex' yourself.
documentWithDOIReferences resolver docW = do
    (refsMap, docConts) <- applyDOIReferenceResolves resolver docW
    let bibfileConts = unlines $ BibTeX.entry . snd <$> Map.toList refsMap
        bibfileName = showHex (abs $ hash bibfileConts) $ ".bib"
    liftIO $ writeFile bibfileName bibfileConts
    () <- addbibresource bibfileName
    document docConts
    
-- | More manual version of 'documentWithDOIReferences', only retrieving suitable
--   BibTeX entries for the DOI-references contained in the document, but not
--   generating any @.bib@ files or wrapping the content in it.
applyDOIReferenceResolves :: (MonadIO m, LaTeXC (m ()), SG.Semigroup (m ()), r ~ DOIReference)
  => (r -> m (Maybe BibTeX.T)) -- ^ Reference-resolver function.
  -> ReferenceQueryT r m ()    -- ^ The document content.
  -> m ( Map.Map DOIReference BibTeX.T
       , m ())                 -- ^ All the BibTeX entries found, and a version of the
                               --   document with all its doi-references changed to point to
                               --   the identifiers in that file.
applyDOIReferenceResolves 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
    return (refsMap, 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, Show)
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  -- ^ The unambiguous document identifier.
        -> String    -- ^ Synopsis of the cited work, in the form
                     --   @"J Doe et al 1950: Investigation of a Foo"@;
                     --   this is strictly speaking optional, the synopsis will /not/
                     --   be included in the final document (provided the DOI
                     --   can be properly resolved).
        -> ReferenceQueryT DOIReference m ()
citeDOI doi synops = ReferenceQueryT $ (\a -> ( (r :), a, \f -> f r Flavour_cite ))
                       <$> mempty
 where r = DOIReference doi $ fromString synops

-- | Transform a citation into @\\textcite@, i.e. so that it can be used as a noun in a sentence.
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

-- | Transform a citation into @\\Textcite@, i.e. so that it can be used as the first word in a sentence.
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    -- ^ A @.bib@ file containing entries for all relevant literature.
      -> (DOIReference -> m (Maybe BibTeX.T))
                     -- ^ Lookup-function, suitable for 'documentWithDOIReferences'.
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)