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 @@ -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 = 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 @@ -39,7 +39,7 @@ tokenToBuilder :: Token -> Builder tokenToBuilder (TokenBeginDocument attrs) = fromByteString "\n") + `mappend` foldAttrs oneSpace attrs (fromByteString "?>") tokenToBuilder (TokenInstruction (Instruction target data_)) = mconcat [ fromByteString "\n" + , fromByteString ">" ] where go Nothing = mempty diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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 - "\n\n" + "\n" , D.parseLBS_ def - "\n\n&ignore;" + "\n&ignore;" , D.parseLBS_ def "]]>" , 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 [ "" , "" , " " - , if x - then " text" - else " text " + , " text" , " " , "" ] @@ -116,7 +117,7 @@ liftIO $ x @?= Just "combine &content" where input = L.concat - [ "\n" + [ "" , "\n" , "" , "" @@ -137,7 +138,7 @@ liftIO $ x @?= Just (2 :: Int) where input = L.concat - [ "\n" + [ "" , "\n" , "" , "" @@ -151,7 +152,7 @@ liftIO $ length x @?= 5 where input = L.concat - [ "\n" + [ "" , "\n" , "" , "" @@ -170,7 +171,7 @@ liftIO $ x @?= Just (2 :: Int) where input = L.concat - [ "\n" + [ "" , "\n" , "" , "" @@ -306,9 +307,9 @@ stripDuplicateAttributes :: Assertion stripDuplicateAttributes = do - "\n" @=? + "" @=? D.renderLBS def (Document (Prologue [] Nothing []) (Element "foo" [("bar", [ContentText "baz"]), ("bar", [ContentText "bin"])] []) []) - "\n" @=? + "" @=? 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 - "\n" + "" @=? 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 "]>" root2 @?= Res.Element "foo" [("bar", "baz")] [] + +casePretty :: Assertion +casePretty = do + let pretty = S.unlines + [ "" + , "" + , "" + , " " + , " Hello World" + , " " + , " " + , " " + , " " + , " " + , " bar content" + , " " + , "" + ] + 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) 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: 0.7.0.2 +version: 0.7.0.3 license: BSD3 license-file: LICENSE author: Michael Snoyman , Aristid Breitkreuz @@ -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