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

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

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