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
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
type NamesYear = ([Output],String)
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 ]
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 = []
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)