{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module : Text.CSL.Proc
-- Copyright : (c) Andrea Rossato
-- License : BSD-style (see LICENSE)
--
-- Maintainer : Andrea Rossato <andrea.rossato@unitn.it>
-- Stability : unstable
-- Portability : unportable
--
-- This module provides functions for processing the evaluated
-- 'Output' for disambiguation and citation collapsing.
--
-----------------------------------------------------------------------------
module Text.CSL.Proc where
import Prelude
import Control.Applicative ((<|>))
import Control.Arrow (second, (&&&), (>>>))
import Control.Monad.State (execState, modify)
import Data.Aeson
import Data.Char (isDigit, isLetter, toLower)
import Data.List
import Data.Maybe (mapMaybe)
import Data.Ord (comparing)
import Text.CSL.Eval
import Text.CSL.Proc.Collapse
import Text.CSL.Proc.Disamb
import Text.CSL.Reference
import Text.CSL.Style
import Text.CSL.Util (proc, proc', query, tr', uncamelize)
import Text.Pandoc.Definition (Block (Para),
Inline (Note, Space, Str))
data ProcOpts
= ProcOpts
{ bibOpts :: BibOpts
, linkCitations :: Bool
}
deriving ( Show, Read, Eq )
data BibOpts
= Select [(String, String)] [(String, String)]
| Include [(String, String)] [(String, String)]
| Exclude [(String, String)] [(String, String)]
deriving ( Show, Read, Eq )
newtype FieldVal = FieldVal{
unFieldVal :: (String, String)
} deriving Show
instance FromJSON FieldVal where
parseJSON (Object v) = do
x <- v .: "field"
y <- v .: "value"
return $ FieldVal (x,y)
parseJSON _ = fail "Could not parse FieldVal"
instance FromJSON BibOpts where
parseJSON (Object v) = do
quash <- v .:? "quash".!= []
let quash' = map unFieldVal quash
(v .: "select" >>= \x -> return $ Select (map unFieldVal x) quash')
<|>
(v .: "include" >>= \x -> return $ Include (map unFieldVal x) quash')
<|>
(v .: "exclude" >>= \x -> return $ Exclude (map unFieldVal x) quash')
<|>
return (Select [] quash')
parseJSON _ = return $ Select [] []
procOpts :: ProcOpts
procOpts = ProcOpts
{ bibOpts = Select [] []
, linkCitations = False
}
-- | With a 'Style', a list of 'Reference's and the list of citation
-- groups (the list of citations with their locator), produce the
-- 'Formatted' for each citation group.
processCitations :: ProcOpts -> Style -> [Reference] -> Citations -> [Formatted]
processCitations ops s rs
= citations . citeproc ops s rs
-- | With a 'Style' and the list of 'Reference's produce the
-- 'Formatted' for the bibliography.
processBibliography :: ProcOpts -> Style -> [Reference] -> [Formatted]
processBibliography ops s rs
= bibliography $ citeproc ops s rs [map (\r -> emptyCite { citeId = unLiteral $ refId r}) rs]
-- | With a 'Style', a list of 'Reference's and the list of
-- 'Citations', produce the 'Formatted' for each citation group
-- and the bibliography.
citeproc :: ProcOpts -> Style -> [Reference] -> Citations -> BiblioData
citeproc ops s rs cs
= BD citsOutput biblioOutput $ map (unLiteral . refId) biblioRefs
where
-- the list of bib entries, as a list of Reference, with
-- position, locator and year suffix set.
biblioRefs = procRefs s . mapMaybe (getReference rs) .
nubBy (\a b -> citeId a == citeId b) . concat $ cs
biblioOutput = if "disambiguate-add-year-suffix" `elem` getCitDisambOptions s
then map (formatOutputList .
proc (updateYearSuffixes yearS) . map addYearSuffix) $
procBiblio (bibOpts ops) s biblioRefs
else map formatOutputList $
tr' "citeproc:after procBiblio" $
procBiblio (bibOpts ops) s biblioRefs
citsAndRefs = processCites biblioRefs cs
(yearS,citG) = disambCitations s biblioRefs cs $ map (procGroup s) citsAndRefs
citsOutput = map (formatCitLayout s) .
tr' "citeproc:collapsed" .
collapseCitGroups s .
(if linkCitations ops && styleClass s == "in-text"
then proc addLink
else id) .
tr' "citeproc:citG" $
citG
addLink :: (Cite, Output) -> (Cite, Output)
addLink (cit, outp) = (cit, proc (addLink' (citeId cit)) outp)
addLink' citeid (OYear y _ f) =
OYear y citeid f{hyperlink = "#ref-" ++ citeid}
addLink' citeid (OYearSuf y _ d f) =
OYearSuf y citeid d f{hyperlink = "#ref-" ++ citeid}
addLink' citeid (OCitNum n f) =
OCitNum n f{hyperlink = "#ref-" ++ citeid}
addLink' citeid (OCitLabel l f) =
OCitLabel l f{hyperlink = "#ref-" ++ citeid}
addLink' citeid (Output xs@(OStr _ _: _) f) =
Output xs f{hyperlink = "#ref-" ++ citeid}
addLink' _ x = x
-- | Given the CSL 'Style' and the list of 'Reference's sort the list
-- according to the 'Style' and assign the citation number to each
-- 'Reference'.
procRefs :: Style -> [Reference] -> [Reference]
procRefs Style {biblio = mb, csMacros = ms , styleLocale = l, styleAbbrevs = as, csOptions = opts} rs
= maybe (setCNum rs) process mb
where
opts' b = mergeOptions (bibOptions b) opts
setCNum = map (\(x,y) -> x { citationNumber = fromIntegral y }) . flip zip ([1..] :: [Int])
sort_ b = evalSorting (EvalSorting emptyCite {citePosition = "first"}) l ms (opts' b) (bibSort b) as
process b = setCNum . sortItems . map (id &&& sort_ b . Just) $ rs
sortItems :: Show a => [(a,[Sorting])] -> [a]
sortItems [] = []
sortItems l
= case head . concatMap (map snd) $ result of
[] -> concatMap (map fst) result
_ -> if any ((<) 1 . length) result
then concatMap sortItems result
else concatMap (map fst) result
where
result = process l
process = sortBy (comparing $ take 1 . snd) >>>
groupBy (\a b -> take 1 (snd a) == take 1 (snd b)) >>>
map (map $ second (drop 1))
-- | With a 'Style' and a sorted list of 'Reference's produce the
-- evaluated output for the bibliography.
procBiblio :: BibOpts -> Style -> [Reference] -> [[Output]]
procBiblio bos Style {biblio = mb, csMacros = ms , styleLocale = l,
styleAbbrevs = as, csOptions = opts} rs
= map addSpaceAfterCitNum $ maybe [] process mb
where
-- handle second-field-align (sort of)
addSpaceAfterCitNum [Output (OCitNum n f : xs) f']
| secondFieldAlign == Just "flush" =
[Output (OCitNum n f : OSpace : xs) f']
| secondFieldAlign == Just "margin" =
[Output (OCitNum n f : OSpace : xs) f']
| otherwise = [Output (OCitNum n f : xs) f']
addSpaceAfterCitNum xs = xs
secondFieldAlign = lookup "second-field-align" $ maybe [] bibOptions mb
process :: Bibliography -> [[Output]]
process b = map (formatBiblioLayout (layFormat $ bibLayout b) (layDelim $ bibLayout b)) $ render b
render :: Bibliography -> [[Output]]
render b = subsequentAuthorSubstitute b . map (evalBib b) . filterRefs bos $ rs
evalBib :: Bibliography -> Reference -> [Output]
evalBib b = evalLayout (bibLayout b) (EvalBiblio emptyCite {citePosition = "first"}) False l ms (mergeOptions (bibOptions b) opts) as . Just
subsequentAuthorSubstitute :: Bibliography -> [[Output]] -> [[Output]]
subsequentAuthorSubstitute b = if null subAuthStr then id else chkCreator
where
subAuthStr = getOptionVal "subsequent-author-substitute" (bibOptions b)
subAuthRule = getOptionVal "subsequent-author-substitute-rule" (bibOptions b)
queryContrib = proc' rmLabel . query contribsQ
getContrib = if null subAuthStr
then const []
else case subAuthRule of
"partial-first" -> take 1 . query namesQ . queryContrib
"partial-each" -> query namesQ . queryContrib
_ -> queryContrib
getPartialEach x xs = concat . take 1 . map fst .
sortBy (flip (comparing $ length . snd)) . filter ((<) 0 . length . snd) .
zip xs . map (takeWhile id . zipWith (==) x) $ xs
chkCreator = if subAuthRule == "partial-each" then chPartialEach [] else chkCr []
chkCr _ [] = []
chkCr a (x:xs) = let contribs = getContrib x in
if contribs `elem` a
then substituteAuth []
x : chkCr a xs
else x : chkCr (contribs : a) xs
chPartialEach _ [] = []
chPartialEach a (x:xs) = let contribs = getContrib x
partial = getPartialEach contribs a in
if not $ null partial
then substituteAuth partial x :
if length partial < length contribs
then chPartialEach (contribs : a) xs
else chPartialEach a xs
else x : chPartialEach (contribs : a) xs
substituteAuth a = if subAuthRule == "complete-each"
then proc chNamas else proc (updateContribs a)
updateContribs a o@(OContrib i r y ds os)
= if r == "author" || r == "authorsub" then OContrib i r upCont ds os else o
where
upCont = case subAuthRule of
"partial-first" -> rmFirstName y
"partial-each" -> rmSelectedName a y
_ -> OStr subAuthStr emptyFormatting : proc rmNames y
updateContribs _ o = o
contribsQ o
| OContrib _ r c _ _ <- o = if r == "author" || r == "authorsub" then c else []
| otherwise = []
namesQ o
| OName {} <- o = [o]
| otherwise = []
rmSelectedName _ [] = []
rmSelectedName a (o:os)
| OName {} <- o = (if o `elem` a then OStr subAuthStr emptyFormatting else o) : rmSelectedName a os
| otherwise = o : rmSelectedName a os
rmFirstName [] = []
rmFirstName (o:os)
| OName {} <- o = OStr subAuthStr emptyFormatting : os
| otherwise = o : rmFirstName os
chNamas o
| OName s _ os f <- o = OName s [OStr subAuthStr emptyFormatting] os f
| otherwise = o
rmNames o
| OName {} <- o = ONull
| OStr {} <- o = ONull
| ODel {} <- o = ONull
| otherwise = o
rmLabel [] = []
rmLabel (o:os)
| OLabel {} <- o = rmLabel os
| otherwise = o : rmLabel os
filterRefs :: BibOpts -> [Reference] -> [Reference]
filterRefs bos refs
| Select s q <- bos = filter (select s) . filter (quash q) $ refs
| Include i q <- bos = filter (include i) . filter (quash q) $ refs
| Exclude e q <- bos = filter (exclude e) . filter (quash q) $ refs
| otherwise = refs
where
quash [] _ = True
quash q r = not $ all (lookup_ r) q
select s r = all (lookup_ r) s
include i r = any (lookup_ r) i
exclude e r = all (not . lookup_ r) e
lookup_ r (f, v) = case f of
"type" -> look "ref-type"
"id" -> look "ref-id"
"categories" -> look "categories"
x -> look x
where
look s = case lookup s (mkRefMap (Just r)) of
Just x | Just v' <- (fromValue x :: Maybe RefType ) -> v == uncamelize (show v')
| Just v' <- (fromValue x :: Maybe String ) -> v == v'
| Just v' <- (fromValue x :: Maybe [String] ) -> v `elem` v'
| Just v' <- (fromValue x :: Maybe [Agent] ) -> null v && null v' || v == show v'
| Just v' <- (fromValue x :: Maybe [RefDate]) -> null v && null v' || v == show v'
_ -> False
-- | Given the CSL 'Style' and the list of 'Cite's coupled with their
-- 'Reference's, generate a 'CitationGroup'. The citations are sorted
-- according to the 'Style'.
procGroup :: Style -> [(Cite, Maybe Reference)] -> CitationGroup
procGroup Style {citation = ct, csMacros = ms , styleLocale = l,
styleAbbrevs = as, csOptions = opts} cr
= CG authIn (layFormat $ citLayout ct) (layDelim $ citLayout ct) (authIn ++ co)
where
(co, authIn) = case cr of
(c:_) -> if authorInText (fst c)
then (filter (eqCites (/=) c) result,
take 1 . filter (eqCites (==) c) $ result)
else (result, [])
_ -> (result, [])
eqCites eq c = fst >>> citeId &&& citeHash >>> eq (citeId &&& citeHash $ fst c)
opts' = mergeOptions (citOptions ct) opts
format (c,r) = (c, evalLayout (citLayout ct) (EvalCite c) False l ms opts' as r)
sort_ (c,r) = evalSorting (EvalSorting c) l ms opts' (citSort ct) as r
process = map (second (flip Output emptyFormatting) . format &&& sort_)
result = concatMap sortItems $ toChunks $ process cr
-- toChunks splits the citations up into groups, such that
-- a citation with a non-null prefix is by itself in its
-- group, otherwise preserving the order (see #292 for
-- motivation; we don't want to move prefixed citations
-- around)
toChunks xs = reverse $ execState (toChunks' xs) []
toChunks' xs = do
case break hasPrefix xs of
([], []) -> return ()
([], y:ys) -> modify ([y]:) >> toChunks' ys
(zs, ys) -> modify (zs:) >> toChunks' ys
hasPrefix ((c,_),_) = citePrefix c /= mempty
formatBiblioLayout :: Formatting -> Delimiter -> [Output] -> [Output]
formatBiblioLayout f d = appendOutput f . addDelim d
formatCitLayout :: Style -> CitationGroup -> Formatted
formatCitLayout s (CG co f d cs)
| [a] <- co = combine (formatAuth a)
(formatCits $
(fst >>> citeId &&& citeHash >>> setAsSupAu $ a) cs)
| otherwise = formatCits cs
where
isNote = styleClass s == "note"
toNote (Formatted []) = mempty
toNote (Formatted xs) = Formatted [Note [Para xs]]
combine (Formatted []) ys = ys
combine xs ys =
case ys of
Formatted [] -> xs
Formatted (Note _ : _) -> xs <> ys
Formatted (Str [c]:_) | c `elem` (", ;:" :: String) -> xs <> ys
_ -> xs <> Formatted [Space] <> ys
formatAuth = formatOutput . localMod
formatCits = (if isNote then toNote else id) .
formatOutputList . appendOutput formatting . addAffixes f .
addDelim d .
map (fst &&& localMod >>> uncurry addCiteAffixes)
formatting = f{ prefix = [], suffix = [],
verticalAlign = if isAuthorInText cs
then ""
else verticalAlign f }
isAuthorInText [] = False
isAuthorInText ((c,_):_) = authorInText c
localMod = uncurry $ localModifiers s (not $ null co)
setAsSupAu h = map $ \(c,o) -> if (citeId c, citeHash c) == h
then (c { authorInText = False
, suppressAuthor = True }, o)
else (c, o)
addAffixes :: Formatting -> [Output] -> [Output]
addAffixes f os
| [] <- os = []
| [ONull] <- os = []
| [Output [ONull] _] <- os = []
| otherwise = pref ++ suff
where
pref = if not (null (prefix f))
then OStr (prefix f) emptyFormatting : os
else os
suff = case suffix f of
[] -> []
(c:cs)
| isLetter c || isDigit c || c == '(' || c == '[' ->
[OSpace, OStr (c:cs) emptyFormatting]
| otherwise -> [OStr (c:cs) emptyFormatting]
-- | The 'Bool' is 'True' if we are formatting a textual citation (in
-- pandoc terminology).
localModifiers :: Style -> Bool -> Cite -> Output -> Output
localModifiers s b c
| authorInText c = check . return . contribOnly s
| suppressAuthor c = check . rmContrib . return
| otherwise = id
where
isPunct' [] = False
isPunct' xs = all (`elem` (".,;:!? " :: String)) xs
check o = case cleanOutput o of
[] -> ONull
x -> case trim' x of
[] -> ONull
x' -> Output x' emptyFormatting
hasOutput o
| Output [] _ <- o = [False]
| ODel _ <- o = [False]
| OSpace <- o = [False]
| ONull <- o = [False]
| otherwise = [True]
trim' [] = []
trim' (o:os)
| Output ot f <- o, p <- prefix f, p /= []
, isPunct' p = trim' $ Output ot f { prefix = []} : os
| Output ot f <- o = if or (query hasOutput ot)
then Output (trim' ot) f : os
else Output ot f : trim' os
| ODel _ <- o = trim' os
| OSpace <- o = trim' os
| OStr x f <- o = OStr x (if isPunct' (prefix f)
then f { prefix = []} else f) : os
| otherwise = o:os
rmCitNum o
| OCitNum {} <- o = ONull
| otherwise = o
rmContrib [] = []
rmContrib o
| b, isNumStyle o = proc rmCitNum o
| otherwise = rmContrib' o
rmContrib' [] = []
rmContrib' (o:os)
| Output ot f <- o = Output (rmContrib' ot) f : rmContrib' os
| ODel _ <- o
, OContrib _ "author"
_ _ _ : xs <- os = rmContrib' xs
| ODel _ <- o
, OContrib _ "authorsub"
_ _ _ : xs <- os = rmContrib' xs
| OContrib _ "author" _ _ _ <- o
, ODel _ : xs <- os = rmContrib' xs
| OContrib _ "authorsub" _ _ _ <- o
, ODel _ : xs <- os = rmContrib' xs
| OContrib _ "author"
_ _ _ <- o = rmContrib' os
| OContrib _ "authorsub"
_ _ _ <- o = rmContrib' os
| OStr x _ <- o
, "ibid" <- filter (/= '.') (map toLower x) = rmContrib' os
| otherwise = o : rmContrib' os
contribOnly :: Style -> Output -> Output
contribOnly s o
| isNumStyle [o]
, OCitNum n f <- o = Output [ OCitNum n f{
verticalAlign = "",
prefix = "",
suffix = "" } ] emptyFormatting
| OContrib _ "author"
_ _ _ <- o = o
| OContrib _ "authorsub"
_ _ _ <- o = o
| Output ot f <- o = Output (cleanOutput $ map (contribOnly s) ot)
f{ verticalAlign = "",
prefix = "",
suffix = "" }
| OStr x _ <- o
, "ibid" <- filter (/= '.')
(map toLower x) = o
| otherwise = ONull