1-- ------------------------------------------------------------
2
3{- |
4   Module     : Text.XML.HXT.Arrow.Pickle.Schema
5   Copyright  : Copyright (C) 2005 Uwe Schmidt
6   License    : MIT
7
8   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
9   Stability  : experimental
10   Portability: portable
11   Version    : $Id$
12
13Datatypes and functions for building a content model
14for XML picklers. A schema is part of every pickler
15and can be used to derive a corrensponding DTD (or Relax NG schema).
16This schema further enables checking the picklers.
17
18-}
19
20-- ------------------------------------------------------------
21
22module Text.XML.HXT.Arrow.Pickle.Schema
23where
24
25import Text.XML.HXT.DOM.TypeDefs
26import Text.XML.HXT.XMLSchema.DataTypeLibW3CNames
27
28import Data.List
29    ( sort )
30
31-- ------------------------------------------------------------
32
33-- | The datatype for modelling the structure of an
34
35data Schema                     = Any
36                                | Seq           { sc_l  :: [Schema]
37                                                }
38                                | Alt           { sc_l  :: [Schema]
39                                                }
40                                | Rep           { sc_lb :: Int
41                                                , sc_ub :: Int
42                                                , sc_1  :: Schema
43                                                }
44                                | Element       { sc_n  :: Name
45                                                , sc_1  :: Schema
46                                                }
47                                | Attribute     { sc_n  :: Name
48                                                , sc_1  :: Schema
49                                                }
50                                | ElemRef       { sc_n  :: Name
51                                                }
52                                | CharData      { sc_dt :: DataTypeDescr
53                                                }
54                                  deriving (Eq, Show)
55
56type Name                       = String
57type Schemas                    = [Schema]
58
59data DataTypeDescr              = DTDescr { dtLib    :: String
60                                          , dtName   :: String
61                                          , dtParams :: Attributes
62                                          }
63                                  deriving (Show)
64
65instance Eq DataTypeDescr where
66    x1 == x2 = dtLib x1 == dtLib x2
67               &&
68               dtName x1 == dtName x2
69               &&
70               sort (dtParams x1) == sort (dtParams x2)
71
72-- ------------------------------------------------------------
73
74-- | test: is schema a simple XML Schema datatype
75
76isScXsd                 :: (String -> Bool) -> Schema -> Bool
77
78isScXsd p (CharData (DTDescr lib n _ps))
79                        = lib == w3cNS
80                          &&
81                          p n
82isScXsd _ _             = False
83
84-- | test: is type a fixed value attribute type
85
86isScFixed               :: Schema -> Bool
87isScFixed sc            = isScXsd (== xsd_string) sc
88                          &&
89                          ((== 1) . length . words . xsdParam xsd_enumeration) sc
90
91isScEnum                :: Schema -> Bool
92isScEnum sc             = isScXsd (== xsd_string) sc
93                          &&
94                          (not . null . xsdParam xsd_enumeration) sc
95
96isScElem                :: Schema -> Bool
97isScElem (Element _ _)  = True
98isScElem _              = False
99
100isScAttr                :: Schema -> Bool
101isScAttr (Attribute _ _)= True
102isScAttr _              = False
103
104isScElemRef             :: Schema -> Bool
105isScElemRef (ElemRef _) = True
106isScElemRef _           = False
107
108isScCharData            :: Schema -> Bool
109isScCharData (CharData _)= True
110isScCharData _          = False
111
112isScSARE                :: Schema -> Bool
113isScSARE (Seq _)        = True
114isScSARE (Alt _)        = True
115isScSARE (Rep _ _ _)    = True
116isScSARE (ElemRef _)    = True
117isScSARE _              = False
118
119isScList                :: Schema -> Bool
120isScList (Rep 0 (-1) _) = True
121isScList _              = False
122
123isScOpt                 :: Schema -> Bool
124isScOpt (Rep 0 1 _)     = True
125isScOpt _               = False
126
127-- | access an attribute of a descr of an atomic type
128
129xsdParam                :: String -> Schema -> String
130xsdParam n (CharData dtd)
131                        = lookup1 n (dtParams dtd)
132xsdParam _ _            = ""
133
134-- ------------------------------------------------------------
135
136-- smart constructors for Schema datatype
137
138-- ------------------------------------------------------------
139--
140-- predefined xsd data types for representation of DTD types
141
142scDT            :: String -> String -> Attributes -> Schema
143scDT l n rl     = CharData $ DTDescr l n rl
144
145scDTxsd         :: String -> Attributes -> Schema
146scDTxsd         = scDT w3cNS
147
148scString        :: Schema
149scString        = scDTxsd xsd_string []
150
151scString1       :: Schema
152scString1       = scDTxsd xsd_string [(xsd_minLength, "1")]
153
154scFixed         :: String -> Schema
155scFixed v       = scDTxsd xsd_string [(xsd_enumeration, v)]
156
157scEnum          :: [String] -> Schema
158scEnum vs       = scFixed (unwords vs)
159
160scNmtoken       :: Schema
161scNmtoken       = scDTxsd xsd_NCName []
162
163scNmtokens      :: Schema
164scNmtokens      = scList scNmtoken
165
166-- ------------------------------------------------------------
167
168scEmpty                         :: Schema
169scEmpty                         = Seq []
170
171scSeq                           :: Schema -> Schema -> Schema
172scSeq (Seq [])   sc2            = sc2
173scSeq sc1        (Seq [])       = sc1
174scSeq (Seq scs1) (Seq scs2)     = Seq (scs1 ++ scs2)    -- prevent nested Seq expr
175scSeq (Seq scs1) sc2            = Seq (scs1 ++ [sc2])
176scSeq sc1        (Seq scs2)     = Seq (sc1  :  scs2)
177scSeq sc1        sc2            = Seq [sc1,sc2]
178
179scSeqs                          :: [Schema] -> Schema
180scSeqs                          = foldl scSeq scEmpty
181
182scNull                          :: Schema
183scNull                          = Alt []
184
185scAlt                           :: Schema -> Schema -> Schema
186scAlt (Alt [])   sc2            = sc2
187scAlt sc1        (Alt [])       = sc1
188scAlt (Alt scs1) (Alt scs2)     = Alt (scs1 ++ scs2)    -- prevent nested Alt expr
189scAlt (Alt scs1) sc2            = Alt (scs1 ++ [sc2])
190scAlt sc1        (Alt scs2)     = Alt (sc1  :  scs2)
191scAlt sc1        sc2            = Alt [sc1,sc2]
192
193scAlts          :: [Schema] -> Schema
194scAlts          = foldl scAlt scNull
195
196scOption        :: Schema -> Schema
197scOption     (Seq [])           = scEmpty
198scOption (Attribute n sc2)      = Attribute n (scOption sc2)
199scOption sc1
200    | sc1 == scString1          = scString
201    | otherwise                 = scOpt sc1
202
203scList          :: Schema -> Schema
204scList          = scRep 0 (-1)
205
206scList1         :: Schema -> Schema
207scList1         = scRep 1 (-1)
208
209scOpt           :: Schema -> Schema
210scOpt           = scRep 0 1
211
212scRep           :: Int -> Int -> Schema -> Schema
213scRep l u sc1  = Rep l u sc1
214
215scElem          :: String -> Schema -> Schema
216scElem n sc1    = Element n sc1
217
218scAttr          :: String -> Schema -> Schema
219scAttr n sc1    = Attribute n sc1
220
221-- ------------------------------------------------------------
222