Proc.hs

{-# 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 Control.Arrow ( (&&&), (***) )
import Data.Char ( chr )
import Data.List ( elemIndex, findIndices
                 , sortBy, mapAccumL, nub )
import Data.Maybe
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

-- | 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 :: Style -> [Reference] -> [[(String, String)]] -> [[FormattedOutput]]
processCitations s rs
    = citations . citeproc s rs

-- | With a 'Style' and the list of 'Reference's produce the
-- 'FormattedOutput' for the bibliography.
processBibliography :: Style -> [Reference] -> [[FormattedOutput]]
processBibliography s rs
    = bibliography $ citeproc s rs [zip (map citeKey rs) (repeat "")]

-- | 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 and the bibliography.
citeproc :: Style -> [Reference] -> [[(String, String)]] -> BiblioData
citeproc 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   = refsYSuffix . procRefs s . map (getReference rs) .
                     nub . map (id *** const []) . concat $ cs
      biblioOutput = if "disambiguate-add-year-suffix" `elem` getCitDisambOptions s
                     then map (map formatOutput) $ proc addYearSuffix $ procBiblio s biblioRefs
                     else map (map formatOutput) $ procBiblio s biblioRefs
      outputGroups = map $ \(CG fm d os) -> map formatOutput $ outputList fm d os
      citsOutput   = outputGroups $ collapseCitGroups s $ disambCitations s biblioRefs cs

-- | With a 'Style' and a sorted list of 'Reference's produce the
-- evaluated output for the bibliography.
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

-- | 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 , csTerms = ts}) rs
    = maybe rs process mb
    where
      citNum x = x { citationNumber = maybe 0 ((+) 1 . fromIntegral) . elemIndex x $ rs }
      sort    b = evalSorting ts ms (bibOptions b) (bibSort b)
      process b = map fst . sortBy (comparing snd) . map (citNum &&& sort b) $ rs

-- | Given the list of 'Reference's, compare year and contributors'
-- names and, when they collide, generate a suffix to append to the
-- year for disambiguation.
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    -> []

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