diff --git a/Text/XML.hs b/Text/XML.hs --- a/Text/XML.hs +++ b/Text/XML.hs @@ -53,6 +53,7 @@ -- ** Parsing , ParseSettings , psDecodeEntities + , P.psRetainNamespaces -- *** Entity decoding , P.decodeXmlEntities , P.decodeHtmlEntities 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 @@ -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: + -- + -- + -- + -- 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) diff --git a/Text/XML/Unresolved.hs b/Text/XML/Unresolved.hs --- a/Text/XML/Unresolved.hs +++ b/Text/XML/Unresolved.hs @@ -34,6 +34,7 @@ -- ** Parse , P.ParseSettings , P.psDecodeEntities + , P.psRetainNamespaces -- ** Render , R.RenderSettings , R.rsPretty diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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 = "" + 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") + [] + ]) + [] 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.2.0.3 +version: 1.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman , Aristid Breitkreuz