XML.hs

{-# OPTIONS -fallow-overlapping-instances -fallow-undecidable-instances -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  HSP.Data.XML
-- Copyright   :  (c) Niklas Broberg 2004,
-- License     :  BSD-style (see the file LICENSE.txt)
-- 
-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se
-- Stability   :  experimental
-- Portability :  requires undecidable and overlapping instances
--
-- Datatypes and type classes comprising the basic model behind
-- the scenes of Haskell Server Pages tags.
-----------------------------------------------------------------------------
module HSP.Data.XML (
	-- * The 'XML' datatype
	XML(..), 
	Domain, 
	Name, 
	Attributes, 
	Children,
	pcdata,
	cdata,
	-- * The Attribute type
	Attribute,
	AttrValue(..),
	-- * Functions
	renderXML,
	isTag, isCdata
	) where

import Data.List (intersperse)

import HSP.Data.PCDATA (toPCDATA)
---------------------------------------------------------------
-- Data types

type Domain = Maybe String
type Name = (Domain, String)
type Attributes = [Attribute]
type Children = [XML]

data XML = Tag Name Attributes Children
	 | CDATA String

instance Show XML where
 show = renderXML

isTag, isCdata :: XML -> Bool
isTag (Tag {}) = True
isTag _ = False
isCdata = not . isTag

pcdata :: String -> XML
pcdata = CDATA . toPCDATA

cdata :: String -> XML
cdata = CDATA

---------------------------------------------------------------
-- Attributes

type Attribute = (Name, AttrValue)

newtype AttrValue = Value String

instance Show AttrValue where
 show (Value str) = str

------------------------------------------------------------------
-- Rendering

renderXML :: XML -> String
renderXML xml = renderXML' 0 xml ""

data TagType = Open | Close | Single

renderXML' :: Int -> XML -> ShowS
renderXML' _ (CDATA cdata) = showString cdata
renderXML' n (Tag name attrs []) = renderTag Single n name attrs
renderXML' n (Tag 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 (n, (Value val)) = showName n . showChar '=' . renderAttrVal 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 ' ')