diff --git a/Text/XML.hs b/Text/XML.hs --- a/Text/XML.hs +++ b/Text/XML.hs @@ -58,6 +58,7 @@ , R.RenderSettings , R.rsPretty , R.rsNamespaces + , R.rsAttrOrder -- * Conversion , toXMLDocument , fromXMLDocument @@ -141,21 +142,30 @@ -} toXMLDocument :: Document -> X.Document -toXMLDocument (Document a b c) = X.Document a (toXMLElement b) c +toXMLDocument = toXMLDocument' def +toXMLDocument' :: R.RenderSettings -> Document -> X.Document +toXMLDocument' rs (Document a b c) = X.Document a (toXMLElement' rs b) c + toXMLElement :: Element -> X.Element -toXMLElement (Element name as nodes) = +toXMLElement = toXMLElement' def + +toXMLElement' :: R.RenderSettings -> Element -> X.Element +toXMLElement' rs (Element name as nodes) = X.Element name as' nodes' where - as' = map (\(x, y) -> (x, [X.ContentText y])) $ Map.toList as - nodes' = map toXMLNode nodes + as' = map (\(x, y) -> (x, [X.ContentText y])) $ R.rsAttrOrder rs name as + nodes' = map (toXMLNode' rs) nodes toXMLNode :: Node -> X.Node -toXMLNode (NodeElement e) = X.NodeElement $ toXMLElement e -toXMLNode (NodeContent t) = X.NodeContent $ X.ContentText t -toXMLNode (NodeComment c) = X.NodeComment c -toXMLNode (NodeInstruction i) = X.NodeInstruction i +toXMLNode = toXMLNode' def +toXMLNode' :: R.RenderSettings -> Node -> X.Node +toXMLNode' rs (NodeElement e) = X.NodeElement $ toXMLElement' rs e +toXMLNode' _ (NodeContent t) = X.NodeContent $ X.ContentText t +toXMLNode' _ (NodeComment c) = X.NodeComment c +toXMLNode' _ (NodeInstruction i) = X.NodeInstruction i + fromXMLDocument :: X.Document -> Either (Set Text) Document fromXMLDocument (X.Document a b c) = case fromXMLElement b of @@ -247,7 +257,7 @@ instance Exception UnresolvedEntityException renderBytes :: MonadUnsafeIO m => R.RenderSettings -> Document -> Pipe l i ByteString u m () -renderBytes rs doc = D.renderBytes rs $ toXMLDocument doc +renderBytes rs doc = D.renderBytes rs $ toXMLDocument' rs doc writeFile :: R.RenderSettings -> FilePath -> Document -> IO () writeFile rs fp doc = 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 @@ -11,6 +11,7 @@ , def , rsPretty , rsNamespaces + , rsAttrOrder , prettify ) where @@ -54,12 +55,16 @@ -- 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. } instance Default RenderSettings where def = RenderSettings { rsPretty = False , rsNamespaces = [] + , rsAttrOrder = const Map.toList } -- | Render a stream of 'Event's into a stream of 'Builder's. Builders are from diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -78,6 +78,8 @@ it "handles conflicts" caseTLNConflict describe "blaze-html instances" $ do it "works" caseBlazeHtml + describe "attribute reordering" $ do + it "works" caseAttrReorder documentParseRender :: IO () documentParseRender = @@ -451,3 +453,25 @@ , "" , "

Hello World!

" ] + +caseAttrReorder :: Assertion +caseAttrReorder = do + let lbs = S.concat + [ "" + , "" + , "" + , "" + ] + rs = def { Res.rsAttrOrder = \name m -> + case name of + "foo" -> reverse $ Map.toAscList m + _ -> Map.toAscList m + } + attrs = Map.fromList [("a", "a"), ("b", "b"), ("c", "c")] + doc = Res.Document (Res.Prologue [] Nothing []) + (Res.Element "foo" attrs + [ Res.NodeElement + $ Res.Element "bar" attrs [] + ]) + [] + lbs @=? S.concat (L.toChunks $ Res.renderLBS rs 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: 1.0.0 +version: 1.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman , Aristid Breitkreuz