    {-# LANGUAGE PatternGuards, DeriveDataTypeable #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Text.CSL.Proc
    -- 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 disambiguation and citation collapsing.
    --
    -----------------------------------------------------------------------------

    module Text.CSL.Proc where

    import Control.Arrow ( (&&&), (>>>), second )
    import Data.Char ( toLower )
    import Data.List
    import Data.Ord  ( comparing )

    import Text.CSL.Eval hiding ( trim )
    import Text.CSL.Output.Plain
    import Text.CSL.Parser
    import Text.CSL.Proc.Collapse
    import Text.CSL.Proc.Disamb
    import Text.CSL.Reference
    import Text.CSL.Style

    data ProcOpts
        = ProcOpts
          { bibOpts :: BibOpts
          }
        deriving ( Show, Read, Eq )

    data BibOpts
        = Select  [(String, String)] [(String, String)]
        | Include [(String, String)] [(String, String)]
        | Exclude [(String, String)] [(String, String)]
        deriving ( Show, Read, Eq )

    procOpts :: ProcOpts
    procOpts = ProcOpts (Select [] [])

    -- | With a 'Style', a list of 'Reference's and the list of citation
    -- groups (the list of citations with their locator), produce the
    -- 'FormattedOutput' for each citation group.
    processCitations :: ProcOpts -> Style -> [Reference] -> Citations -> [[FormattedOutput]]
    processCitations ops s rs
        = citations . citeproc ops s rs

    -- | With a 'Style' and the list of 'Reference's produce the
    -- 'FormattedOutput' for the bibliography.
    processBibliography :: ProcOpts -> Style -> [Reference] -> [[FormattedOutput]]
    processBibliography ops s rs
        = bibliography $ citeproc ops s rs [map (\r -> emptyCite { citeId = refId r}) rs]

    -- | With a 'Style', a list of 'Reference's and the list of
    -- 'Citations', produce the 'FormattedOutput' for each citation group
    -- and the bibliography.
    citeproc :: ProcOpts -> Style -> [Reference] -> Citations -> BiblioData
    citeproc ops s rs cs
        = BD citsOutput biblioOutput
        where
          -- the list of bib entries, as a list of Reference, with
          -- position, locator and year suffix set.
          biblioRefs   = procRefs s . map (getReference rs) .
                         nubBy (\a b -> citeId a == citeId b) . concat $ cs
          biblioOutput = if "disambiguate-add-year-suffix" `elem` getCitDisambOptions s
                         then map formatOutputList $
                              map (proc (updateYearSuffixes yearS) . map addYearSuffix) $
                              procBiblio (bibOpts ops) s biblioRefs
                         else map formatOutputList $
                              procBiblio (bibOpts ops) s biblioRefs
          citsAndRefs  = processCites biblioRefs cs
          (yearS,citG) = disambCitations s biblioRefs cs $ map (procGroup s) citsAndRefs
          citsOutput   = map (formatCitLayout s) . collapseCitGroups s $ citG

    -- | Given the CSL 'Style' and the list of 'Reference's sort the list
    -- according to the 'Style' and assign the citation number to each
    -- 'Reference'.
    procRefs :: Style -> [Reference] -> [Reference]
    procRefs (Style {biblio = mb, csMacros = ms , styleLocale = l, styleAbbrevs = as, csOptions = opts}) rs
        = maybe (setCNum rs) process mb
        where
          opts'   b = mergeOptions (bibOptions b) opts
          setCNum   = map (\(x,y) -> x { citationNumber = fromIntegral y }) . flip zip ([1..] :: [Int])
          sort_   b = evalSorting (EvalSorting emptyCite {citePosition = "first"})l ms (opts' b) (bibSort b) as
          process b = setCNum . sortItems . map (id &&& sort_ b) $ rs

    sortItems :: Show a => [(a,[Sorting])] -> [a]
    sortItems [] = []
    sortItems l
        = case head . concatMap (map snd) $ result of
            [] -> concatMap (map fst) result
            _  -> if or $ map ((<) 1 . length) result
                  then concatMap sortItems result
                  else concatMap (map fst) result
        where
          result = process l
          process = sortBy (comparing $ head' . snd)                 >>>
                    groupBy (\a b -> head' (snd a) == head' (snd b)) >>>
                    map (map $ second tail')

    -- | With a 'Style' and a sorted list of 'Reference's produce the
    -- evaluated output for the bibliography.
    procBiblio :: BibOpts -> Style -> [Reference] -> [[Output]]
    procBiblio bos (Style {biblio = mb, csMacros = ms , styleLocale = l,
                           styleAbbrevs = as, csOptions = opts}) rs
        = maybe [] process mb
        where
          process b   = flip map (render b) $ uncurry formatBiblioLayout (layFormat &&& layDelim $ bibLayout b)
          render  b   = subsequentAuthorSubstitute b . map (evalBib b) . filterRefs bos $ rs
          evalBib b r = evalLayout (bibLayout b) (EvalBiblio emptyCite {citePosition = "first"}) False l ms
                                   (mergeOptions (bibOptions b) opts) as r

    subsequentAuthorSubstitute :: Bibliography -> [[Output]] -> [[Output]]
    subsequentAuthorSubstitute b = if null subAuthStr then id else chkCreator
        where
          subAuthStr  = getOptionVal "subsequent-author-substitute"      (bibOptions b)
          subAuthRule = getOptionVal "subsequent-author-substitute-rule" (bibOptions b)

          queryContrib = proc' rmLabel . query contribsQ
          getContrib = if null subAuthStr
                       then const []
                       else case subAuthRule of
                              "partial-first" -> head'  . query namesQ  . queryContrib
                              "partial-each"  ->          query namesQ  . queryContrib
                              _               ->                          queryContrib

          getPartialEach x xs = concat . head' . map fst . reverse .
                                sortBy (comparing $ length . snd) . filter ((<) 0 . length . snd) .
                                zip xs . map (takeWhile id . map (uncurry (==)) . zip x) $ xs

          chkCreator = if subAuthRule == "partial-each" then chPartialEach [] else chkCr []

          chkCr _ []     = []
          chkCr a (x:xs) = let contribs = getContrib x in
                           if  contribs `elem` a
                           then substituteAuth []
                                x : chkCr             a  xs
                           else x : chkCr (contribs : a) xs

          chPartialEach _ [] = []
          chPartialEach a (x:xs) = let contribs = getContrib x
                                       partial  = getPartialEach contribs a in
                                   if not $ null partial
                                   then substituteAuth partial x :
                                        if length partial < length contribs
                                        then chPartialEach (contribs : a) xs
                                        else chPartialEach             a  xs
                                   else x  : chPartialEach (contribs : a) xs

          substituteAuth a = if subAuthRule == "complete-each"
                             then proc chNamas else proc (updateContribs a)

          updateContribs a o@(OContrib i r y ds os)
              = if r == "author" || r == "authorsub" then OContrib i r upCont ds os else o
              where
                upCont = case subAuthRule of
                           "partial-first" -> rmFirstName      y
                           "partial-each"  -> rmSelectedName a y
                           _               -> OStr subAuthStr emptyFormatting : proc rmNames y
          updateContribs _ o = o

          contribsQ o
              | OContrib _ r c _ _ <- o = if r == "author" || r == "authorsub" then c else []
              | otherwise               = []
          namesQ o
              | OName {} <- o = [o]
              | otherwise     = []
          rmSelectedName _ [] = []
          rmSelectedName a (o:os)
              | OName {} <- o = (if o `elem` a then OStr subAuthStr emptyFormatting else o) : rmSelectedName a os
              | otherwise     = o : rmSelectedName a os
          rmFirstName [] = []
          rmFirstName (o:os)
              | OName {} <- o = OStr subAuthStr emptyFormatting : os
              | otherwise     = o : rmFirstName os
          chNamas o
              | OName s _ os f <- o = OName s [OStr subAuthStr emptyFormatting] os f
              | otherwise           = o
          rmNames o
              | OName {} <- o = ONull
              | OStr  {} <- o = ONull
              | ODel  {} <- o = ONull
              | otherwise     = o
          rmLabel [] = []
          rmLabel (o:os)
              | OLabel {} <- o =     rmLabel os
              | otherwise      = o : rmLabel os

    filterRefs :: BibOpts -> [Reference] -> [Reference]
    filterRefs bos refs
        | Select  s q <- bos = filter (select  s) . filter (quash q) $ refs
        | Include i q <- bos = filter (include i) . filter (quash q) $ refs
        | Exclude e q <- bos = filter (exclude e) . filter (quash q) $ refs
        | otherwise          = refs
        where
          quash  [] _ = True
          quash   q r = not . and . flip map q $ \(f,v) ->       lookup_ r f v
          select  s r =       and . flip map s $ \(f,v) ->       lookup_ r f v
          include i r =       or  . flip map i $ \(f,v) ->       lookup_ r f v
          exclude e r =       and . flip map e $ \(f,v) -> not $ lookup_ r f v
          lookup_ r f v = case f of
                            "type"         -> look "ref-type"
                            "id"           -> look "ref-id"
                            "categories"   -> look "categories"
                            x              -> look x
              where
                look s = case lookup s (mkRefMap r) of
                           Just x | Just v' <- (fromValue x :: Maybe RefType  ) -> v == toShow (show v')
                                  | Just v' <- (fromValue x :: Maybe String   ) -> v  == v'
                                  | Just v' <- (fromValue x :: Maybe [String] ) -> v `elem` v'
                                  | Just v' <- (fromValue x :: Maybe [Agent]  ) -> v == [] && v' == [] || v == show v'
                                  | Just v' <- (fromValue x :: Maybe [RefDate]) -> v == [] && v' == [] || v == show v'
                           _                                                    -> False

    -- | Given the CSL 'Style' and the list of 'Cite's coupled with their
    -- 'Reference's, generate a 'CitationGroup'. The citations are sorted
    -- according to the 'Style'.
    procGroup :: Style -> [(Cite, Reference)] -> CitationGroup
    procGroup (Style {citation = ct, csMacros = ms , styleLocale = l,
                      styleAbbrevs = as, csOptions = opts}) cr
        = CG authIn (layFormat $ citLayout ct) (layDelim $ citLayout ct) (authIn ++ co)
        where
          (co, authIn) = case cr of
                           (c:_) -> if authorInText (fst c)
                                    then (,) (filter (eqCites (/=) c) $ result
                                             ) . foldr (\x _ -> [x]) [] .
                                              filter (eqCites (==) c) $ result
                                    else (,) result []
                           _     -> (,) result []
          eqCites eq c = fst >>> citeId &&& citeHash >>> eq (citeId &&& citeHash $ fst c)
          opts'        = mergeOptions (citOptions ct) opts
          format (c,r) = (,) c $ evalLayout (citLayout ct) (EvalCite c) False l ms opts' as r
          sort_  (c,r) = evalSorting (EvalSorting c) l ms opts' (citSort ct) as r
          process      = map (second (flip Output emptyFormatting) . format &&& sort_)
          result       = sortItems $ process cr

    formatBiblioLayout :: Formatting -> Delimiter -> [Output] -> [Output]
    formatBiblioLayout  f d = appendOutput f . addDelim d

    formatCitLayout :: Style -> CitationGroup -> [FormattedOutput]
    formatCitLayout s (CG co f d cs)
        | [a] <- co = formatAuth a : formatCits (fst >>> citeId &&& citeHash >>> setAsSupAu $ a) cs
        | otherwise = formatCits id cs
        where
          formatAuth   = formatOutput . localMod
          formatCits g = formatOutputList . appendOutput formatting . addAffixes f .
                         addDelim d . map (fst &&& localMod >>> uncurry addCiteAffixes) . g
          formatting   = unsetAffixes f
          localMod     = if cs /= []
                         then uncurry $ localModifiers s (co /= [])
                         else snd
          setAsSupAu h = map $ \(c,o) -> if (citeId c, citeHash c) == h
                                         then flip (,) o c { authorInText   = False
                                                           , suppressAuthor = True }
                                         else flip (,) o c

    addAffixes :: Formatting -> [Output] -> [Output]
    addAffixes f os
        | []      <- os = []
        | [ONull] <- os = []
        | otherwise     = pref ++ suff
        where
          pref = if prefix f /= []
                 then [OStr (prefix f) emptyFormatting] ++ os
                 else os
          suff = if suffix f /= [] &&
                 elem (head $ suffix f) ",.:?!" &&
                 [head $ suffix f] == lastOutput
                 then [OStr (tail $ suffix f) emptyFormatting]
                 else suff'
          suff' = if suffix f /= [] then [OStr (suffix f) emptyFormatting] else []
          lastOutput = case renderPlain (formatOutputList os) of
                         [] -> ""
                         x  -> [last x]

    -- | The 'Bool' is 'True' if we are formatting a textual citation (in
    -- pandoc terminology).
    localModifiers :: Style -> Bool -> Cite -> Output -> Output
    localModifiers s b c
        | authorInText   c = check . return . proc rmFormatting . contribOnly s
        | suppressAuthor c = check . rmContrib . return
        | otherwise        = id
        where
          isPunct = and . map (flip elem ".,;:!? ")
          check o = case cleanOutput o of
                      [] -> ONull
                      x  -> case trim x of
                              [] -> ONull
                              x' -> Output x' emptyFormatting
          hasOutput o
              | Output [] _ <- o = [False]
              | ODel      _ <- o = [False]
              | OSpace      <- o = [False]
              | ONull       <- o = [False]
              | otherwise        = [True]
          trim [] = []
          trim (o:os)
              | Output ot f <- o, p <- prefix f,  p /= []
              , isPunct p         = trim $ Output ot f { prefix = []} : os
              | Output ot f <- o  = if or (query hasOutput ot)
                                    then Output (trim ot) f : os
                                    else Output       ot  f : trim os
              | ODel _      <- o  = trim os
              | OSpace      <- o  = trim os
              | OStr    x f <- o  = OStr x (if isPunct (prefix f)
                                            then f { prefix = []} else f) : os
              | otherwise         = o:os
          rmFormatting f
              | Formatting {} <- f = emptyFormatting { prefix = prefix f
                                                     , suffix = suffix f}
              | otherwise          = f
          rmCitNum o
              | OCitNum {} <- o = ONull
              | otherwise       = o
          rmContrib [] = []
          rmContrib o
              | b, isNumStyle o = proc rmCitNum o
              | otherwise       = rmContrib' o
          rmContrib' [] = []
          rmContrib' (o:os)
              | Output ot f <- o = Output (rmContrib' ot) f : rmContrib' os
              | ODel _ <- o
              , OContrib _ "author"
                         _ _ _ : xs <- os = rmContrib' xs
              | ODel _ <- o
              , OContrib _ "authorsub"
                         _ _ _ : xs <- os = rmContrib' xs
              | OContrib _ "author" _ _ _ <- o
              , ODel _ : xs <- os =     rmContrib' xs
              | OContrib _ "authorsub" _ _ _ <- o
              , ODel _ : xs <- os =     rmContrib' xs
              | OContrib _ "author"
                      _ _ _ <- o =     rmContrib' os
              | OContrib _ "authorsub"
                      _ _ _ <- o =     rmContrib' os
              | OStr x _ <- o
              , "ibid" <- filter (/= '.') (map toLower x) = rmContrib' os

              | otherwise        = o : rmContrib' os

    contribOnly :: Style -> Output -> Output
    contribOnly s o
        | isNumStyle [o]
        , OCitNum  {} <- o = Output [ OStr (query getRefTerm s) emptyFormatting
                                    , OSpace, o] emptyFormatting
        | OContrib _ "author"
                _ _ _ <- o = o
        | OContrib _ "authorsub"
                _ _ _ <- o = o
        | Output ot f <- o = Output (cleanOutput $ map (contribOnly s) ot) f
        | OStr    x _ <- o
        , "ibid" <- filter (/= '.')
           (map toLower x) = o
        | otherwise        = ONull
        where
          getRefTerm :: CslTerm -> String
          getRefTerm t
              | CT "reference" Long _ _ x _ _ <- t = capitalize x
              | otherwise                          = []