HaXmlAliases.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.XML.HaXmlAliases
-- Copyright   :  (c) 2011 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Multifocal:
-- Bidirectional Two-level Transformation of XML Schemas
-- 
-- Alaises for the HaXml library.
--
-----------------------------------------------------------------------------

module Language.XML.HaXmlAliases
    where

import Text.XML.HaXml.Types
import Text.XML.HaXml.ParseLazy as Lazy hiding (document)
import Text.XML.HaXml.Parse as Strict hiding (document)
import Text.XML.HaXml.Posn
import Text.XML.HaXml.Schema.Schema
import Text.XML.HaXml.Schema.Parse
import Text.XML.HaXml.Schema.XSDTypeModel
import Text.XML.HaXml.Util
import Text.XML.HaXml.Namespaces
import Text.XML.HaXml.Schema.TypeConversion
import Text.XML.HaXml.Schema.Environment
import Text.XML.HaXml.Pretty
import Text.PrettyPrint.HughesPJ
import Control.Monad

-- | Parses a XML file into HaXml 'Document' type.
parseXml :: String -> String -> Document Posn
parseXml = Strict.xmlParse

-- | Parses a XML file into HaXml 'Document' type. (Lazy)
parseXmlLazy :: String -> String -> Document Posn
parseXmlLazy = Lazy.xmlParse

-- | Parses a XML DTD into Haxml 'DocTypeDecl' type.
parseDtd :: String -> String -> Maybe DocTypeDecl
parseDtd = Strict.dtdParse

-- | Parses a XML DTD into Haxml 'DocTypeDecl' type. (Lazy)
parseDtdLazy :: String -> String -> Maybe DocTypeDecl
parseDtdLazy = Lazy.dtdParse

doc2Xsd :: Document Posn -> Maybe Schema
doc2Xsd doc = case runParser schema [docContent (posInNewCxt "" Nothing) doc] of
	(Right schema,[]) -> return schema
	(Left msg,_)      -> fail msg

one2posn :: Document () -> Document Posn
one2posn (Document a b e c) = Document a b (one2posn' e) c
	where
	one2posn' :: Element () -> Element Posn
	one2posn' (Elem n as cs) = Elem n as $ map one2posn'' cs
	
	one2posn'' :: Content () -> Content Posn
	one2posn'' (CElem e _) = CElem (one2posn' e) noPos
	one2posn'' (CString b c _) = CString b c noPos
	one2posn'' (CRef r _) = CRef r noPos
	one2posn'' (CMisc m _) = CMisc m noPos

parseXsd :: String -> String -> Maybe Schema
parseXsd name content = do
	let doc@Document{} = resolveAllNames qualify
	                     . either (error . ("not XML:\n"++)) id
	                     . xmlParse' name
	                     $ content
	doc2Xsd doc

renderXml :: Document a -> String
renderXml = render . document

testDoc = do
	xml <- readFile "examples/imdb.xml"
	print $ document $ parseXml "examples/imdb.xml" xml
	
testXsd = do
	xml <- readFile "examples/company.xsd"
	print $ parseXsd "examples/company.xsd" xml
testSchema = do
	xml <- readFile "examples/imdb.xsd"
	print $ parseXsd "examples/imdb.xsd" xml