citeproc-hs 0.3.3 → 0.3.4
raw patch · 22 files changed
+695/−482 lines, 22 filesdep ~pandoc-types
Dependency ranges changed: pandoc-types
Files
- README +29/−19
- citeproc-hs.cabal +2/−2
- src/Text/CSL.hs +1/−0
- src/Text/CSL/Eval.hs +43/−88
- src/Text/CSL/Eval/Common.hs +2/−0
- src/Text/CSL/Eval/Date.hs +10/−9
- src/Text/CSL/Eval/Names.hs +38/−34
- src/Text/CSL/Eval/Output.hs +66/−1
- src/Text/CSL/Input/Bibutils.hs +14/−8
- src/Text/CSL/Input/Json.hs +18/−2
- src/Text/CSL/Input/MODS.hs +63/−44
- src/Text/CSL/Output/Pandoc.hs +37/−11
- src/Text/CSL/Output/Plain.hs +6/−1
- src/Text/CSL/Parser.hs +9/−7
- src/Text/CSL/Pickle.hs +1/−1
- src/Text/CSL/Proc.hs +56/−53
- src/Text/CSL/Proc/Collapse.hs +95/−29
- src/Text/CSL/Proc/Disamb.hs +85/−85
- src/Text/CSL/Reference.hs +62/−56
- src/Text/CSL/Style.hs +37/−23
- src/Text/CSL/Test.hs +11/−7
- test/test.hs +10/−2
README view
@@ -28,7 +28,7 @@ style, given a collection of references. Natively [citeproc-hs] can read [JSON][^1] and [MODS][^2] XML-formattted bibliographic databases.+formatted bibliographic databases. [bibutils] can be used to convert Bibtex and other bibliographic databases to [MODS] collections, which can be thus read by@@ -54,11 +54,7 @@ To get the darcs source run: - darcs get http://code.haskell.org/citeproc-hs/--**NOTE**: <http://code.haskell.org> is presently down. The darcs- repository may be accessed at:- <http://gorgias.mine.nu/repos/citeproc-hs/>+ darcs get http://gorgias.mine.nu/repos/citeproc-hs/ Installation ------------@@ -133,7 +129,7 @@ <http://hackage.haskell.org/package/citeproc-hs> -### Some notes about name parsing+### Name parsing The [MODS] parser has been optimized for bibtex input, especially for parsing names with affixes , dropping and non-dropping particles.@@ -159,6 +155,20 @@ <http://citationstyles.org/downloads/specification.html#name-particles> +### Date parsing++The [MODS] parser, which is used to read all bibliograhic databases+supported by [bibutils], tries to parse dates, including seasons+(expressed in English). An example of supported formats:++ 2010-01-31 (January 31, 2010)++ 2004-05 (May, 2004)++ 2001 (the year only)++ Summer, 2001 (the season)+ ### Running the test-suite To run the test suite, you first need to grab it with [mercurial] by@@ -178,11 +188,15 @@ runhaskell test/test.hs - You may also specify a test group: runhaskell test/test.hs date +or a single test in a group:++ runhaskell test/test.hs date IgnoreNonexistentSort++ To increase the debug messages edit *test/test.hs* and increase the *Int* parameter of *runTS*: @@ -191,21 +205,17 @@ Known Issues ------------ -[citeproc-hs] is in an early stage of development and the [CSL]-implementation is not complete.--Most of [CSL]-1.0 features are implemented. Some missing features are-meaningless in [pandoc], the main target of [citeproc-hs] at the-present time. Specifically the [display] attribute has not been-implemented yet.+The [CSL] implementation is mostly but not entirely complete. Some of+the missing features are meaningless in [pandoc], the main target of+[citeproc-hs] at the present time. Specifically the [display]+attribute has not been implemented yet. -The [citeproc-hs]-0.3.2 release passes 411 out of 537 tests of the+The [citeproc-hs]-0.3.4 release passes 483 out of 654 tests of the [citeproc-test] suite. The test-suite has been developed along with [citeproc-js], and the failure of some of those tests is not-meaningful for [citeproc-hs]. The major missing bits are related to-multi-language names.+meaningful for [citeproc-hs]. -The [MODS] parser needs some refinement too.+The [MODS] parser may need some refinement. Bug Reports -----------
citeproc-hs.cabal view
@@ -1,5 +1,5 @@ name: citeproc-hs-version: 0.3.3+version: 0.3.4 homepage: http://gorgias.mine.nu/repos/citeproc-hs/ synopsis: A Citation Style Language implementation in Haskell @@ -101,7 +101,7 @@ ghc-prof-options: -prof -auto-all hs-source-dirs: src build-depends: containers, directory, mtl, xml, json, utf8-string,- bytestring, filepath, pandoc-types >= 1.8 && < 1.9+ bytestring, filepath, pandoc-types >= 1.8 && < 1.10 if flag(bibutils) build-depends: hs-bibutils >= 0.3
src/Text/CSL.hs view
@@ -32,6 +32,7 @@ , readModsCollectionFile , readJsonInput , readJsonInputString+ , readJsonAbbrevFile -- ** Reference Representation , Reference (..)
src/Text/CSL/Eval.hs view
@@ -16,8 +16,7 @@ module Text.CSL.Eval ( evalLayout , evalSorting- , rtfParser- , last'+ , last', split, trim , module Text.CSL.Eval.Common , module Text.CSL.Eval.Output ) where@@ -26,6 +25,7 @@ import Control.Applicative ( (<$>) ) import Control.Monad.State import Data.Char+import qualified Data.Map as M import Data.Maybe import Text.CSL.Eval.Common@@ -36,15 +36,14 @@ import Text.CSL.Reference import Text.CSL.Style import Text.Pandoc.Definition-import Text.ParserCombinators.Parsec hiding ( State (..) ) -- | Produce the output with a 'Layout', the 'EvalMode', a 'Bool' -- 'True' if the evaluation happens for disambiguation purposes, the--- 'Locale', the 'MacrpMap', the position of the cite and the+-- 'Locale', the 'MacroMap', the position of the cite and the -- 'Reference'. evalLayout :: Layout -> EvalMode -> Bool -> [Locale] -> [MacroMap]- -> [Option] -> Reference -> [Output]-evalLayout (Layout _ _ es) em b l m o r+ -> [Option] -> [Abbrev] -> Reference -> [Output]+evalLayout (Layout _ _ es) em b l m o a r = cleanOutput evalOut where evalOut = case evalState job initSt of@@ -62,15 +61,16 @@ EvalSorting c -> c EvalBiblio s -> emptyCite { citePosition = s } initSt = EvalState (mkRefMap r) (Env cit (localeTermMap locale) m- (localeDate locale) o []) [] em b False [] [] False [] [] []+ (localeDate locale) o [] a) [] em b False [] [] False [] [] [] -evalSorting :: EvalMode -> [Locale] -> [MacroMap] -> [Option] -> [Sort] -> Reference -> [Sorting]-evalSorting m l ms opts ss r+evalSorting :: EvalMode -> [Locale] -> [MacroMap] -> [Option] ->+ [Sort] -> [Abbrev] -> Reference -> [Sorting]+evalSorting m l ms opts ss as r = map (format . sorting) ss where render = renderPlainStrict . formatOutputList format (s,e) = applaySort s . render $ uncurry eval e- eval o e = evalLayout (Layout emptyFormatting [] [e]) m False l ms o r+ eval o e = evalLayout (Layout emptyFormatting [] [e]) m False l ms o as r applaySort c s | Ascending {} <- c = Ascending s | otherwise = Descending s@@ -108,12 +108,18 @@ ifEmpty (evalNames False s n d) (withNames s el $ evalElements sub) (appendOutput fm)- | Substitute (e:els) <- el = ifEmpty (consuming $ evalElement e)+ | Substitute (e:els) <- el = ifEmpty (consuming $ substituteWith e) (getFirst els) id | ShortNames s fm d <- el = head <$> gets (names . env) >>= \(Names _ ns fm' d' _) -> appendOutput fm' <$> evalNames False s (updateNameParts d fm ns) d' | otherwise = return [] where+ substituteWith e = head <$> gets (names . env) >>= \(Names _ ns fm d _) -> do+ case e of+ Names rs [Name NotSet _ [] [] []] fm' d' []+ -> evalElement $ Names rs ns (mergeFM fm' fm) (d' `betterThen` d) []+ _ -> evalElement e+ updateNameParts d fm (Name f fm' nf d' np : xs) = Name f (mergeFM fm' fm) nf (d `betterThen` d') np : xs updateNameParts d fm (x : xs) = x : updateNameParts d fm xs updateNameParts _ _ [] = []@@ -140,14 +146,16 @@ (getFirst xs) getMacro s = maybe [] id . lookup s <$> gets (macros . env)- getVariable f fm s = case s of+ getVariable f fm s = case (map toLower s) of "year-suffix" -> getStringVar "ref-id" >>= \k -> return . return $ OYearSuf [] k [] fm "page" -> getStringVar "page" >>= formatRange fm "title" -> formatTitle f fm "locator" -> getLocVar >>= formatRange fm . snd- _ -> gets (options . env) >>= \opts ->- getVar [] (getFormattedValue opts f fm) s >>= \r ->+ "url" -> getStringVar "url" >>= \k ->+ if null k then return [] else return [OUrl k fm]+ _ -> gets (env >>> options &&& abbrevs) >>= \(opts,as) ->+ getVar [] (getFormattedValue opts as f fm s) s >>= \r -> consumeVariable s >> return r evalIfThen :: IfThen -> [IfThen] -> [Element] -> State EvalState [Output]@@ -178,7 +186,6 @@ chkType t = let chk = (==) (formatVariable t) . show . fromMaybe NoType . fromValue in getVar False chk "ref-type"- numericVars = ["edition", "volume", "number-of-volumes", "number", "issue", "citation-number"] chkNumeric v = do val <- getStringVar v return (v `elem` numericVars && or (map isDigit val)) chkDate v = getDateVar v >>= return . not . null . filter ((/=) [] . circa)@@ -195,9 +202,9 @@ b == "ibid-with-locator-c" then True else False | otherwise = isIbid b -getFormattedValue :: [Option] -> Form -> Formatting -> Value -> [Output]-getFormattedValue o f fm val- | Just v <- fromValue val :: Maybe String = rtfParser fm v+getFormattedValue :: [Option] -> [Abbrev] -> Form -> Formatting -> String -> Value -> [Output]+getFormattedValue o as f fm s val+ | Just v <- fromValue val :: Maybe String = rtfParser fm . getAbbr $ value v | Just v <- fromValue val :: Maybe Int = output fm (if v == 0 then [] else show v) | Just v <- fromValue val :: Maybe CNum = if v == 0 then [] else [OCitNum (unCNum v) fm] | Just v <- fromValue val :: Maybe [RefDate] = formatDate (EvalSorting emptyCite) [] [] sortDate v@@ -205,83 +212,31 @@ fm nameOpts []) v | otherwise = [] where+ value = if stripPeriods fm then filter (/= '.') else id+ getAbbr v = if f /= Short then v else+ case lookup "default" as of+ Nothing -> v+ Just x -> case lookup s x of+ Nothing -> v+ Just x' -> case M.lookup v x' of+ Nothing -> v+ Just x'' -> x'' nameOpts = ("name-as-sort-order","all") : o sortDate = [ DatePart "year" "numeric-leading-zeros" "" emptyFormatting , DatePart "month" "numeric-leading-zeros" "" emptyFormatting , DatePart "day" "numeric-leading-zeros" "" emptyFormatting] -rtfTags :: [(String, (String,Formatting))]-rtfTags =- [("b" , ("b" , ef {fontWeight = "bold" }))- ,("i" , ("i" , ef {fontStyle = "italic" }))- ,("sc" , ("sc" , ef {fontVariant = "small-caps"}))- ,("sup" , ("sup" , ef {verticalAlign = "sub" }))- ,("sub" , ("sub" , ef {verticalAlign = "sub" }))- ,("span class=\"nocase\"" , ("span", ef {noCase = True }))- ,("span class=\"nodecor\"" , ("span", ef {noDecor = True }))- ]- where- ef = emptyFormatting--rtfParser :: Formatting -> String -> [Output]-rtfParser _ [] = []-rtfParser fm s- = either (const [OStr s fm]) (return . flip Output fm . concat) $- parse (manyTill parser eof) "" s- where- parser = parseText <|> parseMarkup-- parseText = do- let amper = string "&" >> notFollowedBy (char '#') >>- return [OStr "&" emptyFormatting]- x <- many $ noneOf "<'\"`“‘&"- xs <- parseQuotes <|> parseMarkup <|> amper- r <- manyTill anyChar eof- return (OStr x emptyFormatting : xs ++- [Output (rtfParser emptyFormatting r) emptyFormatting])-- parseMarkup = do- let tillTag = many $ noneOf "<"- m <- string "<" >> manyTill anyChar (try $ string ">")- res <- case lookup m rtfTags of- Just tf -> do let ot = "<" ++ fst tf ++ ">"- ct = "</" ++ fst tf ++ ">"- parseGreedy = do a <- tillTag- _ <- string ct- return a- x <- manyTill anyChar $ try $ string ct- y <- try parseGreedy <|> (string ot >> pzero) <|> return []- let r = if null y then x else x ++ ct ++ y- return [Output (rtfParser emptyFormatting r) (snd tf)]- Nothing -> do r <- tillTag- return [OStr ("<" ++ m ++ ">" ++ r) emptyFormatting]- return [Output res emptyFormatting]-- parseQuotes = choice [parseQ "'" "'"- ,parseQ "\"" "\""- ,parseQ "``" "''"- ,parseQ "`" "'"- ,parseQ "“" "”"- ,parseQ "‘" "’"- ,parseQ "'" "'"- ,parseQ """ """- ,parseQ """ """- ,parseQ "'" "'"- ]- parseQ a b = try $ do- q <- string a >> manyTill anyChar (try $ string b)- return [Output (rtfParser emptyFormatting q) (emptyFormatting {quotes = True})]- formatTitle :: Form -> Formatting -> State EvalState [Output] formatTitle f fm- | Short <- f = getIt "short-title" "title"- | otherwise = getIt "title" "short-title"+ | Short <- f = getIt "title-short" "title"+ | otherwise = getIt "title" "title-short" where getIt x fb = do o <- gets (options . env)- r <- getVar [] (getFormattedValue o f fm) x+ a <- gets (abbrevs . env)+ r <- getVar [] (getFormattedValue o a f fm x) x case r of- [] -> getVar [] (getFormattedValue o f fm) fb+ [] -> getVar [] (getFormattedValue o a f fm x) fb _ -> return r formatNumber :: NumericForm -> Formatting -> String -> State EvalState [Output]@@ -309,18 +264,18 @@ formatRange fm p = do ops <- gets (options . env) let opt = getOptionVal "page-range-format" ops- splitRange = second (dropWhile (== '-')) . break (== '-')+ splitRange = break (== '-') >>> trim *** trim . dropWhile (== '-') pages = map splitRange . split (== ',') $ p format a b = if b /= []- then flip Output emptyFormatting [ OStr a emptyFormatting, OPan [EnDash]+ then flip Output emptyFormatting [ OStr a emptyFormatting, OPan [Str "\x2013"] , OStr b emptyFormatting] else flip Output emptyFormatting [ OStr a emptyFormatting] result = case opt of "expanded" -> map (uncurry format . uncurry expandedRange) pages "chicago" -> map (uncurry format . uncurry chicagoRange ) pages "minimal" -> map (uncurry format . uncurry minimalRange ) pages- _ -> [OStr p emptyFormatting]- return [flip Output fm $ addDelim ", " result]+ _ -> map (uncurry format ) pages+ return [flip OLoc fm $ addDelim ", " result] expandedRange :: String -> String -> (String, String) expandedRange sa [] = (sa,[])
src/Text/CSL/Eval/Common.hs view
@@ -49,6 +49,7 @@ , dates :: [Element] , options :: [Option] , names :: [Element]+ , abbrevs :: [Abbrev] } deriving ( Show ) data EvalMode@@ -128,6 +129,7 @@ withRefMap :: (ReferenceMap -> a) -> State EvalState a withRefMap f = return . f =<< gets ref +-- | Convert variable to lower case, translating underscores ("_") to dashes ("-") formatVariable :: String -> String formatVariable = foldr f [] where f x xs = if x == '_' then '-' : xs else toLower x : xs
src/Text/CSL/Eval/Date.hs view
@@ -26,7 +26,7 @@ import Text.CSL.Parser ( toRead ) import Text.CSL.Reference import Text.CSL.Style-import Text.Pandoc.Definition ( Inline (Str,EnDash) )+import Text.Pandoc.Definition ( Inline (Str) ) evalDate :: Element -> State EvalState [Output] evalDate (Date s f fm dl dp dp') = do@@ -100,20 +100,20 @@ addZero n = if length n == 1 then '0' : n else n addZeros = reverse . take 5 . flip (++) (repeat '0') . reverse formatDatePart False (RefDate y m e d _ _) (DatePart n f _ fm)- | "year" <- n, y /= [] = return $ OYear (formatYear f y) k fm- | "month" <- n, m /= [] = output fm (formatMonth f m)- | "day" <- n, d /= [] = output fm (formatDay f d)+ | "year" <- n, y /= [] = return $ OYear (formatYear f y) k fm+ | "month" <- n, m /= [] = output fm (formatMonth f fm m)+ | "day" <- n, d /= [] = output fm (formatDay f d) | "month" <- n, m == [] , e /= [] = output fm $ term f ("season-0" ++ e) formatDatePart True (RefDate y m e d _ _) (DatePart n f rd fm) | "year" <- n, y /= [] = OYear (formatYear f y) k (fm {suffix = []}) : formatDelim- | "month" <- n, m /= [] = output (fm {suffix = []}) (formatMonth f m) ++ formatDelim- | "day" <- n, d /= [] = output (fm {suffix = []}) (formatDay f d) ++ formatDelim+ | "month" <- n, m /= [] = output (fm {suffix = []}) (formatMonth f fm m) ++ formatDelim+ | "day" <- n, d /= [] = output (fm {suffix = []}) (formatDay f d) ++ formatDelim | "month" <- n, m == [] , e /= [] = output (fm {suffix = []}) (term f $ "season-0" ++ e) ++ formatDelim where- formatDelim = if rd == "-" then [OPan [EnDash]] else [OPan [Str rd]]+ formatDelim = if rd == "-" then [OPan [Str "\x2013"]] else [OPan [Str rd]] formatDatePart _ (RefDate _ _ _ _ o _) (DatePart n _ _ fm) | "year" <- n, o /= [] = output fm o@@ -131,12 +131,13 @@ | otherwise = y where iy = readNum y- formatMonth f m- | "short" <- f = getMonth fst+ formatMonth f fm m+ | "short" <- f = getMonth $ period . fst | "long" <- f = getMonth fst | "numeric" <- f = m | otherwise = addZero m where+ period = if stripPeriods fm then filter (/= '.') else id getMonth g = maybe m g $ lookup ("month-" ++ addZero m, read $ toRead f) tm formatDay f d | "numeric-leading-zeros" <- f = addZero d
src/Text/CSL/Eval/Names.hs view
@@ -17,7 +17,7 @@ import Control.Applicative ( (<$>) ) import Control.Monad.State-import Data.Char ( toUpper, isLower, isSpace )+import Data.Char ( toUpper, isLower, isUpper, isSpace ) import Data.List ( nub ) import Data.Maybe ( isJust ) @@ -69,7 +69,7 @@ agents p s a = concatMapM (formatNames (hasEtAl nl) d p s a) nl delim ops = if d == [] then getOptionVal "names-delimiter" ops else d resetEtal = modify (\s -> s { etal = [] })- count num x = if hasCount nl && num /= []+ count num x = if hasCount nl && num /= [] -- FIXME!! le zero!! then [OContrib [] [] [ONum (length num) emptyFormatting] [] []] else x hasCount = or . query hasCount'@@ -172,19 +172,21 @@ if isWithLastName o then case () of _ | (length as - i) == 1 -> et_al o b t fm d i -- is that correct? FIXME later- | (length as - i) > 1 -> return $ [ODel d, OPan [Ellipses], OSpace] ++ ln+ | (length as - i) > 1 -> return $ [ODel d, OPan [Str "\x2026"], OSpace] ++ ln | otherwise -> return [] else et_al o b t fm d i et_al o b t fm d i = when' (gets mode >>= return . not . isSorting) $ if b || length as <= i then return []- else case getOptionVal "delimiter-precedes-et-al" o of- "never" -> return . (++) [OSpace] . output fm =<< getTerm False Long t- "always" -> return . (++) [ODel d] . output fm =<< getTerm False Long t- _ -> if i > 1- then return . (++) [ODel d] . output fm =<< getTerm False Long t- else return . (++) [OSpace] . output fm =<< getTerm False Long t+ else do x <- getTerm False Long t+ when' (return $ x /= []) $+ case getOptionVal "delimiter-precedes-et-al" o of+ "never" -> return . (++) [OSpace] $ output fm x+ "always" -> return . (++) [ODel d] $ output fm x+ _ -> if i > 1+ then return . (++) [ODel d] $ output fm x+ else return . (++) [OSpace] $ output fm x -- | The first 'Bool' is 'True' if we are evaluating the bibliography. -- The 'String' is the cite position. The function also returns the@@ -223,23 +225,18 @@ else getOptionVal' "et-al-use-first" "et-al-subsequent-min" in if null u then 1 else read u -isPlural :: Plural -> Int -> Bool-isPlural p l- = case p of- Always -> True- Never -> False- Contextual -> l > 1- -- | Generate the 'Agent's names applying et-al options, with all -- possible permutations to disambiguate colliding citations. The -- 'Bool' indicate whether we are formatting the first name or not. formatName :: EvalMode -> Bool -> Form -> Formatting -> [Option] -> [NamePart] -> Agent -> [Output] formatName m b f fm ops np n- | Short <- f = return $ OName (show n) shortName disambdata fm- | otherwise = return $ OName (show n) (longName given) disambdata fm+ | literal n /= [] = return $ OName (show n) institution [] fm+ | Short <- f = return $ OName (show n) shortName disambdata fm+ | otherwise = return $ OName (show n) (longName given) disambdata fm where+ institution = [OStr (literal n) $ form "family"] when_ c o = if c /= [] then o else []- addAffixes s sf ns = [Output ((OStr s (form sf) { prefix = [], suffix = [] }) : ns) $+ addAffixes s sf ns = [Output ((oStr' s (form sf) { prefix = [], suffix = [] }) ++ ns) $ emptyFormatting { prefix = prefix (form sf) , suffix = suffix (form sf)}] @@ -251,13 +248,17 @@ hyphen = if getOptionVal "initialize-with-hyphen" ops == "false" then getOptionVal "initialize-with" ops else filter (not . isSpace) $ getOptionVal "initialize-with" ops ++ "-"- initial x = if isJust (lookup "initialize-with" ops)+ isInit x = length x == 1 && or (map isUpper x)+ initial x = if isJust (lookup "initialize-with" ops) &&+ getOptionVal "initialize" ops /= "false" then if not . and . map isLower $ x then addIn x $ getOptionVal "initialize-with" ops else " " ++ case x of _:'\'':[] -> x _ -> x ++ " "- else " " ++ x+ else " " ++ if isJust (lookup "initialize-with" ops) && isInit x+ then addIn x $ getOptionVal "initialize-with" ops+ else x addIn x i = if hasHyphen x then head ( takeWhile (/= '-') x) : hyphen ++ head (tail $ dropWhile (/= '-') x) : i@@ -278,26 +279,27 @@ givenLong = when_ (givenName n) . unwords' $ givenName n family = familyName n - shortName = [OStr (nonDroppingPart n <+> family) (form "family")]+ shortName = oStr' (nonDroppingPart n <+> family) (form "family") longName g = if isSorting m then let firstPart = case getOptionVal "demote-non-dropping-particle" ops of "never" -> nonDroppingPart n <+> family <+> droppingPart n _ -> family <+> droppingPart n <+> nonDroppingPart n- in [OStr firstPart (form "family")] <++> [OStr g (form "given")] ++ suffCom+ in [OStr firstPart (form "family")] <++> oStr' g (form "given") ++ suffCom else if (b && getOptionVal "name-as-sort-order" ops == "first") || getOptionVal "name-as-sort-order" ops == "all" then let (fam,par) = case getOptionVal "demote-non-dropping-particle" ops of "never" -> (nonDroppingPart n <+> family, droppingPart n) "sort-only" -> (nonDroppingPart n <+> family, droppingPart n) _ -> (family, droppingPart n <+> nonDroppingPart n)- in OStr fam (form "family") : sortSep g par ++ suffCom+ in oStr' fam (form "family") ++ sortSep g par ++ suffCom else oStr' g (form "given") <++> addAffixes (droppingPart n <+> nonDroppingPart n <+> family) "family" suff disWithGiven = getOptionVal "disambiguate-add-givenname" ops == "true"- initialize = not . null . getOptionVal "initialize-with" $ ops+ initialize = isJust . lookup "initialize-with" $ ops isLong = f /= Short && initialize- givenRule = getOptionVal "givenname-disambiguation-rule" ops+ givenRule = let gr = getOptionVal "givenname-disambiguation-rule" ops+ in if null gr then "by-cite" else gr disambdata = case () of _ | "all-names-with-initials" <- givenRule , disWithGiven, Short <- f, initialize -> [longName given]@@ -323,19 +325,21 @@ formatLabel f fm p s | "locator" <- s = when' (gets (citeLocator . cite . env) >>= return . (/=) []) $ do (l,v) <- getLocVar- format l ('-' `elem` v)- | "page" <- s = when' (isVarSet s) $ do- v <- getStringVar s- format s ('-' `elem` v)+ form (\fm' -> return . flip OLoc emptyFormatting . output fm') id l ('-' `elem` v)+ | "page" <- s = checkPlural+ | "volume" <- s = checkPlural | "ibid" <- s = format' s p | otherwise = format s p where- format = form id+ checkPlural = when' (isVarSet s) $ do+ v <- getStringVar s+ format s ('-' `elem` v)+ format = form output id format' t b = gets (citePosition . cite . env) >>= \po -> if po == "ibid-with-locator-c" || po == "ibid-c"- then form capital t b- else form id t b- form g t b = return . output fm =<< g . period <$> getTerm (b && p) f t+ then form output capital t b+ else format t b+ form o g t b = return . o fm =<< g . period <$> getTerm (b && p) f t period = if stripPeriods fm then filter (/= '.') else id capital x = toUpper (head x) : (tail x)
src/Text/CSL/Eval/Output.hs view
@@ -17,6 +17,7 @@ import Text.CSL.Output.Plain import Text.CSL.Style+import Text.ParserCombinators.Parsec hiding ( State (..) ) output :: Formatting -> String -> [Output] output fm s@@ -38,6 +39,7 @@ | ONull <- o = flatten os | Output [] _ <- o = flatten os | OStr [] _ <- o = flatten os+ | OUrl [] _ <- o = flatten os | Output xs f <- o , f == emptyFormatting = flatten xs ++ flatten os | otherwise = o : flatten os@@ -66,9 +68,72 @@ oStr' :: String -> Formatting -> [Output] oStr' [] _ = []-oStr' s f = [OStr s f]+oStr' s f = rtfParser f s (<++>) :: [Output] -> [Output] -> [Output] [] <++> o = o o <++> [] = o o1 <++> o2 = o1 ++ [OSpace] ++ o2++rtfTags :: [(String, (String,Formatting))]+rtfTags =+ [("b" , ("b" , ef {fontWeight = "bold" }))+ ,("i" , ("i" , ef {fontStyle = "italic" }))+ ,("sc" , ("sc" , ef {fontVariant = "small-caps"}))+ ,("sup" , ("sup" , ef {verticalAlign = "sup" }))+ ,("sub" , ("sub" , ef {verticalAlign = "sub" }))+ ,("span class=\"nocase\"" , ("span", ef {noCase = True }))+ ,("span class=\"nodecor\"" , ("span", ef {noDecor = True }))+ ]+ where+ ef = emptyFormatting++rtfParser :: Formatting -> String -> [Output]+rtfParser _ [] = []+rtfParser fm s+ = either (const [OStr s fm]) (return . flip Output fm . concat) $+ parse (manyTill parser eof) "" s+ where+ parser = parseText <|> parseMarkup++ parseText = do+ let amper = string "&" >> notFollowedBy (char '#') >>+ return [OStr "&" emptyFormatting]+ apos = string "'" >> return [OStr "’" emptyFormatting]+ x <- many $ noneOf "<'\"`“‘&"+ xs <- parseQuotes <|> parseMarkup <|> amper <|> apos+ r <- manyTill anyChar eof+ return (OStr x emptyFormatting : xs +++ [Output (rtfParser emptyFormatting r) emptyFormatting])++ parseMarkup = do+ let tillTag = many $ noneOf "<"+ m <- string "<" >> manyTill anyChar (try $ string ">")+ res <- case lookup m rtfTags of+ Just tf -> do let ot = "<" ++ fst tf ++ ">"+ ct = "</" ++ fst tf ++ ">"+ parseGreedy = do a <- tillTag+ _ <- string ct+ return a+ x <- manyTill anyChar $ try $ string ct+ y <- try parseGreedy <|> (string ot >> pzero) <|> return []+ let r = if null y then x else x ++ ct ++ y+ return [Output (rtfParser emptyFormatting r) (snd tf)]+ Nothing -> do r <- tillTag+ return [OStr ("<" ++ m ++ ">" ++ r) emptyFormatting]+ return [Output res emptyFormatting]++ parseQuotes = choice [parseQ "'" "'"+ ,parseQ "\"" "\""+ ,parseQ "``" "''"+ ,parseQ "`" "'"+ ,parseQ "“" "”"+ ,parseQ "‘" "’"+ ,parseQ "'" "'"+ ,parseQ """ """+ ,parseQ """ """+ ,parseQ "'" "'"+ ]+ parseQ a b = try $ do+ q <- string a >> manyTill anyChar (try $ string b)+ return [Output (rtfParser emptyFormatting q) (emptyFormatting {quotes = True})]
src/Text/CSL/Input/Bibutils.hs view
@@ -23,9 +23,10 @@ import Text.CSL.Reference import Text.CSL.Input.Json import Text.CSL.Input.MODS+import Text.JSON.Generic #ifdef USE_BIBUTILS-import Control.Exception ( bracket )+import Control.Exception ( bracket, catch ) import Control.Monad.Trans ( liftIO ) import System.FilePath ( (</>), (<.>) ) import System.IO.Error ( isAlreadyExistsError )@@ -44,6 +45,7 @@ = case getExt f of ".mods" -> readBiblioFile' f mods_in ".bib" -> readBiblioFile' f biblatex_in+ ".bibtex" -> readBiblioFile' f bibtex_in ".ris" -> readBiblioFile' f ris_in ".enl" -> readBiblioFile' f endnote_in ".xml" -> readBiblioFile' f endnotexml_in@@ -51,20 +53,23 @@ ".medline" -> readBiblioFile' f medline_in ".copac" -> readBiblioFile' f copac_in ".json" -> readJsonInput f+ ".native" -> readFile f >>= return . decodeJSON _ -> error $ "citeproc: the format of the bibliographic database could not be recognized\n" ++ "using the file extension." #else readBiblioFile f- | ".mods" <- getExt f = readModsCollectionFile f- | ".json" <- getExt f = readJsonInput f- | otherwise = error $ "citeproc: Bibliography format not supported.\n" ++- "citeproc-hs was not compiled with bibutils support."+ | ".mods" <- getExt f = readModsCollectionFile f+ | ".json" <- getExt f = readJsonInput f+ | ".native" <- getExt f = readFile f >>= return . decodeJSON+ | otherwise = error $ "citeproc: Bibliography format not supported.\n" +++ "citeproc-hs was not compiled with bibutils support." #endif data BibFormat = Mods | Json+ | Native #ifdef USE_BIBUTILS | Bibtex | BibLatex@@ -80,6 +85,7 @@ readBiblioString b s | Mods <- b = return $ readXmlString xpModsCollection s | Json <- b = return $ readJsonInputString s+ | Native <- b = return $ decodeJSON s #ifdef USE_BIBUTILS | Bibtex <- b = go bibtex_in | BibLatex <- b = go biblatex_in@@ -128,10 +134,10 @@ createTempDir num baseName = do sysTempDir <- getTemporaryDirectory let dirName = sysTempDir </> baseName <.> show num- liftIO $ catch (createDirectory dirName >> return dirName) $+ liftIO $ Control.Exception.catch (createDirectory dirName >> return dirName) $ \e -> if isAlreadyExistsError e- then createTempDir (num + 1) baseName- else ioError e+ then createTempDir (num + 1) baseName+ else ioError e #endif getExt :: String -> String
src/Text/CSL/Input/Json.hs view
@@ -20,6 +20,7 @@ import Data.Generics import Data.Char (toLower, toUpper) import Data.List+import qualified Data.Map as M import Data.Ratio import Text.JSON.Generic@@ -50,6 +51,15 @@ let rmCom = unlines . filter (\x -> not (" *" `isPrefixOf` x || "/*" `isPrefixOf` x)) . lines in either error id . runGetJSON readJSTopType . rmCom +readJsonAbbrevFile :: FilePath -> IO [Abbrev]+readJsonAbbrevFile f = readJsonAbbrev `fmap` readJsonFile f++readJsonAbbrev :: JSValue -> [Abbrev]+readJsonAbbrev+ = mapSndObj (mapSndObj (M.fromList . mapSndObj fromJString))+ where+ mapSndObj f = map (second f) . fromObj+ readJsonCitations :: JSValue -> [Cite] readJsonCitations jv | JSArray (JSObject o:_) <- jv@@ -91,8 +101,9 @@ | "non-dropping-particle" <- s = ("nonDroppingPart", j) | "comma-suffix" <- s = ("commaSuffix", toJSBool j) | "id" <- s = ("refId" , toString j)+ | "shortTitle" <- s = ("titleShort" , j) | isRefDate s- , JSObject js <- j = (s , JSArray (editDate $ fromJSObject js))+ , JSObject js <- j = (camel s , JSArray (editDate $ fromJSObject js)) | "family" <- s = ("familyName" , j) | "suffix" <- s = ("nameSuffix" , j) | "edition" <- s = ("edition" , toString j)@@ -111,7 +122,7 @@ camel x | '-':y:ys <- x = toUpper y : camel ys | '_':y:ys <- x = toUpper y : camel ys- | y:ys <- x = y : camel ys+ | y:ys <- x = toLower y : camel ys | otherwise = [] format (x:xs) = toUpper x : xs@@ -212,6 +223,11 @@ fromObj :: JSValue -> [(String, JSValue)] fromObj (JSObject o) = fromJSObject o fromObj _ = []++fromJString :: JSValue -> String+fromJString j+ | JSString x <- j = fromJSString x+ | otherwise = [] defaultJson :: [(String, JSValue)] defaultJson = fromObj (toJSON emptyReference) ++ fromObj emptyRefDate ++
src/Text/CSL/Input/MODS.hs view
@@ -16,16 +16,14 @@ module Text.CSL.Input.MODS where -import Text.CSL.Output.Plain ( (<+>) )-import Text.CSL.Reference+import Text.CSL.Eval ( split )+import Text.CSL.Output.Plain ( (<+>), tail' ) import Text.CSL.Pickle+import Text.CSL.Reference import Text.CSL.Style ( betterThen ) import Data.Char ( isDigit, isLower )--#ifdef USE_HXT-import Text.XML.HXT.Arrow.Pickle.Xml-#endif+import qualified Data.Map as M -- | Read a file with a single MODS record. readModsFile :: FilePath -> IO Reference@@ -47,11 +45,11 @@ , (ck,ty,ti,i,d) ,((au,ed,tr),(re,it,pu'),(co,ce)) ,((di',pg,vl,is),(nu,sc,ch))- , (di,pu,pp)- , ((ac,uri),no)+ , (di,ac,pu,pp)+ , ((ac',uri),no) ) -> ref { refId = ck `betterThen` take 10 (concat $ words ti)- , refType = if refType ref /= NoType then refType ref else ty+ , refType = if ty == NoType then refType ref else ty , title = ti , author = au , editor = ed `betterThen` editor ref@@ -64,10 +62,10 @@ , containerAuthor = containerAuthor ref , url = uri , note = no- , accessed = ac , isbn = i , doi = d , issued = issued ref `betterThen` di `betterThen` di'+ , accessed = accessed ref `betterThen` ac `betterThen` ac' , page = page ref `betterThen` pg , volume = volume ref `betterThen` vl , issue = issue ref `betterThen` is@@ -85,26 +83,27 @@ ,(composer r, collectionEditor r)) ,((issued r, page r, volume r, issue r) ,(number r, section r, chapterNumber r))- , (issued r, emptyAgents, publisherPlace r)+ , (issued r, accessed r, emptyAgents, publisherPlace r) ,((accessed r, url r), note r) )) $ xp6Tuple (xpDefault emptyReference xpRelatedItem) (xp5Tuple xpCiteKey xpRefType xpTitle xpIsbn xpDoi)- xpAgents xpPart xpOrigin- (xpPair xpUrl xpNote)+ xpAgents xpPart xpOrigin (xpPair xpUrl xpNote) xpCiteKey :: PU String xpCiteKey = xpDefault [] $- xpChoice (xpAttr "ID" xpText)- (xpIElem "identifier" xpText)+ xpChoice (xpAttr "ID" xpText)+ (xpElemWithAttrValue "identifier" "type" "citekey" xpText) xpLift -xpOrigin :: PU ([RefDate],[Agent],String)+xpOrigin :: PU ([RefDate],[RefDate],[Agent],String) xpOrigin- = xpDefault ([],[],[]) . xpIElem "originInfo" $- xpTriple (xpDefault [] $ xpWrap (readDate,show) $+ = xpDefault ([],[],[],[]) . xpIElem "originInfo" $+ xp4Tuple (xpDefault [] $ xpWrap (readDate,show) $ xpIElem "dateIssued" xpText0)+ (xpDefault [] $ xpWrap (readDate,show) $+ xpIElem "dateCaptured" xpText0) (xpDefault [] $ xpList $ xpWrap (\s -> Agent [] [] [] s [] [] False, show) $ xpIElem "publisher" xpText0) (xpDefault [] $ xpIElem "place" $ xpIElem "placeTerm" xpText0)@@ -112,26 +111,7 @@ xpRefType :: PU RefType xpRefType = xpDefault NoType $- xpWrap (readType, const []) xpGenre- where- readType [] = NoType- readType (t:_)- | "conference publication" <- t = PaperConference- | "periodical" <- t = ArticleJournal- | otherwise = Book--xpRefType' :: PU RefType-xpRefType'- = xpDefault NoType $- xpWrap (readTypeIn, const []) xpGenre- where- readTypeIn [] = NoType- readTypeIn t- | "book" `elem` t = Chapter- | "conference publication" `elem` t = PaperConference- | "academic journal" `elem` t = ArticleJournal- | "collection" `elem` t = Chapter- | otherwise = ArticleJournal+ xpWrap (readRefType, const []) xpGenre xpGenre :: PU [String] xpGenre@@ -146,7 +126,7 @@ xpWrap ( \( (ty,ct) ,((ca,ed,tr),(re,it,pu'),(co,ce)) ,((di,pg,vl,is),(nu,sc,ch))- , (di',pu,pp)+ , (di',ac,pu,pp) ) -> emptyReference { refType = ty , containerAuthor = ca@@ -160,6 +140,7 @@ , composer = co , collectionEditor = ce , issued = di `betterThen` di'+ , accessed = ac , page = pg , volume = vl , issue = is@@ -173,9 +154,9 @@ ,(composer r, collectionEditor r)) ,((issued r, page r, volume r, issue r) ,(number r, section r, chapterNumber r))- , (issued r, emptyAgents, publisherPlace r)+ , (issued r, accessed r,emptyAgents, publisherPlace r) )) $- xp4Tuple (xpPair xpRefType' xpTitle)+ xp4Tuple (xpPair xpRefType xpTitle) xpAgents xpPart xpOrigin -- FIXME: join title and subtitle correctly: usare Title per shortTitle.@@ -314,9 +295,47 @@ xpNote = xpDefault [] $ xpIElem "note" xpText readDate :: String -> [RefDate]-readDate s = if takeWhile isDigit s /= []- then return $ RefDate (takeWhile isDigit s) [] [] [] [] []- else []+readDate s = (parseDate $ takeWhile (/= '/') s) +++ (parseDate . tail' $ dropWhile (/= '/') s) +-- | Possible formats: "YYYY", "YYYY-MM", "YYYY-MM-DD".+parseDate :: String -> [RefDate]+parseDate s = case split (== '-') (unwords $ words s) of+ [y,m,d] -> [RefDate y m [] d [] []]+ [y,m] -> [RefDate y m [] [] [] []]+ [y] -> if and (map isDigit y)+ then [RefDate y [] [] [] [] []]+ else [RefDate [] [] [] [] y []]+ _ -> []+ emptyAgents :: [Agent] emptyAgents = []++readRefType :: [String] -> RefType+readRefType [] = NoType+readRefType (t:_) =+ case M.lookup t genreTypeMapping of+ Just x -> x+ Nothing -> ArticleJournal -- Reasonable default (?)++-- The string constants come from http://www.loc.gov/standards/valuelist/marcgt.html, which are used in the+-- "<genre></genre>" element (http://www.loc.gov/standards/mods/userguide/genre.html)+genreTypeMapping :: M.Map String RefType+genreTypeMapping = M.fromList+ [ ( "book", Book )+ , ( "periodical", ArticleJournal )+ , ( "newspaper", ArticleNewspaper )+ , ( "encyclopedia", EntryEncyclopedia )+ , ( "conference publication", PaperConference )+ , ( "academic journal", ArticleJournal )+ , ( "collection", Chapter )+ , ( "legal case and case notes", LegalCase )+ , ( "legislation", Legislation )+ , ( "motion picutre", MotionPicture )+ , ( "patent", Patent )+ , ( "review", Review )+ , ( "thesis", Thesis )+ , ( "web page", Webpage )+ , ( "webpage", Webpage )+ , ( "web site", Webpage )+ ]
src/Text/CSL/Output/Pandoc.hs view
@@ -26,6 +26,7 @@ ) where import Data.Char ( toUpper, toLower, isPunctuation )+import Data.Maybe ( fromMaybe ) import Text.CSL.Style import Text.CSL.Output.Plain@@ -35,19 +36,22 @@ -- the native 'Pandoc' formats (i.e. immediately readable by pandoc). renderPandoc :: Style -> [FormattedOutput] -> [Inline] renderPandoc s- = proc' (clean s $ isPunctuationInQuote s) . concatMap (flipFlop . render s)+ = proc (convertQuoted s) . proc' (clean s $ isPunctuationInQuote s) .+ concatMap (flipFlop . render s) -- | Same as 'renderPandoc', but the output is wrapped in a pandoc -- paragraph block. renderPandoc' :: Style -> [FormattedOutput] -> Block renderPandoc' s- = Para . proc' (clean s $ isPunctuationInQuote s) . concatMap (flipFlop . render s)+ = Para . proc (convertQuoted s) . proc' (clean s $ isPunctuationInQuote s) .+ concatMap (flipFlop . render s) -- | For the testsuite: we use 'Link' and 'Strikeout' to store -- "nocase" and "nodecor" rich text formatting classes. renderPandoc_ :: Style -> [FormattedOutput] -> [Inline] renderPandoc_ s- = proc (clean' s $ isPunctuationInQuote s) . concatMap (flipFlop . render s)+ = proc (convertQuoted s) . proc (clean' s $ isPunctuationInQuote s) .+ concatMap (flipFlop . render s) render :: Style -> FormattedOutput -> [Inline] render _ (FPan i) = i@@ -56,14 +60,16 @@ | FS str fm <- fo = toPandoc fm $ toStr str | FN str fm <- fo = toPandoc fm $ toStr $ rmZeros str | FO fm xs <- fo = toPandoc fm $ rest xs+ | FUrl u fm <- fo = toPandoc fm [Link (toStr u) (u,u)] | otherwise = [] where addSuffix f i | suffix f /= []- , elem (head $ suffix f) ",.:?!"- , [head $ suffix f] == lastInline i = i ++ toStr (tail $ suffix f)- | suffix f /= [] = i ++ toStr ( suffix f)- | otherwise = i+ , elem (head $ suffix f) ".?!"+ , lastInline i /= []+ , last (lastInline i)`elem` ".?!" = i ++ toStr (tail $ suffix f)+ | suffix f /= [] = i ++ toStr ( suffix f)+ | otherwise = i toPandoc f i = addSuffix f $ toStr (prefix f) ++ (format f . quote f . proc cleanStrict $ i)@@ -72,7 +78,6 @@ quote f i = if i /= [] && quotes f then [Quoted DoubleQuote . valign f $ i] else valign f i- setCase f i | Str s <- i = Str $ f s | otherwise = i@@ -121,9 +126,15 @@ toStr = toStr' . entityToChar where toStr' s+ |'«':' ':xs <- s = toStr' ("«\8239" ++ xs)+ |' ':'»':xs <- s = toStr' ("\8239»" ++ xs)+ |' ':';':xs <- s = toStr' ("\8239;" ++ xs)+ |' ':':':xs <- s = toStr' ("\8239:" ++ xs)+ |' ':'!':xs <- s = toStr' ("\8239!" ++ xs)+ |' ':'?':xs <- s = toStr' ("\8239?" ++ xs) |' ':xs <- s = Space : toStr' xs | x :xs <- s = Str [x] : toStr' xs- | otherwise = []+ | otherwise = [] cleanStrict :: [Inline] -> [Inline] cleanStrict [] = []@@ -142,8 +153,8 @@ | SmallCaps x <- i = split (isLink "nodecor" ) (return . SmallCaps ) x ++ clean s b is | Emph x <- i = split (isLink' "emph" ) (return . Emph ) x ++ clean s b is | Strong x <- i = split (isLink' "strong" ) (return . Strong ) x ++ clean s b is- | Link x _ <- i = clean' s b (x ++ clean s b is)- | otherwise = clean' s b (i : clean s b is)+ | Link x t <- i = clean' s b (Link x t : clean s b is)+ | otherwise = clean' s b (i : clean s b is) where unwrap f ls | Link x _ : _ <- ls = clean' s b x@@ -219,6 +230,21 @@ endWithPunct, startWithPunct :: [Inline] -> Bool endWithPunct = and . map (`elem` ".,;:!?") . lastInline startWithPunct = and . map (`elem` ".,;:!?") . headInline++convertQuoted :: Style -> [Inline] -> [Inline]+convertQuoted s = proc convertQuoted'+ where+ locale = let l = styleLocale s in case l of [x] -> x; _ -> Locale [] [] [] [] []+ getQuote x y = entityToChar . fst . fromMaybe (x,[]) . lookup (y,Long) . localeTermMap $ locale+ doubleQuotesO = getQuote "\"" "open-quote"+ doubleQuotesC = getQuote "\"" "close-quote"+ singleQuotesO = getQuote "'" "open-inner-quote"+ singleQuotesC = getQuote "'" "close-inner-quote"+ convertQuoted' o+ | (Quoted DoubleQuote t:xs) <- o = Str doubleQuotesO : t ++ Str doubleQuotesC : convertQuoted' xs+ | (Quoted SingleQuote t:xs) <- o = Str singleQuotesO : t ++ Str singleQuotesC : convertQuoted' xs+ | (x :xs) <- o = x : convertQuoted' xs+ | otherwise = [] headInline :: [Inline] -> String headInline [] = []
src/Text/CSL/Output/Plain.hs view
@@ -89,8 +89,13 @@ | x :xs <- s = x : entityToChar xs | otherwise = [] where- parseEntity = chr . read . takeWhile isDigit &&&+ parseEntity = chr . readNum . takeWhile (/= ';') &&& entityToChar . tail' . dropWhile (/= ';')+ readNum ('x': n) = readNum $ "0x" ++ n+ readNum n = case readsPrec 1 n of+ [(x,[])] -> x+ _ -> error $ "Invalid character entity:" ++ n+ head' :: [a] -> [a] head' = foldr (\x _ -> [x]) []
src/Text/CSL/Parser.hs view
@@ -257,8 +257,8 @@ xpStyle :: PU Style xpStyle- = xpWrap ( \ ((v,sc,si,sl,l),(o,m,c,b)) -> Style v sc si sl l o m c b- , \ (Style v sc si sl l o m c b) -> ((v,sc,si,sl,l),(o,m,c,b))) $+ = xpWrap ( \ ((v,sc,si,sl,l),(o,m,c,b)) -> Style v sc si sl l [] o m c b+ , \ (Style v sc si sl l _ o m c b) -> ((v,sc,si,sl,l),(o,m,c,b))) $ xpIElem "style" $ xpPair (xp5Tuple (xpAttrText "version") (xpAttrText "class")@@ -321,16 +321,18 @@ xpNameFormat :: PU [Option] xpNameFormat- = xpWrap (\(a,b,c,d,e) ->+ = xpWrap (\(a,b,c,d,e,f) -> catMaybes [ checkOpt "and" a , checkOpt "delimiter-precedes-last" b , checkOpt "sort-separator" c- , checkOpt "initialize-with" d- , checkOpt "name-as-sort-order" e- ] , const (Nothing, Nothing, Nothing, Nothing, Nothing)) $- xp5Tuple (getOpt "and")+ , checkOpt "initialize" d+ , checkOpt "initialize-with" e+ , checkOpt "name-as-sort-order" f+ ] , const (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)) $+ xp6Tuple (getOpt "and") (getOpt "delimiter-precedes-last") (getOpt "sort-separator")+ (getOpt "initialize") (getOpt "initialize-with") (getOpt "name-as-sort-order")
src/Text/CSL/Pickle.hs view
@@ -351,7 +351,7 @@ return (Just res, st) xpElemWithAttrValue :: String -> String -> String -> PU a -> PU a-xpElemWithAttrValue n a v = xpElem n . xpAddFixedAttr a v+xpElemWithAttrValue n a v = xpIElem n . xpAddFixedAttr a v xpAttrFixed :: String -> String -> PU () xpAttrFixed name val
src/Text/CSL/Proc.hs view
@@ -17,10 +17,11 @@ module Text.CSL.Proc where import Control.Arrow ( (&&&), (>>>), second )+import Data.Char ( toLower ) import Data.List import Data.Ord ( comparing ) -import Text.CSL.Eval+import Text.CSL.Eval hiding ( trim ) import Text.CSL.Output.Plain import Text.CSL.Parser import Text.CSL.Proc.Collapse@@ -81,12 +82,12 @@ -- according to the 'Style' and assign the citation number to each -- 'Reference'. procRefs :: Style -> [Reference] -> [Reference]-procRefs (Style {biblio = mb, csMacros = ms , styleLocale = l, csOptions = opts}) rs+procRefs (Style {biblio = mb, csMacros = ms , styleLocale = l, styleAbbrevs = as, csOptions = opts}) rs = maybe rs process mb where opts' b = mergeOptions (bibOptions b) opts citNum x = x { citationNumber = maybe 0 ((+) 1 . fromIntegral) . elemIndex x $ rs }- sort_ b = evalSorting (EvalSorting emptyCite {citePosition = "first"})l ms (opts' b) (bibSort b)+ sort_ b = evalSorting (EvalSorting emptyCite {citePosition = "first"})l ms (opts' b) (bibSort b) as process b = sortItems . map (citNum &&& sort_ b) $ rs sortItems :: Show a => [(a,[Sorting])] -> [a]@@ -106,12 +107,14 @@ -- | With a 'Style' and a sorted list of 'Reference's produce the -- evaluated output for the bibliography. procBiblio :: BibOpts -> Style -> [Reference] -> [[Output]]-procBiblio bos (Style {biblio = mb, csMacros = ms , styleLocale = l, csOptions = opts}) rs+procBiblio bos (Style {biblio = mb, csMacros = ms , styleLocale = l,+ styleAbbrevs = as, csOptions = opts}) rs = maybe [] process mb where render b = map (format b) . chkAut [] . filterRefs bos $ rs process b = flip map (render b) $ uncurry formatBiblioLayout (layFormat &&& layDelim $ bibLayout b)- format b (p,r) = evalLayout (bibLayout b) (EvalBiblio p) False l ms (mergeOptions (bibOptions b) opts) r+ format b (p,r) = evalLayout (bibLayout b) (EvalBiblio p) False l ms+ (mergeOptions (bibOptions b) opts) as r chkAut _ [] = [] chkAut a (x:xs) = if author x `elem` a then ("subsequent",x) : chkAut a xs@@ -143,22 +146,25 @@ | Just v' <- (fromValue x :: Maybe [RefDate]) -> v == [] && v' == [] || v == show v' _ -> False --- | Given the CSL 'Style' and the list of 'Reference's coupled with--- their position, generate a 'CitationGroup'. The citations are--- sorted according to the 'Style'.+-- | Given the CSL 'Style' and the list of 'Cite's coupled with their+-- 'Reference's, generate a 'CitationGroup'. The citations are sorted+-- according to the 'Style'. procGroup :: Style -> [(Cite, Reference)] -> CitationGroup-procGroup (Style {citation = ct, csMacros = ms , styleLocale = l, csOptions = opts}) cr- = CG authInTxt (layFormat $ citLayout ct) (layDelim $ citLayout ct) result+procGroup (Style {citation = ct, csMacros = ms , styleLocale = l,+ styleAbbrevs = as, csOptions = opts}) cr+ = CG authIn (layFormat $ citLayout ct) (layDelim $ citLayout ct) (authIn ++ co) where- authInTxt = case cr of+ (co, authIn) = case cr of (c:_) -> if authorInText (fst c)- then foldr (\x _ -> [x]) [] $- filter ((==) (citeId $ fst c) . citeId . fst) result- else []- _ -> []+ then (,) (filter (eqCites (/=) c) $ result+ ) . foldr (\x _ -> [x]) [] .+ filter (eqCites (==) c) $ result+ else (,) result []+ _ -> (,) result []+ eqCites eq c = fst >>> citeId &&& citeHash >>> eq (citeId &&& citeHash $ fst c) opts' = mergeOptions (citOptions ct) opts- format (c,r) = (,) c $ evalLayout (citLayout ct) (EvalCite c) False l ms opts' r- sort_ (c,r) = evalSorting (EvalSorting c) l ms opts' (citSort ct) r+ format (c,r) = (,) c $ evalLayout (citLayout ct) (EvalCite c) False l ms opts' as r+ sort_ (c,r) = evalSorting (EvalSorting c) l ms opts' (citSort ct) as r process = map (second (flip Output emptyFormatting) . format &&& sort_) result = sortItems $ process cr @@ -167,35 +173,20 @@ formatCitLayout :: Style -> CitationGroup -> [FormattedOutput] formatCitLayout s (CG co f d cs)- | [a] <- co = formatAuth a : formatCits (setAsSupAu . citeHash . fst $ a) cs+ | [a] <- co = formatAuth a : formatCits (fst >>> citeId &&& citeHash >>> setAsSupAu $ a) cs | otherwise = formatCits id cs where formatAuth = formatOutput . localMod formatCits g = formatOutputList . appendOutput formatting . addAffixes f .- addDelim d . map (fst &&& localMod >>> uncurry format) . g- formatting = if co /= []- then emptyFormatting- else unsetAffixes f+ addDelim d . map (fst &&& localMod >>> uncurry addCiteAffixes) . g+ formatting = unsetAffixes f localMod = if cs /= [] then uncurry $ localModifiers s (co /= []) else snd- setAsSupAu h = map $ \(c,o) -> if citeHash c == h+ setAsSupAu h = map $ \(c,o) -> if (citeId c, citeHash c) == h then flip (,) o c { authorInText = False , suppressAuthor = True } else flip (,) o c- format c x = if isNumStyle [x]- then x- else flip Output emptyFormatting $- addCiteAff citePrefix True c ++ [x] ++- addCiteAff citeSuffix False c- addCiteAff g x c =- case g c of- PlainText [] -> []- PlainText p | x -> [Output (rtfParser emptyFormatting p) emptyFormatting, OSpace]- PlainText p -> [OSpace, Output (rtfParser emptyFormatting p) emptyFormatting]- PandocText [] -> []- PandocText p | x -> [OPan p, OSpace]- PandocText p -> [OPan p] addAffixes :: Formatting -> [Output] -> [Output] addAffixes f os@@ -238,6 +229,8 @@ | otherwise = [True] trim [] = [] trim (o:os)+ | Output ot f <- o, p <- prefix f, p /= []+ , isPunct p = trim $ Output ot f { prefix = []} : os | Output ot f <- o = if or (query hasOutput ot) then Output (trim ot) f : os else Output ot f : trim os@@ -259,29 +252,39 @@ | OContrib _ "authorsub" _ _ _ <- o = o | Output ot f <- o = Output (cleanOutput $ map contribOnly ot) f+ | OStr x _ <- o+ , "ibid" <- filter (/= '.')+ (map toLower x) = o | otherwise = ONull+ rmCitNum o+ | OCitNum {} <- o = ONull+ | otherwise = o rmContrib [] = [] rmContrib o- | b, isNumStyle o = []- rmContrib (o:os)- | Output ot f <- o = Output (rmContrib ot) f : rmContrib os+ | b, isNumStyle o = proc rmCitNum o+ | otherwise = rmContrib' o+ rmContrib' [] = []+ rmContrib' (o:os)+ | Output ot f <- o = Output (rmContrib' ot) f : rmContrib' os+ | ODel _ <- o+ , OContrib _ "author"+ _ _ _ : xs <- os = rmContrib' xs+ | ODel _ <- o+ , OContrib _ "authorsub"+ _ _ _ : xs <- os = rmContrib' xs+ | OContrib _ "author" _ _ _ <- o+ , ODel _ : xs <- os = rmContrib' xs+ | OContrib _ "authorsub" _ _ _ <- o+ , ODel _ : xs <- os = rmContrib' xs | OContrib _ "author"- _ _ _ <- o = rmContrib os+ _ _ _ <- o = rmContrib' os | OContrib _ "authorsub"- _ _ _ <- o = rmContrib os- | otherwise = o : rmContrib os+ _ _ _ <- o = rmContrib' os+ | OStr x _ <- o+ , "ibid" <- filter (/= '.') (map toLower x) = rmContrib' os++ | otherwise = o : rmContrib' os getRefTerm :: TermMap -> String getRefTerm t | (("reference", Long), (x,_)) <- t = capitalize x | otherwise = []--isNumStyle :: [Output] -> Bool-isNumStyle = null . query authorOrDate- where- authorOrDate o- | OContrib {} <- o = ['a']- | OYear {} <- o = ['a']- | OYearSuf {} <- o = ['a']- | OStr {} <- o = ['a']- | OPan {} <- o = ['a']- | otherwise = []
src/Text/CSL/Proc/Collapse.hs view
@@ -16,13 +16,14 @@ module Text.CSL.Proc.Collapse where -import Control.Arrow ( (&&&), (>>>) )+import Control.Arrow ( (&&&), (>>>), second ) import Data.Char import Data.List ( groupBy ) import Text.CSL.Eval import Text.CSL.Proc.Disamb import Text.CSL.Style+import Text.Pandoc.Definition ( Inline (Str) ) -- | Collapse citations according to the style options. collapseCitGroups :: Style -> [CitationGroup] -> [CitationGroup]@@ -42,23 +43,31 @@ = map snd . filter ((==) "collapse" . fst) . citOptions . citation collapseNumber :: CitationGroup -> CitationGroup-collapseNumber = mapCitationGroup process+collapseNumber cg+ | CG [a] f d os <- cg = mapCitationGroup process . CG [a] f d $ tail' os+ | otherwise = mapCitationGroup process cg where+ tail' x = if length x > 1 then tail x else x+ hasLocator = or . query hasLocator'+ hasLocator' o+ | OLoc _ _ <- o = [True]+ | otherwise = [False] citNum o | OCitNum i f <- o = [(i,f)] | otherwise = []- numOf = foldr (\x _ -> x) (0,emptyFormatting) . query citNum- newNum = map numOf >>> (map fst >>> groupConsec) &&& map snd >>> uncurry zip- process xs = flip concatMap (newNum xs) $+ numOf = foldr (\x _ -> x) (0,emptyFormatting) . query citNum+ newNum = map numOf >>> (map fst >>> groupConsec) &&& map snd >>> uncurry zip+ process xs = if hasLocator xs then xs else+ flip concatMap (newNum xs) $ \(x,f) -> if length x > 2 then return $ Output [ OCitNum (head x) f- , ODel "-"+ , OPan [Str "\x2013"] , OCitNum (last x) f ] emptyFormatting else map (flip OCitNum f) x collapseYear :: Style -> String -> CitationGroup -> CitationGroup-collapseYear s ranged (CG cs f d os) = CG cs f [] [(emptyCite, process $ map snd os)]+collapseYear s ranged (CG cs f d os) = CG cs f [] (process os) where styleYSD = getOptionVal "year-suffix-delimiter" . citOptions . citation $ s yearSufDel = styleYSD `betterThen` (layDelim . citLayout . citation $ s)@@ -67,31 +76,46 @@ format [] = [] format (x:xs) = x : map getYearAndSuf xs- getYearAndSuf x = case query getOYear x of+ getYearAndSuf x = case query getOYear x of [] -> noOutputError x' -> Output x' emptyFormatting getOYear o- | OYear {} <- o = [o]- | OYearSuf {} <- o = [o]- | OPan {} <- o = [o]- | otherwise = []+ | OYear {} : _ <- o = [head o]+ | OYearSuf {} : _ <- o = [head o]+ | OPan {} : _ <- o = [head o]+ | OLoc {} : _ <- o = [head o]+ | ODel _ : OLoc {} : _ <- o = [head o]+ | otherwise = [] isRanged = case ranged of "year-suffix-ranged" -> True _ -> False- collapsYS xs = if length xs < 2 || null ranged- then xs- else collapseYearSuf isRanged yearSufDel xs- addDelimiter [] = []- addDelimiter (x:[]) = [addDelim d x]- addDelimiter (x:xs) = if length x > 1- then (addDelim d x ++ [ODel afterColDel]) : addDelimiter xs- else (addDelim d x ++ [ODel d ]) : addDelimiter xs- namesOf = map (fst . snd) . getNamesYear True- process = flip Output emptyFormatting . concat . addDelimiter .- map (collapsYS . format) . groupBy (\a b -> namesOf a == namesOf b) -collapseYearSuf :: Bool -> String -> [Output] -> [Output]+ collapseRange = if null ranged then map (uncurry addCiteAffixes)+ else collapseYearSuf isRanged yearSufDel++ rmAffixes x = x {citePrefix = emptyAffix, citeSuffix = emptyAffix}+ collapsYS a = case a of+ [] -> (emptyCite, ONull)+ [x] -> rmAffixes . fst &&& uncurry addCiteAffixes $ x+ _ -> (,) (rmAffixes $ fst $ head a) . flip Output emptyFormatting .+ addDelim d . collapseRange .+ uncurry zip . second format . unzip $ a++ doCollapse [] = []+ doCollapse (x:[]) = [collapsYS x]+ doCollapse (x:xs) = let (a,b) = collapsYS x+ in if length x > 1+ then (a, Output (b : [ODel afterColDel]) emptyFormatting) : doCollapse xs+ else (a, Output (b : [ODel d ]) emptyFormatting) : doCollapse xs++ contribsQ o+ | OContrib _ _ c _ _ <- o = [c]+ | otherwise = []+ namesOf = query contribsQ+ process = doCollapse . groupBy (\a b -> namesOf (snd a) == namesOf (snd b))++collapseYearSuf :: Bool -> String -> [(Cite,Output)] -> [Output] collapseYearSuf ranged ysd = process where yearOf = concat . query getYear@@ -100,13 +124,25 @@ | otherwise = [] processYS = if ranged then collapseYearSufRanged else id- process = map (flip Output emptyFormatting . getYS) .- groupBy (\a b -> yearOf a == yearOf b)+ process = map (flip Output emptyFormatting . getYS) . groupBy comp + checkAffix (PlainText []) = True+ checkAffix (PandocText []) = True+ checkAffix _ = False++ comp a b = yearOf (snd a) == yearOf (snd b) &&+ checkAffix (citePrefix $ fst a) &&+ checkAffix (citeSuffix $ fst a) &&+ checkAffix (citePrefix $ fst b) &&+ checkAffix (citeSuffix $ fst b) &&+ null (citeLocator $ fst a) &&+ null (citeLocator $ fst b)+ getYS [] = []+ getYS (x:[]) = return $ uncurry addCiteAffixes x getYS (x:xs) = if ranged- then proc rmOYearSuf x : addDelim ysd (processYS $ x : query rmOYear xs)- else addDelim ysd $ x : (processYS $ query rmOYear xs)+ then proc rmOYearSuf (snd x) : addDelim ysd (processYS $ (snd x) : query rmOYear (map snd xs))+ else addDelim ysd $ (snd x) : (processYS $ query rmOYear (map snd xs)) rmOYearSuf o | OYearSuf {} <- o = ONull | otherwise = o@@ -125,10 +161,40 @@ process xs = flip concatMap (newSuf xs) $ \(x,f) -> if length x > 2 then return $ Output [ OStr [chr $ head x] f- , ODel "-"+ , OPan [Str "\x2013"] , OStr [chr $ last x] f ] emptyFormatting else map (\y -> if y == 0 then ONull else flip OStr f . return . chr $ y) x++addCiteAffixes :: Cite -> Output -> Output+addCiteAffixes = format+ where+ format c x = if isNumStyle [x]+ then x+ else flip Output emptyFormatting $+ addCiteAff citePrefix True c ++ [x] +++ addCiteAff citeSuffix False c+ addCiteAff g x c =+ case g c of+ PlainText [] -> []+ PlainText p | x -> [Output (rtfParser emptyFormatting p) emptyFormatting, OSpace]+ PlainText p -> [Output (rtfParser emptyFormatting p) emptyFormatting]+ PandocText [] -> []+ PandocText p | x -> [OPan p, OSpace]+ PandocText p -> [OPan p]++isNumStyle :: [Output] -> Bool+isNumStyle = null . query authorOrDate . proc rmLocator+ where+ rmLocator o+ | OLoc {} <- o = ONull+ | otherwise = o+ authorOrDate o+ | OContrib {} <- o = ['a']+ | OYear {} <- o = ['a']+ | OYearSuf {} <- o = ['a']+ | OStr {} <- o = ['a']+ | otherwise = [] -- | Group consecutive integers: --
src/Text/CSL/Proc/Disamb.hs view
@@ -20,8 +20,8 @@ import Control.Arrow ( (&&&), (>>>), second ) import Data.Char ( chr )-import Data.List ( elemIndex, find, findIndex, sortBy, mapAccumL- , nub, groupBy, isPrefixOf )+import Data.List ( elemIndex, elemIndices, find, findIndex, sortBy, mapAccumL+ , nub, nubBy, groupBy, isPrefixOf ) import Data.Maybe import Data.Ord ( comparing ) @@ -47,23 +47,29 @@ -- name data of name duplicates nameDupls = getDuplNameData groups -- citation data of ambiguous cites- duplics = getDuplCiteData hasNamesOpt $ addGName groups+ duplics = getDuplCiteData hasNamesOpt hasYSuffOpt groups -- check the options set in the style- --isByCite = getOptionVal "givenname-disambiguation-rule" (citOptions . citation $ s) == "by-cite"- disOpts = getCitDisambOptions s+ isByCite = let gno = getOptionVal "givenname-disambiguation-rule" (citOptions $ citation s)+ in gno == "by-cite" || gno == []+ disOpts = getCitDisambOptions s hasNamesOpt = "disambiguate-add-names" `elem` disOpts hasGNameOpt = "disambiguate-add-givenname" `elem` disOpts hasYSuffOpt = "disambiguate-add-year-suffix" `elem` disOpts+ givenNames = if hasGNameOpt+ then if isByCite then ByCite else AllNames+ else NoGiven - withNames = flip map duplics $ same . proc rmNameHash . proc rmGivenNames .+ clean = if hasGNameOpt then id else proc rmNameHash . proc rmGivenNames+ withNames = flip map duplics $ same . clean . map (if hasNamesOpt then disambData else return . disambYS) - needNames = filter_ (not . snd) $ zip (map disambAddNames duplics) withNames- needYSuff = filter_ snd $ zip (map disambAddLast duplics) withNames+ needNames = filter_ (not . snd) $ zip duplics withNames+ needYSuff = filter_ snd $ zip duplics withNames newNames :: [CiteData]- newNames = when_ hasNamesOpt $ needNames ++ needYSuff+ newNames = when_ (hasNamesOpt || hasGNameOpt) $ disambAddNames givenNames $ needNames +++ if hasYSuffOpt && givenNames == NoGiven then [] else needYSuff newGName :: [NameData] newGName = when_ hasGNameOpt $ concatMap disambAddGivenNames nameDupls@@ -76,38 +82,44 @@ then map (uncurry $ reEvaluate s reEval) $ zip refs groups else groups - addGName = proc (updateOutput [] newGName)- addNames = proc (updateOutput newNames newGName)- withYearS = if hasYSuffOpt then map (mapCitationGroup $ setYearSuffCollision hasNamesOpt needYSuff) $ reEvaluated else rmYearSuff $ reEvaluated yearSuffs = when_ hasYSuffOpt . generateYearSuffix bibs . query getYearSuffixes $ withYearS + addNames = proc (updateContrib givenNames newNames newGName) processed = if hasYSuffOpt then proc (updateYearSuffixes yearSuffs) . addNames $ withYearS else addNames $ withYearS - citOutput = if disOpts /= [] then processed else groups+ citOutput = if disOpts /= [] then processed else reEvaluated mapDisambData :: (Output -> Output) -> CiteData -> CiteData-mapDisambData f (CD k c ys d r y) = CD k c ys (proc f d) r y+mapDisambData f (CD k c ys d r s y) = CD k c ys (proc f d) r s y mapCitationGroup :: ([Output] -> [Output]) -> CitationGroup -> CitationGroup mapCitationGroup f (CG cs fm d os) = CG cs fm d (zip (map fst os) . f $ map snd os) -disambAddNames :: [CiteData] -> [CiteData]-disambAddNames needName = addLNames- where- disSolved = zip needName (disambiguate $ map disambData needName)- addLNames = map (\(c,n) -> c { disambed = if null n then collision c else head n }) disSolved+data GiveNameDisambiguation+ = NoGiven+ | ByCite+ | AllNames+ deriving (Show, Eq) -disambAddLast :: [CiteData] -> [CiteData]-disambAddLast = map last_+disambAddNames :: GiveNameDisambiguation -> [CiteData] -> [CiteData]+disambAddNames b needName = addLNames where- last_ c = c { disambed = if disambData c /= [] then last $ disambData c else collision c }+ clean = if b == NoGiven then proc rmNameHash . proc rmGivenNames else id+ disSolved = zip needName' . disambiguate . map disambData $ needName'+ needName' = nub' needName []+ addLNames = map (\(c,n) -> c { disambed = if null n then collision c else head n }) disSolved+ nub' [] r = r+ nub' (x:xs) r = case elemIndex (disambData $ clean x) (map (disambData . clean) r) of+ Nothing -> nub' xs (x:r)+ Just i -> let y = r !! i+ in nub' xs (y {sameAs = key x : sameAs y} : filter (/= y) r) disambAddGivenNames :: [NameData] -> [NameData] disambAddGivenNames needName = addGName@@ -115,17 +127,23 @@ disSolved = zip needName (disambiguate $ map nameDisambData needName) addGName = map (\(c,n) -> c { nameDataSolved = if null n then nameCollision c else head n }) disSolved --- | Given the list of 'CiteData' with the disambiguated field set--- update the evaluated citations by setting the contributor list--- accordingly.-updateOutput :: [CiteData] -> [NameData] -> Output -> Output-updateOutput c n o- | OContrib k r x _ d <- o = case elemIndex (CD k (clean x) [] [] [] []) c of- Just i -> OContrib k r (disambed $ c !! i) [] d- _ -> o+updateContrib :: GiveNameDisambiguation -> [CiteData] -> [NameData] -> Output -> Output+updateContrib g c n o+ | OContrib k r s d dd <- o = case filter (key &&& sameAs >>> uncurry (:) >>> elem k) c of+ x:_ | clean (disambData x) == clean (d:dd) ->+ OContrib k r (map processGNames $ disambed x) [] dd+ _ | null c, AllNames <- g -> OContrib k r (map processGNames s) d dd+ | otherwise -> o+ | otherwise = o+ where+ clean = if g == NoGiven then proc rmNameHash . proc rmGivenNames else id+ processGNames = if g /= NoGiven then updateOName n else id++updateOName :: [NameData] -> Output -> Output+updateOName n o | OName _ _ [] _ <- o = o | OName k x _ f <- o = case elemIndex (ND k (clean x) [] []) n of- Just i -> OName k (nameDataSolved $ n !! i) [] f+ Just i -> OName [] (nameDataSolved $ n !! i) [] f _ -> o | otherwise = o where@@ -135,11 +153,12 @@ -- field set to 'True' (for matching the @\"disambiguate\"@ -- condition). reEvaluate :: Style -> [CiteData] -> [(Cite, Reference)] -> CitationGroup -> CitationGroup-reEvaluate (Style {citation = ct, csMacros = ms , styleLocale = lo}) l cr (CG a f d os)+reEvaluate (Style {citation = ct, csMacros = ms , styleLocale = lo,+ styleAbbrevs = as}) l cr (CG a f d os) = CG a f d . flip concatMap (zip cr os) $ \((c,r),out) -> if refId r `elem` map key l then return . second (flip Output emptyFormatting) $- (,) c $ evalLayout (citLayout ct) (EvalCite c) True lo ms (citOptions ct) r+ (,) c $ evalLayout (citLayout ct) (EvalCite c) True lo ms (citOptions ct) as r else [out] -- | Check if the 'Style' has any conditional for disambiguation. In@@ -159,28 +178,46 @@ filter (isPrefixOf "disambiguate" . fst) . citOptions . citation -- | Group citation data (with possible alternative names) of--- citations which have a duplicate (same 'collision' and same--- 'citYear'). If the first 'Bool' is 'False', then we need to--- retrieve data for year suffix disambiguation.-getDuplCiteData :: Bool -> [CitationGroup] -> [[CiteData]]-getDuplCiteData b g+-- citations which have a duplicate (same 'collision', and same+-- 'citYear' if year suffix disambiiguation is used). If the first+-- 'Bool' is 'False', then we need to retrieve data for year suffix+-- disambiguation. The second 'Bool' is 'True' when comparing both+-- year and contributors' names for finding duplicates (when the+-- year-suffix option is set).+getDuplCiteData :: Bool -> Bool -> [CitationGroup] -> [[CiteData]]+getDuplCiteData b1 b2 g = groupBy (\x y -> collide x == collide y) . sortBy (comparing collide) $ duplicates where- whatToGet = if b then collision else disambYS- collide = proc rmNameHash . proc rmGivenNames . whatToGet- citeData = nub $ concatMap (mapGroupOutput $ getCiteData) g- duplicates = filter (collide &&& citYear >>> flip elem (getDuplNamesYear b g)) citeData+ whatToGet = if b1 then collision else disambYS+ collide = proc rmExtras . proc rmNameHash . proc rmGivenNames . whatToGet+ citeData = nubBy (\a b -> collide a == collide b && key a == key b) $+ concatMap (mapGroupOutput $ getCiteData) g+ findDupl f = filter (flip (>) 1 . length . flip elemIndices (map f citeData) . f) citeData+ duplicates = if b2 then findDupl (collide &&& citYear)+ else findDupl collide+rmExtras :: [Output] -> [Output]+rmExtras os+ | Output x f : xs <- os = if null (rmExtras x)+ then rmExtras xs+ else Output (rmExtras x) f : rmExtras xs+ | OContrib _ _ x _ _ : xs <- os = OContrib [] [] x [] [] : rmExtras xs+ | OYear y _ f : xs <- os = OYear y [] f : rmExtras xs+ | ODel _ : xs <- os = rmExtras xs+ | OLoc _ _ : xs <- os = rmExtras xs+ | x : xs <- os = x : rmExtras xs+ | otherwise = [] -- | For an evaluated citation get its 'CiteData'. The disambiguated--- citation and the year fields are empty.+-- citation and the year fields are empty. Only the first list of+-- contributors' disambiguation data are collected for disambiguation+-- purposes. getCiteData :: Output -> [CiteData]-getCiteData- = contribs &&& years >>>- zipData+getCiteData out+ = (contribs &&& years >>> zipData) out where contribs x = if query contribsQ x /= [] then query contribsQ x- else [CD [] [] [] [] [] []]+ else [CD [] [] [] [] [] [] []] yearsQ = query getYears years o = if yearsQ o /= [] then yearsQ o else [([],[])] zipData = uncurry . zipWith $ \c y -> if key c /= []@@ -188,45 +225,8 @@ else c {key = fst y ,citYear = snd y} contribsQ o- | OContrib k _ c d dd <- o = [CD k c d dd [] []]+ | OContrib k _ _ d dd <- o = [CD k [out] d (d:dd) [] [] []] | otherwise = []---- | The contributors diambiguation data, the list of names and--- give-names, and the citation year ('OYear').-type NamesYear = ([Output],String)---- | Get the contributors list ('OContrib') and the year occurring in--- more then one citation.-getDuplNamesYear :: Bool -> [CitationGroup] -> [NamesYear]-getDuplNamesYear b- = nub . catMaybes . snd . mapAccumL dupl [] . getData- where- getData = nub . concatMap (mapGroupOutput $ getNamesYear b)- dupl a c = if snd c `elem` a- then (a,Just $ snd c) else (snd c:a,Nothing)---- | Get the list of citation keys coupled with their 'NamesYear' in--- the evaluated 'Output'. If the 'Bool' is 'False' then the function--- retrieves the names used in citations not occuring for the first--- time.-getNamesYear :: Bool -> Output -> [(String,NamesYear)]-getNamesYear b- = proc rmNameHash >>>- proc rmGivenNames >>>- contribs &&& years >>>- zipData- where- contribs x = if query contribsQ x /= []- then query contribsQ x- else [([],[])]- yearsQ = query getYears- years o = if yearsQ o /= [] then yearsQ o else [([],[])]- zipData = uncurry . zipWith $ \(k,c) y -> if k /= []- then (,) k (c, snd y)- else (,) (fst y) (c, snd y)- contribsQ o- | OContrib k _ c d _ <- o = [(k,if b then c else d)]- | otherwise = [] getYears :: Output -> [(String,String)] getYears o
src/Text/CSL/Reference.hs view
@@ -128,64 +128,65 @@ -- | The 'Reference' record. data Reference = Reference- { refId :: String- , refType :: RefType+ { refId :: String+ , refType :: RefType - , author :: [Agent]- , editor :: [Agent]- , translator :: [Agent]- , recipient :: [Agent]- , interviewer :: [Agent]- , composer :: [Agent]- , originalAuthor :: [Agent]- , containerAuthor :: [Agent]- , collectionEditor :: [Agent]- , editorialDirector :: [Agent]+ , author :: [Agent]+ , editor :: [Agent]+ , translator :: [Agent]+ , recipient :: [Agent]+ , interviewer :: [Agent]+ , composer :: [Agent]+ , originalAuthor :: [Agent]+ , containerAuthor :: [Agent]+ , collectionEditor :: [Agent]+ , editorialDirector :: [Agent] - , issued :: [RefDate]- , eventDate :: [RefDate]- , accessed :: [RefDate]- , container :: [RefDate]- , originalDate :: [RefDate]+ , issued :: [RefDate]+ , eventDate :: [RefDate]+ , accessed :: [RefDate]+ , container :: [RefDate]+ , originalDate :: [RefDate] - , title :: String- , shortTitle :: String- , containerTitle :: String- , collectionTitle :: String- , collectionNumber :: String --Int- , originalTitle :: String- , publisher :: String- , originalPublisher :: String- , publisherPlace :: String- , authority :: String- , archive :: String- , archivePlace :: String- , archiveLocation :: String- , event :: String- , eventPlace :: String- , page :: String- , pageFirst :: String- , numberOfPages :: String- , version :: String- , volume :: String- , numberOfVolumes :: String --Int- , issue :: String- , chapterNumber :: String- , medium :: String- , status :: String- , edition :: String- , section :: String- , genre :: String- , note :: String- , annote :: String- , abstract :: String- , keyword :: String- , number :: String- , references :: String- , url :: String- , doi :: String- , isbn :: String- , categories :: [String]+ , title :: String+ , titleShort :: String+ , containerTitle :: String+ , collectionTitle :: String+ , containerTitleShort :: String+ , collectionNumber :: String --Int+ , originalTitle :: String+ , publisher :: String+ , originalPublisher :: String+ , publisherPlace :: String+ , authority :: String+ , archive :: String+ , archivePlace :: String+ , archiveLocation :: String+ , event :: String+ , eventPlace :: String+ , page :: String+ , pageFirst :: String+ , numberOfPages :: String+ , version :: String+ , volume :: String+ , numberOfVolumes :: String --Int+ , issue :: String+ , chapterNumber :: String+ , medium :: String+ , status :: String+ , edition :: String+ , section :: String+ , genre :: String+ , note :: String+ , annote :: String+ , abstract :: String+ , keyword :: String+ , number :: String+ , references :: String+ , url :: String+ , doi :: String+ , isbn :: String+ , categories :: [String] , citationNumber :: CNum , firstReferenceNoteNumber :: Int@@ -216,8 +217,9 @@ , originalDate = [] , title = []- , shortTitle = []+ , titleShort = [] , containerTitle = []+ , containerTitleShort = [] , collectionTitle = [] , collectionNumber = []@@ -259,6 +261,10 @@ , firstReferenceNoteNumber = 0 , citationLabel = [] }++numericVars :: [String]+numericVars = [ "edition", "volume", "number-of-volumes", "number", "issue", "citation-number"+ , "chapter-number", "collection-number", "number-of-pages"] parseLocator :: String -> (String, String) parseLocator s
src/Text/CSL/Style.hs view
@@ -18,6 +18,7 @@ import Data.List ( nubBy, isPrefixOf ) import Data.Generics ( Typeable, Data, everywhere , everywhere', everything, mkT, mkQ)+import qualified Data.Map as M import Text.JSON import Text.Pandoc.Definition ( Inline ) @@ -29,6 +30,7 @@ , styleInfo :: Maybe CSInfo , styleDefaultLocale :: String , styleLocale :: [Locale]+ , styleAbbrevs :: [Abbrev] , csOptions :: [Option] , csMacros :: [MacroMap] , citation :: Citation@@ -63,6 +65,9 @@ newDate x = nubBy (\(Date _ a _ _ _ _) (Date _ b _ _ _ _) -> a == b) (concatMap localeDate x ++ localeDate l) +type Abbrev+ = (String, [(String, M.Map String String)])+ type TermMap = ((String,Form),(String,String)) @@ -222,6 +227,13 @@ = NamePart String Formatting deriving ( Show, Eq, Typeable, Data ) +isPlural :: Plural -> Int -> Bool+isPlural p l+ = case p of+ Always -> True+ Never -> False+ Contextual -> l > 1+ isName :: Name -> Bool isName x = case x of Name {} -> True; _ -> False @@ -294,12 +306,13 @@ -- | The formatted output, produced after post-processing the -- evaluated citations. data FormattedOutput- = FO Formatting [FormattedOutput]- | FN String Formatting- | FS String Formatting- | FDel String- | FPan [Inline]- | FNull+ = FO Formatting [FormattedOutput] -- ^ List of 'FormatOutput' items+ | FN String Formatting -- ^ Formatted number+ | FS String Formatting -- ^ Formatted string+ | FUrl String Formatting -- ^ Formatted uniform resource locator (URL)+ | FDel String -- ^ Delimeter string+ | FPan [Inline] -- ^ Pandoc inline elements+ | FNull -- ^ Null formatting item deriving ( Eq, Show ) -- | The 'Output' generated by the evaluation of a style. Must be@@ -318,6 +331,8 @@ | OContrib String String [Output] [Output] [[Output]] -- ^ The citation key, the role (author, editor, etc.), the contributor(s), -- the output needed for year suf. disambiguation, and everything used for -- name disambiguation.+ | OUrl String Formatting -- ^ A uniform resource locator (URL)+ | OLoc [Output] Formatting -- ^ The citation's locator | Output [Output] Formatting -- ^ Some nested 'Output' deriving ( Eq, Ord, Show, Typeable, Data ) @@ -357,9 +372,10 @@ emptyCite :: Cite emptyCite = Cite [] emptyAffix emptyAffix [] [] [] [] False False False 0 --- | A citation group: a list of evaluated citations, the 'Formatting'--- to be applied to them, and the 'Delimiter' between individual--- citations.+-- | A citation group: the first list has a single member when the+-- citation group starts with an "author-in-text" cite, the+-- 'Formatting' to be applied, the 'Delimiter' between individual+-- citations and the list of evaluated citations. data CitationGroup = CG [(Cite, Output)] Formatting Delimiter [(Cite, Output)] deriving ( Show, Eq, Typeable, Data ) data BiblioData@@ -369,11 +385,12 @@ } deriving ( Show ) -- | A record with all the data to produce the 'FormattedOutput' of a--- citation: the citation key, the part of the citation that may be--- colliding with other citations (the list of contributors for the--- same year), the data to disambiguate it (all possible contributors--- and all possible given names), and the disambiguated citation and--- its year.+-- citation: the citation key, the part of the formatted citation that+-- may be colliding with other citations, the form of the citation+-- when a year suffix is used for disambiguation , the data to+-- disambiguate it (all possible contributors and all possible given+-- names), and, after processing, the disambiguated citation and its+-- year, initially empty. data CiteData = CD { key :: String@@ -381,12 +398,13 @@ , disambYS :: [Output] , disambData :: [[Output]] , disambed :: [Output]+ , sameAs :: [String] , citYear :: String } deriving ( Show, Typeable, Data ) instance Eq CiteData where- (==) (CD ka ca _ _ _ _)- (CD kb cb _ _ _ _) = ka == kb && ca == cb+ (==) (CD ka ca _ _ _ _ _)+ (CD kb cb _ _ _ _ _) = ka == kb && ca == cb data NameData = ND@@ -421,7 +439,7 @@ formatOutput :: Output -> FormattedOutput formatOutput o | OSpace <- o = FDel " "- | OPan i <- o = FPan i+ | OPan i <- o = FPan i | ODel [] <- o = FNull | ODel s <- o = FDel s | OStr [] _ <- o = FNull@@ -430,8 +448,10 @@ | OYearSuf s _ _ f <- o = FS s f | ONum i f <- o = FS (show i) f | OCitNum i f <- o = FN (add00 i) f+ | OUrl s f <- o = FUrl s f | OName _ s _ f <- o = FO f (format s) | OContrib _ _ s _ _ <- o = FO emptyFormatting (format s)+ | OLoc os f <- o = FO f (format os) | Output os f <- o = FO f (format os) | otherwise = FNull where@@ -465,12 +485,6 @@ rmNameHash o | OName _ s ss f <- o = OName [] s ss f | otherwise = o---- | Removes all contributors' names.-rmContribs :: Output -> Output-rmContribs o- | OContrib s r _ _ _ <- o = OContrib s r [] [] []- | otherwise = o -- | Add, with 'proc', a give name to the family name. Needed for -- disambiguation.
src/Text/CSL/Test.hs view
@@ -47,7 +47,7 @@ import qualified Data.ByteString.UTF8 as BS ( toString ) import Text.CSL.Parser ( localeFiles ) #else-import Foreign+import System.IO.Unsafe import Data.IORef import Paths_citeproc_hs ( getDataFileName ) import Text.CSL.Parser ( readLocaleFile )@@ -59,6 +59,7 @@ { testMode :: String , testInput :: [Reference] , testCSL :: Style+ , testAbbrevs :: [Abbrev] , testResult :: String , testBibSect :: BibOpts , testCitItems :: Maybe Citations@@ -66,7 +67,7 @@ } deriving ( Show ) toTest :: JSValue -> Test-toTest ob = Test mode input style result bibsection cites cites'+toTest ob = Test mode input style abbrevs result bibsection cites cites' where getObj f = case procJSObject f ob of JSObject o -> fromJSObject o@@ -82,6 +83,10 @@ mode = look "mode" result = look "result" + abbrevs = case lookup "abbreviations" object of+ Just o -> readJsonAbbrev o+ _ -> []+ bibsection = case lookup "bibsection" objectI of Just (JSObject o) -> getBibOpts $ fromJSObject o _ -> Select [] []@@ -125,7 +130,7 @@ readTestFile :: FilePath -> IO JSValue readTestFile f = do s <- readFile f- let fields = ["CSL","RESULT","MODE","INPUT","CITATION-ITEMS","CITATIONS","BIBSECTION","BIBENTRIES"]+ let fields = ["CSL","RESULT","MODE","INPUT","CITATION-ITEMS","CITATIONS","BIBSECTION","BIBENTRIES", "ABBREVIATIONS"] format = map (toLower . \x -> if x == '-' then '_' else x) return . toJson . zip (map format fields) . map (fieldsParser s) $ fields @@ -165,8 +170,6 @@ | Superscript is <- i = "<sup>" ++ pandocToHTML is ++ "</sup>" ++ pandocToHTML xs | Subscript is <- i = "<sub>" ++ pandocToHTML is ++ "</sub>" ++ pandocToHTML xs | Space <- i = " " ++ pandocToHTML xs- | EnDash <- i = "–" ++ pandocToHTML xs- | Ellipses <- i = "…" ++ pandocToHTML xs | Quoted t is <- i = case t of DoubleQuote -> "“" ++ pandocToHTML is ++ "”" ++ pandocToHTML xs SingleQuote -> "‘" ++ pandocToHTML is ++ "’" ++ pandocToHTML xs@@ -196,7 +199,7 @@ #ifndef EMBED_DATA_FILES localeCache :: IORef [(String, Locale)]-localeCache = unsafePerformIO $ newIORef []+localeCache = System.IO.Unsafe.unsafePerformIO $ newIORef [] getCachedLocale :: String -> IO [Locale] getCachedLocale n = maybe [] return `fmap` lookup n `fmap` readIORef localeCache@@ -230,7 +233,8 @@ #endif let opts = procOpts { bibOpts = testBibSect t} style' = testCSL t- style = style' {styleLocale = mergeLocales (styleDefaultLocale style') ls $ styleLocale style'}+ style = style' {styleLocale = mergeLocales (styleDefaultLocale style') ls $ styleLocale style'+ ,styleAbbrevs = testAbbrevs t} cites = case (testCitations t, testCitItems t) of (Just cs, _ ) -> cs (_, Just cs) -> cs
test/test.hs view
@@ -1,10 +1,18 @@ import System.Environment+import Text.CSL.Eval (split) import Text.CSL.Test -- a dir with a final slash-testDir = "citeproc-test/processor-tests/machines/"+testDir = "citeproc-test/processor-tests/machines/"+testDirH = "citeproc-test/processor-tests/humans/" main :: IO () main = do args <- getArgs- runTS args 0 testDir+ case args of+ [x,y,z] -> if z == "txt"+ then test_ 2 (testDirH ++ x ++ "_" ++ y ++ ".txt" ) >> return ()+ else test' 2 (testDir ++ x ++ "_" ++ y ++ ".json") >> return ()+ [x,y] -> test' 2 (testDir ++ x ++ "_" ++ y ++ ".json") >> return ()+ [x] -> runTS (split (== ',') x) 0 testDir+ x -> runTS x 0 testDir