module Text.CSL.Proc.Disamb where
import Control.Arrow ( (&&&), (>>>) )
import Data.List ( (\\), elemIndex, sortBy, mapAccumL
, nub, groupBy, isPrefixOf )
import Data.Maybe
import Data.Ord ( comparing )
import Text.CSL.Eval
import Text.CSL.Reference
import Text.CSL.Style
disambCitations :: Style -> [Reference] -> [[(String, String)]] -> [CitationGroup]
disambCitations s bibs cs
= citOutput
where
refs = getRefs bibs cs
groups = map (procGroup s) refs
duplics = getDuplCiteData groups
disOpts = getCitDisambOptions s
hasNames = "disambiguate-add-names" `elem` disOpts
hasGName = "disambiguate-add-givenname" `elem` disOpts
hasYSuff = "disambiguate-add-year-suffix" `elem` disOpts
needYSuff = map (allTheSame . map disambData) duplics
needName = concatMap fst . filter (not . snd) $ zip duplics needYSuff
addNames = disambWithNames hasNames hasGName needName
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
citOutput = if disOpts /= []
then if hasYSuff
then proc addYearSuffix $ proc (updateOutput addNames) reEvaluated
else proc (updateOutput addNames) reEvaluated
else groups
disambWithNames :: Bool -> Bool -> [CiteData] -> [CiteData]
disambWithNames bn bg needName
| bn && bg = let (n ,ns ) = done addLNames
(n',ns') = done $ addGNames ns
in n ++ n' ++ addGNames ns'
| bn = fst . done $ addLNames
| bg = fst . done $ addGNames needName
| otherwise = []
where
disSolved = zip needName (disambiguate $ map disambData 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))
updateOutput :: [CiteData] -> Output -> Output
updateOutput m o
| OContrib k x _ <- o = case elemIndex (CD k x [] [] []) m of
Just i -> OContrib k (disambed $ m !! i) []
_ -> o
| otherwise = o
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]
hasIfDis :: IfThen -> [Bool]
hasIfDis o
| IfThen (Condition {disambiguation = d}) _ _ <- o = [d /= []]
| otherwise = [False ]
getCitDisambOptions :: Style -> [String]
getCitDisambOptions
= map fst . filter ((==) "true" . snd) .
filter (isPrefixOf "disambiguate" . fst) . citOptions . citation
getRefs :: [Reference] -> [[(String, String)]] -> [[(String, Reference)]]
getRefs r = map (map $ getReference' r) . generatePosition
getDuplCiteData :: [CitationGroup] -> [[CiteData]]
getDuplCiteData g
= groupBy (\a b -> collide a == collide b) . sortBy (comparing collide) $ duplicates
where
collide = proc rmGivenNames . collision
citeData = nub $ concatMap (mapGroupOutput getCiteData) g
duplicates = filter (collide &&& citYear >>> flip elem (getDuplNamesYear g)) citeData
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
| OContrib k x xs <- o = [CD k x xs [] []]
| otherwise = []
type NamesYear = ([Output],String)
getDuplNamesYear :: [CitationGroup] -> [NamesYear]
getDuplNamesYear
= nub . catMaybes . snd . mapAccumL dupl [] . getData
where
getData = concat . map nub . map (mapGroupOutput getNamesYear)
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
| OContrib k x _ <- o = [(k,x)]
| otherwise = []
getYears :: Output -> [String]
getYears o
| OYear x _ _ <- o = [x]
| otherwise = []
disambiguate :: (Eq a) => [[a]] -> [[a]]
disambiguate [] = []
disambiguate l
= if hasMult l && not (allTheSame l) && hasDuplicates heads
then disambiguate (rest l)
else heads
where
heads = map head' l
rest = map (\(b,x) -> if b then tail' x else head' x) . zip (same heads)
hasMult [] = False
hasMult (x:xs) = length x > 1 || hasMult xs
tail' [x] = [x]
tail' x = if null x then x else tail x
same :: Eq a => [a] -> [Bool]
same [] = []
same l
= map (flip elem dupl) l
where
dupl = catMaybes . snd . macc [] $ l
macc = mapAccumL $ \a x -> if x `elem` a then (a,Just x) else (x:a,Nothing)
hasDuplicates :: Eq a => [a] -> Bool
hasDuplicates = or . same
allTheSame :: Eq a => [a] -> Bool
allTheSame = and . same