diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,68 @@
# citeproc changelog
+## 0.14
+
+ * [API change] Replace unlawful Ord Term instance with `termMatches`.
+ The old instance violated the Ord laws. It was only used for term
+ matching in lookupTerm, so we now export a function `termMatches`
+ for that purpose.
+
+ * [API change] Add `isEmpty` to CiteprocOutput class.
+ This allows us to avoid rendering to Text just to check for
+ emptiness.
+
+ * Fix flip-flop state bugs in `cslJsonToJson`.
+
+ * Fix end-trimming bugs in the pandoc backend's `dropTextWhileEnd'`.
+
+ * Fix EDTF year 0000 (1 BC) rendering as an open date range.
+ EDTF uses astronomical year numbering, in which 0000 means 1 BC, but
+ the parser passed year 0 through unchanged, colliding with the internal
+ year-0 sentinel for the empty side of an open date range; a 1 BC date
+ therefore rendered as nothing.
+
+ * Fix `punctuationInsideQuotes` missing nested quoted content.
+
+ * Remove empty Str elemnets left behind by Pandoc inline trimming.
+
+ * Fix `showYearSuffix` overflow past "zz".
+
+ * Use locale-aware lowercasing in `initialize`.
+
+ * Make `removeDoubleSpaces` collapse all space runs.
+
+ * Add some benchmarks for disambiguation and collapsing.
+
+ * Make disambiguation re-render only affected citations.
+
+ * Avoid repeated traversals in citation grouping.
+
+ * Cache reference lang so we don't reparse it all the time.
+
+ * Simplify `endWithPunct`.
+
+ * Only apply `after-inverted-name` delimiter after actually inverted names.
+ Fixes `test/csl/name_DelimiterAfterInverted.txt`.
+
+ * Compare rendered names in subsequent-author-substitute.
+ Fixes `fullstyles_ChicagoAuthorDateSimple.txt`, `sort_ChicagoYearSuffix1.txt`,
+ and `sort_ChicagoYearSuffix2.txt`.
+
+ * Treat whitespace-only term definitions as empty.
+ Fixes `test/csl/label_EditorTranslator1.txt`.
+
+ * Suppress date variables rendered via `cs:substitute`.
+ Improves `test/csl/bugreports_LegislationCrash.txt`, which
+ however still is an expected failure because of a spurious
+ space in the expected output.
+
+ * Drop cites that render empty after collapsing.
+ Fixes `test/csl/collapse_AuthorCollapseNoDateSorted.txt`.
+
+ * Include non-dropping particle when grouping names for disambiguation.
+ Fixes `test/csl/disambiguate_PrimaryNameWithParticle.txt` and
+ `test/csl/disambiguate_PrimaryNameWithNonDroppingParticle.txt`.
+
## 0.13.0.1
* Detect terminal punctuation hidden by closing quotes (#179,
diff --git a/bench/Bench.hs b/bench/Bench.hs
new file mode 100644
--- /dev/null
+++ b/bench/Bench.hs
@@ -0,0 +1,145 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Benchmark for citation processing dominated by disambiguation.
+-- Generates n synthetic references, cites them all in clusters of
+-- three, and times 'citeproc', in two scenarios:
+--
+-- * dense: every reference's authors and years collide heavily (so
+-- that add-names, add-givenname, and year-suffix disambiguation all
+-- kick in); reference data repeats with period 24, so every
+-- reference has many exact duplicates.
+--
+-- * sparse: only every 20th reference collides; the rest have unique
+-- authors. This is the realistic case for large bibliographies.
+--
+-- * collapse: the style has collapse="year" and the citation clusters
+-- have 100 items each, to exercise the cite grouping/collapsing
+-- code; authors are unique so that disambiguation stays quiet (and
+-- grouping does all-pairs comparisons, its worst case).
+--
+-- Run with, e.g.:
+-- cabal bench --benchmark-options="800 1600 3200"
+module Main (main) where
+import Citeproc
+import Citeproc.CslJson (CslJson, renderCslJson)
+import Control.Exception (evaluate)
+import Control.Monad (forM_)
+import qualified Data.Aeson as Aeson
+import Data.Aeson (object, (.=))
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.Environment (getArgs)
+import System.Exit (exitFailure)
+import System.TimeIt (timeItT)
+import Text.Printf (printf)
+
+main :: IO ()
+main = do
+ args <- getArgs
+ let sizes = if null args then [800, 1600, 3200] else map read args
+ let getStyle collapse = do
+ parseResult <- parseStyle (\_ -> return "") (styleText collapse)
+ case parseResult of
+ Left err -> print err >> exitFailure
+ Right sty -> return (sty :: Style (CslJson Text))
+ style <- getStyle False
+ collapseStyle <- getStyle True
+ let scenarios = [ ("dense", const True, 3, style)
+ , ("sparse", \i -> i `mod` 20 == 0, 3, style)
+ , ("collapse", const False, 100, collapseStyle)
+ ] :: [(String, Int -> Bool, Int, Style (CslJson Text))]
+ forM_ scenarios $ \(scenario, collides, clusterSize, sty) ->
+ forM_ sizes $ \n -> do
+ refs <- either fail return $ mapM refFromValue
+ $ mkRefValues collides n
+ let result = citeproc defaultCiteprocOptions sty Nothing refs
+ (mkCitations clusterSize n)
+ (t, outlen) <- timeItT $ evaluate $ T.length $ T.concat
+ $ map (renderCslJson False mempty)
+ $ resultCitations result
+ printf "%-6s n = %5d %8.3f s (%d chars of output)\n"
+ scenario n t outlen
+
+refFromValue :: Aeson.Value -> Either String (Reference (CslJson Text))
+refFromValue v =
+ case Aeson.fromJSON v of
+ Aeson.Success r -> Right r
+ Aeson.Error e -> Left e
+
+mkRefValues :: (Int -> Bool) -> Int -> [Aeson.Value]
+mkRefValues collides n = map mkRef [1..n]
+ where
+ mkRef :: Int -> Aeson.Value
+ mkRef i = object
+ [ "id" .= itemName i
+ , "type" .= ("book" :: Text)
+ , "title" .= ("Title " <> T.pack (show i))
+ , "issued" .= object ["date-parts" .= [[2000 + i `mod` 4]]]
+ , "author" .=
+ if collides i
+ then map (mkAuthor i) [0 .. i `mod` 3]
+ else [object [ "family" .= ("Unique" <> T.pack (show i))
+ , "given" .= ("Author" :: Text) ]]
+ ]
+ mkAuthor i j = object
+ [ "family" .= families !! ((i + j) `mod` length families)
+ , "given" .= givens !! ((i + j) `mod` length givens)
+ ]
+ families, givens :: [Text]
+ families = ["Smith", "Jones", "Garcia", "Chen",
+ "Miller", "Davis", "Wilson", "Moore"]
+ givens = ["Alexandra", "Benjamin", "Catherine",
+ "Daniel", "Eleanor", "Frederick"]
+
+mkCitations :: Int -> Int -> [Citation (CslJson Text)]
+mkCitations clusterSize n = map mkCitation (chunksOf clusterSize [1..n])
+ where
+ chunksOf _ [] = []
+ chunksOf k xs = let (as, bs) = splitAt k xs in as : chunksOf k bs
+ mkCitation is = Citation
+ { citationId = Nothing
+ , citationResetPosition = False
+ , citationNoteNumber = Nothing
+ , citationPrefix = Nothing
+ , citationSuffix = Nothing
+ , citationItems = map mkItem is
+ }
+ mkItem i = CitationItem
+ { citationItemId = ItemId (itemName i)
+ , citationItemLabel = Nothing
+ , citationItemLocator = Nothing
+ , citationItemType = NormalCite
+ , citationItemPrefix = Nothing
+ , citationItemSuffix = Nothing
+ , citationItemData = Nothing
+ }
+
+itemName :: Int -> Text
+itemName i = "ref" <> T.pack (show i)
+
+-- An author-date style with every disambiguation strategy enabled
+-- (and, if the argument is True, collapse=\"year\").
+styleText :: Bool -> Text
+styleText collapse = T.unlines
+ [ ""
+ ]
diff --git a/cabal.project b/cabal.project
deleted file mode 100644
--- a/cabal.project
+++ /dev/null
@@ -1,5 +0,0 @@
-packages: citeproc.cabal
-
-package citeproc
- flags: -icu +executable
-
diff --git a/citeproc.cabal b/citeproc.cabal
--- a/citeproc.cabal
+++ b/citeproc.cabal
@@ -1,6 +1,6 @@
cabal-version: 2.2
name: citeproc
-version: 0.13.0.1
+version: 0.14
synopsis: Generates citations and bibliography from CSL styles.
description: citeproc parses CSL style files and uses them to
generate a list of formatted citations and bibliography
@@ -15,12 +15,10 @@
build-type: Simple
extra-doc-files: README.md
, CHANGELOG.md
-extra-source-files: stack.yaml
- cabal.project
- locales/*.xml
- locales/locales.json
man/citeproc.1.md
man/citeproc.1
+extra-source-files: locales/*.xml
+ locales/locales.json
test/NOTES.md
test/csl/*.txt
test/extra/*.txt
@@ -128,6 +126,32 @@
buildable: True
else
buildable: False
+
+test-suite unit
+ import: hie-options
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ main-is: Unit.hs
+ build-depends: base >= 4.8 && < 5
+ , citeproc
+ , pandoc-types
+ , aeson
+ , text
+ ghc-options: -Wall
+ default-language: Haskell2010
+
+benchmark bench
+ import: hie-options
+ type: exitcode-stdio-1.0
+ hs-source-dirs: bench
+ main-is: Bench.hs
+ build-depends: base >= 4.8 && < 5
+ , citeproc
+ , aeson
+ , text
+ , timeit
+ ghc-options: -Wall
+ default-language: Haskell2010
test-suite spec
import: hie-options
diff --git a/src/Citeproc/CslJson.hs b/src/Citeproc/CslJson.hs
--- a/src/Citeproc/CslJson.hs
+++ b/src/Citeproc/CslJson.hs
@@ -100,6 +100,12 @@
biplate = plateSelf
instance CiteprocOutput (CslJson Text) where
+ isEmpty = \x ->
+ case x of
+ CslEmpty -> True
+ CslText "" -> True
+ CslConcat y z -> isEmpty y && isEmpty z
+ _ -> False
toText = fold
fromText = \t -> if T.null t
then CslEmpty
@@ -337,11 +343,11 @@
| otherwise -> [ object
[ ("format", "no-italics")
, ("contents", toJSON $
- go ctx{ useItalics = False } x)
+ go ctx{ useItalics = True } x)
]
]
CslBold x
- | useItalics ctx -> [ object
+ | useBold ctx -> [ object
[ ("format", "bold")
, ("contents", toJSON $
go ctx{ useBold = False } x)
@@ -350,7 +356,7 @@
| otherwise -> [ object
[ ("format", "no-bold")
, ("contents", toJSON $
- go ctx{ useBold = False } x)
+ go ctx{ useBold = True } x)
]
]
CslUnderline x -> [ object
@@ -373,7 +379,7 @@
| otherwise -> [ object
[ ("format", "no-small-caps")
, ("contents", toJSON $
- go ctx{ useSmallCaps = False } x)
+ go ctx{ useSmallCaps = True } x)
]
]
CslSup x -> [ object
@@ -496,7 +502,7 @@
(CslConcat (CslText t) z) | startsWithMovable t
-> CslQuoted (go (x <> CslText (T.take 1 t))) <>
CslText (T.drop 1 t) <> z
- z -> CslQuoted x <> z
+ z -> CslQuoted (go x) <> z
CslConcat (CslConcat x y) z -> go (CslConcat x (CslConcat y z))
CslConcat x y -> go x <> go y
CslQuoted x -> CslQuoted (go x)
diff --git a/src/Citeproc/Element.hs b/src/Citeproc/Element.hs
--- a/src/Citeproc/Element.hs
+++ b/src/Citeproc/Element.hs
@@ -145,9 +145,16 @@
name <- case lookupAttribute "name" attr of
Just n -> return n
Nothing -> parseFailure "Text node has no name attribute"
- let single = mconcat $ map getTextContent $ getChildren "single" node
- let multiple = mconcat $ map getTextContent $ getChildren "multiple" node
- let txt = getTextContent node
+ -- Whitespace-only content (e.g.
+ -- in a pretty-printed style) defines an empty term;
+ -- but leading/trailing whitespace in an otherwise nonempty term
+ -- is significant (e.g. AD).
+ let unlessBlank t = if T.null (T.strip t) then mempty else t
+ let single = unlessBlank $ mconcat $ map getTextContent $
+ getChildren "single" node
+ let multiple = unlessBlank $ mconcat $ map getTextContent $
+ getChildren "multiple" node
+ let txt = unlessBlank $ getTextContent node
let form = case lookupAttribute "form" attr of
Just "short" -> Short
Just "verb" -> Verb
diff --git a/src/Citeproc/Eval.hs b/src/Citeproc/Eval.hs
--- a/src/Citeproc/Eval.hs
+++ b/src/Citeproc/Eval.hs
@@ -12,14 +12,14 @@
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 Safe (atMay, 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, (\\))
+ partition, sort, (\\))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Char (isSpace, isDigit, isUpper, isLower, isLetter,
@@ -72,6 +72,7 @@
, stateNoteMap :: M.Map Int (Set.Set ItemId) -- ids cited in note
, stateRefMap :: ReferenceMap a
, stateReference :: Reference a
+ , stateReferenceLang :: Maybe Lang
, stateUsedYearSuffix :: Bool
, stateUsedIdentifier :: Bool
-- ^ tracks whether an identifier (DOI,PMCID,PMID,URL) has yet been used
@@ -126,6 +127,7 @@
, stateNoteMap = mempty
, stateRefMap = refmap
, stateReference = Reference mempty mempty Nothing mempty
+ , stateReferenceLang = Nothing
, stateUsedYearSuffix = False
, stateUsedIdentifier = False
, stateUsedTitle = False
@@ -358,7 +360,12 @@
go y@(Tagged (TagNames _ _ ns) r) =
case (if null names then CompleteAll else rule) of
CompleteAll ->
- if ns == names && (not (null names) || r == raw)
+ -- Compare names as rendered, not name data: name lists that
+ -- differ in data can render identically (e.g. names
+ -- truncated by et-al, or a one-part family name vs. the
+ -- same name as a literal), and the substitution exists to
+ -- avoid exactly this kind of visible repetition.
+ if sameRenderedNames r
then Just $ replaceAll y
else Nothing
CompleteEach ->
@@ -374,6 +381,15 @@
num | num >= (1 :: Int) -> Just $ transform (replaceFirst 1) y
_ -> Nothing
go _ = Nothing
+ -- The rendered text of the individual names, in order (ignoring
+ -- the label and the "et al" marker).
+ renderedNames x = [outputToText o | Tagged (TagName _) o <- universe x]
+ sameRenderedNames r =
+ case (renderedNames raw, renderedNames r) of
+ -- no names rendered on either side (e.g. a substituted title):
+ -- compare the whole rendered output
+ ([], []) -> outputToText r == outputToText raw
+ (xs, ys) -> xs == ys
replaceAll (Tagged (TagNames t' nf ns') x)
= Tagged (TagNames t' nf ns') $
-- removeName will leave label "ed."
@@ -388,6 +404,7 @@
_ -> Literal replacement
replaceAll x = x
removeName (Tagged (TagName _) _) = NullOutput
+ removeName (Tagged (TagTerm _) _) = NullOutput -- the "et al" marker
removeName x = x
replaceEach (Tagged (TagName n) _)
| n `elem` names
@@ -416,6 +433,23 @@
, ddRendered :: Text
} deriving (Eq, Ord, Show)
+-- | Position-tracking state ('stateLastCitedMap', 'stateNoteMap') in
+-- effect just before a citation is rendered.
+type PositionState =
+ ( M.Map ItemId (Int, Maybe Int, Int, Bool, Maybe Text, Maybe Text)
+ , M.Map Int (Set.Set ItemId) )
+
+-- | A rendered citation, together with the position-tracking state in
+-- effect just before it was rendered (which allows re-rendering it in
+-- isolation) and the disambiguation-relevant data extracted from the
+-- rendering (lazily, so it is only computed when needed).
+data RenderedCitation a =
+ RenderedCitation
+ { rcPositionState :: PositionState
+ , rcOutput :: Output a
+ , rcDisambData :: [DisambData]
+ }
+
disambiguateCitations :: forall a . CiteprocOutput a
=> Style a
-> M.Map ItemId [SortKeyValue]
@@ -424,11 +458,13 @@
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
+ -- we add "ghost" citations for EVERY reference in the database,
+ -- even those we have already cited, to handle cases like #116.
+ -- Each ghost is a separate citation so that it can be re-rendered
+ -- individually when its reference's disambiguation data changes.
+ let ghostCitations =
+ [ Citation Nothing False Nothing Nothing Nothing [basicItem ident]
+ | ident <- refIds ]
-- for purposes of disambiguation, we remove prefixes and
-- suffixes and locators, and we convert author-in-text to normal citation.
@@ -446,15 +482,14 @@
-- 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 False Nothing Nothing Nothing (map basicItem ghostItems)]
- allCites <- renderCitations citations'
+ let citations' = map cleanCitation citations ++ ghostCitations
+ allCites <- renderAll citations'
mblang <- asks (localeLanguage . contextLocale)
styleOpts <- asks contextStyleOptions
let strategy = styleDisambiguation styleOpts
let allNameGroups = [ns | Tagged (TagNames _ _ ns) _ <-
- concatMap universe allCites]
+ concatMap (universe . rcOutput) allCites]
let allNames = nubOrd $ concat allNameGroups
let primaryNames = nubOrd $ concatMap (take 1) allNameGroups
allCites' <-
@@ -467,10 +502,16 @@
PrimaryNameWithInitials -> primaryNames
PrimaryName -> primaryNames
_ -> allNames
- let familyNames = nubOrd $ mapMaybe nameFamily relevantNames
+ -- The short form of a name includes the non-dropping
+ -- particle, so e.g. "dos Santos" and "Santos" are not
+ -- ambiguous with each other. See
+ -- disambiguate_PrimaryNameWithNonDroppingParticle.txt.
+ let shortName v = (nameNonDroppingParticle v, nameFamily v)
+ let familyNames = nubOrd [shortName v | v <- relevantNames
+ , isJust (nameFamily v)]
let grps = map (\name ->
[v | v <- relevantNames
- , nameFamily v == Just name])
+ , shortName v == name])
familyNames
let toHint names name =
if any (initialsMatch mblang name) (filter (/= name) names)
@@ -504,53 +545,118 @@
(unReferenceMap $ stateRefMap st)
refIds }
-- redo citations
- renderCitations citations'
+ renderAll citations'
- case getAmbiguities allCites' of
+ disambStates <- getDisambStates
+ case groupAmbiguities (concatMap rcDisambData allCites') of
[] -> return ()
- ambiguities -> analyzeAmbiguities mblang strategy citations' ambiguities
+ ambiguities -> analyzeAmbiguities mblang strategy citations' allCites'
+ disambStates ambiguities
renderCitations citations
where
renderCitations :: [Citation a] -> Eval a [Output a]
- renderCitations cs =
+ renderCitations cs = map rcOutput <$> renderAll cs
+
+ renderedCitation :: PositionState -> Output a -> RenderedCitation a
+ renderedCitation posState result =
+ RenderedCitation posState result
+ (map toDisambData (extractTagItems [result]))
+
+ -- Render citations, capturing for each one the position-tracking
+ -- state in effect just before it is rendered. This state depends
+ -- only on the citation structure, which never changes during
+ -- disambiguation, so a captured snapshot allows the citation to be
+ -- re-rendered individually in a later pass (see refreshCitations).
+ renderAll :: [Citation a] -> Eval a [RenderedCitation a]
+ renderAll cs =
withRWST (\ctx st -> (ctx,
st { stateLastCitedMap = mempty
, stateNoteMap = mempty })) $
- mapM (evalLayout (styleCitation style)) (zip [1..] cs)
+ mapM (\(num, citation) -> do
+ posState <- gets $ \st -> (stateLastCitedMap st,
+ stateNoteMap st)
+ result <- evalLayout (styleCitation style) (num, citation)
+ return $ renderedCitation posState result)
+ (zip [1..] cs)
- refreshAmbiguities :: [Citation a] -> Eval a [[DisambData]]
- refreshAmbiguities = fmap getAmbiguities . renderCitations
+ -- referenceDisambiguation for each reference; a change in these is
+ -- the only thing that can alter how a citation is rendered from one
+ -- disambiguation pass to the next.
+ getDisambStates :: Eval a (M.Map ItemId (Maybe DisambiguationData))
+ getDisambStates =
+ gets (M.map referenceDisambiguation . unReferenceMap . stateRefMap)
+ -- Re-render only the citations containing an item whose
+ -- disambiguation data changed since the last rendering (whose
+ -- disambiguation states are given by prevDisambs); for the rest,
+ -- reuse the cached rendering.
+ refreshCitations :: [Citation a]
+ -> [RenderedCitation a]
+ -> M.Map ItemId (Maybe DisambiguationData)
+ -> Eval a ([RenderedCitation a],
+ M.Map ItemId (Maybe DisambiguationData))
+ refreshCitations cs rendered prevDisambs = do
+ newDisambs <- getDisambStates
+ let changed = M.keysSet $
+ M.differenceWith
+ (\new old -> if new == old then Nothing else Just new)
+ newDisambs prevDisambs
+ let isAffected = any ((`Set.member` changed) . citationItemId)
+ . citationItems
+ let rerender (num, citation, cached)
+ | isAffected citation = do
+ let posState@(lastCited, noteMap) = rcPositionState cached
+ result <- withRWST
+ (\ctx st -> (ctx, st{ stateLastCitedMap = lastCited
+ , stateNoteMap = noteMap })) $
+ evalLayout (styleCitation style) (num, citation)
+ return $ renderedCitation posState result
+ | otherwise = return cached
+ rendered' <- mapM rerender (zip3 [1..] cs rendered)
+ return (rendered', newDisambs)
+
+ refreshAmbiguities :: [Citation a]
+ -> [RenderedCitation a]
+ -> M.Map ItemId (Maybe DisambiguationData)
+ -> Eval a ([[DisambData]],
+ [RenderedCitation a],
+ M.Map ItemId (Maybe DisambiguationData))
+ refreshAmbiguities cs rendered prevDisambs = do
+ (rendered', disambs') <- refreshCitations cs rendered prevDisambs
+ return (groupAmbiguities (concatMap rcDisambData rendered'),
+ rendered', disambs')
+
analyzeAmbiguities :: Maybe Lang
-> DisambiguationStrategy
-> [Citation a]
+ -> [RenderedCitation a]
+ -> M.Map ItemId (Maybe DisambiguationData)
-> [[DisambData]]
-> Eval a ()
- analyzeAmbiguities mblang strategy cs ambiguities = do
+ analyzeAmbiguities mblang strategy cs rendered0 disambs0 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
+ (as1, rendered1, disambs1) <-
+ if not (null ambiguities) && disambiguateAddNames strategy
+ then do
+ mapM_ (tryAddNames mblang (disambiguateAddGivenNames strategy))
+ ambiguities
+ refreshAmbiguities cs rendered0 disambs0
+ else return (ambiguities, rendered0, disambs0)
+ (as2, rendered2, disambs2) <-
+ case disambiguateAddGivenNames strategy of
+ Just ByCite | not (null as1) -> do
+ mapM_ (tryAddGivenNames mblang) as1
+ refreshAmbiguities cs rendered1 disambs1
+ _ -> return (as1, rendered1, disambs1)
+ (as3, _, _) <-
+ if not (null as2) && disambiguateAddYearSuffix strategy
+ then do
+ addYearSuffixes bibSortKeyMap as2
+ refreshAmbiguities cs rendered2 disambs2
+ else return (as2, rendered2, disambs2)
+ mapM_ tryDisambiguateCondition as3
basicItem :: ItemId -> CitationItem a
basicItem iid = CitationItem
@@ -690,7 +796,9 @@
addNameHint mblang names (item, name) = do
let familyMatches = [n | n <- names
, n /= name
- , nameFamily n == nameFamily name]
+ , nameFamily n == nameFamily name
+ , nameNonDroppingParticle n ==
+ nameNonDroppingParticle name]
case familyMatches of
[] -> return Nothing
_ -> do
@@ -729,8 +837,8 @@
(alterReferenceDisambiguation
(\d -> d{ disambCondition = x }))
-getAmbiguities :: CiteprocOutput a => [Output a] -> [[DisambData]]
-getAmbiguities =
+groupAmbiguities :: [DisambData] -> [[DisambData]]
+groupAmbiguities =
mapMaybe
(\zs ->
case zs of
@@ -744,8 +852,6 @@
_ -> Nothing)
. groupBy (\x y -> ddRendered x == ddRendered y)
. sortOn ddRendered
- . map toDisambData
- . extractTagItems
extractTagItems :: [Output a] -> [(ItemId, Output a)]
extractTagItems xs =
@@ -784,6 +890,19 @@
-- Grouping and collapsing
--
+-- | A rendered citation item, annotated with precomputed properties
+-- that grouping consults repeatedly (so that they are not recomputed
+-- once per pair of items): whether the item has a prefix or suffix,
+-- and the names (or date) used to determine whether two items can be
+-- grouped ('extractTagged').
+data GroupingItem a =
+ GroupingItem
+ { giOutput :: Output a
+ , giHasPrefix :: Bool
+ , giHasSuffix :: Bool
+ , giTagged :: Maybe (Output a)
+ }
+
groupAndCollapseCitations :: forall a . CiteprocOutput a
=> Text
-> Maybe Text
@@ -800,30 +919,43 @@
(groupSuccessive isAdjacentCitationNumber xs)
Just collapseType ->
Formatted f{ formatDelimiter = Nothing } $
- foldr (collapseGroup collapseType) [] (groupWith sameNames xs)
+ foldr (collapseGroup collapseType) [] groupedItems
Nothing ->
Formatted f $
map (Formatted mempty{ formatDelimiter = Just citeGroupDelim })
- (groupWith sameNames xs)
+ groupedItems
where
+ -- To avoid traversing each rendered item once per PAIR of items,
+ -- we annotate every item up front with the data the grouping
+ -- functions consult repeatedly (see 'GroupingItem').
+ groupedItems :: [[Output a]]
+ groupedItems = map (map giOutput) $ groupWith $ map annotate xs
+
+ annotate :: Output a -> GroupingItem a
+ annotate x = GroupingItem
+ { giOutput = x
+ , giHasPrefix = hasPrefix x
+ , giHasSuffix = hasSuffix x
+ , giTagged = extractTagged x
+ }
+
-- Note that we cannot assume we've sorted by name,
- -- so we can't just use Data.ListgroupBy. We also
+ -- so we can't just use Data.List.groupBy. 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
+ groupWith :: [GroupingItem a] -> [[GroupingItem a]]
+ groupWith [] = []
+ groupWith (z:zs)
+ | giHasSuffix z = [z] : groupWith zs
| otherwise = -- we allow a prefix on first item in collapsed group
case span hasNoPrefixOrSuffix zs of
- ([],ys) -> [z] : groupWith isMatched ys
+ ([],ys) -> [z] : groupWith ys
(ws,ys) ->
- (z : filter (isMatched z) ws) :
- groupWith isMatched (filter (not . isMatched z) ws ++ ys)
+ case partition (sameNames z) ws of
+ (matched, unmatched) ->
+ (z : matched) : groupWith (unmatched ++ ys)
- hasNoPrefixOrSuffix :: Output a -> Bool
- hasNoPrefixOrSuffix x = not (hasPrefix x) && not (hasSuffix x)
+ hasNoPrefixOrSuffix :: GroupingItem a -> Bool
+ hasNoPrefixOrSuffix x = not (giHasPrefix x) && not (giHasSuffix x)
hasPrefix :: Output a -> Bool
hasPrefix x = not $ null [y | y@(Tagged TagPrefix _) <- universe x]
@@ -850,7 +982,14 @@
collapseGroup :: Collapsing -> [Output a] -> [Output a] -> [Output a]
collapseGroup _ [] zs = zs
collapseGroup collapseType (y:ys) zs =
- let ys' = y : map (transform removeNames) ys
+ -- After removing the names, a cite with no date renders empty
+ -- (e.g. a cite with no issued date under collapse="year");
+ -- drop it so we don't emit a stray delimiter. See
+ -- collapse_AuthorCollapseNoDateSorted.txt.
+ let removeNamesFromCite u =
+ let u' = transform removeNames u
+ in if outputToText u' == mempty then Nothing else Just u'
+ ys' = y : mapMaybe removeNamesFromCite ys
ws = collapseYearSuffix collapseType ys'
noCollapse = ws == y:ys
noYearSuffixCollapse = ws == ys'
@@ -956,9 +1095,9 @@
= n2 == n1 + 1
isAdjacentCitationNumber _ _ = False
- sameNames :: Output a -> Output a -> Bool
+ sameNames :: GroupingItem a -> GroupingItem a -> Bool
sameNames x y =
- case (extractTagged x, extractTagged y) of
+ case (giTagged x, giTagged y) of
(Just (Tagged (TagNames t1 _nf1 ns1) ws1),
Just (Tagged (TagNames t2 _nf2 ns2) ws2))
-> t1 == t2 && (if ns1 == ns2
@@ -1033,7 +1172,11 @@
newContext oldContext s =
(oldContext{ contextNameFormat = combineNameFormat
nameformat (contextNameFormat oldContext)},
- s{ stateReference = ref })
+ s{ stateReference = ref
+ , stateReferenceLang =
+ M.lookup "language" (referenceVariables ref) >>=
+ valToText >>= eitherToMaybe . parseLang
+ })
evalSortKey citeId (SortKeyVariable sortdir var) = do
refmap <- gets stateRefMap
SortKeyValue sortdir <$>
@@ -1244,6 +1387,9 @@
, contextPosition = position
},
st{ stateReference = ref
+ , stateReferenceLang =
+ M.lookup "language" (referenceVariables ref) >>=
+ valToText >>= eitherToMaybe . parseLang
, stateUsedYearSuffix = False
, stateUsedIdentifier = False
, stateUsedTitle = False
@@ -1440,8 +1586,7 @@
ENames vars namesFormat subst ->
(:[]) <$> eNames vars namesFormat subst formatting
-withFormatting :: CiteprocOutput a
- => Formatting -> Eval a (Output a) -> Eval a (Output a)
+withFormatting :: 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
@@ -1449,13 +1594,7 @@
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
+ reflang <- gets stateReferenceLang
let mainLangIsEn Nothing = False
mainLangIsEn (Just l) = langLanguage l == "en"
let isEnglish = case reflang of
@@ -1477,7 +1616,7 @@
case M.lookup (termName term') terms of
Just ts -> return $ [ (term'',t)
| (term'',t) <- ts
- , term' <= term''
+ , term' `termMatches` term''
]
Nothing -> return []
@@ -1844,6 +1983,7 @@
return NullOutput
| otherwise = do
datevar <- askVariable var
+ unless (isNothing datevar) $ deleteSubstitutedVariables [var]
localeDateElt <- M.lookup dateType <$> asks (localeDate . contextLocale)
let addOverride newdps olddp accum =
case find ((== dpName olddp) . dpName) newdps of
@@ -2223,6 +2363,15 @@
| numnames < x
, finalNameIsOthers -> Just (numnames - 1)
_ -> Nothing
+ -- Is the name at (1-based) index i rendered inverted (family name
+ -- first)? Only personal names can be inverted; literal names
+ -- cannot. See name_DelimiterAfterInverted.txt.
+ let nameIsInverted i = maybe False (isJust . nameFamily)
+ (atMay names (i - 1)) &&
+ case nameAsSortOrder nameFormat of
+ Just NameAsSortOrderAll -> True
+ Just NameAsSortOrderFirst -> i == 1
+ Nothing -> False
let beforeLastDelim =
case mbAndTerm of
Nothing -> delim
@@ -2233,11 +2382,8 @@
| numnames > 2 -> delim
| otherwise -> ""
PrecedesAfterInvertedName
- -> case nameAsSortOrder nameFormat of
- Just NameAsSortOrderAll -> delim
- Just NameAsSortOrderFirst
- | numnames < 3 -> delim
- _ -> ""
+ | nameIsInverted (numnames - 1) -> delim
+ | otherwise -> ""
PrecedesAlways -> delim
PrecedesNever -> ""
let andPreSpace = case beforeLastDelim of
@@ -2263,25 +2409,28 @@
, etAlThreshold > Just 1 -> delim
| otherwise -> etAlPreSpace
PrecedesAfterInvertedName
- -> case nameAsSortOrder nameFormat of
- Just NameAsSortOrderAll -> delim
- Just NameAsSortOrderFirst
- | etAlThreshold < Just 2 -> delim
- _ -> etAlPreSpace
+ -> case etAlThreshold of
+ Just t | nameIsInverted t -> delim
+ _ -> etAlPreSpace
PrecedesAlways -> delim
PrecedesNever -> etAlPreSpace
+ -- The "et al" marker is tagged so that subsequent-author-substitute
+ -- can identify and remove it (see 'replaceMatch').
+ let tagEtAl term = Tagged (TagTerm emptyTerm{ termName = term })
etAl <- case namesEtAl namesFormat of
- Just (term, f) -> withFormatting f{
+ Just (term, f) -> tagEtAl term <$>
+ (withFormatting f{
formatPrefix = removeDoubleSpaces <$>
Just beforeEtAl <> formatPrefix f } $
- lookupTerm' emptyTerm{ termName = term }
+ lookupTerm' emptyTerm{ termName = term })
Nothing
| etAlUseLast && not finalNameIsOthers ->
- return $
+ return $ tagEtAl "et-al" $
Formatted mempty{ formatPrefix = Just beforeEtAl }
[literal "\x2026 "] -- ellipses
| otherwise ->
- Formatted mempty{ formatPrefix = Just beforeEtAl }
+ tagEtAl "et-al"
+ . Formatted mempty{ formatPrefix = Just beforeEtAl }
. (:[]) <$> lookupTerm' emptyTerm{ termName = "et-al" }
let addNameAndDelim name idx
| etAlThreshold == Just 0 = NullOutput
@@ -2375,13 +2524,14 @@
literal :: CiteprocOutput a => Text -> Output a
literal = Literal . fromText
+-- 1 = a, 26 = z, 27 = aa, 702 = zz, 703 = aaa, ... (bijective base 26)
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))]
+showYearSuffix = T.pack . go ""
+ where
+ go s x
+ | x < 1 = s
+ | otherwise = let (q, r) = (x - 1) `divMod` 26
+ in go (chr (ord 'a' + r) : s) q
initialize :: Maybe Lang
-> Bool -- ^ initialize
@@ -2433,7 +2583,7 @@
| 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 <> Unicode.toLower mblang (T.singleton d)
_ -> T.singleton c
_ -> t
initializeWord (Left t) -- Left values already initialized
@@ -2829,12 +2979,21 @@
T.pack (printf "%02d" $ x `mod` 100)
_ -> ""
+-- | Collapse each run of spaces to a single space.
removeDoubleSpaces :: Text -> Text
-removeDoubleSpaces = T.replace " " " "
+removeDoubleSpaces t =
+ let t' = T.replace " " " " t
+ in if t' == t
+ then t
+ else removeDoubleSpaces t'
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)
+
+eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe (Left _) = Nothing
+eitherToMaybe (Right x) = Just x
diff --git a/src/Citeproc/Pandoc.hs b/src/Citeproc/Pandoc.hs
--- a/src/Citeproc/Pandoc.hs
+++ b/src/Citeproc/Pandoc.hs
@@ -17,10 +17,10 @@
import Citeproc.CaseTransform
import Control.Monad.Trans.State.Strict as S
import Control.Monad (unless, when)
-import Data.Functor.Reverse
import Data.Char (isSpace, isPunctuation, isAlphaNum)
instance CiteprocOutput Inlines where
+ isEmpty = null
toText = stringify
fromText t = (if " " `T.isPrefixOf` t
then B.space
@@ -122,34 +122,33 @@
go (Span ("",["csl-quoted"],[]) xs : Str t : rest)
| startsWithMovable t
= Span ("",["csl-quoted"],[])
- (xs ++ [Str (T.take 1 t) | not (endWithPunct True xs)]) :
+ (xs ++ [Str (T.take 1 t) | not (endWithPunct xs)]) :
if T.length t == 1
then go rest
else Str (T.drop 1 t) : go rest
go (Quoted qt xs : Str t : rest)
| startsWithMovable t
= Quoted qt
- (xs ++ [Str (T.take 1 t) | not (endWithPunct True xs)]) :
+ (xs ++ [Str (T.take 1 t) | not (endWithPunct xs)]) :
if T.length t == 1
then go rest
else Str (T.drop 1 t) : go rest
go (x:xs) = x : go xs
-endWithPunct :: Bool -> [Inline] -> Bool
-endWithPunct _ [] = False
-endWithPunct onlyFinal xs@(_:_) =
- case reverse (T.unpack $ stringify xs) of
- [] -> True
- -- covers .), .", etc.:
- (d:c:_) | isPunctuation d
- && not onlyFinal
- && isEndPunct c -> True
- (c:_) | isEndPunct c -> True
- | otherwise -> False
- where isEndPunct c = c `elem` (".,;:!?" :: String)
+endWithPunct :: [Inline] -> Bool
+endWithPunct [] = False
+endWithPunct xs =
+ case T.unsnoc (stringify xs) of
+ Nothing -> True -- no text content
+ Just (_, c) -> c `elem` (".,;:!?" :: String)
+-- Trimming can reduce a Str, Space, or SoftBreak to an empty Str;
+-- remove these leftovers, at all nesting levels.
+removeEmptyStrs :: Inlines -> Inlines
+removeEmptyStrs = B.fromList . walk (filter (/= Str "")) . B.toList
+
dropTextWhile' :: (Char -> Bool) -> Inlines -> Inlines
-dropTextWhile' f ils = evalState (walkM go ils) True
+dropTextWhile' f ils = removeEmptyStrs $ evalState (walkM go ils) True
where
go x = do
atStart <- get
@@ -171,10 +170,17 @@
else return x
+-- The state records whether we are still at the end, i.e. have not
+-- yet encountered a character that shouldn't be dropped. We need an
+-- explicit traversal (rather than walkM over Reverse) so that the
+-- children of nested inlines are also processed from right to left.
dropTextWhileEnd' :: (Char -> Bool) -> Inlines -> Inlines
dropTextWhileEnd' f ils =
- getReverse $ evalState (walkM go $ Reverse ils) True
+ removeEmptyStrs $ evalState (fmap B.fromList . goList . B.toList $ ils) True
where
+ goList :: [Inline] -> State Bool [Inline]
+ goList = fmap reverse . mapM go . reverse
+ go :: Inline -> State Bool Inline
go x = do
atEnd <- get
if atEnd
@@ -185,9 +191,25 @@
unless (T.null t') $
put False
return $ Str t'
- _ | x == Space || x == SoftBreak
- , f ' ' -> return $ Str ""
- | otherwise -> return x
+ Space
+ | f ' ' -> return $ Str ""
+ | otherwise -> put False >> return x
+ SoftBreak
+ | f ' ' -> return $ Str ""
+ | otherwise -> put False >> return x
+ Emph xs -> Emph <$> goList xs
+ Underline xs -> Underline <$> goList xs
+ Strong xs -> Strong <$> goList xs
+ Strikeout xs -> Strikeout <$> goList xs
+ Superscript xs -> Superscript <$> goList xs
+ Subscript xs -> Subscript <$> goList xs
+ SmallCaps xs -> SmallCaps <$> goList xs
+ Quoted qt xs -> Quoted qt <$> goList xs
+ Cite cs xs -> Cite cs <$> goList xs
+ Span attr xs -> Span attr <$> goList xs
+ Link attr xs t -> (\xs' -> Link attr xs' t) <$> goList xs
+ Image attr xs t -> (\xs' -> Image attr xs' t) <$> goList xs
+ _ -> return x
else return x
-- taken from Text.Pandoc.Shared:
diff --git a/src/Citeproc/Types.hs b/src/Citeproc/Types.hs
--- a/src/Citeproc/Types.hs
+++ b/src/Citeproc/Types.hs
@@ -66,6 +66,7 @@
, TermNumber(..)
, TermForm(..)
, Term(..)
+ , termMatches
, emptyTerm
, SortDirection(..)
, SortKey(..)
@@ -199,6 +200,7 @@
-- that corresponds to the markup allowed in CSL JSON. See
-- the 'Citeproc.Pandoc' module for an instance for Pandoc 'Inlines'.
class (Semigroup a, Monoid a, Show a, Eq a, Ord a) => CiteprocOutput a where
+ isEmpty :: a -> Bool
toText :: a -> Text
fromText :: Text -> a
dropTextWhile :: (Char -> Bool) -> a -> a
@@ -219,7 +221,7 @@
addFormatting :: CiteprocOutput a => Locale -> Formatting -> a -> a
addFormatting locale f x =
- if T.null (toText x) -- TODO inefficient
+ if isEmpty x
then mempty
else
maybe id addDisplay (formatDisplay f) .
@@ -799,9 +801,12 @@
emptyTerm :: Term
emptyTerm = Term mempty Long Nothing Nothing Nothing Nothing
-instance Ord Term where
- (<=)(Term name1 form1 num1 gen1 gf1 match1)
- (Term name2 form2 num2 gen2 gf2 match2) =
+-- | True if the first term matches the second. Name and form must
+-- be identical; for the other attributes, a 'Nothing' on either side
+-- functions as a wildcard.
+termMatches :: Term -> Term -> Bool
+termMatches (Term name1 form1 num1 gen1 gf1 match1)
+ (Term name2 form2 num2 gen2 gf2 match2) =
name1 == name2 &&
form1 == form2 &&
(isNothing num1 || isNothing num2 || num1 == num2) &&
@@ -1437,31 +1442,28 @@
then return (True, T.drop 1 t')
else return (False, t')
let t''' = T.takeWhile (not . isSpecial) t''
+ let readYear y' = do
+ guard $ T.length y' == 4 || hasY && T.length y' >= 4
+ (if isNeg
+ then (\x -> (x * (-1)) - 1) -- EDTF -0001 = 2 BC
+ else (\x -> if x == 0 then -1 else x)) -- EDTF 0000 = 1 BC
+ <$> readAsInt y'
case T.split (=='-') t''' of
[""] -> return $ DateParts [0]
[y', m', d'] -> do
- guard $ T.length y' == 4 || hasY && T.length y' >= 4
guard $ T.length m' == 2
guard $ T.length d' == 2
- y <- (if isNeg
- then (\x -> (x * (-1)) - 1) -- 0 = 1 BC
- else id) <$> readAsInt y'
+ y <- readYear y'
m <- readAsInt m'
d <- readAsInt d'
return $ DateParts [y, m, d]
[y', m'] -> do
- guard $ T.length y' == 4 || hasY && T.length y' >= 4
guard $ T.length m' == 2
- y <- (if isNeg
- then (\x -> (x * (-1)) - 1) -- 0 = 1 BC
- else id) <$> readAsInt y'
+ y <- readYear y'
m <- readAsInt m'
return $ DateParts [y, m]
[y'] -> do
- guard $ T.length y' == 4 || hasY && T.length y' >= 4
- y <- (if isNeg
- then (\x -> (x * (-1)) - 1) -- 0 = 1 BC
- else id) <$> readAsInt y'
+ y <- readYear y'
return $ DateParts [y]
_ -> mzero
dps <- mapM dparts ranges
diff --git a/stack.yaml b/stack.yaml
deleted file mode 100644
--- a/stack.yaml
+++ /dev/null
@@ -1,9 +0,0 @@
-flags:
- citeproc:
- executable: true
- icu: false
-resolver: lts-23.0
-extra-deps:
-- Diff-1.0.2
-ghc-options:
- "$locals": -fhide-source-paths
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -393,7 +393,6 @@
"test/csl/bugreports_SmallCapsEscape.txt",
"test/csl/bugreports_SortedIeeeItalicsFail.txt",
"test/csl/bugreports_ikeyOne.txt",
- "test/csl/collapse_AuthorCollapseNoDateSorted.txt",
"test/csl/date_NegativeDateSort.txt",
"test/csl/date_NegativeDateSortViaMacro.txt",
"test/csl/date_NegativeDateSortViaMacroOnYearMonthOnly.txt",
@@ -403,8 +402,6 @@
"test/csl/disambiguate_DisambiguationHang.txt",
"test/csl/disambiguate_IncrementalExtraText.txt",
"test/csl/disambiguate_InitializeWithButNoDisambiguation.txt",
- "test/csl/disambiguate_PrimaryNameWithNonDroppingParticle.txt",
- "test/csl/disambiguate_PrimaryNameWithParticle.txt",
"test/csl/disambiguate_YearCollapseWithInstitution.txt",
"test/csl/disambiguate_YearSuffixAtTwoLevels.txt",
"test/csl/disambiguate_YearSuffixWithEtAlSubequent.txt",
@@ -412,16 +409,13 @@
"test/csl/flipflop_LeadingMarkupWithApostrophe.txt",
"test/csl/flipflop_OrphanQuote.txt",
"test/overrides/fullstyles_ABdNT.txt",
- "test/csl/fullstyles_ChicagoAuthorDateSimple.txt",
"test/csl/integration_FirstReferenceNoteNumberPositionChange.txt",
"test/csl/integration_IbidOnInsert.txt",
- "test/csl/label_EditorTranslator1.txt",
"test/csl/magic_CapitalizeFirstOccurringTerm.txt",
"test/csl/magic_PunctuationInQuoteNested.txt",
"test/csl/magic_SubsequentAuthorSubstituteNotFooled.txt",
"test/csl/magic_TermCapitalizationWithPrefix.txt",
"test/csl/name_CiteGroupDelimiterWithYearSuffixCollapse2.txt",
- "test/csl/name_DelimiterAfterInverted.txt",
"test/csl/name_EtAlWithCombined.txt",
"test/csl/name_HebrewAnd.txt",
"test/csl/name_InTextMarkupInitialize.txt",
@@ -441,8 +435,6 @@
"test/csl/sort_BibliographyCitationNumberDescending.txt",
"test/csl/sort_BibliographyCitationNumberDescendingViaCompositeMacro.txt",
"test/csl/sort_BibliographyCitationNumberDescendingViaMacro.txt",
- "test/csl/sort_ChicagoYearSuffix1.txt",
- "test/csl/sort_ChicagoYearSuffix2.txt",
"test/csl/sort_LeadingApostropheOnNameParticle.txt",
"test/csl/sort_OmittedBibRefMixedNumericStyle.txt",
"test/csl/sort_OmittedBibRefNonNumericStyle.txt",
diff --git a/test/Unit.hs b/test/Unit.hs
new file mode 100644
--- /dev/null
+++ b/test/Unit.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Unit tests for backend functions not covered by the file-based
+-- CSL test suite (which only exercises the CslJson backend's HTML
+-- rendering).
+module Main (main) where
+import Citeproc.Types (CiteprocOutput(..))
+import Citeproc.CslJson (CslJson(..), cslJsonToJson, parseCslJson)
+import Citeproc.Pandoc ()
+import Text.Pandoc.Builder
+import Data.Aeson (Value(..), object, toJSON)
+import Data.Text (Text)
+import Data.Maybe (mapMaybe)
+import System.Exit (exitFailure, exitSuccess)
+import Text.Printf (printf)
+
+main :: IO ()
+main = do
+ let failures = mapMaybe check inlineCases ++ mapMaybe check jsonCases
+ ++ mapMaybe check quoteCases
+ let total = length inlineCases + length jsonCases + length quoteCases
+ mapM_ report failures
+ printf "%d of %d unit tests passed.\n" (total - length failures) total
+ if null failures
+ then exitSuccess
+ else exitFailure
+ where
+ check (name, actual, expected)
+ | actual == expected = Nothing
+ | otherwise = Just (name, show expected, show actual)
+ report (name, expected, actual) = do
+ putStrLn $ "[FAILED] " <> name
+ putStrLn $ " expected: " <> expected
+ putStrLn $ " actual: " <> actual
+
+-- dropTextWhile/dropTextWhileEnd on pandoc Inlines:
+inlineCases :: [(String, Inlines, Inlines)]
+inlineCases =
+ -- dropTextWhileEnd must trim from the *last* Str of a trailing
+ -- nested inline, not the first:
+ [ ("dropTextWhileEnd: trims last Str inside trailing nested inline",
+ dropTextWhileEnd (== '.') (fromList [Emph [Str "a.", Str "b."]]),
+ fromList [Emph [Str "a.", Str "b"]])
+ -- a Space that doesn't match the predicate must stop the trimming:
+ , ("dropTextWhileEnd: stops at non-matching Space",
+ dropTextWhileEnd (== '.') (fromList [Str "etc.", Space, Str "."]),
+ fromList [Str "etc.", Space])
+ -- as long as everything so far has been dropped, trimming continues
+ -- past nesting boundaries:
+ , ("dropTextWhileEnd: continues across nesting while dropping",
+ dropTextWhileEnd (== '.') (fromList [Emph [Str "a.", Str "."], Str "."]),
+ fromList [Emph [Str "a"]])
+ -- trailing space trimming (the trimR use case in Citeproc.hs):
+ , ("dropTextWhileEnd: drops a trailing Space",
+ dropTextWhileEnd (== ' ') (fromList [Str "hi", Space]),
+ fromList [Str "hi"])
+ , ("dropTextWhileEnd: single Str inside trailing nested inline",
+ dropTextWhileEnd (== '.') (fromList [Str "x ", Emph [Str "Title."]]),
+ fromList [Str "x ", Emph [Str "Title"]])
+ -- fully-dropped Strs and Spaces leave no empty Strs behind:
+ , ("dropTextWhile: drops a leading Str and Space entirely",
+ dropTextWhile (== '.') (fromList [Str ".", Str ".a"]),
+ fromList [Str "a"])
+ , ("dropTextWhile: drops a leading Space",
+ dropTextWhile (== ' ') (fromList [Space, Str "hi"]),
+ fromList [Str "hi"])
+ ]
+
+-- flip-flop formatting state in cslJsonToJson's JSON output:
+jsonCases :: [(String, [Value], [Value])]
+jsonCases =
+ [ ("cslJsonToJson: bold flip-flops in nested bold",
+ jsonOf "One Two Three",
+ [fmt "bold" [String "One ",
+ fmt "no-bold" [String "Two ",
+ fmt "bold" [String "Three"]]]])
+ , ("cslJsonToJson: bold state unaffected by italic context",
+ jsonOf "One Two",
+ [fmt "italics" [String "One ", fmt "bold" [String "Two"]]])
+ , ("cslJsonToJson: italics flip-flop in nested italics",
+ jsonOf "One Two Three",
+ [fmt "italics" [String "One ",
+ fmt "no-italics" [String "Two ",
+ fmt "italics" [String "Three"]]]])
+ , ("cslJsonToJson: small-caps flip-flop in nested small-caps",
+ jsonOf "One \
+ \Two \
+ \Three\
+ \",
+ [fmt "small-caps" [String "One ",
+ fmt "no-small-caps" [String "Two ",
+ fmt "small-caps" [String "Three"]]]])
+ ]
+ where
+ jsonOf = cslJsonToJson . parseCslJson mempty
+ fmt :: Text -> [Value] -> Value
+ fmt f xs = object [("format", String f), ("contents", toJSON xs)]
+
+-- punctuation moving (punctuation-in-quote) on the CslJson backend:
+quoteCases :: [(String, CslJson Text, CslJson Text)]
+quoteCases =
+ -- the basic case: movable punctuation after a quoted span moves inside:
+ [ ("punctuationInsideQuotes: moves comma following a quote inside",
+ movePunctuationInsideQuotes
+ (CslQuoted (CslText "Hi") <> CslText ", she said"),
+ CslQuoted (CslText "Hi" <> CslText ",") <> CslText " she said")
+ -- when the text after a quoted span starts with something unmovable,
+ -- punctuation moving must still be applied *inside* the quoted span:
+ , ("punctuationInsideQuotes: processes nested content of a quote",
+ movePunctuationInsideQuotes
+ (CslQuoted (CslQuoted (CslText "inner") <> CslText ", outer")
+ <> CslText " rest"),
+ CslQuoted (CslQuoted (CslText "inner" <> CslText ",") <> CslText " outer")
+ <> CslText " rest")
+ ]
diff --git a/test/extra/name_InitializeTurkishDotlessI.txt b/test/extra/name_InitializeTurkishDotlessI.txt
new file mode 100644
--- /dev/null
+++ b/test/extra/name_InitializeTurkishDotlessI.txt
@@ -0,0 +1,51 @@
+>>===== MODE =====>>
+citation
+<<===== MODE =====<<
+
+Initialization of a name like "MIsak" abbreviates to the first two
+letters (cf. name_LongAbbreviation), lowercasing the second. With a
+Turkish locale, "I" must lowercase to dotless "ı", not "i".
+
+>>===== RESULT =====>>
+Mı. Yılmaz
+<<===== RESULT =====<<
+
+>>===== CSL =====>>
+
+<<===== CSL =====<<
+
+>>===== INPUT =====>>
+[
+ {
+ "id": "ITEM-1",
+ "author": [
+ {
+ "family": "Yılmaz",
+ "given": "MIsak"
+ }
+ ],
+ "type": "book"
+ }
+]
+<<===== INPUT =====<<
+
+>>===== VERSION =====>>
+1.0
+<<===== VERSION =====<<