{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : Text.CSL.Proc.Collapse -- 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 citation collapsing. -- ----------------------------------------------------------------------------- module Text.CSL.Proc.Collapse where import Prelude import Control.Arrow (second, (&&&), (>>>)) import Data.Char import Data.List (groupBy, sortBy) import Data.Monoid (Any (..)) import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T import Text.CSL.Eval import Text.CSL.Proc.Disamb import Text.CSL.Style hiding (Any) import Text.CSL.Util (proc, proc', query) import Text.Pandoc.Definition (Inline (Str)) -- | Collapse citations according to the style options. collapseCitGroups :: Style -> [CitationGroup] -> [CitationGroup] collapseCitGroups s = map doCollapse where doCollapse = case getCollapseOptions s of "year" : _ -> collapseYear s "" "year-suffix" : _ -> collapseYear s "year-suffix" "year-suffix-ranged" : _ -> collapseYear s "year-suffix-ranged" "citation-number" : _ -> collapseNumber _ -> id -- | Get the collapse option set in the 'Style' for citations. getCollapseOptions :: Style -> [Text] getCollapseOptions = map snd . filter ((==) "collapse" . fst) . citOptions . citation collapseNumber :: CitationGroup -> CitationGroup collapseNumber (CG _ f d os) = mapCitationGroup process $ CG [] f d os -- note: for numerical styles, we treat author-in-text citations just -- like any others. where hasLocator = or . query hasLocator' hasLocator' o | OLoc _ _ <- o = [True] | otherwise = [False] citNums (OCitNum i _) = [i] citNums (Output xs _) = concatMap citNums xs citNums _ = [] numOf = foldr const 0 . citNums process xs = if hasLocator xs then xs else flip concatMap (groupConsecWith numOf xs) $ \ys -> if length ys > 2 then [ Output [ head ys , OPan [Str "\x2013"] , last ys ] emptyFormatting ] else ys groupCites :: [(Cite, Output)] -> [(Cite, Output)] groupCites [] = [] groupCites (x:xs) = let equal = filter (hasSameNamesAs x) xs notequal = filter (not . hasSameNamesAs x) xs in x : equal ++ groupCites notequal where hasSameNamesAs w y = namesOf (snd w) == namesOf (snd y) contribsQ o | OContrib _ _ c _ _ <- o = [c] | otherwise = [] namesOf y = case query contribsQ y of [] -> [] (z:_) -> proc rmHashAndGivenNames z getYearAndSuf :: Output -> Output getYearAndSuf x = case query getOYear x of [] -> noOutputError x' -> Output x' emptyFormatting where getOYear o | OYear {} : _ <- o = [head o] | OYearSuf {} : _ <- o = [head o] | OLoc {} : _ <- o = [head o] | ODel _ : OLoc {} : _ <- o = [head o] | OStatus {} : _ <- o = [head o] | otherwise = [] collapseYear :: Style -> Text -> CitationGroup -> CitationGroup collapseYear s ranged (CG cs f d os) = CG cs f "" (process os) where styleYSD = getOptionVal "year-suffix-delimiter" . citOptions . citation $ s yearSufDel = if T.null styleYSD then layDelim . citLayout . citation $ s else styleYSD afterCD = getOptionVal "after-collapse-delimiter" . citOptions . citation $ s afterColDel = if T.null afterCD then d else afterCD format [] = [] format (x:xs) = x : map getYearAndSuf xs isRanged = case ranged of "year-suffix-ranged" -> True _ -> False collapseRange = if T.null ranged then map (uncurry addCiteAffixes) else collapseYearSuf isRanged yearSufDel rmAffixes x = x {citePrefix = mempty, citeSuffix = mempty} delim = let d' = getOptionVal "cite-group-delimiter" . citOptions . citation $ s -- FIXME: see https://bitbucket.org/bdarcus/citeproc-test/issue/15 -- in if null d' then if null d then ", " else d else d' in if T.null d' then ", " else d' collapsYS a = case a of [] -> (emptyCite, ONull) [x] -> rmAffixes . fst &&& uncurry addCiteAffixes $ x _ -> (,) (rmAffixes $ fst $ head a) . flip Output emptyFormatting . addDelim delim . collapseRange . uncurry zip . second format . unzip $ a doCollapse [] = [] doCollapse [x] = [collapsYS x] doCollapse (x:xs) = let (a,b) = collapsYS x in if length x > 1 then (a, Output (b : [ODel afterColDel]) emptyFormatting) : doCollapse xs else (a, Output (b : [ODel d ]) emptyFormatting) : doCollapse xs contribsQ o | OContrib _ _ c _ _ <- o = [proc' rmHashAndGivenNames c] | otherwise = [] namesOf = query contribsQ hasSameNames a b = not (null (namesOf (snd a))) && namesOf (snd a) == namesOf (snd b) process = doCollapse . groupBy hasSameNames . groupCites collapseYearSuf :: Bool -> Text -> [(Cite,Output)] -> [Output] collapseYearSuf ranged ysd = process where yearOf = T.concat . query getYear getYear o | OYear y _ _ <- o = [y] | otherwise = [] processYS = if ranged then collapseYearSufRanged else id process = map (flip Output emptyFormatting . getYS) . groupBy comp checkAffix (Formatted []) = True checkAffix _ = False comp a b = yearOf (snd a) == yearOf (snd b) && checkAffix (citePrefix $ fst a) && checkAffix (citeSuffix $ fst a) && checkAffix (citePrefix $ fst b) && checkAffix (citeSuffix $ fst b) && T.null (citeLocator $ fst a) && T.null (citeLocator $ fst b) getYS [] = [] getYS [x] = return $ uncurry addCiteAffixes x getYS (x:xs) = if ranged then proc rmOYearSuf (snd x) : addDelim ysd (processYS $ snd x : query rmOYear (map snd xs)) else addDelim ysd $ snd x : processYS (query rmOYear (map snd xs)) rmOYearSuf o | OYearSuf {} <- o = ONull | otherwise = o rmOYear o | OYearSuf {} <- o = [o] | otherwise = [] collapseYearSufRanged :: [Output] -> [Output] collapseYearSufRanged = process where getOYS o | OYearSuf s _ _ f <- o = [(if s /= "" then ord (T.head s) else 0, f)] | otherwise = [] sufOf = foldr const (0,emptyFormatting) . query getOYS newSuf = map sufOf >>> (map fst >>> groupConsec) &&& map snd >>> uncurry zip process xs = flip concatMap (newSuf xs) $ \(x,f) -> if length x > 2 then return $ Output [ OStr (T.singleton . chr $ head x) f , OPan [Str "\x2013"] , OStr (T.singleton . chr $ last x) f ] emptyFormatting else map (\y -> if y == 0 then ONull else flip OStr f . T.singleton . chr $ y) x addCiteAffixes :: Cite -> Output -> Output addCiteAffixes c x = if isNumStyle [x] then x else Output ( addCiteAff True (citePrefix c) ++ [x] ++ addCiteAff False (citeSuffix c)) emptyFormatting where addCiteAff isprefix y = case y of Formatted [] -> [] Formatted ils | isprefix -> case reverse ils of (Str zs@(T.uncons -> Just (_,_)):_) | T.last zs == '\160' -> [OPan ils] _ -> [OPan ils, OSpace] | otherwise -> case ils of (Str (T.uncons -> Just (z,_)):_) | isAlphaNum z || z == '(' -> [OSpace, OPan ils] _ -> [OPan ils] isNumStyle :: [Output] -> Bool isNumStyle = getAny . query ocitnum where ocitnum OCitNum {} = Any True ocitnum _ = Any False -- | Group consecutive integers: -- -- > groupConsec [1,2,3,5,6,8,9] == [[1,2,3],[5,6],[8,9]] groupConsec :: [Int] -> [[Int]] groupConsec = groupConsecWith id groupConsecWith :: (a -> Int) -> [a] -> [[a]] groupConsecWith f = foldr go [] . sortBy (comparing f) where go x [] = [[x]] go x ((y:ys):gs) = if (f x + 1) == f y then (x:y:ys):gs else [x]:(y:ys):gs go _ ([]:_) = error "groupConsec: head of list is empty"