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

{- |
   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
    DataTypeDescr
x1 == :: DataTypeDescr -> DataTypeDescr -> Bool
== 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 Name -> Bool
p (CharData (DTDescr Name
lib Name
n 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 Name -> Bool
_ Schema
_             = Bool
False

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

isScFixed               :: Schema -> Bool
isScFixed :: Schema -> Bool
isScFixed 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
== Int
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 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 Name
_ Schema
_)  = Bool
True
isScElem Schema
_              = Bool
False

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

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

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

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

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

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

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

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

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

-- 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 Name
l Name
n 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, Name
"1")]

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

scEnum          :: [String] -> Schema
scEnum :: [Name] -> Schema
scEnum [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 [])   Schema
sc2            = Schema
sc2
scSeq Schema
sc1        (Seq [])       = Schema
sc1
scSeq (Seq [Schema]
scs1) (Seq [Schema]
scs2)     = [Schema] -> Schema
Seq ([Schema]
scs1 [Schema] -> [Schema] -> [Schema]
forall a. [a] -> [a] -> [a]
++ [Schema]
scs2)    -- prevent nested Seq expr
scSeq (Seq [Schema]
scs1) Schema
sc2            = [Schema] -> Schema
Seq ([Schema]
scs1 [Schema] -> [Schema] -> [Schema]
forall a. [a] -> [a] -> [a]
++ [Schema
sc2])
scSeq Schema
sc1        (Seq [Schema]
scs2)     = [Schema] -> Schema
Seq (Schema
sc1  Schema -> [Schema] -> [Schema]
forall a. a -> [a] -> [a]
:  [Schema]
scs2)
scSeq Schema
sc1        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 [])   Schema
sc2            = Schema
sc2
scAlt Schema
sc1        (Alt [])       = Schema
sc1
scAlt (Alt [Schema]
scs1) (Alt [Schema]
scs2)     = [Schema] -> Schema
Alt ([Schema]
scs1 [Schema] -> [Schema] -> [Schema]
forall a. [a] -> [a] -> [a]
++ [Schema]
scs2)    -- prevent nested Alt expr
scAlt (Alt [Schema]
scs1) Schema
sc2            = [Schema] -> Schema
Alt ([Schema]
scs1 [Schema] -> [Schema] -> [Schema]
forall a. [a] -> [a] -> [a]
++ [Schema
sc2])
scAlt Schema
sc1        (Alt [Schema]
scs2)     = [Schema] -> Schema
Alt (Schema
sc1  Schema -> [Schema] -> [Schema]
forall a. a -> [a] -> [a]
:  [Schema]
scs2)
scAlt Schema
sc1        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 Name
n Schema
sc2)      = Name -> Schema -> Schema
Attribute Name
n (Schema -> Schema
scOption Schema
sc2)
scOption 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 Int
0 (-Int
1)

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

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

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

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

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

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