----------------------------------------------------------------------------
--
-- Module	: HXML.HaXmlAdapter
-- Copyright	: (C) 2000-2002 Joe English.  Freely redistributable.
-- License	: "MIT-style"
--
-- Author	: Joe English <jenglish@flightlab.com>
-- Stability	: provisional
-- Portability	: portable
--
-- $Id: HaXmlAdapter.hs,v 1.3 2002/03/06 04:20:50 joe Exp $
--
----------------------------------------------------------------------------
--
-- Adapter for HaXml
--

module HaXmlAdapter where

import XmlTypes	

import XML (XMLNode(..))
import XMLParse
import Tree
import TreeBuild
import PrintXML

import qualified XmlPP
import qualified Pretty


-- Extra HaXml combinators:
-- c1 +++ c2 +++ ... +++ cN is more space-efficient than cat [c1, c2, ... ,cN]
-- mkElem' is similar to mkElem, but does not use cat internally.

-- type CFilter = Content -> [Content]
mkElem' :: String -> (Content -> [Content]) -> (Content -> [Content])
mkElem' h cf = \t -> [CElem (Elem h [] (cf t))]

(+++) :: (a -> [b]) -> (a -> [b]) -> a -> [b]
(+++) = lift (++) where lift f g h x = f (g x) (h x)

--

toContent :: Tree XMLNode -> Content
toContent = foldTree convertNode (:) []

fromContent :: Content -> Tree XMLNode
fromContent = buildTree . serializeContent

parseContent :: String -> Content
parseContent = buildContent . parseDocument

buildContent :: [XMLEvent] -> Content
buildContent = constructTree convertNode (:) []

convertNode :: XMLNode -> [Content] -> Content
convertNode (TXNode text) _ 	= CString False text
convertNode (ELNode gi atts) c	= CElem (Elem gi (pairsToAtts atts) c)
convertNode (PINode tgt val) _  = CMisc (PI (tgt,val))
convertNode (CXNode txt) _	= CMisc (Comment txt)
convertNode (ENNode ename) _	= CRef (RefEntity ename)
convertNode  RTNode content 	= rootElement content where
    rootElement (x@(CElem _):_) = x
    rootElement (_:rest)	= rootElement rest
    rootElement [] 		= error "No root element found"

fromAttValue :: AttValue -> String
toAttValue   :: String -> AttValue
pairsToAtts  :: [(String,String)] -> [(String,AttValue)] 
attsToPairs  :: [(String,AttValue)] -> [(String,String)] 

pairsToAtts l = [(name, toAttValue   value) | (name, value) <- l]
attsToPairs l = [(name, fromAttValue value) | (name, value) <- l]

toAttValue value = AttValue [Left value]
fromAttValue (AttValue fs) = concatMap (either id fromReference) fs

-- @@@ This is incorrect:
-- @@@ However, it never gets called either, so that's OK.
fromReference :: Reference -> String
fromReference (RefEntity ename)	= "&" ++ ename ++ ";"
fromReference (RefChar stuff)	= "&" ++ stuff ++ ";"

serializeContent :: Content -> [XMLEvent]
serializeContent content = sc content [] where 
    sc c k = case c of
	CElem (Elem gi atts children) ->
	    (StartEvent gi (attsToPairs atts)) : sl children (EndEvent gi : k)
	CString _ text 		-> TextEvent text : k
	CRef (RefEntity ename) 	-> GERefEvent ename : k
	CRef (RefChar stuff) 	-> GERefEvent stuff : k	-- @@@ this is wrong
	CMisc (Comment txt)	-> CommentEvent txt : k
	CMisc (PI (tgt,val))	-> PIEvent tgt val : k
    sl [] k 	= k
    sl (x:xs) k = sc x (sl xs k)

processXmlWith' :: (Content -> [Content]) -> IO ()
processXmlWith' filter = 
    getContents >>= (putString . renderContent . filter . parseContent)
    where putString = mapM_ putChar -- @@ putStrLn is leaky in Hugs and NHC.

renderContent :: [Content] -> String
renderContent = Pretty.render . XmlPP.element . extractRoot where
	extractRoot (CElem e:_) = e
	extractRoot []  	= error "produced no output"
	extractRoot _   	= error "produced more than one output"

processXmlWith'' :: (Content -> [Content]) -> IO ()
processXmlWith'' filter = 
    getContents >>= 
	(printContent . head . filter . parseContent) >> putChar '\n'

printContent :: Content -> IO ()
printContent = printEvents . serializeContent

showContent :: Content -> String
showContent = showEvents . serializeContent

-- *EOF*
