diff --git a/citeproc-hs.cabal b/citeproc-hs.cabal --- a/citeproc-hs.cabal +++ b/citeproc-hs.cabal @@ -1,5 +1,5 @@ name: citeproc-hs -version: 0.3.5 +version: 0.3.6 homepage: http://gorgias.mine.nu/repos/citeproc-hs/ synopsis: A Citation Style Language implementation in Haskell @@ -30,14 +30,15 @@ locales/locales-de-CH.xml locales/locales-de-DE.xml locales/locales-el-GR.xml - locales/locales-en-US.xml locales/locales-en-GB.xml + locales/locales-en-US.xml locales/locales-es-ES.xml locales/locales-et-EE.xml locales/locales-eu.xml locales/locales-fa-IR.xml locales/locales-fi-FI.xml - locales/locales-fr-FR.xml + locales/locales-fr-CA.xml + locales/locales-fr-FR.xml locales/locales-he-IL.xml locales/locales-hu-HU.xml locales/locales-is-IS.xml @@ -45,6 +46,7 @@ locales/locales-ja-JP.xml locales/locales-km-KH.xml locales/locales-ko-KR.xml + locales/locales-lt-LT.xml locales/locales-mn-MN.xml locales/locales-nb-NO.xml locales/locales-nl-NL.xml @@ -76,6 +78,10 @@ description: Use network and HTTP to retrieve csl file from URIs. default: True +flag hexpat + description: Use hexpat to parse XML + default: True + flag embed_data_files description: Embed locale files into the library (needed for windows packaging) default: False @@ -104,7 +110,7 @@ ghc-options: -funbox-strict-fields -Wall ghc-prof-options: -prof -auto-all hs-source-dirs: src - build-depends: containers, directory, mtl, xml, json, utf8-string, + build-depends: containers, directory, mtl, json, utf8-string, bytestring, filepath, pandoc-types >= 1.8 && < 1.11 if flag(bibutils) @@ -116,6 +122,14 @@ build-depends: network >= 2, HTTP >= 4000.0.9 extensions: CPP cpp-options: -DUSE_NETWORK + + if flag(hexpat) + build-depends: hexpat >= 0.20.2 + exposed-modules: Text.CSL.Pickle.Hexpat + cpp-options: -DUSE_HEXPAT + else + build-depends: xml + exposed-modules: Text.CSL.Pickle.Xml if flag(embed_data_files) build-depends: template-haskell, file-embed diff --git a/src/Text/CSL/Input/Bibutils.hs b/src/Text/CSL/Input/Bibutils.hs --- a/src/Text/CSL/Input/Bibutils.hs +++ b/src/Text/CSL/Input/Bibutils.hs @@ -17,6 +17,7 @@ , BibFormat (..) ) where +import Data.ByteString.Lazy.UTF8 ( fromString ) import Data.Char import System.FilePath ( takeExtension ) import Text.CSL.Pickle @@ -83,7 +84,7 @@ readBiblioString :: BibFormat -> String -> IO [Reference] readBiblioString b s - | Mods <- b = return $ readXmlString xpModsCollection s + | Mods <- b = return $ readXmlString xpModsCollection (fromString s) | Json <- b = return $ readJsonInputString s | Native <- b = return $ decodeJSON s #ifdef USE_BIBUTILS diff --git a/src/Text/CSL/Parser.hs b/src/Text/CSL/Parser.hs --- a/src/Text/CSL/Parser.hs +++ b/src/Text/CSL/Parser.hs @@ -22,7 +22,7 @@ import Text.CSL.Pickle #ifdef EMBED_DATA_FILES import Data.FileEmbed -import qualified Data.ByteString as BS +import qualified Data.ByteString as S import Data.ByteString.UTF8 ( toString ) #else import Paths_citeproc_hs ( getDataFileName ) @@ -31,6 +31,8 @@ import Data.Char ( isUpper, toUpper, toLower ) import Data.Maybe ( catMaybes ) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.UTF8 ( fromString ) #ifdef USE_NETWORK import Network.HTTP ( getResponseBody, mkRequest, RequestMethod(..) ) @@ -54,18 +56,20 @@ #else f <- readFile' src #endif - parseCSL f + parseCSL' f -- | Parse a 'String' into a fully localized 'Style' parseCSL :: String -> IO Style -parseCSL f = do +parseCSL = parseCSL' . fromString + +parseCSL' :: L.ByteString -> IO Style +parseCSL' f = do let s = readXmlString xpStyle f l <- readLocaleFile (styleDefaultLocale s) return s { styleLocale = mergeLocales (styleDefaultLocale s) l (styleLocale s)} - #ifdef EMBED_DATA_FILES -localeFiles :: [(FilePath, BS.ByteString)] +localeFiles :: [(FilePath, L.ByteString)] localeFiles = $(embedDir "locales/") #endif @@ -82,7 +86,7 @@ | otherwise -> case lookup ("locales-" ++ take 5 x ++ ".xml") localeFiles of Just x' -> return x' _ -> error "could not load the locale file" - return $ readXmlString xpLocale (toString f) + return $ readXmlString xpLocale f #else f <- case s of x | length x == 2 -> getDataFileName ("locales/locales-" ++ diff --git a/src/Text/CSL/Pickle.hs b/src/Text/CSL/Pickle.hs --- a/src/Text/CSL/Pickle.hs +++ b/src/Text/CSL/Pickle.hs @@ -22,10 +22,14 @@ import Data.List ( elemIndex ) import Data.Maybe import System.Directory ( doesFileExist ) -import qualified Data.ByteString as B -import Data.ByteString.UTF8 ( toString ) +import qualified Data.ByteString.Lazy as L +#ifdef USE_HEXPAT +import Text.CSL.Pickle.Hexpat +#else +import Text.CSL.Pickle.Xml import Text.XML.Light +#endif data St = St { attributes :: [Attr] @@ -38,7 +42,7 @@ } pickleXML :: PU a -> a -> String -pickleXML p v = concatMap showContent $ contents st +pickleXML p v = concatMap showXML $ contents st where st = appPickle p (v, emptySt) unpickleXML :: PU a -> [Content] -> Maybe a @@ -59,11 +63,11 @@ addCont x s = s {contents = x : contents s} dropCont :: St -> St -dropCont s = s { contents = drop 1 (contents s) } +dropCont s = s { contents = dropFirstElem (contents s)} getAtt :: String -> St -> Maybe Attr getAtt name - = listToMaybe . filter ((==) name . qName . attrKey) . attributes + = listToMaybe . filter ((==) name . getAttName) . attributes getCont :: St -> Maybe Content getCont = listToMaybe . contents @@ -234,35 +238,6 @@ -------------------------------------------------------------------------------- -getText :: Content -> Maybe String -getText c - | Text cd <- c = Just (showCData cd) - | otherwise = Nothing - -getChildren :: Content -> [Content] -getChildren c - | Elem el <- c = elContent el - | otherwise = [] - -getElemName :: Content -> Maybe QName -getElemName c - | Elem el <- c = Just (elName el) - | otherwise = Nothing - -getAttrl :: Content -> [Attr] -getAttrl c - | Elem el <- c = elAttribs el - | otherwise = [] - -mkText :: String -> Content -mkText str = Text $ blank_cdata { cdData = str} - -mkName :: String -> QName -mkName n = blank_name {qName = n} - -qualifiedName :: QName -> String -qualifiedName qn = (fromMaybe [] $ qPrefix qn) ++ qName qn - xpText :: PU String xpText = PU { appPickle = \ (s, st) -> addCont (mkText s) st @@ -271,9 +246,8 @@ where unpickleString st = do - t <- getCont st - s <- getText t - return (Just (unescape s), dropCont st) + s <- getText (contents st) + return (Just (unescape s), st {contents = dropText $ contents st}) xpText0 :: PU String xpText0 @@ -288,21 +262,21 @@ let st' = appPickle pa (a, emptySt) in - addCont (Elem $ Element (mkName name) (attributes st') (contents st') Nothing) st + addCont (mkElement name (attributes st') (contents st')) st ) , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st) } where unpickleElement st = do - e <- listToMaybe . map Elem . onlyElems . contents $ st + e <- listToMaybe . onlyElems' . contents $ st n <- getElemName e if qualifiedName n /= name then fail "element name does not match" else do al <- Just $ getAttrl e res <- fst . appUnPickle pa $ St {attributes = al, contents = getChildren e} - return (Just res, st {contents = filter ((/=) (show e) . show) $ contents st}) + return (Just res, dropCont st) -- | A pickler for interleaved elements. xpIElem :: String -> PU a -> PU a @@ -311,14 +285,14 @@ let st' = appPickle pa (a, emptySt) in - addCont (Elem $ Element (mkName name) (attributes st') (contents st') Nothing) st + addCont (mkElement name (attributes st') (contents st')) st ) , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st) } where unpickleElement st = do - let t = map Elem . onlyElems . contents $ st + let t = onlyElems' . contents $ st ns <- mapM getElemName t case elemIndex name (map qualifiedName ns) of Nothing -> fail "element name does not match" @@ -334,19 +308,16 @@ let st' = appPickle pa (a, emptySt) in - addAtt (Attr (mkName name) (getAtVal $ contents st')) st + addAtt (mkAttribute name $ getAttrVal $ contents st') st ) , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleAttr st) } where - getAtVal at - | Text cd : _ <- at = cdData cd - | otherwise = [] unpickleAttr st = do a <- getAtt name st res <- fst . appUnPickle pa $ St { attributes = [] - , contents = [Text blank_cdata {cdData = attrVal a}]} + , contents = [attrToCont a]} return (Just res, st) xpElemWithAttrValue :: String -> String -> String -> PU a -> PU a @@ -383,38 +354,16 @@ unescape ('&':'a':'m':'p':';':xs) = "&" ++ unescape xs unescape (x: xs) = x : unescape xs -readXmlString :: Show a => PU a -> String -> a -readXmlString xp str = - case parseXML str of - [] -> error $ "error while reading the style" - x -> case unpickleXML xp x of - Just a -> a - _ -> case getStyleVersion x of - (_:_) -> error "error while parsing the style" - _ -> error styleErr08 +readXmlString :: Show a => PU a -> L.ByteString -> a +readXmlString xp s + = case unpickleXML xp $ parseXML' s of + Just a -> a + _ -> error "error while parsing the XML string" -readXmlFile :: Show a => PU a -> String -> IO a +readXmlFile :: Show a => PU a -> FilePath -> IO a readXmlFile xp f = readXmlString xp `fmap` readFile' f -readFile' :: FilePath -> IO String +readFile' :: FilePath -> IO L.ByteString readFile' f = do flip unless (error $ f ++ " file does not exist") =<< doesFileExist f - toString `fmap` B.readFile f - -getStyleVersion :: [Content] -> String -getStyleVersion c - = case filterElems c of - [x] -> case lookupAttr styleVersion (elAttribs x) of - Just s -> s - _ -> [] - _ -> error "malformed style: no cs:style element found" - where - filterElems = catMaybes . map (filterElementName isStyle) . onlyElems - styleVersion = mkName "version" - isStyle (QName qn _ _) = qn == "style" - -styleErr08 :: String -styleErr08 - = "the parsed style seems to be CSL-0.8 while citeproc-hs only supports CSL 1.0.\n" ++ - "Styles may be updated by using the csl-utils. For more information see:\n" ++ - "http://citationstyles.org/downloads/upgrade-notes.html#updating-csl-0-8-styles" + L.readFile f diff --git a/src/Text/CSL/Pickle/Hexpat.hs b/src/Text/CSL/Pickle/Hexpat.hs new file mode 100644 --- /dev/null +++ b/src/Text/CSL/Pickle/Hexpat.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.CSL.Pickle.Hexpat +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Andrea Rossato +-- Stability : unstable +-- Portability : portable +-- +----------------------------------------------------------------------------- + +module Text.CSL.Pickle.Hexpat where + +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.UTF8 ( toString ) +import Data.Maybe +import Text.XML.Expat.Tree hiding ( mkText, getText, getChildren ) +import Text.XML.Expat.Format +import Text.XML.Expat.Proc + +type Content = UNode String +type Attr = (String, String) + +showXML :: Content -> String +showXML = toString . format + +getText :: [Content] -> Maybe String +getText [] = Nothing +getText (c:xs) + | Text x <- c = Just (x ++ getAllText xs) + | otherwise = Nothing + +getAllText :: [Content] -> String +getAllText [] = [] +getAllText (c:xs) + | Text cd <- c = cd ++ getAllText xs + | otherwise = [] + +dropFirstElem :: [Content] -> [Content] +dropFirstElem [] = [] +dropFirstElem (x:xs) + | Text {} <- x = dropFirstElem xs + | otherwise = xs + +dropText :: [Content] -> [Content] +dropText [] = [] +dropText a@(c:cs) + | Text _ <- c = dropText cs + | otherwise = a + +getChildren :: Content -> [Content] +getChildren c + | Element _ _ x <- c = x + | otherwise = [] + +getElemName :: Content -> Maybe String +getElemName c + | Element x _ _ <- c = Just x + | otherwise = Nothing + +getAttName :: Attr -> String +getAttName = reverse . takeWhile (/= ':') . reverse . fst + +getAttrl :: Content -> [Attr] +getAttrl c + | Element _ x _ <- c = x + | otherwise = [] + +getAttrVal :: [Content] -> String +getAttrVal at + | Text cd : _ <- at = cd + | otherwise = [] + +mkText :: String -> Content +mkText = Text + +mkName :: String -> String +mkName = id + +mkElement :: String -> [Attr] -> [Content] -> Content +mkElement n a c = Element n a c + +mkAttribute :: String -> String -> Attr +mkAttribute n v = (n, v) + +attrToCont :: Attr -> Content +attrToCont = Text . snd + +qualifiedName :: String -> String +qualifiedName = id + +onlyElems' :: [Content] -> [Content] +onlyElems' = onlyElems + +parseXML' :: L.ByteString -> [Content] +parseXML' s + = case parse defaultParseOptions s of + (_, Just e) -> error $ "error while reading the XML file: " ++ show e + (x, Nothing) -> return x diff --git a/src/Text/CSL/Pickle/Xml.hs b/src/Text/CSL/Pickle/Xml.hs new file mode 100644 --- /dev/null +++ b/src/Text/CSL/Pickle/Xml.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.CSL.Pickle.Xml +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Andrea Rossato +-- Stability : unstable +-- Portability : portable +-- +----------------------------------------------------------------------------- + +module Text.CSL.Pickle.Xml where + +import Data.ByteString.Lazy.UTF8 ( toString ) +import qualified Data.ByteString.Lazy as L +import Data.Maybe +import Text.XML.Light + +showXML :: Content -> String +showXML = showContent + +getText :: [Content] -> Maybe String +getText [] = Nothing +getText (c:_) + | Text x <- c = Just (showCData x) + | otherwise = Nothing + +getChildren :: Content -> [Content] +getChildren c + | Elem el <- c = elContent el + | otherwise = [] + +getElemName :: Content -> Maybe QName +getElemName c + | Elem el <- c = Just (elName el) + | otherwise = Nothing + +dropFirstElem :: [Content] -> [Content] +dropFirstElem [] = [] +dropFirstElem (x:xs) + | Text {} <- x = dropFirstElem xs + | otherwise = xs + +dropText :: [Content] -> [Content] +dropText [] = [] +dropText a@(x:xs) + | Text {} <- x = dropFirstElem xs + | otherwise = a + +getAttName :: Attr -> String +getAttName = qName . attrKey + +getAttrl :: Content -> [Attr] +getAttrl c + | Elem el <- c = elAttribs el + | otherwise = [] + +getAttrVal :: [Content] -> String +getAttrVal at + | Text cd : _ <- at = cdData cd + | otherwise = [] + +mkText :: String -> Content +mkText s = Text $ blank_cdata { cdData = s } + +attrToCont :: Attr -> Content +attrToCont a = Text $ blank_cdata { cdData = attrVal a } + +mkName :: String -> QName +mkName n = blank_name {qName = n } + +mkElement :: String -> [Attr] -> [Content] -> Content +mkElement n a c = Elem $ Element (mkName n) a c Nothing + +mkAttribute :: String -> String -> Attr +mkAttribute n c = Attr (mkName n) c + +qualifiedName :: QName -> String +qualifiedName qn = (fromMaybe [] $ qPrefix qn) ++ qName qn + +onlyElems' :: [Content] -> [Content] +onlyElems' = map Elem . onlyElems + +parseXML' :: L.ByteString -> [Content] +parseXML' s + = case parseXML (toString s) of + [] -> error $ "error while reading the XML string" + x -> x 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 @@ -35,7 +35,7 @@ , csMacros :: [MacroMap] , citation :: Citation , biblio :: Maybe Bibliography - } deriving ( Show, Typeable, Data ) + } deriving ( Show, Read, Typeable, Data ) data Locale = Locale @@ -44,7 +44,7 @@ , localeOptions :: [Option] , localeTermMap :: [TermMap] , localeDate :: [Element] - } deriving ( Show, Eq, Typeable, Data ) + } deriving ( Show, Read, Eq, Typeable, Data ) -- | With the 'defaultLocale', the locales-xx-XX.xml loaded file and -- the parsed 'Style' cs:locale elements, produce the final 'Locale' @@ -79,14 +79,14 @@ { citOptions :: [Option] , citSort :: [Sort] , citLayout :: Layout - } deriving ( Show, Typeable, Data ) + } deriving ( Show, Read, Typeable, Data ) data Bibliography = Bibliography { bibOptions :: [Option] , bibSort :: [Sort] , bibLayout :: Layout - } deriving ( Show, Typeable, Data ) + } deriving ( Show, Read, Typeable, Data ) type Option = (String,String) @@ -98,7 +98,7 @@ { layFormat :: Formatting , layDelim :: Delimiter , elements :: [Element] - } deriving ( Show, Typeable, Data ) + } deriving ( Show, Read, Typeable, Data ) data Element = Choose IfThen [IfThen] [Element] @@ -113,11 +113,11 @@ | Substitute [Element] | Group Formatting Delimiter [Element] | Date [String] DateForm Formatting Delimiter [DatePart] String - deriving ( Show, Eq, Typeable, Data ) + deriving ( Show, Read, Eq, Typeable, Data ) data IfThen = IfThen Condition Match [Element] - deriving ( Eq, Show, Typeable, Data ) + deriving ( Eq, Show, Read, Typeable, Data ) data Condition = Condition @@ -128,7 +128,7 @@ , isPosition :: [String] , disambiguation :: [String] , isLocator :: [String] - } deriving ( Eq, Show, Typeable, Data ) + } deriving ( Eq, Show, Read, Typeable, Data ) type Delimiter = String @@ -149,7 +149,7 @@ , dpForm :: String , dpRangeDelim :: String , dpFormatting :: Formatting - } deriving ( Show, Eq, Typeable, Data ) + } deriving ( Show, Read, Eq, Typeable, Data ) defaultDate :: [DatePart] defaultDate @@ -160,7 +160,7 @@ data Sort = SortVariable String Sorting | SortMacro String Sorting Int Int String - deriving ( Eq, Show, Typeable, Data ) + deriving ( Eq, Show, Read, Typeable, Data ) data Sorting = Ascending String @@ -219,13 +219,13 @@ = Name Form Formatting NameAttrs Delimiter [NamePart] | NameLabel Form Formatting Plural | EtAl Formatting String - deriving ( Eq, Show, Typeable, Data ) + deriving ( Eq, Show, Read, Typeable, Data ) type NameAttrs = [(String, String)] data NamePart = NamePart String Formatting - deriving ( Show, Eq, Typeable, Data ) + deriving ( Show, Read, Eq, Typeable, Data ) isPlural :: Plural -> Int -> Bool isPlural p l diff --git a/src/Text/CSL/Test.hs b/src/Text/CSL/Test.hs --- a/src/Text/CSL/Test.hs +++ b/src/Text/CSL/Test.hs @@ -23,6 +23,7 @@ import Control.Arrow import Control.Monad.State +import Data.ByteString.Lazy.UTF8 ( fromString ) import Data.Char (toLower) import Data.List import Data.Maybe (isJust) @@ -44,7 +45,7 @@ import Text.CSL.Style import Text.Pandoc.Definition #ifdef EMBED_DATA_FILES -import qualified Data.ByteString.UTF8 as BS ( toString ) +import Data.ByteString.UTF8 ( toString ) import Text.CSL.Parser ( localeFiles ) #else import System.IO.Unsafe @@ -79,7 +80,7 @@ look s = case lookup s object of Just (JSString x) -> fromJSString x _ -> error $ "in test " ++ s ++ " section." - style = readXmlString xpStyle $ look "csl" + style = readXmlString xpStyle . fromString $ look "csl" mode = look "mode" result = look "result" @@ -216,7 +217,7 @@ | otherwise -> take 5 x #ifdef EMBED_DATA_FILES ls <- case lookup ("locales-" ++ locale ++ ".xml") localeFiles of - Just x' -> return $ readXmlString xpLocale (BS.toString x') + Just x' -> return $ readXmlString xpLocale (toString x') _ -> return $ Locale [] [] [] [] [] #else ls' <- getCachedLocale locale