{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Text.XML.Writer
(
document
, documentA
, documentD
, documentAD
, soap
, pprint
, XML
, node
, instruction
, comment
, element, elementMaybe, elementA
, content
, empty
, many
, render, (!:)
, 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
type XML = Writer (DL.DList Node) ()
document :: Name
-> XML
-> 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
}
documentA :: Name
-> [(Name, Text)]
-> XML
-> 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
}
documentD :: Name
-> Maybe Doctype
-> XML
-> 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
}
documentAD :: Name
-> [(Name, Text)]
-> Maybe Doctype
-> XML
-> 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
}
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 }
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
empty :: XML
empty :: XML
empty = () -> XML
forall a. a -> WriterT (DList Node) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
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)
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)
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)
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_
comment :: Text -> XML
= Node -> XML
node (Node -> XML) -> (Text -> Node) -> Text -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Node
NodeComment
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
many :: (ToXML a)
=> Name
-> [a]
-> 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)
(!:) :: Text -> Name -> Name
Text
pref !: :: Text -> Name -> Name
!: Name
name = Name
name { namePrefix = Just pref }
class ToXML a where
toXML :: a -> XML
instance ToXML () where
toXML :: () -> XML
toXML () = XML
empty
instance ToXML XML where
toXML :: XML -> XML
toXML = XML -> XML
forall a. a -> a
id
instance ToXML Text where
toXML :: Text -> XML
toXML = Text -> XML
content
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
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
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
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)