diff --git a/src/Text/XML.hs b/src/Text/XML.hs --- a/src/Text/XML.hs +++ b/src/Text/XML.hs @@ -59,7 +59,6 @@ , P.decodeHtmlEntities -- ** Rendering , R.RenderSettings - , R.rsPretty , R.rsNamespaces , R.rsAttrOrder , R.rsUseCDATA diff --git a/src/Text/XML/Stream/Render.hs b/src/Text/XML/Stream/Render.hs --- a/src/Text/XML/Stream/Render.hs +++ b/src/Text/XML/Stream/Render.hs @@ -1,427 +1,31 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} --- | 'Enumeratee's to render XML 'Event's. Unlike libxml-enumerator and --- expat-enumerator, this module does not provide IO and ST variants, since the --- underlying rendering operations are pure functions. -module Text.XML.Stream.Render - ( -- * Rendering XML files - renderBuilder - , renderBuilderFlush - , renderBytes - , renderText - , prettify - -- * Renderer settings - , RenderSettings - , def - , rsPretty - , rsNamespaces - , rsAttrOrder - , rsUseCDATA - , rsXMLDeclaration - , orderAttrs - -- * Event rendering - , tag - , content - -- * Attribute rendering - , Attributes - , attr - , optionalAttr - ) where - -import Control.Applicative ((<$>)) -import Control.Monad.Trans.Resource (MonadThrow) -import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder) -import Conduit -import Data.Default (Default (def)) -import Data.List (foldl') -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Monoid (Monoid, mappend, mempty) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import Data.XML.Types (Content (..), Event (..), - Name (..)) -import Text.XML.Stream.Token - --- | Render a stream of 'Event's into a stream of 'ByteString's. This function --- wraps around 'renderBuilder' and 'builderToByteString', so it produces --- optimally sized 'ByteString's with minimal buffer copying. --- --- The output is UTF8 encoded. -renderBytes :: PrimMonad m => RenderSettings -> ConduitT Event ByteString m () -renderBytes rs = renderBuilder rs .| builderToByteString - --- | Render a stream of 'Event's into a stream of 'Text's. This function --- wraps around 'renderBuilder', 'builderToByteString' and 'renderBytes', so it --- produces optimally sized 'Text's with minimal buffer copying. -renderText :: (PrimMonad m, MonadThrow m) => RenderSettings -> ConduitT Event Text m () -renderText rs = renderBytes rs .| decodeUtf8C - -{-# DEPRECATED rsPretty "Will be removed in future versions of `xml-conduit`. See ." #-} -data RenderSettings = RenderSettings - { 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)] - -- ^ Specify how to turn the unordered attributes used by the "Text.XML" - -- module into an ordered list. - , rsUseCDATA :: Content -> Bool - -- ^ Determines if for a given text content the renderer should use a - -- CDATA node. - -- - -- Default: @False@ - -- - -- @since 1.3.3 - , rsXMLDeclaration :: Bool - -- ^ Determines whether the XML declaration will be output. - -- - -- Default: @True@ - -- - -- @since 1.5.1 - } - -instance Default RenderSettings where - def = RenderSettings - { rsPretty = False - , rsNamespaces = [] - , rsAttrOrder = const Map.toList - , rsUseCDATA = const False - , rsXMLDeclaration = True - } - --- | Convenience function to create an ordering function suitable for --- use as the value of 'rsAttrOrder'. The ordering function is created --- from an explicit ordering of the attributes, specified as a list of --- tuples, as follows: In each tuple, the first component is the --- 'Name' of an element, and the second component is a list of --- attributes names. When the given element is rendered, the --- attributes listed, when present, appear first in the given order, --- followed by any other attributes in arbitrary order. If an element --- does not appear, all of its attributes are rendered in arbitrary --- order. -orderAttrs :: [(Name, [Name])] -> - Name -> Map Name Text -> [(Name, Text)] -orderAttrs orderSpec = order - where - order elt attrMap = - let initialAttrs = fromMaybe [] $ lookup elt orderSpec - mkPair attr' = (,) attr' <$> Map.lookup attr' attrMap - otherAttrMap = - Map.filterWithKey (const . not . (`elem` initialAttrs)) attrMap - in mapMaybe mkPair initialAttrs ++ Map.toAscList otherAttrMap - --- | Render a stream of 'Event's into a stream of 'Builder's. Builders are from --- the blaze-builder package, and allow the create of optimally sized --- 'ByteString's with minimal buffer copying. -renderBuilder :: Monad m => RenderSettings -> ConduitT Event Builder m () -renderBuilder settings = mapC Chunk .| renderBuilder' yield' settings - where - yield' Flush = return () - yield' (Chunk bs) = yield bs - --- | Same as 'renderBuilder' but allows you to flush XML stream to ensure that all --- events at needed point are rendered. --- --- @since 1.3.5 -renderBuilderFlush :: Monad m => RenderSettings -> ConduitT (Flush Event) (Flush Builder) m () -renderBuilderFlush = renderBuilder' yield - -renderBuilder' - :: Monad m - => (Flush Builder -> ConduitT (Flush Event) o m ()) - -> RenderSettings - -> ConduitT (Flush Event) o m () -renderBuilder' yield' settings = - if rsPretty settings - then prettify .| renderEvent' - else renderEvent' - where - renderEvent' = renderEvent yield' settings - -renderEvent - :: Monad m - => (Flush Builder -> ConduitT (Flush Event) o m ()) - -> RenderSettings - -> ConduitT (Flush Event) o m () -renderEvent yield' RenderSettings { rsPretty = isPretty, rsNamespaces = namespaces0, rsUseCDATA = useCDATA, rsXMLDeclaration = useXMLDecl } = - loop [] - where - loop nslevels = await >>= maybe (return ()) (go nslevels) - - go nslevels Flush = yield' Flush >> loop nslevels - go nslevels (Chunk e) = - case e of - EventBeginElement n1 as -> do - mnext <- peekC - isClosed <- - case mnext of - Just (Chunk (EventEndElement n2)) | n1 == n2 -> do - dropC 1 - return True - _ -> return False - let (token, nslevels') = mkBeginToken isPretty isClosed namespaces0 nslevels n1 as - yield' $ Chunk token - loop nslevels' - _ -> do - let (token, nslevels') = eventToToken nslevels useCDATA useXMLDecl e - yield' $ Chunk token - loop nslevels' - -eventToToken :: Stack -> (Content -> Bool) -> Bool -> Event -> (Builder, [NSLevel]) -eventToToken s _ True EventBeginDocument = - (tokenToBuilder $ TokenXMLDeclaration - [ ("version", [ContentText "1.0"]) - , ("encoding", [ContentText "UTF-8"]) - ] - , s) -eventToToken s _ False EventBeginDocument = (mempty, s) -eventToToken s _ _ EventEndDocument = (mempty, s) -eventToToken s _ _ (EventInstruction i) = (tokenToBuilder $ TokenInstruction i, s) -eventToToken s _ _ (EventBeginDoctype n meid) = (tokenToBuilder $ TokenDoctype n meid [], s) -eventToToken s _ _ EventEndDoctype = (mempty, s) -eventToToken s _ _ (EventCDATA t) = (tokenToBuilder $ TokenCDATA t, s) -eventToToken s _ _ (EventEndElement name) = - (tokenToBuilder $ TokenEndElement $ nameToTName sl name, s') - where - (sl:s') = s -eventToToken s useCDATA _ (EventContent c) - | useCDATA c = - case c of - 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) -eventToToken _ _ _ EventBeginElement{} = error "eventToToken on EventBeginElement" -- mkBeginToken False s name attrs - -type Stack = [NSLevel] - -nameToTName :: NSLevel -> Name -> TName -nameToTName _ (Name name _ (Just pref)) - | pref == "xml" = TName (Just "xml") name -nameToTName _ (Name name Nothing _) = TName Nothing name -- invariant that this is true -nameToTName (NSLevel def' sl) (Name name (Just ns) _) - | def' == Just ns = TName Nothing name - | otherwise = - case Map.lookup ns sl of - Nothing -> error "nameToTName" - Just pref -> TName (Just pref) name - -mkBeginToken :: Bool -- ^ pretty print attributes? - -> Bool -- ^ self closing? - -> [(Text, Text)] -- ^ namespaces to apply to top-level - -> Stack - -> Name - -> [(Name, [Content])] - -> (Builder, Stack) -mkBeginToken isPretty isClosed namespaces0 s name attrs = - (tokenToBuilder $ TokenBeginElement tname tattrs3 isClosed indent, - if isClosed then s else sl3 : s) - where - indent = if isPretty then 2 + 4 * length s else 0 - prevsl = case s of - [] -> NSLevel Nothing Map.empty - sl':_ -> sl' - (sl1, tname, tattrs1) = newElemStack prevsl name - (sl2, tattrs2) = foldr newAttrStack (sl1, tattrs1) $ nubAttrs attrs - (sl3, tattrs3) = - case s of - [] -> (sl2 { prefixes = Map.union (prefixes sl2) $ Map.fromList namespaceSL }, namespaceAttrs ++ tattrs2) - _ -> (sl2, tattrs2) - - (namespaceSL, namespaceAttrs) = unzip $ mapMaybe unused namespaces0 - unused (k, v) = - case lookup k' tattrs2 of - Just{} -> Nothing - Nothing -> Just ((v, k), (k', v')) - where - k' = TName (Just "xmlns") k - v' = [ContentText v] - -newElemStack :: NSLevel -> Name -> (NSLevel, TName, [TAttribute]) -newElemStack nsl@(NSLevel def' _) (Name local ns _) - | def' == ns = (nsl, TName Nothing local, []) -newElemStack (NSLevel _ nsmap) (Name local Nothing _) = - (NSLevel Nothing nsmap, TName Nothing local, [(TName Nothing "xmlns", [])]) -newElemStack (NSLevel _ nsmap) (Name local (Just ns) Nothing) = - (NSLevel (Just ns) nsmap, TName Nothing local, [(TName Nothing "xmlns", [ContentText ns])]) -newElemStack (NSLevel def' nsmap) (Name local (Just ns) (Just pref)) = - case Map.lookup ns nsmap of - Just pref' - | pref == pref' -> - ( NSLevel def' nsmap - , TName (Just pref) local - , [] - ) - _ -> ( NSLevel def' nsmap' - , TName (Just pref) local - , [(TName (Just "xmlns") pref, [ContentText ns])] - ) - where - nsmap' = Map.insert ns pref nsmap - -newAttrStack :: (Name, [Content]) -> (NSLevel, [TAttribute]) -> (NSLevel, [TAttribute]) -newAttrStack (name, value) (NSLevel def' nsmap, attrs) = - (NSLevel def' nsmap', addNS $ (tname, value) : attrs) - where - (nsmap', tname, addNS) = - case name of - Name local Nothing _ -> (nsmap, TName Nothing local, id) - Name local (Just ns) mpref -> - let ppref = fromMaybe "ns" mpref - (pref, addNS') = getPrefix ppref nsmap ns - in (Map.insert ns pref nsmap, TName (Just pref) local, addNS') - -getPrefix :: Text -> Map Text Text -> Text -> (Text, [TAttribute] -> [TAttribute]) -getPrefix _ _ "http://www.w3.org/XML/1998/namespace" = ("xml", id) -getPrefix ppref nsmap ns = - case Map.lookup ns nsmap of - Just pref -> (pref, id) - Nothing -> - let pref = findUnused ppref $ Map.elems nsmap - in (pref, (:) (TName (Just "xmlns") pref, [ContentText ns])) - where - findUnused x xs - | x `elem` xs = findUnused (x `T.snoc` '_') xs - | otherwise = x - --- | Convert a stream of 'Event's into a prettified one, adding extra --- whitespace. Note that this can change the meaning of your XML. -{-# DEPRECATED prettify "Will be removed in future versions of `xml-conduit`. See ." #-} -prettify :: Monad m => ConduitT (Flush Event) (Flush Event) m () -prettify = prettify' 0 - -prettify' :: Monad m => Int -> ConduitT (Flush Event) (Flush Event) m () -prettify' level = - await >>= maybe (return ()) goC - where - yield' = yield . Chunk - - goC Flush = yield Flush >> prettify' level - goC (Chunk e) = go e - - go e@EventBeginDocument = do - yield' e - yield' $ EventContent $ ContentText "\n" - prettify' level - go e@EventBeginElement{} = do - yield' before - yield' e - mnext <- peekC - case mnext of - Just (Chunk next@EventEndElement{}) -> do - dropC 1 - yield' next - yield' after - prettify' level - _ -> do - yield' after - prettify' $ level + 1 - go e@EventEndElement{} = do - let level' = max 0 $ level - 1 - yield' $ before' level' - yield' e - yield' after - prettify' level' - go (EventContent c) = do - cs <- takeContents (c:) - let cs' = mapMaybe normalize cs - case cs' of - [] -> return () - _ -> do - yield' before - mapM_ (yield' . EventContent) cs' - yield' after - prettify' level - go (EventCDATA t) = go $ EventContent $ ContentText t - go e@EventInstruction{} = do - yield' before - yield' e - yield' after - prettify' level - go (EventComment t) = do - yield' before - yield' $ EventComment $ T.concat - [ " " - , T.unwords $ T.words t - , " " - ] - yield' after - prettify' level - - go e@EventEndDocument = yield' e >> prettify' level - go e@EventBeginDoctype{} = yield' e >> prettify' level - go e@EventEndDoctype{} = yield' e >> yield' after >> prettify' level - - takeContents front = do - me <- peekC - case me of - Just (Chunk (EventContent c)) -> do - dropC 1 - takeContents $ front . (c:) - Just (Chunk (EventCDATA t)) -> do - dropC 1 - takeContents $ front . (ContentText t:) - _ -> return $ front [] - - normalize (ContentText t) - | T.null t' = Nothing - | otherwise = Just $ ContentText t' - where - 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 = - front [] - where - (front, _) = foldl' go (id, Set.empty) orig - go (dlist, used) (k, v) - | k `Set.member` used = (dlist, used) - | otherwise = (dlist . ((k, v):), Set.insert k used) - - --- | Generate a complete XML 'Element'. -tag :: (Monad m) => Name -> Attributes -> ConduitT i Event m () -- ^ 'Element''s subnodes. - -> ConduitT i Event m () -tag name (Attributes a) content' = do - yield $ EventBeginElement name a - content' - yield $ EventEndElement name - --- | Generate a textual 'EventContent'. -content :: (Monad m) => Text -> ConduitT i Event m () -content = yield . EventContent . ContentText +{- | 'Enumeratee's to render XML 'Event's. Unlike libxml-enumerator and +expat-enumerator, this module does not provide IO and ST variants, since the +underlying rendering operations are pure functions. +-} +module Text.XML.Stream.Render ( + -- * Rendering XML files + renderBuilder, + renderBuilderFlush, + renderBytes, + renderText, --- | A list of attributes. -data Attributes = Attributes [(Name, [Content])] + -- * Renderer settings + RenderSettings, + def, + rsNamespaces, + rsAttrOrder, + rsUseCDATA, + rsXMLDeclaration, + orderAttrs, -instance Monoid Attributes where - mempty = Attributes mempty -#if !MIN_VERSION_base(4,11,0) - (Attributes a) `mappend` (Attributes b) = Attributes (a `mappend` b) -#else -instance Semigroup Attributes where - (Attributes a) <> (Attributes b) = Attributes (a <> b) -#endif + -- * Event rendering + tag, + content, --- | Generate a single attribute. -attr :: Name -- ^ Attribute's name - -> Text -- ^ Attribute's value - -> Attributes -attr name value = Attributes [(name, [ContentText value])] + -- * Attribute rendering + Attributes, + attr, + optionalAttr, +) where --- | Helper function that generates a valid attribute if input isn't 'Nothing', or 'mempty' otherwise. -optionalAttr :: Name -> Maybe Text -> Attributes -optionalAttr name = maybe mempty (attr name) +import Text.XML.Stream.Render.Internal diff --git a/src/Text/XML/Stream/Render/Internal.hs b/src/Text/XML/Stream/Render/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Stream/Render/Internal.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +-- | 'Enumeratee's to render XML 'Event's. Unlike libxml-enumerator and +-- expat-enumerator, this module does not provide IO and ST variants, since the +-- underlying rendering operations are pure functions. +module Text.XML.Stream.Render.Internal + ( -- * Rendering XML files + renderBuilder + , renderBuilderFlush + , renderBytes + , renderText + -- * Renderer settings + , RenderSettings + , def + , rsPretty + , rsNamespaces + , rsAttrOrder + , rsUseCDATA + , rsXMLDeclaration + , orderAttrs + -- * Event rendering + , tag + , content + -- * Attribute rendering + , Attributes + , attr + , optionalAttr + ) where + +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Resource (MonadThrow) +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder) +import Conduit +import Data.Default (Default (def)) +import Data.List (foldl') +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Monoid (Monoid, mappend, mempty) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.XML.Types (Content (..), Event (..), + Name (..)) +import Text.XML.Stream.Token + +-- | Render a stream of 'Event's into a stream of 'ByteString's. This function +-- wraps around 'renderBuilder' and 'builderToByteString', so it produces +-- optimally sized 'ByteString's with minimal buffer copying. +-- +-- The output is UTF8 encoded. +renderBytes :: PrimMonad m => RenderSettings -> ConduitT Event ByteString m () +renderBytes rs = renderBuilder rs .| builderToByteString + +-- | Render a stream of 'Event's into a stream of 'Text's. This function +-- wraps around 'renderBuilder', 'builderToByteString' and 'renderBytes', so it +-- produces optimally sized 'Text's with minimal buffer copying. +renderText :: (PrimMonad m, MonadThrow m) => RenderSettings -> ConduitT Event Text m () +renderText rs = renderBytes rs .| decodeUtf8C + +data RenderSettings = RenderSettings + { rsPretty :: Bool + -- ^ Pretty-print XML document. Implementation is arbitrary and can change the meaning of your XML (e.g. by adding whitespace and newlines in text content.) + -- + -- See . + , 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)] + -- ^ Specify how to turn the unordered attributes used by the "Text.XML" + -- module into an ordered list. + , rsUseCDATA :: Content -> Bool + -- ^ Determines if for a given text content the renderer should use a + -- CDATA node. + -- + -- Default: @False@ + -- + -- @since 1.3.3 + , rsXMLDeclaration :: Bool + -- ^ Determines whether the XML declaration will be output. + -- + -- Default: @True@ + -- + -- @since 1.5.1 + } + +instance Default RenderSettings where + def = RenderSettings + { rsPretty = False + , rsNamespaces = [] + , rsAttrOrder = const Map.toList + , rsUseCDATA = const False + , rsXMLDeclaration = True + } + +-- | Convenience function to create an ordering function suitable for +-- use as the value of 'rsAttrOrder'. The ordering function is created +-- from an explicit ordering of the attributes, specified as a list of +-- tuples, as follows: In each tuple, the first component is the +-- 'Name' of an element, and the second component is a list of +-- attributes names. When the given element is rendered, the +-- attributes listed, when present, appear first in the given order, +-- followed by any other attributes in arbitrary order. If an element +-- does not appear, all of its attributes are rendered in arbitrary +-- order. +orderAttrs :: [(Name, [Name])] -> + Name -> Map Name Text -> [(Name, Text)] +orderAttrs orderSpec = order + where + order elt attrMap = + let initialAttrs = fromMaybe [] $ lookup elt orderSpec + mkPair attr' = (,) attr' <$> Map.lookup attr' attrMap + otherAttrMap = + Map.filterWithKey (const . not . (`elem` initialAttrs)) attrMap + in mapMaybe mkPair initialAttrs ++ Map.toAscList otherAttrMap + +-- | Render a stream of 'Event's into a stream of 'Builder's. Builders are from +-- the blaze-builder package, and allow the create of optimally sized +-- 'ByteString's with minimal buffer copying. +renderBuilder :: Monad m => RenderSettings -> ConduitT Event Builder m () +renderBuilder settings = mapC Chunk .| renderBuilder' yield' settings + where + yield' Flush = return () + yield' (Chunk bs) = yield bs + +-- | Same as 'renderBuilder' but allows you to flush XML stream to ensure that all +-- events at needed point are rendered. +-- +-- @since 1.3.5 +renderBuilderFlush :: Monad m => RenderSettings -> ConduitT (Flush Event) (Flush Builder) m () +renderBuilderFlush = renderBuilder' yield + +renderBuilder' + :: Monad m + => (Flush Builder -> ConduitT (Flush Event) o m ()) + -> RenderSettings + -> ConduitT (Flush Event) o m () +renderBuilder' yield' settings = + if rsPretty settings + then prettify .| renderEvent' + else renderEvent' + where + renderEvent' = renderEvent yield' settings + +renderEvent + :: Monad m + => (Flush Builder -> ConduitT (Flush Event) o m ()) + -> RenderSettings + -> ConduitT (Flush Event) o m () +renderEvent yield' RenderSettings { rsPretty = isPretty, rsNamespaces = namespaces0, rsUseCDATA = useCDATA, rsXMLDeclaration = useXMLDecl } = + loop [] + where + loop nslevels = await >>= maybe (return ()) (go nslevels) + + go nslevels Flush = yield' Flush >> loop nslevels + go nslevels (Chunk e) = + case e of + EventBeginElement n1 as -> do + mnext <- peekC + isClosed <- + case mnext of + Just (Chunk (EventEndElement n2)) | n1 == n2 -> do + dropC 1 + return True + _ -> return False + let (token, nslevels') = mkBeginToken isPretty isClosed namespaces0 nslevels n1 as + yield' $ Chunk token + loop nslevels' + _ -> do + let (token, nslevels') = eventToToken nslevels useCDATA useXMLDecl e + yield' $ Chunk token + loop nslevels' + +eventToToken :: Stack -> (Content -> Bool) -> Bool -> Event -> (Builder, [NSLevel]) +eventToToken s _ True EventBeginDocument = + (tokenToBuilder $ TokenXMLDeclaration + [ ("version", [ContentText "1.0"]) + , ("encoding", [ContentText "UTF-8"]) + ] + , s) +eventToToken s _ False EventBeginDocument = (mempty, s) +eventToToken s _ _ EventEndDocument = (mempty, s) +eventToToken s _ _ (EventInstruction i) = (tokenToBuilder $ TokenInstruction i, s) +eventToToken s _ _ (EventBeginDoctype n meid) = (tokenToBuilder $ TokenDoctype n meid [], s) +eventToToken s _ _ EventEndDoctype = (mempty, s) +eventToToken s _ _ (EventCDATA t) = (tokenToBuilder $ TokenCDATA t, s) +eventToToken s _ _ (EventEndElement name) = + (tokenToBuilder $ TokenEndElement $ nameToTName sl name, s') + where + (sl:s') = s +eventToToken s useCDATA _ (EventContent c) + | useCDATA c = + case c of + 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) +eventToToken _ _ _ EventBeginElement{} = error "eventToToken on EventBeginElement" -- mkBeginToken False s name attrs + +type Stack = [NSLevel] + +nameToTName :: NSLevel -> Name -> TName +nameToTName _ (Name name _ (Just pref)) + | pref == "xml" = TName (Just "xml") name +nameToTName _ (Name name Nothing _) = TName Nothing name -- invariant that this is true +nameToTName (NSLevel def' sl) (Name name (Just ns) _) + | def' == Just ns = TName Nothing name + | otherwise = + case Map.lookup ns sl of + Nothing -> error "nameToTName" + Just pref -> TName (Just pref) name + +mkBeginToken :: Bool -- ^ pretty print attributes? + -> Bool -- ^ self closing? + -> [(Text, Text)] -- ^ namespaces to apply to top-level + -> Stack + -> Name + -> [(Name, [Content])] + -> (Builder, Stack) +mkBeginToken isPretty isClosed namespaces0 s name attrs = + (tokenToBuilder $ TokenBeginElement tname tattrs3 isClosed indent, + if isClosed then s else sl3 : s) + where + indent = if isPretty then 2 + 4 * length s else 0 + prevsl = case s of + [] -> NSLevel Nothing Map.empty + sl':_ -> sl' + (sl1, tname, tattrs1) = newElemStack prevsl name + (sl2, tattrs2) = foldr newAttrStack (sl1, tattrs1) $ nubAttrs attrs + (sl3, tattrs3) = + case s of + [] -> (sl2 { prefixes = Map.union (prefixes sl2) $ Map.fromList namespaceSL }, namespaceAttrs ++ tattrs2) + _ -> (sl2, tattrs2) + + (namespaceSL, namespaceAttrs) = unzip $ mapMaybe unused namespaces0 + unused (k, v) = + case lookup k' tattrs2 of + Just{} -> Nothing + Nothing -> Just ((v, k), (k', v')) + where + k' = TName (Just "xmlns") k + v' = [ContentText v] + +newElemStack :: NSLevel -> Name -> (NSLevel, TName, [TAttribute]) +newElemStack nsl@(NSLevel def' _) (Name local ns _) + | def' == ns = (nsl, TName Nothing local, []) +newElemStack (NSLevel _ nsmap) (Name local Nothing _) = + (NSLevel Nothing nsmap, TName Nothing local, [(TName Nothing "xmlns", [])]) +newElemStack (NSLevel _ nsmap) (Name local (Just ns) Nothing) = + (NSLevel (Just ns) nsmap, TName Nothing local, [(TName Nothing "xmlns", [ContentText ns])]) +newElemStack (NSLevel def' nsmap) (Name local (Just ns) (Just pref)) = + case Map.lookup ns nsmap of + Just pref' + | pref == pref' -> + ( NSLevel def' nsmap + , TName (Just pref) local + , [] + ) + _ -> ( NSLevel def' nsmap' + , TName (Just pref) local + , [(TName (Just "xmlns") pref, [ContentText ns])] + ) + where + nsmap' = Map.insert ns pref nsmap + +newAttrStack :: (Name, [Content]) -> (NSLevel, [TAttribute]) -> (NSLevel, [TAttribute]) +newAttrStack (name, value) (NSLevel def' nsmap, attrs) = + (NSLevel def' nsmap', addNS $ (tname, value) : attrs) + where + (nsmap', tname, addNS) = + case name of + Name local Nothing _ -> (nsmap, TName Nothing local, id) + Name local (Just ns) mpref -> + let ppref = fromMaybe "ns" mpref + (pref, addNS') = getPrefix ppref nsmap ns + in (Map.insert ns pref nsmap, TName (Just pref) local, addNS') + +getPrefix :: Text -> Map Text Text -> Text -> (Text, [TAttribute] -> [TAttribute]) +getPrefix _ _ "http://www.w3.org/XML/1998/namespace" = ("xml", id) +getPrefix ppref nsmap ns = + case Map.lookup ns nsmap of + Just pref -> (pref, id) + Nothing -> + let pref = findUnused ppref $ Map.elems nsmap + in (pref, (:) (TName (Just "xmlns") pref, [ContentText ns])) + where + findUnused x xs + | x `elem` xs = findUnused (x `T.snoc` '_') xs + | otherwise = x + +-- | 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 => ConduitT (Flush Event) (Flush Event) m () +prettify = prettify' 0 + +prettify' :: Monad m => Int -> ConduitT (Flush Event) (Flush Event) m () +prettify' level = + await >>= maybe (return ()) goC + where + yield' = yield . Chunk + + goC Flush = yield Flush >> prettify' level + goC (Chunk e) = go e + + go e@EventBeginDocument = do + yield' e + yield' $ EventContent $ ContentText "\n" + prettify' level + go e@EventBeginElement{} = do + yield' before + yield' e + mnext <- peekC + case mnext of + Just (Chunk next@EventEndElement{}) -> do + dropC 1 + yield' next + yield' after + prettify' level + _ -> do + yield' after + prettify' $ level + 1 + go e@EventEndElement{} = do + let level' = max 0 $ level - 1 + yield' $ before' level' + yield' e + yield' after + prettify' level' + go (EventContent c) = do + cs <- takeContents (c:) + let cs' = mapMaybe normalize cs + case cs' of + [] -> return () + _ -> do + yield' before + mapM_ (yield' . EventContent) cs' + yield' after + prettify' level + go (EventCDATA t) = go $ EventContent $ ContentText t + go e@EventInstruction{} = do + yield' before + yield' e + yield' after + prettify' level + go (EventComment t) = do + yield' before + yield' $ EventComment $ T.concat + [ " " + , T.unwords $ T.words t + , " " + ] + yield' after + prettify' level + + go e@EventEndDocument = yield' e >> prettify' level + go e@EventBeginDoctype{} = yield' e >> prettify' level + go e@EventEndDoctype{} = yield' e >> yield' after >> prettify' level + + takeContents front = do + me <- peekC + case me of + Just (Chunk (EventContent c)) -> do + dropC 1 + takeContents $ front . (c:) + Just (Chunk (EventCDATA t)) -> do + dropC 1 + takeContents $ front . (ContentText t:) + _ -> return $ front [] + + normalize (ContentText t) + | T.null t' = Nothing + | otherwise = Just $ ContentText t' + where + 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 = + front [] + where + (front, _) = foldl' go (id, Set.empty) orig + go (dlist, used) (k, v) + | k `Set.member` used = (dlist, used) + | otherwise = (dlist . ((k, v):), Set.insert k used) + + +-- | Generate a complete XML 'Element'. +tag :: (Monad m) => Name -> Attributes -> ConduitT i Event m () -- ^ 'Element''s subnodes. + -> ConduitT i Event m () +tag name (Attributes a) content' = do + yield $ EventBeginElement name a + content' + yield $ EventEndElement name + +-- | Generate a textual 'EventContent'. +content :: (Monad m) => Text -> ConduitT i Event m () +content = yield . EventContent . ContentText + +-- | A list of attributes. +data Attributes = Attributes [(Name, [Content])] + +instance Monoid Attributes where + mempty = Attributes mempty +#if !MIN_VERSION_base(4,11,0) + (Attributes a) `mappend` (Attributes b) = Attributes (a `mappend` b) +#else +instance Semigroup Attributes where + (Attributes a) <> (Attributes b) = Attributes (a <> b) +#endif + +-- | Generate a single attribute. +attr :: Name -- ^ Attribute's name + -> Text -- ^ Attribute's value + -> Attributes +attr name value = Attributes [(name, [ContentText value])] + +-- | Helper function that generates a valid attribute if input isn't 'Nothing', or 'mempty' otherwise. +optionalAttr :: Name -> Maybe Text -> Attributes +optionalAttr name = maybe mempty (attr name) diff --git a/src/Text/XML/Unresolved.hs b/src/Text/XML/Unresolved.hs --- a/src/Text/XML/Unresolved.hs +++ b/src/Text/XML/Unresolved.hs @@ -38,9 +38,8 @@ , P.psDecodeEntities , P.psRetainNamespaces -- ** Render - , R.RenderSettings - , R.rsPretty - , R.rsNamespaces + , RI.RenderSettings + , RI.rsNamespaces ) where import Conduit @@ -67,6 +66,7 @@ import Text.XML.Stream.Parse (ParseSettings) import qualified Text.XML.Stream.Parse as P import qualified Text.XML.Stream.Render as R +import qualified Text.XML.Stream.Render.Internal as RI readFile :: P.ParseSettings -> FilePath -> IO Document readFile ps fp = runConduitRes $ CB.sourceFile fp .| sinkDoc ps diff --git a/test/unit.hs b/test/unit.hs --- a/test/unit.hs +++ b/test/unit.hs @@ -15,6 +15,7 @@ import Text.XML.Stream.Parse (def) import qualified Text.XML.Stream.Parse as P import qualified Text.XML.Unresolved as D +import qualified Text.XML.Stream.Render.Internal as R import Control.Monad import qualified Data.Set as Set @@ -143,7 +144,7 @@ documentParsePrettyRender :: IO () documentParsePrettyRender = - L.unpack (D.renderLBS def { D.rsPretty = True } (D.parseLBS_ def doc)) @?= L.unpack doc + L.unpack (D.renderLBS def { R.rsPretty = True } (D.parseLBS_ def doc)) @?= L.unpack doc where doc = L.unlines [ "" @@ -901,7 +902,7 @@ , Res.NodeComment "foo bar\n\r\nbaz \tbin " , Res.NodeElement $ Res.Element "bar" Map.empty [Res.NodeContent "bar content"] ] - pretty @=? S.concat (L.toChunks $ Res.renderLBS def { D.rsPretty = True } doc) + pretty @=? S.concat (L.toChunks $ Res.renderLBS def { R.rsPretty = True } doc) caseTopLevelNamespace :: Assertion caseTopLevelNamespace = do diff --git a/xml-conduit.cabal b/xml-conduit.cabal --- a/xml-conduit.cabal +++ b/xml-conduit.cabal @@ -1,7 +1,7 @@ cabal-version: 1.14 name: xml-conduit -version: 1.9.1.4 +version: 1.10.0.0 license: MIT license-file: LICENSE author: Michael Snoyman , Aristid Breitkreuz @@ -14,10 +14,10 @@ homepage: http://github.com/snoyberg/xml extra-source-files: README.md ChangeLog.md -tested-with: GHC >=8.0 && <8.12 +tested-with: GHC >=8.0 && <9.10 custom-setup - setup-depends: base >= 4 && <5, Cabal <4, cabal-doctest >= 1.0.9 && <1.1 + setup-depends: base >= 4 && <5, Cabal <4, cabal-doctest >= 1 && <1.1 library build-depends: base >= 4.12 && < 5 @@ -36,6 +36,7 @@ , deepseq >= 1.1.0.0 exposed-modules: Text.XML.Stream.Parse Text.XML.Stream.Render + Text.XML.Stream.Render.Internal Text.XML.Unresolved Text.XML.Cursor Text.XML.Cursor.Generic