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

    {- |
       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

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