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

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

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