diff --git a/README b/README --- a/README +++ b/README @@ -50,12 +50,16 @@ [citeproc-hs] can be downloaded from [Hackage]: - + To get the darcs source run: darcs get http://code.haskell.org/citeproc-hs/ +**NOTE**: is presently down. The darcs + repository may be accessed at: + + Installation ------------ @@ -124,10 +128,10 @@ Documentation ------------- -[Haddock] documentation for the exported API is available at the -following address: +[Haddock] documentation for the exported API is available on +[Hackage]: - + ### Some notes about name parsing @@ -195,12 +199,11 @@ present time. Specifically the [display] attribute has not been implemented yet. -The [citeproc-hs]-0.3.0 release passes 401 out of 537 tests of the +The [citeproc-hs]-0.3.2 release passes 411 out of 537 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 -rich text formatting (flip-flopping, specifically) and multi-language -names. +multi-language names. The [MODS] parser needs some refinement too. diff --git a/citeproc-hs.cabal b/citeproc-hs.cabal --- a/citeproc-hs.cabal +++ b/citeproc-hs.cabal @@ -1,6 +1,6 @@ name: citeproc-hs -version: 0.3.1 -homepage: http://code.haskell.org/citeproc-hs +version: 0.3.2 +homepage: http://gorgias.mine.nu/repos/citeproc-hs/ synopsis: A Citation Style Language implementation in Haskell description: citeproc-hs is a library for rendering @@ -16,7 +16,8 @@ license: BSD3 license-file: LICENSE author: Andrea Rossato -maintainer: andrea.rossato@ing.unitn.it +maintainer: andrea.rossato@unitn.it +bug-reports: http://code.google.com/p/citeproc-hs/issues/list cabal-version: >= 1.6 build-type: Simple data-files: locales/locales-af-ZA.xml diff --git a/src/Text/CSL.hs b/src/Text/CSL.hs --- a/src/Text/CSL.hs +++ b/src/Text/CSL.hs @@ -61,7 +61,6 @@ , renderPlainStrict , renderPandoc , renderPandoc' - , renderPandocStrict , headInline , initInline , tailFirstInlineStr diff --git a/src/Text/CSL/Eval.hs b/src/Text/CSL/Eval.hs --- a/src/Text/CSL/Eval.hs +++ b/src/Text/CSL/Eval.hs @@ -105,7 +105,7 @@ evalElement el | Choose i ei e <- el = evalIfThen i ei e | Macro s fm <- el = return . appendOutput fm =<< evalElements =<< getMacro s - | Const s fm <- el = return . output fm $ s + | Const s fm <- el = return $ rtfParser fm $ unescape s | Number s f fm <- el = formatNumber f fm =<< getStringVar s | Variable s f fm d <- el = return . addDelim d =<< concatMapM (getVariable f fm) s | Group fm d l <- el = when' ((/=) [] <$> tryGroup l) $ @@ -239,17 +239,26 @@ parser = parseText <|> parseMarkup parseText = do - x <- many $ noneOf "<'\"`" - xs <- option [] parseMarkup - ys <- option [] parseQuotes - return (OStr x emptyFormatting : xs ++ ys) + x <- many $ noneOf "<'\"`“‘&" + xs <- parseQuotes <|> parseMarkup + 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 r <- manyTill anyChar $ try $ string $ "" + Just tf -> do let ot = "<" ++ fst tf ++ ">" + ct = "" + 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 <- many $ noneOf "<" + Nothing -> do r <- tillTag return [OStr ("<" ++ m ++ ">" ++ r) emptyFormatting] return [Output res emptyFormatting] @@ -257,8 +266,14 @@ ,parseQ "\"" "\"" ,parseQ "``" "''" ,parseQ "`" "'" + ,parseQ "“" "”" + ,parseQ "‘" "’" + ,parseQ "'" "'" + ,parseQ """ """ + ,parseQ """ """ + ,parseQ "'" "'" ] - parseQ a b = do + parseQ a b = try $ do q <- string a >> manyTill anyChar (try $ string b) return [Output (rtfParser emptyFormatting q) (emptyFormatting {quotes = True})] @@ -366,6 +381,12 @@ sb' = reverse sb comp a b = let b' = takeWhile isDigit b in take (length b') a == b' + +unescape :: String -> String +unescape [] = [] +unescape ('&':'l':'t':';':xs) = "<" ++ unescape xs +unescape ('&':'g':'t':';':xs) = ">" ++ unescape xs +unescape (x :xs) = x : unescape xs last' :: [a] -> [a] last' = foldl (\_ x -> [x]) [] diff --git a/src/Text/CSL/Eval/Names.hs b/src/Text/CSL/Eval/Names.hs --- a/src/Text/CSL/Eval/Names.hs +++ b/src/Text/CSL/Eval/Names.hs @@ -204,18 +204,21 @@ | isOptionSet' "et-al-min" "et-al-subsequent-min" , le <- etAlMin' "et-al-min" "et-al-subsequent-min" , length as >= le - , length as > 1 = (,) True le + , length as > 1 = (,) True getUseFirst | otherwise = (,) False $ length as where etAlMin x = read $ getOptionVal x os etAlMin' x y = if b then etAlMin x else read $ getOptionVal' x y - isOptionSet' s1 s2 = if b then isOptionSet s1 os else or $ (isOptionSet s1 os) : [(isOptionSet s2 os)] getOptionVal' s1 s2 = if null (getOptionVal s1 os) then getOptionVal s2 os else getOptionVal s1 os + getUseFirst = let u = if b + then getOptionVal "et-al-use-first" os + 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 diff --git a/src/Text/CSL/Input/Json.hs b/src/Text/CSL/Input/Json.hs --- a/src/Text/CSL/Input/Json.hs +++ b/src/Text/CSL/Input/Json.hs @@ -353,11 +353,17 @@ | Strong is <- i = "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs | Superscript is <- i = "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs | Subscript is <- i = "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs - | Quoted _ is <- i = "“" ++ pandocToHTML is ++ "”" ++ 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 | Link is x <- i = case snd x of + "emph" -> "" ++ + pandocToHTML is ++ "" ++ pandocToHTML xs + "strong" -> "" ++ + pandocToHTML is ++ "" ++ pandocToHTML xs "nodecor" -> "" ++ pandocToHTML is ++ "" ++ pandocToHTML xs "baseline" -> "" ++ @@ -367,6 +373,8 @@ | otherwise = [] where check ('&':[]) = "&" + check ('<':ys) = "<" ++ check ys + check ('>':ys) = ">" ++ check ys check (y :ys) = y : check ys check [] = [] diff --git a/src/Text/CSL/Output/Pandoc.hs b/src/Text/CSL/Output/Pandoc.hs --- a/src/Text/CSL/Output/Pandoc.hs +++ b/src/Text/CSL/Output/Pandoc.hs @@ -15,7 +15,6 @@ module Text.CSL.Output.Pandoc ( renderPandoc - , renderPandocStrict , renderPandoc' , renderPandoc_ , headInline @@ -36,30 +35,24 @@ -- the native 'Pandoc' formats (i.e. immediately readable by pandoc). renderPandoc :: Style -> [FormattedOutput] -> [Inline] renderPandoc s - = proc (clean s) . concatMap (render s False) + = 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) . concatMap (render s False) + = Para . 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) . concatMap (render s False) - --- | Same as 'renderPandoc', but will not clean up the produced --- output. -renderPandocStrict :: Style -> [FormattedOutput] -> [Inline] -renderPandocStrict s - = concatMap (render s True) + = proc (clean' s $ isPunctuationInQuote s) . concatMap (flipFlop . render s) -render :: Style -> Bool -> FormattedOutput -> [Inline] -render _ _ (FPan i) = i -render _ _ (FDel s) = toStr s -render sty b fo +render :: Style -> FormattedOutput -> [Inline] +render _ (FPan i) = i +render _ (FDel s) = toStr s +render sty fo | 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 @@ -75,10 +68,10 @@ toPandoc f i = addSuffix f $ toStr (prefix f) ++ (format f . quote f . proc cleanStrict $ i) format f = font_variant f . font f . text_case f - rest xs = procList xs $ concatMap (render sty b) + rest xs = procList xs $ concatMap (render sty) quote f i = if i /= [] && quotes f - then [Quoted DoubleQuote . valign f $ i] - else valign f i + then [Quoted DoubleQuote . valign f $ i] + else valign f i setCase f i | Str s <- i = Str $ f s @@ -87,13 +80,17 @@ | Link s r <- i = Link (map (setCase f) s) r | otherwise = setCase f i - toCap s = if s /= [] then toUpper (head s) : map toLower (tail s) else [] + toCap s = if s /= [] then toUpper (head s) : map toLower (tail s) else [] + toTitleCap s = if isShortWord s then toUpper (head s) : tail s else s + isShortWord s = not $ s `elem` ["a","an","and","the","at","by","for","of" + ,"in","up","on","as","but","if","or","nor"] text_case _ [] = [] text_case fm a@(i:is) | noCase fm = [escape "nocase" a] | "lowercase" <- textCase fm = map (setCase' $ map toLower) a | "uppercase" <- textCase fm = map (setCase' $ map toUpper) a - | "capitalize-all" <- textCase fm = map (setCase $ unwords . map toCap . words) a + | "capitalize-all" <- textCase fm = map (setCase $ unwords . map toCap . words) a + | "title" <- textCase fm = map (setCase $ unwords . map toTitleCap . words) a | "capitalize-first" <- textCase fm = [setCase capitalize i] ++ is | "sentence" <- textCase fm = [setCase toCap i] ++ map (setCase $ map toLower) is @@ -112,7 +109,7 @@ valign _ [] = [] valign fm i - | "sup" <- verticalAlign fm = [Superscript i] -- FIXME + | "sup" <- verticalAlign fm = [Superscript i] | "sub" <- verticalAlign fm = [Subscript i] | "baseline" <- verticalAlign fm = [escape "baseline" i] | otherwise = i @@ -137,45 +134,87 @@ , Str sb:xs <- is = Str (sa ++ sb) : cleanStrict xs | otherwise = i : cleanStrict is -clean :: Style -> [Inline] -> [Inline] -clean _ [] = [] -clean s (i:is) - | Superscript x <- i = split (isLink "baseline") (return . Superscript) x - | Subscript x <- i = split (isLink "baseline") (return . Subscript ) x - | Link x _ <- i = clean' s (x ++ clean s is) - | otherwise = clean' s (i : clean s is) +clean :: Style -> Bool -> [Inline] -> [Inline] +clean _ _ [] = [] +clean s b (i:is) + | Superscript x <- i = split (isLink "baseline") (return . Superscript) x ++ clean s b is + | Subscript x <- i = split (isLink "baseline") (return . Subscript ) x ++ clean s b is + | 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) where unwrap f ls - | Link x _ : _ <- ls = clean' s x + | Link x _ : _ <- ls = clean' s b x | _ : _ <- ls = f ls | otherwise = [] isLink l il | Link _ (x,y) <- il = x == l && x == y | otherwise = False - + isLink' l il + | Link _ (x,y) <- il = (x == l || x == "nodecor") && x == y + | otherwise = False split _ _ [] = [] split f g xs = let (y, r) = break f xs in concatMap (unwrap g) [y, head' r] ++ split f g (tail' r) -clean' :: Style -> [Inline] -> [Inline] -clean' _ [] = [] -clean' s (i:is) +clean' :: Style -> Bool -> [Inline] -> [Inline] +clean' _ _ [] = [] +clean' s b (i:is) | Quoted t inls <- i - , punctIn s = case headInline is of + , b = case headInline is of [x] -> if isPunctuation x - then Quoted t (inls ++ [Str [x]]) : clean' s (tailInline is) - else i : clean' s is - _ -> i : clean' s is + then Quoted t (reverseQuoted t inls ++ [Str [x]]) : clean' s b (tailInline is) + else Quoted t (reverseQuoted t inls ) : clean' s b is + _ -> Quoted t (reverseQuoted t inls) : clean' s b is + | Quoted t inls <- i = Quoted t (reverseQuoted t inls) : clean' s b is | otherwise = if lastInline [i] == headInline is && isPunct - then i : clean' s (tailInline is) - else i : clean' s is + then i : clean' s b (tailInline is) + else i : clean' s b is where - punctIn = or . query punctIn' + isPunct = and . map (flip elem ".,;:!? ") $ headInline is + reverseQuoted t = proc reverseQuoted' + where + reverseQuoted' q + | Quoted _ qs <- q + , DoubleQuote <- t = Quoted SingleQuote (reverseQuoted SingleQuote qs) + | Quoted _ qs <- q + , SingleQuote <- t = Quoted DoubleQuote (reverseQuoted DoubleQuote qs) + | otherwise = q + +flipFlop :: [Inline] -> [Inline] +flipFlop [] = [] +flipFlop (i:is) + | Emph inls <- i = Emph (reverseEmph True inls) : flipFlop is + | Strong inls <- i = Strong (reverseStrong True inls) : flipFlop is + | otherwise = i : flipFlop is + where + reverseEmph bo = map reverseEmph' + where + reverseEmph' e + | bo, Emph inls <- e = Link (reverseEmph False inls) ("emph","emph") + | Emph inls <- e = Emph (reverseEmph True inls) + | Link ls (x,y) <- e = if x == "nodecor" && x == y + then Link ls ("emph","emph") + else e + | otherwise = e + reverseStrong bo = map reverseStrong' + where + reverseStrong' e + | bo, Strong inls <- e = Link (reverseStrong False inls) ("strong","strong") + | Strong inls <- e = Strong (reverseStrong True inls) + | Link ls (x,y) <- e = if x == "nodecor" && x == y + then Link ls ("strong","strong") + else e + | otherwise = e + +isPunctuationInQuote :: Style -> Bool +isPunctuationInQuote = or . query punctIn' + where punctIn' n | ("punctuation-in-quote","true") <- n = [True] | otherwise = [False] - - isPunct = and . map (flip elem ".,;:!? ") $ headInline is endWithPunct, startWithPunct :: [Inline] -> Bool endWithPunct = and . map (`elem` ".,;:!?") . lastInline diff --git a/src/Text/CSL/Reference.hs b/src/Text/CSL/Reference.hs --- a/src/Text/CSL/Reference.hs +++ b/src/Text/CSL/Reference.hs @@ -157,6 +157,7 @@ , publisher :: String , originalPublisher :: String , publisherPlace :: String + , authority :: String , archive :: String , archivePlace :: String , archiveLocation :: String @@ -224,6 +225,7 @@ , publisher = [] , originalPublisher = [] , publisherPlace = [] + , authority = [] , archive = [] , archivePlace = [] , archiveLocation = [] diff --git a/src/Text/CSL/Style.hs b/src/Text/CSL/Style.hs --- a/src/Text/CSL/Style.hs +++ b/src/Text/CSL/Style.hs @@ -16,8 +16,8 @@ module Text.CSL.Style where import Data.List ( nubBy, isPrefixOf ) -import Data.Generics ( Typeable, Data - , everywhere, everything, mkT, mkQ) +import Data.Generics ( Typeable, Data, everywhere + , everywhere', everything, mkT, mkQ) import Text.JSON import Text.Pandoc.Definition ( Inline ) @@ -445,6 +445,11 @@ -- | A generic processing function. proc :: (Typeable a, Data b) => (a -> a) -> b -> b proc f = everywhere (mkT f) + +-- | A generic processing function: process a data structure in +-- top-down manner. +proc' :: (Typeable a, Data b) => (a -> a) -> b -> b +proc' f = everywhere' (mkT f) -- | A generic query function. query :: (Typeable a, Data b) => (a -> [c]) -> b -> [c]