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

    {- |
       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.XMLSchema.DataTypeLibW3CNames

    import Data.List
        ( sort )

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

    -- | The datatype for modelling the structure of an

    data Schema                     = Any
                                    | Seq           { Schema -> [Schema]
    sc_l  :: [Schema]
                                                    }
                                    | Alt           { sc_l  :: [Schema]
                                                    }
                                    | Rep           { Schema -> Int
    sc_lb :: Int
                                                    , Schema -> Int
    sc_ub :: Int
                                                    , Schema -> Schema
    sc_1  :: Schema
                                                    }
                                    | Element       { Schema -> Name
    sc_n  :: Name
                                                    , sc_1  :: Schema
                                                    }
                                    | Attribute     { sc_n  :: Name
                                                    , sc_1  :: Schema
                                                    }
                                    | ElemRef       { sc_n  :: Name
                                                    }
                                    | CharData      { Schema -> DataTypeDescr
    sc_dt :: DataTypeDescr
                                                    }
                                      deriving (Schema -> Schema -> Bool
    (Schema -> Schema -> Bool)
    -> (Schema -> Schema -> Bool) -> Eq Schema
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: Schema -> Schema -> Bool
    $c/= :: Schema -> Schema -> Bool
    == :: Schema -> Schema -> Bool
    $c== :: Schema -> Schema -> Bool
    Eq, Int -> Schema -> ShowS
    [Schema] -> ShowS
    Schema -> Name
    (Int -> Schema -> ShowS)
    -> (Schema -> Name) -> ([Schema] -> ShowS) -> Show Schema
    forall a.
    (Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
    showList :: [Schema] -> ShowS
    $cshowList :: [Schema] -> ShowS
    show :: Schema -> Name
    $cshow :: Schema -> Name
    showsPrec :: Int -> Schema -> ShowS
    $cshowsPrec :: Int -> Schema -> ShowS
    Show)

    type Name                       = String
    type Schemas                    = [Schema]

    data DataTypeDescr              = DTDescr { DataTypeDescr -> Name
    dtLib    :: String
                                              , DataTypeDescr -> Name
    dtName   :: String
                                              , DataTypeDescr -> Attributes
    dtParams :: Attributes
                                              }
                                      deriving (Int -> DataTypeDescr -> ShowS
    [DataTypeDescr] -> ShowS
    DataTypeDescr -> Name
    (Int -> DataTypeDescr -> ShowS)
    -> (DataTypeDescr -> Name)
    -> ([DataTypeDescr] -> ShowS)
    -> Show DataTypeDescr
    forall a.
    (Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
    showList :: [DataTypeDescr] -> ShowS
    $cshowList :: [DataTypeDescr] -> ShowS
    show :: DataTypeDescr -> Name
    $cshow :: DataTypeDescr -> Name
    showsPrec :: Int -> DataTypeDescr -> ShowS
    $cshowsPrec :: Int -> DataTypeDescr -> ShowS
    Show)

    instance Eq DataTypeDescr where
        x1 :: DataTypeDescr
    x1 == :: DataTypeDescr -> DataTypeDescr -> Bool
    == x2 :: DataTypeDescr
    x2 = DataTypeDescr -> Name
    dtLib DataTypeDescr
    x1 Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == DataTypeDescr -> Name
    dtLib DataTypeDescr
    x2
                   Bool -> Bool -> Bool
    &&
                   DataTypeDescr -> Name
    dtName DataTypeDescr
    x1 Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == DataTypeDescr -> Name
    dtName DataTypeDescr
    x2
                   Bool -> Bool -> Bool
    &&
                   Attributes -> Attributes
    forall a. Ord a => [a] -> [a]
    sort (DataTypeDescr -> Attributes
    dtParams DataTypeDescr
    x1) Attributes -> Attributes -> Bool
    forall a. Eq a => a -> a -> Bool
    == Attributes -> Attributes
    forall a. Ord a => [a] -> [a]
    sort (DataTypeDescr -> Attributes
    dtParams DataTypeDescr
    x2)

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

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

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

    isScXsd :: (Name -> Bool) -> Schema -> Bool
    isScXsd p :: Name -> Bool
    p (CharData (DTDescr lib :: Name
    lib n :: Name
    n _ps :: Attributes
    _ps))
                            = Name
    lib Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    w3cNS
                              Bool -> Bool -> Bool
    &&
                              Name -> Bool
    p Name
    n
    isScXsd _ _             = Bool
    False

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

    isScFixed               :: Schema -> Bool
    isScFixed :: Schema -> Bool
    isScFixed sc :: Schema
    sc            = (Name -> Bool) -> Schema -> Bool
    isScXsd (Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    xsd_string) Schema
    sc
                              Bool -> Bool -> Bool
    &&
                              ((Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == 1) (Int -> Bool) -> (Schema -> Int) -> Schema -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Name] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ([Name] -> Int) -> (Schema -> [Name]) -> Schema -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> [Name]
    words (Name -> [Name]) -> (Schema -> Name) -> Schema -> [Name]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Schema -> Name
    xsdParam Name
    xsd_enumeration) Schema
    sc

    isScEnum                :: Schema -> Bool
    isScEnum :: Schema -> Bool
    isScEnum sc :: Schema
    sc             = (Name -> Bool) -> Schema -> Bool
    isScXsd (Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    xsd_string) Schema
    sc
                              Bool -> Bool -> Bool
    &&
                              (Bool -> Bool
    not (Bool -> Bool) -> (Schema -> Bool) -> Schema -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (Name -> Bool) -> (Schema -> Name) -> Schema -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Schema -> Name
    xsdParam Name
    xsd_enumeration) Schema
    sc

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

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

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

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

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

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

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

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

    xsdParam                :: String -> Schema -> String
    xsdParam :: Name -> Schema -> Name
    xsdParam n :: Name
    n (CharData dtd :: DataTypeDescr
    dtd)
                            = Name -> Attributes -> Name
    forall k e. Eq k => k -> AssocList k [e] -> [e]
    lookup1 Name
    n (DataTypeDescr -> Attributes
    dtParams DataTypeDescr
    dtd)
    xsdParam _ _            = ""

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

    -- smart constructors for Schema datatype

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

    scDT            :: String -> String -> Attributes -> Schema
    scDT :: Name -> Name -> Attributes -> Schema
    scDT l :: Name
    l n :: Name
    n rl :: Attributes
    rl     = DataTypeDescr -> Schema
    CharData (DataTypeDescr -> Schema) -> DataTypeDescr -> Schema
    forall a b. (a -> b) -> a -> b
    $ Name -> Name -> Attributes -> DataTypeDescr
    DTDescr Name
    l Name
    n Attributes
    rl

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

    scString        :: Schema
    scString :: Schema
    scString        = Name -> Attributes -> Schema
    scDTxsd Name
    xsd_string []

    scString1       :: Schema
    scString1 :: Schema
    scString1       = Name -> Attributes -> Schema
    scDTxsd Name
    xsd_string [(Name
    xsd_minLength, "1")]

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

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

    scNmtoken       :: Schema
    scNmtoken :: Schema
    scNmtoken       = Name -> Attributes -> Schema
    scDTxsd Name
    xsd_NCName []

    scNmtokens      :: Schema
    scNmtokens :: Schema
    scNmtokens      = Schema -> Schema
    scList Schema
    scNmtoken

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

    scEmpty                         :: Schema
    scEmpty :: Schema
    scEmpty                         = [Schema] -> Schema
    Seq []

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

    scSeqs                          :: [Schema] -> Schema
    scSeqs :: [Schema] -> Schema
    scSeqs                          = (Schema -> Schema -> Schema) -> Schema -> [Schema] -> Schema
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Schema -> Schema -> Schema
    scSeq Schema
    scEmpty

    scNull                          :: Schema
    scNull :: Schema
    scNull                          = [Schema] -> Schema
    Alt []

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

    scAlts          :: [Schema] -> Schema
    scAlts :: [Schema] -> Schema
    scAlts          = (Schema -> Schema -> Schema) -> Schema -> [Schema] -> Schema
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Schema -> Schema -> Schema
    scAlt Schema
    scNull

    scOption        :: Schema -> Schema
    scOption :: Schema -> Schema
    scOption     (Seq [])           = Schema
    scEmpty
    scOption (Attribute n :: Name
    n sc2 :: Schema
    sc2)      = Name -> Schema -> Schema
    Attribute Name
    n (Schema -> Schema
    scOption Schema
    sc2)
    scOption sc1 :: Schema
    sc1
        | Schema
    sc1 Schema -> Schema -> Bool
    forall a. Eq a => a -> a -> Bool
    == Schema
    scString1          = Schema
    scString
        | Bool
    otherwise                 = Schema -> Schema
    scOpt Schema
    sc1

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

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

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

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

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

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

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