module Text.CSL.Proc.Collapse where
import Control.Arrow ( (&&&), (>>>) )
import Data.Char
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 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 = mapCitationGroup process
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 :: Style -> String -> CitationGroup -> CitationGroup
collapseYear s ranged (CG cs f d os) = CG cs f [] [(emptyCite, process $ map snd os)]
where
styleYSD = getOptionVal "year-suffix-delimiter" . citOptions . citation $ s
yearSufDel = styleYSD `betterThen` (layDelim . citLayout . citation $ s)
afterCD = getOptionVal "after-collapse-delimiter" . citOptions . citation $ s
afterColDel = afterCD `betterThen` d
format [] = []
format (x:xs) = x : map getYearAndSuf xs
getYearAndSuf x = case query getOYear x of
[] -> noOutputError
x' -> Output x' emptyFormatting
getOYear o
| OYear {} <- o = [o]
| OYearSuf {} <- o = [o]
| OPan {} <- o = [o]
| otherwise = []
isRanged = case ranged of
"year-suffix-ranged" -> True
_ -> False
collapsYS xs = if length xs < 2 || null ranged
then xs
else collapseYearSuf isRanged yearSufDel xs
addDelimiter [] = []
addDelimiter (x:[]) = [addDelim d x]
addDelimiter (x:xs) = if length x > 1
then (addDelim d x ++ [ODel afterColDel]) : addDelimiter xs
else (addDelim d x ++ [ODel d ]) : addDelimiter xs
namesOf = map (fst . snd) . getNamesYear True
process = flip Output emptyFormatting . concat . addDelimiter .
map (collapsYS . format) . groupBy (\a b -> namesOf a == namesOf b)
collapseYearSuf :: Bool -> String -> [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 (\a b -> yearOf a == yearOf b)
getYS [] = []
getYS (x:xs) = if ranged
then proc rmOYearSuf x : addDelim ysd (processYS $ x : query rmOYear xs)
else addDelim ysd $ x : (processYS $ query rmOYear 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 (\x _ -> x) (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
, ODel "-"
, OStr [chr $ last x] f
] emptyFormatting
else map (\y -> if y == 0 then ONull else flip OStr f . return . chr $ y) x
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