{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
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))
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
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
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
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
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"