diff --git a/Text/XML/Stream/Parse.hs b/Text/XML/Stream/Parse.hs --- a/Text/XML/Stream/Parse.hs +++ b/Text/XML/Stream/Parse.hs @@ -159,9 +159,8 @@ , PositionRange , EventPos ) where -import Control.Applicative (Alternative ((<|>)), - Applicative (..), optional, - (<$>)) +import Control.Applicative (Alternative (empty, (<|>)), + Applicative (..), (<$>)) import qualified Control.Applicative as A import Control.Arrow ((***)) import Control.Exception (Exception (..), SomeException) @@ -390,12 +389,17 @@ parseTextPos :: MonadThrow m => ParseSettings -> Conduit T.Text m EventPos -parseTextPos de = dropBOM =$= tokenize =$= toEventC de =$= addBeginEnd where - tokenize = conduitToken de - addBeginEnd = yield (Nothing, EventBeginDocument) >> addEnd - addEnd = await >>= maybe - (yield (Nothing, EventEndDocument)) - (\e -> yield e >> addEnd) +parseTextPos de = + dropBOM + =$= tokenize + =$= toEventC de + =$= addBeginEnd + where + tokenize = conduitToken de + addBeginEnd = yield (Nothing, EventBeginDocument) >> addEnd + addEnd = await >>= maybe + (yield (Nothing, EventEndDocument)) + (\e -> yield e >> addEnd) toEventC :: Monad m => ParseSettings -> Conduit (PositionRange, Token) m EventPos toEventC ps = @@ -461,7 +465,7 @@ skipSpace char' '?' char' '>' - optional newline + newline <|> return () return $ TokenXMLDeclaration as else do skipSpace @@ -867,7 +871,7 @@ => String -- ^ Error message -> m (Maybe a) -- ^ Optional parser to be forced -> m a -force msg i = i >>= maybe (throwM $ XmlException msg) return +force msg i = i >>= maybe (throwM $ XmlException msg Nothing) return -- | A helper function which reads a file from disk using 'enumFile', detects -- character encoding using 'detectUtf', parses the XML using 'parseBytes', and @@ -885,37 +889,10 @@ -> Producer m Event parseLBS ps lbs = CL.sourceList (L.toChunks lbs) =$= parseBytes ps - -prettyEvent :: Event -> String -prettyEvent EventBeginDocument = "" -prettyEvent (EventBeginDoctype t externalID) = "" -prettyEvent EventEndDoctype = ">" -prettyEvent (EventInstruction (Instruction target data_)) = "" -prettyEvent (EventBeginElement name attributes) = "<" ++ prettyName name ++ " " ++ prettyAttributes attributes ++ ">" -prettyEvent (EventEndElement name) = "" -prettyEvent (EventContent content) = prettyContent content -prettyEvent (EventComment t) = "" -prettyEvent (EventCDATA t) = "" - -prettyAttributes :: [(Name, [Content])] -> String -prettyAttributes = intercalate " " . map (uncurry prettyAttribute) - -prettyAttribute :: Name -> [Content] -> String -prettyAttribute name content = prettyName name ++ "=\"" ++ concatMap prettyContent content ++ "\"" - -prettyExternalID :: ExternalID -> String -prettyExternalID (SystemID location) = "SYSTEM \"" ++ T.unpack location ++ "\"" -prettyExternalID (PublicID name location) = "PUBLIC \"" ++ T.unpack name ++ "\" \"" ++ T.unpack location ++ "\"" - -prettyContent :: Content -> String -prettyContent (ContentText t) = T.unpack t -prettyContent (ContentEntity t) = T.unpack t - -prettyName :: Name -> String -prettyName (Name name _namespace _prefix) = T.unpack name - -data XmlException = XmlException String +data XmlException = XmlException + { xmlErrorMessage :: String + , xmlBadInput :: Maybe Event + } | InvalidEndElement Name (Maybe Event) | InvalidEntity String (Maybe Event) | MissingAttribute String @@ -924,10 +901,11 @@ instance Exception XmlException where #if MIN_VERSION_base(4, 8, 0) - displayException (XmlException msg) = "Error while parsing XML: " ++ msg - displayException (InvalidEndElement name (Just event)) = "Error while parsing XML event: expected , got " ++ prettyEvent event + displayException (XmlException msg (Just event)) = "Error while parsing XML event " ++ show event ++ ": " ++ msg + displayException (XmlException msg _) = "Error while parsing XML: " ++ msg + displayException (InvalidEndElement name (Just event)) = "Error while parsing XML event: expected , got " ++ show event displayException (InvalidEndElement name _) = "Error while parsing XML event: expected , got nothing" - displayException (InvalidEntity msg (Just event)) = "Error while parsing XML entity " ++ prettyEvent event ++ ": " ++ msg + displayException (InvalidEntity msg (Just event)) = "Error while parsing XML entity " ++ show event ++ ": " ++ msg displayException (InvalidEntity msg _) = "Error while parsing XML entity: " ++ msg displayException (MissingAttribute msg) = "Missing required attribute: " ++ msg displayException (UnparsedAttributes attrs) = show (length attrs) ++ " remaining unparsed attributes: \n" ++ intercalate "\n" (show <$> attrs) @@ -995,7 +973,7 @@ pure = return (<*>) = ap instance Alternative AttrParser where - empty = AttrParser $ const $ Left $ toException $ XmlException "AttrParser.empty" + empty = AttrParser $ const $ Left $ toException $ XmlException "AttrParser.empty" Nothing AttrParser f <|> AttrParser g = AttrParser $ \x -> either (const $ g x) Right (f x) instance MonadThrow AttrParser where @@ -1043,24 +1021,24 @@ -- | Keep parsing elements as long as the parser returns 'Just'. many :: Monad m - => ConduitM i o m (Maybe a) - -> ConduitM i o m [a] + => ConduitM Event o m (Maybe a) + -> ConduitM Event o m [a] many i = manyIgnore i $ return Nothing -- | Like 'many' but discards the results without building an intermediate list. -- -- Since 1.5.0 many_ :: MonadThrow m - => ConduitM i o m (Maybe a) - -> ConduitM i o m () + => ConduitM Event o m (Maybe a) + -> ConduitM Event o m () many_ consumer = manyIgnoreYield (return Nothing) (void <$> consumer) -- | Keep parsing elements as long as the parser returns 'Just' -- or the ignore parser returns 'Just'. manyIgnore :: Monad m - => ConduitM i o m (Maybe a) - -> ConduitM i o m (Maybe b) - -> ConduitM i o m [a] + => ConduitM Event o m (Maybe a) + -> ConduitM Event o m (Maybe b) + -> ConduitM Event o m [a] manyIgnore i ignored = go id where go front = i >>= maybe (onFail front) (\y -> go $ front . (:) y) -- onFail is called if the main parser fails @@ -1085,9 +1063,9 @@ -- | Like 'manyIgnore', but uses 'yield' so the result list can be streamed -- to downstream conduits without waiting for 'manyIgnoreYield' to finish manyIgnoreYield :: MonadThrow m - => ConduitM i b m (Maybe b) -- ^ Consuming parser that generates the result stream - -> ConduitM i b m (Maybe ()) -- ^ Ignore parser that consumes elements to be ignored - -> Conduit i m b + => ConduitM Event b m (Maybe b) -- ^ Consuming parser that generates the result stream + -> ConduitM Event b m (Maybe ()) -- ^ Ignore parser that consumes elements to be ignored + -> Conduit Event m b manyIgnoreYield consumer ignoreParser = fix $ \loop -> consumer >>= maybe (onFail loop) (\x -> yield x >> loop) where onFail loop = ignoreParser >>= maybe (return ()) (const loop) diff --git a/Text/XML/Stream/Render.hs b/Text/XML/Stream/Render.hs --- a/Text/XML/Stream/Render.hs +++ b/Text/XML/Stream/Render.hs @@ -69,16 +69,16 @@ renderText rs = renderBytes rs =$= CT.decode CT.utf8 data RenderSettings = RenderSettings - { rsPretty :: Bool - , rsNamespaces :: [(Text, Text)] + { rsPretty :: Bool + , rsNamespaces :: [(Text, Text)] -- ^ Defines some top level namespace definitions to be used, in the form -- of (prefix, namespace). This has absolutely no impact on the meaning -- of your documents, but can increase readability by moving commonly -- used namespace declarations to the top level. - , rsAttrOrder :: Name -> Map.Map Name Text -> [(Name, Text)] + , rsAttrOrder :: Name -> Map.Map Name Text -> [(Name, Text)] -- ^ Specify how to turn the unordered attributes used by the "Text.XML" -- module into an ordered list. - , rsUseCDATA :: Content -> Bool + , rsUseCDATA :: Content -> Bool -- ^ Determines if for a given text content the renderer should use a -- CDATA node. -- @@ -129,7 +129,7 @@ renderBuilder :: Monad m => RenderSettings -> Conduit Event m Builder renderBuilder settings = CL.map Chunk =$= renderBuilder' yield' settings where - yield' Flush = return () + yield' Flush = return () yield' (Chunk bs) = yield bs -- | Same as 'renderBuilder' but allows you to flush XML stream to ensure that all @@ -192,7 +192,7 @@ eventToToken s useCDATA _ (EventContent c) | useCDATA c = case c of - ContentText txt -> (tokenToBuilder $ TokenCDATA txt, s) + ContentText txt -> (tokenToBuilder $ TokenCDATA txt, s) ContentEntity txt -> (tokenToBuilder $ TokenCDATA txt, s) | otherwise = (tokenToBuilder $ TokenContent c, s) eventToToken s _ _ (EventComment t) = (tokenToBuilder $ TokenComment t, s) @@ -208,7 +208,7 @@ | def' == Just ns = TName Nothing name | otherwise = case Map.lookup ns sl of - Nothing -> error "nameToTName" + Nothing -> error "nameToTName" Just pref -> TName (Just pref) name mkBeginToken :: Bool -- ^ pretty print attributes? @@ -224,7 +224,7 @@ where indent = if isPretty then 2 + 4 * length s else 0 prevsl = case s of - [] -> NSLevel Nothing Map.empty + [] -> NSLevel Nothing Map.empty sl':_ -> sl' (sl1, tname, tattrs1) = newElemStack prevsl name (sl2, tattrs2) = foldr newAttrStack (sl1, tattrs1) $ nubAttrs attrs @@ -236,7 +236,7 @@ (namespaceSL, namespaceAttrs) = unzip $ mapMaybe unused namespaces0 unused (k, v) = case lookup k' tattrs2 of - Just{} -> Nothing + Just{} -> Nothing Nothing -> Just ((v, k), (k', v')) where k' = TName (Just "xmlns") k @@ -300,7 +300,7 @@ where yield' = yield . Chunk - goC Flush = yield Flush >> prettify' level + goC Flush = yield Flush >> prettify' level goC (Chunk e) = go e go e@EventBeginDocument = do diff --git a/Text/XML/Stream/Token.hs b/Text/XML/Stream/Token.hs --- a/Text/XML/Stream/Token.hs +++ b/Text/XML/Stream/Token.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} module Text.XML.Stream.Token ( tokenToBuilder , TName (..) @@ -8,26 +8,21 @@ , NSLevel (..) ) where -import Blaze.ByteString.Builder (Builder, - copyByteString, - fromByteString, - writeByteString) -import Blaze.ByteString.Builder.Char.Utf8 (fromText, writeChar) -import qualified Blaze.ByteString.Builder.Char8 as BC8 -import Blaze.ByteString.Builder.Internal.Write (fromWriteList) -import Control.Arrow (first) -import Data.ByteString.Char8 () -import Data.List (foldl') -import Data.Map (Map) -import Data.Monoid (mappend, mconcat, - mempty) -import qualified Data.Set as Set -import Data.String (IsString (fromString)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.XML.Types (Content (..), - ExternalID (..), - Instruction (..)) +import Data.XML.Types (Instruction (..), Content (..), ExternalID (..)) +import qualified Data.Text as T +import Data.Text (Text) +import Data.String (IsString (fromString)) +import Blaze.ByteString.Builder + (Builder, fromByteString, writeByteString, copyByteString) +import Blaze.ByteString.Builder.Internal.Write (fromWriteList) +import Blaze.ByteString.Builder.Char.Utf8 (writeChar, fromText) +import Data.Monoid (mconcat, mempty, mappend) +import Data.ByteString.Char8 () +import Data.Map (Map) +import qualified Blaze.ByteString.Builder.Char8 as BC8 +import qualified Data.Set as Set +import Data.List (foldl') +import Control.Arrow (first) oneSpace :: Builder oneSpace = copyByteString " " @@ -63,17 +58,17 @@ (if isEmpty then fromByteString "/>" else fromByteString ">") where attrs = nubAttrs $ map (first splitTName) attrs' - lessThan3 [] = True - lessThan3 [_] = True + lessThan3 [] = True + lessThan3 [_] = True lessThan3 [_, _] = True - lessThan3 _ = False + lessThan3 _ = False tokenToBuilder (TokenEndElement name) = mconcat [ fromByteString "" ] tokenToBuilder (TokenContent c) = contentToText c -tokenToBuilder (TokenCDATA t) = +tokenToBuilder (TokenCDATA t) = copyByteString "" @@ -156,7 +151,7 @@ data NSLevel = NSLevel { defaultNS :: Maybe Text - , prefixes :: Map Text Text + , prefixes :: Map Text Text } deriving Show @@ -176,6 +171,6 @@ | otherwise = TName (Just a) $ T.drop 1 b where (a, b) = T.break (== ':') t - + escCDATA :: Text -> Builder escCDATA s = fromText (T.replace "]]>" "]]]]>" s) diff --git a/xml-conduit.cabal b/xml-conduit.cabal --- a/xml-conduit.cabal +++ b/xml-conduit.cabal @@ -1,5 +1,5 @@ name: xml-conduit -version: 1.7.1.1 +version: 1.7.1.2 license: MIT license-file: LICENSE author: Michael Snoyman , Aristid Breitkreuz