    {-# LANGUAGE PatternGuards #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Text.CSL.Proc.Collapse
    -- Copyright   :  (c) Andrea Rossato
    -- License     :  BSD-style (see LICENSE)
    --
    -- Maintainer  :  Andrea Rossato <andrea.rossato@unitn.it>
    -- Stability   :  unstable
    -- Portability :  unportable
    --
    -- This module provides functions for processing the evaluated
    -- 'Output' for citation collapsing.
    --
    -----------------------------------------------------------------------------

    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

    -- | Collapse citations according to the style options.
    collapseCitGroups :: Style -> [CitationGroup] -> [CitationGroup]
    collapseCitGroups s
        = map doCollapse
        where
          doCollapse = case getCollapseOptions s of
                         "year"            : _ -> collapseYear
                         "year-suffix"     : _ -> collapseYearSuf
                         "citation-number" : _ -> collapseNumber
                         _                     -> id

    -- | Get the collapse option set in the 'Style' for citations.
    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

    -- | Group consecutive integers:
    --
    -- > groupConsec [1,2,3,5,6,8,9] == [[1,2,3],[5,6],[8,9]]
    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