module HSP.XML (
XML(..),
XMLMetaData(..),
Namespace,
NSName,
Attributes,
Children,
pcdata,
cdata,
Attribute(..),
AttrValue(..),
attrVal, pAttrVal,
renderXML,
isElement, isCDATA,
fromStringLit
) where
import Data.List (intersperse)
import Data.Monoid ((<>), mconcat)
import Data.String (fromString)
import Data.Text.Lazy.Builder (Builder, fromLazyText, singleton, toLazyText)
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as Text
import HSP.XML.PCDATA (escape)
fromStringLit :: String -> Text
fromStringLit :: String -> Text
fromStringLit = String -> Text
Text.pack
type Namespace = Maybe Text
type NSName = (Namespace, Text)
newtype Attribute = MkAttr (NSName, AttrValue)
deriving Int -> Attribute -> ShowS
[Attribute] -> ShowS
Attribute -> String
(Int -> Attribute -> ShowS)
-> (Attribute -> String)
-> ([Attribute] -> ShowS)
-> Show Attribute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attribute] -> ShowS
$cshowList :: [Attribute] -> ShowS
show :: Attribute -> String
$cshow :: Attribute -> String
showsPrec :: Int -> Attribute -> ShowS
$cshowsPrec :: Int -> Attribute -> ShowS
Show
data AttrValue = Value Bool Text | NoValue
attrVal, pAttrVal :: Text -> AttrValue
attrVal :: Text -> AttrValue
attrVal = Bool -> Text -> AttrValue
Value Bool
False
pAttrVal :: Text -> AttrValue
pAttrVal = Bool -> Text -> AttrValue
Value Bool
True
instance Show AttrValue where
show :: AttrValue -> String
show (Value Bool
_ Text
txt) = Text -> String
Text.unpack Text
txt
show AttrValue
NoValue = String
""
type Attributes = [Attribute]
data XML
= Element NSName Attributes Children
| CDATA Bool Text
deriving Int -> XML -> ShowS
[XML] -> ShowS
XML -> String
(Int -> XML -> ShowS)
-> (XML -> String) -> ([XML] -> ShowS) -> Show XML
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XML] -> ShowS
$cshowList :: [XML] -> ShowS
show :: XML -> String
$cshow :: XML -> String
showsPrec :: Int -> XML -> ShowS
$cshowsPrec :: Int -> XML -> ShowS
Show
type Children = [XML]
cdata , pcdata :: Text -> XML
cdata :: Text -> XML
cdata = Bool -> Text -> XML
CDATA Bool
False
pcdata :: Text -> XML
pcdata = Bool -> Text -> XML
CDATA Bool
True
isElement, isCDATA :: XML -> Bool
isElement :: XML -> Bool
isElement (Element {}) = Bool
True
isElement XML
_ = Bool
False
isCDATA :: XML -> Bool
isCDATA = Bool -> Bool
not (Bool -> Bool) -> (XML -> Bool) -> XML -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XML -> Bool
isElement
data XMLMetaData = XMLMetaData
{ XMLMetaData -> (Bool, Text)
doctype :: (Bool, Text)
, XMLMetaData -> Text
contentType :: Text
, XMLMetaData -> XML -> Builder
preferredRenderer :: XML -> Builder
}
data TagType = Open | Close | Single
renderTag :: TagType -> Int -> NSName -> Attributes -> Builder
renderTag :: TagType -> Int -> NSName -> [Attribute] -> Builder
renderTag TagType
typ Int
n NSName
name [Attribute]
attrs =
let (Builder
start,Builder
end) = case TagType
typ of
TagType
Open -> (Char -> Builder
singleton Char
'<', Char -> Builder
singleton Char
'>')
TagType
Close -> (String -> Builder
forall a. IsString a => String -> a
fromString String
"</", Char -> Builder
singleton Char
'>')
TagType
Single -> (Char -> Builder
singleton Char
'<', String -> Builder
forall a. IsString a => String -> a
fromString String
"/>")
nam :: Builder
nam = NSName -> Builder
showNSName NSName
name
as :: Builder
as = [Attribute] -> Builder
renderAttrs [Attribute]
attrs
in [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder
start, Builder
nam, Builder
as, Builder
end]
where renderAttrs :: Attributes -> Builder
renderAttrs :: [Attribute] -> Builder
renderAttrs [] = Builder
nl
renderAttrs [Attribute]
attrs' = Char -> Builder
singleton Char
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
ats Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
nl
where ats :: [Builder]
ats = Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse (Char -> Builder
singleton Char
' ') ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$ (Attribute -> Builder) -> [Attribute] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attribute -> Builder
renderAttr [Attribute]
attrs'
renderAttr :: Attribute -> Builder
renderAttr :: Attribute -> Builder
renderAttr (MkAttr (NSName
nam, (Value Bool
needsEscape Text
val))) =
NSName -> Builder
showNSName NSName
nam Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'=' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
renderAttrVal (if Bool
needsEscape then Text -> Builder
escape Text
val else Text -> Builder
fromLazyText Text
val)
renderAttr (MkAttr (NSName
nam, AttrValue
NoValue)) = NSName -> Builder
showNSName NSName
nam Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'=' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
renderAttrVal (String -> Builder
forall a. IsString a => String -> a
fromString String
"")
renderAttrVal :: Builder -> Builder
renderAttrVal :: Builder -> Builder
renderAttrVal Builder
txt = Char -> Builder
singleton Char
'\"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
txt Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'\"'
showNSName :: NSName -> Builder
showNSName (Maybe Text
Nothing, Text
s) = Text -> Builder
fromLazyText Text
s
showNSName (Just Text
d, Text
s) = Text -> Builder
fromLazyText Text
d Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromLazyText Text
s
nl :: Builder
nl = Char -> Builder
singleton Char
'\n' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
forall a. IsString a => String -> a
fromString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ')
renderXML' :: Int -> XML -> Builder
renderXML' :: Int -> XML -> Builder
renderXML' Int
_ (CDATA Bool
needsEscape Text
cd) = if Bool
needsEscape then Text -> Builder
escape Text
cd else Text -> Builder
fromLazyText Text
cd
renderXML' Int
n (Element NSName
name [Attribute]
attrs []) = TagType -> Int -> NSName -> [Attribute] -> Builder
renderTag TagType
Single Int
n NSName
name [Attribute]
attrs
renderXML' Int
n (Element NSName
name [Attribute]
attrs [XML]
children) =
let open :: Builder
open = TagType -> Int -> NSName -> [Attribute] -> Builder
renderTag TagType
Open Int
n NSName
name [Attribute]
attrs
cs :: Builder
cs = Int -> [XML] -> Builder
renderChildren Int
n [XML]
children
close :: Builder
close = TagType -> Int -> NSName -> [Attribute] -> Builder
renderTag TagType
Close Int
n NSName
name []
in Builder
open Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
close
where renderChildren :: Int -> Children -> Builder
renderChildren :: Int -> [XML] -> Builder
renderChildren Int
n' [XML]
cs = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (XML -> Builder) -> [XML] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> XML -> Builder
renderXML' (Int
n'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)) [XML]
cs
renderXML :: XML -> Text
renderXML :: XML -> Text
renderXML XML
xml = Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Int -> XML -> Builder
renderXML' Int
0 XML
xml