1949dc2 · typeable/xsd-parser

git.iko.soy/typeable/xsd-parser

on master help sign in

Rework simple type names

1949dc2Denis Redozubov7 years ago

src/Text/XSD/Internal.hs+50−43

compare with master

unifiedsplit

@@ -48,52 +48,52 @@ data ModelGroupSchema

48 | CTAll [Element]

49 deriving (Show, Eq)

51−fromSimpleTypeStr :: Text -> Either String SimpleAtomicType

51+fromSimpleTypeStr :: QName -> Either String SimpleAtomicType

52−fromSimpleTypeStr "anyURI" = Right $ STAnyURI

52+fromSimpleTypeStr (_, "anyURI") = Right $ STAnyURI

53−fromSimpleTypeStr "base64Binary" = Right $ STBase64Binary

53+fromSimpleTypeStr (_, "base64Binary") = Right $ STBase64Binary

54−fromSimpleTypeStr "boolean" = Right $ STBoolean

54+fromSimpleTypeStr (_, "boolean") = Right $ STBoolean

55−fromSimpleTypeStr "date" = Right $ STDate

55+fromSimpleTypeStr (_, "date") = Right $ STDate

56−fromSimpleTypeStr "datetime" = Right $ STDateTime

56+fromSimpleTypeStr (_, "datetime") = Right $ STDateTime

57−fromSimpleTypeStr "dateTimeStamp" = Right $ STDateTimeStamp

57+fromSimpleTypeStr (_, "dateTimeStamp") = Right $ STDateTimeStamp

58−fromSimpleTypeStr "decimal" = Right $ STDecimal DTDecimal

58+fromSimpleTypeStr (_, "decimal") = Right $ STDecimal DTDecimal

59−fromSimpleTypeStr "integer" = Right $ STDecimal DTInteger

59+fromSimpleTypeStr (_, "integer") = Right $ STDecimal DTInteger

60−fromSimpleTypeStr "long" = Right $ STDecimal DTLong

60+fromSimpleTypeStr (_, "long") = Right $ STDecimal DTLong

61−fromSimpleTypeStr "int" = Right $ STDecimal DTInt

61+fromSimpleTypeStr (_, "int") = Right $ STDecimal DTInt

62−fromSimpleTypeStr "short" = Right $ STDecimal DTShort

62+fromSimpleTypeStr (_, "short") = Right $ STDecimal DTShort

63−fromSimpleTypeStr "byte" = Right $ STDecimal DTByte

63+fromSimpleTypeStr (_, "byte") = Right $ STDecimal DTByte

64−fromSimpleTypeStr "nonNegativeInteger" = Right $ STDecimal DTNonNegativeInteger

64+fromSimpleTypeStr (_, "nonNegativeInteger")= Right $ STDecimal DTNonNegativeInteger

65−fromSimpleTypeStr "positiveInteger" = Right $ STDecimal DTPositiveInteger

65+fromSimpleTypeStr (_, "positiveInteger") = Right $ STDecimal DTPositiveInteger

66−fromSimpleTypeStr "unsignedLong" = Right $ STDecimal DTUnsignedLong

66+fromSimpleTypeStr (_, "unsignedLong") = Right $ STDecimal DTUnsignedLong

67−fromSimpleTypeStr "unsignedInt" = Right $ STDecimal DTUnsignedInt

67+fromSimpleTypeStr (_, "unsignedInt") = Right $ STDecimal DTUnsignedInt

68−fromSimpleTypeStr "unsignedShort" = Right $ STDecimal DTUnsignedShort

68+fromSimpleTypeStr (_, "unsignedShort") = Right $ STDecimal DTUnsignedShort

69−fromSimpleTypeStr "unsignedByte" = Right $ STDecimal DTUnsignedByte

69+fromSimpleTypeStr (_, "unsignedByte") = Right $ STDecimal DTUnsignedByte

70−fromSimpleTypeStr "nonPositiveInteger" = Right $ STDecimal DTNonPositiveInteger

70+fromSimpleTypeStr (_, "nonPositiveInteger")= Right $ STDecimal DTNonPositiveInteger

71−fromSimpleTypeStr "negativeInteger" = Right $ STDecimal DTNegativeInteger

71+fromSimpleTypeStr (_, "negativeInteger") = Right $ STDecimal DTNegativeInteger

72−fromSimpleTypeStr "float" = Right $ STFloat

72+fromSimpleTypeStr (_, "float") = Right $ STFloat

73−fromSimpleTypeStr "gDay" = Right $ STGDay

73+fromSimpleTypeStr (_, "gDay") = Right $ STGDay

74−fromSimpleTypeStr "gMonth" = Right $ STGMonth

74+fromSimpleTypeStr (_, "gMonth") = Right $ STGMonth

75−fromSimpleTypeStr "gMonthDay" = Right $ STGMonthDay

75+fromSimpleTypeStr (_, "gMonthDay") = Right $ STGMonthDay

76−fromSimpleTypeStr "gYear" = Right $ STGYear

76+fromSimpleTypeStr (_, "gYear") = Right $ STGYear

77−fromSimpleTypeStr "gYearMonth" = Right $ STGYearMonth

77+fromSimpleTypeStr (_, "gYearMonth") = Right $ STGYearMonth

78−fromSimpleTypeStr "hexBinary" = Right $ STHexBinary

78+fromSimpleTypeStr (_, "hexBinary") = Right $ STHexBinary

79−fromSimpleTypeStr "NOTATION" = Right $ STNOTATION

79+fromSimpleTypeStr (_, "NOTATION") = Right $ STNOTATION

80−fromSimpleTypeStr "QName" = Right $ STQName

80+fromSimpleTypeStr (_, "QName") = Right $ STQName

81−fromSimpleTypeStr "string" = Right $ STString StrString

81+fromSimpleTypeStr (_, "string") = Right $ STString StrString

82−fromSimpleTypeStr "normalizedString" = Right $ STString StrNormalizedString

82+fromSimpleTypeStr (_, "normalizedString") = Right $ STString StrNormalizedString

83−fromSimpleTypeStr "token" = Right $ STString StrToken

83+fromSimpleTypeStr (_, "token") = Right $ STString StrToken

84−fromSimpleTypeStr "language" = Right $ STString StrLanguage

84+fromSimpleTypeStr (_, "language") = Right $ STString StrLanguage

85−fromSimpleTypeStr "Name" = Right $ STString StrName

85+fromSimpleTypeStr (_, "Name") = Right $ STString StrName

86−fromSimpleTypeStr "NCName" = Right $ STString StrNCName

86+fromSimpleTypeStr (_, "NCName") = Right $ STString StrNCName

87−fromSimpleTypeStr "ENTITY" = Right $ STString StrENTITY

87+fromSimpleTypeStr (_, "ENTITY") = Right $ STString StrENTITY

88−fromSimpleTypeStr "ID" = Right $ STString StrID

88+fromSimpleTypeStr (_, "ID") = Right $ STString StrID

89−fromSimpleTypeStr "IDREF" = Right $ STString StrIDREF

89+fromSimpleTypeStr (_, "IDREF") = Right $ STString StrIDREF

90−fromSimpleTypeStr "NMTOKEN" = Right $ STString StrNMTOKEN

90+fromSimpleTypeStr (_, "NMTOKEN") = Right $ STString StrNMTOKEN

91−fromSimpleTypeStr "time" = Right $ STTime

91+fromSimpleTypeStr (_, "time") = Right $ STTime

92−fromSimpleTypeStr t = Left $ "unsupported type: " <> T.unpack t

92+fromSimpleTypeStr (_, t) = Left $ "unsupported type: " <> T.unpack t

94-- | ENTITIES, IDREFS and NMTOKENS are not supported right now.

95data SimpleType

96− = STAtomic SimpleAtomicType [Restriction]

96+ = STAtomic Text SimpleAtomicType [Restriction]

97 -- STUnion [SimpleType] -- special - xs:union

98 -- STList [SimpleType] -- special - xs:list

99 deriving (Show, Eq)

@@ -163,6 +163,13 @@ type Namespace = Text

163

164type QName = (Maybe Namespace, LocalName)

165

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+

166-- | Based on https://www.w3.org/TR/xmlschema11-1/#concepts-data-model

173-- | Based on https://www.w3.org/TR/xmlschema11-1/#concepts-data-model

167-- Secondary and helper schema components are not supported right now.

174-- Secondary and helper schema components are not supported right now.

168-- data SchemaComponent

175-- data SchemaComponent

src/Text/XSD/Parser.hs+14−7

@@ -46,12 +46,15 @@ attrThrowXsd name elNode = maybeThrowXsd (M.lookup name $ elementAttributes elNo

46toElemsAndDatatypes :: XML.Cursor -> XSDMonad [XSD.Element]

47toElemsAndDatatypes cursor = do

48 elems <- traverse toElem (cursor $/ laxElement "element")

49− datatypes <- traverse toComplexType (cursor $/ laxElement "complexType")

49+ complexDatatypes <- traverse toComplexType (cursor $/ laxElement "complexType")

50− for_ datatypes $ \case

50+ for_ complexDatatypes $ \case

51 datatype@(ComplexType (Just name) _ _) ->

52 tell (M.singleton name (TypeComplex datatype))

53 datatype@(ComplexType Nothing _ _) ->

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

55 pure elems

58 pure elems

57safeHead :: [a] -> Maybe a

60safeHead :: [a] -> Maybe a

@@ -105,6 +108,9 @@ toElem cursor = do

105

108

106toSimpleType :: Cursor -> XSDMonad SimpleType

109toSimpleType :: Cursor -> XSDMonad SimpleType

107toSimpleType cursor = do

110toSimpleType cursor = do

111+ name <- maybeThrowXsd

112+ (safeHead $ cursor $| attribute "name")

113+ $ "More than one \"name\" attribute in simpleType declaration"

108 let restrictionAxis = laxElement "restriction"

114 let restrictionAxis = laxElement "restriction"

109 if P.null (cursor $// restrictionAxis)

115 if P.null (cursor $// restrictionAxis)

110 then throwXsd $ "unsupported simpleType element: " <> show cursor

116 then throwXsd $ "unsupported simpleType element: " <> show cursor

@@ -116,10 +122,10 @@ toSimpleType cursor = do

116 let

122 let

117 enumValues = childCursor $// laxElement "enumeration" &/ attribute "value"

123 enumValues = childCursor $// laxElement "enumeration" &/ attribute "value"

118 -- only enumeration is supported now

124 -- only enumeration is supported now

119− case fromSimpleTypeStr baseType of

125+ case fromSimpleTypeStr $ toQName baseType of

120 Left e -> throwXsd e

126 Left e -> throwXsd e

121 Right simpleAtomicType ->

127 Right simpleAtomicType ->

122− pure $ STAtomic simpleAtomicType

128+ pure $ STAtomic name simpleAtomicType

123 $ if P.null enumValues then [] else [Enumeration enumValues]

129 $ if P.null enumValues then [] else [Enumeration enumValues]

124

130

125-- | Takes a cursor to the 'xs:complexType' element.

131-- | Takes a cursor to the 'xs:complexType' element.

@@ -159,9 +165,10 @@ toAttribute cursor = do

159 $ "No name attribute found in child <attribute> of: "

165 $ "No name attribute found in child <attribute> of: "

160 <> show (cursor $| ancestor <=< ancestor)

166 <> show (cursor $| ancestor <=< ancestor)

161 simpleType <- case safeHead $ cursor $| attribute "type" of

167 simpleType <- case safeHead $ cursor $| attribute "type" of

168+ Just simpleAtomicType ->

162− Just simpleAtomicType -> case fromSimpleTypeStr simpleAtomicType of

169+ case fromSimpleTypeStr $ toQName simpleAtomicType of

163− Left e -> throwXsd e

170+ Left e -> throwXsd e

164− Right simpleAtomicType -> pure $ STAtomic simpleAtomicType []

171+ Right simpleAtomicType -> pure $ STAtomic name simpleAtomicType []

165 Nothing -> do

172 Nothing -> do

166 let simpleTypeCursor = safeHead $ cursor $// laxElement "simpleType"

173 let simpleTypeCursor = safeHead $ cursor $// laxElement "simpleType"

167 case simpleTypeCursor of

174 case simpleTypeCursor of

xsd-parser.cabal+1−1

@@ -18,7 +18,7 @@ extra-source-files: CHANGELOG.md

20library

21− ghc-options: -Werror

21+ -- ghc-options: -Werror

22 -- Modules exported by the library.

23 exposed-modules: Text.XSD

24 , Text.XSD.Parser