citeproc-hs 0.3.1 → 0.3.2

raw patch · 9 files changed

+146/−65 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README +10/−7
• citeproc-hs.cabal +4/−3
• src/Text/CSL.hs +0/−1
• src/Text/CSL/Eval.hs +29/−8
• src/Text/CSL/Eval/Names.hs +5/−2
• src/Text/CSL/Input/Json.hs +9/−1
• src/Text/CSL/Output/Pandoc.hs +80/−41
• src/Text/CSL/Reference.hs +2/−0
• src/Text/CSL/Style.hs +7/−2

@@ -50,12 +50,16 @@  [citeproc-hs] can be downloaded from [Hackage]: -<http://hackage.haskell.org/cgi-bin/hackage-scripts/package/citeproc-hs>+<http://hackage.haskell.org/package/citeproc-hs>  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/>+ 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]: -<http://code.haskell.org/citeproc-hs/docs/>+<http://hackage.haskell.org/package/citeproc-hs>  ### 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. 

@@ -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

@@ -61,7 +61,6 @@     , renderPlainStrict     , renderPandoc     , renderPandoc'-    , renderPandocStrict     , headInline     , initInline     , tailFirstInlineStr

@@ -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 $ "</" ++ fst tf ++ ">"+                 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 <- 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 "&#39;" "&#39;"+                           ,parseQ "&#34;" "&#34;"+                           ,parseQ "&quot;" "&quot;"+                           ,parseQ "&apos;" "&apos;"                            ]-      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]) []

@@ -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

@@ -353,11 +353,17 @@     | Strong      is <- i = "<b>" ++ pandocToHTML is ++ "</b>" ++ pandocToHTML xs     | Superscript is <- i = "<sup>" ++ pandocToHTML is ++ "</sup>" ++ pandocToHTML xs     | Subscript   is <- i = "<sub>" ++ pandocToHTML is ++ "</sub>" ++ 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"     -> "<span style=\"font-style:normal;\">" +++                                            pandocToHTML is ++ "</span>" ++ pandocToHTML xs+                              "strong"   -> "<span style=\"font-weight:normal;\">" +++                                            pandocToHTML is ++ "</span>" ++ pandocToHTML xs                               "nodecor"  -> "<span style=\"font-variant:normal;\">" ++                                             pandocToHTML is ++ "</span>" ++ pandocToHTML xs                               "baseline" -> "<span style=\"baseline\">" ++@@ -367,6 +373,8 @@     | otherwise           = []     where       check ('&':[]) = "&amp;"+      check ('<':ys) = "&lt;" ++ check ys+      check ('>':ys) = "&gt;" ++ check ys       check (y  :ys) = y : check ys       check []       = [] 

@@ -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

@@ -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     = []

@@ -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]