xml-conduit 0.7.0.2 → 0.7.0.3
raw patch · 4 files changed
+139/−90 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Text/XML/Stream/Render.hs +86/−72
- Text/XML/Stream/Token.hs +2/−2
- test/main.hs +49/−14
- xml-conduit.cabal +2/−2
Text/XML/Stream/Render.hs view
@@ -21,15 +21,15 @@ import Data.Conduit.Blaze (builderToByteString) import qualified Data.Map as Map import Data.Map (Map)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import Data.ByteString (ByteString)-import Data.Char (isSpace) import Data.Default (Default (def)) import qualified Data.Set as Set import Data.List (foldl') import qualified Data.Conduit as C+import Data.Conduit.Internal (sinkToPipe)+import qualified Data.Conduit.List as CL import qualified Data.Conduit.Text as CT-import Control.Exception (assert) import Control.Monad.Trans.Resource (MonadUnsafeIO) -- | Render a stream of 'Event's into a stream of 'ByteString's. This function@@ -60,11 +60,11 @@ -- the blaze-builder package, and allow the create of optimally sized -- 'ByteString's with minimal buffer copying. renderBuilder :: Monad m => RenderSettings -> C.Conduit Event m Builder-renderBuilder RenderSettings { rsPretty = True } = prettify C.=$= renderBuilder'-renderBuilder RenderSettings { rsPretty = False } = renderBuilder'+renderBuilder RenderSettings { rsPretty = True } = prettify C.=$= renderBuilder' True+renderBuilder RenderSettings { rsPretty = False } = renderBuilder' False -renderBuilder' :: Monad m => C.Conduit Event m Builder-renderBuilder' = C.conduitState+renderBuilder' :: Monad m => Bool -> C.Conduit Event m Builder+renderBuilder' isPretty = C.conduitState (id, []) push close@@ -79,10 +79,10 @@ : EventEndElement n2 : rest ) front | n1 == n2 =- let (token, stack') = mkBeginToken False True stack n1 as+ let (token, stack') = mkBeginToken isPretty True stack n1 as in go stack' atEnd rest (front . token) go stack atEnd (EventBeginElement name as:rest) front =- let (token, stack') = mkBeginToken False False stack name as+ let (token, stack') = mkBeginToken isPretty False stack name as in go stack' atEnd rest (front . token) go stack atEnd (e:rest) front = let (token, stack') = eventToToken stack e@@ -195,75 +195,89 @@ -- | Convert a stream of 'Event's into a prettified one, adding extra -- whitespace. Note that this can change the meaning of your XML. prettify :: Monad m => C.Conduit Event m Event-prettify = prettify' 0 []+prettify = prettify' 0 -prettify' :: Monad m => Int -> [Name] -> C.Conduit Event m Event-prettify' level0 names0 = C.conduitState- (id, (level0, names0))- push- close+prettify' :: Monad m => Int -> C.Conduit Event m Event+prettify' level = do+ me <- C.await+ case me of+ Nothing -> return ()+ Just e -> go e where- push (front, a) b = do- let (a', es) = go False a (front [b]) id- return $ C.StateProducing a' es- close (front, a) = do- let ((front', _), es) = go True a (front []) id- assert (null $ front' [])- $ return es-- go _ state [] front = ((id, state), front [])- go atEnd state@(level, _) es@(EventContent t:xs) front =- case takeContents (t:) xs of- Nothing- | not atEnd -> (((es++), state), front [])- | otherwise -> assert False $ error "Text.XML.Stream.Redner.prettify'"- Just (ts, xs') ->- let ts' = map EventContent $ cleanWhite ts- ts'' = if null ts' then [] else before level : ts' ++ [after]- in go atEnd state xs' (front . (ts'' ++))- go atEnd (level, names) (x:xs) front = do- go atEnd (level', names') xs' (front . chunks)- where- (chunks, level', names', xs') =- case (x, xs) of- (EventBeginElement name attrs, EventEndElement _:rest) ->- (\a -> before level : EventBeginElement name attrs : EventEndElement name : after : a, level, names, rest)- (EventBeginElement name attrs, _) ->- (\a -> before level : EventBeginElement name attrs : after : a, level + 1, name : names, xs)- (EventEndElement _, _) ->- let newLevel = level - 1- n:ns = names- in (\a -> before newLevel : EventEndElement n : after : a, newLevel, ns, xs)- (EventBeginDocument, _) -> ((EventBeginDocument:), level, names, xs)- (EventEndDocument, _) -> (\a -> EventEndDocument : a, level, names, xs)- (EventComment t, _) -> (\a -> before level : EventComment (T.map normalSpace t) : after : a, level, names, xs)- (e, _) -> (\a -> before level : e : after : a, level, names, xs)-- before l = EventContent $ ContentText $ T.replicate l " "- after = EventContent $ ContentText "\n"+ go e@EventBeginDocument = do+ C.yield e+ C.yield $ EventContent $ ContentText "\n"+ prettify' level+ go e@EventBeginElement{} = do+ C.yield before+ C.yield e+ mnext <- sinkToPipe CL.peek+ case mnext of+ Just next@EventEndElement{} -> do+ sinkToPipe $ CL.drop 1+ C.yield next+ C.yield after+ prettify' level+ _ -> do+ C.yield after+ prettify' $ level + 1+ go e@EventEndElement{} = do+ let level' = max 0 $ level - 1+ C.yield $ before' level'+ C.yield e+ C.yield after+ prettify' level'+ go (EventContent c) = do+ cs <- sinkToPipe $ takeContents (c:)+ let cs' = mapMaybe normalize cs+ case cs' of+ [] -> return ()+ _ -> do+ C.yield before+ mapM_ (C.yield . EventContent) cs'+ C.yield after+ prettify' level+ go (EventCDATA t) = go $ EventContent $ ContentText t+ go e@EventInstruction{} = do+ C.yield before+ C.yield e+ C.yield after+ prettify' level+ go (EventComment t) = do+ C.yield before+ C.yield $ EventComment $ T.concat+ [ " "+ , T.unwords $ T.words t+ , " "+ ]+ C.yield after+ prettify' level -takeContents :: ([Content] -> [Content]) -> [Event] -> Maybe ([Content], [Event])-takeContents _ [] = Nothing-takeContents front (EventContent t:es) = takeContents (front . (t:)) es-takeContents front es = Just (front [], es)+ go e@EventEndDocument = C.yield e >> prettify' level+ go e@EventBeginDoctype{} = C.yield e >> prettify' level+ go e@EventEndDoctype{} = C.yield e >> C.yield after >> prettify' level -normalSpace :: Char -> Char-normalSpace c- | isSpace c = ' '- | otherwise = c+ takeContents front = do+ me <- CL.peek+ case me of+ Just (EventContent c) -> do+ CL.drop 1+ takeContents $ front . (c:)+ Just (EventCDATA t) -> do+ CL.drop 1+ takeContents $ front . (ContentText t:)+ _ -> return $ front [] -cleanWhite :: [Content] -> [Content]-cleanWhite x =- go True [] $ go True [] x- where- go _ end (ContentEntity e:rest) = go False (ContentEntity e : end) rest- go isFront end (ContentText t:rest) =- if T.null t'- then go isFront end rest- else go False (ContentText t' : end) rest+ normalize (ContentText t)+ | T.null t' = Nothing+ | otherwise = Just $ ContentText t' where- t' = (if isFront then T.dropWhile isSpace else id) $ T.map normalSpace t- go _ end [] = end+ t' = T.unwords $ T.words t+ normalize c = Just c++ before = EventContent $ ContentText $ T.replicate level " "+ before' l = EventContent $ ContentText $ T.replicate l " "+ after = EventContent $ ContentText "\n" nubAttrs :: [(Name, v)] -> [(Name, v)] nubAttrs orig =
Text/XML/Stream/Token.hs view
@@ -39,7 +39,7 @@ tokenToBuilder :: Token -> Builder tokenToBuilder (TokenBeginDocument attrs) = fromByteString "<?xml"- `mappend` foldAttrs oneSpace attrs (fromByteString "?>\n")+ `mappend` foldAttrs oneSpace attrs (fromByteString "?>") tokenToBuilder (TokenInstruction (Instruction target data_)) = mconcat [ fromByteString "<?" , fromText target@@ -77,7 +77,7 @@ [ fromByteString "<!DOCTYPE " , fromText name , go eid- , fromByteString ">\n"+ , fromByteString ">" ] where go Nothing = mempty
test/main.hs view
@@ -6,6 +6,7 @@ import Data.XML.Types import Test.HUnit hiding (Test) import Test.Hspec.Monadic+import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import qualified Text.XML.Unresolved as D import qualified Text.XML.Stream.Parse as P@@ -66,6 +67,8 @@ it "works for resolvable entities" resolvedAllGood it "merges adjacent content nodes" resolvedMergeContent it "understands inline entity declarations" resolvedInline+ describe "pretty" $ do+ it "works" casePretty documentParseRender :: IO () documentParseRender =@@ -77,9 +80,9 @@ (Element "foo" [] []) [] , D.parseLBS_ def- "<?xml version=\"1.0\"?>\n<!DOCTYPE foo>\n<foo/>"+ "<?xml version=\"1.0\"?><!DOCTYPE foo>\n<foo/>" , D.parseLBS_ def- "<?xml version=\"1.0\"?>\n<!DOCTYPE foo>\n<foo><nested>&ignore;</nested></foo>"+ "<?xml version=\"1.0\"?><!DOCTYPE foo>\n<foo><nested>&ignore;</nested></foo>" , D.parseLBS_ def "<foo><![CDATA[this is some<CDATA content>]]></foo>" , D.parseLBS_ def@@ -92,15 +95,13 @@ documentParsePrettyRender :: IO () documentParsePrettyRender =- L.unpack (D.renderLBS def { D.rsPretty = True } (D.parseLBS_ def $ doc True)) @?= L.unpack (doc False)+ L.unpack (D.renderLBS def { D.rsPretty = True } (D.parseLBS_ def doc)) @?= L.unpack doc where- doc x = L.unlines+ doc = L.unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" , "<foo>" , " <?bar bar?>"- , if x- then " text"- else " text "+ , " text" , " <?bin bin?>" , "</foo>" ]@@ -116,7 +117,7 @@ liftIO $ x @?= Just "combine <all> &content" where input = L.concat- [ "<?xml version='1.0'?>\n"+ [ "<?xml version='1.0'?>" , "<!DOCTYPE foo []>\n" , "<hello world='true'>" , "<?this should be ignored?>"@@ -137,7 +138,7 @@ liftIO $ x @?= Just (2 :: Int) where input = L.concat- [ "<?xml version='1.0'?>\n"+ [ "<?xml version='1.0'?>" , "<!DOCTYPE foo []>\n" , "<hello>" , "<success/>"@@ -151,7 +152,7 @@ liftIO $ length x @?= 5 where input = L.concat- [ "<?xml version='1.0'?>\n"+ [ "<?xml version='1.0'?>" , "<!DOCTYPE foo []>\n" , "<hello>" , "<success/>"@@ -170,7 +171,7 @@ liftIO $ x @?= Just (2 :: Int) where input = L.concat- [ "<?xml version='1.0'?>\n"+ [ "<?xml version='1.0'?>" , "<!DOCTYPE foo []>\n" , "<hello>" , "<success/>"@@ -306,9 +307,9 @@ stripDuplicateAttributes :: Assertion stripDuplicateAttributes = do- "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo bar=\"baz\"/>" @=?+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo bar=\"baz\"/>" @=? D.renderLBS def (Document (Prologue [] Nothing []) (Element "foo" [("bar", [ContentText "baz"]), ("bar", [ContentText "bin"])] []) [])- "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo x:bar=\"baz\" xmlns:x=\"namespace\"/>" @=?+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo x:bar=\"baz\" xmlns:x=\"namespace\"/>" @=? D.renderLBS def (Document (Prologue [] Nothing []) (Element "foo" [ ("x:bar", [ContentText "baz"]) , (Name "bar" (Just "namespace") (Just "x"), [ContentText "bin"])@@ -316,7 +317,7 @@ testRenderComments :: Assertion testRenderComments =do- "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo><!--comment--></foo>"+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo><!--comment--></foo>" @=? D.renderLBS def (Document (Prologue [] Nothing []) (Element "foo" [] [NodeComment "comment"]) []) @@ -326,3 +327,37 @@ root @?= Res.Element "foo" [] [Res.NodeContent "baz"] Res.Document _ root2 _ <- return $ Res.parseLBS_ Res.def "<!DOCTYPE foo [<!ENTITY bar \"baz\">]><foo bar='&bar;'/>" root2 @?= Res.Element "foo" [("bar", "baz")] []++casePretty :: Assertion+casePretty = do+ let pretty = S.unlines+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+ , "<!DOCTYPE foo>"+ , "<foo bar=\"bar\" baz=\"baz\">"+ , " <foo"+ , " bar=\"bar\""+ , " baz=\"baz\""+ , " bin=\"bin\">"+ , " Hello World"+ , " </foo>"+ , " <foo/>"+ , " <?foo bar?>"+ , " <!-- foo bar baz bin -->"+ , " <bar>"+ , " bar content"+ , " </bar>"+ , "</foo>"+ ]+ doctype = Res.Doctype "foo" Nothing+ doc = Res.Document (Res.Prologue [] (Just doctype) []) root []+ root = Res.Element "foo" [("bar", "bar"), ("baz", "baz")]+ [ Res.NodeElement $ Res.Element "foo" [("bar", "bar"), ("baz", "baz"), ("bin", "bin")]+ [ Res.NodeContent " Hello World\n\n"+ , Res.NodeContent " "+ ]+ , Res.NodeElement $ Res.Element "foo" [] []+ , Res.NodeInstruction $ Res.Instruction "foo" "bar"+ , Res.NodeComment "foo bar\n\r\nbaz \tbin "+ , Res.NodeElement $ Res.Element "bar" [] [Res.NodeContent "bar content"]+ ]+ pretty @=? S.concat (L.toChunks $ Res.renderLBS def { D.rsPretty = True } doc)
xml-conduit.cabal view
@@ -1,5 +1,5 @@ name: xml-conduit-version: 0.7.0.2+version: 0.7.0.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michaels@suite-sol.com>, Aristid Breitkreuz <aristidb@googlemail.com>@@ -52,7 +52,7 @@ other-modules: Text.XML.Stream.Token ghc-options: -Wall -test-suite runtests+test-suite test type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test