git.iko.soy/typeable/xsd-parser
on master help sign in
swap
648877d25 ahead, 0 behind
14 files changed+1607−222
since splitsnapshots
unifiedsplit
.gitmodules+3 README.md+10 src/Text/XSD.hs−6 src/Text/XSD/Internal.hs−114 src/Text/XSD/Parser.hs−82 src/Xsd.hs+144 src/Xsd/Parser.hs+579 src/Xsd/Types.hs+210 test/Main.hs+9 test/Spec.hs+319 xsd-isogen.cabal → xsd-parser.cabal+31−20 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 @@
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/Text/XSD.hsdeleted−6
@@ -1,6 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−-- | A subset of XSD specification.
4−module Text.XSD where
5−
6−import Text.XSD.Parser
src/Text/XSD/Internal.hsdeleted−114
@@ -1,114 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−-- | A subset of XSD specification.
4−module Text.XSD.Internal where
5−
6−import Control.Lens
7−import Data.Text
8−import Data.Map as M
9−
10−
11−-- | Roughly based on https://www.w3.org/TR/xmlschema11-2/#built-in-datatypes
12−data Datatype
13− = ComplexType ComplexType
14− | SimpleType SimpleType
15− deriving (Show)
16−
17−-- | Based on https://www.w3.org/TR/xmlschema11-1/#dcl.ctd.ctsc
18−-- Only sequence and choice are supported
19−data ComplexType
20− = CTSequence
21− | CTChoice
22− deriving (Show)
23−
24−-- | ENTITIES, IDREFS and NMTOKENS are not supported right now.
25−data SimpleType
26− = STAnyURI
27− | STBase64Binary
28− | STBoolean
29− | STDate
30− | STDateTime
31− | STDecimal DecimalType
32− | STDouble
33− | STDuration DurationType
34− | STFloat
35− | STGDay
36− | STGMonth
37− | STGMonthDay
38− | STGYear
39− | STGYearMonth
40− | STHexBinary
41− | STNOTATION
42− | STQName QName
43− | STString StringType
44− | STTime
45− | STUnion -- special - xs:union
46− | STList -- special - xs:list
47− deriving (Show)
48−
49−data StringType
50− = StrNormalizedString
51− | StrToken
52− | StrLanguage
53− | StrName
54− | StrNCNAME
55− | StrENTITY
56− | StrID
57− | StrIDREF
58− | StrNMTOKEN
59− deriving (Show)
60−
61−data DurationType = DayTimeDuration | YearMonthDuration deriving (Show, Eq)
62−
63−data DecimalType
64− = DTInteger
65− | DTLong
66− | DTInt
67− | DTShort
68− | DTByte
69− | DTNonNegativeInteger
70− | DTPositiveInteger
71− | DTUnsignedLong
72− | DTUnsignedInt
73− | DTUnsignedShort
74− | DTUnsignedByte
75− | DTNonPositiveInteger
76− | DTNegativeInteger
77− deriving (Show, Eq)
78−
79−type LocalName = Text
80−
81−type Namespace = Text
82−
83−type QName = (Namespace, LocalName)
84−
85−-- data Definition
86−-- = XSString
87−-- | XSSeq [Definition]
88−-- | XSChoice [Definition]
89−-- deriving (Show)
90−
91−type Attribute = (Text, Text)
92−
93−-- | Based on https://www.w3.org/TR/xmlschema11-1/#concepts-data-model
94−-- Secondary and helper schema components are not supported right now.
95−data SchemaComponent
96− = SCSimpleType SimpleType
97− | SCComplexType ComplexType
98− | SCElement Element
99− | SCAttribute
100− deriving (Show)
101−
102−data Element = Element
103− { name :: String
104− , target :: Maybe Namespace
105− , xtype :: Datatype
106− , attrs :: [Attribute]
107− , abstract :: Bool
108− , elements :: [Element]
109− }
110− deriving (Show)
111−
112−-- | Embodies an XSD document
113−newtype XSD = XSD { unXSD :: Element }
114− deriving (Show)
src/Text/XSD/Parser.hsdeleted−82
@@ -1,82 +0,0 @@
1−module Text.XSD.Parser where
2−
3−import Control.Exception
4−import Control.Monad
5−import Control.Monad.Error
6−import Control.Monad.Trans.Reader
7−import Data.ByteString.Lazy
8−import Data.Map as M
9−import Data.Text
10−import Prelude as P
11−import Text.XML as XML
12−import Text.XML.Cursor as XML
13−import Text.XSD.Internal as XSD
14−
15−
16−newtype XSDException = XSDException String
17− deriving (Show)
18−
19−instance Exception XSDException
20−
21−type XSDMonad a = ReaderT (M.Map Name Datatype) (Either SomeException) a
22−
23−parseXSD :: ParseSettings -> ByteString -> Either SomeException XSD.Element
24−parseXSD ps bs = parseLBS ps bs >>= toXsd
25−
26−data Expectation
27− = ExpName Text
28− | Expectation :+: Expectation
29−
30−satisfy :: Expectation -> XML.Node -> Bool
31−satisfy exp node@(NodeElement (XML.Element name _ _)) =
32− case node of
33− NodeElement (XML.Element (Name name _ _) _ _) -> case exp of
34− ExpName n -> name == n
35− exp1 :+: exp2 -> satisfy exp1 node && satisfy exp2 node
36−
37−satisfySome
38− :: XML.Cursor
39− -> [Expectation]
40− -> Bool
41−satisfySome c e = satisfySome' True c e
42−
43−satisfySome'
44− :: Bool -- ^ check current
45− -> XML.Cursor
46− -> [Expectation]
47− -> Bool
48−satisfySome' checkCurrent cur [] = True
49−satisfySome' checkCurrent cur (exp:exps) = result
50− where
51− satisfyCurrent = satisfy exp (node cur)
52− validChildren = P.filter (satisfy (P.head exps) . node) (child cur)
53− result =
54− if checkCurrent && P.null exps
55− then satisfyCurrent
56− else P.foldr (\c r -> r && satisfySome' False c exps) True validChildren
57−
58−-- Show is Meh
59−throwXsd :: Show s => s -> XSDMonad a
60−throwXsd = throwError . SomeException . XSDException . show
61−
62−toSchema :: XML.Node -> [XSD.Element] -> XSDMonad XSD
63−toSchema (XML.NodeElement (XML.Element (Name name _ _) _ _)) elems
64− | name == "schema" = pure $ XSD $ XSD.Element (XSSeq []) "schema" [] elems
65− | otherwise = throwXsd "Top-level schema definition not found"
66−
67−fromElem :: XML.Cursor -> XSDMonad XSD.Element
68−fromElem cursor = do
69− case node cursor of
70− NodeElement el -> case nameLocalName (elementName el) of
71− "element" -> do
72−
73− "simpleType" -> error "TODO: implement"
74− e ->
75− throwXsd $ "xsd node not supported: " <> show e
76−
77−toXsd :: Document -> Either SomeException XSD.Element
78−toXsd doc = do
79− let
80− cursor = fromDocument doc
81− elems = child cursor &| fromElem
82− runReader M.null $ toSchema (node cursor) elems
src/Xsd.hsnew file+144
@@ -0,0 +1,144 @@
1+
2+module Xsd
3+( module Xsd.Types
4+, module Xsd.Parser
5+, Schema(..)
6+, getSchema
7+, mergeSchemata
8+)
9+where
10+
11+import qualified Data.Text as Text
12+import Data.Maybe
13+import Data.Map (Map)
14+import qualified Data.Map as Map
15+import qualified Data.Set as Set
16+import Control.Monad.IO.Class
17+import Control.Monad.Trans.State
18+import Network.URI (URI)
19+import qualified Network.URI as URI
20+import qualified Network.HTTP.Client as Http
21+import qualified Network.HTTP.Client.TLS as Http
22+import System.FilePath
23+
24+import Xsd.Types
25+import Xsd.Parser
26+
27+data Schema = Schema
28+ { schemaTypes :: Map QName Type
29+ , schemaElements :: Map QName Element
30+ }
31+ deriving (Show)
32+
33+emptySchema :: Schema
34+emptySchema = Schema
35+ { schemaTypes = Map.empty
36+ , schemaElements = Map.empty
37+ }
38+
39+mergeSchemata :: Schema -> Schema -> Schema
40+mergeSchemata s1 s2 = Schema
41+ { schemaTypes = schemaTypes s1 <> schemaTypes s2
42+ , schemaElements = schemaElements s1 <> schemaElements s2
43+ }
44+
45+instance Semigroup Schema where
46+ (<>) = mergeSchemata
47+
48+instance Monoid Schema where
49+ mempty = emptySchema
50+
51+-- | Get schema from file or URL
52+getSchema :: String -> IO Schema
53+getSchema source = do
54+ uri <- maybe (fail "Can't parse the source URI") return
55+ (URI.parseURIReference source)
56+ mconcat <$> evalStateT (go uri []) Set.empty
57+ where
58+ go uri schemata = do
59+ skip <- gets (Set.member uri)
60+ if skip
61+ then return schemata
62+ else do
63+ xsd <- liftIO $ fetchXsd uri
64+ modify' (Set.insert uri)
65+ let
66+ schema = xsdToSchema xsd
67+ includes = flip mapMaybe (children xsd) $ \c -> case c of
68+ ChildInclude i -> Just i
69+ _ -> Nothing
70+ imports = flip mapMaybe (children xsd) $ \c -> case c of
71+ ChildImport i -> Just i
72+ _ -> Nothing
73+ goInclude uri includes (schema:schemata)
74+ >>= goImports uri imports
75+
76+ goInclude _ [] schemata = return schemata
77+ goInclude uri (i:is) schemata = do
78+ let location = includeLocation i
79+ uri' <- maybe
80+ (fail ("Can't parse the location URI " <> show location))
81+ (\u -> return $ combineURIs uri u )
82+ (URI.parseURIReference (Text.unpack location))
83+ go uri' schemata
84+ >>= goInclude uri is
85+
86+ goImports _ [] schemata = return schemata
87+ goImports uri (i:is) schemata =
88+ case importLocation i of
89+ Nothing -> goImports uri is schemata
90+ Just location -> do
91+ uri' <- maybe
92+ (fail ("Can't parse the location URI " <> show location))
93+ (\u -> return $ combineURIs uri u)
94+ (URI.parseURIReference (Text.unpack location))
95+ go uri' schemata
96+ >>= goImports uri is
97+
98+-- | If the second URI is relative, then make it relative to the first one
99+combineURIs :: URI -> URI -> URI
100+combineURIs u1 u2 = if URI.uriIsAbsolute u2
101+ then u2
102+ else if isLocal u1
103+ then u1 {URI.uriPath = dropFileName (URI.uriPath u1) </> URI.uriPath u2}
104+ else u2 `URI.relativeTo` u1
105+
106+xsdToSchema :: Xsd -> Schema
107+xsdToSchema xsd = Schema
108+ { schemaTypes = Map.fromList types
109+ , schemaElements = Map.fromList elements
110+ }
111+ where
112+ (types, elements) = go ([], []) (children xsd)
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
117+ _ -> go (ts, es) cs
118+
119+fetchXsd :: URI -> IO Xsd
120+fetchXsd uri = do
121+ let
122+ path = URI.uriToString id uri ""
123+ onParseErr e = fail $ path ++ ": " ++ show e
124+ if isLocal uri
125+ then
126+ parseFile path
127+ >>= either onParseErr return
128+ else fetchHttp path
129+
130+fetchHttp :: String -> IO Xsd
131+fetchHttp url = do
132+ mgr <- Http.newTlsManager
133+ req <- Http.parseUrlThrow url
134+ resp <- Http.responseBody <$> Http.httpLbs req mgr
135+ either onErr return $
136+ parseLazyByteString resp
137+ where
138+ onErr e = fail $ url ++ ": " ++ show e
139+
140+isLocal :: URI -> Bool
141+isLocal uri = case URI.uriScheme uri of
142+ "http:" -> False
143+ "https:" -> False
144+ _ -> True
src/Xsd/Parser.hsnew file+579
@@ -0,0 +1,579 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Xsd.Parser
4+( parse
5+, parseFile
6+, parseLazyByteString
7+, ParseError(..)
8+, Config(..)
9+, defaultConfig
10+)
11+where
12+
13+import qualified Data.ByteString.Lazy as Lazy (ByteString)
14+import Data.Text (Text)
15+import qualified Data.Text as Text
16+import Data.Maybe
17+import qualified Data.Map as Map
18+import Control.Monad
19+import Control.Monad.Trans
20+import Control.Monad.Trans.Reader
21+import Control.Monad.Trans.Except
22+import Text.Read (readEither)
23+import Text.XML
24+import Text.XML.Cursor
25+
26+import Xsd.Types (Xsd(Xsd))
27+import qualified Xsd.Types as Xsd
28+
29+parseSchema :: Cursor -> P Xsd
30+parseSchema c = do
31+ let targetNamespace = Xsd.Namespace <$> anAttribute "targetNamespace" c
32+
33+ children <- local (\env -> env {envTargetNamespace = targetNamespace}) $
34+ parseChildren c
35+ return Xsd
36+ { Xsd.targetNamespace = targetNamespace
37+ , Xsd.children = children
38+ }
39+
40+parseChildren :: Cursor -> P [Xsd.Child]
41+parseChildren c =
42+ catMaybes <$> mapM parseChild (c $/ anyElement)
43+
44+-- | Parse top level schema node
45+--
46+-- Returns Nothing for unknown/unsupported nodes
47+parseChild :: Cursor -> P (Maybe Xsd.Child)
48+parseChild c = do
49+ name <- getElementName c
50+ case name of
51+ "element" -> Just . Xsd.ChildElement <$> parseElementOrRef c
52+ "simpleType" -> Just <$> parseTopSimpleType c
53+ "complexType" -> Just <$> parseTopComplexType c
54+ "include" -> Just . Xsd.ChildInclude <$> parseInclude c
55+ "import" -> Just . Xsd.ChildImport <$> parseImport c
56+ _ -> return Nothing
57+
58+parseInclude :: Cursor -> P Xsd.Include
59+parseInclude c = do
60+ location <- theAttribute "schemaLocation" c
61+ return Xsd.Include
62+ { Xsd.includeLocation = location
63+ }
64+
65+parseImport :: Cursor -> P Xsd.Import
66+parseImport c = do
67+ let
68+ location = anAttribute "schemaLocation" c
69+ namespace = Xsd.Namespace <$> anAttribute "namespace" c
70+
71+ tns <- asks envTargetNamespace
72+ case (namespace, tns) of
73+ (Nothing, Nothing) -> parseError c "Expected namespace"
74+ (Just ns1, Just ns2)
75+ | ns1 == ns2
76+ -> parseError c "Namespace equals target namespace"
77+ _ -> return ()
78+
79+ return Xsd.Import
80+ { Xsd.importLocation = location
81+ , Xsd.importNamespace = namespace
82+ }
83+
84+parseElementOrRef :: Cursor -> P (Xsd.RefOr Xsd.Element)
85+parseElementOrRef c = do
86+ case anAttribute "ref" c of
87+ Nothing -> Xsd.Inline <$> parseElement c
88+ Just ref -> Xsd.Ref <$> makeQName c ref
89+
90+parseElement :: Cursor -> P Xsd.Element
91+parseElement c = handleNamespaces c $ do
92+ name <- theAttribute "name" c
93+
94+ tp <- case anAttribute "type" c of
95+ Just t -> Xsd.Ref <$> makeQName c t
96+ _ -> maybe (Xsd.Ref anyType) Xsd.Inline <$> parseType c
97+
98+ minOccurs <- case anAttribute "minOccurs" c of
99+ Nothing -> return 1
100+ Just val -> case readEither (Text.unpack val) of
101+ Left err -> parseError c ("Can't parse minOccurs: " <> Text.pack err)
102+ Right v -> return v
103+
104+ maxOccurs <- case anAttribute "maxOccurs" c of
105+ Nothing -> return (Xsd.MaxOccurs 1)
106+ Just "unbounded" -> return Xsd.MaxOccursUnbound
107+ Just val -> case readEither (Text.unpack val) of
108+ Left err -> parseError c ("Can't parse maxOccurs" <> Text.pack err)
109+ Right v -> return (Xsd.MaxOccurs v)
110+
111+ annotations <- parseAnnotations c
112+
113+ qname <- makeTargetQName name
114+
115+ nillable <- case anAttribute "nillable" c of
116+ Nothing -> return False
117+ Just "true" -> return True
118+ Just "false" -> return False
119+ _ -> parseError c "Unexpected value of nillable attribute"
120+
121+ return Xsd.Element
122+ { Xsd.elementName = qname
123+ , Xsd.elementType = tp
124+ , Xsd.elementAnnotations = annotations
125+ , Xsd.elementOccurs = (minOccurs, maxOccurs)
126+ , Xsd.elementNillable = nillable
127+ }
128+ where
129+ anyType = Xsd.QName (Just (Xsd.Namespace Xsd.schemaNamespace)) "anyType"
130+
131+-- | Parse inline type, simple or complex
132+parseType :: Cursor -> P (Maybe Xsd.Type)
133+parseType c = do
134+ simpleTypeAxis <- makeElemAxis "simpleType"
135+ complexTypeAxis <- makeElemAxis "complexType"
136+ case (c $/ simpleTypeAxis, c $/ complexTypeAxis) of
137+ ([], []) -> return Nothing
138+ ([t], []) -> Just . Xsd.TypeSimple <$> parseSimpleType t
139+ ([], [t]) -> Just . Xsd.TypeComplex <$> parseComplexType t
140+ _ -> parseError c "Multiple types"
141+
142+-- | Top level simple type
143+parseTopSimpleType :: Cursor -> P Xsd.Child
144+parseTopSimpleType c = do
145+ name <- theAttribute "name" c >>= makeTargetQName
146+ t <- parseSimpleType c
147+ return $ Xsd.ChildType name (Xsd.TypeSimple t)
148+
149+-- | Top level complex type
150+parseTopComplexType :: Cursor -> P Xsd.Child
151+parseTopComplexType c = do
152+ name <- theAttribute "name" c >>= makeTargetQName
153+ t <- parseComplexType c
154+ return $ Xsd.ChildType name (Xsd.TypeComplex t)
155+
156+parseSimpleType :: Cursor -> P Xsd.SimpleType
157+parseSimpleType c = do
158+ restrictionAxis <- makeElemAxis "restriction"
159+ listAxis <- makeElemAxis "list"
160+ unionAxis <- makeElemAxis "union"
161+ case (c $/ restrictionAxis, c $/ listAxis, c $/ unionAxis) of
162+ ([e], [], []) -> Xsd.AtomicType
163+ <$> parseSimpleRestriction e
164+ <*> parseAnnotations c
165+ ([], [l], []) -> Xsd.ListType
166+ <$> parseList l
167+ <*> parseAnnotations c
168+ ([], [], [u]) -> Xsd.UnionType
169+ <$> parseUnion u
170+ <*> parseAnnotations c
171+ _ -> parseError c "Expected exactly of of restriction, list or union"
172+
173+-- | Restriction for simple type
174+parseSimpleRestriction :: Cursor -> P Xsd.SimpleRestriction
175+parseSimpleRestriction c = do
176+ -- XXX: generalaze RefOr parsing
177+ tp <- case anAttribute "base" c of
178+ Nothing -> do
179+ simpleTypeAxis <- makeElemAxis "simpleType"
180+ case c $/ simpleTypeAxis of
181+ [] -> parseError c "Expected simpleType"
182+ [s] -> Xsd.Inline <$> parseSimpleType s
183+ _ -> parseError c "Multiple types"
184+ Just t -> Xsd.Ref <$> makeQName c t
185+
186+ constraints <- parseConstrains c
187+
188+ return Xsd.SimpleRestriction
189+ { Xsd.simpleRestrictionBase = tp
190+ , Xsd.simpleRestrictionConstraints = constraints
191+ }
192+
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+
199+parseList :: Cursor -> P (Xsd.RefOr Xsd.SimpleType)
200+parseList c =
201+ -- XXX: generalaze RefOr parsing
202+ case anAttribute "itemType" c of
203+ Nothing -> do
204+ simpleTypeAxis <- makeElemAxis "simpleType"
205+ case c $/ simpleTypeAxis of
206+ [] -> parseError c "Expected simpleType"
207+ [s] -> Xsd.Inline <$> parseSimpleType s
208+ _ -> parseError c "Multiple types"
209+ Just t -> Xsd.Ref <$> makeQName c t
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+
220+parseComplexType :: Cursor -> P Xsd.ComplexType
221+parseComplexType c = do
222+ annotations <- parseAnnotations c
223+ cont <- parseContent c
224+ return Xsd.ComplexType
225+ { Xsd.complexAnnotations = annotations
226+ , Xsd.complexContent = cont
227+ }
228+
229+parseContent :: Cursor -> P Xsd.Content
230+parseContent c = do
231+ simpleContentAxis <- makeElemAxis "simpleContent"
232+ complexContentAxis <- makeElemAxis "complexContent"
233+ case (c $/ simpleContentAxis, c $/ complexContentAxis) of
234+ ([], []) -> Xsd.ContentPlain <$> parsePlainContent c
235+ ([s], []) -> Xsd.ContentSimple <$> parseSimpleContent s
236+ ([], [s]) -> Xsd.ContentComplex <$> parseComplexContent s
237+ _ -> parseError c
238+ "Expected one of simpleContent, complextContent or model group"
239+
240+parsePlainContent :: Cursor -> P Xsd.PlainContent
241+parsePlainContent c = do
242+ attributes <- parseAttributes c
243+ model <- parseModelGroup c
244+ return Xsd.PlainContent
245+ { Xsd.plainContentModel = model
246+ , Xsd.plainContentAttributes = attributes
247+ }
248+
249+parseSimpleContent :: Cursor -> P Xsd.SimpleContent
250+parseSimpleContent c = do
251+ restrictionAxis <- makeElemAxis "restriction"
252+ extenstionAxis <- makeElemAxis "extension"
253+ case (c $/ restrictionAxis, c $/ extenstionAxis) of
254+ ([r], []) -> Xsd.SimpleContentRestriction <$> parseSimpleRestriction r
255+ ([], [e]) -> Xsd.SimpleContentExtension <$> parseSimpleExtension e
256+ _ -> parseError c "Expected one of restriction or extension"
257+
258+parseSimpleExtension :: Cursor -> P Xsd.SimpleExtension
259+parseSimpleExtension c = handleNamespaces c $ do
260+ base <- theAttribute "base" c >>= makeQName c
261+ attributes <- parseAttributes c
262+ return Xsd.SimpleExtension
263+ { Xsd.simpleExtensionBase = base
264+ , Xsd.simpleExtensionAttributes = attributes
265+ }
266+
267+parseComplexContent :: Cursor -> P Xsd.ComplexContent
268+parseComplexContent c = do
269+ restrictionAxis <- makeElemAxis "restriction"
270+ extenstionAxis <- makeElemAxis "extension"
271+ case (c $/ restrictionAxis, c $/ extenstionAxis) of
272+ ([r], []) -> Xsd.ComplexContentRestriction <$> parseComplexRestriction r
273+ ([], [e]) -> Xsd.ComplexContentExtension <$> parseComplexExtension e
274+ _ -> parseError c "Expected one of restriction or extension"
275+
276+parseComplexExtension :: Cursor -> P Xsd.ComplexExtension
277+parseComplexExtension c = handleNamespaces c $ do
278+ base <- theAttribute "base" c >>= makeQName c
279+ attributes <- parseAttributes c
280+ model <- parseModelGroup c
281+ return Xsd.ComplexExtension
282+ { Xsd.complexExtensionBase = base
283+ , Xsd.complexExtensionModel = model
284+ , Xsd.complexExtensionAttributes = attributes
285+ }
286+
287+parseComplexRestriction :: Cursor -> P Xsd.ComplexRestriction
288+parseComplexRestriction c = handleNamespaces c $ do
289+ base <- theAttribute "base" c >>= makeQName c
290+ attributes <- parseAttributes c
291+ model <- parseModelGroup c
292+ return Xsd.ComplexRestriction
293+ { Xsd.complexRestrictionBase = base
294+ , Xsd.complexRestrictionModel = model
295+ , Xsd.complexRestrictionAttributes = attributes
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+
310+parseSequence :: Cursor -> P Xsd.ModelGroup
311+parseSequence c = Xsd.Sequence <$> parseElements c
312+
313+parseChoice :: Cursor -> P Xsd.ModelGroup
314+parseChoice c = Xsd.Choice <$> parseElements c
315+
316+parseAll :: Cursor -> P Xsd.ModelGroup
317+parseAll c = Xsd.All <$> parseElements c
318+
319+-- | Get all child elements
320+parseElements :: Cursor -> P [Xsd.RefOr Xsd.Element]
321+parseElements c = do
322+ elementAxis <- makeElemAxis "element"
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)
329+
330+parseAttribute :: Cursor -> P Xsd.Attribute
331+parseAttribute c = do
332+ use <- parseUseAttribute c
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"
359+
360+parseUseAttribute :: Cursor -> P Xsd.Use
361+parseUseAttribute c = case anAttribute "use" c of
362+ Nothing -> return Xsd.Optional
363+ Just "optional" -> return Xsd.Optional
364+ Just "required" -> return Xsd.Required
365+ Just "prohibited" -> return Xsd.Prohibited
366+ _ -> parseError c "Unknown attribute use"
367+
368+parseAnnotations :: Cursor -> P [Xsd.Annotation]
369+parseAnnotations c = do
370+ annotationAxis <- makeElemAxis "annotation"
371+ documentationAxis <- makeElemAxis "documentation"
372+
373+ let
374+ documentation = c
375+ $/ annotationAxis
376+ &// documentationAxis
377+ &/ content
378+ return $ Xsd.Documentation <$> documentation
379+
380+-- Section: parser entry points
381+
382+-- | Specifies modes of operation
383+data Config = Config
384+ { configIgnoreSchemaNamespace :: Bool
385+ -- ^ if not set, parser will check that all relevant xml nodes
386+ -- live is the correct XMLSchema namespace
387+ }
388+ deriving (Show)
389+
390+-- | Default configuration
391+defaultConfig :: Config
392+defaultConfig = Config
393+ { configIgnoreSchemaNamespace = False
394+ }
395+
396+-- | Parse the whole document
397+--
398+-- Make sure the document is parsed with `psRetainNamespaces` enabled!
399+parse :: Config -> Document -> Either ParseError Xsd
400+parse conf doc = do
401+ let
402+ env = Env
403+ { envConfig = conf
404+ , envTargetNamespace = Nothing
405+ , envPrefixes = []
406+ }
407+ c = fromDocument doc
408+ runExcept $ flip runReaderT env $ handleNamespaces c $ do
409+ schemaAxis <- makeElemAxis "schema"
410+ case c $.// schemaAxis of
411+ [] -> parseError c "Not schema found"
412+ [s] -> parseSchema s
413+ _ -> parseError c "Multiple schemata found"
414+
415+-- | Parse file
416+--
417+-- It uses the `defaultConfig`
418+parseFile :: FilePath -> IO (Either ParseError Xsd)
419+parseFile path = parse defaultConfig <$>
420+ Text.XML.readFile def{psRetainNamespaces=True} path
421+
422+parseLazyByteString :: Lazy.ByteString -> Either ParseError Xsd
423+parseLazyByteString = parse defaultConfig
424+ . parseLBS_ def{psRetainNamespaces=True}
425+
426+-- Section: parser environment
427+
428+-- | Namespace prefix, e.g. \"xs\" or \"tns\"
429+newtype Prefix = Prefix Text
430+ deriving (Show, Eq)
431+
432+-- | Parser environment
433+data Env = Env
434+ { envConfig :: Config
435+ , envTargetNamespace :: Maybe Xsd.Namespace
436+ -- ^ targetNamespace for the current schema
437+ , envPrefixes :: [(Maybe Prefix, Xsd.Namespace)]
438+ -- ^ all xmlns:prefix="namespace" things from the
439+ -- schema element
440+ }
441+ deriving (Show)
442+
443+-- | Parser
444+type P a = ReaderT Env (Except ParseError) a
445+
446+-- Section: error handling
447+
448+-- | Describes what exactly went wrong
449+data ParseError = ParseError
450+ { errorLocation :: Text
451+ -- ^ e.g. schema.element[Person].attribute[firstName]
452+ , errorMessage :: Text
453+ }
454+ deriving (Show)
455+
456+-- | Builds path to the current curson position
457+--
458+-- Goes through parents and collects their element names,
459+-- optionally adds value of "name" attribute
460+pprCursor :: Cursor -> Text
461+pprCursor = Text.intercalate "." . go []
462+ where
463+ go ctx c = case node c of
464+ NodeElement e ->
465+ let
466+ ctx' = name : ctx
467+ elemName = nameLocalName (elementName e)
468+ name = case laxAttribute "name" c of
469+ (n:_) -> elemName <> "[" <> n <> "]"
470+ _ -> elemName
471+ in case parent c of
472+ (p:_) -> go ctx' p
473+ _ -> ctx'
474+ _ -> ctx
475+
476+-- | Fail with the location and message
477+parseError :: Cursor -> Text -> P a
478+parseError c msg = lift $ throwE ParseError
479+ { errorLocation = pprCursor c
480+ , errorMessage = msg
481+ }
482+
483+-- Section: general utilities
484+
485+-- | Get value of an optional attribute
486+anAttribute :: Text -> Cursor -> Maybe Text
487+anAttribute name c = case c $| laxAttribute name of
488+ (a:_) -> Just a
489+ _ -> Nothing
490+
491+-- | Get value of the required attribute
492+theAttribute :: Text -> Cursor -> P Text
493+theAttribute name c = maybe err return (anAttribute name c)
494+ where
495+ err = parseError c ("Element should have attibute " <> name)
496+
497+-- | Select nodes with the specified name
498+--
499+-- Depending on the `configIgnoreSchemaNamespace`, it will or will not
500+-- check the namespace to be XMLSchema one
501+makeElemAxis :: Text -> P Axis
502+makeElemAxis name = do
503+ ignore <- asks (configIgnoreSchemaNamespace . envConfig)
504+ return $ if ignore
505+ then laxElement name
506+ else element (mkSchemaName name)
507+
508+-- | Parses reference to a type
509+--
510+-- Fails if it has a prefix which is not bound
511+makeQName :: Cursor -> Text -> P Xsd.QName
512+makeQName c t = case Text.splitOn ":" t of
513+ [n] -> do
514+ ns <- asks (lookup Nothing . envPrefixes)
515+ return Xsd.QName
516+ { Xsd.qnNamespace = ns
517+ , Xsd.qnName = n
518+ }
519+ [p, n] -> do
520+ known <- asks (lookup (Just (Prefix p)) . envPrefixes)
521+ case known of
522+ Nothing -> parseError c "Unbound prefix"
523+ _ -> return ()
524+ return Xsd.QName
525+ { Xsd.qnNamespace = known
526+ , Xsd.qnName = n
527+ }
528+ _ -> parseError c ("Can't parse name " <> t)
529+
530+makeTargetQName :: Text -> P Xsd.QName
531+makeTargetQName name = do
532+ tns <- asks envTargetNamespace
533+ return Xsd.QName
534+ { Xsd.qnNamespace = tns
535+ , Xsd.qnName = name
536+ }
537+
538+-- | Get name of the current node
539+--
540+-- Depending on `configIgnoreSchemaNamespace` value, it will or will not
541+-- check the namespace to be XMLSchema one
542+getElementName :: Cursor -> P Text
543+getElementName c = do
544+ case node c of
545+ NodeElement e -> do
546+ let name = elementName e
547+ ignore <- asks (configIgnoreSchemaNamespace . envConfig)
548+ unless ignore $ do
549+ when (nameNamespace name /= Just Xsd.schemaNamespace) $ do
550+ parseError c "Expected XMLSchema element"
551+ return (nameLocalName name)
552+ _ -> parseError c "Expected node element here"
553+
554+-- | Attaches xml schema namespace
555+mkSchemaName :: Text -> Name
556+mkSchemaName name = Name name (Just Xsd.schemaNamespace) Nothing
557+
558+-- | Add additional xmlns bindings into local scope
559+handleNamespaces :: Cursor -> P a -> P a
560+handleNamespaces c m = do
561+ ns <- parsePrefixes c
562+ local (\env -> env {envPrefixes = ns ++ envPrefixes env}) m
563+
564+-- | Parse namespace bindings
565+--
566+-- Cursor should point to schema node
567+parsePrefixes :: Cursor -> P [(Maybe Prefix, Xsd.Namespace)]
568+parsePrefixes c = case node c of
569+ NodeElement e -> return
570+ . concatMap toPrefix
571+ . Map.toList
572+ . elementAttributes
573+ $ e
574+ _ -> parseError c "Expected an element"
575+ where
576+ toPrefix (n, v) = case Text.splitOn ":" (nameLocalName n) of
577+ ["xmlns"] -> [(Nothing, Xsd.Namespace v)]
578+ ["xmlns", prefix] -> [(Just (Prefix prefix), Xsd.Namespace v)]
579+ _ -> []
src/Xsd/Types.hsnew file+210
@@ -0,0 +1,210 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Xsd.Types
4+( Xsd(..)
5+, Namespace(..)
6+, Child(..)
7+, Type(..)
8+, SimpleType(..)
9+, Constraint(..)
10+, ComplexType(..)
11+, Content(..)
12+, PlainContent(..)
13+, SimpleContent(..)
14+, SimpleExtension(..)
15+, SimpleRestriction(..)
16+, ComplexContent(..)
17+, ComplexExtension(..)
18+, ComplexRestriction(..)
19+, RefOr(..)
20+, refOr
21+, Element(..)
22+, MaxOccurs(..)
23+, Attribute(..)
24+, AttributeRef(..)
25+, AttributeInline(..)
26+, Annotation(..)
27+, Use(..)
28+, ModelGroup(..)
29+, Import(..)
30+, Include(..)
31+, QName(..)
32+, schemaNamespace
33+)
34+where
35+
36+import Data.Text (Text)
37+
38+data Xsd = Xsd
39+ { targetNamespace :: Maybe Namespace
40+ , children :: [Child]
41+ -- XXX: Investigate whether there could be any dependency on the order
42+ -- on children. E.g whether an element can reference type from other
43+ -- namespace only after the namespace is imported.
44+ -- If there is no such dependency, then get rid of Child and list
45+ -- types and elements separately here.
46+ }
47+ deriving (Show, Eq)
48+
49+-- | Namespace name, e.g. \"http://www.w3.org/2001/XMLSchema\"
50+newtype Namespace = Namespace
51+ { fromNamespace :: Text
52+ }
53+ deriving (Show, Eq, Ord)
54+
55+data Child
56+ = ChildElement (RefOr Element)
57+ | ChildType QName Type
58+ | ChildImport Import
59+ | ChildInclude Include
60+ deriving (Show, Eq)
61+
62+data Annotation = Documentation Text
63+ deriving (Show, Eq)
64+
65+data Element = Element
66+ { elementName :: QName
67+ , elementType :: RefOr Type
68+ , elementOccurs :: (Int, MaxOccurs)
69+ , elementNillable :: Bool
70+ , elementAnnotations :: [Annotation]
71+ }
72+ deriving (Show, Eq)
73+
74+data MaxOccurs
75+ = MaxOccurs Int
76+ | MaxOccursUnbound
77+ deriving (Show, Eq)
78+
79+data Type
80+ = TypeSimple SimpleType
81+ | TypeComplex ComplexType
82+ deriving (Show, Eq)
83+
84+data Import = Import
85+ { importNamespace :: Maybe Namespace
86+ , importLocation :: Maybe Text
87+ }
88+ deriving (Show, Eq)
89+
90+data Include = Include
91+ { includeLocation :: Text
92+ }
93+ deriving (Show, Eq)
94+
95+data SimpleType
96+ = AtomicType SimpleRestriction [Annotation]
97+ | ListType (RefOr SimpleType) [Annotation]
98+ | UnionType [RefOr SimpleType] [Annotation]
99+ deriving (Show, Eq)
100+
101+data ComplexType = ComplexType
102+ { complexAnnotations :: [Annotation]
103+ , complexContent :: Content
104+ }
105+ 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+
144+data ModelGroup
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+ }
160+ deriving (Show, Eq)
161+
162+data AttributeRef = AttributeRef
163+ { attributeRefRef :: QName
164+ , attributeRefUse :: Use
165+ }
166+ deriving (Show, Eq)
167+
168+data Use
169+ = Optional
170+ | Prohibited
171+ | Required
172+ deriving (Show, Eq)
173+
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]
184+ }
185+ deriving (Show, Eq)
186+
187+-- | Reference to a type or an inline one
188+data RefOr t
189+ = Ref QName
190+ | Inline t
191+ deriving (Show, Eq)
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+
198+data Constraint
199+ = Enumeration Text
200+ deriving (Show, Eq)
201+
202+data QName = QName
203+ { qnNamespace :: Maybe Namespace
204+ , qnName :: Text
205+ }
206+ deriving (Show, Eq, Ord)
207+
208+-- | XMLSchema namespace, all relevant xml nodes should live in it
209+schemaNamespace :: Text
210+schemaNamespace = "http://www.w3.org/2001/XMLSchema"
test/Main.hsnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Test.Hspec
4+
5+import Spec (spec)
6+
7+main :: IO ()
8+main = hspec $ do
9+ spec
test/Spec.hsnew file+319
@@ -0,0 +1,319 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Spec
4+( spec
5+)
6+where
7+
8+import Data.Text (Text)
9+import Data.Maybe
10+import Data.Either
11+import Data.Map (Map)
12+import qualified Data.Map as Map
13+import Text.XML
14+
15+import qualified Xsd
16+
17+import Test.Hspec
18+
19+spec :: Spec
20+spec = do
21+ describe "parse" $ do
22+ context "when targetNamespace is given" $ do
23+ it "parses the namespace" $ do
24+ let
25+ doc = mkDoc $
26+ mkElem "schema"
27+ (Map.fromList[("targetNamespace", "something")])
28+ []
29+ Right xsd = Xsd.parse Xsd.defaultConfig doc
30+ Xsd.targetNamespace xsd `shouldBe` Just (Xsd.Namespace "something")
31+
32+ context "when targetNamespace is not given" $ do
33+ it "returns Nothing" $ do
34+ let
35+ doc = mkDoc $
36+ mkElem "schema"
37+ (Map.fromList [])
38+ []
39+ Right xsd = Xsd.parse Xsd.defaultConfig doc
40+ Xsd.targetNamespace xsd `shouldBe` Nothing
41+
42+ context "when root element is not schema" $ do
43+ context "when root element has different name" $ do
44+ it "fails" $ do
45+ let
46+ doc = mkDoc $
47+ mkElem "notschema"
48+ (Map.fromList [])
49+ []
50+ Left err = Xsd.parse Xsd.defaultConfig doc
51+ Xsd.errorLocation err `shouldBe` "notschema"
52+
53+ context "when root element has different namespace" $ do
54+ it "fails" $ do
55+ let
56+ doc = mkDoc $
57+ Element "{othernamespace}schema"
58+ (Map.fromList [])
59+ []
60+ Left err = Xsd.parse Xsd.defaultConfig doc
61+ Xsd.errorLocation err `shouldBe` "schema"
62+
63+ context "when ignoring schema namespace" $ do
64+ it "succeeds" $ do
65+ let
66+ doc = mkDoc $
67+ Element "{othernamespace}schema"
68+ (Map.fromList [])
69+ []
70+ res = Xsd.parse conf doc
71+ conf = Xsd.defaultConfig
72+ { Xsd.configIgnoreSchemaNamespace = True
73+ }
74+ res `shouldSatisfy` isRight
75+
76+ context "when simple type is given" $ do
77+ context "when it's atomic with restriction" $ do
78+ it "parses it" $ do
79+ let
80+ doc = mkDoc $
81+ mkElem "schema"
82+ (Map.fromList [("xmlns:xs","something")])
83+ [NodeElement $ mkElem "simpleType"
84+ (Map.fromList [("name", "str")])
85+ [NodeElement $ mkElem "restriction"
86+ (Map.fromList [("base", "xs:string")])
87+ []]]
88+ res = Xsd.parse Xsd.defaultConfig doc
89+ Right [Xsd.ChildType tpName (Xsd.TypeSimple t)] =
90+ fmap Xsd.children res
91+ Xsd.AtomicType restriction _ = t
92+ res `shouldSatisfy` isRight
93+ tpName `shouldBe` (Xsd.QName Nothing "str")
94+ Xsd.simpleRestrictionBase restriction `shouldBe`
95+ Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
96+
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
124+ it "parses it" $ do
125+ let
126+ doc = mkDoc $
127+ mkElem "schema"
128+ (Map.fromList [("xmlns:xs","something")])
129+ [NodeElement $ mkElem "simpleType"
130+ (Map.fromList [("name", "str")])
131+ [NodeElement $ mkElem "restriction" Map.empty
132+ [NodeElement $ mkElem "simpleType" Map.empty
133+ [NodeElement $ mkElem "restriction"
134+ (Map.fromList [("base", "xs:string")])
135+ []]]]]
136+ res = Xsd.parse Xsd.defaultConfig doc
137+ Right [Xsd.ChildType tpName (Xsd.TypeSimple t)] =
138+ fmap Xsd.children res
139+ Xsd.AtomicType restriction' _ = t
140+ Xsd.Inline (Xsd.AtomicType restriction _) =
141+ Xsd.simpleRestrictionBase restriction'
142+ res `shouldSatisfy` isRight
143+ tpName `shouldBe` (Xsd.QName Nothing "str")
144+ Xsd.simpleRestrictionBase restriction `shouldBe`
145+ Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
146+
147+ context "when base refers to an unbound prefix" $ do
148+ it "fails" $ do
149+ let
150+ doc = mkDoc $
151+ mkElem "schema"
152+ (Map.fromList [])
153+ [NodeElement $ mkElem "simpleType"
154+ (Map.fromList [("name", "str")])
155+ [NodeElement $ mkElem "restriction"
156+ (Map.fromList [("base", "xs:string")])
157+ []]]
158+ res = Xsd.parse Xsd.defaultConfig doc
159+ Left err = res
160+ res `shouldSatisfy` isLeft
161+ Xsd.errorLocation err `shouldBe`
162+ "schema.simpleType[str].restriction"
163+
164+ context "when target namespace is provided" $ do
165+ it "parses it" $ do
166+ let
167+ doc = mkDoc $
168+ mkElem "schema"
169+ (Map.fromList
170+ [ ("xmlns:xs","something")
171+ , ("targetNamespace", "me")
172+ ])
173+ [NodeElement $ mkElem "simpleType"
174+ (Map.fromList [("name", "str")])
175+ [NodeElement $ mkElem "restriction"
176+ (Map.fromList [("base", "xs:string")])
177+ []]]
178+ res = Xsd.parse Xsd.defaultConfig doc
179+ Right [Xsd.ChildType tpName _] = fmap Xsd.children res
180+ res `shouldSatisfy` isRight
181+ tpName `shouldBe` (Xsd.QName (Just (Xsd.Namespace "me")) "str")
182+
183+ context "when complex type is given" $ do
184+ context "when it has attributes" $ do
185+ context "when attribute type is a reference" $ do
186+ it "succeeds" $ do
187+ let
188+ doc = mkDoc $
189+ mkElem "schema"
190+ (Map.fromList [("xmlns:xs","something")])
191+ [NodeElement $ mkElem "complexType"
192+ (Map.fromList [("name", "person")])
193+ [NodeElement $ mkElem "attribute"
194+ (Map.fromList
195+ [ ("type", "xs:string")
196+ , ("name", "firstName")
197+ ])
198+ []]]
199+ res = Xsd.parse Xsd.defaultConfig doc
200+ Right [Xsd.ChildType tpName (Xsd.TypeComplex t)] =
201+ fmap Xsd.children res
202+ Xsd.ContentPlain plain = Xsd.complexContent t
203+ [Xsd.InlineAttribute attr] = Xsd.plainContentAttributes plain
204+ res `shouldSatisfy` isRight
205+ tpName `shouldBe` Xsd.QName Nothing "person"
206+ Xsd.attributeInlineName attr `shouldBe` Xsd.QName Nothing "firstName"
207+ Xsd.attributeInlineType attr `shouldBe`
208+ Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
209+
210+ context "when attribute type is inlined" $ do
211+ it "succeeds" $ do
212+ let
213+ doc = mkDoc $
214+ mkElem "schema"
215+ (Map.fromList [("xmlns:xs","something")])
216+ [NodeElement $ mkElem "complexType"
217+ (Map.fromList [("name", "person")])
218+ [NodeElement $ mkElem "attribute"
219+ (Map.fromList [("name", "firstName")])
220+ [NodeElement $ mkElem "simpleType"
221+ (Map.empty)
222+ [NodeElement $ mkElem "restriction"
223+ (Map.fromList [("base", "xs:string")])
224+ []]]]]
225+ res = Xsd.parse Xsd.defaultConfig doc
226+ Right [Xsd.ChildType _ (Xsd.TypeComplex t)] =
227+ fmap Xsd.children res
228+ Xsd.ContentPlain plain = Xsd.complexContent t
229+ [Xsd.InlineAttribute attr] = Xsd.plainContentAttributes plain
230+ Xsd.Inline (Xsd.AtomicType restriction _) =
231+ Xsd.attributeInlineType attr
232+ res `shouldSatisfy` isRight
233+ Xsd.simpleRestrictionBase restriction `shouldBe`
234+ Xsd.Ref (Xsd.QName (Just (Xsd.Namespace "something")) "string")
235+
236+ context "when it contains a sequence" $ do
237+ it "succeeds" $ do
238+ let
239+ doc = mkDoc $
240+ mkElem "schema"
241+ (Map.fromList [("xmlns:xs","something")])
242+ [NodeElement $ mkElem "complexType"
243+ (Map.fromList [("name", "person")])
244+ [NodeElement $ mkElem "sequence" Map.empty
245+ [ NodeElement $ mkElem "element"
246+ (Map.fromList
247+ [ ("name", "firstName")
248+ , ("type", "xs:string")
249+ ])
250+ []
251+ , NodeElement $ mkElem "element"
252+ (Map.fromList
253+ [ ("name", "lastName")
254+ , ("type", "xs:string")
255+ ])
256+ []
257+ ]]]
258+ res = Xsd.parse Xsd.defaultConfig doc
259+ Right [Xsd.ChildType _ (Xsd.TypeComplex t)] =
260+ fmap Xsd.children res
261+ Xsd.ContentPlain plain = Xsd.complexContent t
262+ Just (Xsd.Sequence elems) = Xsd.plainContentModel plain
263+ res `shouldSatisfy` isRight
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"
293+
294+ context "when element is given" $ do
295+ context "when type is inlined" $ do
296+ it "succeeds" $ do
297+ let
298+ doc = mkDoc $
299+ mkElem "schema"
300+ (Map.fromList [("xmlns:xs","something")])
301+ [NodeElement $ mkElem "element"
302+ (Map.fromList [("name", "person")])
303+ [NodeElement $ mkElem "simpleType" Map.empty
304+ [NodeElement $ mkElem "restriction"
305+ (Map.fromList [("base", "xs:string")])
306+ []]
307+ ]
308+ ]
309+ res = Xsd.parse Xsd.defaultConfig doc
310+ Right [Xsd.ChildElement (Xsd.Inline e)] = fmap Xsd.children res
311+ res `shouldSatisfy` isRight
312+ Xsd.elementName e `shouldBe`
313+ Xsd.QName Nothing "person"
314+
315+mkDoc :: Element -> Document
316+mkDoc e = Document (Prologue [] Nothing []) e []
317+
318+mkElem :: Text -> Map Name Text -> [Node] -> Element
319+mkElem n = Element (Name n (Just Xsd.schemaNamespace) Nothing)
xsd-isogen.cabal → xsd-parser.cabalrenamed+31−20
@@ -1,5 +1,5 @@
11cabal-version: 2.4
2−name: xsd-isogen
2+name: xsd-parser
33
44-- The package version. See the Haskell package versioning policy (PVP)
55-- for standards guiding when and how versions should be incremented.
@@ -8,7 +8,7 @@ name: xsd-isogen
88-- | | +----- non-breaking API additions
99-- | | | +--- code changes with no API change
1010version: 0.1.0.0
11−synopsis: XSD representation and xml-isogen description generator from XSD
11+synopsis: Haskell representation and parser of the subset of xsd schema description format
1212license: BSD-3-Clause
1313license-file: LICENSE
1414author: Denis Redozubov
@@ -19,25 +19,30 @@ extra-source-files: CHANGELOG.md
1919
2020library
2121 -- Modules exported by the library.
22− exposed-modules: Text.XSD
23− , Text.XSD.Parser
24− , Text.XSD.Internal
25−
26− default-extensions: OverloadedStrings
27− other-extensions: TemplateHaskell
22+ exposed-modules: Xsd
23+ , Xsd.Types
24+ , Xsd.Parser
2825
2926 -- Other library packages from which modules are imported.
30− build-depends: base ^>=4.12.0.0
27+ build-depends: base >=4.12 && < 5
3128 , bytestring
3229 , containers
3330 , lens >= 4.13
3431 , mtl
3532 , text
33+ , template-haskell
3634 , transformers
3735 , xml-conduit
36+ , writer-cps-mtl
37+ , uniplate
38+ , network-uri
39+ , http-client
40+ , http-client-tls
41+ , filepath
3842
3943 -- Directories containing source files.
4044 hs-source-dirs: src
45+ ghc-options: -Wall
4146
4247 -- Base language which the package is written in.
4348 default-language: Haskell2010
@@ -46,20 +51,26 @@ test-suite spec
4651 type: exitcode-stdio-1.0
4752 hs-source-dirs: test
4853 main-is: Main.hs
54+ other-modules: Spec
4955 build-depends: base
5056 , bytestring
57+ , text
5158 , hspec
5259 , transformers
5360 , xml-conduit
54− , xsd-isogen
61+ , containers
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
5575 default-language: Haskell2010
56− default-extensions: CPP
57− , DeriveGeneric
58− , FlexibleInstances
59− , LambdaCase
60− , OverloadedStrings
61− , StandaloneDeriving
62− , TemplateHaskell
63− , TupleSections
64− , TypeFamilies
65− ghc-options: -Wall -fno-warn-missing-signatures
76+ ghc-options: -Wall
xsdtestsnew file+1

Submodule changed.

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