{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.CSL.Proc
-- Copyright   :  (c) Andrea Rossato
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Andrea Rossato <andrea.rossato@ing.unitn.it>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Output processing.
--
-----------------------------------------------------------------------------

module Text.CSL.Proc where

import Control.Arrow ( (&&&), (>>>), (***) )
import Data.Char ( chr )
import Data.List ( (\\), elemIndex, findIndices
                 , sortBy, mapAccumL, nub, groupBy
                 , isPrefixOf )
import Data.Maybe
import Data.Ord ( comparing )

import Text.CSL.Eval
import Text.CSL.Reference
import Text.CSL.Style

processCitations :: Style -> [Reference] -> [[(String, String)]] -> [[FormattedOutput]]
processCitations s rs
    = citations . citeproc s rs

processBibliography :: Style -> [Reference] -> [[FormattedOutput]]
processBibliography s rs
    = bibliography $ citeproc s rs [zip (map citeKey rs) (repeat "")]

citeproc :: Style -> [Reference] -> [[(String, String)]] -> BiblioData
citeproc s rs cs
    = BD  (outputGroups citOutput) biblioOutput
    where
      bibs   = refsYSuffix . procRefs s . map (getReference rs) .
               nub . map (id *** const []) . concat $ cs
      refs   = getRefs bibs cs
      groups = map (procGroup s) refs

      -- | group citation data (with possible alternative names) for every
      -- list of contributors which has a duplicate.
      contribs  = nub $ concatMap (\(CG _ _ os) -> concatMap getCiteData os) groups
      collid    = map rmGivenNames . collision
      duplics   = groupBy (\a b -> collid a == collid b) .
                  sortBy  (comparing collid) $
                  filter  (collid &&& citYear >>> flip elem (getDuplicates groups)) contribs

      needYSuff = map (allTheSame . map disData) duplics
      needName  = concatMap fst . filter (not . snd) $ zip duplics needYSuff

      disSolved = zip needName (disambiguate $ map disData needName)
      addLNames = map (\(c,n) -> c { disambed = head n }) disSolved
      addGNames = map (\ c    -> c { disambed = addGivenNames (disambed c) })

      chkdup = same . proc rmGivenNames . map disambed
      need a = map fst . filter (not . snd) . zip a
      done a = (,) (need a $ chkdup a) (a \\ (need a $ chkdup a))

      disOpts  = getDisOptions s
      hasNames = "disambiguate-add-names"       `elem` disOpts
      hasGName = "disambiguate-add-givenname"   `elem` disOpts
      hasYSuff = "disambiguate-add-year-suffix" `elem` disOpts
      nameDis  = case () of
                  _ | hasNames
                    , hasGName -> let (n ,ns ) = done   addLNames
                                      (n',ns') = done $ addGNames ns
                                  in   n ++ n' ++ addGNames ns'
                    | hasNames -> fst . done $ addLNames
                    | hasGName -> fst . done $ addGNames needName
                    | otherwise                                   -> []

      reEval       = let chk = if hasYSuff then filter ((==) [] . citYear) else id
                     in  chk . concatMap fst . filter snd $ zip duplics needYSuff
      reEvaluated  = if or (query hasIfDis s) && reEval /= []
                     then map (uncurry $ reEvaluate s reEval) $ zip refs groups
                     else groups

      outputGroups = map $ \(CG fm d os) -> map formatOutput $ outputList fm d os
      citOutput    = if disOpts /= []
                     then if hasYSuff
                          then proc addYearSuffix $ proc (updateOutput nameDis) reEvaluated
                          else proc (updateOutput nameDis) reEvaluated
                     else groups
      biblioOutput = if hasYSuff
                     then map (map formatOutput) $ proc addYearSuffix $ procBiblio s bibs
                     else map (map formatOutput) $ procBiblio s bibs

procBiblio :: Style -> [Reference] -> [[Output]]
procBiblio (Style {biblio = mb, csMacros = ms , csTerms = ts}) rs
    = maybe [] process mb
    where
      format  b = uncurry $ evalLayout (bibLayout b) False ts ms (bibOptions b)
      render  b = map (format b) $ chkAut [] rs
      process b = flip map (render b) $ uncurry outputList (layFormat &&& layDelim $ bibLayout b)
      chkAut _ []     = []
      chkAut a (x:xs) = if author x `elem` a
                        then ("subsequent",x) : chkAut             a  xs
                        else ("first"     ,x) : chkAut (author x : a) xs

procRefs :: Style -> [Reference] -> [Reference]
procRefs (Style {biblio = mb, csMacros = ms , csTerms = ts}) rs
    = maybe rs process mb
    where
      citNum x = x { citationNumber = maybe 0 ((+) 1) . elemIndex x $ rs }
      sort    b = evalSorting ts ms (bibOptions b) (bibSort b)
      process b = map fst . sortBy (comparing snd) . map (citNum &&& sort b) $ rs

refsYSuffix :: [Reference] -> [Reference]
refsYSuffix rs
    = update indices
    where
      ryear a b = issued     a == issued     b && issued     a /= []
      auth  a b = author     a == author     b && author     a /= []
      edit  a b = editor     a == editor     b && editor     a /= []
      tran  a b = translator a == translator b && translator a /= []
      comp  a b = (ryear a b && auth a b) ||
                  (ryear a b && edit a b) ||
                  (ryear a b && tran a b)
      update l = fst $ mapAccumL check rs l
      check r (i,s) = flip (,) [] $ take i r ++ [(r !! i){yearSuffix = s}] ++ drop (i + 1) r
      indices  = concatMap (flip zip suffixes) . nub $ map needed rs
      needed r = case () of
                   _ | i <- findIndices (comp r) rs
                     , length i > 1 -> i
                     | otherwise    -> []

procGroup :: Style -> [(String,Reference)] -> CitationGroup
procGroup (Style {citation = c, csMacros = ms , csTerms = ts})
    = CG (layFormat $ citLayout c) (layDelim $ citLayout c) . concat . process
    where
      format (p,r) = evalLayout (citLayout c) False ts ms (citOptions c) p r
      sort    = evalSorting ts ms (citOptions c) (citSort c) . snd
      process = map fst . sortBy (comparing snd) . map (format &&& sort)

reEvaluate :: Style -> [CiteData] -> [(String,Reference)] -> CitationGroup -> CitationGroup
reEvaluate (Style {citation = c, csMacros = ms , csTerms = ts}) l pr (CG f d os)
    = CG f d . flip concatMap (zip pr os) $
      \((p,r),out) -> if citeKey r `elem` map key l
                      then evalLayout (citLayout c) True ts ms (citOptions c) p r
                      else [out]

suffixes :: [String]
suffixes
    = l ++ [x ++ y | x <- l, y <- l ]
    where
      l = map (return . chr) [97..122]

updateOutput :: [CiteData] -> Output -> Output
updateOutput m o
    | FC k x _ <- o = case elemIndex (CD k x [] [] []) m of
                        Just i -> FC k (disambed $ m !! i) []
                        _      -> o
    | otherwise     = o

getDisOptions :: Style -> [String]
getDisOptions
   = map fst . filter ((==) "true" . snd) .
     filter (isPrefixOf "disambiguate" . fst) . citOptions . citation

getRefs :: [Reference] -> [[(String, String)]] -> [[(String, Reference)]]
getRefs r = map (map $ getReference' r) . generatePosition

-- | The contributors diambiguation data, the list of names and
-- give-names, and the citation year ('FY').
type NamesYear = ([Output],String)

-- | Get the contributors list ('FC') and the year occurring in more
-- then one citation.
getDuplicates :: [CitationGroup] -> [NamesYear]
getDuplicates
    = nub . catMaybes . snd . mapAccumL dupl [] . getData
    where
      getData l = concat . map nub . flip map l $ \(CG _ _ os) ->  concatMap getNamesYear os
      dupl  a c = if snd c `elem` map snd a
                  then if fst c `elem` map fst a then (a,Nothing) else (c:a,Just $ snd c)
                  else if fst c `elem` map fst a then (a,Nothing) else (c:a,Nothing     )

getNamesYear :: Output -> [(String,NamesYear)]
getNamesYear
    = proc rmGivenNames        >>>
      query contribs &&& years >>>
      zipData
    where
      yearsQ  = query getYears
      years o = if yearsQ o /= [] then yearsQ o else [""]
      zipData = uncurry . zipWith $ \(k,c) y -> (,) k (c,y)
      contribs o
          | FC k x _ <- o = [(k,x)]
          | otherwise     = []

getYears :: Output -> [String]
getYears o
    | FY x _ _ <- o = [x]
    | otherwise     = []

hasIfDis :: IfThen -> [Bool]
hasIfDis o
    | IfThen (Condition {disambiguation = d}) _ _ <- o = [d /= []]
    | otherwise                                        = [False  ]

-- | Get the list of possible non ambiguous names for every citation
-- whose contributor list and year is occuring in more then one
-- citation.
getCiteData :: Output -> [CiteData]
getCiteData
    = query contribs &&& years >>>
      zipData
    where
      yearsQ  = query getYears
      years o = if yearsQ o /= [] then yearsQ o else [""]
      zipData = uncurry . zipWith $ \c y -> c {citYear = y}
      contribs o
          | FC k x xs <- o = [CD k x xs [] []]
          | otherwise     = []

-- List Utilities

disambiguate :: (Eq a) => [[a]] -> [[a]]
disambiguate [] = []
disambiguate ls
    = if hasDuplicates takeHead
      then diff ++ disambiguate (map tail' dupl)
      else takeHead
    where
      zipped = zip ls takeHead
      diff   = map        fst  . filter (not . snd) $ zip takeHead (same takeHead)
      dupl   = map (fst . fst) . filter        snd  $ zip zipped   (same takeHead)

      takeHead  = map head' ls
      head'     = foldr (\x _ -> [x]) []
      tail' [x] = [x]
      tail'  x  = tail x

same :: Eq a => [a] -> [Bool]
same [] = []
same l
    = snd $ mapAccumL check (catMaybes dupl) l
    where
      dupl = snd $ mapAccumL (\a x -> if x `elem` a then (a,Just x) else (x:a,Nothing)) [] l
      check a e = if e `elem` a then (a,True) else (e:a,False)

hasDuplicates :: Eq a => [a] -> Bool
hasDuplicates = hasSame or

allTheSame :: Eq a => [a] -> Bool
allTheSame = hasSame and

hasSame :: Eq a => ([Bool] -> Bool) -> [a] -> Bool
hasSame _ [] = False
hasSame f l
    = f . snd $ mapAccumL check [head l] (tail l)
    where
      check a e = if e `elem` a then (a,True) else (e:a,False)