citeproc 0.13.0.1 → 0.14
raw patch · 13 files changed
+740/−169 lines, 13 filesdep ~pandoc-typesPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: pandoc-types
API changes (from Hackage documentation)
- Citeproc.Types: instance GHC.Classes.Ord Citeproc.Types.Term
+ Citeproc.Types: isEmpty :: CiteprocOutput a => a -> Bool
+ Citeproc.Types: termMatches :: Term -> Term -> Bool
Files
- CHANGELOG.md +63/−0
- bench/Bench.hs +145/−0
- cabal.project +0/−5
- citeproc.cabal +29/−5
- src/Citeproc/CslJson.hs +11/−5
- src/Citeproc/Element.hs +10/−3
- src/Citeproc/Eval.hs +257/−98
- src/Citeproc/Pandoc.hs +42/−20
- src/Citeproc/Types.hs +18/−16
- stack.yaml +0/−9
- test/Spec.hs +0/−8
- test/Unit.hs +114/−0
- test/extra/name_InitializeTurkishDotlessI.txt +51/−0
CHANGELOG.md view
@@ -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,
+ bench/Bench.hs view
@@ -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+ [ "<style xmlns=\"http://purl.org/net/xbiblio/csl\" class=\"in-text\" version=\"1.0\">"+ , " <info> <id/> <title/> <updated>2020-01-01T00:00:00Z</updated> </info>"+ , " <citation disambiguate-add-names=\"true\""+ , " disambiguate-add-givenname=\"true\""+ , " disambiguate-add-year-suffix=\"true\""+ , if collapse then " collapse=\"year\"" else ""+ , " et-al-min=\"3\" et-al-use-first=\"1\">"+ , " <layout prefix=\"(\" suffix=\")\" delimiter=\"; \">"+ , " <group delimiter=\" \">"+ , " <names variable=\"author\">"+ , " <name form=\"short\" and=\"symbol\"/>"+ , " </names>"+ , " <date variable=\"issued\" form=\"numeric\" date-parts=\"year\"/>"+ , " <choose>"+ , " <if disambiguate=\"true\">"+ , " <text value=\"[d]\"/>"+ , " </if>"+ , " </choose>"+ , " </group>"+ , " </layout>"+ , " </citation>"+ , "</style>"+ ]
− cabal.project
@@ -1,5 +0,0 @@-packages: citeproc.cabal--package citeproc- flags: -icu +executable-
citeproc.cabal view
@@ -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
src/Citeproc/CslJson.hs view
@@ -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)
src/Citeproc/Element.hs view
@@ -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. <term name="and others">+ -- </term> in a pretty-printed style) defines an empty term;+ -- but leading/trailing whitespace in an otherwise nonempty term+ -- is significant (e.g. <term name="ad"> AD</term>).+ 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
src/Citeproc/Eval.hs view
@@ -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
src/Citeproc/Pandoc.hs view
@@ -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:
src/Citeproc/Types.hs view
@@ -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
− stack.yaml
@@ -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
test/Spec.hs view
@@ -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",
+ test/Unit.hs view
@@ -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 "<b>One <b>Two <b>Three</b></b></b>",+ [fmt "bold" [String "One ",+ fmt "no-bold" [String "Two ",+ fmt "bold" [String "Three"]]]])+ , ("cslJsonToJson: bold state unaffected by italic context",+ jsonOf "<i>One <b>Two</b></i>",+ [fmt "italics" [String "One ", fmt "bold" [String "Two"]]])+ , ("cslJsonToJson: italics flip-flop in nested italics",+ jsonOf "<i>One <i>Two <i>Three</i></i></i>",+ [fmt "italics" [String "One ",+ fmt "no-italics" [String "Two ",+ fmt "italics" [String "Three"]]]])+ , ("cslJsonToJson: small-caps flip-flop in nested small-caps",+ jsonOf "<span style=\"font-variant:small-caps;\">One \+ \<span style=\"font-variant:small-caps;\">Two \+ \<span style=\"font-variant:small-caps;\">Three\+ \</span></span></span>",+ [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")+ ]
+ test/extra/name_InitializeTurkishDotlessI.txt view
@@ -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 =====>>+<style+ xmlns="http://purl.org/net/xbiblio/csl"+ class="in-text"+ version="1.0"+ default-locale="tr-TR">+ <info>+ <id />+ <title />+ <updated>2009-08-10T04:49:00+09:00</updated>+ </info>+ <citation>+ <layout>+ <names variable="author">+ <name initialize-with=". "/>+ </names>+ </layout>+ </citation>+</style>+<<===== CSL =====<<++>>===== INPUT =====>>+[+ {+ "id": "ITEM-1",+ "author": [+ {+ "family": "Yılmaz",+ "given": "MIsak"+ }+ ],+ "type": "book"+ }+]+<<===== INPUT =====<<++>>===== VERSION =====>>+1.0+<<===== VERSION =====<<