module Text.CSL.Proc where
import Control.Arrow ( (&&&), (>>>), second )
import Data.List
import Data.Ord ( comparing )
import Text.CSL.Eval
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 [] [])
processCitations :: ProcOpts -> Style -> [Reference] -> Citations -> [[FormattedOutput]]
processCitations ops s rs
= citations . citeproc ops s rs
processBibliography :: ProcOpts -> Style -> [Reference] -> [[FormattedOutput]]
processBibliography ops s rs
= bibliography $ citeproc ops s rs [map (\r -> emptyCite { citeId = refId r}) rs]
citeproc :: ProcOpts -> Style -> [Reference] -> Citations -> BiblioData
citeproc ops s rs cs
= BD citsOutput biblioOutput
where
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
procRefs :: Style -> [Reference] -> [Reference]
procRefs (Style {biblio = mb, csMacros = ms , styleLocale = l, csOptions = opts}) rs
= maybe rs process mb
where
opts' b = mergeOptions (bibOptions b) opts
citNum x = x { citationNumber = maybe 0 ((+) 1 . fromIntegral) . elemIndex x $ rs }
sort_ b = evalSorting (EvalSorting emptyCite {citePosition = "first"})l ms (opts' b) (bibSort b)
process b = sortItems . map (citNum &&& 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')
procBiblio :: BibOpts -> Style -> [Reference] -> [[Output]]
procBiblio bos (Style {biblio = mb, csMacros = ms , styleLocale = l, csOptions = opts}) rs
= maybe [] process mb
where
render b = map (format b) . chkAut [] . filterRefs bos $ rs
process b = flip map (render b) $ uncurry formatBiblioLayout (layFormat &&& layDelim $ bibLayout b)
format b (p,r) = evalLayout (bibLayout b) (EvalBiblio p) False l ms (mergeOptions (bibOptions b) opts) r
chkAut _ [] = []
chkAut a (x:xs) = if author x `elem` a
then ("subsequent",x) : chkAut a xs
else ("first" ,x) : chkAut (author x : a) xs
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
procGroup :: Style -> [(Cite, Reference)] -> CitationGroup
procGroup (Style {citation = ct, csMacros = ms , styleLocale = l, csOptions = opts}) cr
= CG authInTxt (layFormat $ citLayout ct) (layDelim $ citLayout ct) result
where
authInTxt = case cr of
(c:_) -> if authorInText (fst c)
then foldr (\x _ -> [x]) [] $
filter ((==) (citeId $ fst c) . citeId . fst) result
else []
_ -> []
opts' = mergeOptions (citOptions ct) opts
format (c,r) = (,) c $ evalLayout (citLayout ct) (EvalCite c) False l ms opts' r
sort_ (c,r) = evalSorting (EvalSorting c) l ms opts' (citSort ct) 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 (setAsSupAu . citeHash . fst $ a) cs
| otherwise = formatCits id cs
where
formatAuth = formatOutput . localMod
formatCits g = formatOutputList . appendOutput formatting .
addAffixes f . addDelim d . map localMod . g
formatting = if co /= []
then emptyFormatting
else unsetAffixes f
localMod = if cs /= []
then uncurry $ localModifiers s (co /= [])
else snd
setAsSupAu h = map $ \(c,o) -> if 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]
localModifiers :: Style -> Bool -> Cite -> Output -> Output
localModifiers s b c
| authorInText c = check . return . proc rmFormatting . contribOnly
| 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
trim [] = []
trim (o:os)
| Output ot f <- o = Output (trim ot) f : 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
contribOnly o
| isNumStyle [o]
, OCitNum {} <- o = Output [ OStr (query getRefTerm s) emptyFormatting
, OSpace, o] emptyFormatting
| OContrib _ "author"
_ _ _ <- o = o
| Output ot f <- o = Output (cleanOutput $ map contribOnly ot) f
| otherwise = ONull
rmContrib [] = []
rmContrib o
| b, isNumStyle o = []
rmContrib (o:os)
| Output ot f <- o = Output (rmContrib ot) f : rmContrib os
| OContrib _ "author"
_ _ _ <- o = rmContrib os
| otherwise = o : rmContrib os
isNumStyle = null . query authorOrDate
authorOrDate o
| OContrib {} <- o = ['a']
| OYear {} <- o = ['a']
| OYearSuf {} <- o = ['a']
| OStr {} <- o = ['a']
| OPan {} <- o = ['a']
| otherwise = []
getRefTerm :: TermMap -> String
getRefTerm t
| (("reference", Long), (x,_)) <- t = capitalize x
| otherwise = []