module Text.CSL.Proc.Collapse where
import Control.Arrow ( (&&&), (>>>) )
import Data.List ( groupBy )
import Text.CSL.Eval
import Text.CSL.Proc.Disamb
import Text.CSL.Style
collapseCitGroups :: Style -> [CitationGroup] -> [CitationGroup]
collapseCitGroups s
= map doCollapse
where
doCollapse = case getCollapseOptions s of
"year" : _ -> collapseYear
"year-suffix" : _ -> collapseYearSuf
"citation-number" : _ -> collapseNumber
_ -> id
getCollapseOptions :: Style -> [String]
getCollapseOptions
= map snd . filter ((==) "collapse" . fst) . citOptions . citation
collapseNumber :: CitationGroup -> CitationGroup
collapseNumber (CG fm d os) = CG fm d (process os)
where
citNum o
| OCitNum i f <- o = [(i,f)]
| otherwise = []
numOf = foldr (\x _ -> x) (0,emptyFormatting) . query citNum
newNum = map numOf >>> (map fst >>> groupConsec) &&& map snd >>> uncurry zip
process xs = flip concatMap (newNum xs) $
\(x,f) -> if length x > 2
then return $ Output [ OCitNum (head x) f
, ODel "-"
, OCitNum (last x) f
] emptyFormatting
else map (flip OCitNum f) x
collapseYear :: CitationGroup -> CitationGroup
collapseYear (CG f d os) = CG f d (process os)
where
rmNames [] = []
rmNames (x:xs) = x : remove xs
remove = proc rmFirstDelim . proc rmContribs
namesOf = map (fst . snd) . getNamesYear
process = map (\x -> Output (addDelim ", " $ rmNames x) emptyFormatting) .
groupBy (\a b -> namesOf a == namesOf b)
collapseYearSuf :: CitationGroup -> CitationGroup
collapseYearSuf (CG f d os) = CG f d (process os)
where
rmNames [] = []
rmNames (x:xs) = x : remove xs
remove = proc rmFirstDelim . proc rmYear . proc rmContribs
namesOf = map (fst . snd) . getNamesYear
yearOf = concatMap (take 4 . snd . snd) . getNamesYear
process = map (\x -> Output (addDelim ", " $ rmNames x) emptyFormatting) .
groupBy (\a b -> namesOf a == namesOf b && yearOf a == yearOf b)
rmYear o
| OYear _ sf fm <- o = OYear sf sf fm
| otherwise = o
rmFirstDelim :: Output -> Output
rmFirstDelim o
| Output os f <- o = Output (rm os) f
| otherwise = o
where
rm [] = []
rm (x:xs)
| ODel _ <- x = xs
| otherwise = x : rm xs
groupConsec :: [Int] -> [[Int]]
groupConsec = groupConsec' []
where
groupConsec' x [] = x
groupConsec' [] (y:ys) = groupConsec' [[y]] ys
groupConsec' xs (y:ys) = if y head (last xs) == length (last xs)
then groupConsec' (init xs ++ [last xs ++ [y]]) ys
else groupConsec' ( xs ++ [ [y]]) ys