git.iko.soy/typeable/xsd-parser
on master help sign in
swap
648877d9 ahead, 0 behind
.gitmodulesnew file+3
since splitsnapshots
unifiedsplit
@@ -0,0 +1,3 @@
1+[submodule "xsdtests"]
2+ path = xsdtests
3+ url = git@github.com:w3c/xsdtests.git
README.mdnew file+10
@@ -0,0 +1,10 @@
1+
2+# xsd-parser
3+
4+Library for parsing XML schema files.
5+
6+# W3C XML Schema 1.1 test suite
7+
8+The test suite is designed mostly to test validation, but at least we
9+can check whether we are able to parse all the xsd files from the
10+test suite. See results [here](xsts.md).
src/Xsd.hs+1−1
@@ -113,7 +113,7 @@ xsdToSchema xsd = Schema
113 go res [] = res
113 go res [] = res
114 go (ts, es) (c:cs) = case c of
114 go (ts, es) (c:cs) = case c of
115 ChildType n t -> go ((n, t):ts, es) cs
115 ChildType n t -> go ((n, t):ts, es) cs
116− ChildElement e -> go (ts, (elementName e, e):es) cs
116+ ChildElement (Inline e) -> go (ts, (elementName e, e):es) cs
117 _ -> go (ts, es) cs
117 _ -> go (ts, es) cs
118
118
119fetchXsd :: URI -> IO Xsd
119fetchXsd :: URI -> IO Xsd
src/Xsd/Parser.hs+158−53
@@ -48,7 +48,7 @@ parseChild :: Cursor -> P (Maybe Xsd.Child)
48parseChild c = do
48parseChild c = do
49 name <- getElementName c
49 name <- getElementName c
50 case name of
50 case name of
51− "element" -> Just . Xsd.ChildElement <$> parseElement c
51+ "element" -> Just . Xsd.ChildElement <$> parseElementOrRef c
52 "simpleType" -> Just <$> parseTopSimpleType c
52 "simpleType" -> Just <$> parseTopSimpleType c
53 "complexType" -> Just <$> parseTopComplexType c
53 "complexType" -> Just <$> parseTopComplexType c
54 "include" -> Just . Xsd.ChildInclude <$> parseInclude c
54 "include" -> Just . Xsd.ChildInclude <$> parseInclude c
@@ -81,14 +81,19 @@ parseImport c = do
81 , Xsd.importNamespace = namespace
81 , Xsd.importNamespace = namespace
82 }
82 }
83
83
84+parseElementOrRef :: Cursor -> P (Xsd.RefOr Xsd.Element)
85+parseElementOrRef c = do
86+ case anAttribute "ref" c of
87+ Nothing -> Xsd.Inline <$> parseElement c
88+ Just ref -> Xsd.Ref <$> makeQName c ref
89+
84parseElement :: Cursor -> P Xsd.Element
90parseElement :: Cursor -> P Xsd.Element
85parseElement c = handleNamespaces c $ do
91parseElement c = handleNamespaces c $ do
86 name <- theAttribute "name" c
92 name <- theAttribute "name" c
87
93
88− -- XXX: generalaze RefOr parsing
89 tp <- case anAttribute "type" c of
94 tp <- case anAttribute "type" c of
90 Just t -> Xsd.Ref <$> makeQName c t
95 Just t -> Xsd.Ref <$> makeQName c t
91− _ -> Xsd.Inline <$> parseType c
96+ _ -> maybe (Xsd.Ref anyType) Xsd.Inline <$> parseType c
92
97
93 minOccurs <- case anAttribute "minOccurs" c of
98 minOccurs <- case anAttribute "minOccurs" c of
94 Nothing -> return 1
99 Nothing -> return 1
@@ -107,22 +112,31 @@ parseElement c = handleNamespaces c $ do
107
112
108 qname <- makeTargetQName name
113 qname <- makeTargetQName name
109
114
115+ nillable <- case anAttribute "nillable" c of
116+ Nothing -> return False
117+ Just "true" -> return True
118+ Just "false" -> return False
119+ _ -> parseError c "Unexpected value of nillable attribute"
120+
110 return Xsd.Element
121 return Xsd.Element
111 { Xsd.elementName = qname
122 { Xsd.elementName = qname
112 , Xsd.elementType = tp
123 , Xsd.elementType = tp
113 , Xsd.elementAnnotations = annotations
124 , Xsd.elementAnnotations = annotations
114 , Xsd.elementOccurs = (minOccurs, maxOccurs)
125 , Xsd.elementOccurs = (minOccurs, maxOccurs)
126+ , Xsd.elementNillable = nillable
115 }
127 }
128+ where
129+ anyType = Xsd.QName (Just (Xsd.Namespace Xsd.schemaNamespace)) "anyType"
116
130
117-- | Parse inline type, simple or complex
131-- | Parse inline type, simple or complex
118−parseType :: Cursor -> P Xsd.Type
132+parseType :: Cursor -> P (Maybe Xsd.Type)
119parseType c = do
133parseType c = do
120 simpleTypeAxis <- makeElemAxis "simpleType"
134 simpleTypeAxis <- makeElemAxis "simpleType"
121 complexTypeAxis <- makeElemAxis "complexType"
135 complexTypeAxis <- makeElemAxis "complexType"
122 case (c $/ simpleTypeAxis, c $/ complexTypeAxis) of
136 case (c $/ simpleTypeAxis, c $/ complexTypeAxis) of
123− ([], []) -> parseError c "No type"
137+ ([], []) -> return Nothing
124− ([t], []) -> Xsd.TypeSimple <$> parseSimpleType t
138+ ([t], []) -> Just . Xsd.TypeSimple <$> parseSimpleType t
125− ([], [t]) -> Xsd.TypeComplex <$> parseComplexType t
139+ ([], [t]) -> Just . Xsd.TypeComplex <$> parseComplexType t
126 _ -> parseError c "Multiple types"
140 _ -> parseError c "Multiple types"
127
141
128-- | Top level simple type
142-- | Top level simple type
@@ -146,18 +160,19 @@ parseSimpleType c = do
146 unionAxis <- makeElemAxis "union"
160 unionAxis <- makeElemAxis "union"
147 case (c $/ restrictionAxis, c $/ listAxis, c $/ unionAxis) of
161 case (c $/ restrictionAxis, c $/ listAxis, c $/ unionAxis) of
148 ([e], [], []) -> Xsd.AtomicType
162 ([e], [], []) -> Xsd.AtomicType
149− <$> parseRestriction e
163+ <$> parseSimpleRestriction e
150 <*> parseAnnotations c
164 <*> parseAnnotations c
151 ([], [l], []) -> Xsd.ListType
165 ([], [l], []) -> Xsd.ListType
152 <$> parseList l
166 <$> parseList l
153 <*> parseAnnotations c
167 <*> parseAnnotations c
154− -- TODO implement me
168+ ([], [], [u]) -> Xsd.UnionType
155− ([], [], [_]) -> parseError c "Not implemented: union"
169+ <$> parseUnion u
170+ <*> parseAnnotations c
156 _ -> parseError c "Expected exactly of of restriction, list or union"
171 _ -> parseError c "Expected exactly of of restriction, list or union"
157
172
158-- | Restriction for simple type
173-- | Restriction for simple type
159−parseRestriction :: Cursor -> P Xsd.Restriction
174+parseSimpleRestriction :: Cursor -> P Xsd.SimpleRestriction
160−parseRestriction c = do
175+parseSimpleRestriction c = do
161 -- XXX: generalaze RefOr parsing
176 -- XXX: generalaze RefOr parsing
162 tp <- case anAttribute "base" c of
177 tp <- case anAttribute "base" c of
163 Nothing -> do
178 Nothing -> do
@@ -170,9 +185,9 @@ parseRestriction c = do
170
185
171 constraints <- parseConstrains c
186 constraints <- parseConstrains c
172
187
173− return Xsd.Restriction
188+ return Xsd.SimpleRestriction
174− { Xsd.restrictionBase = tp
189+ { Xsd.simpleRestrictionBase = tp
175− , Xsd.restrictionConstraints = constraints
190+ , Xsd.simpleRestrictionConstraints = constraints
176 }
191 }
177
192
178parseConstrains :: Cursor -> P [Xsd.Constraint]
193parseConstrains :: Cursor -> P [Xsd.Constraint]
@@ -193,30 +208,105 @@ parseList c =
193 _ -> parseError c "Multiple types"
208 _ -> parseError c "Multiple types"
194 Just t -> Xsd.Ref <$> makeQName c t
209 Just t -> Xsd.Ref <$> makeQName c t
195
210
211+parseUnion :: Cursor -> P [Xsd.RefOr Xsd.SimpleType]
212+parseUnion c =
213+ case anAttribute "memberTypes" c of
214+ Just list ->
215+ mapM (fmap Xsd.Ref . makeQName c) (Text.splitOn " " list)
216+ Nothing -> do
217+ simpleTypeAxis <- makeElemAxis "simpleType"
218+ mapM (fmap Xsd.Inline . parseSimpleType) (c $/ simpleTypeAxis)
219+
196parseComplexType :: Cursor -> P Xsd.ComplexType
220parseComplexType :: Cursor -> P Xsd.ComplexType
197parseComplexType c = do
221parseComplexType c = do
198− attrAxis <- makeElemAxis "attribute"
199− attributes <- mapM parseAttribute (c $/ attrAxis)
200−
201− group <- do
202− sequenceAxis <- makeElemAxis "sequence"
203− choiceAxis <- makeElemAxis "choice"
204− allAxis <- makeElemAxis "all"
205− case (c $/ sequenceAxis, c $/ choiceAxis, c $/ allAxis) of
206− ([], [], []) -> return Nothing
207− ([g], [], []) -> Just <$> parseSequence g
208− ([], [g], []) -> Just <$> parseChoice g
209− ([], [], [g]) -> Just <$> parseAll g
210− _ -> parseError c "Multiple groups"
211−
212 annotations <- parseAnnotations c
222 annotations <- parseAnnotations c
213−
223+ cont <- parseContent c
214 return Xsd.ComplexType
224 return Xsd.ComplexType
215− { Xsd.complexAttributes = attributes
216− , Xsd.complexModelGroup = group
217− , Xsd.complexAnnotations = annotations
225+ { Xsd.complexAnnotations = annotations
226+ , Xsd.complexContent = cont
227+ }
228+
229+parseContent :: Cursor -> P Xsd.Content
230+parseContent c = do
231+ simpleContentAxis <- makeElemAxis "simpleContent"
232+ complexContentAxis <- makeElemAxis "complexContent"
233+ case (c $/ simpleContentAxis, c $/ complexContentAxis) of
234+ ([], []) -> Xsd.ContentPlain <$> parsePlainContent c
235+ ([s], []) -> Xsd.ContentSimple <$> parseSimpleContent s
236+ ([], [s]) -> Xsd.ContentComplex <$> parseComplexContent s
237+ _ -> parseError c
238+ "Expected one of simpleContent, complextContent or model group"
239+
240+parsePlainContent :: Cursor -> P Xsd.PlainContent
241+parsePlainContent c = do
242+ attributes <- parseAttributes c
243+ model <- parseModelGroup c
244+ return Xsd.PlainContent
245+ { Xsd.plainContentModel = model
246+ , Xsd.plainContentAttributes = attributes
247+ }
248+
249+parseSimpleContent :: Cursor -> P Xsd.SimpleContent
250+parseSimpleContent c = do
251+ restrictionAxis <- makeElemAxis "restriction"
252+ extenstionAxis <- makeElemAxis "extension"
253+ case (c $/ restrictionAxis, c $/ extenstionAxis) of
254+ ([r], []) -> Xsd.SimpleContentRestriction <$> parseSimpleRestriction r
255+ ([], [e]) -> Xsd.SimpleContentExtension <$> parseSimpleExtension e
256+ _ -> parseError c "Expected one of restriction or extension"
257+
258+parseSimpleExtension :: Cursor -> P Xsd.SimpleExtension
259+parseSimpleExtension c = handleNamespaces c $ do
260+ base <- theAttribute "base" c >>= makeQName c
261+ attributes <- parseAttributes c
262+ return Xsd.SimpleExtension
263+ { Xsd.simpleExtensionBase = base
264+ , Xsd.simpleExtensionAttributes = attributes
265+ }
266+
267+parseComplexContent :: Cursor -> P Xsd.ComplexContent
268+parseComplexContent c = do
269+ restrictionAxis <- makeElemAxis "restriction"
270+ extenstionAxis <- makeElemAxis "extension"
271+ case (c $/ restrictionAxis, c $/ extenstionAxis) of
272+ ([r], []) -> Xsd.ComplexContentRestriction <$> parseComplexRestriction r
273+ ([], [e]) -> Xsd.ComplexContentExtension <$> parseComplexExtension e
274+ _ -> parseError c "Expected one of restriction or extension"
275+
276+parseComplexExtension :: Cursor -> P Xsd.ComplexExtension
277+parseComplexExtension c = handleNamespaces c $ do
278+ base <- theAttribute "base" c >>= makeQName c
279+ attributes <- parseAttributes c
280+ model <- parseModelGroup c
281+ return Xsd.ComplexExtension
282+ { Xsd.complexExtensionBase = base
283+ , Xsd.complexExtensionModel = model
284+ , Xsd.complexExtensionAttributes = attributes
285+ }
286+
287+parseComplexRestriction :: Cursor -> P Xsd.ComplexRestriction
288+parseComplexRestriction c = handleNamespaces c $ do
289+ base <- theAttribute "base" c >>= makeQName c
290+ attributes <- parseAttributes c
291+ model <- parseModelGroup c
292+ return Xsd.ComplexRestriction
293+ { Xsd.complexRestrictionBase = base
294+ , Xsd.complexRestrictionModel = model
295+ , Xsd.complexRestrictionAttributes = attributes
218 }
296 }
219
297
298+parseModelGroup :: Cursor -> P (Maybe Xsd.ModelGroup)
299+parseModelGroup c = do
300+ sequenceAxis <- makeElemAxis "sequence"
301+ choiceAxis <- makeElemAxis "choice"
302+ allAxis <- makeElemAxis "all"
303+ case (c $/ sequenceAxis, c $/ choiceAxis, c $/ allAxis) of
304+ ([], [], []) -> return Nothing
305+ ([g], [], []) -> Just <$> parseSequence g
306+ ([], [g], []) -> Just <$> parseChoice g
307+ ([], [], [g]) -> Just <$> parseAll g
308+ _ -> parseError c "Multiple model groups"
309+
220parseSequence :: Cursor -> P Xsd.ModelGroup
310parseSequence :: Cursor -> P Xsd.ModelGroup
221parseSequence c = Xsd.Sequence <$> parseElements c
311parseSequence c = Xsd.Sequence <$> parseElements c
222
312
@@ -227,31 +317,45 @@ parseAll :: Cursor -> P Xsd.ModelGroup
227parseAll c = Xsd.All <$> parseElements c
317parseAll c = Xsd.All <$> parseElements c
228
318
229-- | Get all child elements
319-- | Get all child elements
230−parseElements :: Cursor -> P [Xsd.Element]
320+parseElements :: Cursor -> P [Xsd.RefOr Xsd.Element]
231parseElements c = do
321parseElements c = do
232 elementAxis <- makeElemAxis "element"
322 elementAxis <- makeElemAxis "element"
233− mapM parseElement (c $/ elementAxis)
323+ mapM parseElementOrRef (c $/ elementAxis)
324+
325+parseAttributes :: Cursor -> P [Xsd.Attribute]
326+parseAttributes c = do
327+ attrAxis <- makeElemAxis "attribute"
328+ mapM parseAttribute (c $/ attrAxis)
234
329
235parseAttribute :: Cursor -> P Xsd.Attribute
330parseAttribute :: Cursor -> P Xsd.Attribute
236parseAttribute c = do
331parseAttribute c = do
237− name <- theAttribute "name" c >>= makeTargetQName
238 use <- parseUseAttribute c
332 use <- parseUseAttribute c
239−
333+ case (anAttribute "name" c, anAttribute "ref" c) of
240− -- XXX: generalaze RefOr parsing
334+ (Just n, Nothing) -> do
335+ name <- makeTargetQName n
241− tp <- case anAttribute "type" c of
336+ tp <- case anAttribute "type" c of
242− Nothing -> do
337+ Nothing -> do
243− simpleTypeAxis <- makeElemAxis "simpleType"
338+ simpleTypeAxis <- makeElemAxis "simpleType"
244− case c $/ simpleTypeAxis of
339+ case c $/ simpleTypeAxis of
245− [s] -> Xsd.Inline <$> parseSimpleType s
340+ [s] -> Xsd.Inline <$> parseSimpleType s
246− [] -> parseError c "Attribute should have type"
341+ [] -> return (Xsd.Ref anySimpleType)
247− _ -> parseError c "Multiple simple types"
342+ _ -> parseError c "Multiple simple types"
248− Just t -> Xsd.Ref <$> makeQName c t
343+ Just t -> Xsd.Ref <$> makeQName c t
249−
344+ return $ Xsd.InlineAttribute $ Xsd.AttributeInline
250− return Xsd.Attribute
345+ { Xsd.attributeInlineName = name
251− { Xsd.attrName = name
346+ , Xsd.attributeInlineUse = use
252− , Xsd.attrUse = use
347+ , Xsd.attributeInlineType = tp
253− , Xsd.attrType = tp
348+ }
349+ (Nothing, Just r) -> do
350+ ref <- makeQName c r
351+ return $ Xsd.RefAttribute $ Xsd.AttributeRef
352+ { Xsd.attributeRefRef = ref
353+ , Xsd.attributeRefUse = use
254− }
354+ }
355+ _ -> parseError c "Should be either name or ref"
356+ where
357+ anySimpleType =
358+ Xsd.QName (Just (Xsd.Namespace Xsd.schemaNamespace)) "anySimpleType"
255
359
256parseUseAttribute :: Cursor -> P Xsd.Use
360parseUseAttribute :: Cursor -> P Xsd.Use
257parseUseAttribute c = case anAttribute "use" c of
361parseUseAttribute c = case anAttribute "use" c of
@@ -407,8 +511,9 @@ makeElemAxis name = do
407makeQName :: Cursor -> Text -> P Xsd.QName
511makeQName :: Cursor -> Text -> P Xsd.QName
408makeQName c t = case Text.splitOn ":" t of
512makeQName c t = case Text.splitOn ":" t of
409 [n] -> do
513 [n] -> do
514+ ns <- asks (lookup Nothing . envPrefixes)
410 return Xsd.QName
515 return Xsd.QName
411− { Xsd.qnNamespace = Nothing
516+ { Xsd.qnNamespace = ns
412 , Xsd.qnName = n
517 , Xsd.qnName = n
413 }
518 }
414 [p, n] -> do
519 [p, n] -> do
src/Xsd/Types.hs+87−17
@@ -6,13 +6,23 @@ module Xsd.Types
6, Child(..)
6, Child(..)
7, Type(..)
7, Type(..)
8, SimpleType(..)
8, SimpleType(..)
9−, Restriction(..)
10, Constraint(..)
9, Constraint(..)
11, ComplexType(..)
10, ComplexType(..)
11+, Content(..)
12+, PlainContent(..)
13+, SimpleContent(..)
14+, SimpleExtension(..)
15+, SimpleRestriction(..)
16+, ComplexContent(..)
17+, ComplexExtension(..)
18+, ComplexRestriction(..)
12, RefOr(..)
19, RefOr(..)
20+, refOr
13, Element(..)
21, Element(..)
14, MaxOccurs(..)
22, MaxOccurs(..)
15, Attribute(..)
23, Attribute(..)
24+, AttributeRef(..)
25+, AttributeInline(..)
16, Annotation(..)
26, Annotation(..)
17, Use(..)
27, Use(..)
18, ModelGroup(..)
28, ModelGroup(..)
@@ -43,7 +53,7 @@ newtype Namespace = Namespace
43 deriving (Show, Eq, Ord)
53 deriving (Show, Eq, Ord)
44
54
45data Child
55data Child
46− = ChildElement Element
56+ = ChildElement (RefOr Element)
47 | ChildType QName Type
57 | ChildType QName Type
48 | ChildImport Import
58 | ChildImport Import
49 | ChildInclude Include
59 | ChildInclude Include
@@ -56,6 +66,7 @@ data Element = Element
56 { elementName :: QName
66 { elementName :: QName
57 , elementType :: RefOr Type
67 , elementType :: RefOr Type
58 , elementOccurs :: (Int, MaxOccurs)
68 , elementOccurs :: (Int, MaxOccurs)
69+ , elementNillable :: Bool
59 , elementAnnotations :: [Annotation]
70 , elementAnnotations :: [Annotation]
60 }
71 }
61 deriving (Show, Eq)
72 deriving (Show, Eq)
@@ -82,28 +93,75 @@ data Include = Include
82 deriving (Show, Eq)
93 deriving (Show, Eq)
83
94
84data SimpleType
95data SimpleType
85− = AtomicType Restriction [Annotation]
96+ = AtomicType SimpleRestriction [Annotation]
86 | ListType (RefOr SimpleType) [Annotation]
97 | ListType (RefOr SimpleType) [Annotation]
87− -- TODO: also union
98+ | UnionType [RefOr SimpleType] [Annotation]
88 deriving (Show, Eq)
99 deriving (Show, Eq)
89
100
90data ComplexType = ComplexType
101data ComplexType = ComplexType
91− { complexAttributes :: [Attribute]
92− , complexModelGroup :: Maybe ModelGroup
93− , complexAnnotations :: [Annotation]
102+ { complexAnnotations :: [Annotation]
103+ , complexContent :: Content
94 }
104 }
95 deriving (Show, Eq)
105 deriving (Show, Eq)
96
106
107+data Content
108+ = ContentComplex ComplexContent
109+ | ContentSimple SimpleContent
110+ | ContentPlain PlainContent
111+ deriving (Show, Eq)
112+
113+-- | Represent content of complexType without simpleContent or complexContent
114+data PlainContent = PlainContent
115+ { plainContentModel :: Maybe ModelGroup
116+ , plainContentAttributes :: [Attribute]
117+ }
118+ deriving (Show, Eq)
119+
120+data ComplexContent
121+ = ComplexContentExtension ComplexExtension
122+ | ComplexContentRestriction ComplexRestriction
123+ deriving (Show, Eq)
124+
125+data ComplexExtension = ComplexExtension
126+ { complexExtensionBase :: QName
127+ , complexExtensionModel :: Maybe ModelGroup
128+ , complexExtensionAttributes :: [Attribute]
129+ }
130+ deriving (Show, Eq)
131+
132+data ComplexRestriction = ComplexRestriction
133+ { complexRestrictionBase :: QName
134+ , complexRestrictionModel :: Maybe ModelGroup
135+ , complexRestrictionAttributes :: [Attribute]
136+ }
137+ deriving (Show, Eq)
138+
139+data SimpleContent
140+ = SimpleContentExtension SimpleExtension
141+ | SimpleContentRestriction SimpleRestriction
142+ deriving (Show, Eq)
143+
97data ModelGroup
144data ModelGroup
98− = Sequence [Element]
145+ = Sequence [RefOr Element]
99− | Choice [Element]
146+ | Choice [RefOr Element]
100− | All [Element]
147+ | All [RefOr Element]
148+ deriving (Show, Eq)
149+
150+data Attribute
151+ = RefAttribute AttributeRef
152+ | InlineAttribute AttributeInline
153+ deriving (Show, Eq)
154+
155+data AttributeInline = AttributeInline
156+ { attributeInlineName :: QName
157+ , attributeInlineType :: RefOr SimpleType
158+ , attributeInlineUse :: Use
159+ }
101 deriving (Show, Eq)
160 deriving (Show, Eq)
102
161
103−data Attribute = Attribute
162+data AttributeRef = AttributeRef
104− { attrName :: QName
163+ { attributeRefRef :: QName
105− , attrType :: RefOr SimpleType
164+ , attributeRefUse :: Use
106− , attrUse :: Use
107 }
165 }
108 deriving (Show, Eq)
166 deriving (Show, Eq)
109
167
@@ -113,9 +171,16 @@ data Use
113 | Required
171 | Required
114 deriving (Show, Eq)
172 deriving (Show, Eq)
115
173
116−data Restriction = Restriction
174+data SimpleRestriction = SimpleRestriction
117− { restrictionBase :: RefOr SimpleType
175+ { simpleRestrictionBase :: RefOr SimpleType
118− , restrictionConstraints :: [Constraint]
176+ -- XXX: could simpleRestrictionBase be an inline type? Probably not.
177+ , simpleRestrictionConstraints :: [Constraint]
178+ }
179+ deriving (Show, Eq)
180+
181+data SimpleExtension = SimpleExtension
182+ { simpleExtensionBase :: QName
183+ , simpleExtensionAttributes :: [Attribute]
119 }
184 }
120 deriving (Show, Eq)
185 deriving (Show, Eq)
121
186
@@ -125,6 +190,11 @@ data RefOr t
125 | Inline t
190 | Inline t
126 deriving (Show, Eq)
191 deriving (Show, Eq)
127
192
193+refOr :: (QName -> a) -> (t -> a) -> RefOr t -> a
194+refOr f g ref = case ref of
195+ Ref name -> f name
196+ Inline t -> g t
197+
128data Constraint
198data Constraint
129 = Enumeration Text
199 = Enumeration Text
130 deriving (Show, Eq)
200 deriving (Show, Eq)
test/Spec.hs+46−14
@@ -6,6 +6,7 @@ module Spec
6where
6where
7
7
8import Data.Text (Text)
8import Data.Text (Text)
9+import Data.Maybe
9import Data.Either
10import Data.Either
10import Data.Map (Map)
11import Data.Map (Map)
11import qualified Data.Map as Map
12import qualified Data.Map as Map
@@ -90,7 +91,7 @@ spec = do
90 Xsd.AtomicType restriction _ = t
91 Xsd.AtomicType restriction _ = t
91 res `shouldSatisfy` isRight
92 res `shouldSatisfy` isRight
92 tpName `shouldBe` (Xsd.QName Nothing "str")
93 tpName `shouldBe` (Xsd.QName Nothing "str")
93− Xsd.restrictionBase restriction `shouldBe`
94+ Xsd.simpleRestrictionBase restriction `shouldBe`
94 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
95 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
95
96
96 context "when restriction contains enumerations" $ do
97 context "when restriction contains enumerations" $ do
@@ -114,7 +115,7 @@ spec = do
114 Xsd.AtomicType restriction _ = t
115 Xsd.AtomicType restriction _ = t
115 res `shouldSatisfy` isRight
116 res `shouldSatisfy` isRight
116 tpName `shouldBe` (Xsd.QName Nothing "str")
117 tpName `shouldBe` (Xsd.QName Nothing "str")
117− Xsd.restrictionConstraints restriction `shouldBe`
118+ Xsd.simpleRestrictionConstraints restriction `shouldBe`
118 [ Xsd.Enumeration "value1"
119 [ Xsd.Enumeration "value1"
119 , Xsd.Enumeration "value2"
120 , Xsd.Enumeration "value2"
120 ]
121 ]
@@ -137,10 +138,10 @@ spec = do
137 fmap Xsd.children res
138 fmap Xsd.children res
138 Xsd.AtomicType restriction' _ = t
139 Xsd.AtomicType restriction' _ = t
139 Xsd.Inline (Xsd.AtomicType restriction _) =
140 Xsd.Inline (Xsd.AtomicType restriction _) =
140− Xsd.restrictionBase restriction'
141+ Xsd.simpleRestrictionBase restriction'
141 res `shouldSatisfy` isRight
142 res `shouldSatisfy` isRight
142 tpName `shouldBe` (Xsd.QName Nothing "str")
143 tpName `shouldBe` (Xsd.QName Nothing "str")
143− Xsd.restrictionBase restriction `shouldBe`
144+ Xsd.simpleRestrictionBase restriction `shouldBe`
144 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
145 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
145
146
146 context "when base refers to an unbound prefix" $ do
147 context "when base refers to an unbound prefix" $ do
@@ -198,11 +199,12 @@ spec = do
198 res = Xsd.parse Xsd.defaultConfig doc
199 res = Xsd.parse Xsd.defaultConfig doc
199 Right [Xsd.ChildType tpName (Xsd.TypeComplex t)] =
200 Right [Xsd.ChildType tpName (Xsd.TypeComplex t)] =
200 fmap Xsd.children res
201 fmap Xsd.children res
201− [attr] = Xsd.complexAttributes t
202+ Xsd.ContentPlain plain = Xsd.complexContent t
203+ [Xsd.InlineAttribute attr] = Xsd.plainContentAttributes plain
202 res `shouldSatisfy` isRight
204 res `shouldSatisfy` isRight
203 tpName `shouldBe` Xsd.QName Nothing "person"
205 tpName `shouldBe` Xsd.QName Nothing "person"
204− Xsd.attrName attr `shouldBe` Xsd.QName Nothing "firstName"
206+ Xsd.attributeInlineName attr `shouldBe` Xsd.QName Nothing "firstName"
205− Xsd.attrType attr `shouldBe`
207+ Xsd.attributeInlineType attr `shouldBe`
206 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
208 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
207
209
208 context "when attribute type is inlined" $ do
210 context "when attribute type is inlined" $ do
@@ -223,10 +225,12 @@ spec = do
223 res = Xsd.parse Xsd.defaultConfig doc
225 res = Xsd.parse Xsd.defaultConfig doc
224 Right [Xsd.ChildType _ (Xsd.TypeComplex t)] =
226 Right [Xsd.ChildType _ (Xsd.TypeComplex t)] =
225 fmap Xsd.children res
227 fmap Xsd.children res
226− [attr] = Xsd.complexAttributes t
228+ Xsd.ContentPlain plain = Xsd.complexContent t
229+ [Xsd.InlineAttribute attr] = Xsd.plainContentAttributes plain
227− Xsd.Inline (Xsd.AtomicType restriction _) = Xsd.attrType attr
230+ Xsd.Inline (Xsd.AtomicType restriction _) =
231+ Xsd.attributeInlineType attr
228 res `shouldSatisfy` isRight
232 res `shouldSatisfy` isRight
229− Xsd.restrictionBase restriction `shouldBe`
233+ Xsd.simpleRestrictionBase restriction `shouldBe`
230 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
234 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
231
235
232 context "when it contains a sequence" $ do
236 context "when it contains a sequence" $ do
@@ -254,10 +258,38 @@ spec = do
254 res = Xsd.parse Xsd.defaultConfig doc
258 res = Xsd.parse Xsd.defaultConfig doc
255 Right [Xsd.ChildType _ (Xsd.TypeComplex t)] =
259 Right [Xsd.ChildType _ (Xsd.TypeComplex t)] =
256 fmap Xsd.children res
260 fmap Xsd.children res
261+ Xsd.ContentPlain plain = Xsd.complexContent t
257− Just (Xsd.Sequence elems) = Xsd.complexModelGroup t
262+ Just (Xsd.Sequence elems) = Xsd.plainContentModel plain
258 res `shouldSatisfy` isRight
263 res `shouldSatisfy` isRight
259− map Xsd.elementName elems `shouldBe`
264+ mapMaybe (Xsd.refOr (const Nothing) (Just . Xsd.elementName)) elems
260− map (Xsd.QName Nothing) ["firstName", "lastName"]
265+ `shouldBe` map (Xsd.QName Nothing) ["firstName", "lastName"]
266+
267+ context "when it contains complexContent" $ do
268+ context "when it's an extenstion" $ do
269+ it "succeeds" $ do
270+ let
271+ doc = mkDoc $
272+ mkElem "schema"
273+ (Map.fromList [("xmlns:xs","something")])
274+ [NodeElement $ mkElem "complexType"
275+ (Map.fromList [("name", "person")])
276+ [NodeElement $ mkElem "complexContent" Map.empty
277+ [ NodeElement $ mkElem "extension"
278+ (Map.fromList [("base", "BaseType")])
279+ [ NodeElement $ mkElem "sequence" Map.empty
280+ [ NodeElement $ mkElem "element"
281+ (Map.fromList
282+ [ ("name", "first")
283+ , ("type", "xs:string")])
284+ []
285+ ]]]]]
286+ res = Xsd.parse Xsd.defaultConfig doc
287+ Right [Xsd.ChildType _ (Xsd.TypeComplex t)] =
288+ fmap Xsd.children res
289+ Xsd.ContentComplex (Xsd.ComplexContentExtension e)
290+ = Xsd.complexContent t
291+ res `shouldSatisfy` isRight
292+ Xsd.complexExtensionBase e `shouldBe` Xsd.QName Nothing "BaseType"
261
293
262 context "when element is given" $ do
294 context "when element is given" $ do
263 context "when type is inlined" $ do
295 context "when type is inlined" $ do
@@ -275,7 +307,7 @@ spec = do
275 ]
307 ]
276 ]
308 ]
277 res = Xsd.parse Xsd.defaultConfig doc
309 res = Xsd.parse Xsd.defaultConfig doc
278− Right [Xsd.ChildElement e] = fmap Xsd.children res
310+ Right [Xsd.ChildElement (Xsd.Inline e)] = fmap Xsd.children res
279 res `shouldSatisfy` isRight
311 res `shouldSatisfy` isRight
280 Xsd.elementName e `shouldBe`
312 Xsd.elementName e `shouldBe`
281 Xsd.QName Nothing "person"
313 Xsd.QName Nothing "person"
xsd-parser.cabal+13−1
@@ -24,7 +24,7 @@ library
24 , Xsd.Parser
24 , Xsd.Parser
25
25
26 -- Other library packages from which modules are imported.
26 -- Other library packages from which modules are imported.
27− build-depends: base ^>=4.12.0.0
27+ build-depends: base >=4.12 && < 5
28 , bytestring
28 , bytestring
29 , containers
29 , containers
30 , lens >= 4.13
30 , lens >= 4.13
@@ -62,3 +62,15 @@ test-suite spec
62 , xsd-parser
62 , xsd-parser
63 default-language: Haskell2010
63 default-language: Haskell2010
64 ghc-options: -Wall
64 ghc-options: -Wall
65+
66+test-suite xsts
67+ type: exitcode-stdio-1.0
68+ hs-source-dirs: xsts-test
69+ main-is: Main.hs
70+ build-depends: base
71+ , text
72+ , filepath
73+ , xml-conduit
74+ , xsd-parser
75+ default-language: Haskell2010
76+ ghc-options: -Wall
xsdtestsnew file+1

Submodule changed.

xsts-test/Main.hsnew file+201
@@ -0,0 +1,201 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Main
4+( main
5+)
6+where
7+
8+import Data.Text (Text)
9+import qualified Data.Text as Text
10+import Data.IORef
11+import Control.Monad
12+import Control.Exception
13+import System.FilePath
14+import System.IO.Unsafe (unsafePerformIO)
15+import qualified System.IO as IO
16+import Text.XML
17+import Text.XML.Cursor
18+
19+import qualified Xsd
20+
21+data Stat = Stat
22+ { statTotal :: Int
23+ , statSucceeded :: Int
24+ , statValidFailed :: Int
25+ , statInvalidSucceeded :: Int
26+ }
27+ deriving (Show)
28+
29+{-# NOINLINE errRef #-}
30+errRef :: IORef Int
31+errRef = unsafePerformIO (newIORef 0)
32+
33+{-# NOINLINE okRef #-}
34+okRef :: IORef Int
35+okRef = unsafePerformIO (newIORef 0)
36+
37+{-# NOINLINE statsRef #-}
38+statsRef :: IORef [(Text, Stat)]
39+statsRef = unsafePerformIO (newIORef [])
40+
41+dumpResults :: [(Text, Stat)] -> IO ()
42+dumpResults stats = IO.withFile "xsts.md" IO.WriteMode $ \h -> do
43+ IO.hPutStrLn h "This table is generated automatically by `xsts` test."
44+ IO.hPutStrLn h "It contains number of xsd files successfully parsed."
45+ IO.hPutStrLn h "Note that we don't currently attempt to validate xml files"
46+ IO.hPutStrLn h "against the schemata."
47+ IO.hPutStrLn h ""
48+ IO.hPutStrLn h "Test set | Total tests | Passed tests | Invalid passed | Valid failed"
49+ IO.hPutStrLn h "--- | --- | --- | --- | ---"
50+ forM_ stats $ \(name, s) -> do
51+ IO.hPutStrLn h $ mconcat
52+ [ Text.unpack name, " | "
53+ , show (statTotal s), " | "
54+ , show (statSucceeded s), " | "
55+ , show (statInvalidSucceeded s), " | "
56+ , show (statValidFailed s)
57+ ]
58+
59+expectedFailures :: Int
60+expectedFailures = 3513
61+
62+main :: IO ()
63+main = do
64+ let path = "./xsdtests/suite.xml"
65+ doc <- Text.XML.readFile def path
66+ runSuite path (fromDocument doc)
67+ oks <- readIORef okRef
68+ readIORef statsRef >>= dumpResults
69+ putStrLn $ "Succeeded: " ++ show oks
70+ errs <- readIORef errRef
71+ putStrLn $ "Failed: " ++ show errs
72+ unless (errs == expectedFailures) $
73+ fail $ "There were " ++ show errs ++ " errors, expected "
74+ ++ show expectedFailures
75+
76+runSuite :: FilePath -> Cursor -> IO ()
77+runSuite path c = mapM_ (runTestSetRef dir) (c $/ laxElement "testSetRef")
78+ where
79+ dir = takeDirectory path
80+
81+runTestSetRef :: FilePath -> Cursor -> IO ()
82+runTestSetRef dir c = do
83+ ref <- theAttribute c "href"
84+ let path = normalise (dir </> Text.unpack ref)
85+ runTestSet path
86+
87+runTestSet :: FilePath -> IO ()
88+runTestSet path = do
89+ doc <- Text.XML.readFile def path
90+ let c = fromDocument doc
91+ name <- theAttribute c "name"
92+ putStrLn ("----- Test set " <> Text.unpack name)
93+ results <- mapM (runTestGroup dir) (c $/ laxElement "testGroup")
94+ let
95+ stat = Stat
96+ { statTotal = (sum . map statTotal) results
97+ , statSucceeded = (sum . map statSucceeded) results
98+ , statValidFailed = (sum . map statValidFailed) results
99+ , statInvalidSucceeded = (sum . map statInvalidSucceeded) results
100+ }
101+ modifyIORef' statsRef ((name, stat) :)
102+ where
103+ dir = takeDirectory path
104+
105+runTestGroup :: FilePath -> Cursor -> IO Stat
106+runTestGroup dir c = do
107+ name <- theAttribute c "name"
108+ results <- mapM (runSchemaTest dir name) (aChild c "schemaTest")
109+ case join results of
110+ Nothing -> return Stat
111+ { statTotal = 0
112+ , statSucceeded = 0
113+ , statValidFailed = 0
114+ , statInvalidSucceeded = 0
115+ }
116+ Just ValidSucceeded -> return Stat
117+ { statTotal = 1
118+ , statSucceeded = 1
119+ , statValidFailed = 0
120+ , statInvalidSucceeded = 0
121+ }
122+ Just ValidFailed -> return Stat
123+ { statTotal = 1
124+ , statSucceeded = 0
125+ , statValidFailed = 1
126+ , statInvalidSucceeded = 0
127+ }
128+ Just InvalidSucceeded -> return Stat
129+ { statTotal = 1
130+ , statSucceeded = 0
131+ , statValidFailed = 0
132+ , statInvalidSucceeded = 1
133+ }
134+ Just InvalidFailed -> return Stat
135+ { statTotal = 1
136+ , statSucceeded = 1
137+ , statValidFailed = 0
138+ , statInvalidSucceeded = 0
139+ }
140+
141+data Result
142+ = InvalidFailed
143+ | InvalidSucceeded
144+ | ValidFailed
145+ | ValidSucceeded
146+ deriving (Show)
147+
148+runSchemaTest :: FilePath -> Text -> Cursor -> IO (Maybe Result)
149+runSchemaTest dir groupName c = do
150+ path <- do
151+ c' <- theChild c "schemaDocument"
152+ theAttribute c' "href"
153+ mvalid <- do
154+ c' <- theChild c "expected"
155+ valid <- theAttribute c' "validity"
156+ case valid of
157+ "valid" -> return (Just True)
158+ "invalid" -> return (Just False)
159+ _ -> return Nothing
160+ case mvalid of
161+ Nothing -> return Nothing -- indetermined
162+ Just valid -> do
163+ res <- try (Xsd.getSchema (dir </> Text.unpack path))
164+ case (res, valid) of
165+ (Left _, False) -> do
166+ modifyIORef' okRef succ
167+ return (Just InvalidFailed)
168+ (Right _, True) -> do
169+ modifyIORef' okRef succ
170+ return (Just ValidSucceeded)
171+ (Right _, False) -> do
172+ modifyIORef' errRef succ
173+ putStrLn $ "invalid xsd passed: " <> Text.unpack groupName
174+ <> " (" <> dir </> Text.unpack path <> ")"
175+ return (Just InvalidSucceeded)
176+ (Left err, True) -> do
177+ modifyIORef' errRef succ
178+ putStrLn $ "valid xsd didn't pass: " <> Text.unpack groupName
179+ <> " (" <> dir </> Text.unpack path <> ")"
180+ <> ": " <> show (err :: SomeException)
181+ return (Just ValidFailed)
182+
183+anAttribute :: Cursor -> Text -> Maybe Text
184+anAttribute c name = case c $| laxAttribute name of
185+ (a:_) -> Just a
186+ _ -> Nothing
187+
188+theAttribute :: Cursor -> Text -> IO Text
189+theAttribute c name = maybe err return (anAttribute c name)
190+ where
191+ err = fail $ "no attribute " <> Text.unpack name
192+
193+aChild :: Cursor -> Text -> Maybe Cursor
194+aChild c name = case c $/ laxElement name of
195+ (a:_) -> Just a
196+ _ -> Nothing
197+
198+theChild :: Cursor -> Text -> IO Cursor
199+theChild c name = case aChild c name of
200+ Just a -> return a
201+ _ -> fail $ "no element " <> Text.unpack name
xsts.mdnew file+100
@@ -0,0 +1,100 @@
1+This table is generated automatically by `xsts` test.
2+It contains number of xsd files successfully parsed.
3+Note that we don't currently attempt to validate xml files
4+against the schemata.
5+
6+Test set | Total tests | Passed tests | Invalid passed | Valid failed
7+--- | --- | --- | --- | ---
8+yearMonthDuration | 25 | 13 | 12 | 0
9+XSImportReference | 1 | 0 | 1 | 0
10+XPathDefaultNSonKeyKeyRefUnique | 13 | 13 | 0 | 0
11+XML11Support | 11 | 11 | 0 | 0
12+wildcard | 17 | 15 | 2 | 0
13+VC | 6 | 6 | 0 | 0
14+unsignedIntegers | 8 | 8 | 0 | 0
15+UnitsLength | 8 | 6 | 2 | 0
16+union | 19 | 14 | 5 | 0
17+CTA | 6 | 6 | 0 | 0
18+TypeAlternativeTests | 23 | 16 | 7 | 0
19+time | 1 | 1 | 0 | 0
20+TargetNS | 2 | 2 | 0 | 0
21+substitutionGroup | 5 | 3 | 2 | 0
22+rf-whiteSpace | 2 | 2 | 0 | 0
23+RestrictionOfComplexTypes | 13 | 9 | 4 | 0
24+RegularExpression | 8 | 8 | 0 | 0
25+PopenContent | 24 | 16 | 8 | 0
26+list | 2 | 1 | 1 | 0
27+IdentityConstraint | 12 | 6 | 6 | 0
28+ID_IDREF | 77 | 57 | 20 | 0
29+gMonth | 1 | 0 | 1 | 0
30+gDay | 1 | 1 | 0 | 0
31+gMonthDay | 1 | 1 | 0 | 0
32+gYear | 1 | 1 | 0 | 0
33+gYearMonth | 1 | 1 | 0 | 0
34+float | 2 | 2 | 0 | 0
35+explicitTimezone | 18 | 14 | 4 | 0
36+EDCWildcard | 2 | 2 | 0 | 0
37+double | 2 | 2 | 0 | 0
38+DefaultFixed | 5 | 5 | 0 | 0
39+defaultAttributesApply | 17 | 14 | 3 | 0
40+dayTimeDuration | 24 | 12 | 12 | 0
41+dateTimeStamp | 28 | 11 | 17 | 0
42+date | 1 | 1 | 0 | 0
43+CyclicDependencies_Redefine_Include_Import_Override | 5 | 0 | 5 | 0
44+constraintsOnAttribute | 16 | 6 | 10 | 0
45+ConditionalInclusion | 3 | 2 | 1 | 0
46+assertion | 51 | 50 | 1 | 0
47+Assert | 35 | 35 | 0 | 0
48+anyAttribute | 9 | 7 | 2 | 0
49+allGroup | 9 | 7 | 2 | 0
50+IRI | 1 | 1 | 0 | 0
51+substitution-groups | 6 | 6 | 0 | 0
52+Zone | 9 | 5 | 4 | 0
53+Zone | 20 | 15 | 5 | 0
54+XmlVersions | 13 | 13 | 0 | 0
55+Wild | 84 | 63 | 21 | 0
56+VC | 24 | 19 | 4 | 1
57+TargetNS | 4 | 2 | 2 | 0
58+Subsgroup | 6 | 3 | 3 | 0
59+Simple | 58 | 17 | 41 | 0
60+Override | 30 | 21 | 9 | 0
61+Open | 51 | 37 | 14 | 0
62+Missing | 6 | 4 | 2 | 0
63+Id | 32 | 30 | 2 | 0
64+CTA | 44 | 33 | 11 | 0
65+Complex | 25 | 19 | 6 | 0
66+Assert | 34 | 34 | 0 | 0
67+All | 62 | 26 | 34 | 2
68+BoeingXSDTestCases | 6 | 6 | 0 | 0
69+MS-Wildcards2006-07-15 | 315 | 218 | 97 | 0
70+MS-SimpleType2006-07-15 | 333 | 210 | 123 | 0
71+MS-Schema2006-07-15 | 124 | 56 | 61 | 7
72+MS-Regex2006-07-15 | 2590 | 1988 | 602 | 0
73+MS-Particles2006-07-15 | 855 | 561 | 293 | 1
74+MS-Notations2006-07-15 | 116 | 38 | 78 | 0
75+MS-ModelGroups2006-07-15 | 391 | 215 | 176 | 0
76+MS-IdentityConstraint2006-07-15 | 844 | 621 | 223 | 0
77+MS-Group2006-07-15 | 218 | 138 | 80 | 0
78+MS-Errata102006-07-15 | 19 | 15 | 4 | 0
79+MS-Element2006-07-15 | 355 | 263 | 92 | 0
80+MS-DataTypes2006-07-15 | 2247 | 1491 | 752 | 4
81+MS-ComplexType2006-07-15 | 550 | 311 | 239 | 0
82+MS-Attribute2006-07-15 | 279 | 165 | 114 | 0
83+MS-AttributeGroup2006-07-15 | 114 | 63 | 51 | 0
84+MS-Annotations2006-07-15 | 80 | 51 | 27 | 2
85+MS-Additional2006-07-15 | 253 | 202 | 45 | 6
86+Wildcard | 26 | 22 | 4 | 0
87+Schema | 6 | 6 | 0 | 0
88+SType | 138 | 131 | 7 | 0
89+Notation | 13 | 8 | 5 | 0
90+MGroupDef | 19 | 8 | 11 | 0
91+MGroup | 40 | 24 | 16 | 0
92+IdConstrDefs | 27 | 21 | 6 | 0
93+ElemDecl | 227 | 171 | 56 | 0
94+CType | 31 | 25 | 6 | 0
95+AttrUse | 4 | 3 | 1 | 0
96+AttrDecl | 83 | 78 | 5 | 0
97+AGroupDef | 13 | 6 | 7 | 0
98+suntest | 52 | 30 | 22 | 0
99+NIST2004-01-14 | 3953 | 3953 | 0 | 0
100+introspection | 1 | 0 | 0 | 1