citeproc-0.9: src/Citeproc/Eval.hs
{-# LANGUAGE StrictData #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Citeproc.Eval
( evalStyle )
where
import Citeproc.Types
import Citeproc.Style (mergeLocales)
import qualified Citeproc.Unicode as Unicode
import Control.Monad.Trans.RWS.CPS
import Data.Containers.ListUtils (nubOrdOn, nubOrd)
import Safe (headMay, headDef, lastMay, initSafe, tailSafe, maximumMay)
import Data.Maybe
import Control.Monad (foldM, foldM_, zipWithM, when, unless)
import qualified Data.Map as M
import qualified Data.Set as Set
import Data.Coerce (coerce)
import Data.List (find, intersperse, sortBy, sortOn, groupBy, foldl', transpose,
sort, (\\))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Char (isSpace, isDigit, isUpper, isLower, isLetter,
ord, chr)
import Text.Printf (printf)
import Control.Applicative
import Data.Generics.Uniplate.Operations (universe, transform)
-- import Debug.Trace (trace)
-- traceShowIdLabeled :: Show a => String -> a -> a
-- traceShowIdLabeled label x =
-- trace (label ++ ": " ++ show x) x
-- import Text.Show.Pretty (ppShow)
-- ppTrace :: Show a => a -> a
-- ppTrace x = trace (ppShow x) x
data Context a =
Context
{ contextLocale :: Locale
, contextCollate :: [SortKeyValue] -> [SortKeyValue] -> Ordering
, contextAbbreviations :: Maybe Abbreviations
, contextStyleOptions :: StyleOptions
, contextLocator :: Maybe Text
, contextLabel :: Maybe Text
, contextPosition :: [Position]
, contextInSubstitute :: Bool
, contextInSortKey :: Bool
, contextInBibliography :: Bool
, contextSubstituteNamesForm :: Maybe NamesFormat
}
-- used internally for group elements, which
-- are skipped if (a) the group calls a variable
-- but (b) all of the variables called are empty.
data VarCount =
VarCount
{ variablesAccessed :: Int
, variablesNonempty :: Int
} deriving (Show)
data EvalState a =
EvalState
{ stateVarCount :: VarCount
, stateLastCitedMap :: M.Map ItemId (Int, Maybe Int, Int,
Bool, Maybe Text, Maybe Text)
-- (citegroup, noteNum, posInGroup,
-- aloneInCitation, label, locator)
, stateNoteMap :: M.Map Int (Set.Set ItemId) -- ids cited in note
, stateRefMap :: ReferenceMap a
, stateReference :: Reference a
, stateUsedYearSuffix :: Bool
, stateUsedIdentifier :: Bool
-- ^ tracks whether an identifier (DOI,PMCID,PMID,URL) has yet been used
, stateUsedTitle :: Bool
-- ^ tracks whether the item title has yet been used
} deriving (Show)
type Eval a = RWS (Context a) (Set.Set Text) (EvalState a)
updateVarCount :: Int -> Int -> Eval a ()
updateVarCount total' nonempty' =
modify $ \st ->
let VarCount{ variablesAccessed = total
, variablesNonempty = nonempty } = stateVarCount st
in st{ stateVarCount =
VarCount { variablesAccessed = total + total',
variablesNonempty = nonempty + nonempty' } }
evalStyle :: CiteprocOutput a
=> Style a -- ^ Parsed CSL style.
-> Maybe Lang -- ^ Override style default locale.
-> [Reference a] -- ^ List of references (bibliographic data).
-> [Citation a] -- ^ List of citations.
-> ([Output a], [(Text, Output a)], [Text])
-- ^ (citations, (id, bibentry) pairs, warnings)
evalStyle style mblang refs' citations =
(citationOs, bibliographyOs, Set.toList warnings)
where
refs'' = refs' ++ extractItemData citations
(refs, refmap) = makeReferenceMap refs''
((citationOs, bibliographyOs), warnings) = evalRWS go
Context
{ contextLocale = mergeLocales mblang style
, contextCollate = \xs ys ->
compSortKeyValues (Unicode.comp mblang)
xs ys
, contextAbbreviations = styleAbbreviations style
, contextStyleOptions = styleOptions style
, contextLocator = Nothing
, contextLabel = Nothing
, contextPosition = []
, contextInSubstitute = False
, contextInSortKey = False
, contextInBibliography = False
, contextSubstituteNamesForm = Nothing
}
EvalState
{ stateVarCount = VarCount 0 0
, stateLastCitedMap = mempty
, stateNoteMap = mempty
, stateRefMap = refmap
, stateReference = Reference mempty mempty Nothing mempty
, stateUsedYearSuffix = False
, stateUsedIdentifier = False
, stateUsedTitle = False
}
assignCitationNumbers sortedIds =
modify $ \st ->
st{ stateRefMap = ReferenceMap $ foldl'
(\m (citeId, num) ->
M.adjust (\ref ->
ref{ referenceVariables =
M.insert "citation-number"
(NumVal num) .
M.insert "citation-key"
(TextVal (unItemId citeId)) .
M.alter (addIfMissing (citationLabel ref))
"citation-label"
$ referenceVariables ref
}) citeId m)
(unReferenceMap (stateRefMap st))
(zip sortedIds [1..]) }
addIfMissing x Nothing = Just x
addIfMissing _ (Just x) = Just x
go = do
-- list of citationItemIds that are actually cited
let citationOrder = M.fromList $ reverse $ zip
(concatMap (map citationItemId . citationItems) citations)
[(1 :: Int)..]
let citeIds = M.keysSet citationOrder
let sortedCiteIds = sortOn
(fromMaybe maxBound . (`M.lookup` citationOrder))
(map referenceId refs)
let layoutOpts = layoutOptions $ styleCitation style
let mbcgDelim =
case styleCiteGroupDelimiter (styleOptions style) of
Just x -> Just x
Nothing
-- grouping is activated whenever there is
-- collapsing; this is the default
-- cite-group-delimiter
| isJust (layoutCollapse layoutOpts) -> Just ", "
| otherwise -> Nothing
assignCitationNumbers sortedCiteIds
-- sorting of bibliography, insertion of citation-number
collate <- asks contextCollate
(bibCitations, bibSortKeyMap) <-
case styleBibliography style of
Nothing -> return ([], mempty)
Just biblayout -> do
bibSortKeyMap <- M.fromList
<$> mapM
((\citeId ->
(citeId,) <$> evalSortKeys biblayout citeId)
. referenceId)
refs
let sortedIds =
if null (layoutSortKeys biblayout)
then sortedCiteIds
else sortBy
(\x y -> collate
(fromMaybe [] $ M.lookup x bibSortKeyMap)
(fromMaybe [] $ M.lookup y bibSortKeyMap))
(map referenceId refs)
assignCitationNumbers $
case layoutSortKeys biblayout of
(SortKeyVariable Descending "citation-number":_)
-> reverse sortedIds
(SortKeyMacro Descending
(Element (ENumber "citation-number" _) _:_) : _)
-> reverse sortedIds
(SortKeyMacro Descending
(Element (EText (TextVariable _ "citation-number")) _:_): _)
-> reverse sortedIds
_ -> sortedIds
let bibCitations = map (\ident ->
Citation (Just $ unItemId ident) Nothing
[CitationItem ident Nothing Nothing
NormalCite Nothing Nothing Nothing]) sortedIds
return (bibCitations, bibSortKeyMap)
-- styling of citations
sortKeyMap <-
foldM (\m citeId -> do
sk <- evalSortKeys (styleCitation style) citeId
return $ M.insert citeId sk m)
M.empty
citeIds
-- We can't just sort all the citations, because
-- this can make a hash out of prefixes and suffixes.
-- See e.g. pandoc-citeproc issue #292.
-- we need to first break into groups so that any
-- suffix ends a group and any prefix begins a group;
-- then sort the groups; then combine again:
let canGroup i1 i2
= isNothing (citationItemSuffix i1) &&
isNothing (citationItemPrefix i2)
let sortCitationItems citation' =
citation'{ citationItems =
concatMap
(sortBy
(\item1 item2 ->
collate
(fromMaybe [] $ M.lookup
(citationItemId item1) sortKeyMap)
(fromMaybe [] $ M.lookup
(citationItemId item2) sortKeyMap)))
$ groupBy canGroup
$ citationItems citation' }
let citCitations = map sortCitationItems citations
cs <- disambiguateCitations style bibSortKeyMap citCitations
let cs' = case mbcgDelim of
Nothing -> cs
Just citeGroupDelim -> map
(groupAndCollapseCitations citeGroupDelim
(layoutYearSuffixDelimiter layoutOpts)
(layoutAfterCollapseDelimiter layoutOpts)
(layoutCollapse layoutOpts))
cs
let removeIfEqual x y
| x == y = NullOutput
| otherwise = y
let removeNamesIfSuppressAuthor
(Tagged (TagItem SuppressAuthor cid') x)
= let y = getAuthors x
in Tagged (TagItem SuppressAuthor cid')
(transform (removeIfEqual y) x)
removeNamesIfSuppressAuthor x = x
-- we need to do this after disambiguation and collapsing
let handleSuppressAuthors = transform removeNamesIfSuppressAuthor
let isNoteCitation = styleIsNoteStyle (styleOptions style)
-- if we have an author-only citation at the beginning
-- separate it out:
let handleAuthorOnly formattedCit =
case formattedCit of
Formatted f
(x@(Tagged (TagItem AuthorOnly _) _):xs)
| isNoteCitation
-> formatted mempty
(x : [InNote (formatted f xs) | not (null xs)])
| otherwise
-> formatted mempty
(x :
if null xs
then []
else [Literal (fromText " "),
formatted f xs])
Formatted f
(Formatted f'
(x@(Tagged (TagItem AuthorOnly _) _):xs) : ys)
| isNoteCitation
-> formatted mempty
(x :
if null xs && null ys
then []
else [InNote (formatted f
(formatted f' xs : ys))])
| otherwise
-> Formatted mempty
(x :
if null xs && null ys
then []
else [Literal (fromText " "),
formatted f (formatted f' xs : ys)])
_ | isNoteCitation -> InNote formattedCit
| otherwise -> formattedCit
let cs'' = map (handleSuppressAuthors . handleAuthorOnly) cs'
-- styling of bibliography (this needs to go here to take account
-- of year suffixes added in disambiguation)
bs <- case styleBibliography style of
Just biblayout
-> local (\context ->
context{ contextInBibliography = True }) $
mapM (evalLayout biblayout) (zip [1..] bibCitations)
>>= \bs ->
case styleSubsequentAuthorSubstitute
(styleOptions style) of
Nothing -> return bs
Just subs -> subsequentAuthorSubstitutes subs bs
Nothing -> return []
return (cs'', case styleBibliography style of
Nothing -> []
Just _ ->
zip (map (fromMaybe "" . citationId) bibCitations) bs)
extractItemData :: [Citation a] -> [Reference a]
extractItemData = concatMap (mapMaybe citationItemData . citationItems)
subsequentAuthorSubstitutes :: CiteprocOutput a
=> SubsequentAuthorSubstitute
-> [Output a]
-> Eval a [Output a]
subsequentAuthorSubstitutes (SubsequentAuthorSubstitute t rule) =
return . groupCitesByNames
where
groupCitesByNames [] = []
groupCitesByNames (x:xs) =
let xnames = fromMaybe ([],NullOutput) $ getNames x
samenames = replaceMatch rule (fromText t) xnames xs
rest = drop (length samenames) xs
in (x : samenames) ++ groupCitesByNames rest
getNames (Formatted _ (x:_)) =
case [(ns,r) | (Tagged (TagNames _ _ ns) r) <- universe x] of
((ns,r) : _) -> Just (ns,r)
[] -> Nothing
getNames _ = Nothing
replaceMatch :: CiteprocOutput a
=> SubsequentAuthorSubstituteRule
-> a
-> ([Name], Output a)
-> [Output a]
-> [Output a]
replaceMatch _ _ _ [] = []
replaceMatch rule replacement (names, raw) (z:zs) =
case go z of
Nothing -> []
Just z' -> z' : replaceMatch rule replacement (names, raw) zs
where
go (Tagged t@TagItem{} y) =
Tagged t <$> go y
go (Formatted f (y:ys)) =
Formatted f . (: ys) <$> go y
go y@(Tagged (TagNames _ _ ns) r) =
case (if null names then CompleteAll else rule) of
CompleteAll ->
if ns == names && (not (null names) || r == raw)
then Just $ replaceAll y
else Nothing
CompleteEach ->
if ns == names
then Just $ transform replaceEach y
else Nothing
PartialEach ->
case numberOfMatches ns names of
num | num >= 1 -> Just $ transform (replaceFirst num) y
_ -> Nothing
PartialFirst ->
case numberOfMatches ns names of
num | num >= (1 :: Int) -> Just $ transform (replaceFirst 1) y
_ -> Nothing
go _ = Nothing
replaceAll (Tagged (TagNames t' nf ns') x)
= Tagged (TagNames t' nf ns') $
-- removeName will leave label "ed."
-- which we want, but it will also leave the substituted
-- title when there is no name, which we do not want.
-- So, if ns' is null, then we just remove everything.
if null ns'
then Literal replacement
else
case transform removeName x of
Formatted f' xs -> Formatted f' (Literal replacement : xs)
_ -> Literal replacement
replaceAll x = x
removeName (Tagged (TagName _) _) = NullOutput
removeName x = x
replaceEach (Tagged (TagName n) _)
| n `elem` names
= Tagged (TagName n) (Literal replacement)
replaceEach x = x
replaceFirst num x@(Tagged (TagNames _ _ ns') _)
= foldr (transform . replaceName) x $ take num ns'
replaceFirst _num x = x
replaceName name (Tagged (TagName n) _)
| n == name = Tagged (TagName n) (Literal replacement)
replaceName _ x = x
numberOfMatches (a:as) (b:bs)
| a == b = 1 + numberOfMatches as bs
| otherwise = 0
numberOfMatches _ _ = 0
--
-- Disambiguation
--
data DisambData =
DisambData
{ ddItem :: ItemId
, ddNames :: [Name]
, ddDates :: [Date]
, ddRendered :: Text
} deriving (Eq, Ord, Show)
disambiguateCitations :: forall a . CiteprocOutput a
=> Style a
-> M.Map ItemId [SortKeyValue]
-> [Citation a]
-> Eval a [Output a]
disambiguateCitations style bibSortKeyMap citations = do
refs <- unReferenceMap <$> gets stateRefMap
let refIds = M.keys refs
let ghostItems = [ ident
| ident <- refIds
]
-- we add additional references for EVERY citation,
-- even those we have already, to handle cases like #116
-- for purposes of disambiguation, we remove prefixes and
-- suffixes and locators, and we convert author-in-text to normal citation.
let removeAffix item = item{ citationItemLabel = Nothing
, citationItemLocator = Nothing
, citationItemPrefix = Nothing
, citationItemSuffix = Nothing }
let cleanCitation (Citation a b (i1:i2:is))
| citationItemType i1 == AuthorOnly
, citationItemType i2 == SuppressAuthor
= Citation a b
(map removeAffix (i2{ citationItemType = NormalCite }:is))
cleanCitation (Citation a b is)
= Citation a b (map removeAffix is)
-- note that citations must go first, and order must be preserved:
-- we use a "basic item" that strips off prefixes, suffixes, locators
let citations' = map cleanCitation citations ++
[Citation Nothing Nothing (map basicItem ghostItems)]
allCites <- renderCitations citations'
mblang <- asks (localeLanguage . contextLocale)
styleOpts <- asks contextStyleOptions
let strategy = styleDisambiguation styleOpts
let allNameGroups = [ns | Tagged (TagNames _ _ ns) _ <-
concatMap universe allCites]
let allNames = nubOrd $ concat allNameGroups
let primaryNames = nubOrd $ concatMap (take 1) allNameGroups
allCites' <-
case disambiguateAddGivenNames strategy of
Nothing -> return allCites
Just ByCite -> return allCites -- do this later
Just rule -> do -- disambiguate names, not just citations
let relevantNames =
case rule of
PrimaryNameWithInitials -> primaryNames
PrimaryName -> primaryNames
_ -> allNames
let familyNames = nubOrd $ mapMaybe nameFamily relevantNames
let grps = map (\name ->
[v | v <- relevantNames
, nameFamily v == Just name])
familyNames
let toHint names name =
if any (initialsMatch mblang name) (filter (/= name) names)
then
case rule of
AllNamesWithInitials -> Nothing
PrimaryNameWithInitials -> Nothing
PrimaryName -> Just AddGivenNameIfPrimary
_ -> Just AddGivenName
else
case rule of
PrimaryNameWithInitials -> Just AddInitialsIfPrimary
PrimaryName -> Just AddInitialsIfPrimary
_ -> Just AddInitials
let namesMap = mconcat $ map
(\names -> if length names > 1
then foldr
(\name ->
case toHint names name of
Just x -> M.insert name x
Nothing -> id)
mempty
names
else mempty) grps
-- use this same names map for every citation
modify $ \st ->
st{ stateRefMap = ReferenceMap $
foldr
(M.adjust (alterReferenceDisambiguation
(\d -> d{ disambNameMap = namesMap })))
(unReferenceMap $ stateRefMap st)
refIds }
-- redo citations
renderCitations citations'
case getAmbiguities allCites' of
[] -> return ()
ambiguities -> analyzeAmbiguities mblang strategy citations' ambiguities
renderCitations citations
where
renderCitations :: [Citation a] -> Eval a [Output a]
renderCitations cs =
withRWST (\ctx st -> (ctx,
st { stateLastCitedMap = mempty
, stateNoteMap = mempty })) $
mapM (evalLayout (styleCitation style)) (zip [1..] cs)
refreshAmbiguities :: [Citation a] -> Eval a [[DisambData]]
refreshAmbiguities = fmap getAmbiguities . renderCitations
analyzeAmbiguities :: Maybe Lang
-> DisambiguationStrategy
-> [Citation a]
-> [[DisambData]]
-> Eval a ()
analyzeAmbiguities mblang strategy cs ambiguities = do
-- add names to et al.
return ambiguities
>>= (\as ->
(if not (null as) && disambiguateAddNames strategy
then do
mapM_ (tryAddNames mblang (disambiguateAddGivenNames strategy)) as
refreshAmbiguities cs
else
return as))
>>= (\as ->
(case disambiguateAddGivenNames strategy of
Just ByCite | not (null as) -> do
mapM_ (tryAddGivenNames mblang) as
refreshAmbiguities cs
_ -> return as))
>>= (\as ->
(if not (null as) && disambiguateAddYearSuffix strategy
then do
addYearSuffixes bibSortKeyMap as
refreshAmbiguities cs
else return as))
>>= mapM_ tryDisambiguateCondition
basicItem :: ItemId -> CitationItem a
basicItem iid = CitationItem
{ citationItemId = iid
, citationItemLabel = Nothing
, citationItemLocator = Nothing
, citationItemType = NormalCite
, citationItemPrefix = Nothing
, citationItemSuffix = Nothing
, citationItemData = Nothing
}
isDisambiguated :: Maybe Lang
-> Maybe GivenNameDisambiguationRule
-> Int -- et al min
-> [DisambData]
-> DisambData
-> Bool
isDisambiguated mblang mbrule etAlMin xs x =
all (\y -> x == y || disambiguatedName y /= disambiguatedName x) xs
where
disambiguatedName = nameParts . take etAlMin . ddNames
nameParts =
case mbrule of
Just AllNames -> id
Just AllNamesWithInitials ->
map (\name -> name{ nameGiven = initialize mblang True False ""
<$> nameGiven name })
Just PrimaryName ->
\case
[] -> []
(z:zs) -> z : map (\name -> name{ nameGiven = Nothing }) zs
Just PrimaryNameWithInitials ->
\case
[] -> []
(z:zs) -> z{ nameGiven =
initialize mblang True False "" <$> nameGiven z } :
map (\name -> name{ nameGiven = Nothing }) zs
Just ByCite -> id -- hints will be added later
_ -> map (\name -> name{ nameGiven = Nothing })
tryAddNames :: Maybe Lang
-> Maybe GivenNameDisambiguationRule
-> [DisambData]
-> Eval a ()
tryAddNames mblang mbrule bs =
(case mbrule of
Just ByCite -> bs <$ tryAddGivenNames mblang bs
_ -> return bs) >>= go 1
-- if ByCite, we want to make sure that
-- tryAddGivenNames is still applied, as
-- calculation of "add names" assumes this.
where
maxnames = fromMaybe 0 . maximumMay . map (length . ddNames)
go n as
| n > maxnames as = return ()
| otherwise = do
let ds = filter (isDisambiguated mblang mbrule n as) as
if null ds
then go (n + 1) as
else do
modify $ \st ->
st{ stateRefMap = ReferenceMap
$ foldr (setEtAlNames (Just n) . ddItem)
(unReferenceMap $ stateRefMap st) as }
go (n + 1) (as \\ ds)
tryAddGivenNames :: Maybe Lang
-> [DisambData]
-> Eval a ()
tryAddGivenNames mblang as = do
let correspondingNames =
map (zip (map ddItem as)) $ transpose $ map ddNames as
go [] _ = return []
go (as' :: [DisambData]) (ns :: [(ItemId, Name)]) = do
hintedIds <- Set.fromList . catMaybes <$>
mapM (addNameHint mblang (map snd ns)) ns
return $ filter (\x -> ddItem x `Set.notMember` hintedIds) as'
foldM_ go as correspondingNames
addYearSuffixes :: M.Map ItemId [SortKeyValue]
-> [[DisambData]]
-> Eval a ()
addYearSuffixes bibSortKeyMap' as = do
let allitems = concat as
collate <- asks contextCollate
let companions a =
sortBy
(\item1 item2 ->
collate
(fromMaybe [] $ M.lookup (ddItem item1) bibSortKeyMap')
(fromMaybe [] $ M.lookup (ddItem item2) bibSortKeyMap'))
(concat [ x | x <- as, a `elem` x ])
let groups = Set.map companions $ Set.fromList allitems
let addYearSuffix item suff =
modify $ \st ->
st{ stateRefMap = ReferenceMap
$ setYearSuffix suff item
$ unReferenceMap
$ stateRefMap st }
mapM_ (\xs -> zipWithM addYearSuffix (map ddItem xs) [1..]) groups
tryDisambiguateCondition :: [DisambData] -> Eval a ()
tryDisambiguateCondition as =
case as of
[] -> return ()
xs -> modify $ \st ->
st{ stateRefMap = ReferenceMap
$ foldr (setDisambCondition True . ddItem)
(unReferenceMap (stateRefMap st))
xs }
alterReferenceDisambiguation :: (DisambiguationData -> DisambiguationData)
-> Reference a
-> Reference a
alterReferenceDisambiguation f r =
r{ referenceDisambiguation = f <$>
case referenceDisambiguation r of
Nothing -> Just
DisambiguationData
{ disambYearSuffix = Nothing
, disambNameMap = mempty
, disambEtAlNames = Nothing
, disambCondition = False
}
Just x -> Just x }
initialsMatch :: Maybe Lang -> Name -> Name -> Bool
initialsMatch mblang x y =
case (nameGiven x, nameGiven y) of
(Just x', Just y') ->
initialize mblang True False "" x' ==
initialize mblang True False "" y'
_ -> False
addNameHint :: Maybe Lang -> [Name] -> (ItemId, Name) -> Eval a (Maybe ItemId)
addNameHint mblang names (item, name) = do
let familyMatches = [n | n <- names
, n /= name
, nameFamily n == nameFamily name]
case familyMatches of
[] -> return Nothing
_ -> do
let hint = if any (initialsMatch mblang name) familyMatches
then AddGivenName
else AddInitials
modify $ \st ->
st{ stateRefMap = ReferenceMap
$ setNameHint hint name item
$ unReferenceMap (stateRefMap st) }
return $ Just item
setNameHint :: NameHints -> Name -> ItemId
-> M.Map ItemId (Reference a) -> M.Map ItemId (Reference a)
setNameHint hint name = M.adjust
(alterReferenceDisambiguation
(\d -> d{ disambNameMap =
M.insert name hint
(disambNameMap d) }))
setEtAlNames :: Maybe Int -> ItemId
-> M.Map ItemId (Reference a) -> M.Map ItemId (Reference a)
setEtAlNames x = M.adjust
(alterReferenceDisambiguation
(\d -> d{ disambEtAlNames = x }))
setYearSuffix :: Int -> ItemId
-> M.Map ItemId (Reference a) -> M.Map ItemId (Reference a)
setYearSuffix x = M.adjust
(alterReferenceDisambiguation
(\d -> d{ disambYearSuffix = Just x }))
setDisambCondition :: Bool -> ItemId
-> M.Map ItemId (Reference a) -> M.Map ItemId (Reference a)
setDisambCondition x = M.adjust
(alterReferenceDisambiguation
(\d -> d{ disambCondition = x }))
getAmbiguities :: CiteprocOutput a => [Output a] -> [[DisambData]]
getAmbiguities =
mapMaybe
(\zs ->
case zs of
[] -> Nothing
[_] -> Nothing
(z:_) ->
case ddRendered z of
"" -> Nothing
_ -> case nubOrdOn ddItem zs of
ys@(_:_:_) -> Just ys -- > 1 ambiguous entry
_ -> Nothing)
. groupBy (\x y -> ddRendered x == ddRendered y)
. sortOn ddRendered
. map toDisambData
. extractTagItems
extractTagItems :: [Output a] -> [(ItemId, Output a)]
extractTagItems xs =
[(iid, x) | Tagged (TagItem NormalCite iid) x <- concatMap universe xs
, not (hasIbid x)]
where -- we don't want two "ibid" entries to be treated as ambiguous.
hasIbid x = not $ null [ trm | Tagged (TagTerm trm) _ <- universe x
, termName trm == "ibid" ]
toDisambData :: CiteprocOutput a => (ItemId, Output a) -> DisambData
toDisambData (iid, x) =
let xs = universe x
ns' = getNames xs
ds' = getDates xs
t = outputToText x
in DisambData { ddItem = iid
, ddNames = ns'
, ddDates = ds'
, ddRendered = t }
where
getNames :: [Output a] -> [Name]
getNames (Tagged (TagNames _ _ ns) _ : xs)
= ns ++ getNames xs
getNames (_ : xs) = getNames xs
getNames [] = []
getDates :: [Output a] -> [Date]
getDates (Tagged (TagDate d) _ : xs)
= d : getDates xs
getDates (_ : xs) = getDates xs
getDates [] = []
--
-- Grouping and collapsing
--
groupAndCollapseCitations :: forall a . CiteprocOutput a
=> Text
-> Maybe Text
-> Maybe Text
-> Maybe Collapsing
-> Output a
-> Output a
groupAndCollapseCitations citeGroupDelim yearSuffixDelim afterCollapseDelim
collapsing (Formatted f xs) =
case collapsing of
Just CollapseCitationNumber ->
Formatted f{ formatDelimiter = Nothing } $
foldr collapseRange []
(groupSuccessive isAdjacentCitationNumber xs)
Just collapseType ->
Formatted f{ formatDelimiter = Nothing } $
foldr (collapseGroup collapseType) [] (groupWith sameNames xs)
Nothing ->
Formatted f $
map (Formatted mempty{ formatDelimiter = Just citeGroupDelim })
(groupWith sameNames xs)
where
-- Note that we cannot assume we've sorted by name,
-- so we can't just use Data.ListgroupBy. We also
-- take care not to move anything past a prefix or suffix.
groupWith :: (Output a -> Output a -> Bool)
-> [Output a]
-> [[Output a]]
groupWith _ [] = []
groupWith isMatched (z:zs)
| hasSuffix z = [z] : groupWith isMatched zs
| otherwise = -- we allow a prefix on first item in collapsed group
case span hasNoPrefixOrSuffix zs of
([],ys) -> [z] : groupWith isMatched ys
(ws,ys) ->
(z : filter (isMatched z) ws) :
groupWith isMatched (filter (not . isMatched z) ws ++ ys)
hasNoPrefixOrSuffix :: Output a -> Bool
hasNoPrefixOrSuffix x = not (hasPrefix x) && not (hasSuffix x)
hasPrefix :: Output a -> Bool
hasPrefix x = not $ null [y | y@(Tagged TagPrefix _) <- universe x]
hasSuffix :: Output a -> Bool
hasSuffix x = not $ null [y | y@(Tagged TagSuffix _) <- universe x]
collapseRange :: [Output a] -> [Output a] -> [Output a]
collapseRange ys zs
| length ys >= 3
, Just yhead <- headMay ys
, Just ylast <- lastMay ys
= Formatted mempty{ formatDelimiter = Just $ T.singleton enDash }
[yhead, ylast] :
if null zs
then []
else maybe NullOutput literal afterCollapseDelim : zs
collapseRange ys zs =
Formatted mempty{ formatDelimiter = formatDelimiter f } ys :
if null zs
then []
else maybe NullOutput literal (formatDelimiter f) : zs
collapseGroup :: Collapsing -> [Output a] -> [Output a] -> [Output a]
collapseGroup _ [] zs = zs
collapseGroup collapseType (y:ys) zs =
let ys' = y : map (transform removeNames) ys
ws = collapseYearSuffix collapseType ys'
noCollapse = ws == y:ys
noYearSuffixCollapse = ws == ys'
hasLocator u = not $ null [x | x@(Tagged TagLocator _) <- universe u]
anyHasLocator = any hasLocator ws
-- https://github.com/citation-style-language/test-suite/issues/36 :
flippedAfterCollapseDelim = collapseType == CollapseYear
addCGDelim u [] = [u]
addCGDelim u us =
Formatted mempty{ formatSuffix =
if noCollapse || noYearSuffixCollapse &&
not (flippedAfterCollapseDelim &&
anyHasLocator)
then Just citeGroupDelim
else afterCollapseDelim <|>
formatDelimiter f } [u] : us
in Formatted mempty{ formatDelimiter = Nothing
, formatSuffix =
if null zs
then Nothing
else if noCollapse &&
not flippedAfterCollapseDelim
then formatDelimiter f
else afterCollapseDelim <|>
formatDelimiter f }
(foldr addCGDelim [] ws) : zs
collapseRanges = map rangifyGroup . groupSuccessive isSuccessive
isSuccessive x y
= case ([c | Tagged (TagYearSuffix c) _ <- universe x],
[d | Tagged (TagYearSuffix d) _ <- universe y]) of
([c],[d]) -> d == c + 1
_ -> False
rangifyGroup :: [Output a] -> Output a
rangifyGroup zs
| length zs >= 3
, Just zhead <- headMay zs
, Just zlast <- lastMay zs
= Formatted mempty{ formatDelimiter = Just (T.singleton enDash) }
[zhead, zlast]
rangifyGroup [z] = z
rangifyGroup zs = Formatted mempty{ formatDelimiter = yearSuffixDelim
} zs
yearSuffixGroup :: Bool -> [Output a] -> Output a
yearSuffixGroup _ [x] = x
yearSuffixGroup useRanges zs =
Formatted mempty{ formatDelimiter = yearSuffixDelim }
$ if useRanges then collapseRanges zs else zs
collapseYearSuffix :: Collapsing -> [Output a] -> [Output a]
collapseYearSuffix CollapseYearSuffix zs =
reverse $ yearSuffixGroup False cur : items
where
(cur, items) = foldl' (goYearSuffix False) ([], []) zs
collapseYearSuffix CollapseYearSuffixRanged zs =
reverse $ yearSuffixGroup True cur : items
where
(cur, items) = foldl' (goYearSuffix True) ([], []) zs
collapseYearSuffix _ zs = zs
getDates :: Output a -> [Date]
getDates x = [d | Tagged (TagDate d) _ <- universe x]
getYears :: Output a -> [[Maybe Int]]
getYears x = [map (\case
DateParts (y:_) -> Just y
_ -> Nothing) (dateParts d)
| d <- getDates x
, isNothing (dateLiteral d)]
goYearSuffix :: Bool -> ([Output a], [Output a]) -> Output a
-> ([Output a], [Output a])
goYearSuffix useRanges (cur, items) item =
case cur of
[] -> ([item], items)
(z:zs)
| getYears z == getYears item
-> (z:zs ++ [transform removeYear item], items)
| otherwise -> ([item], yearSuffixGroup useRanges (z:zs) : items)
removeYear :: Output a -> Output a
removeYear (Tagged (TagDate d) x) =
Tagged (TagDate d) (extractYearSuffix x)
removeYear x = x
extractYearSuffix :: Output a -> Output a
extractYearSuffix x =
case [z | z@(Tagged (TagYearSuffix _) _) <- universe x] of
(y:_) -> y
_ -> NullOutput
isAdjacentCitationNumber :: Output a -> Output a -> Bool
isAdjacentCitationNumber
(Tagged (TagItem _ _)
(Formatted _f1 [Tagged (TagCitationNumber n1) _xs1]))
(Tagged (TagItem _ _)
(Formatted _f2 [Tagged (TagCitationNumber n2) _xs2]))
= n2 == n1 + 1
isAdjacentCitationNumber
(Tagged (TagItem _ _) (Tagged (TagCitationNumber n1) _xs1))
(Tagged (TagItem _ _) (Tagged (TagCitationNumber n2) _xs2))
= n2 == n1 + 1
isAdjacentCitationNumber _ _ = False
sameNames :: Output a -> Output a -> Bool
sameNames x y =
case (extractTagged x, extractTagged y) of
(Just (Tagged (TagNames t1 _nf1 ns1) ws1),
Just (Tagged (TagNames t2 _nf2 ns2) ws2))
-> t1 == t2 && (if ns1 == ns2
then not (null ns1) || ws1 == ws2
else ws1 == ws2)
-- case where it's just a date with no name or anything;
-- we treat this as same name e.g. (1955a,b)
(Just (Tagged TagDate{} _), Just (Tagged TagDate{} _))
-> True
-- case where title is substituted
_ -> False
extractTagged :: Output a -> Maybe (Output a)
extractTagged x =
let items = [y | y@(Tagged (TagItem ty _) _) <- universe x
, ty /= AuthorOnly]
names = [y | y@(Tagged TagNames{} _) <- concatMap universe items]
dates = [y | y@(Tagged TagDate{} _) <- concatMap universe items]
in if null items
then Nothing
else listToMaybe names <|> listToMaybe dates
groupAndCollapseCitations _ _ _ _ x = x
takeSeq :: Show a => (a -> a -> Bool) -> [a] -> ([a], [a])
takeSeq isAdjacent (x1 : x2 : rest)
| isAdjacent x1 x2 = (x1:ys, zs)
where (ys, zs) = takeSeq isAdjacent (x2:rest)
takeSeq _ (y:ys) = ([y], ys)
takeSeq _ [] = ([], [])
groupSuccessive :: Show a => (a -> a -> Bool) -> [a] -> [[a]]
groupSuccessive isAdjacent zs =
case takeSeq isAdjacent zs of
([],_) -> []
(xs,ys) -> xs : groupSuccessive isAdjacent ys
--
-- Sorting
--
evalSortKeys :: CiteprocOutput a
=> Layout a
-> ItemId
-> Eval a [SortKeyValue]
evalSortKeys layout citeId =
withRWST (\ctx st -> (ctx{ contextInSortKey = True }, st)) $
mapM (evalSortKey citeId) (layoutSortKeys layout)
evalSortKey :: CiteprocOutput a
=> ItemId
-> SortKey a
-> Eval a SortKeyValue
evalSortKey citeId (SortKeyMacro sortdir elts) = do
refmap <- gets stateRefMap
case lookupReference citeId refmap of
Nothing -> return $ SortKeyValue sortdir Nothing
Just ref -> do
k <- normalizeSortKey . toText .
renderOutput defaultCiteprocOptions . grouped
<$> withRWS newContext (mconcat <$> mapM eElement elts)
return $ SortKeyValue sortdir (Just k)
where
newContext oldContext s =
(oldContext, s{ stateReference = ref })
evalSortKey citeId (SortKeyVariable sortdir var) = do
refmap <- gets stateRefMap
SortKeyValue sortdir <$>
case lookupReference citeId refmap >>= lookupVariable var of
Nothing -> return Nothing
Just (TextVal t) -> return $ Just $ normalizeSortKey t
Just (NumVal i) -> return $ Just [T.pack $ printf "%09d" i]
Just (FancyVal x) -> return $ Just $ normalizeSortKey $ toText x
Just (NamesVal ns) ->
Just . normalizeSortKey . mconcat . intersperse "," . map T.unwords
<$> mapM getNamePartSortOrder ns
Just (DateVal d) -> return $ Just [T.toLower $ dateToText d]
Just SubstitutedVal -> return Nothing
-- Note: we do a case-insensitive sort (using toCaseFold):
normalizeSortKey :: Text -> [Text]
normalizeSortKey = filter (not . T.null) . T.split isWordSep . T.toCaseFold
where
isWordSep c = isSpace c || c == '\'' || c == '’' || c == ',' ||
c == 'ʾ' || c == 'ʿ' -- ayn/hamza in transliterated arabic
-- absence should sort AFTER all values
-- see sort_StatusFieldAscending.txt, sort_StatusFieldDescending.txt
compSortKeyValue :: (Text -> Text -> Ordering)
-> SortKeyValue
-> SortKeyValue
-> Ordering
compSortKeyValue collate sk1 sk2 =
case (sk1, sk2) of
(SortKeyValue _ Nothing, SortKeyValue _ Nothing) -> EQ
(SortKeyValue _ Nothing, SortKeyValue _ (Just _)) -> GT
(SortKeyValue _ (Just _), SortKeyValue _ Nothing) -> LT
(SortKeyValue Ascending (Just t1), SortKeyValue Ascending (Just t2)) ->
collateKey t1 t2
(SortKeyValue Descending (Just t1), SortKeyValue Descending (Just t2))->
collateKey t2 t1
_ -> EQ
where
collateKey :: [Text] -> [Text] -> Ordering
collateKey [] [] = EQ
collateKey [] (_:_) = LT
collateKey (_:_) [] = GT
collateKey (x:xs) (y:ys) =
case collate x y of
EQ -> collateKey xs ys
GT -> GT
LT -> LT
compSortKeyValues :: (Text -> Text -> Ordering)
-> [SortKeyValue]
-> [SortKeyValue]
-> Ordering
compSortKeyValues _ [] [] = EQ
compSortKeyValues _ [] (_:_) = LT
compSortKeyValues _ (_:_) [] = GT
compSortKeyValues collate (x:xs) (y:ys) =
case compSortKeyValue collate x y of
EQ -> compSortKeyValues collate xs ys
GT -> GT
LT -> LT
-- Note! This prints negative (BC) dates as N(999,999,999 + y)
-- and positive (AD) dates as Py so they sort properly. (Note that
-- our unicode sorting ignores punctuation, so we use a letter
-- rather than -.) Do not use out of context of sort keys.
dateToText :: Date -> Text
dateToText = mconcat . map (T.pack . go . coerce) . dateParts
where
go :: [Int] -> String
go [] = ""
go [y] = toYear y <> "0000"
go [y,m] = toYear y <> printf "%02d" m <> "00"
go (y:m:d:_) = toYear y <> printf "%02d" m <> printf "%02d" d
toYear :: Int -> String
toYear y
| y < 0 = printf "N%09d" (999999999 + y)
| otherwise = printf "P%09d" y
evalLayout :: CiteprocOutput a
=> Layout a
-> (Int, Citation a)
-> Eval a (Output a)
evalLayout layout (citationGroupNumber, citation) = do
-- this is a hack to ensure that "ibid" detection will work
-- correctly in a citation starting with an author-only:
-- the combination AuthorOnly [SuppressAuthor] should not
-- count against a later Ibid citation.
let positionsInCitation =
case citationItems citation of
(c:_) | citationItemType c == AuthorOnly -> [0..]
_ -> [1..]
items <- mapM evalItem' (zip positionsInCitation (citationItems citation))
-- see display_SecondFieldAlignMigratePunctuation.txt
let moveSuffixInsideDisplay zs =
case (lastMay zs, formatSuffix formatting) of
(Just (Tagged (TagItem ct id') (Formatted f ys)), Just _) ->
(\ys' -> initSafe zs ++
[Tagged (TagItem ct id') (Formatted f ys')]) <$>
moveSuffixInsideDisplay ys
(Just (Formatted f ys), Just suff)
| isJust (formatDisplay f) ->
Just $ initSafe zs ++
[Formatted f{ formatSuffix = Just
(fromMaybe "" (formatSuffix f) <> suff) } ys]
| otherwise -> (\ys' -> initSafe zs ++ [Formatted f ys']) <$>
moveSuffixInsideDisplay ys
_ -> Nothing
return $
case moveSuffixInsideDisplay items of
Nothing -> formatted formatting items
Just items' -> formatted formatting{ formatSuffix = Nothing } items'
where
formatting = layoutFormatting layout
secondFieldAlign [Linked t (x:xs)] =
secondFieldAlign [x, Linked t xs]
secondFieldAlign (x:xs) =
formatted mempty{ formatDisplay = Just DisplayLeftMargin } [x]
: [formatted mempty{ formatDisplay = Just DisplayRightInline } xs]
secondFieldAlign [] = []
evalItem' (positionInCitation :: Int, item) = do
isBibliography <- asks contextInBibliography
styleOpts <- asks contextStyleOptions
let isNote = styleIsNoteStyle styleOpts
position <- getPosition citationGroupNumber (citationNoteNumber citation)
item positionInCitation
xs <- evalItem layout (position, item)
-- we only update the map in the citations section
unless isBibliography $ do
updateRefMap citationGroupNumber citation item
updateLastCitedMap citationGroupNumber positionInCitation citation item
return $
maybe id (\pref x -> Tagged TagPrefix (grouped [Literal pref, x]))
(citationItemPrefix item)
. maybe id (\suff x -> Tagged TagSuffix (grouped [x, Literal suff]))
(citationItemSuffix item)
. (\x -> case x of
NullOutput -> x
_ -> Tagged (TagItem (citationItemType item)
(citationItemId item)) x)
. formatted mempty
. (if citationItemType item == AuthorOnly
then (:[]) . getAuthors . formatted mempty
else id)
. (case citationItemPrefix item of
Just t | isNote
, ". " `T.isSuffixOf` toText t
, T.count " " (toText t) > 1 -- exclude single word
-> capitalizeInitialTerm
_ -> id)
. (if isBibliography
then
case styleSecondFieldAlign styleOpts of
Just SecondFieldAlignFlush -> secondFieldAlign
Just SecondFieldAlignMargin -> secondFieldAlign -- TODO?
Nothing -> id
else id)
$ xs
evalItem :: CiteprocOutput a
=> Layout a -> ([Position], CitationItem a) -> Eval a [Output a]
evalItem layout (position, item) = do
refmap <- gets stateRefMap
let addLangToFormatting lang (Formatted f xs) =
Formatted f{ formatLang = Just lang } xs
addLangToFormatting _ x = x
case lookupReference (citationItemId item) refmap of
Just ref -> withRWST
(\ctx st ->
(ctx{ contextLocator = citationItemLocator item
, contextLabel = citationItemLabel item
, contextPosition = position
},
st{ stateReference = ref
, stateUsedYearSuffix = False
, stateUsedIdentifier = False
, stateUsedTitle = False
}))
$ do xs <- mconcat <$> mapM eElement (layoutElements layout)
-- find identifiers that can be used to hyperlink the title
let mbident =
foldl (<|>) Nothing
[ IdentDOI <$> (valToText =<< lookupVariable "DOI" ref)
, IdentPMCID <$> (valToText =<< lookupVariable "PMCID" ref)
, IdentPMID <$> (valToText =<< lookupVariable "PMID" ref)
, IdentURL <$> (valToText =<< lookupVariable "URL" ref)
]
let mburl = identifierToURL <$> mbident
-- hyperlink any titles in the output
let linkTitle url (Tagged TagTitle x) = Linked url [Tagged TagTitle x]
linkTitle _ x = x
usedLink <- gets stateUsedIdentifier
usedTitle <- gets stateUsedTitle
inBiblio <- asks contextInBibliography
-- when no links were rendered for a bibliography item, hyperlink
-- the title, if it exists, otherwise hyperlink the whole item
let xs' =
if usedLink || not inBiblio
then xs
else case mburl of
Nothing -> xs
Just url -> if usedTitle
-- hyperlink the title
then fmap (transform (linkTitle url)) xs
-- hyperlink the entire bib item
else [Linked url xs]
let mblang = lookupVariable "language" ref
>>= valToText
>>= either (const Nothing) Just . parseLang
return $
case mblang of
Nothing -> xs'
Just lang -> map
(transform (addLangToFormatting lang)) xs'
Nothing -> do
warn $ "citation " <> unItemId (citationItemId item) <>
" not found"
return [Literal $ addFontWeight BoldWeight
$ fromText $ unItemId (citationItemId item) <> "?"]
updateRefMap :: Int -> Citation a -> CitationItem a -> Eval a ()
updateRefMap citationGroupNumber citation item = do
isNote <- asks (styleIsNoteStyle . contextStyleOptions)
lastCitedMap <- gets stateLastCitedMap
let notenum = NumVal $ fromMaybe citationGroupNumber (citationNoteNumber citation)
-- keep track of how many citations in each note.
-- two citations from the same note don't count as "alone"
-- for ibid purposes. See citation-style-language/documentation#121
case citationNoteNumber citation of
Nothing -> return ()
Just n -> modify $ \st ->
st{ stateNoteMap = M.alter
(maybe
(Just (Set.singleton (citationItemId item)))
(Just . Set.insert (citationItemId item)))
n
(stateNoteMap st) }
case M.lookup (citationItemId item) lastCitedMap of
Nothing | isNote -> -- first citation
modify $ \st ->
st{ stateRefMap = ReferenceMap $
M.adjust (\ref -> ref{ referenceVariables =
M.insert "first-reference-note-number" notenum
(referenceVariables ref)})
(citationItemId item)
(unReferenceMap $ stateRefMap st) }
_ -> return ()
updateLastCitedMap :: Int -> Int -> Citation a -> CitationItem a -> Eval a ()
updateLastCitedMap citationGroupNumber positionInCitation citation item = do
unless (citationItemType item == AuthorOnly) $
modify $ \st ->
st{ stateLastCitedMap =
M.insert (citationItemId item)
(citationGroupNumber, citationNoteNumber citation,
positionInCitation,
(case citationItems citation of
[_] -> True
[x,y] -> citationItemId x == citationItemId y
&& citationItemType x == AuthorOnly
&& citationItemType y == SuppressAuthor
_ -> False),
citationItemLabel item,
citationItemLocator item)
$ stateLastCitedMap st }
-- | The first-occurring element tagged as Names will be
-- treated as the "author"; generally that is the author
-- but it might be the editor if it's an edited volume.
getAuthors :: Output a -> Output a
getAuthors x =
headDef NullOutput [y | y@(Tagged TagNames{} _) <- universe x]
removeNames :: Output a -> Output a
removeNames (Tagged TagNames{} _) = NullOutput
removeNames x = x
capitalizeInitialTerm :: [Output a] -> [Output a]
capitalizeInitialTerm [] = []
capitalizeInitialTerm (z:zs) = go z : zs
where
go (Tagged (TagTerm t) x) =
Tagged (TagTerm t)
(formatted mempty{ formatTextCase = Just CapitalizeFirst } [x])
go (Formatted f xs) = Formatted f (capitalizeInitialTerm xs)
go (Tagged tg x) = Tagged tg (go x)
go x = x
getPosition :: Int -> Maybe Int -> CitationItem a -> Int -> Eval a [Position]
getPosition groupNum mbNoteNum item posInGroup = do
inBibliography <- asks contextInBibliography
if inBibliography
then return []
else getPosition'
where
getPosition' = do
lastCitedMap <- gets stateLastCitedMap
noteMap <- gets stateNoteMap
case M.lookup (citationItemId item) lastCitedMap of
Nothing -> return [FirstPosition]
Just (prevGroupNum, mbPrevNoteNum,
prevPosInGroup, prevAloneInGroup,
prevLabel, prevLoc) -> do
isNote <- asks (styleIsNoteStyle . contextStyleOptions)
nearNoteDistance <- fromMaybe 5 <$>
asks (styleNearNoteDistance . contextStyleOptions)
let noteNum = fromMaybe groupNum mbNoteNum
let prevNoteNum = fromMaybe prevGroupNum mbPrevNoteNum
let prevAloneInNote =
case M.lookup prevNoteNum noteMap of
Nothing -> True
Just s -> Set.size s <= 1
let prevAlone = prevAloneInGroup && prevAloneInNote
return $
(if isNote && noteNum - prevNoteNum < nearNoteDistance
then (NearNote :)
else id) .
(if (groupNum == prevGroupNum &&
posInGroup == prevPosInGroup + 1) ||
(groupNum == prevGroupNum + 1 &&
(((-) <$> mbNoteNum <*> mbPrevNoteNum) <= Just 1) &&
posInGroup == 1 &&
prevAlone)
then case (prevLoc, citationItemLocator item) of
(Nothing, Just _)
-> (IbidWithLocator :) . (Ibid :)
(Nothing, Nothing) -> (Ibid :)
(Just _, Nothing) -> id
(Just l1, Just l2)
| l1 == l2
, citationItemLabel item == prevLabel
-> (Ibid :)
| otherwise
-> (IbidWithLocator :) . (Ibid :)
else id)
$ [Subsequent]
eElement :: CiteprocOutput a => Element a -> Eval a [Output a]
eElement (Element etype formatting) =
case etype of
EText textType ->
(:[]) <$> withFormatting formatting (eText textType)
ENumber var nform ->
(:[]) <$> withFormatting formatting (eNumber var nform)
EGroup isMacro els ->
(:[]) <$> eGroup isMacro formatting els
EChoose chooseParts -> eChoose chooseParts
ELabel var termform pluralize ->
(:[]) <$> eLabel var termform pluralize formatting
EDate var dateType mbShowDateParts dps ->
(:[]) <$> eDate var dateType mbShowDateParts dps formatting
ENames vars namesFormat subst ->
(:[]) <$> eNames vars namesFormat subst formatting
withFormatting :: CiteprocOutput a
=> Formatting -> Eval a (Output a) -> Eval a (Output a)
withFormatting (Formatting Nothing Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing Nothing
False False False) p
= p
withFormatting formatting p = do
-- Title case conversion only affects English-language items.
lang <- asks (localeLanguage . contextLocale)
ref <- gets stateReference
let reflang = case M.lookup "language" (referenceVariables ref) of
Just (TextVal t) ->
either (const Nothing) Just $ parseLang t
Just (FancyVal x) ->
either (const Nothing) Just $ parseLang $ toText x
_ -> Nothing
let mainLangIsEn Nothing = False
mainLangIsEn (Just l) = langLanguage l == "en"
let isEnglish = case reflang of
Just l -> mainLangIsEn (Just l)
Nothing -> mainLangIsEn lang
let formatting' = if formatTextCase formatting == Just TitleCase &&
not isEnglish
then formatting{ formatTextCase = Nothing }
else formatting
res <- p
return $ formatted formatting' [res]
lookupTerm :: Term -> Eval a [(Term, Text)]
lookupTerm term = do
terms <- asks (localeTerms . contextLocale)
let term' = if termName term == "sub verbo"
then term{ termName = "sub-verbo" }
else term
case M.lookup (termName term') terms of
Just ts -> return $ [ (term'',t)
| (term'',t) <- ts
, term' <= term''
]
Nothing -> return []
lookupTerm' :: CiteprocOutput a => Term -> Eval a (Output a)
lookupTerm' term = lookupTerm term >>= f
where
f [] =
-- “verb-short” first falls back to “verb”, “symbol”
-- first falls back to “short”, and “verb” and “short”
-- both fall back to “long”.
case termForm term of
VerbShort -> lookupTerm' term{ termForm = Verb }
Symbol -> lookupTerm' term{ termForm = Short }
Verb -> lookupTerm' term{ termForm = Long }
Short -> lookupTerm' term{ termForm = Long }
_ -> return NullOutput
f ((_,t):_) = return $ if T.null t
then NullOutput
else Literal $ fromText t
pageRange :: CiteprocOutput a => Text -> Eval a (Output a)
pageRange x = do
pageDelim <- lookupTerm'
emptyTerm{ termName = "page-range-delimiter" }
mbPageRangeFormat <- asks (stylePageRangeFormat . contextStyleOptions)
let ranges = map T.strip $ T.groupBy
(\c d -> not (c == ',' || c == '&' || d == ',' || d == '&'))
x
return $ formatted mempty{ formatDelimiter = Just " " }
$ map (formatPageRange mbPageRangeFormat
(case pageDelim of
NullOutput -> literal $ T.singleton enDash
delim -> delim)) ranges
enDash :: Char
enDash = '\x2013'
formatPageRange :: CiteprocOutput a
=> Maybe PageRangeFormat
-> Output a
-> Text
-> Output a
formatPageRange _ _ "&" = literal "&"
formatPageRange _ _ "," = literal ","
formatPageRange mbPageRangeFormat delim t =
let isDash '-' = True
isDash '\x2013' = True
isDash _ = False
rangeParts = if "\\-" `T.isInfixOf` t
then [T.replace "\\-" "-" t]
else map T.strip $ T.split isDash t
inRange pref xs
| T.null pref = grouped (intersperse delim (map literal xs))
| otherwise = grouped
(literal pref : intersperse delim (map literal xs))
changedDigits xs ys =
length $ filter not $ zipWith (==) (xs ++ repeat ' ') ys
minimal threshold pref x y =
case T.commonPrefixes x y of
Just (_comm, restx, resty) | T.length restx == T.length resty ->
if T.length resty < threshold && T.length y >= threshold
then inRange pref [x, T.takeEnd threshold y]
else inRange pref [x, resty]
_ -> inRange pref [x, y]
in case rangeParts of
[] -> NullOutput
[w] -> literal w
[w,v]
| Nothing <- mbPageRangeFormat -> inRange mempty [w,v]
| Just fmt <- mbPageRangeFormat -> do
let wPrefix = T.dropWhileEnd isDigit w
let vPrefix = T.dropWhileEnd isDigit v
if wPrefix == vPrefix
then do
let pref = wPrefix
let x = T.drop (T.length wPrefix) w
let y = T.drop (T.length vPrefix) v
let xlen = T.length x
let ylen = T.length y
let y' = if ylen < xlen
then T.take (xlen - ylen) x <> y
else y
case fmt of
PageRangeChicago15
| xlen < 3 -> inRange pref [x, y']
| "00" `T.isSuffixOf` x -> inRange pref [x, y']
| T.take 1 (T.takeEnd 2 x) == "0"
, T.take 1 (T.takeEnd 2 y') == "0"
-> minimal 1 pref x y'
| xlen == 4
, changedDigits (T.unpack x) (T.unpack y') >= 3
-> inRange pref [x, y']
| otherwise -> minimal 2 pref x y'
PageRangeChicago16
| xlen < 3 -> inRange pref [x, y']
| "00" `T.isSuffixOf` x -> inRange pref [x, y']
| T.take 1 (T.takeEnd 2 x) == "0"
, T.take 1 (T.takeEnd 2 y') == "0"
-> minimal 1 pref x y'
| otherwise -> minimal 2 pref x y'
PageRangeExpanded ->
inRange mempty [pref <> x, pref <> y']
PageRangeMinimal -> minimal 1 pref x y'
PageRangeMinimalTwo -> minimal 2 pref x y'
else inRange mempty [w,v]
_ -> literal t
eText :: CiteprocOutput a => TextType -> Eval a (Output a)
eText (TextVariable varForm v) = do
ref <- gets stateReference
-- Note: we do book keeping on how many variables
-- have been accessed and how many are nonempty,
-- in order to properly handle the group element,
-- which is implicitly conditional.
case v of
"id" -> do
updateVarCount 1 1
return $ Literal $ fromText $ coerce $ referenceId ref
"type" -> do
updateVarCount 1 1
return $ Literal $ fromText $ referenceType ref
"locator" -> do
let handleAmpersands (Just t) | T.any (=='&') t = do
ts <- lookupTerm emptyTerm { termName = "and"
, termForm = Symbol }
case ts of
(_,x):_ -> return (Just $ T.replace "&" x t)
[] -> return (Just t)
handleAmpersands x = return x
mbv <- asks contextLocator >>= handleAmpersands
mbl <- asks contextLabel
case mbv of
Just x | isNothing mbl || mbl == Just "page" -> do
updateVarCount 1 1
Tagged TagLocator <$> pageRange x
| otherwise -> do
updateVarCount 1 1
return $ Tagged TagLocator $
formatPageRange Nothing
(literal $ T.singleton enDash) x
Nothing -> NullOutput <$ updateVarCount 1 0
"year-suffix" -> do
disamb <- gets (referenceDisambiguation . stateReference)
case disamb >>= disambYearSuffix of
Just x ->
-- we don't update var count here; this doesn't
-- count as a variable
return $ Tagged (TagYearSuffix x)
(Literal (fromText (showYearSuffix x)))
Nothing -> return NullOutput
"citation-number" -> do
mbv <- askVariable v
case mbv of
Just (NumVal x) -> return $
Tagged (TagCitationNumber x) $
Literal $ fromText (T.pack (show x))
_ -> do
warn $ "citation-number not defined for " <>
coerce (referenceId ref)
return NullOutput
"citation-label" -> do -- these need year suffix too
mbv <- askVariable v
mbsuff <- getYearSuffix
case mbv of
Just (TextVal t) -> return $
Tagged TagCitationLabel $
grouped $
Literal (fromText t)
: maybeToList mbsuff
Just (FancyVal x) -> return $
Tagged TagCitationLabel $
grouped $
Literal x
: maybeToList mbsuff
_ -> do
warn $ "citation-label of unknown type for " <>
coerce (referenceId ref)
return NullOutput
"DOI" -> handleIdent id IdentDOI
"PMCID" -> handleIdent id IdentPMCID
"PMID" -> handleIdent id IdentPMID
"URL" -> handleIdent id IdentURL
_ -> do
mbv <- if varForm == ShortForm
then do
mbval <- (<|>) <$> askVariable (v <> "-short")
<*> askVariable v
case mbval of
Nothing -> return Nothing
Just val -> do
mbAbbrevs <- asks contextAbbreviations
return $ Just $ fromMaybe val
$ mbAbbrevs >>= lookupAbbreviation v val
else askVariable v
res <- case mbv of
Just (TextVal x)
| v == "page" -> pageRange x
| otherwise -> return $ Literal $ fromText x
Just (FancyVal x)
| v == "page" -> pageRange (toText x)
| otherwise -> return $ Literal x
Just (NumVal x) -> return $ Literal
$ fromText (T.pack (show x))
_ -> return NullOutput
unless (isNothing mbv) $ deleteSubstitutedVariables [v]
if v == "title" && res /= NullOutput
then do
modify (\st -> st { stateUsedTitle = True })
-- tag title so we can hyperlink it later
return $ Tagged TagTitle res
else return res
where
handleIdent :: CiteprocOutput b => (Text -> Text) -> (Text -> Identifier) -> Eval b (Output b)
handleIdent f identConstr = do
mbv <- askVariable v
deleteSubstitutedVariables [v]
case f <$> (valToText =<< mbv) of
Nothing -> return NullOutput
Just t -> do
-- create link and remember that we've done so far
modify (\st -> st { stateUsedIdentifier = True })
let url = identifierToURL (identConstr t)
return $ Linked url [Literal $ fromText t]
eText (TextMacro name) = do
warn $ "encountered unexpanded macro " <> name
return NullOutput
eText (TextValue t) = return $ Literal $ fromText t
eText (TextTerm term) = do
t' <- lookupTerm' term
t'' <- if termName term == "no date"
then do
mbsuff <- getYearSuffix
case mbsuff of
Nothing -> return t'
Just suff
| termForm term == Long
-> return $ grouped [t', Literal (fromText " "), suff]
| otherwise -> return $ grouped [t', suff]
else return t'
return $ Tagged (TagTerm term) t''
-- | Delete substituted variables so they aren't used again.
deleteSubstitutedVariables :: [Variable] -> Eval a ()
deleteSubstitutedVariables vars = do
inSubst <- asks contextInSubstitute
when inSubst $
modify $ \st -> -- delete variables so they aren't used again...
st{ stateReference =
let Reference id' type' d' m' = stateReference st
in Reference id' type' d' (foldr (\v -> M.insert v SubstitutedVal) m' vars) }
-- Numbers with prefixes or suffixes are never ordinalized
-- or rendered in roman numerals (e.g. “2E” remains “2E).
-- Numbers without affixes are individually transformed
-- (“2, 3” can become “2nd, 3rd”, “second, third” or “ii, iii”).
-- So, first we split on punctuation and spaces:
splitNums :: Text -> [Val a]
splitNums = map go . T.groupBy sameClass
where
go t = case readAsInt t of
Just i -> NumVal i
Nothing -> TextVal $ if t == "-"
then T.singleton enDash
else t
sameClass c d = (isSepPunct c || isSpace c) ==
(isSepPunct d || isSpace d)
--- punctuation that separates pages in a range
isSepPunct :: Char -> Bool
isSepPunct ',' = True
isSepPunct ';' = True
isSepPunct '-' = True
isSepPunct '\x2013' = True
isSepPunct _ = False
eLabel :: CiteprocOutput a
=> Variable
-> TermForm
-> Pluralize
-> Formatting
-> Eval a (Output a)
eLabel var termform pluralize formatting = do
ref <- gets stateReference
let getTerm :: CiteprocOutput a
=> Text -> Val a -> Eval a (Output a)
getTerm termname x = do
let determinePlural t
| var == "number-of-volumes"
, t /= "1" && t /= "0" = Plural
| "\\-" `T.isInfixOf` t = Singular
| length (splitNums t) > 1 = Plural
-- see label_CollapsedPageNumberPluralDetection.txt
| otherwise = Singular
let number = case pluralize of
AlwaysPluralize -> Plural
NeverPluralize -> Singular
ContextualPluralize ->
case x of
TextVal t -> determinePlural t
FancyVal w -> determinePlural (toText w)
NamesVal ns -> if length ns > 1
then Plural
else Singular
_ -> Singular
let term = emptyTerm{ termName = termname
, termForm = termform
, termNumber = Just number }
lookupTerm' term
locator <- asks contextLocator
label <- asks contextLabel
let var' = if var == "editortranslator" then "editor" else var
term' <- case (var, locator, label) of
("locator", Just loc, Just lab) -> getTerm lab (TextVal loc)
("locator", Just loc, Nothing)
| beginsWithSpace loc -> return NullOutput
| ". " `T.isPrefixOf` T.dropWhile isLetter loc
-> return NullOutput
| otherwise -> getTerm "page" (TextVal loc)
_ -> case lookupVariable var' ref of
Nothing -> return NullOutput
Just x -> getTerm (fromVariable var) x
return $
case formatSuffix formatting of
Just suff
| "." `T.isPrefixOf` suff
-> case term' of
Literal x
| "." `T.isSuffixOf` toText x
, not (formatStripPeriods formatting)
-> formatted
formatting{ formatSuffix =
if T.length suff <= 1
then Nothing
else Just (T.drop 1 suff) }
[term']
_ -> formatted formatting [term']
_ -> formatted formatting [term']
eDate :: CiteprocOutput a
=> Variable
-> DateType
-> Maybe ShowDateParts
-> [DP]
-> Formatting
-> Eval a (Output a)
eDate var dateType mbShowDateParts dps formatting
| var == mempty = do
warn "skipping date element with no variable attribute set"
return NullOutput
| otherwise = do
datevar <- askVariable var
localeDateElt <- M.lookup dateType <$> asks (localeDate . contextLocale)
let addOverride newdps olddp accum =
case find ((== dpName olddp) . dpName) newdps of
Just x -> x{ dpFormatting =
dpFormatting olddp <> dpFormatting x } : accum
Nothing -> olddp : accum
let useDatePart dp =
case mbShowDateParts of
Just Year -> dpName dp == DPYear
Just YearMonth -> dpName dp == DPYear || dpName dp == DPMonth
_ -> True
let (dps', formatting') =
case localeDateElt of
Just (Element (EDate _ _ _ edps) f)
-> (filter useDatePart $ foldr (addOverride dps) [] edps,
formatting <> f)
_ -> (filter useDatePart dps, formatting)
case datevar of
Nothing ->
-- warn $ "date element for empty variable " <> var
return NullOutput
Just (DateVal date) ->
case dateLiteral date of
Just t -> return $ formatted formatting' [Literal $ fromText t]
Nothing -> do
let dateparts = case dateSeason date of
Just i ->
case dateParts date of
[DateParts [y]] ->
[DateParts [y, 12 + i]] -- pseudo-mo
xs -> xs
Nothing -> dateParts date
xs <- formatDateParts dps'
$ case dateparts of
[] -> (DateParts [], Nothing)
[d] -> (d, Nothing)
(d:e:_) -> (d, Just e)
when (all (== NullOutput) xs) $
-- back off on the claim to nonemptiness
-- when the only match are in date parts that
-- we aren't printing; see
-- group_SuppressTermWhenNoOutputFromPartialDate.txt
updateVarCount 0 (-1)
yearSuffix <- getYearSuffix
return $ Tagged (TagDate date) $ formatted formatting'
(xs ++ maybeToList yearSuffix)
Just _ -> do
warn $ "date element for variable with non-date value " <>
fromVariable var
return NullOutput
getYearSuffix :: CiteprocOutput a => Eval a (Maybe (Output a))
getYearSuffix = do
disamb <- gets (referenceDisambiguation . stateReference)
sopts <- asks contextStyleOptions
-- we only want year suffix on first occurence of year
-- in a reference:
usedYearSuffix <- gets stateUsedYearSuffix
case disamb >>= disambYearSuffix of
Just c
| not (styleUsesYearSuffixVariable sopts)
, not usedYearSuffix
-> do
modify $ \st -> st{ stateUsedYearSuffix = True }
return $ Just $ Tagged (TagYearSuffix c)
(Literal (fromText (showYearSuffix c)))
| otherwise -> return Nothing
Nothing -> return Nothing
formatSortDate :: CiteprocOutput a
=> [DP] -> (Maybe Int, Maybe Int, Maybe Int) -> Output a
formatSortDate dpSpecs (mbyr, mbmo, mbda) =
Literal $ fromText $ T.pack $ sortyr <> sortmo <> sortda
where
sortyr = case mbyr of
Just yr | any ((== DPYear) . dpName) dpSpecs
-> printf "%04d" (yr + 5000) -- to work with BC and AD
_ -> ""
sortmo = case mbmo of
Just mo | any ((== DPMonth) . dpName) dpSpecs
-> printf "%02d" mo
_ -> ""
sortda = case mbda of
Just da | any ((== DPDay) . dpName) dpSpecs
-> printf "%02d" da
_ -> ""
formatDateParts :: CiteprocOutput a
=> [DP] -> (DateParts, Maybe DateParts) -> Eval a [Output a]
formatDateParts dpSpecs (date, mbNextDate) = do
inSortKey <- asks contextInSortKey
let (yr,mo,da) = bindDateParts date
case bindDateParts <$> mbNextDate of
Nothing
| inSortKey -> return [formatSortDate dpSpecs (yr, mo, da)]
| otherwise -> mapM (eDP (yr,mo,da)) dpSpecs
Just (nextyr, nextmo, nextda)
| inSortKey -> return [formatSortDate dpSpecs (yr, mo, da),
Literal (fromText "-"),
formatSortDate dpSpecs (nextyr, nextmo, nextda)]
| otherwise -> do
let isOpenRange = nextyr == Just 0 &&
isNothing nextmo &&
isNothing nextda
-- figure out where the range goes:
-- first to differ out of the items selected by dpSpecs, in order y->m->d
let dpToNs DPYear = (yr, nextyr)
dpToNs DPMonth = (mo, nextmo)
dpToNs DPDay = (da, nextda)
let areSame = takeWhile (uncurry (==) . dpToNs) $
sort $ map dpName dpSpecs
let (sames1, rest) = span (\dp -> dpName dp `elem` areSame) dpSpecs
let (diffs, sames2) = span (\dp -> dpName dp `notElem` areSame) rest
let cleanup = filter (/= NullOutput)
sames1' <- cleanup <$> mapM (eDP (yr,mo,da)) sames1
diffsLeft' <- cleanup <$> mapM (eDP (yr,mo,da)) diffs
diffsRight' <- cleanup <$> mapM (eDP (nextyr,nextmo,nextda)) diffs
sames2' <- cleanup <$> mapM (eDP (yr,mo,da)) sames2
let rangeDelim = case sortOn dpName diffs of
[] -> Nothing
(dp:_) -> Just $ dpRangeDelimiter dp
let toRange xs ys =
case lastMay xs of
Just xlast ->
initSafe xs ++
[Formatted mempty{ formatDelimiter = rangeDelim }
[xlast, headDef (Literal mempty) ys]] ++
tailSafe ys
_ -> xs ++ ys
return $
if isOpenRange
then [Formatted mempty{ formatSuffix = rangeDelim }
(removeLastSuffix $ sames1' ++ diffsLeft')]
else removeLastSuffix $
sames1' ++
toRange (removeLastSuffix diffsLeft')
(removeFirstPrefix diffsRight') ++
sames2'
removeFirstPrefix :: [Output a] -> [Output a]
removeFirstPrefix (Formatted f xs : rest) =
Formatted f{ formatPrefix = Nothing } xs : rest
removeFirstPrefix xs = xs
removeLastSuffix :: [Output a] -> [Output a]
removeLastSuffix [] = []
removeLastSuffix [Formatted f xs] =
[Formatted f{ formatSuffix = Nothing } xs ]
removeLastSuffix (x:xs) = x : removeLastSuffix xs
eDP :: CiteprocOutput a
=> (Maybe Int, Maybe Int, Maybe Int) -> DP -> Eval a (Output a)
eDP (yr,mo,da) dp = do
let mbn = case dpName dp of
DPDay -> da
DPMonth -> mo
DPYear -> yr
case mbn of
Nothing -> return NullOutput
Just 0 | dpName dp == DPYear
-> return $ Literal mempty -- open date range
Just n -> do
let litStr = return . Literal . fromText . T.pack
suffix <- case dpName dp of
DPYear
| n < 0
-> (:[]) <$> lookupTerm' emptyTerm{ termName = "bc" }
| n > 0
, n < 1000
-> (:[]) <$> lookupTerm' emptyTerm{ termName = "ad" }
| otherwise -> return []
_ -> return []
let n' = case dpName dp of
DPYear -> abs n
_ -> n
formatted (dpFormatting dp) . (:suffix) <$>
case dpForm dp of
DPNumeric -> litStr (show n')
DPNumericLeadingZeros -> litStr (printf "%02d" n')
DPOrdinal -> do
locale <- asks contextLocale
if localeLimitDayOrdinalsToDay1 locale == Just True && n' /= 1
then litStr (show n')
else evalNumber NumberOrdinal Nothing (NumVal n')
form -> do
let termForMonth s = emptyTerm{ termName = T.pack s
, termForm = if form == DPShort
then Short
else Long }
case dpName dp of
DPMonth | n <= 0 -> return NullOutput
| n <= 12 ->
lookupTerm' $ termForMonth (printf "month-%02d" n)
| n <= 16 -> -- season pseudo-month
lookupTerm' $ termForMonth (printf "season-%02d" (n - 12))
| n <= 20 -> -- season pseudo-month
lookupTerm' $ termForMonth (printf "season-%02d" (n - 16))
| otherwise -> -- season pseudo-month
lookupTerm' $ termForMonth (printf "season-%02d" (n - 20))
_ -> litStr (show n')
bindDateParts :: DateParts -> (Maybe Int, Maybe Int, Maybe Int)
bindDateParts date =
case date of
DateParts (y:m:d:_) -> (Just y,Just m,Just d)
DateParts [y,m] -> (Just y,Just m,Nothing)
DateParts [y] -> (Just y,Nothing,Nothing)
_ -> (Nothing,Nothing,Nothing)
eNames :: CiteprocOutput a
=> [Variable]
-> NamesFormat
-> [Element a]
-> Formatting
-> Eval a (Output a)
eNames vars namesFormat' subst formatting = do
substituteNamesForm <- asks contextSubstituteNamesForm
inSortKey <- asks contextInSortKey
let namesFormat =
case substituteNamesForm of
Nothing -> namesFormat'
Just subs ->
NamesFormat
{ namesLabel =
if inSortKey -- see test/csl/sort_DropNameLabelInSort.txt
-- though this doesn't seem to be in the spec
then Nothing
else namesLabel namesFormat' <|> namesLabel subs
, namesEtAl = namesEtAl namesFormat' <|>
namesEtAl subs
, namesName = namesName namesFormat' <|>
namesName subs
, namesLabelBeforeName =
if isJust (namesName namesFormat') &&
isJust (namesLabel namesFormat')
then namesLabelBeforeName namesFormat'
else namesLabelBeforeName subs
}
vars' <- if "editor" `elem` vars && "translator" `elem` vars
then do
ed <- askVariable "editor"
tr <- askVariable "translator"
let termform =
case namesLabel namesFormat of
Just (termform', _, _) -> termform'
_ -> Long
mbterm <- lookupTerm'
emptyTerm{ termName = "editortranslator"
, termForm = termform }
if ed == tr && mbterm /= NullOutput
then return $ "editortranslator" :
[v | v <- vars
, v /= "editor"
, v /= "translator"]
else return vars
else return vars
inSubstitute <- asks contextInSubstitute
let (nameFormat, nameFormatting') =
fromMaybe (defaultNameFormat, mempty) (namesName namesFormat)
let nameFormatting = nameFormatting' <>
formatting{ formatPrefix = Nothing
, formatSuffix = Nothing
, formatDelimiter = Nothing }
rawContribs <- mapM (\var -> (var,) <$>
askVariable
(if var == "editortranslator"
then "editor"
else var)) vars'
if all (isNothing . snd) rawContribs
then
case subst of
els@(_:_) | not inSubstitute -> do
res <- withRWST
(\ctx st -> (ctx{ contextInSubstitute = True
, contextSubstituteNamesForm =
Just namesFormat },
st)) $ eSubstitute els
return $
case res of
(Tagged TagNames{} _:_) -> formatted formatting res
-- important to have title (or whatever) tagged as
-- substituting for Names, for purposes of
-- disambiguation:
_ -> formatted formatting
[Tagged (TagNames "" namesFormat []) $ grouped res]
_ -> return NullOutput
else do
xs <- mapM (formatNames namesFormat nameFormat nameFormatting)
rawContribs
deleteSubstitutedVariables [v | (v, Just _) <- rawContribs ]
return $
case nameForm nameFormat of
CountName -> Literal $ fromText $ T.pack $ show $ length
[name
| Tagged (TagName name) _ <- concatMap universe xs]
_ -> formatted mempty{ formatPrefix = formatPrefix formatting
, formatSuffix = formatSuffix formatting
, formatDelimiter =
formatDelimiter formatting } xs
eSubstitute :: CiteprocOutput a
=> [Element a]
-> Eval a [Output a]
eSubstitute els =
case els of
[] -> return []
(e:es) -> do
res <- eElement e
case filter (/= NullOutput) res of
[] -> eSubstitute es
xs -> return xs
formatNames :: CiteprocOutput a
=> NamesFormat
-> NameFormat
-> Formatting
-> (Variable, Maybe (Val a))
-> Eval a (Output a)
formatNames namesFormat nameFormat formatting (var, Just (NamesVal names)) =
do
isSubsequent <- (Subsequent `elem`) <$> asks contextPosition
isInBibliography <- asks contextInBibliography
let (etAlMin, etAlUseFirst) =
if not isInBibliography && isSubsequent
then (nameEtAlSubsequentMin nameFormat <|> nameEtAlMin nameFormat,
nameEtAlSubsequentUseFirst nameFormat <|>
nameEtAlUseFirst nameFormat)
else (nameEtAlMin nameFormat, nameEtAlUseFirst nameFormat)
inSortKey <- asks contextInSortKey
disamb <- gets (referenceDisambiguation . stateReference)
names' <- zipWithM (formatName nameFormat formatting) [1..] names
let delim' = fromMaybe (nameDelimiter nameFormat) $
formatDelimiter formatting
let delim = case (beginsWithSpace <$> formatSuffix formatting,
endsWithSpace <$> formatPrefix formatting) of
(Just True, Just True) -> T.strip delim'
(Just True, _) -> T.stripStart delim'
(_, Just True) -> T.stripEnd delim'
_ -> delim'
let numnames = length names'
label <- case namesLabel namesFormat of
Just (termform, pluralize, lf) | not inSortKey ->
(:[]) <$> eLabel var termform pluralize lf
_ -> return []
mbAndTerm <- case nameAndStyle nameFormat of
Just Symbol -> do
ts <- lookupTerm emptyTerm { termName = "and"
, termForm = Symbol }
case ts of
(_,x):_ -> return $ Just x
[] -> return $ Just "&"
Just _ -> fmap snd . listToMaybe <$>
lookupTerm emptyTerm { termName = "and"
, termForm = Long }
Nothing -> return Nothing
let finalNameIsOthers = (lastMay names >>= nameLiteral) == Just "others"
-- bibtex conversions often have this, and we want to render it "et al"
let etAlUseLast = nameEtAlUseLast nameFormat
let etAlThreshold = case etAlMin of
Just x | numnames >= x
-> case (disamb >>= disambEtAlNames, etAlUseFirst) of
(Just n, Just m) -> Just (max m n)
(_, y) -> y
| numnames < x
, finalNameIsOthers -> Just (numnames - 1)
_ -> Nothing
let beforeLastDelim =
case mbAndTerm of
Nothing -> delim
Just _ ->
case nameDelimiterPrecedesLast nameFormat of
PrecedesContextual
| numnames > 2 -> delim
| otherwise -> ""
PrecedesAfterInvertedName
-> case nameAsSortOrder nameFormat of
Just NameAsSortOrderAll -> delim
Just NameAsSortOrderFirst
| numnames < 3 -> delim
_ -> ""
PrecedesAlways -> delim
PrecedesNever -> ""
let andPreSpace = case beforeLastDelim of
"" -> case formatSuffix formatting of
Just t | endsWithSpace t -> ""
_ -> " "
t | endsWithSpace t -> ""
_ -> " "
let andPostSpace = case formatPrefix formatting of
Just t | beginsWithSpace t -> ""
_ -> " "
let mbAndDelim = case mbAndTerm of
Nothing -> Nothing
Just t -> Just (andPreSpace <> t <> andPostSpace)
let etAlPreSpace = case formatSuffix formatting of
Just t | endsWithSpace t -> ""
_ -> " "
let beforeEtAl =
case nameDelimiterPrecedesEtAl nameFormat of
PrecedesContextual
| numnames > 2
, etAlThreshold > Just 1 -> delim
| otherwise -> etAlPreSpace
PrecedesAfterInvertedName
-> case nameAsSortOrder nameFormat of
Just NameAsSortOrderAll -> delim
Just NameAsSortOrderFirst
| etAlThreshold < Just 2 -> delim
_ -> etAlPreSpace
PrecedesAlways -> delim
PrecedesNever -> etAlPreSpace
etAl <- case namesEtAl namesFormat of
Just (term, f) -> withFormatting f{
formatPrefix = removeDoubleSpaces <$>
Just beforeEtAl <> formatPrefix f } $
lookupTerm' emptyTerm{ termName = term }
Nothing
| etAlUseLast && not finalNameIsOthers ->
return $
Formatted mempty{ formatPrefix = Just beforeEtAl }
[literal "\x2026 "] -- ellipses
| otherwise ->
Formatted mempty{ formatPrefix = Just beforeEtAl }
. (:[]) <$> lookupTerm' emptyTerm{ termName = "et-al" }
let addNameAndDelim name idx
| etAlThreshold == Just 0 = NullOutput
| idx == 1 = name
| maybe False (idx - 1 ==) etAlThreshold =
if inSortKey
then NullOutput
else etAl
| idx == numnames
, etAlUseLast
, maybe False (idx - 1 >=) etAlThreshold
= name
| maybe False (idx - 1 >) etAlThreshold = NullOutput
| inSortKey = name
| idx == numnames
= formatted mempty{ formatPrefix =
Just (beforeLastDelim <> fromMaybe "" mbAndDelim) }
[name]
| otherwise = formatted mempty{ formatPrefix = Just delim } [name]
let names'' = zipWith addNameAndDelim names' [1..]
-- we set delimiter to Nothing because we're handling delim
-- manually, to allow for things like "and" and no final comma
return $ Tagged (TagNames var namesFormat names)
$ grouped $
if namesLabelBeforeName namesFormat
then label ++ names''
else names'' ++ label
formatNames _ _ _ (var, Just x) = do
when (x /= SubstitutedVal) $
warn $ "ignoring non-name value for variable " <> fromVariable var
return NullOutput
formatNames _ _ _ (_, Nothing) = return NullOutput
formatName :: CiteprocOutput a
=> NameFormat -> Formatting -> Int -> Name -> Eval a (Output a)
formatName nameFormat formatting order name = do
disamb <- gets (referenceDisambiguation . stateReference)
let nameFormat' =
case M.lookup name . disambNameMap =<< disamb of
Nothing -> nameFormat
Just AddInitials
-> nameFormat{ nameForm = LongName }
Just AddInitialsIfPrimary
| order == 1 -> nameFormat{ nameForm = LongName }
| otherwise -> nameFormat
Just AddGivenName ->
nameFormat{ nameForm = LongName
, nameInitialize = False
}
Just AddGivenNameIfPrimary
| order == 1 ->
nameFormat{ nameForm = LongName
, nameInitialize = False
}
| otherwise -> nameFormat
Tagged (TagName name) <$>
case nameLiteral name of
Just t -> return $ formatted formatting
$ maybe [literal t]
(\f -> [Formatted f [literal t]])
(nameFamilyFormatting nameFormat)
Nothing -> getDisplayName nameFormat' formatting order name
getNamePartSortOrder :: Name -> Eval a [Text]
getNamePartSortOrder name = do
demoteNonDroppingParticle <-
asks (styleDemoteNonDroppingParticle . contextStyleOptions)
map (fromMaybe mempty) <$>
case nameLiteral name of
Nothing
| isByzantineName name
-> return $
case demoteNonDroppingParticle of
DemoteNever ->
[nameNonDroppingParticle name <> nameFamily name,
nameDroppingParticle name,
nameGiven name,
nameSuffix name]
_ -> [nameFamily name,
nameDroppingParticle name <>
nameNonDroppingParticle name,
nameGiven name,
nameSuffix name]
| otherwise
-> return [nameFamily name,
nameGiven name]
Just n -> return [Just n]
literal :: CiteprocOutput a => Text -> Output a
literal = Literal . fromText
showYearSuffix :: Int -> Text
showYearSuffix x
| x < 27 = T.singleton $ chr $ ord 'a' + (x - 1)
| otherwise =
let x' = x - 1
in T.pack [chr (ord 'a' - 1 + (x' `div` 26)),
chr (ord 'a' + (x' `mod` 26))]
initialize :: Maybe Lang
-> Bool -- ^ initialize
-> Bool -- ^ with hyphen
-> Text -- ^ initialize with (suffix)
-> Text
-> Text
initialize mblang makeInitials useHyphen initializeWith =
stripSpaces . T.replace " -" "-" . mconcat . map initializeWord . splitWords
where
stripSpaces = T.dropWhile (==' ') . T.dropWhileEnd (==' ') -- preserve nbsp
-- Left values are already initials
-- Right values are not
splitWords =
reverse . (\(ws,cs) ->
case cs of
[] -> ws
[d] -> Left (T.singleton d) : ws
_ -> Right (T.pack (reverse cs)) : ws) .
T.foldl'
(\(ws, cs) c ->
case c of
'.' | null cs -> (ws, [])
| otherwise -> (Left (T.pack (reverse cs)) : ws, [])
'-' | null cs -> (ws, ['-'])
| otherwise -> (Right (T.pack (reverse cs)) : ws, ['-'])
' ' -> case cs of
[] -> (ws, cs)
[d] -> (Left (T.singleton d) : ws, [])
_ -> (Right (T.pack (reverse cs)) : ws, [])
_ -> (ws, c:cs))
([], mempty)
addSuffix t
| T.null t = mempty
| otherwise = t <> initializeWith
toInitial t =
case T.uncons t of
Just ('-', t') ->
case T.uncons t' of
Just (c, _)
| isUpper c
, useHyphen -> "-" <> Unicode.toUpper mblang (T.singleton c)
| isUpper c -> Unicode.toUpper mblang (T.singleton c)
_ -> mempty -- e.g. Ji-ping -> J. not J.-p.
Just (c, t')
| isUpper c ->
case T.uncons t' of
Just (d, t'')
| isUpper d -- see test/csl/name_LongAbbreviation.txt
, not (T.null t'')
, T.all isLower t''
-> T.singleton c <> T.toLower (T.singleton d)
_ -> T.singleton c
_ -> t
initializeWord (Left t) -- Left values already initialized
= addSuffix t
initializeWord (Right t) -- Right values not already initialized
| T.all isLower t = if endsWithSpace initializeWith
then t <> " "
else " " <> t <> " "
| makeInitials = (addSuffix . toInitial) t
| otherwise = t <> " "
getDisplayName :: CiteprocOutput a
=> NameFormat -> Formatting -> Int -> Name -> Eval a (Output a)
getDisplayName nameFormat formatting order name = do
inSortKey <- asks contextInSortKey
demoteNonDroppingParticle <-
asks (styleDemoteNonDroppingParticle . contextStyleOptions)
initializeWithHyphen <-
asks (styleInitializeWithHyphen . contextStyleOptions)
mblang <- asks (localeLanguage . contextLocale)
let initialize' =
case nameFamily name of
Nothing -> id
Just _ ->
case nameInitializeWith nameFormat of
Just initializeWith ->
initialize
mblang
(nameInitialize nameFormat)
initializeWithHyphen
initializeWith
Nothing -> id
let separator = nameSortSeparator nameFormat
let x <+> NullOutput = x
NullOutput <+> x = x
Literal x <+> y =
case T.unsnoc (toText x) of
Just (_, c) | c == '’' || c == '\'' || c == '-' || c == '\x2013' ||
c == '\xa0' ->
formatted mempty [Literal x, y]
_ | isByzantineName name ->
formatted mempty{ formatDelimiter = Just " " } [Literal x, y]
| otherwise -> formatted mempty [Literal x, y]
Formatted f x <+> y =
formatted mempty{ formatDelimiter =
case formatSuffix f of
Just t | endsWithSpace t -> Nothing
_ -> Just " " } [formatted f x, y]
Linked i x <+> y =
formatted mempty{ formatDelimiter = Just " " } [Linked i x, y]
Tagged _ x <+> y = x <+> y
InNote x <+> y = x <+> y
let x <:> NullOutput = x
NullOutput <:> x = x
Literal x <:> y =
formatted mempty{ formatDelimiter = Just separator } [Literal x, y]
Formatted f x <:> y = formatted
(mempty{ formatDelimiter = Just separator }) [Formatted f x, y]
Linked i x <:> y = formatted
(mempty{ formatDelimiter = Just separator }) [Linked i x, y]
Tagged _ x <:> y = x <:> y
InNote x <:> y = x <:> y
let familyAffixes = formatted
(case nameFamilyFormatting nameFormat of
Nothing -> mempty
Just f -> mempty{ formatSuffix = formatSuffix f
, formatPrefix = formatPrefix f })
let givenAffixes = formatted
(case nameGivenFormatting nameFormat of
Nothing -> mempty
Just f -> mempty{ formatSuffix = formatSuffix f
, formatPrefix = formatPrefix f })
let familyFormatting = formatted
(case nameFamilyFormatting nameFormat of
Nothing -> mempty
Just f -> f{ formatSuffix = Nothing
, formatPrefix = Nothing })
let givenFormatting = formatted
(case nameGivenFormatting nameFormat of
Nothing -> mempty
Just f -> f{ formatSuffix = Nothing
, formatPrefix = Nothing })
let nonDroppingParticle =
maybe NullOutput (familyFormatting . (:[]) . literal) $
nameNonDroppingParticle name
let droppingParticle =
maybe NullOutput (givenFormatting . (:[]) . literal) $
nameDroppingParticle name
let given =
maybe NullOutput (givenFormatting . (:[]) . literal . initialize') $
nameGiven name
let family =
maybe NullOutput (familyFormatting . (:[]) . literal) $
nameFamily name
let suffix = maybe NullOutput literal $ nameSuffix name
let nameAsSort = case nameAsSortOrder nameFormat of
Just NameAsSortOrderAll -> True
Just NameAsSortOrderFirst -> order == 1
_ -> False
return $ formatted formatting . (:[]) $
if isByzantineName name
then
case nameForm nameFormat of
LongName
| demoteNonDroppingParticle == DemoteNever
, inSortKey || nameAsSort ->
familyAffixes
[ nonDroppingParticle <+>
family ] <:>
givenAffixes
[ given <+>
droppingParticle ] <:>
suffix
| demoteNonDroppingParticle == DemoteSortOnly
, inSortKey ->
familyAffixes
[ family ] <:>
givenAffixes
[ given <+>
droppingParticle <+>
nonDroppingParticle ] <:>
suffix
| demoteNonDroppingParticle == DemoteSortOnly
, nameAsSort ->
familyAffixes
[ nonDroppingParticle <+>
family ] <:>
givenAffixes
[ given <+>
droppingParticle ] <:>
suffix
| demoteNonDroppingParticle == DemoteDisplayAndSort
, inSortKey || nameAsSort ->
familyAffixes
[ family ] <:>
givenAffixes
[ given <+>
droppingParticle <+>
nonDroppingParticle ] <:>
suffix
| nameCommaSuffix name ->
givenAffixes
[ given ] <+>
familyAffixes
[ droppingParticle <+>
nonDroppingParticle <+>
family <:>
suffix ]
| otherwise ->
givenAffixes
[ given ] <+>
familyAffixes
[ droppingParticle <+>
nonDroppingParticle <+>
family <+>
suffix ]
ShortName ->
familyAffixes
[ nonDroppingParticle <+>
family ]
CountName -> NullOutput
else
case nameForm nameFormat of
LongName -> grouped
[ familyAffixes
[ family ]
, givenAffixes
[ given ] ]
ShortName -> familyAffixes
[ family ]
CountName -> NullOutput
eGroup :: CiteprocOutput a
=> Bool -> Formatting -> [Element a] -> Eval a (Output a)
eGroup isMacro formatting els = do
-- A group is suppressed if it directly or indirectly
-- calls at least one variable but all of the variables
-- it calls are empty.
VarCount oldVars oldNonempty <- gets stateVarCount
xs <- mconcat <$> mapM eElement els
VarCount newVars newNonempty <- gets stateVarCount
let isempty = newVars /= oldVars && newNonempty == oldNonempty
-- see
-- https://github.com/citation-style-language/documentation/blob/master/specification.rst#group
-- "When a cs:group contains a child cs:macro, if the cs:macro is
-- non-empty, it is treated as a non-empty variable for the purposes of
-- determining suppression of the outer cs:group."
when (isMacro && not isempty) $ updateVarCount 1 1
return $ if not isempty
then formatted formatting xs
else NullOutput
eChoose :: CiteprocOutput a
=> [(Match, [Condition], [Element a])] -> Eval a [Output a]
eChoose [] = return []
eChoose ((match, conditions, els):rest) = do
ref <- gets stateReference
label <- asks contextLabel
let disambiguate = maybe False
disambCondition (referenceDisambiguation ref)
positions <- asks contextPosition
hasLocator <- isJust <$> asks contextLocator
let isNumeric t = all
(\chunk -> T.any isDigit chunk && not (T.any isSpace chunk)) $
T.split (\c -> c == ',' || c == '-' || c == '&')
(T.replace ", " "," . T.replace "& " "&" . T.replace ", " "," $ t)
let testCondition cond =
case cond of
HasVariable "locator" -> hasLocator
HasVariable t ->
case lookupVariable t ref of
Just x -> isNonEmpty x
Nothing -> False
HasType ts ->
case lookupVariable "type" ref of
Just (TextVal ty) -> ty `elem` ts
_ -> False
IsUncertainDate t -> case lookupVariable t ref of
Just (DateVal d) -> dateCirca d
_ -> False
IsNumeric t -> case lookupVariable t ref of
Just (NumVal _) -> True
Just (TextVal x) -> isNumeric x
Just (FancyVal x) -> isNumeric (toText x)
_ -> False
HasLocatorType t -> case label of
Just "sub verbo" -> t == "sub-verbo"
Just x -> toVariable x == t
Nothing -> t == "page"
HasPosition pos -> pos `elem` positions
WouldDisambiguate -> disambiguate
let matched = (case match of
MatchAll -> all testCondition
MatchAny -> any testCondition
MatchNone -> not . any testCondition) conditions
if matched
then mconcat <$> mapM eElement els
else eChoose rest
eNumber :: CiteprocOutput a => Variable -> NumberForm -> Eval a (Output a)
eNumber var nform = do
mbv <- askVariable var
varTerms <- lookupTerm emptyTerm { termName = fromVariable var }
let mbGender = case varTerms of
[] -> Nothing
((t,_):_) -> termGender t
let nparts = case mbv of
Just x@NumVal{} -> [x]
Just (FancyVal x) -> splitNums (toText x)
Just (TextVal t) -> splitNums t
_ -> []
grouped <$> mapM (evalNumber nform mbGender) nparts
evalNumber :: CiteprocOutput a
=> NumberForm -> Maybe TermGender -> Val a -> Eval a (Output a)
evalNumber form mbGender (NumVal i) = do
let numterm s x = emptyTerm { termName = T.pack $ printf s x
, termGenderForm = mbGender }
let dectext = T.pack (show i)
let twomatch = numterm "ordinal-%02d" (i `mod` 100)
let onematch = numterm "ordinal-%02d" (i `mod` 10)
let fallback = emptyTerm { termName = "ordinal" }
case form of
NumberNumeric -> return $ Literal $ fromText dectext
NumberOrdinal -> do
res <- (if i > 99
then filter (\(t,_) -> termMatch t /= Just WholeNumber)
else id) <$> lookupTerm twomatch
case res of
((_,suff):_) ->
return $ Literal $ fromText (dectext <> suff)
[] -> do -- not an exact match
res' <- (if i > 10
then filter (\(t,_) ->
isNothing (termMatch t) ||
termMatch t == Just LastDigit)
else id) <$> lookupTerm onematch
case res' of
((_,suff):_) ->
return $ Literal $ fromText (dectext <> suff)
[] -> do
res'' <- lookupTerm fallback
case res'' of
((_,suff):_) ->
return $ Literal $ fromText (dectext <> suff)
[] -> do
warn $ "no ordinal suffix found for " <> dectext
return $ Literal $ fromText (T.pack (show i))
NumberLongOrdinal
| i >= 1
, i <= 10 -> do
res <- lookupTerm (numterm "long-ordinal-%02d" i)
case res of
((_,t):_) -> return $ Literal $ fromText t
[] -> evalNumber NumberOrdinal mbGender (NumVal i)
| otherwise -> evalNumber NumberOrdinal mbGender (NumVal i)
NumberRoman -> return $ Literal $ fromText $ toRomanNumeral i
evalNumber _ _ (TextVal t) = return $ Literal $ fromText t
evalNumber _ _ (FancyVal t) = return $ Literal t
evalNumber _ _ _ = return NullOutput
warn :: Text -> Eval a ()
warn t = tell $ Set.singleton t
-- | Convert number < 4000 to lowercase roman numeral.
toRomanNumeral :: Int -> Text
toRomanNumeral x
| x >= 4000 || x < 0 = T.pack (show x)
| x >= 1000 = "m" <> toRomanNumeral (x - 1000)
| x >= 900 = "cm" <> toRomanNumeral (x - 900)
| x >= 500 = "d" <> toRomanNumeral (x - 500)
| x >= 400 = "cd" <> toRomanNumeral (x - 400)
| x >= 100 = "c" <> toRomanNumeral (x - 100)
| x >= 90 = "xc" <> toRomanNumeral (x - 90)
| x >= 50 = "l" <> toRomanNumeral (x - 50)
| x >= 40 = "xl" <> toRomanNumeral (x - 40)
| x >= 10 = "x" <> toRomanNumeral (x - 10)
| x == 9 = "ix"
| x >= 5 = "v" <> toRomanNumeral (x - 5)
| x == 4 = "iv"
| x >= 1 = "i" <> toRomanNumeral (x - 1)
| x == 0 = ""
| otherwise = T.pack (show x)
-- Gets variable while updating var count.
askVariable :: CiteprocOutput a => Variable -> Eval a (Maybe (Val a))
askVariable "page-first" = do
res <- askVariable "page"
case res of
Just (TextVal t) ->
return $ Just $ TextVal $ T.takeWhile (not . isSepPunct) t
Just (FancyVal x) ->
return $ Just $ TextVal $ T.takeWhile (not . isSepPunct) $ toText x
Just (NumVal n) -> return $ Just $ NumVal n
_ -> return Nothing
askVariable v = do
ref <- gets stateReference
case lookupVariable v ref of
Just x | isNonEmpty x && x /= SubstitutedVal -> do
updateVarCount 1 1
return $ Just x
_ -> do
updateVarCount 1 0
return Nothing
isNonEmpty :: CiteprocOutput a => Val a -> Bool
isNonEmpty (TextVal t) = not (T.null t)
isNonEmpty (FancyVal x) = x /= mempty
isNonEmpty (NamesVal []) = False
isNonEmpty (DateVal (Date [] _ Nothing Nothing)) = False
isNonEmpty _ = True
citationLabel :: Reference a -> Val a
citationLabel ref = TextVal trigraph
where
trigraph = namepart <> datepart
datepart = case M.lookup "issued" varmap of
Just (DateVal d) -> getYear d
_ -> ""
namepart = if "author" `elem` namevars
then getNames "author"
else case namevars of
(n:_) -> getNames n
_ -> "Xyz"
varmap = referenceVariables ref
vars = M.keys varmap
namevars = [v | v <- vars, variableType v == NameVariable]
getNames var = case M.lookup var varmap of
Just (NamesVal ns) ->
let x = case length ns of
1 -> 4
n | n >= 4 -> 1
| otherwise -> 2
in mconcat $
map (T.take x . fromMaybe "" . nameFamily)
(take 4 ns)
_ -> ""
getYear d = case dateParts d of
(DateParts (x:_):_) ->
T.pack (printf "%02d" $ x `mod` 100)
_ -> ""
removeDoubleSpaces :: Text -> Text
removeDoubleSpaces = T.replace " " " "
endsWithSpace :: Text -> Bool
endsWithSpace t = not (T.null t) && isSpace (T.last t)
beginsWithSpace :: Text -> Bool
beginsWithSpace t = not (T.null t) && isSpace (T.head t)