{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- 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 Prelude import Control.Applicative ((<|>)) import Control.Arrow (second, (&&&), (>>>)) import Control.Monad.State (execState, modify) import Data.Aeson import Data.Char (isDigit, isLetter) import Data.List import Data.Maybe (mapMaybe) import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T 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 [(Text, Text)] [(Text, Text)] | Include [(Text, Text)] [(Text, Text)] | Exclude [(Text, Text)] [(Text, Text)] deriving ( Show, Read, Eq ) newtype FieldVal = FieldVal{ unFieldVal :: (Text, Text) } 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 T.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 T.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_ :: Reference -> (Text, Text) -> Bool 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 == T.pack (uncamelize (show v')) | Just v' <- (fromValue x :: Maybe Text ) -> v == v' | Just v' <- (fromValue x :: Maybe [Text] ) -> v `elem` v' | Just v' <- (fromValue x :: Maybe [Agent] ) -> T.null v && null v' || v == T.pack (show v') | Just v' <- (fromValue x :: Maybe [RefDate]) -> T.null v && null v' || v == T.pack (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 (T.unpack -> [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 (T.null (prefix f)) then OStr (prefix f) emptyFormatting : os else os suff = case T.uncons $ suffix f of Nothing -> [] Just (c,_) | isLetter c || isDigit c || c == '(' || c == '[' -> [OSpace, OStr (suffix f) emptyFormatting] | otherwise -> [OStr (suffix f) 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 = T.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" <- T.filter (/= '.') (T.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" <- T.filter (/= '.') (T.toLower x) = o | otherwise = ONull