git.iko.soy/typeable/xsd-parser
on master help sign in
Rework simple type names
commit1949dc25eb5e4cd179fbb1addc64bcc194f85f4f authorDenis Redozubov <denis.redozubov@gmail.com> dateMon 21 Oct 2019, 15:33 (7 years ago) parent5e8b37c
3 files changed+65−51
compare with master
unifiedsplit
src/Text/XSD/Internal.hs+50−43 src/Text/XSD/Parser.hs+14−7 xsd-parser.cabal+1−1
src/Text/XSD/Internal.hs+50−43
@@ -48,52 +48,52 @@ data ModelGroupSchema
4848 | CTAll [Element]
4949 deriving (Show, Eq)
5050
51−fromSimpleTypeStr :: Text -> Either String SimpleAtomicType
52−fromSimpleTypeStr "anyURI" = Right $ STAnyURI
53−fromSimpleTypeStr "base64Binary" = Right $ STBase64Binary
54−fromSimpleTypeStr "boolean" = Right $ STBoolean
55−fromSimpleTypeStr "date" = Right $ STDate
56−fromSimpleTypeStr "datetime" = Right $ STDateTime
57−fromSimpleTypeStr "dateTimeStamp" = Right $ STDateTimeStamp
58−fromSimpleTypeStr "decimal" = Right $ STDecimal DTDecimal
59−fromSimpleTypeStr "integer" = Right $ STDecimal DTInteger
60−fromSimpleTypeStr "long" = Right $ STDecimal DTLong
61−fromSimpleTypeStr "int" = Right $ STDecimal DTInt
62−fromSimpleTypeStr "short" = Right $ STDecimal DTShort
63−fromSimpleTypeStr "byte" = Right $ STDecimal DTByte
64−fromSimpleTypeStr "nonNegativeInteger" = Right $ STDecimal DTNonNegativeInteger
65−fromSimpleTypeStr "positiveInteger" = Right $ STDecimal DTPositiveInteger
66−fromSimpleTypeStr "unsignedLong" = Right $ STDecimal DTUnsignedLong
67−fromSimpleTypeStr "unsignedInt" = Right $ STDecimal DTUnsignedInt
68−fromSimpleTypeStr "unsignedShort" = Right $ STDecimal DTUnsignedShort
69−fromSimpleTypeStr "unsignedByte" = Right $ STDecimal DTUnsignedByte
70−fromSimpleTypeStr "nonPositiveInteger" = Right $ STDecimal DTNonPositiveInteger
71−fromSimpleTypeStr "negativeInteger" = Right $ STDecimal DTNegativeInteger
72−fromSimpleTypeStr "float" = Right $ STFloat
73−fromSimpleTypeStr "gDay" = Right $ STGDay
74−fromSimpleTypeStr "gMonth" = Right $ STGMonth
75−fromSimpleTypeStr "gMonthDay" = Right $ STGMonthDay
76−fromSimpleTypeStr "gYear" = Right $ STGYear
77−fromSimpleTypeStr "gYearMonth" = Right $ STGYearMonth
78−fromSimpleTypeStr "hexBinary" = Right $ STHexBinary
79−fromSimpleTypeStr "NOTATION" = Right $ STNOTATION
80−fromSimpleTypeStr "QName" = Right $ STQName
81−fromSimpleTypeStr "string" = Right $ STString StrString
82−fromSimpleTypeStr "normalizedString" = Right $ STString StrNormalizedString
83−fromSimpleTypeStr "token" = Right $ STString StrToken
84−fromSimpleTypeStr "language" = Right $ STString StrLanguage
85−fromSimpleTypeStr "Name" = Right $ STString StrName
86−fromSimpleTypeStr "NCName" = Right $ STString StrNCName
87−fromSimpleTypeStr "ENTITY" = Right $ STString StrENTITY
88−fromSimpleTypeStr "ID" = Right $ STString StrID
89−fromSimpleTypeStr "IDREF" = Right $ STString StrIDREF
90−fromSimpleTypeStr "NMTOKEN" = Right $ STString StrNMTOKEN
91−fromSimpleTypeStr "time" = Right $ STTime
92−fromSimpleTypeStr t = Left $ "unsupported type: " <> T.unpack t
51+fromSimpleTypeStr :: QName -> Either String SimpleAtomicType
52+fromSimpleTypeStr (_, "anyURI") = Right $ STAnyURI
53+fromSimpleTypeStr (_, "base64Binary") = Right $ STBase64Binary
54+fromSimpleTypeStr (_, "boolean") = Right $ STBoolean
55+fromSimpleTypeStr (_, "date") = Right $ STDate
56+fromSimpleTypeStr (_, "datetime") = Right $ STDateTime
57+fromSimpleTypeStr (_, "dateTimeStamp") = Right $ STDateTimeStamp
58+fromSimpleTypeStr (_, "decimal") = Right $ STDecimal DTDecimal
59+fromSimpleTypeStr (_, "integer") = Right $ STDecimal DTInteger
60+fromSimpleTypeStr (_, "long") = Right $ STDecimal DTLong
61+fromSimpleTypeStr (_, "int") = Right $ STDecimal DTInt
62+fromSimpleTypeStr (_, "short") = Right $ STDecimal DTShort
63+fromSimpleTypeStr (_, "byte") = Right $ STDecimal DTByte
64+fromSimpleTypeStr (_, "nonNegativeInteger")= Right $ STDecimal DTNonNegativeInteger
65+fromSimpleTypeStr (_, "positiveInteger") = Right $ STDecimal DTPositiveInteger
66+fromSimpleTypeStr (_, "unsignedLong") = Right $ STDecimal DTUnsignedLong
67+fromSimpleTypeStr (_, "unsignedInt") = Right $ STDecimal DTUnsignedInt
68+fromSimpleTypeStr (_, "unsignedShort") = Right $ STDecimal DTUnsignedShort
69+fromSimpleTypeStr (_, "unsignedByte") = Right $ STDecimal DTUnsignedByte
70+fromSimpleTypeStr (_, "nonPositiveInteger")= Right $ STDecimal DTNonPositiveInteger
71+fromSimpleTypeStr (_, "negativeInteger") = Right $ STDecimal DTNegativeInteger
72+fromSimpleTypeStr (_, "float") = Right $ STFloat
73+fromSimpleTypeStr (_, "gDay") = Right $ STGDay
74+fromSimpleTypeStr (_, "gMonth") = Right $ STGMonth
75+fromSimpleTypeStr (_, "gMonthDay") = Right $ STGMonthDay
76+fromSimpleTypeStr (_, "gYear") = Right $ STGYear
77+fromSimpleTypeStr (_, "gYearMonth") = Right $ STGYearMonth
78+fromSimpleTypeStr (_, "hexBinary") = Right $ STHexBinary
79+fromSimpleTypeStr (_, "NOTATION") = Right $ STNOTATION
80+fromSimpleTypeStr (_, "QName") = Right $ STQName
81+fromSimpleTypeStr (_, "string") = Right $ STString StrString
82+fromSimpleTypeStr (_, "normalizedString") = Right $ STString StrNormalizedString
83+fromSimpleTypeStr (_, "token") = Right $ STString StrToken
84+fromSimpleTypeStr (_, "language") = Right $ STString StrLanguage
85+fromSimpleTypeStr (_, "Name") = Right $ STString StrName
86+fromSimpleTypeStr (_, "NCName") = Right $ STString StrNCName
87+fromSimpleTypeStr (_, "ENTITY") = Right $ STString StrENTITY
88+fromSimpleTypeStr (_, "ID") = Right $ STString StrID
89+fromSimpleTypeStr (_, "IDREF") = Right $ STString StrIDREF
90+fromSimpleTypeStr (_, "NMTOKEN") = Right $ STString StrNMTOKEN
91+fromSimpleTypeStr (_, "time") = Right $ STTime
92+fromSimpleTypeStr (_, t) = Left $ "unsupported type: " <> T.unpack t
9393
9494-- | ENTITIES, IDREFS and NMTOKENS are not supported right now.
9595data SimpleType
96− = STAtomic SimpleAtomicType [Restriction]
96+ = STAtomic Text SimpleAtomicType [Restriction]
9797 -- STUnion [SimpleType] -- special - xs:union
9898 -- STList [SimpleType] -- special - xs:list
9999 deriving (Show, Eq)
@@ -163,6 +163,13 @@ type Namespace = Text
163163
164164type QName = (Maybe Namespace, LocalName)
165165
166+toQName :: Text -> QName
167+toQName n =
168+ let splitName@(f:l) = T.split (==':') n
169+ in if Prelude.length splitName == 1
170+ then (Nothing, f)
171+ else (Just f, Prelude.head l)
172+
166173-- | Based on https://www.w3.org/TR/xmlschema11-1/#concepts-data-model
167174-- Secondary and helper schema components are not supported right now.
168175-- data SchemaComponent
src/Text/XSD/Parser.hs+14−7
@@ -46,12 +46,15 @@ attrThrowXsd name elNode = maybeThrowXsd (M.lookup name $ elementAttributes elNo
4646toElemsAndDatatypes :: XML.Cursor -> XSDMonad [XSD.Element]
4747toElemsAndDatatypes cursor = do
4848 elems <- traverse toElem (cursor $/ laxElement "element")
49− datatypes <- traverse toComplexType (cursor $/ laxElement "complexType")
50− for_ datatypes $ \case
49+ complexDatatypes <- traverse toComplexType (cursor $/ laxElement "complexType")
50+ for_ complexDatatypes $ \case
5151 datatype@(ComplexType (Just name) _ _) ->
5252 tell (M.singleton name (TypeComplex datatype))
5353 datatype@(ComplexType Nothing _ _) ->
5454 throwXsd $ "unnamed type ref for datatype: " <> show datatype
55+ simpleTypes <- traverse toSimpleType (cursor $/ laxElement "simpleType")
56+ for_ simpleTypes $ \simpleType@(STAtomic name _ _) ->
57+ tell (M.singleton name (TypeSimple simpleType))
5558 pure elems
5659
5760safeHead :: [a] -> Maybe a
@@ -105,6 +108,9 @@ toElem cursor = do
105108
106109toSimpleType :: Cursor -> XSDMonad SimpleType
107110toSimpleType cursor = do
111+ name <- maybeThrowXsd
112+ (safeHead $ cursor $| attribute "name")
113+ $ "More than one \"name\" attribute in simpleType declaration"
108114 let restrictionAxis = laxElement "restriction"
109115 if P.null (cursor $// restrictionAxis)
110116 then throwXsd $ "unsupported simpleType element: " <> show cursor
@@ -116,10 +122,10 @@ toSimpleType cursor = do
116122 let
117123 enumValues = childCursor $// laxElement "enumeration" &/ attribute "value"
118124 -- only enumeration is supported now
119− case fromSimpleTypeStr baseType of
125+ case fromSimpleTypeStr $ toQName baseType of
120126 Left e -> throwXsd e
121127 Right simpleAtomicType ->
122− pure $ STAtomic simpleAtomicType
128+ pure $ STAtomic name simpleAtomicType
123129 $ if P.null enumValues then [] else [Enumeration enumValues]
124130
125131-- | Takes a cursor to the 'xs:complexType' element.
@@ -159,9 +165,10 @@ toAttribute cursor = do
159165 $ "No name attribute found in child <attribute> of: "
160166 <> show (cursor $| ancestor <=< ancestor)
161167 simpleType <- case safeHead $ cursor $| attribute "type" of
162− Just simpleAtomicType -> case fromSimpleTypeStr simpleAtomicType of
163− Left e -> throwXsd e
164− Right simpleAtomicType -> pure $ STAtomic simpleAtomicType []
168+ Just simpleAtomicType ->
169+ case fromSimpleTypeStr $ toQName simpleAtomicType of
170+ Left e -> throwXsd e
171+ Right simpleAtomicType -> pure $ STAtomic name simpleAtomicType []
165172 Nothing -> do
166173 let simpleTypeCursor = safeHead $ cursor $// laxElement "simpleType"
167174 case simpleTypeCursor of
xsd-parser.cabal+1−1
@@ -18,7 +18,7 @@ extra-source-files: CHANGELOG.md
1818
1919
2020library
21− ghc-options: -Werror
21+ -- ghc-options: -Werror
2222 -- Modules exported by the library.
2323 exposed-modules: Text.XSD
2424 , Text.XSD.Parser