module HSP.XML (
XML(..),
XMLMetaData(..),
Domain,
Name,
Attributes,
Children,
pcdata,
cdata,
Attribute(..),
AttrValue(..),
attrVal, pAttrVal,
renderXML,
isElement, isCDATA
) where
import Data.List (intersperse)
import HSP.XML.PCDATA (escape)
type Domain = Maybe String
type Name = (Domain, String)
type Attributes = [Attribute]
type Children = [XML]
data XML = Element Name Attributes Children
| CDATA Bool String
deriving Show
data XMLMetaData = XMLMetaData
{ doctype :: (Bool, String)
, contentType :: String
, preferredRenderer :: XML -> String
}
isElement, isCDATA :: XML -> Bool
isElement (Element {}) = True
isElement _ = False
isCDATA = not . isElement
cdata , pcdata :: String -> XML
cdata = CDATA False
pcdata = CDATA True
newtype Attribute = MkAttr (Name, AttrValue)
deriving Show
data AttrValue = Value Bool String
attrVal, pAttrVal :: String -> AttrValue
attrVal = Value False
pAttrVal = Value True
instance Show AttrValue where
show (Value _ str) = str
renderXML :: XML -> String
renderXML xml = renderXML' 0 xml ""
data TagType = Open | Close | Single
renderXML' :: Int -> XML -> ShowS
renderXML' _ (CDATA needsEscape cd) = showString (if needsEscape then escape cd else cd)
renderXML' n (Element name attrs []) = renderTag Single n name attrs
renderXML' n (Element name attrs children) =
let open = renderTag Open n name attrs
cs = renderChildren n children
close = renderTag Close n name []
in open . cs . close
where renderChildren :: Int -> Children -> ShowS
renderChildren n' cs = foldl (.) id $ map (renderXML' (n'+2)) cs
renderTag :: TagType -> Int -> Name -> Attributes -> ShowS
renderTag typ n name attrs =
let (start,end) = case typ of
Open -> (showChar '<', showChar '>')
Close -> (showString "</", showChar '>')
Single -> (showChar '<', showString "/>")
nam = showName name
as = renderAttrs attrs
in start . nam . as . end
where renderAttrs :: Attributes -> ShowS
renderAttrs [] = nl
renderAttrs attrs' = showChar ' ' . ats . nl
where ats = foldl (.) id $ intersperse (showChar ' ') $ fmap renderAttr attrs'
renderAttr :: Attribute -> ShowS
renderAttr (MkAttr (nam, (Value needsEscape val))) = showName nam . showChar '=' . renderAttrVal (if needsEscape then escape val else val)
renderAttrVal :: String -> ShowS
renderAttrVal s = showChar '\"' . showString s . showChar '\"'
showName (Nothing, s) = showString s
showName (Just d, s) = showString d . showChar ':' . showString s
nl = showChar '\n' . showString (replicate n ' ')