{-# 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

-- | 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)