    {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, CPP #-}
    {-# OPTIONS_GHC -fno-warn-orphans #-} -- IsString for XML

    -- | Overcome XML insanity, node by node.
    --
    -- > {-# LANGUAGE OverloadedStrings #-}
    -- >
    -- > let doc = document "root" $ do
    -- >     element "hello" $ content "world"
    -- >     element "hierarchy" $ do
    -- >         element "simple" True
    -- >         element "as" ("it should be" :: Text)
    -- >         toXML $ Just . T.pack $ "like this"
    -- >     comment "that's it!"
    --

    module Text.XML.Writer
        (
        -- * Documents
          document
        , documentA
        , documentD
        , documentAD
        , soap
        , pprint
        -- * Elements
        , XML
        -- ** Node creation
        , node
        , instruction
        , comment
        , element, elementMaybe, elementA
        , content
        , empty
        , many
        -- ** Element helpers
        , render, (!:)
        -- ** Converting data
        , ToXML(..)
        ) where

    import Text.XML
    import Control.Monad.Writer.Strict
    import Data.Default ()
    import qualified Data.DList as DL
    import qualified Data.Map as M

    import Data.Text (Text)
    import qualified Data.Text as T
    import qualified Data.Text.Lazy.IO as TL
    import Data.String (IsString(..))

    #if MIN_VERSION_mtl(2,3,0)
    import Control.Monad
    #endif

    #if MIN_VERSION_xml_conduit(1,10,0)
    import Text.XML.Stream.Render.Internal (rsPretty)
    #endif

    -- | Node container to be rendered as children nodes.
    type XML = Writer (DL.DList Node) ()

    -- | Create a simple Document starting with a root element.
    document :: Name -- ^ Root node name
             -> XML  -- ^ Contents
             -> Document
    document :: Name -> XML -> Document
    document Name
    name XML
    children = Document { documentPrologue :: Prologue
    documentPrologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
    Prologue [Miscellaneous]
    forall a. Default a => a
    def Maybe Doctype
    forall a. Default a => a
    def [Miscellaneous]
    forall a. Default a => a
    def
                                      , documentRoot :: Element
    documentRoot = Name -> Map Name Text -> [Node] -> Element
    Element Name
    name Map Name Text
    forall a. Default a => a
    def (XML -> [Node]
    render XML
    children)
                                      , documentEpilogue :: [Miscellaneous]
    documentEpilogue = [Miscellaneous]
    forall a. Default a => a
    def
                                      }

    -- | Create a simple Document starting with a root element with attributes.
    documentA :: Name           -- ^ Root node name
              -> [(Name, Text)] -- ^ Attributes
              -> XML            -- ^ Contents
              -> Document
    documentA :: Name -> [(Name, Text)] -> XML -> Document
    documentA Name
    name [(Name, Text)]
    attrs XML
    children = Document { documentPrologue :: Prologue
    documentPrologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
    Prologue [Miscellaneous]
    forall a. Default a => a
    def Maybe Doctype
    forall a. Default a => a
    def [Miscellaneous]
    forall a. Default a => a
    def
                                             , documentRoot :: Element
    documentRoot = Name -> Map Name Text -> [Node] -> Element
    Element Name
    name ([(Name, Text)] -> Map Name Text
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList [(Name, Text)]
    attrs) (XML -> [Node]
    render XML
    children)
                                             , documentEpilogue :: [Miscellaneous]
    documentEpilogue = [Miscellaneous]
    forall a. Default a => a
    def
                                             }

    -- | Create a simple Document starting with a root element with a doctype.
    documentD :: Name             -- ^ Root node name
                -> Maybe Doctype  -- ^ DOCTYPE
                -> XML            -- ^ Contents
                -> Document
    documentD :: Name -> Maybe Doctype -> XML -> Document
    documentD Name
    name Maybe Doctype
    dt XML
    children = Document { documentPrologue :: Prologue
    documentPrologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
    Prologue [Miscellaneous]
    forall a. Default a => a
    def Maybe Doctype
    dt [Miscellaneous]
    forall a. Default a => a
    def
                                          , documentRoot :: Element
    documentRoot = Name -> Map Name Text -> [Node] -> Element
    Element Name
    name Map Name Text
    forall a. Default a => a
    def (XML -> [Node]
    render XML
    children)
                                          , documentEpilogue :: [Miscellaneous]
    documentEpilogue = [Miscellaneous]
    forall a. Default a => a
    def
                                          }

    -- | Create a simple Document starting with a root element with attributes and doctype.
    documentAD :: Name            -- ^ Root node name
                -> [(Name, Text)] -- ^ Attributes
                -> Maybe Doctype  -- ^ DOCTYPE
                -> XML            -- ^ Contents
                -> Document
    documentAD :: Name -> [(Name, Text)] -> Maybe Doctype -> XML -> Document
    documentAD Name
    name [(Name, Text)]
    attrs Maybe Doctype
    dt XML
    children = Document { documentPrologue :: Prologue
    documentPrologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
    Prologue [Miscellaneous]
    forall a. Default a => a
    def Maybe Doctype
    dt [Miscellaneous]
    forall a. Default a => a
    def
                                                 , documentRoot :: Element
    documentRoot = Name -> Map Name Text -> [Node] -> Element
    Element Name
    name ([(Name, Text)] -> Map Name Text
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList [(Name, Text)]
    attrs) (XML -> [Node]
    render XML
    children)
                                                 , documentEpilogue :: [Miscellaneous]
    documentEpilogue = [Miscellaneous]
    forall a. Default a => a
    def
                                                 }

    -- | Render document using xml-conduit's pretty-printer.
    pprint :: Document -> IO ()
    pprint :: Document -> IO ()
    pprint = Text -> IO ()
    TL.putStrLn (Text -> IO ()) -> (Document -> Text) -> Document -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . RenderSettings -> Document -> Text
    renderText RenderSettings
    forall a. Default a => a
    def { rsPretty = True }

    -- | Convert collected nodes to a list of child nodes.
    render :: XML -> [Node]
    render :: XML -> [Node]
    render = DList Node -> [Node]
    forall a. DList a -> [a]
    DL.toList (DList Node -> [Node]) -> (XML -> DList Node) -> XML -> [Node]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XML -> DList Node
    forall w a. Writer w a -> w
    execWriter

    -- | Do nothing.
    empty :: XML
    empty :: XML
    empty = () -> XML
    forall a. a -> WriterT (DList Node) Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    -- | Insert one node.
    node :: Node -> XML
    node :: Node -> XML
    node = DList Node -> XML
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
    tell (DList Node -> XML) -> (Node -> DList Node) -> Node -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Node -> DList Node
    forall a. a -> DList a
    DL.singleton

    -- | Insert an "Element" node constructed with name and children.
    element :: (ToXML a) => Name -> a -> XML
    element :: forall a. ToXML a => Name -> a -> XML
    element Name
    name a
    children = Node -> XML
    node (Node -> XML) -> (Element -> Node) -> Element -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Element -> Node
    NodeElement (Element -> XML) -> Element -> XML
    forall a b. (a -> b) -> a -> b
    $! Name -> Map Name Text -> [Node] -> Element
    Element Name
    name Map Name Text
    forall a. Default a => a
    def (XML -> [Node]
    render (XML -> [Node]) -> XML -> [Node]
    forall a b. (a -> b) -> a -> b
    $ a -> XML
    forall a. ToXML a => a -> XML
    toXML a
    children)

    -- | Insert an "Element" node converted from Maybe value or do nothing.
    elementMaybe :: (ToXML a) => Name -> Maybe a -> XML
    elementMaybe :: forall a. ToXML a => Name -> Maybe a -> XML
    elementMaybe Name
    name = XML -> (a -> XML) -> Maybe a -> XML
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe XML
    empty (Name -> a -> XML
    forall a. ToXML a => Name -> a -> XML
    element Name
    name)

    -- | Insert an "Element" node constructed with name, attributes and children.
    elementA :: (ToXML a) => Name -> [(Name, Text)] -> a -> XML
    elementA :: forall a. ToXML a => Name -> [(Name, Text)] -> a -> XML
    elementA Name
    name [(Name, Text)]
    attrs a
    children = Node -> XML
    node (Node -> XML) -> (Element -> Node) -> Element -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Element -> Node
    NodeElement (Element -> XML) -> Element -> XML
    forall a b. (a -> b) -> a -> b
    $! Name -> Map Name Text -> [Node] -> Element
    Element Name
    name ([(Name, Text)] -> Map Name Text
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList [(Name, Text)]
    attrs) (XML -> [Node]
    render (XML -> [Node]) -> XML -> [Node]
    forall a b. (a -> b) -> a -> b
    $ a -> XML
    forall a. ToXML a => a -> XML
    toXML a
    children)

    -- | Insert an "Instruction" node.
    instruction :: Text -> Text -> XML
    instruction :: Text -> Text -> XML
    instruction Text
    target Text
    data_ = Node -> XML
    node (Node -> XML) -> (Instruction -> Node) -> Instruction -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Instruction -> Node
    NodeInstruction (Instruction -> XML) -> Instruction -> XML
    forall a b. (a -> b) -> a -> b
    $! Text -> Text -> Instruction
    Instruction Text
    target Text
    data_

    -- | Insert a text comment node.
    comment :: Text -> XML
    comment :: Text -> XML
    comment = Node -> XML
    node (Node -> XML) -> (Text -> Node) -> Text -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Node
    NodeComment

    -- | Insert text content node.
    content :: Text -> XML
    content :: Text -> XML
    content = Node -> XML
    node (Node -> XML) -> (Text -> Node) -> Text -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Node
    NodeContent

    -- | Mass-convert to nodes.
    --
    -- > let array = element "container" $ many "wrapper" [1..3]
    --
    -- Which gives:
    --
    -- > <container>
    -- >     <wrapper>1</wrapper>
    -- >     <wrapper>2</wrapper>
    -- >     <wrapper>3</wrapper>
    -- > </container>
    --
    -- Use `mapM_ toXML xs` to convert a list without wrapping
    -- each item in separate element.
    --
    -- > let mess = element "container" $ mapM_ toXML ["chunky", "chunk"]
    --
    -- Content nodes tend to glue together:
    --
    -- > <container>chunkychunk</container>
    many :: (ToXML a)
         => Name -- ^ Container element name.
         -> [a]  -- ^ Items to convert.
         -> XML
    many :: forall a. ToXML a => Name -> [a] -> XML
    many Name
    n = (a -> XML) -> [a] -> XML
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (Name -> XML -> XML
    forall a. ToXML a => Name -> a -> XML
    element Name
    n (XML -> XML) -> (a -> XML) -> a -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> XML
    forall a. ToXML a => a -> XML
    toXML)

    -- | Attach a prefix to a Name.
    --
    -- Because simply placing a colon in an element name
    -- yields 'Nothing' as a prefix and children will
    -- revert to en empty namespace.
    (!:) :: Text -> Name -> Name
    Text
    pref !: :: Text -> Name -> Name
    !: Name
    name = Name
    name { namePrefix = Just pref }

    -- | Provide instances for this class to use your data
    -- as "XML" nodes.
    class ToXML a where
        toXML :: a -> XML

    -- | Do nothing.
    instance ToXML () where
        toXML :: () -> XML
    toXML () = XML
    empty

    -- | Insert already prepared nodes.
    instance ToXML XML where
        toXML :: XML -> XML
    toXML = XML -> XML
    forall a. a -> a
    id

    -- | Don't use [Char] please, it will scare OverloadedStrings.
    instance ToXML Text where
        toXML :: Text -> XML
    toXML = Text -> XML
    content

    -- | XML schema uses lower case.
    instance ToXML Bool where
        toXML :: Bool -> XML
    toXML Bool
    True  = XML
    "true"
        toXML Bool
    False = XML
    "false"

    instance ToXML Float where
        toXML :: Float -> XML
    toXML = Text -> XML
    content (Text -> XML) -> (Float -> Text) -> Float -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    T.pack (String -> Text) -> (Float -> String) -> Float -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Float -> String
    forall a. Show a => a -> String
    show

    instance ToXML Double where
        toXML :: Double -> XML
    toXML = Text -> XML
    content (Text -> XML) -> (Double -> Text) -> Double -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    T.pack (String -> Text) -> (Double -> String) -> Double -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Double -> String
    forall a. Show a => a -> String
    show

    instance ToXML Int where
        toXML :: Int -> XML
    toXML = Text -> XML
    content (Text -> XML) -> (Int -> Text) -> Int -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    T.pack (String -> Text) -> (Int -> String) -> Int -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String
    forall a. Show a => a -> String
    show

    instance ToXML Integer where
        toXML :: Integer -> XML
    toXML = Text -> XML
    content (Text -> XML) -> (Integer -> Text) -> Integer -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    T.pack (String -> Text) -> (Integer -> String) -> Integer -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Integer -> String
    forall a. Show a => a -> String
    show

    instance ToXML Char where
        toXML :: Char -> XML
    toXML = Text -> XML
    content (Text -> XML) -> (Char -> Text) -> Char -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> Text
    T.singleton

    -- | Insert node if available. Otherwise do nothing.
    instance (ToXML a) => ToXML (Maybe a) where
        toXML :: Maybe a -> XML
    toXML = XML -> (a -> XML) -> Maybe a -> XML
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe XML
    empty a -> XML
    forall a. ToXML a => a -> XML
    toXML

    instance IsString XML where
        fromString :: String -> XML
    fromString = Text -> XML
    content (Text -> XML) -> (String -> Text) -> String -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    T.pack

    -- | Generate a SOAPv1.1 document.
    --
    -- Empty header will be ignored.
    -- Envelope uses a `soapenv` prefix.
    -- Works great with 'ToXML' class.
    --
    -- > data BigData = BigData { webScale :: Bool }
    -- > instance ToXML BigData where
    -- >     toXML (BigData ws) = element ("v" !: "{vendor:uri}bigData") $ toXML ws
    -- > let doc = soap () (BigData True)
    soap :: (ToXML h, ToXML b)
         => h
         -> b
         -> Document
    soap :: forall h b. (ToXML h, ToXML b) => h -> b -> Document
    soap h
    header b
    body = Name -> XML -> Document
    document (Text -> Name
    sn Text
    "Envelope") (XML -> Document) -> XML -> Document
    forall a b. (a -> b) -> a -> b
    $ do
        -- Some servers are allergic to dangling Headers...
        Bool -> XML -> XML
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ [Node] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Node]
    headerContent) (XML -> XML) -> XML -> XML
    forall a b. (a -> b) -> a -> b
    $ do
            Node -> XML
    node (Node -> XML) -> (Element -> Node) -> Element -> XML
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Element -> Node
    NodeElement (Element -> XML) -> Element -> XML
    forall a b. (a -> b) -> a -> b
    $! Name -> Map Name Text -> [Node] -> Element
    Element (Text -> Name
    sn Text
    "Header") Map Name Text
    forall a. Default a => a
    def [Node]
    headerContent
        Name -> XML -> XML
    forall a. ToXML a => Name -> a -> XML
    element (Text -> Name
    sn Text
    "Body") (b -> XML
    forall a. ToXML a => a -> XML
    toXML b
    body)

        where sn :: Text -> Name
    sn Text
    n = Text -> Maybe Text -> Maybe Text -> Name
    Name Text
    n (Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    ns) (Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "soapenv")
              ns :: Text
    ns = Text
    "http://schemas.xmlsoap.org/soap/envelope/"
              headerContent :: [Node]
    headerContent = XML -> [Node]
    render (h -> XML
    forall a. ToXML a => a -> XML
    toXML h
    header)