{-# LANGUAGE PatternGuards, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Text.CSL.Proc -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) -- -- Maintainer : Andrea Rossato -- Stability : unstable -- Portability : unportable -- -- This module provides functions for processing the evaluated -- 'Output' for disambiguation and citation collapsing. -- ----------------------------------------------------------------------------- module Text.CSL.Proc where import Control.Arrow ( (&&&), (>>>), second ) import Data.Char ( toLower ) import Data.List import Data.Ord ( comparing ) import Text.CSL.Eval hiding ( trim ) import Text.CSL.Output.Plain import Text.CSL.Parser import Text.CSL.Proc.Collapse import Text.CSL.Proc.Disamb import Text.CSL.Reference import Text.CSL.Style data ProcOpts = ProcOpts { bibOpts :: BibOpts } 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 ) procOpts :: ProcOpts procOpts = ProcOpts (Select [] []) -- | With a 'Style', a list of 'Reference's and the list of citation -- groups (the list of citations with their locator), produce the -- 'FormattedOutput' for each citation group. processCitations :: ProcOpts -> Style -> [Reference] -> Citations -> [[FormattedOutput]] processCitations ops s rs = citations . citeproc ops s rs -- | With a 'Style' and the list of 'Reference's produce the -- 'FormattedOutput' for the bibliography. processBibliography :: ProcOpts -> Style -> [Reference] -> [[FormattedOutput]] processBibliography ops s rs = bibliography $ citeproc ops s rs [map (\r -> emptyCite { citeId = refId r}) rs] -- | With a 'Style', a list of 'Reference's and the list of -- 'Citations', produce the 'FormattedOutput' for each citation group -- and the bibliography. citeproc :: ProcOpts -> Style -> [Reference] -> Citations -> BiblioData citeproc ops s rs cs = BD citsOutput biblioOutput where -- the list of bib entries, as a list of Reference, with -- position, locator and year suffix set. biblioRefs = procRefs s . map (getReference rs) . nubBy (\a b -> citeId a == citeId b) . concat $ cs biblioOutput = if "disambiguate-add-year-suffix" `elem` getCitDisambOptions s then map formatOutputList $ map (proc (updateYearSuffixes yearS) . map addYearSuffix) $ procBiblio (bibOpts ops) s biblioRefs else map formatOutputList $ procBiblio (bibOpts ops) s biblioRefs citsAndRefs = processCites biblioRefs cs (yearS,citG) = disambCitations s biblioRefs cs $ map (procGroup s) citsAndRefs citsOutput = map (formatCitLayout s) . collapseCitGroups s $ citG -- | 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) $ rs sortItems :: Show a => [(a,[Sorting])] -> [a] sortItems [] = [] sortItems l = case head . concatMap (map snd) $ result of [] -> concatMap (map fst) result _ -> if or $ map ((<) 1 . length) result then concatMap sortItems result else concatMap (map fst) result where result = process l process = sortBy (comparing $ head' . snd) >>> groupBy (\a b -> head' (snd a) == head' (snd b)) >>> map (map $ second tail') -- | 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 = maybe [] process mb where process b = flip map (render b) $ uncurry formatBiblioLayout (layFormat &&& layDelim $ bibLayout b) render b = subsequentAuthorSubstitute b . map (evalBib b) . filterRefs bos $ rs evalBib b r = evalLayout (bibLayout b) (EvalBiblio emptyCite {citePosition = "first"}) False l ms (mergeOptions (bibOptions b) opts) as r 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" -> head' . query namesQ . queryContrib "partial-each" -> query namesQ . queryContrib _ -> queryContrib getPartialEach x xs = concat . head' . map fst . reverse . sortBy (comparing $ length . snd) . filter ((<) 0 . length . snd) . zip xs . map (takeWhile id . map (uncurry (==)) . zip 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 . and . flip map q $ \(f,v) -> lookup_ r f v select s r = and . flip map s $ \(f,v) -> lookup_ r f v include i r = or . flip map i $ \(f,v) -> lookup_ r f v exclude e r = and . flip map e $ \(f,v) -> not $ lookup_ r f v 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 r) of Just x | Just v' <- (fromValue x :: Maybe RefType ) -> v == toShow (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] ) -> v == [] && v' == [] || v == show v' | Just v' <- (fromValue x :: Maybe [RefDate]) -> v == [] && 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, 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 ) . foldr (\x _ -> [x]) [] . 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 = sortItems $ process cr formatBiblioLayout :: Formatting -> Delimiter -> [Output] -> [Output] formatBiblioLayout f d = appendOutput f . addDelim d formatCitLayout :: Style -> CitationGroup -> [FormattedOutput] formatCitLayout s (CG co f d cs) | [a] <- co = formatAuth a : formatCits (fst >>> citeId &&& citeHash >>> setAsSupAu $ a) cs | otherwise = formatCits id cs where formatAuth = formatOutput . localMod formatCits g = formatOutputList . appendOutput formatting . addAffixes f . addDelim d . map (fst &&& localMod >>> uncurry addCiteAffixes) . g formatting = unsetAffixes f localMod = if cs /= [] then uncurry $ localModifiers s (co /= []) else snd setAsSupAu h = map $ \(c,o) -> if (citeId c, citeHash c) == h then flip (,) o c { authorInText = False , suppressAuthor = True } else flip (,) o c addAffixes :: Formatting -> [Output] -> [Output] addAffixes f os | [] <- os = [] | [ONull] <- os = [] | otherwise = pref ++ suff where pref = if prefix f /= [] then [OStr (prefix f) emptyFormatting] ++ os else os suff = if suffix f /= [] && elem (head $ suffix f) ",.:?!" && [head $ suffix f] == lastOutput then [OStr (tail $ suffix f) emptyFormatting] else suff' suff' = if suffix f /= [] then [OStr (suffix f) emptyFormatting] else [] lastOutput = case renderPlain (formatOutputList os) of [] -> "" x -> [last x] -- | 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 . proc rmFormatting . contribOnly s | suppressAuthor c = check . rmContrib . return | otherwise = id where isPunct = and . map (flip elem ".,;:!? ") 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 rmFormatting f | Formatting {} <- f = emptyFormatting { prefix = prefix f , suffix = suffix f} | otherwise = f 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 {} <- o = Output [ OStr (query getRefTerm s) emptyFormatting , OSpace, o] emptyFormatting | OContrib _ "author" _ _ _ <- o = o | OContrib _ "authorsub" _ _ _ <- o = o | Output ot f <- o = Output (cleanOutput $ map (contribOnly s) ot) f | OStr x _ <- o , "ibid" <- filter (/= '.') (map toLower x) = o | otherwise = ONull where getRefTerm :: CslTerm -> String getRefTerm t | CT "reference" Long _ _ x _ _ <- t = capitalize x | otherwise = []