7863254 · typeable/xsd-isogen

git.iko.soy/typeable/xsd-isogen

on master help sign in

Generate extensions for complex types (#12)

7863254Yuras7 years ago

cabal.project+1−1

compare with master

unifiedsplit

@@ -3,4 +3,4 @@ packages: .

3source-repository-package

4 type: git

5 location: https://github.com/typeable/xsd-parser.git

6− tag: f9cbe65a9b9c37e9015a73707f1cd4f00e79c96e

6+ tag: 2ec49b8f0c560fdc411850d71b8724be1526e798

src/BuiltInTypes.hs+11−3

@@ -5,13 +5,14 @@ module BuiltInTypes

6where

8−import Data.Text (Text)

9import Data.Map (Map)

8import Data.Map (Map)

10import qualified Data.Map as Map

9import qualified Data.Map as Map

12import qualified Xsd

11import qualified Xsd

13+import Gen

14+

14−builtInTypes :: Map Xsd.QName Text

15+builtInTypes :: Map Xsd.QName TypeName

15builtInTypes = Map.fromList . map qualify $

16builtInTypes = Map.fromList . map qualify $

16 [ ("anyURI", "Text")

17 [ ("anyURI", "Text")

17 , ("base64Binary", "ByteString")

18 , ("base64Binary", "ByteString")

@@ -56,4 +57,11 @@ builtInTypes = Map.fromList . map qualify $

56 ]

57 ]

57 where

58 where

58 qualify (n, t) =

59 qualify (n, t) =

60+ let

61+ tn = TypeName

62+ { tnName = t

63+ , tnPrefixed = t

64+ , tnQName = qname

65+ }

59− ( Xsd.QName (Just (Xsd.Namespace Xsd.schemaNamespace)) n, t)

66+ qname = Xsd.QName (Just (Xsd.Namespace Xsd.schemaNamespace)) n

67+ in (qname, tn)

src/Gen.hs+29−14

@@ -13,6 +13,7 @@ module Gen

13, resolveType

14, resolveTypeName

15, knownTypeName

16+, extensions

16, makeTypeName

17, makeTypeName

17, makeFieldName

18, makeFieldName

18, makeEnumName

19, makeEnumName

@@ -38,7 +39,9 @@ import Options (GenType(..))

38data GenState = GenState

39data GenState = GenState

39 { gsTypes :: Map Xsd.QName Xsd.Type

40 { gsTypes :: Map Xsd.QName Xsd.Type

40 -- ^ All global types

41 -- ^ All global types

42+ , gsExtensions :: Map Xsd.QName [(Xsd.QName, Xsd.Type)]

43+ -- ^ Lift of extension of the specified type

41− , gsKnownTypes :: Map Xsd.QName Text

44+ , gsKnownTypes :: Map Xsd.QName TypeName

42 -- ^ Global types that were already processed and their generated names

45 -- ^ Global types that were already processed and their generated names

43 , gsBoundTypeName :: Set Text

46 , gsBoundTypeName :: Set Text

44 -- ^ prefixed names that were already used

47 -- ^ prefixed names that were already used

@@ -106,15 +109,17 @@ makeTypeName name tp = go Nothing

106 if bound || duplicateFields

109 if bound || duplicateFields

107 then go next

110 then go next

108 else do

111 else do

112+ let

113+ tn = TypeName

114+ { tnName = typeName

115+ , tnPrefixed = prefixed

116+ , tnQName = name

117+ }

109 Gen $ modify' $ \s -> s

118 Gen $ modify' $ \s -> s

110− { gsKnownTypes = Map.insert name prefixed (gsKnownTypes s)

119+ { gsKnownTypes = Map.insert name tn (gsKnownTypes s)

111 , gsBoundTypeName = Set.insert prefixed (gsBoundTypeName s)

120 , gsBoundTypeName = Set.insert prefixed (gsBoundTypeName s)

112 }

121 }

113− return TypeName

122+ return tn

114− { tnName = typeName

115− , tnPrefixed = prefixed

116− , tnQName = name

117− }

118

123

119makeFieldName :: TypeName -> Xsd.QName -> Gen Text

124makeFieldName :: TypeName -> Xsd.QName -> Gen Text

120makeFieldName typeName name = do

125makeFieldName typeName name = do

@@ -147,11 +152,18 @@ hasDuplicateFields typeName tp = do

147-- | Get all fields from the type

152-- | Get all fields from the type

148allFields :: Xsd.Type -> [Xsd.QName]

153allFields :: Xsd.Type -> [Xsd.QName]

149allFields (Xsd.TypeSimple _) = []

154allFields (Xsd.TypeSimple _) = []

150−allFields (Xsd.TypeComplex t) = do

155+allFields (Xsd.TypeComplex t) =

151− case Xsd.complexModelGroup t of

156+ case Xsd.complexContent t of

152− Nothing -> []

157+ Xsd.ContentPlain c ->

158+ case Xsd.plainContentModel c of

159+ Just (Xsd.Sequence es) -> map Xsd.elementName es

160+ _ -> []

161+ Xsd.ContentSimple _ -> []

162+ Xsd.ContentComplex (Xsd.ComplexContentExtension e) ->

163+ case Xsd.complexExtensionModel e of

153− Just (Xsd.Sequence es) -> map Xsd.elementName es

164+ Just (Xsd.Sequence es) -> map Xsd.elementName es

154− _ -> []

165+ _ -> []

166+ Xsd.ContentComplex Xsd.ComplexContentRestriction -> []

155

167

156-- | Prefix field name with based on the type name

168-- | Prefix field name with based on the type name

157makePrefixedField :: Text -> Xsd.QName -> Text

169makePrefixedField :: Text -> Xsd.QName -> Text

@@ -165,9 +177,12 @@ makePrefixedField typeName field = prefix <> Xsd.qnName field

165-- | Get generated name for the type name

177-- | Get generated name for the type name

166--

178--

167-- Returns Nothing if the type was not generated yet

179-- Returns Nothing if the type was not generated yet

168−knownTypeName :: Xsd.QName -> Gen (Maybe Text)

180+knownTypeName :: Xsd.QName -> Gen (Maybe TypeName)

169knownTypeName name = Gen $ gets (Map.lookup name . gsKnownTypes)

181knownTypeName name = Gen $ gets (Map.lookup name . gsKnownTypes)

170

182

183+extensions :: Xsd.QName -> Gen [(Xsd.QName, Xsd.Type)]

184+extensions base = Gen $ gets (Map.findWithDefault [] base . gsExtensions)

185+

171-- | Returns type for the reference

186-- | Returns type for the reference

172resolveType :: Xsd.QName -> Gen Xsd.Type

187resolveType :: Xsd.QName -> Gen Xsd.Type

173resolveType name = do

188resolveType name = do

@@ -179,7 +194,7 @@ resolveType name = do

179-- | Returns type type for the reference

194-- | Returns type type for the reference

180--

195--

181-- It should already be generated

196-- It should already be generated

182−resolveTypeName :: Xsd.QName -> Gen Text

197+resolveTypeName :: Xsd.QName -> Gen TypeName

183resolveTypeName name = knownTypeName name

198resolveTypeName name = knownTypeName name

184 >>= maybe (genError ("unresolved type: " <> show name)) return

199 >>= maybe (genError ("unresolved type: " <> show name)) return

185

200

src/Main.hs+163−26

@@ -9,6 +9,7 @@ import Data.Text (Text)

9import qualified Data.Text as Text

10import qualified Data.Text.IO as Text

11import Data.Maybe

12+import qualified Data.List as List

12import qualified Data.Set as Set

13import qualified Data.Set as Set

13import Data.Map (Map)

14import Data.Map (Map)

14import qualified Data.Map as Map

15import qualified Data.Map as Map

@@ -37,21 +38,27 @@ data Result = Result

38generate :: Options -> Xsd.Schema -> Either String Result

39generate :: Options -> Xsd.Schema -> Either String Result

39generate opts schema = do

40generate opts schema = do

41+ let

42+ types = Map.union (Xsd.schemaTypes schema)

43+ (elementsToTypes (Xsd.schemaElements schema))

40− s <- runGen (initialGenState opts schema) $ do

44+ s <- runGen (initialGenState opts types) $ do

41 genHeader opts

45 genHeader opts

42− genTypes (Xsd.schemaTypes schema)

46+ genTypes types

43− genElements (Xsd.schemaElements schema)

44 Right Result

47 Right Result

45 { resultCode = Text.unlines (reverse (gsCode s))

48 { resultCode = Text.unlines (reverse (gsCode s))

46 , resultWarnings = reverse (gsWarnings s)

49 , resultWarnings = reverse (gsWarnings s)

47 }

50 }

52+elementsToTypes :: Map Xsd.QName Xsd.Element -> Map Xsd.QName Xsd.Type

53+elementsToTypes = List.foldl' step Map.empty . Map.toList

54+ where

55+ step types (_, e) = case Xsd.elementType e of

56+ Xsd.Ref _ -> types

57+ Xsd.Inline t -> Map.insert (Xsd.elementName e) t types

58+

49genTypes :: Map Xsd.QName Xsd.Type -> Gen ()

59genTypes :: Map Xsd.QName Xsd.Type -> Gen ()

50genTypes types = mapM_ (uncurry genTopType) . Map.toList $ types

60genTypes types = mapM_ (uncurry genTopType) . Map.toList $ types

52−genElements :: Map Xsd.QName Xsd.Element -> Gen ()

53−genElements = mapM_ genElement

54−

55genTopType :: Xsd.QName -> Xsd.Type -> Gen ()

62genTopType :: Xsd.QName -> Xsd.Type -> Gen ()

56genTopType = genType []

63genTopType = genType []

@@ -69,6 +76,105 @@ genType annotations name tp = do

69 case tp of

76 case tp of

70 Xsd.TypeSimple t -> genSimpleType typeName t annotations

77 Xsd.TypeSimple t -> genSimpleType typeName t annotations

71 Xsd.TypeComplex t -> genComplexType typeName t annotations

78 Xsd.TypeComplex t -> genComplexType typeName t annotations

79+ genExtension name

80+

81+genExtension :: Xsd.QName -> Gen ()

82+genExtension base = do

83+ exts <- extensions base

84+ case exts of

85+ [] -> return ()

86+ types -> do

87+ mapM_ (uncurry genTopType) types

88+ baseTypeName <- tnPrefixed <$> resolveTypeName base

89+ writeCode

90+ [ "data Any" <> baseTypeName

91+ , " = The" <> baseTypeName <> " !" <> baseTypeName

92+ ]

93+ let

94+ mkConstructor (n, _) = do

95+ tn <- tnPrefixed <$> resolveTypeName n

96+ exts' <- extensions n

97+ let

98+ n' = case exts' of

99+ [] -> tn

100+ _ -> "Any" <> tn

101+ return (" | The" <> n' <> " !" <> n')

102+ constructors <- mapM mkConstructor types

103+ writeCode constructors

104+ writeCode

105+ [ " deriving (Eq, Show)"

106+ , ""

107+ ]

108+ writeCode

109+ [ "instance NFData Any" <> baseTypeName <> " where"

110+ , " rnf = rwhnf"

111+ , " "

112+ ]

113+ mode <- getMode

114+ unless (mode == Generator) $ do

115+ writeCode

116+ [ "instance FromDom Any" <> baseTypeName <> " where"

117+ , " fromDom = do"

118+ , " tp <- parseAttribute"

119+ , " (matchName " <>

120+ "\"{http://www.w3.org/2001/XMLSchema-instance}type\")"

121+ , " Right"

122+ , " case tp of"

123+ ]

124+ let

125+ mkClause n = do

126+ tn <- resolveTypeName n

127+ exts' <- extensions n

128+ n' <- case exts' of

129+ [] -> return (tnPrefixed tn)

130+ _ | n == base -> return (tnPrefixed tn)

131+ _ -> return ("Any" <> tnPrefixed tn)

132+ return $ mconcat

133+ [ " \""

134+ , tnName tn

135+ , "\" -> The"

136+ , n'

137+ , " <$> fromDom"

138+ ]

139+ clauses <- mapM mkClause (base : map fst types)

140+ writeCode clauses

141+ writeCode [""]

142+ unless (mode == Parser) $ do

143+ writeCode

144+ [ "instance ToXML Any" <> baseTypeName <> " where"

145+ , " toXML (The" <> baseTypeName <> " a) = toXML a"

146+ ]

147+ let

148+ mkClause (n, _) = do

149+ tn <- tnPrefixed <$> resolveTypeName n

150+ exts' <- extensions n

151+ let

152+ n' = case exts' of

153+ [] -> tn

154+ _ -> "Any" <> tn

155+ return (" toXML (The" <> n' <> " a) = toXML a")

156+ clauses <- mapM mkClause types

157+ writeCode clauses

158+ writeCode [""]

159+ writeCode

160+ [ "instance ToXmlParentAttributes Any" <> baseTypeName <> " where"

161+ ]

162+ let

163+ toAttrLine n = do

164+ tn <- resolveTypeName n

165+ exts' <- extensions n

166+ n' <- case exts' of

167+ [] -> return (tnPrefixed tn)

168+ _ | n == base -> return (tnPrefixed tn)

169+ _ -> return ("Any" <> tnPrefixed tn)

170+ return

171+ [ " toXmlParentAttributes (The" <> n' <> " a) ="

172+ , " (\"{http://www.w3.org/2001/XMLSchema-instance}type\", \""

173+ <> tnName tn <> "\")"

174+ , " : toXmlParentAttributes a"

175+ ]

176+ attrLines <- mapM toAttrLine (base : map fst types)

177+ writeCode (concat attrLines)

178

73genDependencies :: References a => a -> Gen ()

179genDependencies :: References a => a -> Gen ()

74genDependencies a = forM_ (references a) $ \name -> do

180genDependencies a = forM_ (references a) $ \name -> do

@@ -97,7 +203,7 @@ genSimpleType typeName (Xsd.ListType _ _) _ = genUnsupported typeName

203

98genNewtype :: TypeName -> Xsd.QName -> [Xsd.Annotation] -> Gen ()

204genNewtype :: TypeName -> Xsd.QName -> [Xsd.Annotation] -> Gen ()

99genNewtype tn base annots = do

205genNewtype tn base annots = do

100− fieldTypeName <- resolveTypeName base

206+ fieldTypeName <- tnPrefixed <$> resolveTypeName base

101 mode <- getMode

207 mode <- getMode

102 let

208 let

103 typeName = tnPrefixed tn

209 typeName = tnPrefixed tn

@@ -143,7 +249,7 @@ genComplexType typeName t parentAnn = do

143 let

249 let

144 header = "\"" <> tnName typeName <> "\" =:= record "

250 header = "\"" <> tnName typeName <> "\" =:= record "

145 <> genTypeToText mode

251 <> genTypeToText mode

146− fields <- maybe (return []) (genFields typeName) (Xsd.complexModelGroup t)

252+ fields <- genFields typeName (Xsd.complexContent t)

147 writeCode $ makeComments typeName

253 writeCode $ makeComments typeName

148 (parentAnn <> Xsd.complexAnnotations t)

254 (parentAnn <> Xsd.complexAnnotations t)

149 writeCode [header]

255 writeCode [header]

@@ -168,13 +274,28 @@ makeComments typeName annotations =

168-- | Generate code for record fields

274-- | Generate code for record fields

169--

275--

170-- The first argument - record name

276-- The first argument - record name

171−genFields :: TypeName -> Xsd.ModelGroup -> Gen [Text]

277+genFields :: TypeName -> Xsd.Content -> Gen [Text]

278+genFields typeName (Xsd.ContentPlain c) =

279+ maybe (return []) (genFieldsForModel typeName) (Xsd.plainContentModel c)

280+genFields _ (Xsd.ContentSimple _) = return []

281+genFields typeName (Xsd.ContentComplex (Xsd.ComplexContentExtension e)) = do

282+ base <- resolveType (Xsd.complexExtensionBase e)

283+ baseFields <- case base of

284+ Xsd.TypeComplex t -> genFields typeName (Xsd.complexContent t)

285+ _ -> return []

286+ fields <- maybe (return []) (genFieldsForModel typeName)

287+ (Xsd.complexExtensionModel e)

288+ return (baseFields ++ fields)

289+genFields _ (Xsd.ContentComplex Xsd.ComplexContentRestriction) =

290+ return []

291+

292+genFieldsForModel :: TypeName -> Xsd.ModelGroup -> Gen [Text]

172−genFields typeName (Xsd.Sequence elements) =

293+genFieldsForModel typeName (Xsd.Sequence elements) =

173 catMaybes <$> mapM (genField typeName) elements

294 catMaybes <$> mapM (genField typeName) elements

174−genFields _ (Xsd.Choice _) = do

295+genFieldsForModel _ (Xsd.Choice _) = do

175 warn "choice: not implemented"

296 warn "choice: not implemented"

176 return []

297 return []

177−genFields _ (Xsd.All _) = do

298+genFieldsForModel _ (Xsd.All _) = do

178 warn "all: not implemented"

299 warn "all: not implemented"

179 return []

300 return []

180

301

@@ -183,10 +304,15 @@ genField typeName e = do

183 fieldName <- makeFieldName typeName (Xsd.elementName e)

304 fieldName <- makeFieldName typeName (Xsd.elementName e)

184

305

185 fieldTypeName <- case Xsd.elementType e of

306 fieldTypeName <- case Xsd.elementType e of

307+ Xsd.Ref name -> do

186− Xsd.Ref name -> resolveTypeName name

308+ tn <- tnPrefixed <$> resolveTypeName name

309+ exts <- extensions name

310+ case exts of

311+ [] -> return tn

312+ _ -> return ("Any" <> tn)

187 Xsd.Inline t -> do

313 Xsd.Inline t -> do

188 genType (Xsd.elementAnnotations e) (Xsd.elementName e) t

314 genType (Xsd.elementAnnotations e) (Xsd.elementName e) t

189− resolveTypeName (Xsd.elementName e)

315+ tnPrefixed <$> resolveTypeName (Xsd.elementName e)

190

316

191 qualifier <- makeQualifier (Xsd.elementOccurs e)

317 qualifier <- makeQualifier (Xsd.elementOccurs e)

192

318

@@ -243,11 +369,6 @@ genUnsupported tn = do

243 , ""

369 , ""

244 ]

370 ]

245

371

246−genElement :: Xsd.Element -> Gen ()

247−genElement e = case Xsd.elementType e of

248− Xsd.Ref _ -> return ()

249− Xsd.Inline t -> genType (Xsd.elementAnnotations e) (Xsd.elementName e) t

250−

251genHeader :: Options -> Gen ()

372genHeader :: Options -> Gen ()

252genHeader opts = do

373genHeader opts = do

253 case oHeader opts of

374 case oHeader opts of

@@ -270,17 +391,19 @@ genHeader opts = do

270 ]

391 ]

271 where

392 where

272 imports = case oMode opts of

393 imports = case oMode opts of

273− Generator -> [ xmlWriter ]

394+ Generator -> [ xmlWriter, parentAttr ]

274 Parser -> [ domParser ]

395 Parser -> [ domParser ]

275− Both -> [ domParser, xmlWriter ]

396+ Both -> [ domParser, xmlWriter, parentAttr ]

276− xmlWriter = "import Text.XML.Writer"

397+ xmlWriter = "import Text.XML.Writer"

277− domParser = "import Text.XML.DOM.Parser.FromDom"

398+ parentAttr = "import Text.XML.ParentAttributes"

399+ domParser = "import Text.XML.DOM.Parser"

278

400

279-- | We populate the initial state with all built-in types to make sure

401-- | We populate the initial state with all built-in types to make sure

280-- they will be correctly resolved

402-- they will be correctly resolved

281−initialGenState :: Options -> Xsd.Schema -> GenState

403+initialGenState :: Options -> Map Xsd.QName Xsd.Type -> GenState

282−initialGenState opts schema = GenState

404+initialGenState opts types = GenState

283− { gsTypes = Xsd.schemaTypes schema

405+ { gsTypes = types

406+ , gsExtensions = collectExtensions types

284 , gsKnownTypes = builtInTypes

407 , gsKnownTypes = builtInTypes

285 , gsBoundTypeName = Set.empty

408 , gsBoundTypeName = Set.empty

286 , gsBoundFields = Set.empty

409 , gsBoundFields = Set.empty

@@ -288,3 +411,17 @@ initialGenState opts schema = GenState

288 , gsCode = []

411 , gsCode = []

289 , gsWarnings = []

412 , gsWarnings = []

290 }

413 }

414+

415+collectExtensions

416+ :: Map Xsd.QName Xsd.Type

417+ -> Map Xsd.QName [(Xsd.QName, Xsd.Type)]

418+collectExtensions = List.foldl' step Map.empty . Map.toList

419+ where

420+ step exts (n, t) = case baseOf t of

421+ Nothing -> exts

422+ Just base -> Map.insertWith (++) base [(n, t)] exts

423+ baseOf (Xsd.TypeSimple _) = Nothing

424+ baseOf (Xsd.TypeComplex t) = case Xsd.complexContent t of

425+ Xsd.ContentComplex (Xsd.ComplexContentExtension e) ->

426+ Just (Xsd.complexExtensionBase e)

427+ _ -> Nothing

src/References.hs+25−2

@@ -31,8 +31,31 @@ instance References t => References (Xsd.RefOr t) where

31 references (Xsd.Inline t) = references t

33instance References Xsd.ComplexType where

34− references t = referencesList (Xsd.complexAttributes t)

34+ references t = references (Xsd.complexContent t)

35+

36+instance References Xsd.Content where

37+ references (Xsd.ContentComplex c) = references c

38+ references (Xsd.ContentSimple c) = references c

39+ references (Xsd.ContentPlain c) = references c

40+

41+instance References Xsd.PlainContent where

42+ references t = referencesList (Xsd.plainContentAttributes t)

35− ++ references (Xsd.complexModelGroup t)

43+ ++ references (Xsd.plainContentModel t)

44+

45+instance References Xsd.SimpleContent where

46+ references _ = []

47+

48+instance References Xsd.ComplexContent where

49+ references (Xsd.ComplexContentExtension e) = references e

50+ references Xsd.ComplexContentRestriction = []

51+

52+instance References Xsd.ComplexExtension where

53+ -- Note that we don't include extension base here

54+ -- becase we don't depend on it. And actaully we generate extensions before

55+ -- the base because we need to generate the ADT with all the extensions

56+ -- at this point.

57+ references e = referencesList (Xsd.complexExtensionAttributes e)

58+ ++ references (Xsd.complexExtensionModel e)

37instance References Xsd.Attribute where

60instance References Xsd.Attribute where

38 references = references . Xsd.attrType

61 references = references . Xsd.attrType