9fadbc0...master · typeable/xsd-parser

git.iko.soy/typeable/xsd-parser

10 files changed+655−86

since splitsnapshots

unifiedsplit

.gitmodules+3 README.md+10 src/Xsd.hs+1−1 src/Xsd/Parser.hs+166−53 src/Xsd/Types.hs+88−17 test/Spec.hs+72−14 xsd-parser.cabal+13−1 xsdtests+1 xsts-test/Main.hs+201 xsts.md+100

.gitmodulesnew file+3

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

2+# xsd-parser

4+Library for parsing XML schema files.

6+# W3C XML Schema 1.1 test suite

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

113113 go res [] = res

114114 go (ts, es) (c:cs) = case c of

115115 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

117117 _ -> go (ts, es) cs

118118

119119fetchXsd :: URI -> IO Xsd

src/Xsd/Parser.hs+166−53

@@ -48,7 +48,7 @@ parseChild :: Cursor -> P (Maybe Xsd.Child)

4848parseChild c = do

4949 name <- getElementName c

5050 case name of

51− "element" -> Just . Xsd.ChildElement <$> parseElement c

51+ "element" -> Just . Xsd.ChildElement <$> parseElementOrRef c

5252 "simpleType" -> Just <$> parseTopSimpleType c

5353 "complexType" -> Just <$> parseTopComplexType c

5454 "include" -> Just . Xsd.ChildInclude <$> parseInclude c

@@ -81,14 +81,19 @@ parseImport c = do

8181 , Xsd.importNamespace = namespace

8282 }

8383

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+

8490parseElement :: Cursor -> P Xsd.Element

8591parseElement c = handleNamespaces c $ do

8692 name <- theAttribute "name" c

8793

88− -- XXX: generalaze RefOr parsing

8994 tp <- case anAttribute "type" c of

9095 Just t -> Xsd.Ref <$> makeQName c t

91− _ -> Xsd.Inline <$> parseType c

96+ _ -> maybe (Xsd.Ref anyType) Xsd.Inline <$> parseType c

9297

9398 minOccurs <- case anAttribute "minOccurs" c of

9499 Nothing -> return 1

@@ -107,22 +112,31 @@ parseElement c = handleNamespaces c $ do

107112

108113 qname <- makeTargetQName name

109114

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+

110121 return Xsd.Element

111122 { Xsd.elementName = qname

112123 , Xsd.elementType = tp

113124 , Xsd.elementAnnotations = annotations

114125 , Xsd.elementOccurs = (minOccurs, maxOccurs)

126+ , Xsd.elementNillable = nillable

115127 }

128+ where

129+ anyType = Xsd.QName (Just (Xsd.Namespace Xsd.schemaNamespace)) "anyType"

116130

117131-- | Parse inline type, simple or complex

118−parseType :: Cursor -> P Xsd.Type

132+parseType :: Cursor -> P (Maybe Xsd.Type)

119133parseType c = do

120134 simpleTypeAxis <- makeElemAxis "simpleType"

121135 complexTypeAxis <- makeElemAxis "complexType"

122136 case (c $/ simpleTypeAxis, c $/ complexTypeAxis) of

123− ([], []) -> parseError c "No type"

124− ([t], []) -> Xsd.TypeSimple <$> parseSimpleType t

125− ([], [t]) -> Xsd.TypeComplex <$> parseComplexType t

137+ ([], []) -> return Nothing

138+ ([t], []) -> Just . Xsd.TypeSimple <$> parseSimpleType t

139+ ([], [t]) -> Just . Xsd.TypeComplex <$> parseComplexType t

126140 _ -> parseError c "Multiple types"

127141

128142-- | Top level simple type

@@ -146,18 +160,19 @@ parseSimpleType c = do

146160 unionAxis <- makeElemAxis "union"

147161 case (c $/ restrictionAxis, c $/ listAxis, c $/ unionAxis) of

148162 ([e], [], []) -> Xsd.AtomicType

149− <$> parseRestriction e

163+ <$> parseSimpleRestriction e

150164 <*> parseAnnotations c

151165 ([], [l], []) -> Xsd.ListType

152166 <$> parseList l

153167 <*> parseAnnotations c

154− -- TODO implement me

155− ([], [], [_]) -> parseError c "Not implemented: union"

168+ ([], [], [u]) -> Xsd.UnionType

169+ <$> parseUnion u

170+ <*> parseAnnotations c

156171 _ -> parseError c "Expected exactly of of restriction, list or union"

157172

158173-- | Restriction for simple type

159−parseRestriction :: Cursor -> P Xsd.Restriction

160−parseRestriction c = do

174+parseSimpleRestriction :: Cursor -> P Xsd.SimpleRestriction

175+parseSimpleRestriction c = do

161176 -- XXX: generalaze RefOr parsing

162177 tp <- case anAttribute "base" c of

163178 Nothing -> do

@@ -168,11 +183,19 @@ parseRestriction c = do

168183 _ -> parseError c "Multiple types"

169184 Just t -> Xsd.Ref <$> makeQName c t

170185

171− return Xsd.Restriction

172− { Xsd.restrictionBase = tp

173− , Xsd.restrictionConstraints = [] -- TODO: implement me

186+ constraints <- parseConstrains c

187+

188+ return Xsd.SimpleRestriction

189+ { Xsd.simpleRestrictionBase = tp

190+ , Xsd.simpleRestrictionConstraints = constraints

174191 }

175192

193+parseConstrains :: Cursor -> P [Xsd.Constraint]

194+parseConstrains c = do

195+ enumerationAxis <- makeElemAxis "enumeration"

196+ forM (c $/ enumerationAxis) $ \e -> do

197+ Xsd.Enumeration <$> theAttribute "value" e

198+

176199parseList :: Cursor -> P (Xsd.RefOr Xsd.SimpleType)

177200parseList c =

178201 -- XXX: generalaze RefOr parsing

@@ -185,30 +208,105 @@ parseList c =

185208 _ -> parseError c "Multiple types"

186209 Just t -> Xsd.Ref <$> makeQName c t

187210

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+

188220parseComplexType :: Cursor -> P Xsd.ComplexType

189221parseComplexType c = do

190− attrAxis <- makeElemAxis "attribute"

191− attributes <- mapM parseAttribute (c $/ attrAxis)

192−

193− group <- do

194− sequenceAxis <- makeElemAxis "sequence"

195− choiceAxis <- makeElemAxis "choice"

196− allAxis <- makeElemAxis "all"

197− case (c $/ sequenceAxis, c $/ choiceAxis, c $/ allAxis) of

198− ([], [], []) -> return Nothing

199− ([g], [], []) -> Just <$> parseSequence g

200− ([], [g], []) -> Just <$> parseChoice g

201− ([], [], [g]) -> Just <$> parseAll g

202− _ -> parseError c "Multiple groups"

203−

204222 annotations <- parseAnnotations c

205−

223+ cont <- parseContent c

206224 return Xsd.ComplexType

207− { Xsd.complexAttributes = attributes

208− , Xsd.complexModelGroup = group

209− , 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

210285 }

211286

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

296+ }

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+

212310parseSequence :: Cursor -> P Xsd.ModelGroup

213311parseSequence c = Xsd.Sequence <$> parseElements c

214312

@@ -219,31 +317,45 @@ parseAll :: Cursor -> P Xsd.ModelGroup

219317parseAll c = Xsd.All <$> parseElements c

220318

221319-- | Get all child elements

222−parseElements :: Cursor -> P [Xsd.Element]

320+parseElements :: Cursor -> P [Xsd.RefOr Xsd.Element]

223321parseElements c = do

224322 elementAxis <- makeElemAxis "element"

225− 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)

226329

227330parseAttribute :: Cursor -> P Xsd.Attribute

228331parseAttribute c = do

229− name <- theAttribute "name" c >>= makeTargetQName

230332 use <- parseUseAttribute c

231−

232− -- XXX: generalaze RefOr parsing

233− tp <- case anAttribute "type" c of

234− Nothing -> do

235− simpleTypeAxis <- makeElemAxis "simpleType"

236− case c $/ simpleTypeAxis of

237− [s] -> Xsd.Inline <$> parseSimpleType s

238− [] -> parseError c "Attribute should have type"

239− _ -> parseError c "Multiple simple types"

240− Just t -> Xsd.Ref <$> makeQName c t

241−

242− return Xsd.Attribute

243− { Xsd.attrName = name

244− , Xsd.attrUse = use

245− , Xsd.attrType = tp

246− }

333+ case (anAttribute "name" c, anAttribute "ref" c) of

334+ (Just n, Nothing) -> do

335+ name <- makeTargetQName n

336+ tp <- case anAttribute "type" c of

337+ Nothing -> do

338+ simpleTypeAxis <- makeElemAxis "simpleType"

339+ case c $/ simpleTypeAxis of

340+ [s] -> Xsd.Inline <$> parseSimpleType s

341+ [] -> return (Xsd.Ref anySimpleType)

342+ _ -> parseError c "Multiple simple types"

343+ Just t -> Xsd.Ref <$> makeQName c t

344+ return $ Xsd.InlineAttribute $ Xsd.AttributeInline

345+ { Xsd.attributeInlineName = name

346+ , Xsd.attributeInlineUse = use

347+ , Xsd.attributeInlineType = 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

354+ }

355+ _ -> parseError c "Should be either name or ref"

356+ where

357+ anySimpleType =

358+ Xsd.QName (Just (Xsd.Namespace Xsd.schemaNamespace)) "anySimpleType"

247359

248360parseUseAttribute :: Cursor -> P Xsd.Use

249361parseUseAttribute c = case anAttribute "use" c of

@@ -399,8 +511,9 @@ makeElemAxis name = do

399511makeQName :: Cursor -> Text -> P Xsd.QName

400512makeQName c t = case Text.splitOn ":" t of

401513 [n] -> do

514+ ns <- asks (lookup Nothing . envPrefixes)

402515 return Xsd.QName

403− { Xsd.qnNamespace = Nothing

516+ { Xsd.qnNamespace = ns

404517 , Xsd.qnName = n

405518 }

406519 [p, n] -> do

src/Xsd/Types.hs+88−17

@@ -6,12 +6,23 @@ module Xsd.Types

66, Child(..)

77, Type(..)

88, SimpleType(..)

9−, Restriction(..)

9+, Constraint(..)

1010, ComplexType(..)

11+, Content(..)

12+, PlainContent(..)

13+, SimpleContent(..)

14+, SimpleExtension(..)

15+, SimpleRestriction(..)

16+, ComplexContent(..)

17+, ComplexExtension(..)

18+, ComplexRestriction(..)

1119, RefOr(..)

20+, refOr

1221, Element(..)

1322, MaxOccurs(..)

1423, Attribute(..)

24+, AttributeRef(..)

25+, AttributeInline(..)

1526, Annotation(..)

1627, Use(..)

1728, ModelGroup(..)

@@ -42,7 +53,7 @@ newtype Namespace = Namespace

4253 deriving (Show, Eq, Ord)

4354

4455data Child

45− = ChildElement Element

56+ = ChildElement (RefOr Element)

4657 | ChildType QName Type

4758 | ChildImport Import

4859 | ChildInclude Include

@@ -55,6 +66,7 @@ data Element = Element

5566 { elementName :: QName

5667 , elementType :: RefOr Type

5768 , elementOccurs :: (Int, MaxOccurs)

69+ , elementNillable :: Bool

5870 , elementAnnotations :: [Annotation]

5971 }

6072 deriving (Show, Eq)

@@ -81,28 +93,75 @@ data Include = Include

8193 deriving (Show, Eq)

8294

8395data SimpleType

84− = AtomicType Restriction [Annotation]

96+ = AtomicType SimpleRestriction [Annotation]

8597 | ListType (RefOr SimpleType) [Annotation]

86− -- TODO: also union

98+ | UnionType [RefOr SimpleType] [Annotation]

8799 deriving (Show, Eq)

88100

89101data ComplexType = ComplexType

90− { complexAttributes :: [Attribute]

91− , complexModelGroup :: Maybe ModelGroup

92− , complexAnnotations :: [Annotation]

102+ { complexAnnotations :: [Annotation]

103+ , complexContent :: Content

93104 }

94105 deriving (Show, Eq)

95106

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+

96144data ModelGroup

97− = Sequence [Element]

98− | Choice [Element]

99− | All [Element]

145+ = Sequence [RefOr Element]

146+ | Choice [RefOr 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+ }

100160 deriving (Show, Eq)

101161

102−data Attribute = Attribute

103− { attrName :: QName

104− , attrType :: RefOr SimpleType

105− , attrUse :: Use

162+data AttributeRef = AttributeRef

163+ { attributeRefRef :: QName

164+ , attributeRefUse :: Use

106165 }

107166 deriving (Show, Eq)

108167

@@ -112,9 +171,16 @@ data Use

112171 | Required

113172 deriving (Show, Eq)

114173

115−data Restriction = Restriction

116− { restrictionBase :: RefOr SimpleType

117− , restrictionConstraints :: [Constraint]

174+data SimpleRestriction = SimpleRestriction

175+ { simpleRestrictionBase :: RefOr SimpleType

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]

118184 }

119185 deriving (Show, Eq)

120186

@@ -124,6 +190,11 @@ data RefOr t

124190 | Inline t

125191 deriving (Show, Eq)

126192

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+

127198data Constraint

128199 = Enumeration Text

129200 deriving (Show, Eq)

test/Spec.hs+72−14

@@ -6,6 +6,7 @@ module Spec

66where

88import Data.Text (Text)

9+import Data.Maybe

910import Data.Either

1011import Data.Map (Map)

1112import qualified Data.Map as Map

@@ -90,9 +91,35 @@ spec = do

9091 Xsd.AtomicType restriction _ = t

9192 res `shouldSatisfy` isRight

9293 tpName `shouldBe` (Xsd.QName Nothing "str")

93− Xsd.restrictionBase restriction `shouldBe`

94+ Xsd.simpleRestrictionBase restriction `shouldBe`

9495 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")

9596

97+ context "when restriction contains enumerations" $ do

98+ it "parses them" $ do

99+ let

100+ doc = mkDoc $

101+ mkElem "schema"

102+ (Map.fromList [("xmlns:xs","something")])

103+ [NodeElement $ mkElem "simpleType"

104+ (Map.fromList [("name", "str")])

105+ [NodeElement $ mkElem "restriction"

106+ (Map.fromList [("base", "xs:string")])

107+ [ NodeElement $ mkElem "enumeration"

108+ (Map.fromList [("value", "value1")]) []

109+ , NodeElement $ mkElem "enumeration"

110+ (Map.fromList [("value", "value2")]) []

111+ ]]]

112+ res = Xsd.parse Xsd.defaultConfig doc

113+ Right [Xsd.ChildType tpName (Xsd.TypeSimple t)] =

114+ fmap Xsd.children res

115+ Xsd.AtomicType restriction _ = t

116+ res `shouldSatisfy` isRight

117+ tpName `shouldBe` (Xsd.QName Nothing "str")

118+ Xsd.simpleRestrictionConstraints restriction `shouldBe`

119+ [ Xsd.Enumeration "value1"

120+ , Xsd.Enumeration "value2"

121+ ]

122+

96123 context "when restrication base is inlined" $ do

97124 it "parses it" $ do

98125 let

@@ -111,13 +138,13 @@ spec = do

111138 fmap Xsd.children res

112139 Xsd.AtomicType restriction' _ = t

113140 Xsd.Inline (Xsd.AtomicType restriction _) =

114− Xsd.restrictionBase restriction'

141+ Xsd.simpleRestrictionBase restriction'

115142 res `shouldSatisfy` isRight

116143 tpName `shouldBe` (Xsd.QName Nothing "str")

117− Xsd.restrictionBase restriction `shouldBe`

144+ Xsd.simpleRestrictionBase restriction `shouldBe`

118145 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")

119146

120− context "when base is refers to an unbound prefix" $ do

147+ context "when base refers to an unbound prefix" $ do

121148 it "fails" $ do

122149 let

123150 doc = mkDoc $

@@ -172,11 +199,12 @@ spec = do

172199 res = Xsd.parse Xsd.defaultConfig doc

173200 Right [Xsd.ChildType tpName (Xsd.TypeComplex t)] =

174201 fmap Xsd.children res

175− [attr] = Xsd.complexAttributes t

202+ Xsd.ContentPlain plain = Xsd.complexContent t

203+ [Xsd.InlineAttribute attr] = Xsd.plainContentAttributes plain

176204 res `shouldSatisfy` isRight

177205 tpName `shouldBe` Xsd.QName Nothing "person"

178− Xsd.attrName attr `shouldBe` Xsd.QName Nothing "firstName"

179− Xsd.attrType attr `shouldBe`

206+ Xsd.attributeInlineName attr `shouldBe` Xsd.QName Nothing "firstName"

207+ Xsd.attributeInlineType attr `shouldBe`

180208 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")

181209

182210 context "when attribute type is inlined" $ do

@@ -197,10 +225,12 @@ spec = do

197225 res = Xsd.parse Xsd.defaultConfig doc

198226 Right [Xsd.ChildType _ (Xsd.TypeComplex t)] =

199227 fmap Xsd.children res

200− [attr] = Xsd.complexAttributes t

201− Xsd.Inline (Xsd.AtomicType restriction _) = Xsd.attrType attr

228+ Xsd.ContentPlain plain = Xsd.complexContent t

229+ [Xsd.InlineAttribute attr] = Xsd.plainContentAttributes plain

230+ Xsd.Inline (Xsd.AtomicType restriction _) =

231+ Xsd.attributeInlineType attr

202232 res `shouldSatisfy` isRight

203− Xsd.restrictionBase restriction `shouldBe`

233+ Xsd.simpleRestrictionBase restriction `shouldBe`

204234 Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")

205235

206236 context "when it contains a sequence" $ do

@@ -228,10 +258,38 @@ spec = do

228258 res = Xsd.parse Xsd.defaultConfig doc

229259 Right [Xsd.ChildType _ (Xsd.TypeComplex t)] =

230260 fmap Xsd.children res

231− Just (Xsd.Sequence elems) = Xsd.complexModelGroup t

261+ Xsd.ContentPlain plain = Xsd.complexContent t

262+ Just (Xsd.Sequence elems) = Xsd.plainContentModel plain

232263 res `shouldSatisfy` isRight

233− map Xsd.elementName elems `shouldBe`

234− map (Xsd.QName Nothing) ["firstName", "lastName"]

264+ mapMaybe (Xsd.refOr (const Nothing) (Just . Xsd.elementName)) elems

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"

235293

236294 context "when element is given" $ do

237295 context "when type is inlined" $ do

@@ -249,7 +307,7 @@ spec = do

249307 ]

250308 ]

251309 res = Xsd.parse Xsd.defaultConfig doc

252− Right [Xsd.ChildElement e] = fmap Xsd.children res

310+ Right [Xsd.ChildElement (Xsd.Inline e)] = fmap Xsd.children res

253311 res `shouldSatisfy` isRight

254312 Xsd.elementName e `shouldBe`

255313 Xsd.QName Nothing "person"

xsd-parser.cabal+13−1

@@ -24,7 +24,7 @@ library

2424 , Xsd.Parser

2525

2626 -- Other library packages from which modules are imported.

27− build-depends: base ^>=4.12.0.0

27+ build-depends: base >=4.12 && < 5

2828 , bytestring

2929 , containers

3030 , lens >= 4.13

@@ -62,3 +62,15 @@ test-suite spec

6262 , xsd-parser

6363 default-language: Haskell2010

6464 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 #-}

3+module Main

4+( main

5+)

6+where

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.

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