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

-- | Collapse citations according to the style options.
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

-- | Get the collapse option set in the 'Style' for citations.
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
-- note:  for numerical styles, we treat author-in-text citations just
-- like any others.
    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
              -- FIXME: see https://bitbucket.org/bdarcus/citeproc-test/issue/15
              -- in  if null d' then if null d then ", " else d else d'
              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

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