master..9fadbc0 · typeable/xsd-parser

git.iko.soy/typeable/xsd-parser

on 9fadbc0 help sign in

.gitmodulesdeleted−3

since splitsnapshots

unifiedsplit

@@ -1,3 +0,0 @@

1−[submodule "xsdtests"]

2− path = xsdtests

3− url = git@github.com:w3c/xsdtests.git

README.mddeleted−10

@@ -1,10 +0,0 @@

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

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

115 ChildType n t -> go ((n, t):ts, es) cs

116− ChildElement (Inline e) -> go (ts, (elementName e, e):es) cs

116+ ChildElement e -> go (ts, (elementName e, e):es) cs

117 _ -> go (ts, es) cs

118

119fetchXsd :: URI -> IO Xsd

src/Xsd/Parser.hs+53−166

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

48parseChild c = do

49 name <- getElementName c

50 case name of

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

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

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

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

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

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

81 , Xsd.importNamespace = namespace

82 }

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−

90parseElement :: Cursor -> P Xsd.Element

84parseElement :: Cursor -> P Xsd.Element

91parseElement c = handleNamespaces c $ do

85parseElement c = handleNamespaces c $ do

92 name <- theAttribute "name" c

86 name <- theAttribute "name" c

88+ -- XXX: generalaze RefOr parsing

94 tp <- case anAttribute "type" c of

89 tp <- case anAttribute "type" c of

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

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

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

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

98 minOccurs <- case anAttribute "minOccurs" c of

93 minOccurs <- case anAttribute "minOccurs" c of

99 Nothing -> return 1

94 Nothing -> return 1

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

112

107

113 qname <- makeTargetQName name

108 qname <- makeTargetQName name

114

109

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−

121 return Xsd.Element

110 return Xsd.Element

122 { Xsd.elementName = qname

111 { Xsd.elementName = qname

123 , Xsd.elementType = tp

112 , Xsd.elementType = tp

124 , Xsd.elementAnnotations = annotations

113 , Xsd.elementAnnotations = annotations

125 , Xsd.elementOccurs = (minOccurs, maxOccurs)

114 , Xsd.elementOccurs = (minOccurs, maxOccurs)

126− , Xsd.elementNillable = nillable

127 }

115 }

128− where

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

130

116

131-- | Parse inline type, simple or complex

117-- | Parse inline type, simple or complex

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

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

133parseType c = do

119parseType c = do

134 simpleTypeAxis <- makeElemAxis "simpleType"

120 simpleTypeAxis <- makeElemAxis "simpleType"

135 complexTypeAxis <- makeElemAxis "complexType"

121 complexTypeAxis <- makeElemAxis "complexType"

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

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

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

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

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

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

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

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

140 _ -> parseError c "Multiple types"

126 _ -> parseError c "Multiple types"

141

127

142-- | Top level simple type

128-- | Top level simple type

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

160 unionAxis <- makeElemAxis "union"

146 unionAxis <- makeElemAxis "union"

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

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

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

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

163− <$> parseSimpleRestriction e

149+ <$> parseRestriction e

164 <*> parseAnnotations c

150 <*> parseAnnotations c

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

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

166 <$> parseList l

152 <$> parseList l

167 <*> parseAnnotations c

153 <*> parseAnnotations c

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

154+ -- TODO implement me

169− <$> parseUnion u

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

170− <*> parseAnnotations c

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

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

172

157

173-- | Restriction for simple type

158-- | Restriction for simple type

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

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

175−parseSimpleRestriction c = do

160+parseRestriction c = do

176 -- XXX: generalaze RefOr parsing

161 -- XXX: generalaze RefOr parsing

177 tp <- case anAttribute "base" c of

162 tp <- case anAttribute "base" c of

178 Nothing -> do

163 Nothing -> do

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

183 _ -> parseError c "Multiple types"

168 _ -> parseError c "Multiple types"

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

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

185

170

186− constraints <- parseConstrains c

171+ return Xsd.Restriction

187−

172+ { Xsd.restrictionBase = tp

188− return Xsd.SimpleRestriction

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

189− { Xsd.simpleRestrictionBase = tp

190− , Xsd.simpleRestrictionConstraints = constraints

191 }

174 }

192

175

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−

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

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

200parseList c =

177parseList c =

201 -- XXX: generalaze RefOr parsing

178 -- XXX: generalaze RefOr parsing

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

208 _ -> parseError c "Multiple types"

185 _ -> parseError c "Multiple types"

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

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

210

187

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−

220parseComplexType :: Cursor -> P Xsd.ComplexType

188parseComplexType :: Cursor -> P Xsd.ComplexType

221parseComplexType c = do

189parseComplexType c = do

222− annotations <- parseAnnotations c

190+ attrAxis <- makeElemAxis "attribute"

223− cont <- parseContent c

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

224− return Xsd.ComplexType

192+

225− { Xsd.complexAnnotations = annotations

193+ group <- do

226− , Xsd.complexContent = cont

194+ sequenceAxis <- makeElemAxis "sequence"

227− }

195+ choiceAxis <- makeElemAxis "choice"

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"

196+ allAxis <- makeElemAxis "all"

253− case (c $/ restrictionAxis, c $/ extenstionAxis) of

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

254− ([r], []) -> Xsd.SimpleContentRestriction <$> parseSimpleRestriction r

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

255− ([], [e]) -> Xsd.SimpleContentExtension <$> parseSimpleExtension e

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

256− _ -> parseError c "Expected one of restriction or extension"

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

257−

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

258−parseSimpleExtension :: Cursor -> P Xsd.SimpleExtension

202+ _ -> parseError c "Multiple groups"

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

203

267−parseComplexContent :: Cursor -> P Xsd.ComplexContent

204+ annotations <- parseAnnotations c

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

205

287−parseComplexRestriction :: Cursor -> P Xsd.ComplexRestriction

206+ return Xsd.ComplexType

288−parseComplexRestriction c = handleNamespaces c $ do

207+ { Xsd.complexAttributes = attributes

289− base <- theAttribute "base" c >>= makeQName c

208+ , Xsd.complexModelGroup = group

290− attributes <- parseAttributes c

209+ , Xsd.complexAnnotations = annotations

291− model <- parseModelGroup c

292− return Xsd.ComplexRestriction

293− { Xsd.complexRestrictionBase = base

294− , Xsd.complexRestrictionModel = model

295− , Xsd.complexRestrictionAttributes = attributes

296 }

210 }

297

211

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−

310parseSequence :: Cursor -> P Xsd.ModelGroup

212parseSequence :: Cursor -> P Xsd.ModelGroup

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

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

312

214

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

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

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

318

220

319-- | Get all child elements

221-- | Get all child elements

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

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

321parseElements c = do

223parseElements c = do

322 elementAxis <- makeElemAxis "element"

224 elementAxis <- makeElemAxis "element"

323− mapM parseElementOrRef (c $/ elementAxis)

225+ mapM parseElement (c $/ elementAxis)

324−

325−parseAttributes :: Cursor -> P [Xsd.Attribute]

326−parseAttributes c = do

327− attrAxis <- makeElemAxis "attribute"

328− mapM parseAttribute (c $/ attrAxis)

329

226

330parseAttribute :: Cursor -> P Xsd.Attribute

227parseAttribute :: Cursor -> P Xsd.Attribute

331parseAttribute c = do

228parseAttribute c = do

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

332 use <- parseUseAttribute c

230 use <- parseUseAttribute c

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

231+

334− (Just n, Nothing) -> do

232+ -- XXX: generalaze RefOr parsing

335− name <- makeTargetQName n

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

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

337− Nothing -> do

234+ Nothing -> do

338− simpleTypeAxis <- makeElemAxis "simpleType"

235+ simpleTypeAxis <- makeElemAxis "simpleType"

339− case c $/ simpleTypeAxis of

236+ case c $/ simpleTypeAxis of

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

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

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

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

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

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

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

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

344− return $ Xsd.InlineAttribute $ Xsd.AttributeInline

241+

345− { Xsd.attributeInlineName = name

242+ return Xsd.Attribute

346− , Xsd.attributeInlineUse = use

243+ { Xsd.attrName = name

347− , Xsd.attributeInlineType = tp

244+ , Xsd.attrUse = use

348− }

245+ , Xsd.attrType = tp

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− }

246+ }

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

356− where

357− anySimpleType =

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

359

247

360parseUseAttribute :: Cursor -> P Xsd.Use

248parseUseAttribute :: Cursor -> P Xsd.Use

361parseUseAttribute c = case anAttribute "use" c of

249parseUseAttribute c = case anAttribute "use" c of

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

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

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

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

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

513 [n] -> do

401 [n] -> do

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

515 return Xsd.QName

402 return Xsd.QName

516− { Xsd.qnNamespace = ns

403+ { Xsd.qnNamespace = Nothing

517 , Xsd.qnName = n

404 , Xsd.qnName = n

518 }

405 }

519 [p, n] -> do

406 [p, n] -> do

src/Xsd/Types.hs+17−88

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

6, Child(..)

7, Type(..)

8, SimpleType(..)

9−, Constraint(..)

9+, Restriction(..)

10, ComplexType(..)

11−, Content(..)

12−, PlainContent(..)

13−, SimpleContent(..)

14−, SimpleExtension(..)

15−, SimpleRestriction(..)

16−, ComplexContent(..)

17−, ComplexExtension(..)

18−, ComplexRestriction(..)

19, RefOr(..)

11, RefOr(..)

20−, refOr

21, Element(..)

12, Element(..)

22, MaxOccurs(..)

13, MaxOccurs(..)

23, Attribute(..)

14, Attribute(..)

24−, AttributeRef(..)

25−, AttributeInline(..)

26, Annotation(..)

15, Annotation(..)

27, Use(..)

16, Use(..)

28, ModelGroup(..)

17, ModelGroup(..)

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

53 deriving (Show, Eq, Ord)

42 deriving (Show, Eq, Ord)

55data Child

44data Child

56− = ChildElement (RefOr Element)

45+ = ChildElement Element

57 | ChildType QName Type

46 | ChildType QName Type

58 | ChildImport Import

47 | ChildImport Import

59 | ChildInclude Include

48 | ChildInclude Include

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

66 { elementName :: QName

55 { elementName :: QName

67 , elementType :: RefOr Type

56 , elementType :: RefOr Type

68 , elementOccurs :: (Int, MaxOccurs)

57 , elementOccurs :: (Int, MaxOccurs)

69− , elementNillable :: Bool

70 , elementAnnotations :: [Annotation]

58 , elementAnnotations :: [Annotation]

71 }

59 }

72 deriving (Show, Eq)

60 deriving (Show, Eq)

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

93 deriving (Show, Eq)

81 deriving (Show, Eq)

95data SimpleType

83data SimpleType

96− = AtomicType SimpleRestriction [Annotation]

84+ = AtomicType Restriction [Annotation]

97 | ListType (RefOr SimpleType) [Annotation]

85 | ListType (RefOr SimpleType) [Annotation]

98− | UnionType [RefOr SimpleType] [Annotation]

86+ -- TODO: also union

99 deriving (Show, Eq)

87 deriving (Show, Eq)

100

101data ComplexType = ComplexType

89data ComplexType = ComplexType

90+ { complexAttributes :: [Attribute]

91+ , complexModelGroup :: Maybe ModelGroup

102− { complexAnnotations :: [Annotation]

92+ , complexAnnotations :: [Annotation]

103− , complexContent :: Content

104 }

93 }

105 deriving (Show, Eq)

94 deriving (Show, Eq)

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−

144data ModelGroup

96data ModelGroup

145− = Sequence [RefOr Element]

97+ = Sequence [Element]

146− | Choice [RefOr Element]

98+ | Choice [Element]

147− | All [RefOr Element]

99+ | All [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− }

160 deriving (Show, Eq)

100 deriving (Show, Eq)

161

101

162−data AttributeRef = AttributeRef

102+data Attribute = Attribute

163− { attributeRefRef :: QName

103+ { attrName :: QName

164− , attributeRefUse :: Use

104+ , attrType :: RefOr SimpleType

105+ , attrUse :: Use

165 }

106 }

166 deriving (Show, Eq)

107 deriving (Show, Eq)

167

108

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

171 | Required

112 | Required

172 deriving (Show, Eq)

113 deriving (Show, Eq)

173

114

174−data SimpleRestriction = SimpleRestriction

115+data Restriction = Restriction

175− { simpleRestrictionBase :: RefOr SimpleType

116+ { restrictionBase :: RefOr SimpleType

176− -- XXX: could simpleRestrictionBase be an inline type? Probably not.

117+ , restrictionConstraints :: [Constraint]

177− , simpleRestrictionConstraints :: [Constraint]

178− }

179− deriving (Show, Eq)

180−

181−data SimpleExtension = SimpleExtension

182− { simpleExtensionBase :: QName

183− , simpleExtensionAttributes :: [Attribute]

184 }

118 }

185 deriving (Show, Eq)

119 deriving (Show, Eq)

186

120

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

190 | Inline t

124 | Inline t

191 deriving (Show, Eq)

125 deriving (Show, Eq)

192

126

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−

198data Constraint

127data Constraint

199 = Enumeration Text

128 = Enumeration Text

200 deriving (Show, Eq)

129 deriving (Show, Eq)

test/Spec.hs+14−72

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

6where

8import Data.Text (Text)

9−import Data.Maybe

10import Data.Either

9import Data.Either

11import Data.Map (Map)

10import Data.Map (Map)

12import qualified Data.Map as Map

11import qualified Data.Map as Map

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

91 Xsd.AtomicType restriction _ = t

90 Xsd.AtomicType restriction _ = t

92 res `shouldSatisfy` isRight

91 res `shouldSatisfy` isRight

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

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

94− Xsd.simpleRestrictionBase restriction `shouldBe`

93+ Xsd.restrictionBase restriction `shouldBe`

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

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

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−

123 context "when restrication base is inlined" $ do

96 context "when restrication base is inlined" $ do

124 it "parses it" $ do

97 it "parses it" $ do

125 let

98 let

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

138 fmap Xsd.children res

111 fmap Xsd.children res

139 Xsd.AtomicType restriction' _ = t

112 Xsd.AtomicType restriction' _ = t

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

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

141− Xsd.simpleRestrictionBase restriction'

114+ Xsd.restrictionBase restriction'

142 res `shouldSatisfy` isRight

115 res `shouldSatisfy` isRight

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

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

144− Xsd.simpleRestrictionBase restriction `shouldBe`

117+ Xsd.restrictionBase restriction `shouldBe`

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

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

146

119

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

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

148 it "fails" $ do

121 it "fails" $ do

149 let

122 let

150 doc = mkDoc $

123 doc = mkDoc $

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

199 res = Xsd.parse Xsd.defaultConfig doc

172 res = Xsd.parse Xsd.defaultConfig doc

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

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

201 fmap Xsd.children res

174 fmap Xsd.children res

202− Xsd.ContentPlain plain = Xsd.complexContent t

175+ [attr] = Xsd.complexAttributes t

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

204 res `shouldSatisfy` isRight

176 res `shouldSatisfy` isRight

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

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

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

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

207− Xsd.attributeInlineType attr `shouldBe`

179+ Xsd.attrType attr `shouldBe`

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

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

209

181

210 context "when attribute type is inlined" $ do

182 context "when attribute type is inlined" $ do

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

225 res = Xsd.parse Xsd.defaultConfig doc

197 res = Xsd.parse Xsd.defaultConfig doc

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

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

227 fmap Xsd.children res

199 fmap Xsd.children res

228− Xsd.ContentPlain plain = Xsd.complexContent t

200+ [attr] = Xsd.complexAttributes t

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

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

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

231− Xsd.attributeInlineType attr

232 res `shouldSatisfy` isRight

202 res `shouldSatisfy` isRight

233− Xsd.simpleRestrictionBase restriction `shouldBe`

203+ Xsd.restrictionBase restriction `shouldBe`

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

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

235

205

236 context "when it contains a sequence" $ do

206 context "when it contains a sequence" $ do

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

258 res = Xsd.parse Xsd.defaultConfig doc

228 res = Xsd.parse Xsd.defaultConfig doc

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

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

260 fmap Xsd.children res

230 fmap Xsd.children res

261− Xsd.ContentPlain plain = Xsd.complexContent t

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

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

263 res `shouldSatisfy` isRight

232 res `shouldSatisfy` isRight

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

233+ map Xsd.elementName elems `shouldBe`

265− `shouldBe` map (Xsd.QName Nothing) ["firstName", "lastName"]

234+ 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"

293

235

294 context "when element is given" $ do

236 context "when element is given" $ do

295 context "when type is inlined" $ do

237 context "when type is inlined" $ do

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

307 ]

249 ]

308 ]

250 ]

309 res = Xsd.parse Xsd.defaultConfig doc

251 res = Xsd.parse Xsd.defaultConfig doc

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

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

311 res `shouldSatisfy` isRight

253 res `shouldSatisfy` isRight

312 Xsd.elementName e `shouldBe`

254 Xsd.elementName e `shouldBe`

313 Xsd.QName Nothing "person"

255 Xsd.QName Nothing "person"

xsd-parser.cabal+1−13

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

24 , Xsd.Parser

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

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

27+ build-depends: base ^>=4.12.0.0

28 , bytestring

29 , containers

30 , lens >= 4.13

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

62 , xsd-parser

63 default-language: Haskell2010

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

xsdtestsdeleted−1

Submodule changed.

xsts-test/Main.hsdeleted−201

@@ -1,201 +0,0 @@

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.mddeleted−100

@@ -1,100 +0,0 @@

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