fb680f3..master · typeable/xsd-parser

git.iko.soy/typeable/xsd-parser

on master help sign in

src/Xsd.hs+1−1

since splitsnapshots

unifiedsplit

@@ -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 e -> go (ts, (elementName e, e):es) cs

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

117 _ -> go (ts, es) cs

118

119fetchXsd :: URI -> IO Xsd

src/Xsd/Parser.hs+81−30

@@ -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 <$> parseElement c

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

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

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

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

@@ -81,6 +81,12 @@ 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+

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

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

154 unionAxis <- makeElemAxis "union"

160 unionAxis <- makeElemAxis "union"

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

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

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

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

157− <$> parseRestriction e

163+ <$> parseSimpleRestriction e

158 <*> parseAnnotations c

164 <*> parseAnnotations c

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

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

160 <$> parseList l

166 <$> parseList l

161 <*> parseAnnotations c

167 <*> parseAnnotations c

162− -- TODO implement me

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

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

169+ <$> parseUnion u

170+ <*> parseAnnotations c

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

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

165

172

166-- | Restriction for simple type

173-- | Restriction for simple type

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

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

168−parseRestriction c = do

175+parseSimpleRestriction c = do

169 -- XXX: generalaze RefOr parsing

176 -- XXX: generalaze RefOr parsing

170 tp <- case anAttribute "base" c of

177 tp <- case anAttribute "base" c of

171 Nothing -> do

178 Nothing -> do

@@ -178,9 +185,9 @@ parseRestriction c = do

178

185

179 constraints <- parseConstrains c

186 constraints <- parseConstrains c

180

187

181− return Xsd.Restriction

188+ return Xsd.SimpleRestriction

182− { Xsd.restrictionBase = tp

189+ { Xsd.simpleRestrictionBase = tp

183− , Xsd.restrictionConstraints = constraints

190+ , Xsd.simpleRestrictionConstraints = constraints

184 }

191 }

185

192

186parseConstrains :: Cursor -> P [Xsd.Constraint]

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

@@ -201,6 +208,15 @@ parseList c =

201 _ -> parseError c "Multiple types"

208 _ -> parseError c "Multiple types"

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

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

203

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+

204parseComplexType :: Cursor -> P Xsd.ComplexType

220parseComplexType :: Cursor -> P Xsd.ComplexType

205parseComplexType c = do

221parseComplexType c = do

206 annotations <- parseAnnotations c

222 annotations <- parseAnnotations c

@@ -231,14 +247,29 @@ parsePlainContent c = do

231 }

247 }

232

248

233parseSimpleContent :: Cursor -> P Xsd.SimpleContent

249parseSimpleContent :: Cursor -> P Xsd.SimpleContent

234−parseSimpleContent c = parseError c "not implemented"

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

235

266

236parseComplexContent :: Cursor -> P Xsd.ComplexContent

267parseComplexContent :: Cursor -> P Xsd.ComplexContent

237parseComplexContent c = do

268parseComplexContent c = do

238 restrictionAxis <- makeElemAxis "restriction"

269 restrictionAxis <- makeElemAxis "restriction"

239 extenstionAxis <- makeElemAxis "extension"

270 extenstionAxis <- makeElemAxis "extension"

240 case (c $/ restrictionAxis, c $/ extenstionAxis) of

271 case (c $/ restrictionAxis, c $/ extenstionAxis) of

241− ([r], []) -> parseError r "not implemented"

272+ ([r], []) -> Xsd.ComplexContentRestriction <$> parseComplexRestriction r

242 ([], [e]) -> Xsd.ComplexContentExtension <$> parseComplexExtension e

273 ([], [e]) -> Xsd.ComplexContentExtension <$> parseComplexExtension e

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

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

244

275

@@ -253,6 +284,17 @@ parseComplexExtension c = handleNamespaces c $ do

253 , Xsd.complexExtensionAttributes = attributes

284 , Xsd.complexExtensionAttributes = attributes

254 }

285 }

255

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

296+ }

297+

256parseModelGroup :: Cursor -> P (Maybe Xsd.ModelGroup)

298parseModelGroup :: Cursor -> P (Maybe Xsd.ModelGroup)

257parseModelGroup c = do

299parseModelGroup c = do

258 sequenceAxis <- makeElemAxis "sequence"

300 sequenceAxis <- makeElemAxis "sequence"

@@ -275,10 +317,10 @@ parseAll :: Cursor -> P Xsd.ModelGroup

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

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

276

318

277-- | Get all child elements

319-- | Get all child elements

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

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

279parseElements c = do

321parseElements c = do

280 elementAxis <- makeElemAxis "element"

322 elementAxis <- makeElemAxis "element"

281− mapM parseElement (c $/ elementAxis)

323+ mapM parseElementOrRef (c $/ elementAxis)

282

324

283parseAttributes :: Cursor -> P [Xsd.Attribute]

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

284parseAttributes c = do

326parseAttributes c = do

@@ -287,24 +329,33 @@ parseAttributes c = do

287

329

288parseAttribute :: Cursor -> P Xsd.Attribute

330parseAttribute :: Cursor -> P Xsd.Attribute

289parseAttribute c = do

331parseAttribute c = do

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

291 use <- parseUseAttribute c

332 use <- parseUseAttribute c

292−

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

293− -- XXX: generalaze RefOr parsing

334+ (Just n, Nothing) -> do

335+ name <- makeTargetQName n

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

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

295− Nothing -> do

337+ Nothing -> do

296− simpleTypeAxis <- makeElemAxis "simpleType"

338+ simpleTypeAxis <- makeElemAxis "simpleType"

297− case c $/ simpleTypeAxis of

339+ case c $/ simpleTypeAxis of

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

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

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

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

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

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

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

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

302−

344+ return $ Xsd.InlineAttribute $ Xsd.AttributeInline

303− return Xsd.Attribute

345+ { Xsd.attributeInlineName = name

304− { Xsd.attrName = name

346+ , Xsd.attributeInlineUse = use

305− , Xsd.attrUse = use

347+ , Xsd.attributeInlineType = tp

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

307− }

354+ }

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

356+ where

357+ anySimpleType =

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

308

359

309parseUseAttribute :: Cursor -> P Xsd.Use

360parseUseAttribute :: Cursor -> P Xsd.Use

310parseUseAttribute c = case anAttribute "use" c of

361parseUseAttribute c = case anAttribute "use" c of

src/Xsd/Types.hs+53−18

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

6, Child(..)

7, Type(..)

8, SimpleType(..)

9−, Restriction(..)

10, Constraint(..)

9, Constraint(..)

11, ComplexType(..)

10, ComplexType(..)

12, Content(..)

11, Content(..)

13, PlainContent(..)

12, PlainContent(..)

14, SimpleContent(..)

13, SimpleContent(..)

14+, SimpleExtension(..)

15+, SimpleRestriction(..)

15, ComplexContent(..)

16, ComplexContent(..)

16, ComplexExtension(..)

17, ComplexExtension(..)

18+, ComplexRestriction(..)

17, RefOr(..)

19, RefOr(..)

20+, refOr

18, Element(..)

21, Element(..)

19, MaxOccurs(..)

22, MaxOccurs(..)

20, Attribute(..)

23, Attribute(..)

24+, AttributeRef(..)

25+, AttributeInline(..)

21, Annotation(..)

26, Annotation(..)

22, Use(..)

27, Use(..)

23, ModelGroup(..)

28, ModelGroup(..)

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

48 deriving (Show, Eq, Ord)

53 deriving (Show, Eq, Ord)

50data Child

55data Child

51− = ChildElement Element

56+ = ChildElement (RefOr Element)

52 | ChildType QName Type

57 | ChildType QName Type

53 | ChildImport Import

58 | ChildImport Import

54 | ChildInclude Include

59 | ChildInclude Include

@@ -88,9 +93,9 @@ data Include = Include

88 deriving (Show, Eq)

93 deriving (Show, Eq)

90data SimpleType

95data SimpleType

91− = AtomicType Restriction [Annotation]

96+ = AtomicType SimpleRestriction [Annotation]

92 | ListType (RefOr SimpleType) [Annotation]

97 | ListType (RefOr SimpleType) [Annotation]

93− -- TODO: also union

98+ | UnionType [RefOr SimpleType] [Annotation]

94 deriving (Show, Eq)

99 deriving (Show, Eq)

100

96data ComplexType = ComplexType

101data ComplexType = ComplexType

@@ -114,7 +119,7 @@ data PlainContent = PlainContent

114

119

115data ComplexContent

120data ComplexContent

116 = ComplexContentExtension ComplexExtension

121 = ComplexContentExtension ComplexExtension

117− | ComplexContentRestriction -- TODO: implement me

122+ | ComplexContentRestriction ComplexRestriction

118 deriving (Show, Eq)

123 deriving (Show, Eq)

119

124

120data ComplexExtension = ComplexExtension

125data ComplexExtension = ComplexExtension

@@ -124,20 +129,39 @@ data ComplexExtension = ComplexExtension

124 }

129 }

125 deriving (Show, Eq)

130 deriving (Show, Eq)

126

131

127−-- TODO: implement me

132+data ComplexRestriction = ComplexRestriction

133+ { complexRestrictionBase :: QName

134+ , complexRestrictionModel :: Maybe ModelGroup

135+ , complexRestrictionAttributes :: [Attribute]

136+ }

137+ deriving (Show, Eq)

138+

128−data SimpleContent = SimpleContent

139+data SimpleContent

140+ = SimpleContentExtension SimpleExtension

141+ | SimpleContentRestriction SimpleRestriction

129 deriving (Show, Eq)

142 deriving (Show, Eq)

130

143

131data ModelGroup

144data ModelGroup

132− = Sequence [Element]

145+ = Sequence [RefOr Element]

133− | Choice [Element]

146+ | Choice [RefOr Element]

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

135 deriving (Show, Eq)

160 deriving (Show, Eq)

136

161

137−data Attribute = Attribute

162+data AttributeRef = AttributeRef

138− { attrName :: QName

163+ { attributeRefRef :: QName

139− , attrType :: RefOr SimpleType

164+ , attributeRefUse :: Use

140− , attrUse :: Use

141 }

165 }

142 deriving (Show, Eq)

166 deriving (Show, Eq)

143

167

@@ -147,10 +171,16 @@ data Use

147 | Required

171 | Required

148 deriving (Show, Eq)

172 deriving (Show, Eq)

149

173

150−data Restriction = Restriction

174+data SimpleRestriction = SimpleRestriction

151− { restrictionBase :: RefOr SimpleType

175+ { simpleRestrictionBase :: RefOr SimpleType

152− -- XXX: could restrictionBase be an inline type? Probably not.

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

153− , restrictionConstraints :: [Constraint]

177+ , simpleRestrictionConstraints :: [Constraint]

178+ }

179+ deriving (Show, Eq)

180+

181+data SimpleExtension = SimpleExtension

182+ { simpleExtensionBase :: QName

183+ , simpleExtensionAttributes :: [Attribute]

154 }

184 }

155 deriving (Show, Eq)

185 deriving (Show, Eq)

156

186

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

160 | Inline t

190 | Inline t

161 deriving (Show, Eq)

191 deriving (Show, Eq)

162

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+

163data Constraint

198data Constraint

164 = Enumeration Text

199 = Enumeration Text

165 deriving (Show, Eq)

200 deriving (Show, Eq)

test/Spec.hs+15−13

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

6where

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")

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

@@ -199,11 +200,11 @@ spec = do

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 Xsd.ContentPlain plain = Xsd.complexContent t

202 Xsd.ContentPlain plain = Xsd.complexContent t

202− [attr] = Xsd.plainContentAttributes plain

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

203 res `shouldSatisfy` isRight

204 res `shouldSatisfy` isRight

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

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

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

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

206− Xsd.attrType attr `shouldBe`

207+ Xsd.attributeInlineType attr `shouldBe`

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

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

208

209

209 context "when attribute type is inlined" $ do

210 context "when attribute type is inlined" $ do

@@ -225,10 +226,11 @@ spec = do

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

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

226 fmap Xsd.children res

227 fmap Xsd.children res

227 Xsd.ContentPlain plain = Xsd.complexContent t

228 Xsd.ContentPlain plain = Xsd.complexContent t

228− [attr] = Xsd.plainContentAttributes plain

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

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

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

231+ Xsd.attributeInlineType attr

230 res `shouldSatisfy` isRight

232 res `shouldSatisfy` isRight

231− Xsd.restrictionBase restriction `shouldBe`

233+ Xsd.simpleRestrictionBase restriction `shouldBe`

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

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

233

235

234 context "when it contains a sequence" $ do

236 context "when it contains a sequence" $ do

@@ -259,8 +261,8 @@ spec = do

259 Xsd.ContentPlain plain = Xsd.complexContent t

261 Xsd.ContentPlain plain = Xsd.complexContent t

260 Just (Xsd.Sequence elems) = Xsd.plainContentModel plain

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

261 res `shouldSatisfy` isRight

263 res `shouldSatisfy` isRight

262− map Xsd.elementName elems `shouldBe`

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

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

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

264

266

265 context "when it contains complexContent" $ do

267 context "when it contains complexContent" $ do

266 context "when it's an extenstion" $ do

268 context "when it's an extenstion" $ do

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

305 ]

307 ]

306 ]

308 ]

307 res = Xsd.parse Xsd.defaultConfig doc

309 res = Xsd.parse Xsd.defaultConfig doc

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

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

309 res `shouldSatisfy` isRight

311 res `shouldSatisfy` isRight

310 Xsd.elementName e `shouldBe`

312 Xsd.elementName e `shouldBe`

311 Xsd.QName Nothing "person"

313 Xsd.QName Nothing "person"

xsd-parser.cabal+1−1

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

24 , Xsd.Parser

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

29 , containers

30 , lens >= 4.13

xsts-test/Main.hs+61−23

@@ -19,9 +19,10 @@ import Text.XML.Cursor

19import qualified Xsd

21data Stat = Stat

22− { statTestSet :: Text

23− , statTotal :: Int

22+ { statTotal :: Int

24 , statSucceeded :: Int

23 , statSucceeded :: Int

24+ , statValidFailed :: Int

25+ , statInvalidSucceeded :: Int

25 }

26 }

26 deriving (Show)

27 deriving (Show)

@@ -34,27 +35,29 @@ okRef :: IORef Int

34okRef = unsafePerformIO (newIORef 0)

35okRef = unsafePerformIO (newIORef 0)

36{-# NOINLINE statsRef #-}

37{-# NOINLINE statsRef #-}

37−statsRef :: IORef [Stat]

38+statsRef :: IORef [(Text, Stat)]

38statsRef = unsafePerformIO (newIORef [])

39statsRef = unsafePerformIO (newIORef [])

40−dumpResults :: [Stat] -> IO ()

41+dumpResults :: [(Text, Stat)] -> IO ()

41dumpResults stats = IO.withFile "xsts.md" IO.WriteMode $ \h -> do

42dumpResults stats = IO.withFile "xsts.md" IO.WriteMode $ \h -> do

42 IO.hPutStrLn h "This table is generated automatically by `xsts` test."

43 IO.hPutStrLn h "This table is generated automatically by `xsts` test."

43 IO.hPutStrLn h "It contains number of xsd files successfully parsed."

44 IO.hPutStrLn h "It contains number of xsd files successfully parsed."

44 IO.hPutStrLn h "Note that we don't currently attempt to validate xml files"

45 IO.hPutStrLn h "Note that we don't currently attempt to validate xml files"

45 IO.hPutStrLn h "against the schemata."

46 IO.hPutStrLn h "against the schemata."

46 IO.hPutStrLn h ""

47 IO.hPutStrLn h ""

47− IO.hPutStrLn h "Test set | Total tests | Passed tests"

48+ IO.hPutStrLn h "Test set | Total tests | Passed tests | Invalid passed | Valid failed"

48− IO.hPutStrLn h "--- | --- | ---"

49+ IO.hPutStrLn h "--- | --- | --- | --- | ---"

49− forM_ stats $ \s -> do

50+ forM_ stats $ \(name, s) -> do

50 IO.hPutStrLn h $ mconcat

51 IO.hPutStrLn h $ mconcat

51− [ Text.unpack (statTestSet s), " | "

52+ [ Text.unpack name, " | "

52 , show (statTotal s), " | "

53 , show (statTotal s), " | "

53− , show (statSucceeded s)

54+ , show (statSucceeded s), " | "

55+ , show (statInvalidSucceeded s), " | "

56+ , show (statValidFailed s)

54 ]

57 ]

56expectedFailures :: Int

59expectedFailures :: Int

57−expectedFailures = 5080

60+expectedFailures = 3513

59main :: IO ()

62main :: IO ()

60main = do

63main = do

@@ -90,24 +93,59 @@ runTestSet path = do

90 results <- mapM (runTestGroup dir) (c $/ laxElement "testGroup")

93 results <- mapM (runTestGroup dir) (c $/ laxElement "testGroup")

91 let

94 let

92 stat = Stat

95 stat = Stat

93− { statTestSet = name

96+ { statTotal = (sum . map statTotal) results

94− , statTotal = (sum . map fst) results

97+ , statSucceeded = (sum . map statSucceeded) results

95− , statSucceeded = (sum . map snd) results

98+ , statValidFailed = (sum . map statValidFailed) results

99+ , statInvalidSucceeded = (sum . map statInvalidSucceeded) results

96 }

100 }

97− modifyIORef' statsRef (stat :)

101+ modifyIORef' statsRef ((name, stat) :)

98 where

102 where

99 dir = takeDirectory path

103 dir = takeDirectory path

100

104

101−runTestGroup :: FilePath -> Cursor -> IO (Int, Int)

105+runTestGroup :: FilePath -> Cursor -> IO Stat

102runTestGroup dir c = do

106runTestGroup dir c = do

103 name <- theAttribute c "name"

107 name <- theAttribute c "name"

104 results <- mapM (runSchemaTest dir name) (aChild c "schemaTest")

108 results <- mapM (runSchemaTest dir name) (aChild c "schemaTest")

105 case join results of

109 case join results of

106− Nothing -> return (0, 0)

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

107− Just True -> return (1, 1)

128+ Just InvalidSucceeded -> return Stat

129+ { statTotal = 1

130+ , statSucceeded = 0

131+ , statValidFailed = 0

132+ , statInvalidSucceeded = 1

133+ }

108− Just False -> return (1, 0)

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)

109

147

110−runSchemaTest :: FilePath -> Text -> Cursor -> IO (Maybe Bool)

148+runSchemaTest :: FilePath -> Text -> Cursor -> IO (Maybe Result)

111runSchemaTest dir groupName c = do

149runSchemaTest dir groupName c = do

112 path <- do

150 path <- do

113 c' <- theChild c "schemaDocument"

151 c' <- theChild c "schemaDocument"

@@ -126,21 +164,21 @@ runSchemaTest dir groupName c = do

126 case (res, valid) of

164 case (res, valid) of

127 (Left _, False) -> do

165 (Left _, False) -> do

128 modifyIORef' okRef succ

166 modifyIORef' okRef succ

129− return (Just True)

167+ return (Just InvalidFailed)

130 (Right _, True) -> do

168 (Right _, True) -> do

131 modifyIORef' okRef succ

169 modifyIORef' okRef succ

132− return (Just True)

170+ return (Just ValidSucceeded)

133 (Right _, False) -> do

171 (Right _, False) -> do

134 modifyIORef' errRef succ

172 modifyIORef' errRef succ

135 putStrLn $ "invalid xsd passed: " <> Text.unpack groupName

173 putStrLn $ "invalid xsd passed: " <> Text.unpack groupName

136 <> " (" <> dir </> Text.unpack path <> ")"

174 <> " (" <> dir </> Text.unpack path <> ")"

137− return (Just False)

175+ return (Just InvalidSucceeded)

138 (Left err, True) -> do

176 (Left err, True) -> do

139 modifyIORef' errRef succ

177 modifyIORef' errRef succ

140 putStrLn $ "valid xsd didn't pass: " <> Text.unpack groupName

178 putStrLn $ "valid xsd didn't pass: " <> Text.unpack groupName

141 <> " (" <> dir </> Text.unpack path <> ")"

179 <> " (" <> dir </> Text.unpack path <> ")"

142 <> ": " <> show (err :: SomeException)

180 <> ": " <> show (err :: SomeException)

143− return (Just False)

181+ return (Just ValidFailed)

144

182

145anAttribute :: Cursor -> Text -> Maybe Text

183anAttribute :: Cursor -> Text -> Maybe Text

146anAttribute c name = case c $| laxAttribute name of

184anAttribute c name = case c $| laxAttribute name of

xsts.md+95−95

@@ -3,98 +3,98 @@ It contains number of xsd files successfully parsed.

3Note that we don't currently attempt to validate xml files

4against the schemata.

6−Test set | Total tests | Passed tests

6+Test set | Total tests | Passed tests | Invalid passed | Valid failed

7−--- | --- | ---

7+--- | --- | --- | --- | ---

8−yearMonthDuration | 25 | 9

8+yearMonthDuration | 25 | 13 | 12 | 0

9−XSImportReference | 1 | 1

9+XSImportReference | 1 | 0 | 1 | 0

10−XPathDefaultNSonKeyKeyRefUnique | 13 | 11

10+XPathDefaultNSonKeyKeyRefUnique | 13 | 13 | 0 | 0

11−XML11Support | 11 | 11

11+XML11Support | 11 | 11 | 0 | 0

12−wildcard | 17 | 9

12+wildcard | 17 | 15 | 2 | 0

13−VC | 6 | 5

13+VC | 6 | 6 | 0 | 0

14−unsignedIntegers | 8 | 8

14+unsignedIntegers | 8 | 8 | 0 | 0

15−UnitsLength | 8 | 7

15+UnitsLength | 8 | 6 | 2 | 0

16−union | 19 | 6

16+union | 19 | 14 | 5 | 0

17−CTA | 6 | 4

17+CTA | 6 | 6 | 0 | 0

18−TypeAlternativeTests | 23 | 9

18+TypeAlternativeTests | 23 | 16 | 7 | 0

19−time | 1 | 1

19+time | 1 | 1 | 0 | 0

20−TargetNS | 2 | 0

20+TargetNS | 2 | 2 | 0 | 0

21−substitutionGroup | 5 | 2

21+substitutionGroup | 5 | 3 | 2 | 0

22−rf-whiteSpace | 2 | 2

22+rf-whiteSpace | 2 | 2 | 0 | 0

23−RestrictionOfComplexTypes | 13 | 11

23+RestrictionOfComplexTypes | 13 | 9 | 4 | 0

24−RegularExpression | 8 | 8

24+RegularExpression | 8 | 8 | 0 | 0

25−PopenContent | 24 | 13

25+PopenContent | 24 | 16 | 8 | 0

26−list | 2 | 1

26+list | 2 | 1 | 1 | 0

27−IdentityConstraint | 12 | 7

27+IdentityConstraint | 12 | 6 | 6 | 0

28−ID_IDREF | 77 | 44

28+ID_IDREF | 77 | 57 | 20 | 0

29−gMonth | 1 | 0

29+gMonth | 1 | 0 | 1 | 0

30−gDay | 1 | 1

30+gDay | 1 | 1 | 0 | 0

31−gMonthDay | 1 | 1

31+gMonthDay | 1 | 1 | 0 | 0

32−gYear | 1 | 1

32+gYear | 1 | 1 | 0 | 0

33−gYearMonth | 1 | 1

33+gYearMonth | 1 | 1 | 0 | 0

34−float | 2 | 2

34+float | 2 | 2 | 0 | 0

35−explicitTimezone | 18 | 6

35+explicitTimezone | 18 | 14 | 4 | 0

36−EDCWildcard | 2 | 2

36+EDCWildcard | 2 | 2 | 0 | 0

37−double | 2 | 2

37+double | 2 | 2 | 0 | 0

38−DefaultFixed | 5 | 2

38+DefaultFixed | 5 | 5 | 0 | 0

39−defaultAttributesApply | 17 | 14

39+defaultAttributesApply | 17 | 14 | 3 | 0

40−dayTimeDuration | 24 | 8

40+dayTimeDuration | 24 | 12 | 12 | 0

41−dateTimeStamp | 28 | 7

41+dateTimeStamp | 28 | 11 | 17 | 0

42−date | 1 | 1

42+date | 1 | 1 | 0 | 0

43−CyclicDependencies_Redefine_Include_Import_Override | 5 | 0

43+CyclicDependencies_Redefine_Include_Import_Override | 5 | 0 | 5 | 0

44−constraintsOnAttribute | 16 | 10

44+constraintsOnAttribute | 16 | 6 | 10 | 0

45−ConditionalInclusion | 3 | 2

45+ConditionalInclusion | 3 | 2 | 1 | 0

46−assertion | 51 | 42

46+assertion | 51 | 50 | 1 | 0

47−Assert | 35 | 25

47+Assert | 35 | 35 | 0 | 0

48−anyAttribute | 9 | 7

48+anyAttribute | 9 | 7 | 2 | 0

49−allGroup | 9 | 8

49+allGroup | 9 | 7 | 2 | 0

50−IRI | 1 | 0

50+IRI | 1 | 1 | 0 | 0

51−substitution-groups | 6 | 0

51+substitution-groups | 6 | 6 | 0 | 0

52−Zone | 9 | 5

52+Zone | 9 | 5 | 4 | 0

53−Zone | 20 | 16

53+Zone | 20 | 15 | 5 | 0

54−XmlVersions | 13 | 13

54+XmlVersions | 13 | 13 | 0 | 0

55−Wild | 84 | 52

55+Wild | 84 | 63 | 21 | 0

56−VC | 24 | 9

56+VC | 24 | 19 | 4 | 1

57−TargetNS | 4 | 0

57+TargetNS | 4 | 2 | 2 | 0

58−Subsgroup | 6 | 3

58+Subsgroup | 6 | 3 | 3 | 0

59−Simple | 58 | 31

59+Simple | 58 | 17 | 41 | 0

60−Override | 30 | 21

60+Override | 30 | 21 | 9 | 0

61−Open | 51 | 34

61+Open | 51 | 37 | 14 | 0

62−Missing | 6 | 5

62+Missing | 6 | 4 | 2 | 0

63−Id | 32 | 7

63+Id | 32 | 30 | 2 | 0

64−CTA | 44 | 13

64+CTA | 44 | 33 | 11 | 0

65−Complex | 25 | 11

65+Complex | 25 | 19 | 6 | 0

66−Assert | 34 | 2

66+Assert | 34 | 34 | 0 | 0

67−All | 62 | 29

67+All | 62 | 26 | 34 | 2

68−BoeingXSDTestCases | 6 | 0

68+BoeingXSDTestCases | 6 | 6 | 0 | 0

69−MS-Wildcards2006-07-15 | 315 | 210

69+MS-Wildcards2006-07-15 | 315 | 218 | 97 | 0

70−MS-SimpleType2006-07-15 | 333 | 146

70+MS-SimpleType2006-07-15 | 333 | 210 | 123 | 0

71−MS-Schema2006-07-15 | 124 | 56

71+MS-Schema2006-07-15 | 124 | 56 | 61 | 7

72−MS-Regex2006-07-15 | 2590 | 1988

72+MS-Regex2006-07-15 | 2590 | 1988 | 602 | 0

73−MS-Particles2006-07-15 | 855 | 491

73+MS-Particles2006-07-15 | 855 | 561 | 293 | 1

74−MS-Notations2006-07-15 | 116 | 40

74+MS-Notations2006-07-15 | 116 | 38 | 78 | 0

75−MS-ModelGroups2006-07-15 | 391 | 221

75+MS-ModelGroups2006-07-15 | 391 | 215 | 176 | 0

76−MS-IdentityConstraint2006-07-15 | 844 | 231

76+MS-IdentityConstraint2006-07-15 | 844 | 621 | 223 | 0

77−MS-Group2006-07-15 | 218 | 69

77+MS-Group2006-07-15 | 218 | 138 | 80 | 0

78−MS-Errata102006-07-15 | 19 | 10

78+MS-Errata102006-07-15 | 19 | 15 | 4 | 0

79−MS-Element2006-07-15 | 355 | 150

79+MS-Element2006-07-15 | 355 | 263 | 92 | 0

80−MS-DataTypes2006-07-15 | 2247 | 1084

80+MS-DataTypes2006-07-15 | 2247 | 1491 | 752 | 4

81−MS-ComplexType2006-07-15 | 550 | 270

81+MS-ComplexType2006-07-15 | 550 | 311 | 239 | 0

82−MS-Attribute2006-07-15 | 279 | 137

82+MS-Attribute2006-07-15 | 279 | 165 | 114 | 0

83−MS-AttributeGroup2006-07-15 | 114 | 64

83+MS-AttributeGroup2006-07-15 | 114 | 63 | 51 | 0

84−MS-Annotations2006-07-15 | 80 | 50

84+MS-Annotations2006-07-15 | 80 | 51 | 27 | 2

85−MS-Additional2006-07-15 | 253 | 157

85+MS-Additional2006-07-15 | 253 | 202 | 45 | 6

86−Wildcard | 26 | 22

86+Wildcard | 26 | 22 | 4 | 0

87−Schema | 6 | 6

87+Schema | 6 | 6 | 0 | 0

88−SType | 138 | 123

88+SType | 138 | 131 | 7 | 0

89−Notation | 13 | 8

89+Notation | 13 | 8 | 5 | 0

90−MGroupDef | 19 | 8

90+MGroupDef | 19 | 8 | 11 | 0

91−MGroup | 40 | 24

91+MGroup | 40 | 24 | 16 | 0

92−IdConstrDefs | 27 | 19

92+IdConstrDefs | 27 | 21 | 6 | 0

93−ElemDecl | 227 | 133

93+ElemDecl | 227 | 171 | 56 | 0

94−CType | 31 | 15

94+CType | 31 | 25 | 6 | 0

95−AttrUse | 4 | 1

95+AttrUse | 4 | 3 | 1 | 0

96−AttrDecl | 83 | 73

96+AttrDecl | 83 | 78 | 5 | 0

97−AGroupDef | 13 | 6

97+AGroupDef | 13 | 6 | 7 | 0

98−suntest | 52 | 19

98+suntest | 52 | 30 | 22 | 0

99−NIST2004-01-14 | 3953 | 3873

99+NIST2004-01-14 | 3953 | 3953 | 0 | 0

100−introspection | 1 | 0

100+introspection | 1 | 0 | 0 | 1