Schema.hs

-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.Arrow.Pickle.Schema
   Copyright  : Copyright (C) 2005 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : experimental
   Portability: portable
   Version    : $Id$

Datatypes and functions for building a content model
for XML picklers. A schema is part of every pickler
and can be used to derive a corrensponding DTD (or Relax NG schema).
This schema further enables checking the picklers.

-}

-- ------------------------------------------------------------

module Text.XML.HXT.Arrow.Pickle.Schema
where

import Text.XML.HXT.DOM.TypeDefs
import Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C

import Data.List
    ( sort )

-- ------------------------------------------------------------

-- | The datatype for modelling the structure of an

data Schema			= Any
				| Seq		{ sc_l	:: [Schema]
						}
				| Alt		{ sc_l	:: [Schema]
						}
				| Rep		{ sc_lb	:: Int
						, sc_ub	:: Int
						, sc_1	:: Schema
						}
				| Element	{ sc_n	:: Name
						, sc_1	:: Schema
						}
				| Attribute	{ sc_n	:: Name
						, sc_1	:: Schema
						}
				| ElemRef	{ sc_n	:: Name
						}
				| CharData	{ sc_dt	:: DataTypeDescr
						}
				  deriving (Eq, Show)

type Name			= String
type Schemas			= [Schema]

data DataTypeDescr		= DTDescr { dtLib    :: String
					  , dtName   :: String
					  , dtParams :: Attributes
					  }
				  deriving (Show)

instance Eq DataTypeDescr where
    x1 == x2 = dtLib x1 == dtLib x2
	       &&
	       dtName x1 == dtName x2
	       &&
	       sort (dtParams x1) == sort (dtParams x2)

-- ------------------------------------------------------------

-- | test: is schema a simple XML Schema datatype

isScXsd			:: (String -> Bool) -> Schema -> Bool

isScXsd p (CharData (DTDescr lib n _ps))
			= lib == w3cNS
			  &&
			  p n
isScXsd _ _		= False

-- | test: is type a fixed value attribute type

isScFixed		:: Schema -> Bool
isScFixed sc		= isScXsd (== xsd_string) sc
			  &&
			  ((== 1) . length . words . xsdParam xsd_enumeration) sc

isScEnum		:: Schema -> Bool
isScEnum sc		= isScXsd (== xsd_string) sc
			  &&
			  (not . null . xsdParam xsd_enumeration) sc

isScElem		:: Schema -> Bool
isScElem (Element _ _)	= True
isScElem _		= False

isScAttr		:: Schema -> Bool
isScAttr (Attribute _ _)= True
isScAttr _		= False

isScElemRef		:: Schema -> Bool
isScElemRef (ElemRef _)	= True
isScElemRef _		= False

isScCharData		:: Schema -> Bool
isScCharData (CharData _)= True
isScCharData _		= False

isScSARE		:: Schema -> Bool
isScSARE (Seq _)	= True
isScSARE (Alt _)	= True
isScSARE (Rep _ _ _)	= True
isScSARE (ElemRef _)	= True
isScSARE _		= False

isScList		:: Schema -> Bool
isScList (Rep 0 (-1) _)	= True
isScList _		= False

isScOpt			:: Schema -> Bool
isScOpt (Rep 0 1 _)	= True
isScOpt _		= False

-- | access an attribute of a descr of an atomic type

xsdParam		:: String -> Schema -> String
xsdParam n (CharData dtd)
                        = lookup1 n (dtParams dtd)
xsdParam _ _            = ""

-- ------------------------------------------------------------

-- smart constructors for Schema datatype

-- ------------------------------------------------------------
--
-- predefined xsd data types for representation of DTD types

scDT		:: String -> String -> Attributes -> Schema
scDT l n rl	= CharData $ DTDescr l n rl

scDTxsd		:: String -> Attributes -> Schema
scDTxsd		= scDT w3cNS

scString	:: Schema
scString	= scDTxsd xsd_string []

scString1	:: Schema
scString1	= scDTxsd xsd_string [(xsd_minLength, "1")]

scFixed		:: String -> Schema
scFixed v	= scDTxsd xsd_string [(xsd_enumeration, v)]

scEnum		:: [String] -> Schema
scEnum vs	= scFixed (unwords vs)

scNmtoken	:: Schema
scNmtoken	= scDTxsd xsd_NCName []

scNmtokens	:: Schema
scNmtokens	= scList scNmtoken

-- ------------------------------------------------------------

scEmpty				:: Schema
scEmpty				= Seq []

scSeq				:: Schema -> Schema -> Schema
scSeq (Seq [])   sc2		= sc2
scSeq sc1        (Seq [])	= sc1
scSeq (Seq scs1) (Seq scs2)	= Seq (scs1 ++ scs2)	-- prevent nested Seq expr
scSeq (Seq scs1) sc2		= Seq (scs1 ++ [sc2])
scSeq sc1        (Seq scs2)	= Seq (sc1  :  scs2)
scSeq sc1        sc2		= Seq [sc1,sc2]

scSeqs				:: [Schema] -> Schema
scSeqs				= foldl scSeq scEmpty

scNull				:: Schema
scNull				= Alt []

scAlt				:: Schema -> Schema -> Schema
scAlt (Alt [])   sc2		= sc2
scAlt sc1        (Alt [])	= sc1
scAlt (Alt scs1) (Alt scs2)	= Alt (scs1 ++ scs2)	-- prevent nested Alt expr
scAlt (Alt scs1) sc2		= Alt (scs1 ++ [sc2])
scAlt sc1        (Alt scs2)	= Alt (sc1  :  scs2)
scAlt sc1        sc2		= Alt [sc1,sc2]

scAlts		:: [Schema] -> Schema
scAlts		= foldl scAlt scNull

scOption	:: Schema -> Schema
scOption     (Seq [])		= scEmpty
scOption (Attribute n sc2)	= Attribute n (scOption sc2)
scOption sc1
    | sc1 == scString1		= scString
    | otherwise			= scOpt sc1

scList		:: Schema -> Schema
scList		= scRep 0 (-1)

scList1		:: Schema -> Schema
scList1		= scRep 1 (-1)

scOpt		:: Schema -> Schema
scOpt		= scRep 0 1

scRep		:: Int -> Int -> Schema -> Schema
scRep l u sc1  = Rep l u sc1

scElem		:: String -> Schema -> Schema
scElem n sc1	= Element n sc1

scAttr		:: String -> Schema -> Schema
scAttr n sc1	= Attribute n sc1

-- ------------------------------------------------------------