module Text.XML.HXT.Arrow.Pickle.Schema
where
import Text.XML.HXT.DOM.TypeDefs
import Text.XML.HXT.XMLSchema.DataTypeLibW3CNames
import Data.List
( sort )
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)
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
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
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 _ _ = ""
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)
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)
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