git.iko.soy/typeable/xsd-parser
on master help sign in
separate toDatatype to toComplexType and toSimpleType
88420dbDenis Redozubov
src/Text/XSD/Internal.hs+11−4
compare with master
unifiedsplit
@@ -11,8 +11,11 @@ import Data.Map as M
11-- | Roughly based on https://www.w3.org/TR/xmlschema11-2/#built-in-datatypes
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
12-- | and https://www.w3.org/TR/xmlschema11-1/#dcl.ctd.ctsc
13data Datatype
13data Datatype
14+ = TypeComplex ComplexType
15+ | TypeSimple SimpleType
16+ deriving (Show, Eq)
17+
14− = ComplexType (Maybe Text) ModelGroupSchema [Element]
18+data ComplexType = ComplexType (Maybe Text) ModelGroupSchema [Element]
15− | SimpleType SimpleType
16 deriving (Show, Eq)
19 deriving (Show, Eq)
17
20
18data DatatypeRef
21data DatatypeRef
@@ -29,6 +32,12 @@ data ModelGroupSchema
29
32
30-- | ENTITIES, IDREFS and NMTOKENS are not supported right now.
33-- | ENTITIES, IDREFS and NMTOKENS are not supported right now.
31data SimpleType
34data SimpleType
35+ = STAtomic SimpleAtomicType
36+ | STUnion [SimpleType] -- special - xs:union
37+ | STList [SimpleType] -- special - xs:list
38+ deriving (Show, Eq)
39+
40+data SimpleAtomicType
32 = STAnyURI
41 = STAnyURI
33 | STBase64Binary
42 | STBase64Binary
34 | STBoolean
43 | STBoolean
@@ -48,8 +57,6 @@ data SimpleType
48 | STQName QName
57 | STQName QName
49 | STString StringType
58 | STString StringType
50 | STTime
59 | STTime
51− | STUnion [SimpleType] -- special - xs:union
52− | STList [SimpleType] -- special - xs:list
53 deriving (Show, Eq)
60 deriving (Show, Eq)
54
61
55data StringType
62data StringType
src/Text/XSD/Parser.hs+38−33
@@ -73,9 +73,9 @@ attrThrowXsd name elNode = maybeThrowXsd (M.lookup name $ elementAttributes elNo
73toElemsAndDatatypes :: XML.Cursor -> XSDMonad [XSD.Element]
73toElemsAndDatatypes :: XML.Cursor -> XSDMonad [XSD.Element]
74toElemsAndDatatypes cursor = do
74toElemsAndDatatypes cursor = do
75 elems <- traverse toElem (cursor $/ laxElement "element")
75 elems <- traverse toElem (cursor $/ laxElement "element")
76− datatypes <- traverse toDatatype (cursor $/ laxElement "complexType")
76+ datatypes <- traverse toComplexType (cursor $/ laxElement "complexType")
77 for_ datatypes $ \case
77 for_ datatypes $ \case
78− datatype@(ComplexType (Just name) _ _) -> tell (M.singleton name datatype)
78+ datatype@(ComplexType (Just name) _ _) -> tell (M.singleton name (TypeComplex datatype))
79 datatype@(ComplexType Nothing _ _) ->
79 datatype@(ComplexType Nothing _ _) ->
80 throwXsd $ "unnamed type ref for datatype: " <> show datatype
80 throwXsd $ "unnamed type ref for datatype: " <> show datatype
81 pure elems
81 pure elems
@@ -116,44 +116,49 @@ toElem cursor = do
116 e ->
116 e ->
117 throwXsd $ "[toElem] element expected, got: " <> show e
117 throwXsd $ "[toElem] element expected, got: " <> show e
118
118
119−-- | Returns 'Just element' if encounters an element,
120toDatatype :: Cursor -> XSDMonad Datatype
119toDatatype :: Cursor -> XSDMonad Datatype
121toDatatype cursor = do
120toDatatype cursor = do
122 case node cursor of
121 case node cursor of
123 NodeElement el -> case nameLocalName (elementName el) of
122 NodeElement el -> case nameLocalName (elementName el) of
124− "simpleType" -> do
123+ "simpleType" -> TypeSimple <$> toSimpleType cursor
125− error "implement simpleType"
124+ "complexType" -> TypeComplex <$> toComplexType cursor
126− "complexType" -> do
127− let sequenceAxis = laxElement "sequence"
128− let choiceAxis = laxElement "choice"
129− let allAxis = laxElement "all"
130− if P.null (cursor $// sequenceAxis)
131− then if P.null (cursor $// choiceAxis)
132− then if P.null (cursor $// allAxis)
133− then throwXsd $ "No definition found for complexType: "
134− <> show (safeHead $ cursor $// laxElement "complexType")
135− else do
136− childCursor <- maybeThrowXsd (safeHead $ cursor $// allAxis)
137− $ "More than one xs:all tag in: "
138− <> show (cursor $// laxElement "complexType")
139− let name = safeHead $ cursor $| attribute "name"
140− ComplexType name CTAll <$> toElemsAndDatatypes childCursor
141− else do
142− childCursor <- maybeThrowXsd (safeHead $ cursor $// choiceAxis)
143− $ "More than one xs:choice tag in: "
144− <> show (cursor $// laxElement "complexType")
145− let name = safeHead $ cursor $| attribute "name"
146− ComplexType name CTChoice <$> toElemsAndDatatypes childCursor
147− else do
148− childCursor <- maybeThrowXsd (safeHead $ cursor $// sequenceAxis)
149− $ "More than one xs:sequence tag in: "
150− <> show (cursor $// laxElement "complexType")
151− let name = safeHead $ cursor $| attribute "name"
152− ComplexType name CTSequence <$> toElemsAndDatatypes childCursor
153− e -> throwXsd $ "[toDatatype] xsd node not supported: " <> show e
125+ e -> throwXsd $ "[toDatatype] xsd node not supported: " <> show e
154 e ->
126 e ->
155 throwXsd $ "[toDatatype] element expected, got: " <> show e
127 throwXsd $ "[toDatatype] element expected, got: " <> show e
156
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+
157toXsd :: Document -> Either SomeException XSD
162toXsd :: Document -> Either SomeException XSD
158toXsd doc = do
163toXsd doc = do
159 (el, dt) <- runWriterT $ toSchema (fromDocument doc)
164 (el, dt) <- runWriterT $ toSchema (fromDocument doc)