git.iko.soy/typeable/xsd-parser
on master help sign in
swap
648877d22 ahead, 0 behind
.gitmodulesnew file+3
since splitsnapshots
unifiedsplit
@@ -0,0 +1,3 @@
1+[submodule "xsdtests"]
2+ path = xsdtests
3+ url = git@github.com:w3c/xsdtests.git
README.mdnew file+10
@@ -0,0 +1,10 @@
1+
2+# xsd-parser
3+
4+Library for parsing XML schema files.
5+
6+# W3C XML Schema 1.1 test suite
7+
8+The test suite is designed mostly to test validation, but at least we
9+can check whether we are able to parse all the xsd files from the
10+test suite. See results [here](xsts.md).
src/Text/XSD.hsdeleted−10
@@ -1,10 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−-- | A subset of XSD specification.
4−module Text.XSD
5− ( module Text.XSD.Internal
6− , module Text.XSD.Parser
7− ) where
8−
9−import Text.XSD.Internal
10−import Text.XSD.Parser
src/Text/XSD/Internal.hsdeleted−113
@@ -1,113 +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−-- | and https://www.w3.org/TR/xmlschema11-1/#dcl.ctd.ctsc
13−data Datatype
14− = TypeComplex ComplexType
15− | TypeSimple SimpleType
16− deriving (Show, Eq)
17−
18−data ComplexType = ComplexType (Maybe Text) ModelGroupSchema [Element]
19− deriving (Show, Eq)
20−
21−data DatatypeRef
22− = InlineComplex Datatype
23− | DatatypeRef Text
24− deriving (Show, Eq)
25−
26−-- | Based on https://www.w3.org/TR/2012/REC-xmlschema11-1-20120405/structures.html#Model_Group_details
27−data ModelGroupSchema
28− = CTSequence
29− | CTChoice
30− | CTAll
31− deriving (Show, Eq)
32−
33−-- | ENTITIES, IDREFS and NMTOKENS are not supported right now.
34−data SimpleType
35− = STAtomic SimpleAtomicType
36− | STUnion [SimpleType] -- special - xs:union
37− | STList [SimpleType] -- special - xs:list
38− deriving (Show, Eq)
39−
40−data SimpleAtomicType
41− = STAnyURI
42− | STBase64Binary
43− | STBoolean
44− | STDate
45− | STDateTime
46− | STDecimal DecimalType
47− | STDouble
48− | STDuration DurationType
49− | STFloat
50− | STGDay
51− | STGMonth
52− | STGMonthDay
53− | STGYear
54− | STGYearMonth
55− | STHexBinary
56− | STNOTATION
57− | STQName QName
58− | STString StringType
59− | STTime
60− deriving (Show, Eq)
61−
62−data StringType
63− = StrNormalizedString
64− | StrToken
65− | StrLanguage
66− | StrName
67− | StrNCNAME
68− | StrENTITY
69− | StrID
70− | StrIDREF
71− | StrNMTOKEN
72− deriving (Show, Eq)
73−
74−data DurationType = DayTimeDuration | YearMonthDuration deriving (Show, Eq)
75−
76−data DecimalType
77− = DTInteger
78− | DTLong
79− | DTInt
80− | DTShort
81− | DTByte
82− | DTNonNegativeInteger
83− | DTPositiveInteger
84− | DTUnsignedLong
85− | DTUnsignedInt
86− | DTUnsignedShort
87− | DTUnsignedByte
88− | DTNonPositiveInteger
89− | DTNegativeInteger
90− deriving (Show, Eq)
91−
92−type LocalName = Text
93−
94−type Namespace = Text
95−
96−type QName = (Maybe Namespace, LocalName)
97−
98−-- | Based on https://www.w3.org/TR/xmlschema11-1/#concepts-data-model
99−-- Secondary and helper schema components are not supported right now.
100−-- data SchemaComponent
101−-- = SCDatatype Datatype
102−-- | SCElement Element
103−-- | SCAttribute
104−-- deriving (Show)
105−
106−data Element = Element
107− { name :: QName
108− , xtype :: DatatypeRef
109− } deriving (Show, Eq)
110−
111−-- | Embodies an XSD document
112−newtype XSD = XSD { unXSD :: [Element] }
113− deriving (Show, Eq)
src/Text/XSD/Parser.hsdeleted−165
@@ -1,165 +0,0 @@
1−module Text.XSD.Parser where
2−
3−import Control.Exception
4−import Control.Monad
5−import Control.Monad.Except (throwError)
6−import Control.Monad.Trans.Reader
7−import Control.Monad.Writer.CPS
8−import Data.ByteString.Lazy
9−import Data.Foldable
10−import Data.Map as M
11−import Data.Maybe
12−import Data.Text as T
13−import Prelude as P
14−import Text.XML as XML
15−import Text.XML.Cursor as XML
16−import Text.XSD.Internal as XSD
17−
18−
19−newtype XSDException = XSDException String
20− deriving (Show)
21−
22−instance Exception XSDException
23−
24−type XSDMonad a = WriterT (M.Map Text Datatype) (Either SomeException) a
25−
26−parseXSD :: ParseSettings -> ByteString -> Either SomeException XSD
27−parseXSD ps bs = parseLBS ps bs >>= toXsd
28−
29−data Expectation
30− = ExpName Text
31− | Expectation :+: Expectation
32−
33−satisfy :: Expectation -> XML.Node -> Bool
34−satisfy exp node@(NodeElement (XML.Element name _ _)) =
35− case node of
36− NodeElement (XML.Element (Name name _ _) _ _) -> case exp of
37− ExpName n -> name == n
38− exp1 :+: exp2 -> satisfy exp1 node && satisfy exp2 node
39−
40−satisfySome
41− :: XML.Cursor
42− -> [Expectation]
43− -> Bool
44−satisfySome c e = satisfySome' True c e
45−
46−satisfySome'
47− :: Bool -- ^ check current
48− -> XML.Cursor
49− -> [Expectation]
50− -> Bool
51−satisfySome' checkCurrent cur [] = True
52−satisfySome' checkCurrent cur (exp:exps) = result
53− where
54− satisfyCurrent = satisfy exp (node cur)
55− validChildren = P.filter (satisfy (P.head exps) . node) (child cur)
56− result =
57− if checkCurrent && P.null exps
58− then satisfyCurrent
59− else P.foldr (\c r -> r && satisfySome' False c exps) True validChildren
60−
61−-- Show is Meh
62−throwXsd :: Show s => s -> XSDMonad a
63−throwXsd = throwError . SomeException . XSDException . show
64−
65−maybeThrowXsd :: Show s => Maybe a -> s -> XSDMonad a
66−maybeThrowXsd (Just a) _ = pure a
67−maybeThrowXsd Nothing e = throwXsd e
68−
69−attrThrowXsd :: Show s => XML.Name -> XML.Element -> s -> XSDMonad Text
70−attrThrowXsd name elNode = maybeThrowXsd (M.lookup name $ elementAttributes elNode)
71−
72−-- | Tells the writer about named complex types and returns a list of elements.
73−toElemsAndDatatypes :: XML.Cursor -> XSDMonad [XSD.Element]
74−toElemsAndDatatypes cursor = do
75− elems <- traverse toElem (cursor $/ laxElement "element")
76− datatypes <- traverse toComplexType (cursor $/ laxElement "complexType")
77− for_ datatypes $ \case
78− datatype@(ComplexType (Just name) _ _) -> tell (M.singleton name (TypeComplex datatype))
79− datatype@(ComplexType Nothing _ _) ->
80− throwXsd $ "unnamed type ref for datatype: " <> show datatype
81− pure elems
82−
83−toSchema :: XML.Cursor -> XSDMonad XSD
84−toSchema cursor = do
85− let topLevel = cursor $| laxElement "schema"
86− if P.null topLevel
87− then throwXsd "Top-level schema definition not found"
88− else XSD <$> toElemsAndDatatypes cursor
89−
90−safeHead :: [a] -> Maybe a
91−safeHead [] = Nothing
92−safeHead (a:_) = Just a
93−
94−toElem :: Cursor -> XSDMonad XSD.Element
95−toElem cursor = do
96− case node cursor of
97− NodeElement el -> case nameLocalName (elementName el) of
98− "element" -> do
99− let
100− attrs = elementAttributes el
101− mAttrType = M.lookup "type" attrs
102− ns = nameNamespace $ elementName el
103− name <- attrThrowXsd "name" el
104− $ "Expected attribute 'name' for element: " <> show (node cursor)
105− datatypeRef <- case mAttrType of
106− Just dtn -> pure $ DatatypeRef dtn
107− Nothing -> do
108− case safeHead (cursor $// anyElement) of
109− Just c -> InlineComplex <$> toDatatype c
110− Nothing ->
111− throwXsd $ "[toElem] unexpected children of " <> T.unpack name
112− pure $ XSD.Element
113− { name = (ns, name)
114− , xtype = datatypeRef }
115− e -> throwXsd $ "[toElem] xsd node not supported: " <> show e
116− e ->
117− throwXsd $ "[toElem] element expected, got: " <> show e
118−
119−toDatatype :: Cursor -> XSDMonad Datatype
120−toDatatype cursor = do
121− case node cursor of
122− NodeElement el -> case nameLocalName (elementName el) of
123− "simpleType" -> TypeSimple <$> toSimpleType cursor
124− "complexType" -> TypeComplex <$> toComplexType cursor
125− e -> throwXsd $ "[toDatatype] xsd node not supported: " <> show e
126− e ->
127− throwXsd $ "[toDatatype] element expected, got: " <> show e
128−
129−toSimpleType :: Cursor -> XSDMonad SimpleType
130−toSimpleType cursor = do
131− error "TODO: implement toSimpleType"
132−
133−toComplexType :: Cursor -> XSDMonad ComplexType
134−toComplexType cursor = do
135− let sequenceAxis = laxElement "sequence"
136− let choiceAxis = laxElement "choice"
137− let allAxis = laxElement "all"
138− if P.null (cursor $// sequenceAxis)
139− then if P.null (cursor $// choiceAxis)
140− then if P.null (cursor $// allAxis)
141− then throwXsd $ "No definition found for complexType: "
142− <> show (safeHead $ cursor $// laxElement "complexType")
143− else do
144− childCursor <- maybeThrowXsd (safeHead $ cursor $// allAxis)
145− $ "More than one xs:all tag in: "
146− <> show (cursor $// laxElement "complexType")
147− let name = safeHead $ cursor $| attribute "name"
148− ComplexType name CTAll <$> toElemsAndDatatypes childCursor
149− else do
150− childCursor <- maybeThrowXsd (safeHead $ cursor $// choiceAxis)
151− $ "More than one xs:choice tag in: "
152− <> show (cursor $// laxElement "complexType")
153− let name = safeHead $ cursor $| attribute "name"
154− ComplexType name CTChoice <$> toElemsAndDatatypes childCursor
155− else do
156− childCursor <- maybeThrowXsd (safeHead $ cursor $// sequenceAxis)
157− $ "More than one xs:sequence tag in: "
158− <> show (cursor $// laxElement "complexType")
159− let name = safeHead $ cursor $| attribute "name"
160− ComplexType name CTSequence <$> toElemsAndDatatypes childCursor
161−
162−toXsd :: Document -> Either SomeException XSD
163−toXsd doc = do
164− (el, dt) <- runWriterT $ toSchema (fromDocument doc)
165− pure el
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)
test/fixtures/retrieve_seat_map.xmldeleted−600
@@ -1,600 +0,0 @@
1−<?xml version="1.0" encoding="UTF-8"?>
2−<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema" targetNamespace="http://xml.amadeus.com/SMPREQ_13_1_IA" xmlns="http://xml.amadeus.com/SMPREQ_13_1_IA" elementFormDefault="qualified">
3− <xs:element name="Air_RetrieveSeatMap">
4− <xs:annotation>
5− <xs:documentation xml:lang="en">To request seat map information for a specific flight and date.</xs:documentation>
6− </xs:annotation>
7− <xs:complexType>
8− <xs:sequence>
9− <xs:element name="travelProductIdent" type="TravelProductInformationTypeI">
10− <xs:annotation>
11− <xs:documentation xml:lang="en">Travel Product Identification</xs:documentation>
12− </xs:annotation>
13− </xs:element>
14− <xs:element name="seatRequestParameters" minOccurs="0" type="SeatRequestParametersTypeI">
15− <xs:annotation>
16− <xs:documentation xml:lang="en">Seat Request Parameters</xs:documentation>
17− </xs:annotation>
18− </xs:element>
19− <xs:element name="productInformation" minOccurs="0" type="RelatedProductInformationTypeI" />
20− <xs:element name="frequentTravelerInfo" minOccurs="0" type="FrequentTravellerInformationTypeI">
21− <xs:annotation>
22− <xs:documentation xml:lang="en">Frequent Traveler Information</xs:documentation>
23− </xs:annotation>
24− </xs:element>
25− <xs:element name="resControlInfo" minOccurs="0" type="ReservationControlInformationTypeI">
26− <xs:annotation>
27− <xs:documentation xml:lang="en">Record locator details</xs:documentation>
28− </xs:annotation>
29− </xs:element>
30− <xs:element name="equipmentInformation" minOccurs="0" type="EquipmentInfoTypeI" />
31− <xs:element name="additionalInfo" minOccurs="0" type="AdditionalBusinessSourceInformationTypeI">
32− <xs:annotation>
33− <xs:documentation xml:lang="en">Point of Sell override</xs:documentation>
34− </xs:annotation>
35− </xs:element>
36− <xs:element name="conversionRate" minOccurs="0" type="ConversionRateTypeI">
37− <xs:annotation>
38− <xs:documentation xml:lang="en">To return price in another currency</xs:documentation>
39− </xs:annotation>
40− </xs:element>
41− <xs:element name="traveler" minOccurs="0" maxOccurs="99">
42− <xs:annotation>
43− <xs:documentation xml:lang="en">Traveler detail group</xs:documentation>
44− </xs:annotation>
45− <xs:complexType>
46− <xs:sequence>
47− <xs:element name="travelerInformation" type="TravellerInformationTypeI" />
48− <xs:element name="frequentTravelerDetails" minOccurs="0" maxOccurs="99" type="FrequentTravellerInformationTypeI" />
49− <xs:element name="fareInfo" minOccurs="0" type="FareInformationTypeI">
50− <xs:annotation>
51− <xs:documentation xml:lang="en">PTC override and Ticket Designator</xs:documentation>
52− </xs:annotation>
53− </xs:element>
54− <xs:element name="dateAndTimeInfo" minOccurs="0" type="DateAndTimeInformationTypeI">
55− <xs:annotation>
56− <xs:documentation xml:lang="en">Date of Birth</xs:documentation>
57− </xs:annotation>
58− </xs:element>
59− <xs:element name="ticketDetails" minOccurs="0" type="TicketNumberTypeI">
60− <xs:annotation>
61− <xs:documentation xml:lang="en">eTicket number for pricing override</xs:documentation>
62− </xs:annotation>
63− </xs:element>
64− <xs:element name="fareQualifierDetails" minOccurs="0" type="FareQualifierDetailsTypeI">
65− <xs:annotation>
66− <xs:documentation xml:lang="en">Fare Basis</xs:documentation>
67− </xs:annotation>
68− </xs:element>
69− </xs:sequence>
70− </xs:complexType>
71− </xs:element>
72− </xs:sequence>
73− </xs:complexType>
74− </xs:element>
75− <xs:complexType name="AdditionalBusinessSourceInformationTypeI">
76− <xs:annotation>
77− <xs:documentation xml:lang="en">To specify additional originator and source information.</xs:documentation>
78− </xs:annotation>
79− <xs:sequence>
80− <xs:element name="sourceType" type="SourceTypeDetailsTypeI" />
81− <xs:element name="originatorDetails" minOccurs="0" type="OriginatorIdentificationDetailsTypeI" />
82− <xs:element name="locationDetails" minOccurs="0" type="LocationTypeI" />
83− <xs:element name="countryCode" minOccurs="0" type="AlphaNumericString_Length1To3" />
84− <xs:element name="systemCode" minOccurs="0" type="AlphaNumericString_Length1To35" />
85− </xs:sequence>
86− </xs:complexType>
87− <xs:complexType name="AdditionalEquipmentInformationTypeI">
88− <xs:annotation>
89− <xs:documentation xml:lang="en">To identify equipment configuration, registration number, and cabin facilities.</xs:documentation>
90− </xs:annotation>
91− <xs:sequence>
92− <xs:element name="fittedConfigurationCode" minOccurs="0" type="AlphaNumericString_Length1To12" />
93− <xs:element name="defaultConfigurationCode" minOccurs="0" type="AlphaNumericString_Length1To12" />
94− <xs:element name="airlineDetails" minOccurs="0" type="AlphaNumericString_Length1To35" />
95− <xs:element name="code" minOccurs="0" type="AlphaNumericString_Length1To17" />
96− <xs:element name="characteristic" minOccurs="0" maxOccurs="2" type="AlphaNumericString_Length1To3" />
97− </xs:sequence>
98− </xs:complexType>
99− <xs:complexType name="AdditionalFareQualifierDetailsTypeI">
100− <xs:annotation>
101− <xs:documentation xml:lang="en">To specify the fare basis and ticket designator codes.</xs:documentation>
102− </xs:annotation>
103− <xs:sequence>
104− <xs:element name="rateClass" minOccurs="0" type="AlphaNumericString_Length1To35" />
105− <xs:element name="commodityCategory" minOccurs="0" type="AlphaNumericString_Length1To18" />
106− </xs:sequence>
107− </xs:complexType>
108− <xs:complexType name="CompanyIdentificationTypeI">
109− <xs:annotation>
110− <xs:documentation xml:lang="en">Code or name to identify a company and any associated companies.</xs:documentation>
111− </xs:annotation>
112− <xs:sequence>
113− <xs:element name="marketingCompany" minOccurs="0" type="AlphaNumericString_Length1To35" />
114− <xs:element name="operatingCompany" minOccurs="0" type="AlphaNumericString_Length1To35" />
115− </xs:sequence>
116− </xs:complexType>
117− <xs:complexType name="ConfigurationDetailsTypeI">
118− <xs:annotation>
119− <xs:documentation xml:lang="en">To identify the number of seats for a specific class of service.</xs:documentation>
120− </xs:annotation>
121− <xs:sequence>
122− <xs:element name="classDesignator" type="AlphaString_Length1To1" />
123− <xs:element name="numberOfSeats" minOccurs="0" type="NumericInteger_Length1To3" />
124− <xs:element name="characteristic" minOccurs="0" maxOccurs="26" type="AlphaNumericString_Length1To17" />
125− </xs:sequence>
126− </xs:complexType>
127− <xs:complexType name="ConversionRateDetailsTypeI">
128− <xs:annotation>
129− <xs:documentation xml:lang="en">To specify the conversion rate and the monetary amount.</xs:documentation>
130− </xs:annotation>
131− <xs:sequence>
132− <xs:element name="conversionType" minOccurs="0" type="AlphaNumericString_Length1To3" />
133− <xs:element name="currency" minOccurs="0" type="AlphaNumericString_Length1To3" />
134− </xs:sequence>
135− </xs:complexType>
136− <xs:complexType name="ConversionRateTypeI">
137− <xs:annotation>
138− <xs:documentation xml:lang="en">To specify details of a conversion rate related to an amount.</xs:documentation>
139− </xs:annotation>
140− <xs:sequence>
141− <xs:element name="conversionRateDetails" type="ConversionRateDetailsTypeI" />
142− </xs:sequence>
143− </xs:complexType>
144− <xs:complexType name="DateAndTimeDetailsTypeI">
145− <xs:annotation>
146− <xs:documentation xml:lang="en">To provide date and time details relative to flight movements.</xs:documentation>
147− </xs:annotation>
148− <xs:sequence>
149− <xs:element name="qualifier" minOccurs="0" type="AlphaNumericString_Length1To3" />
150− <xs:element name="date" minOccurs="0" type="AlphaNumericString_Length1To35" />
151− </xs:sequence>
152− </xs:complexType>
153− <xs:complexType name="DateAndTimeInformationTypeI">
154− <xs:annotation>
155− <xs:documentation xml:lang="en">To provide date and time details relative to flight movements.</xs:documentation>
156− </xs:annotation>
157− <xs:sequence>
158− <xs:element name="dateAndTimeDetails" minOccurs="0" maxOccurs="99" type="DateAndTimeDetailsTypeI" />
159− </xs:sequence>
160− </xs:complexType>
161− <xs:complexType name="EquipmentInfoTypeI">
162− <xs:annotation>
163− <xs:documentation xml:lang="en">To specify configuration details of an aircraft.</xs:documentation>
164− </xs:annotation>
165− <xs:sequence>
166− <xs:element name="cabinClassDetails" minOccurs="0" maxOccurs="5" type="ConfigurationDetailsTypeI" />
167− <xs:element name="iataAircraftTypeCode" minOccurs="0" type="AlphaNumericString_Length1To8" />
168− <xs:element name="configVersionDetails" minOccurs="0" type="AdditionalEquipmentInformationTypeI" />
169− <xs:element name="configVersionDescription" minOccurs="0" type="AlphaNumericString_Length1To70" />
170− </xs:sequence>
171− </xs:complexType>
172− <xs:complexType name="FareInformationTypeI">
173− <xs:annotation>
174− <xs:documentation xml:lang="en">To specify fare details.</xs:documentation>
175− </xs:annotation>
176− <xs:sequence>
177− <xs:element name="valueQualifier" minOccurs="0" type="AlphaNumericString_Length1To3" />
178− <xs:element name="rateCategory" minOccurs="0" maxOccurs="9" type="AlphaNumericString_Length1To35" />
179− </xs:sequence>
180− </xs:complexType>
181− <xs:complexType name="FareQualifierDetailsTypeI">
182− <xs:annotation>
183− <xs:documentation xml:lang="en">To specify the details which qualify a fare</xs:documentation>
184− </xs:annotation>
185− <xs:sequence>
186− <xs:element name="additionalFareDetails" minOccurs="0" type="AdditionalFareQualifierDetailsTypeI" />
187− </xs:sequence>
188− </xs:complexType>
189− <xs:complexType name="FrequentTravellerIdentificationTypeI">
190− <xs:annotation>
191− <xs:documentation xml:lang="en">Identification of the frequent traveller number by company code with the capability to reference a specific traveller.</xs:documentation>
192− </xs:annotation>
193− <xs:sequence>
194− <xs:element name="carrier" type="AlphaNumericString_Length1To35" />
195− <xs:element name="number" type="AlphaNumericString_Length1To25" />
196− <xs:element name="customerReference" minOccurs="0" type="AlphaNumericString_Length1To10" />
197− <xs:element name="tierLevel" minOccurs="0" type="AlphaNumericString_Length1To35" />
198− <xs:element name="priorityCode" minOccurs="0" type="AlphaNumericString_Length1To12" />
199− <xs:element name="customerValue" minOccurs="0" type="NumericInteger_Length1To4" />
200− <xs:element name="type" minOccurs="0" type="AlphaNumericString_Length1To3">
201− <xs:annotation>
202− <xs:documentation xml:lang="en">To specify the product/account number qualifier. (e.g. 2=Corporate Frequent Flyer).</xs:documentation>
203− </xs:annotation>
204− </xs:element>
205− </xs:sequence>
206− </xs:complexType>
207− <xs:complexType name="FrequentTravellerInformationTypeI">
208− <xs:annotation>
209− <xs:documentation xml:lang="en">To specify frequent traveler information.</xs:documentation>
210− </xs:annotation>
211− <xs:sequence>
212− <xs:element name="frequentTravellerDetails" type="FrequentTravellerIdentificationTypeI" />
213− <xs:element name="otherFrequentTravellerDetails" minOccurs="0" maxOccurs="98" type="FrequentTravellerIdentificationTypeI" />
214− </xs:sequence>
215− </xs:complexType>
216− <xs:complexType name="GenericDetailsTypeI">
217− <xs:annotation>
218− <xs:documentation xml:lang="en">To identify the type of seat requested.</xs:documentation>
219− </xs:annotation>
220− <xs:sequence>
221− <xs:element name="cabinClassDesignator" minOccurs="0" type="AlphaString_Length1To1" />
222− <xs:element name="noSmokingIndicator" minOccurs="0" type="AlphaString_Length1To1" />
223− <xs:element name="cabinClass" minOccurs="0" type="NumericInteger_Length1To1" />
224− <xs:element name="compartmentDesignator" minOccurs="0" type="AlphaString_Length1To1" />
225− <xs:element name="seatCharacteristic" minOccurs="0" maxOccurs="5" type="AMA_EDICodesetType_Length1to2" />
226− </xs:sequence>
227− </xs:complexType>
228− <xs:complexType name="LocationTypeI">
229− <xs:annotation>
230− <xs:documentation xml:lang="en">To identify a location by code or name.</xs:documentation>
231− </xs:annotation>
232− <xs:sequence>
233− <xs:element name="trueLocationId" minOccurs="0" type="AlphaNumericString_Length1To25" />
234− <xs:element name="trueLocation" minOccurs="0" type="AlphaNumericString_Length1To17" />
235− </xs:sequence>
236− </xs:complexType>
237− <xs:complexType name="OriginatorIdentificationDetailsTypeI">
238− <xs:annotation>
239− <xs:documentation xml:lang="en">To identify the originator of the travel request.</xs:documentation>
240− </xs:annotation>
241− <xs:sequence>
242− <xs:element name="originatorId" minOccurs="0" type="NumericInteger_Length1To9">
243− <xs:annotation>
244− <xs:documentation xml:lang="en">is alpanum since the sine of an agent might contain his initials and duty code</xs:documentation>
245− </xs:annotation>
246− </xs:element>
247− <xs:element name="inHouseIdentification1" minOccurs="0" type="AlphaNumericString_Length1To9" />
248− <xs:element name="inHouseIdentification2" minOccurs="0" type="AlphaNumericString_Length1To9" />
249− <xs:element name="inHouseIdentification3" minOccurs="0" type="AlphaNumericString_Length1To9" />
250− </xs:sequence>
251− </xs:complexType>
252− <xs:complexType name="ProductDateTimeTypeI">
253− <xs:annotation>
254− <xs:documentation xml:lang="en">To specify the dates and times associated with a product.</xs:documentation>
255− </xs:annotation>
256− <xs:sequence>
257− <xs:element name="departureDate" minOccurs="0" type="AlphaNumericString_Length1To35" />
258− <xs:element name="departureTime" minOccurs="0" type="Time24_HHMM" />
259− <xs:element name="arrivalDate" minOccurs="0" type="AlphaNumericString_Length1To35" />
260− <xs:element name="arrivalTime" minOccurs="0" type="Time24_HHMM" />
261− <xs:element name="dateVariation" minOccurs="0" type="NumericInteger_Length1To1" />
262− </xs:sequence>
263− </xs:complexType>
264− <xs:complexType name="ProductIdentificationDetailsTypeI">
265− <xs:annotation>
266− <xs:documentation xml:lang="en">Code, number or name to identify a specific product or service.</xs:documentation>
267− </xs:annotation>
268− <xs:sequence>
269− <xs:element name="flightNumber" type="AlphaNumericString_Length1To35" />
270− <xs:element name="bookingClass" minOccurs="0" type="AlphaNumericString_Length1To17" />
271− <xs:element name="operationalSuffix" minOccurs="0" type="AlphaNumericString_Length1To3" />
272− <xs:element name="modifier" minOccurs="0" maxOccurs="3" type="AlphaNumericString_Length1To7" />
273− </xs:sequence>
274− </xs:complexType>
275− <xs:complexType name="ProductTypeDetailsTypeI">
276− <xs:annotation>
277− <xs:documentation xml:lang="en">To specify additional characteristics of a product or service.</xs:documentation>
278− </xs:annotation>
279− <xs:sequence>
280− <xs:element name="flightIndicator" maxOccurs="9" type="AlphaNumericString_Length1To6" />
281− </xs:sequence>
282− </xs:complexType>
283− <xs:complexType name="RangeOfRowsDetailsTypeI">
284− <xs:annotation>
285− <xs:documentation xml:lang="en">To specify row information for a means of transport.</xs:documentation>
286− </xs:annotation>
287− <xs:sequence>
288− <xs:element name="seatRowNumber" type="NumericInteger_Length1To3" />
289− <xs:element name="numberOfRows" minOccurs="0" type="NumericInteger_Length1To3" />
290− <xs:element name="seatColumn" minOccurs="0" maxOccurs="20" type="AlphaNumericString_Length1To1" />
291− </xs:sequence>
292− </xs:complexType>
293− <xs:complexType name="RelatedProductInformationTypeI">
294− <xs:annotation>
295− <xs:documentation xml:lang="en">To indicate quantity and action required in relation to a product.</xs:documentation>
296− </xs:annotation>
297− <xs:sequence>
298− <xs:element name="quantity" minOccurs="0" type="NumericInteger_Length1To15" />
299− <xs:element name="statusCode" minOccurs="0" maxOccurs="10" type="AlphaNumericString_Length1To3" />
300− </xs:sequence>
301− </xs:complexType>
302− <xs:complexType name="ReservationControlInformationDetailsTypeI">
303− <xs:annotation>
304− <xs:documentation xml:lang="en">To specify the information required to identify a reservation.</xs:documentation>
305− </xs:annotation>
306− <xs:sequence>
307− <xs:element name="companyId" minOccurs="0" type="AlphaNumericString_Length1To35" />
308− <xs:element name="controlNumber" minOccurs="0" type="AlphaNumericString_Length1To20" />
309− <xs:element name="controlType" minOccurs="0" type="AlphaNumericString_Length1To1" />
310− <xs:element name="date" minOccurs="0" type="AlphaNumericString_Length1To35" />
311− <xs:element name="time" minOccurs="0" type="NumericInteger_Length1To9" />
312− </xs:sequence>
313− </xs:complexType>
314− <xs:complexType name="ReservationControlInformationTypeI">
315− <xs:annotation>
316− <xs:documentation xml:lang="en">To specify a reference to a reservation.</xs:documentation>
317− </xs:annotation>
318− <xs:sequence>
319− <xs:element name="reservation" minOccurs="0" maxOccurs="9" type="ReservationControlInformationDetailsTypeI" />
320− </xs:sequence>
321− </xs:complexType>
322− <xs:complexType name="SeatRequestParametersTypeI">
323− <xs:annotation>
324− <xs:documentation xml:lang="en">To specify the selection criteria for a seat map request.</xs:documentation>
325− </xs:annotation>
326− <xs:sequence>
327− <xs:element name="genericDetails" minOccurs="0" type="GenericDetailsTypeI" />
328− <xs:element name="rangeOfRowsDetails" minOccurs="0" type="RangeOfRowsDetailsTypeI" />
329− <xs:element name="processingIndicator" minOccurs="0" type="AlphaNumericString_Length1To3" />
330− <xs:element name="referenceNumber" minOccurs="0" type="AlphaNumericString_Length1To35" />
331− <xs:element name="description" minOccurs="0" type="AlphaNumericString_Length1To70" />
332− </xs:sequence>
333− </xs:complexType>
334− <xs:complexType name="SourceTypeDetailsTypeI">
335− <xs:annotation>
336− <xs:documentation xml:lang="en">To identify the type of source.</xs:documentation>
337− </xs:annotation>
338− <xs:sequence>
339− <xs:element name="sourceQualifier1" type="AlphaNumericString_Length1To3" />
340− <xs:element name="sourceQualifier2" minOccurs="0" type="AlphaNumericString_Length1To3" />
341− </xs:sequence>
342− </xs:complexType>
343− <xs:complexType name="TicketNumberDetailsTypeI">
344− <xs:annotation>
345− <xs:documentation xml:lang="en">To specify a ticket number, type of ticket, and related information.</xs:documentation>
346− </xs:annotation>
347− <xs:sequence>
348− <xs:element name="number" minOccurs="0" type="AlphaNumericString_Length1To35" />
349− </xs:sequence>
350− </xs:complexType>
351− <xs:complexType name="TicketNumberTypeI">
352− <xs:annotation>
353− <xs:documentation xml:lang="en">To convey information related to a specific ticket.</xs:documentation>
354− </xs:annotation>
355− <xs:sequence>
356− <xs:element name="documentDetails" type="TicketNumberDetailsTypeI" />
357− </xs:sequence>
358− </xs:complexType>
359− <xs:complexType name="TravelProductInformationTypeI">
360− <xs:annotation>
361− <xs:documentation xml:lang="en">To specify details related to a product.</xs:documentation>
362− </xs:annotation>
363− <xs:sequence>
364− <xs:element name="flightDate" minOccurs="0" type="ProductDateTimeTypeI" />
365− <xs:element name="boardPointDetails" minOccurs="0" type="LocationTypeI" />
366− <xs:element name="offpointDetails" minOccurs="0" type="LocationTypeI" />
367− <xs:element name="companyDetails" minOccurs="0" type="CompanyIdentificationTypeI" />
368− <xs:element name="flightIdentification" minOccurs="0" type="ProductIdentificationDetailsTypeI" />
369− <xs:element name="flightTypeDetails" minOccurs="0" type="ProductTypeDetailsTypeI" />
370− </xs:sequence>
371− </xs:complexType>
372− <xs:complexType name="TravellerDetailsTypeI">
373− <xs:annotation>
374− <xs:documentation xml:lang="en">To identify the given/first name and the title of a traveller and the traveller type.</xs:documentation>
375− </xs:annotation>
376− <xs:sequence>
377− <xs:element name="givenName" minOccurs="0" type="AlphaNumericString_Length1To70" />
378− <xs:element name="type" minOccurs="0" type="AlphaNumericString_Length1To3" />
379− <xs:element name="uniqueCustomerIdentifier" minOccurs="0" type="AlphaNumericString_Length1To10" />
380− <xs:element name="infantIndicator" minOccurs="0" type="AlphaNumericString_Length1To1" />
381− </xs:sequence>
382− </xs:complexType>
383− <xs:complexType name="TravellerInformationTypeI">
384− <xs:annotation>
385− <xs:documentation xml:lang="en">To specify a traveler(s) and personal details relating to the traveler(s).</xs:documentation>
386− </xs:annotation>
387− <xs:sequence>
388− <xs:element name="paxDetails" type="TravellerSurnameInformationTypeI" />
389− <xs:element name="otherPaxDetails" minOccurs="0" maxOccurs="99" type="TravellerDetailsTypeI" />
390− </xs:sequence>
391− </xs:complexType>
392− <xs:complexType name="TravellerSurnameInformationTypeI">
393− <xs:annotation>
394− <xs:documentation xml:lang="en">Identification of the surname of a traveller, the type of traveller, number of travellers per surname and the action to be taken.</xs:documentation>
395− </xs:annotation>
396− <xs:sequence>
397− <xs:element name="surname" type="AlphaNumericString_Length1To70" />
398− <xs:element name="type" minOccurs="0" type="AlphaNumericString_Length1To3" />
399− <xs:element name="quantity" minOccurs="0" type="NumericInteger_Length1To15" />
400− </xs:sequence>
401− </xs:complexType>
402− <xs:simpleType name="AlphaNumericString_Length1To3">
403− <xs:annotation>
404− <xs:documentation xml:lang="en">Format limitations: an..3</xs:documentation>
405− </xs:annotation>
406− <xs:restriction base="xs:string">
407− <xs:minLength value="1" />
408− <xs:maxLength value="3" />
409− </xs:restriction>
410− </xs:simpleType>
411− <xs:simpleType name="AlphaNumericString_Length1To35">
412− <xs:annotation>
413− <xs:documentation xml:lang="en">Format limitations: an..35</xs:documentation>
414− </xs:annotation>
415− <xs:restriction base="xs:string">
416− <xs:minLength value="1" />
417− <xs:maxLength value="35" />
418− </xs:restriction>
419− </xs:simpleType>
420− <xs:simpleType name="AlphaNumericString_Length1To70">
421− <xs:annotation>
422− <xs:documentation xml:lang="en">Format limitations: an..70</xs:documentation>
423− </xs:annotation>
424− <xs:restriction base="xs:string">
425− <xs:minLength value="1" />
426− <xs:maxLength value="70" />
427− </xs:restriction>
428− </xs:simpleType>
429− <xs:simpleType name="NumericInteger_Length1To15">
430− <xs:annotation>
431− <xs:documentation xml:lang="en">Format limitations: n..15</xs:documentation>
432− </xs:annotation>
433− <xs:restriction base="xs:integer">
434− <xs:pattern value="-?[0-9]{1,15}" />
435− </xs:restriction>
436− </xs:simpleType>
437− <xs:simpleType name="AlphaNumericString_Length1To8">
438− <xs:annotation>
439− <xs:documentation xml:lang="en">Format limitations: an..8</xs:documentation>
440− </xs:annotation>
441− <xs:restriction base="xs:string">
442− <xs:minLength value="1" />
443− <xs:maxLength value="8" />
444− </xs:restriction>
445− </xs:simpleType>
446− <xs:simpleType name="NumericInteger_Length1To1">
447− <xs:annotation>
448− <xs:documentation xml:lang="en">Format limitations: n1</xs:documentation>
449− </xs:annotation>
450− <xs:restriction base="xs:integer">
451− <xs:pattern value="-?[0-9]{1,1}" />
452− </xs:restriction>
453− </xs:simpleType>
454− <xs:simpleType name="AlphaNumericString_Length1To25">
455− <xs:annotation>
456− <xs:documentation xml:lang="en">Format limitations: an..25</xs:documentation>
457− </xs:annotation>
458− <xs:restriction base="xs:string">
459− <xs:minLength value="1" />
460− <xs:maxLength value="25" />
461− </xs:restriction>
462− </xs:simpleType>
463− <xs:simpleType name="AlphaNumericString_Length1To17">
464− <xs:annotation>
465− <xs:documentation xml:lang="en">Format limitations: an..17</xs:documentation>
466− </xs:annotation>
467− <xs:restriction base="xs:string">
468− <xs:minLength value="1" />
469− <xs:maxLength value="17" />
470− </xs:restriction>
471− </xs:simpleType>
472− <xs:simpleType name="AlphaNumericString_Length1To7">
473− <xs:annotation>
474− <xs:documentation xml:lang="en">Format limitations: an..7</xs:documentation>
475− </xs:annotation>
476− <xs:restriction base="xs:string">
477− <xs:minLength value="1" />
478− <xs:maxLength value="7" />
479− </xs:restriction>
480− </xs:simpleType>
481− <xs:simpleType name="AlphaNumericString_Length1To6">
482− <xs:annotation>
483− <xs:documentation xml:lang="en">Format limitations: an..6</xs:documentation>
484− </xs:annotation>
485− <xs:restriction base="xs:string">
486− <xs:minLength value="1" />
487− <xs:maxLength value="6" />
488− </xs:restriction>
489− </xs:simpleType>
490− <xs:simpleType name="AlphaString_Length1To1">
491− <xs:annotation>
492− <xs:documentation xml:lang="en">Format limitations: a1</xs:documentation>
493− </xs:annotation>
494− <xs:restriction base="xs:string">
495− <xs:minLength value="1" />
496− <xs:maxLength value="1" />
497− </xs:restriction>
498− </xs:simpleType>
499− <xs:simpleType name="NumericInteger_Length1To3">
500− <xs:annotation>
501− <xs:documentation xml:lang="en">Format limitations: n..3</xs:documentation>
502− </xs:annotation>
503− <xs:restriction base="xs:integer">
504− <xs:pattern value="-?[0-9]{1,3}" />
505− </xs:restriction>
506− </xs:simpleType>
507− <xs:simpleType name="AlphaNumericString_Length1To1">
508− <xs:annotation>
509− <xs:documentation xml:lang="en">Format limitations: an1</xs:documentation>
510− </xs:annotation>
511− <xs:restriction base="xs:string">
512− <xs:minLength value="1" />
513− <xs:maxLength value="1" />
514− </xs:restriction>
515− </xs:simpleType>
516− <xs:simpleType name="AlphaNumericString_Length1To10">
517− <xs:annotation>
518− <xs:documentation xml:lang="en">Format limitations: an..10</xs:documentation>
519− </xs:annotation>
520− <xs:restriction base="xs:string">
521− <xs:minLength value="1" />
522− <xs:maxLength value="10" />
523− </xs:restriction>
524− </xs:simpleType>
525− <xs:simpleType name="AlphaNumericString_Length1To12">
526− <xs:annotation>
527− <xs:documentation xml:lang="en">Format limitations: an..12</xs:documentation>
528− </xs:annotation>
529− <xs:restriction base="xs:string">
530− <xs:minLength value="1" />
531− <xs:maxLength value="12" />
532− </xs:restriction>
533− </xs:simpleType>
534− <xs:simpleType name="NumericInteger_Length1To4">
535− <xs:annotation>
536− <xs:documentation xml:lang="en">Format limitations: n..4</xs:documentation>
537− </xs:annotation>
538− <xs:restriction base="xs:integer">
539− <xs:pattern value="-?[0-9]{1,4}" />
540− </xs:restriction>
541− </xs:simpleType>
542− <xs:simpleType name="AlphaNumericString_Length1To20">
543− <xs:annotation>
544− <xs:documentation xml:lang="en">Format limitations: an..20</xs:documentation>
545− </xs:annotation>
546− <xs:restriction base="xs:string">
547− <xs:minLength value="1" />
548− <xs:maxLength value="20" />
549− </xs:restriction>
550− </xs:simpleType>
551− <xs:simpleType name="NumericInteger_Length1To9">
552− <xs:annotation>
553− <xs:documentation xml:lang="en">Format limitations: n..9</xs:documentation>
554− </xs:annotation>
555− <xs:restriction base="xs:integer">
556− <xs:pattern value="-?[0-9]{1,9}" />
557− </xs:restriction>
558− </xs:simpleType>
559− <xs:simpleType name="AlphaNumericString_Length1To9">
560− <xs:annotation>
561− <xs:documentation xml:lang="en">Format limitations: an..9</xs:documentation>
562− </xs:annotation>
563− <xs:restriction base="xs:string">
564− <xs:minLength value="1" />
565− <xs:maxLength value="9" />
566− </xs:restriction>
567− </xs:simpleType>
568− <xs:simpleType name="AlphaNumericString_Length1To18">
569− <xs:annotation>
570− <xs:documentation xml:lang="en">Format limitations: an..18</xs:documentation>
571− </xs:annotation>
572− <xs:restriction base="xs:string">
573− <xs:minLength value="1" />
574− <xs:maxLength value="18" />
575− </xs:restriction>
576− </xs:simpleType>
577− <xs:simpleType name="AMA_EDICodesetType_Length1to2">
578− <xs:annotation>
579− <xs:documentation xml:lang="en">Used for codes in the AMADEUS code tables. Code Length is two alphanumeric characters.</xs:documentation>
580− </xs:annotation>
581− <xs:restriction base="xs:string">
582− <xs:pattern value="[0-9A-Z]{1,2}" />
583− </xs:restriction>
584− </xs:simpleType>
585− <xs:simpleType name="Time24_HHMM">
586− <xs:annotation>
587− <xs:documentation xml:lang="en">Time format: 24H. All digits are mandatory . Example: from 0000 to 2359</xs:documentation>
588− </xs:annotation>
589− <xs:restriction base="xs:string">
590− <xs:pattern value="([0-1][0-9]|2[0-3])[0-5][0-9]" />
591− </xs:restriction>
592− </xs:simpleType>
593−</xs:schema>
594−<!-- SchemaRules="2010/01"-->
595−<!--Created with SchemaBuilder 5.1.0 by Amadeus S.A.S.-->
596−<!--"Amadeus Proprietary and Confidential Information: unauthorized use and disclosure strictly forbidden. 2010 - Amadeus s.a.s - All Rights Reserved."-->
597−<!--Build Key:
598−1F8B080000000000000095534D6FDB4610BDEFAF58E49243218A8A8BA411B007C6A25D0395ED48CC4D8030E68EA44596BBECCED23063F8BF7796A46A1728D0F442CCC7723EDE7B735DDE969BA22A57FBBB5BF5215FFC3A5B2C661F72599DBA401A7A997F5E5EE4CBC52779BDAE7EC9F3659E8B625DC4BE45BA32161D34A838B0FF0264EA2A85B327D2E201086F39472DD4A84E31B6CBF9FCA9B11934A0B1A3ACF6CD5C3C744E5B5C99A0E684311A77A4B9363589FA84F5F72D7F1B503174286AAF919F9072DE25AF69D0B137E59A165C9FDA29D759CB81B60FE6788AEA5D31B693F7C1B7C16084D04B705A5E7A77309A6B18B0F2C61D7C68201AEF96B273D0C5930FE6076AD9110ECFB5A1DA7AEA024A8AC1D4D1F692FF79309A6B649281CBE54C9E9B51061925DF5AB9497390DCF0F4E11175F64E683C4067E37568135C5A1DC0120AEDBB078B5BFCB34357E33DC4FA3465D07DF92930D1BDBE794E04BDEC9F1F31106FC556408B5C862D387287FE451C98BE4D6719339F981CFC81CEE1E764FD4701EB6BB013E4D61F35D3B85AEE7E2F8BD5AED4E60075ACBCB7B42BABFDCA5004172F9929E68F99DBAD217CC7C4F8F88606AE69F7873F722D771C0631FACED95E34188E388131D85706ADA6AD0FF16FF87871E2B90A4A98FE33B662D68D9D94E3FE1744AD372EDE621CE918C416BC8F6F101AFC24E04C8C2B2444295D523ECF17538CAE7C28ACE1DA936293164C8DB46225716F16E58822351062AAFBCD99DAC47E5A24067064077D323E8AB1A6F954B92AD6F3678DD6F01AC0027AC9382BD278FAEDF9B0582ECF3733D6E4C800D570C9C6D5E2896CBCEB62DBC52B6F3506950242CC66EB11C6F724CDEB9DCC66620449DD14E24D7F55DC17FBC284FDE2E2236BBA01E3D4F6A612F8D4325D7BA0FDAABC56D5E65B79A647424050BF5D9C7DB55DDF6FCAAFA2E57B3074628647DC4772D482AD47931863730006060C556ABA413E4E7CE43382B886569C69FAD7E444BC5A5C88BF00DC744BCF06050000
599−-->
600−
test/fixtures/simple.xsddeleted−18
@@ -1,18 +0,0 @@
1−<?xml version="1.0"?>
2−<xs:schema xmlns:xs="http://www.w3.org/2001/XMLSchema"
3−targetNamespace="https://www.w3schools.com"
4−xmlns="https://www.w3schools.com"
5−elementFormDefault="qualified">
6−
7−<xs:element name="note">
8− <xs:complexType>
9− <xs:sequence>
10− <xs:element name="to" type="xs:string"/>
11− <xs:element name="from" type="xs:string"/>
12− <xs:element name="heading" type="xs:string"/>
13− <xs:element name="body" type="xs:string"/>
14− </xs:sequence>
15− </xs:complexType>
16−</xs:element>
17−
18−</xs:schema>
xsd-isogen.cabal → xsd-parser.cabalrenamed+30−21
@@ -1,5 +1,5 @@
1cabal-version: 2.4
1cabal-version: 2.4
2−name: xsd-isogen
2+name: xsd-parser
3
3
4-- The package version. See the Haskell package versioning policy (PVP)
4-- The package version. See the Haskell package versioning policy (PVP)
5-- for standards guiding when and how versions should be incremented.
5-- for standards guiding when and how versions should be incremented.
@@ -8,7 +8,7 @@ name: xsd-isogen
8-- | | +----- non-breaking API additions
8-- | | +----- non-breaking API additions
9-- | | | +--- code changes with no API change
9-- | | | +--- code changes with no API change
10version: 0.1.0.0
10version: 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
12license: BSD-3-Clause
12license: BSD-3-Clause
13license-file: LICENSE
13license-file: LICENSE
14author: Denis Redozubov
14author: Denis Redozubov
@@ -19,27 +19,30 @@ extra-source-files: CHANGELOG.md
19
19
20library
20library
21 -- Modules exported by the library.
21 -- Modules exported by the library.
22− exposed-modules: Text.XSD
22+ exposed-modules: Xsd
23+ , Xsd.Types
23− , Text.XSD.Parser
24+ , Xsd.Parser
24− , Text.XSD.Internal
25−
26− default-extensions: OverloadedStrings
27− , LambdaCase
28− other-extensions: TemplateHaskell
29
25
30 -- Other library packages from which modules are imported.
26 -- Other library packages from which modules are imported.
31− build-depends: base ^>=4.12.0.0
27+ build-depends: base >=4.12 && < 5
32 , bytestring
28 , bytestring
33 , containers
29 , containers
34 , lens >= 4.13
30 , lens >= 4.13
35 , mtl
31 , mtl
36 , text
32 , text
33+ , template-haskell
37 , transformers
34 , transformers
38 , xml-conduit
35 , xml-conduit
39 , writer-cps-mtl
36 , writer-cps-mtl
37+ , uniplate
38+ , network-uri
39+ , http-client
40+ , http-client-tls
41+ , filepath
40
42
41 -- Directories containing source files.
43 -- Directories containing source files.
42 hs-source-dirs: src
44 hs-source-dirs: src
45+ ghc-options: -Wall
43
46
44 -- Base language which the package is written in.
47 -- Base language which the package is written in.
45 default-language: Haskell2010
48 default-language: Haskell2010
@@ -48,20 +51,26 @@ test-suite spec
48 type: exitcode-stdio-1.0
51 type: exitcode-stdio-1.0
49 hs-source-dirs: test
52 hs-source-dirs: test
50 main-is: Main.hs
53 main-is: Main.hs
54+ other-modules: Spec
51 build-depends: base
55 build-depends: base
52 , bytestring
56 , bytestring
57+ , text
53 , hspec
58 , hspec
54 , transformers
59 , transformers
55 , xml-conduit
60 , xml-conduit
56− , 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
57 default-language: Haskell2010
75 default-language: Haskell2010
58− default-extensions: CPP
59− , DeriveGeneric
60− , FlexibleInstances
61− , LambdaCase
62− , OverloadedStrings
63− , StandaloneDeriving
64− , TemplateHaskell
65− , TupleSections
66− , TypeFamilies
67− 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