xml-conduit 1.2.0.3 → 1.2.1
raw patch · 5 files changed
+73/−24 lines, 5 files
Files
- Text/XML.hs +1/−0
- Text/XML/Stream/Parse.hs +49/−23
- Text/XML/Unresolved.hs +1/−0
- test/main.hs +21/−0
- xml-conduit.cabal +1/−1
Text/XML.hs view
@@ -53,6 +53,7 @@ -- ** Parsing , ParseSettings , psDecodeEntities+ , P.psRetainNamespaces -- *** Entity decoding , P.decodeXmlEntities , P.decodeHtmlEntities
Text/XML/Stream/Parse.hs view
@@ -60,6 +60,7 @@ , def , DecodeEntities , psDecodeEntities+ , psRetainNamespaces -- *** Entity decoding , decodeXmlEntities , decodeHtmlEntities@@ -132,25 +133,40 @@ type Ents = [(Text, Text)] -tokenToEvent :: Ents -> [NSLevel] -> Token -> (Ents, [NSLevel], [Event])-tokenToEvent es n (TokenBeginDocument _) = (es, n, [])-tokenToEvent es n (TokenInstruction i) = (es, n, [EventInstruction i])-tokenToEvent es n (TokenBeginElement name as isClosed _) =+tokenToEvent :: ParseSettings -> Ents -> [NSLevel] -> Token -> (Ents, [NSLevel], [Event])+tokenToEvent _ es n (TokenBeginDocument _) = (es, n, [])+tokenToEvent _ es n (TokenInstruction i) = (es, n, [EventInstruction i])+tokenToEvent ps es n (TokenBeginElement name as isClosed _) = (es, n', if isClosed then [begin, end] else [begin]) where l0 = case n of [] -> NSLevel Nothing Map.empty x:_ -> x (as', l') = foldl' go (id, l0) as- go (front, l) (TName kpref kname, val)- | kpref == Just "xmlns" =- (front, l { prefixes = Map.insert kname (contentsToText val)- $ prefixes l })- | isNothing kpref && kname == "xmlns" =- (front, l { defaultNS = if T.null $ contentsToText val- then Nothing- else Just $ contentsToText val })- | otherwise = (front . (:) (TName kpref kname, map resolve val), l)+ go (front, l) (TName kpref kname, val) =+ (addNS front, l'')+ where+ isPrefixed = kpref == Just "xmlns"+ isUnprefixed = isNothing kpref && kname == "xmlns"++ addNS+ | not (psRetainNamespaces ps) && (isPrefixed || isUnprefixed) = id+ | otherwise = (((tname, map resolve val):) .)+ where+ tname+ | isPrefixed = TName Nothing ("xmlns:" `T.append` kname)+ | otherwise = TName kpref kname++ l''+ | isPrefixed =+ l { prefixes = Map.insert kname (contentsToText val)+ $ prefixes l }+ | isUnprefixed =+ l { defaultNS = if T.null $ contentsToText val+ then Nothing+ else Just $ contentsToText val }+ | otherwise = l+ resolve (ContentEntity e) | Just t <- lookup e es = ContentText t resolve c = c@@ -159,19 +175,19 @@ elementName = tnameToName False l' name begin = EventBeginElement elementName $ map fixAttName $ as' [] end = EventEndElement elementName-tokenToEvent es n (TokenEndElement name) =+tokenToEvent _ es n (TokenEndElement name) = (es, n', [EventEndElement $ tnameToName False l name]) where (l, n') = case n of [] -> (NSLevel Nothing Map.empty, []) x:xs -> (x, xs)-tokenToEvent es n (TokenContent (ContentEntity e))+tokenToEvent _ es n (TokenContent (ContentEntity e)) | Just t <- lookup e es = (es, n, [EventContent $ ContentText t])-tokenToEvent es n (TokenContent c) = (es, n, [EventContent c])-tokenToEvent es n (TokenComment c) = (es, n, [EventComment c])-tokenToEvent es n (TokenDoctype t eid es') = (es ++ es', n, [EventBeginDoctype t eid, EventEndDoctype])-tokenToEvent es n (TokenCDATA t) = (es, n, [EventCDATA t])+tokenToEvent _ es n (TokenContent c) = (es, n, [EventContent c])+tokenToEvent _ es n (TokenComment c) = (es, n, [EventComment c])+tokenToEvent _ es n (TokenDoctype t eid es') = (es ++ es', n, [EventBeginDoctype t eid, EventEndDoctype])+tokenToEvent _ es n (TokenCDATA t) = (es, n, [EventCDATA t]) tnameToName :: Bool -> NSLevel -> TName -> Name tnameToName _ _ (TName (Just "xml") name) =@@ -265,7 +281,7 @@ parseText de = dropBOM =$= tokenize- =$= toEventC+ =$= toEventC de =$= addBeginEnd where tokenize = conduitToken de@@ -274,8 +290,8 @@ (yield (Nothing, EventEndDocument)) (\e -> yield e >> addEnd) -toEventC :: Monad m => Conduit (PositionRange, Token) m EventPos-toEventC =+toEventC :: Monad m => ParseSettings -> Conduit (PositionRange, Token) m EventPos+toEventC ps = go [] [] where go !es !levels =@@ -284,15 +300,25 @@ push (position, token) = mapM_ (yield . (,) (Just position)) events >> go es' levels' where- (es', levels', events) = tokenToEvent es levels token+ (es', levels', events) = tokenToEvent ps es levels token data ParseSettings = ParseSettings { psDecodeEntities :: DecodeEntities+ , psRetainNamespaces :: Bool+ -- ^ Whether the original xmlns attributes should be retained in the parsed+ -- values. For more information on motivation, see:+ --+ -- <https://github.com/snoyberg/xml/issues/38>+ --+ -- Default: False+ --+ -- Since 1.2.1 } instance Default ParseSettings where def = ParseSettings { psDecodeEntities = decodeXmlEntities+ , psRetainNamespaces = False } conduitToken :: MonadThrow m => ParseSettings -> Conduit TS.Text m (PositionRange, Token)
Text/XML/Unresolved.hs view
@@ -34,6 +34,7 @@ -- ** Parse , P.ParseSettings , P.psDecodeEntities+ , P.psRetainNamespaces -- ** Render , R.RenderSettings , R.rsPretty
test/main.hs view
@@ -89,6 +89,7 @@ describe "ordering attributes explicitly" $ do it "works" caseOrderAttrs it "parsing CDATA" caseParseCdata+ it "retains namespaces when asked" caseRetainNamespaces documentParseRender :: IO () documentParseRender =@@ -539,3 +540,23 @@ ]) [] Res.parseLBS_ def lbs @?= doc++caseRetainNamespaces :: Assertion+caseRetainNamespaces = do+ let lbs = "<foo xmlns:bar='baz'><bar:bin/><bin3 xmlns='bin4'></bin3></foo>"+ doc = Res.parseLBS_ def { Res.psRetainNamespaces = True } lbs+ doc `shouldBe` Res.Document+ (Res.Prologue [] Nothing [])+ (Res.Element+ "foo"+ (Map.singleton "xmlns:bar" "baz")+ [ Res.NodeElement $ Res.Element+ "{baz}bin"+ Map.empty+ []+ , Res.NodeElement $ Res.Element+ "{bin4}bin3"+ (Map.singleton "xmlns" "bin4")+ []+ ])+ []
xml-conduit.cabal view
@@ -1,5 +1,5 @@ name: xml-conduit-version: 1.2.0.3+version: 1.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michaels@suite-sol.com>, Aristid Breitkreuz <aristidb@googlemail.com>