xml-conduit 1.9.1.4 → 1.10.0.0
raw patch · 6 files changed
+464/−432 lines, 6 files
Files
- src/Text/XML.hs +0/−1
- src/Text/XML/Stream/Render.hs +27/−423
- src/Text/XML/Stream/Render/Internal.hs +427/−0
- src/Text/XML/Unresolved.hs +3/−3
- test/unit.hs +3/−2
- xml-conduit.cabal +4/−3
src/Text/XML.hs view
@@ -59,7 +59,6 @@ , P.decodeHtmlEntities -- ** Rendering , R.RenderSettings- , R.rsPretty , R.rsNamespaces , R.rsAttrOrder , R.rsUseCDATA
src/Text/XML/Stream/Render.hs view
@@ -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 <https://github.com/snoyberg/xml/issues/196>." #-}-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 <https://github.com/snoyberg/xml/issues/196>." #-}-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
+ src/Text/XML/Stream/Render/Internal.hs view
@@ -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 <https://github.com/snoyberg/xml/issues/196>.+ , 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)
src/Text/XML/Unresolved.hs view
@@ -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
test/unit.hs view
@@ -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 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"@@ -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
xml-conduit.cabal view
@@ -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 <michael@snoyman.com>, Aristid Breitkreuz <aristidb@googlemail.com>@@ -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