{-# LANGUAGE NoImplicitPrelude #-}
{-# 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 Text.CSL.Eval
import Text.CSL.Proc.Disamb
import Text.CSL.Style hiding (Any)
import Text.CSL.Util (orIfNull, 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 -> [String]
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 -> String -> 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 = styleYSD `orIfNull` (layDelim . citLayout . citation $ s)
afterCD = getOptionVal "after-collapse-delimiter" . citOptions . citation $ s
afterColDel = afterCD `orIfNull` d
format [] = []
format (x:xs) = x : map getYearAndSuf xs
isRanged = case ranged of
"year-suffix-ranged" -> True
_ -> False
collapseRange = if 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 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 -> String -> [(Cite,Output)] -> [Output]
collapseYearSuf ranged ysd = process
where
yearOf = 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) &&
null (citeLocator $ fst a) &&
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 (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 [chr $ head x] f
, OPan [Str "\x2013"]
, OStr [chr $ last x] f
] emptyFormatting
else map (\y -> if y == 0 then ONull else flip OStr f . return . 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@(_:_):_) |
last zs == '\160' -> [OPan ils]
_ -> [OPan ils, OSpace]
| otherwise -> case ils of
(Str (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"