{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE PatternGuards     #-}
-----------------------------------------------------------------------------
-- |
-- 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 Prelude
import           Control.Applicative    ((<|>))
import           Control.Arrow          (second, (&&&), (>>>))
import           Control.Monad.State    (execState, modify)
import           Data.Aeson
import           Data.Char              (isDigit, isLetter, toLower)
import           Data.List
import           Data.Maybe             (mapMaybe)
import           Data.Ord               (comparing)
import           Text.CSL.Eval
import           Text.CSL.Proc.Collapse
import           Text.CSL.Proc.Disamb
import           Text.CSL.Reference
import           Text.CSL.Style
import           Text.CSL.Util          (proc, proc', query, tr', uncamelize)
import           Text.Pandoc.Definition (Block (Para),
                                         Inline (Note, Space, Str))
data ProcOpts
    = ProcOpts
      { bibOpts       :: BibOpts
      , linkCitations :: Bool
      }
    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 )

newtype FieldVal = FieldVal{
                      unFieldVal :: (String, String)
                    } deriving Show

instance FromJSON FieldVal where
  parseJSON (Object v) = do
    x <- v .: "field"
    y <- v .: "value"
    return $ FieldVal (x,y)
  parseJSON _ = fail "Could not parse FieldVal"

instance FromJSON BibOpts where
  parseJSON (Object v) = do
    quash <- v .:? "quash".!= []
    let quash' = map unFieldVal quash
    (v .: "select" >>= \x -> return $ Select (map unFieldVal x) quash')
     <|>
     (v .: "include" >>= \x -> return $ Include (map unFieldVal x) quash')
     <|>
     (v .: "exclude" >>= \x -> return $ Exclude (map unFieldVal x) quash')
     <|>
     return (Select [] quash')
  parseJSON _ = return $ Select [] []

procOpts :: ProcOpts
procOpts = ProcOpts
      { bibOpts = Select [] []
      , linkCitations = False
      }

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

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

-- | With a 'Style', a list of 'Reference's and the list of
-- 'Citations', produce the 'Formatted' for each citation group
-- and the bibliography.
citeproc :: ProcOpts -> Style -> [Reference] -> Citations -> BiblioData
citeproc ops s rs cs
    = BD citsOutput biblioOutput $ map (unLiteral . refId) biblioRefs
    where
      -- the list of bib entries, as a list of Reference, with
      -- position, locator and year suffix set.
      biblioRefs   = procRefs s . mapMaybe (getReference rs) .
                     nubBy (\a b -> citeId a == citeId b) . concat $ cs
      biblioOutput = if "disambiguate-add-year-suffix" `elem` getCitDisambOptions s
                     then map (formatOutputList .
                               proc (updateYearSuffixes yearS) . map addYearSuffix) $
                          procBiblio (bibOpts ops) s biblioRefs
                     else map formatOutputList $
                          tr' "citeproc:after procBiblio" $
                          procBiblio (bibOpts ops) s biblioRefs
      citsAndRefs  = processCites biblioRefs cs
      (yearS,citG) = disambCitations s biblioRefs cs $ map (procGroup s) citsAndRefs
      citsOutput   = map (formatCitLayout s) .
                     tr' "citeproc:collapsed" .
                     collapseCitGroups s .
                     (if linkCitations ops && styleClass s == "in-text"
                         then proc addLink
                         else id) .
                     tr' "citeproc:citG" $
                     citG
      addLink :: (Cite, Output) -> (Cite, Output)
      addLink (cit, outp) = (cit, proc (addLink' (citeId cit)) outp)
      addLink' citeid (OYear y _ f) =
         OYear y citeid f{hyperlink = "#ref-" ++ citeid}
      addLink' citeid (OYearSuf y _ d f) =
         OYearSuf y citeid d f{hyperlink = "#ref-" ++ citeid}
      addLink' citeid (OCitNum n f) =
         OCitNum n f{hyperlink = "#ref-" ++ citeid}
      addLink' citeid (OCitLabel l f) =
         OCitLabel l f{hyperlink = "#ref-" ++ citeid}
      addLink' citeid (Output xs@(OStr _ _: _) f) =
         Output xs f{hyperlink = "#ref-" ++ citeid}
      addLink' _ x = x

-- | 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 . Just) $ rs

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

-- | 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
    = map addSpaceAfterCitNum $ maybe [] process mb
    where
      -- handle second-field-align (sort of)
      addSpaceAfterCitNum [Output (OCitNum n f : xs) f']
        | secondFieldAlign == Just "flush"  =
            [Output (OCitNum n f : OSpace : xs) f']
        | secondFieldAlign == Just "margin" =
            [Output (OCitNum n f : OSpace : xs) f']
        | otherwise = [Output (OCitNum n f : xs) f']
      addSpaceAfterCitNum xs = xs

      secondFieldAlign = lookup "second-field-align" $ maybe [] bibOptions mb

      process :: Bibliography -> [[Output]]
      process b   = map (formatBiblioLayout (layFormat $ bibLayout b) (layDelim $ bibLayout b)) $ render b

      render :: Bibliography -> [[Output]]
      render  b   = subsequentAuthorSubstitute b . map (evalBib b) . filterRefs bos $ rs

      evalBib :: Bibliography -> Reference -> [Output]
      evalBib b = evalLayout (bibLayout b) (EvalBiblio emptyCite {citePosition = "first"}) False l ms (mergeOptions (bibOptions b) opts) as . Just

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" -> take 1  . query namesQ  . queryContrib
                          "partial-each"  ->          query namesQ  . queryContrib
                          _               ->                          queryContrib

      getPartialEach x xs = concat . take 1 . map fst .
                            sortBy (flip (comparing $ length . snd)) . filter ((<) 0 . length . snd) .
                            zip xs . map (takeWhile id .  zipWith (==) 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 $ all (lookup_ r) q
      select  s r =       all (lookup_ r) s
      include i r =       any (lookup_ r) i
      exclude e r =       all (not . lookup_ r) e
      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 (Just r)) of
                       Just x | Just v' <- (fromValue x :: Maybe RefType  ) -> v == uncamelize (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]  ) -> null v && null v' || v == show v'
                              | Just v' <- (fromValue x :: Maybe [RefDate]) -> null v && null 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, Maybe 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,
                                      take 1 .  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       = concatMap sortItems $ toChunks $ process cr
      -- toChunks splits the citations up into groups, such that
      -- a citation with a non-null prefix is by itself in its
      -- group, otherwise preserving the order (see #292 for
      -- motivation; we don't want to move prefixed citations
      -- around)
      toChunks  xs = reverse $ execState (toChunks' xs) []
      toChunks' xs = do
        case break hasPrefix xs of
                ([], [])   -> return ()
                ([], y:ys) -> modify ([y]:) >> toChunks' ys
                (zs, ys)   -> modify (zs:) >> toChunks' ys
      hasPrefix ((c,_),_) = citePrefix c /= mempty

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

formatCitLayout :: Style -> CitationGroup -> Formatted
formatCitLayout s (CG co f d cs)
    | [a] <- co = combine (formatAuth a)
                  (formatCits $
                   (fst >>> citeId &&& citeHash >>> setAsSupAu $ a) cs)
    | otherwise = formatCits cs
    where
      isNote    = styleClass s == "note"
      toNote (Formatted []) = mempty
      toNote (Formatted xs) = Formatted [Note [Para xs]]
      combine (Formatted []) ys = ys
      combine xs ys =
        case ys of
             Formatted []           -> xs
             Formatted (Note _ : _) -> xs <> ys
             Formatted (Str [c]:_)  | c `elem` (", ;:" :: String) -> xs <> ys
             _                      -> xs <> Formatted [Space] <> ys
      formatAuth   = formatOutput . localMod
      formatCits   = (if isNote then toNote else id) .
                     formatOutputList . appendOutput formatting . addAffixes f .
                     addDelim d .
                     map (fst &&& localMod >>> uncurry addCiteAffixes)
      formatting   = f{ prefix = [], suffix = [],
                        verticalAlign = if isAuthorInText cs
                                           then ""
                                           else verticalAlign f }
      isAuthorInText []        = False
      isAuthorInText ((c,_):_) = authorInText c
      localMod     = uncurry $ localModifiers s (not $ null co)
      setAsSupAu h = map $ \(c,o) -> if (citeId c, citeHash c) == h
                                     then (c { authorInText   = False
                                             , suppressAuthor = True }, o)
                                     else (c, o)

addAffixes :: Formatting -> [Output] -> [Output]
addAffixes f os
    | []      <- os            = []
    | [ONull] <- os            = []
    | [Output [ONull] _] <- os = []
    | otherwise                = pref ++ suff
    where
      pref = if not (null (prefix f))
             then OStr (prefix f) emptyFormatting : os
             else os
      suff = case suffix f of
                  []     -> []
                  (c:cs)
                    | isLetter c || isDigit c || c == '(' || c == '[' ->
                         [OSpace, OStr (c:cs) emptyFormatting]
                    | otherwise -> [OStr (c:cs) emptyFormatting]

-- | 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 . contribOnly s
    | suppressAuthor c = check . rmContrib . return
    | otherwise        = id
    where
      isPunct' [] = False
      isPunct' xs = all (`elem` (".,;:!? " :: String)) xs
      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
      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 n f <- o = Output [ OCitNum n f{
                                       verticalAlign = "",
                                       prefix = "",
                                       suffix = "" } ] emptyFormatting
    | OContrib _ "author"
            _ _ _ <- o = o
    | OContrib _ "authorsub"
            _ _ _ <- o = o
    | Output ot f <- o = Output (cleanOutput $ map (contribOnly s) ot)
                         f{ verticalAlign = "",
                            prefix = "",
                            suffix = "" }
    | OStr    x _ <- o
    , "ibid" <- filter (/= '.')
       (map toLower x) = o
    | otherwise        = ONull