@@ -9,6 +9,7 @@ import Data.Text (Text)
99import qualified Data.Text as Text
1010import qualified Data.Text.IO as Text
1111import Data.Maybe
12+import qualified Data.List as List
1213import qualified Data.Set as Set
1314import Data.Map (Map)
1415import qualified Data.Map as Map
@@ -37,21 +38,27 @@ data Result = Result
3738
3839generate :: Options -> Xsd.Schema -> Either String Result
3940generate opts schema = do
40− s <- runGen (initialGenState opts schema) $ do
41+ let
42+ types = Map.union (Xsd.schemaTypes schema)
43+ (elementsToTypes (Xsd.schemaElements schema))
44+ s <- runGen (initialGenState opts types) $ do
4145 genHeader opts
42− genTypes (Xsd.schemaTypes schema)
43− genElements (Xsd.schemaElements schema)
46+ genTypes types
4447 Right Result
4548 { resultCode = Text.unlines (reverse (gsCode s))
4649 , resultWarnings = reverse (gsWarnings s)
4750 }
4851
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+
4959genTypes :: Map Xsd.QName Xsd.Type -> Gen ()
5060genTypes types = mapM_ (uncurry genTopType) . Map.toList $ types
5161
52−genElements :: Map Xsd.QName Xsd.Element -> Gen ()
53−genElements = mapM_ genElement
54−
5562genTopType :: Xsd.QName -> Xsd.Type -> Gen ()
5663genTopType = genType []
5764
@@ -69,6 +76,105 @@ genType annotations name tp = do
6976 case tp of
7077 Xsd.TypeSimple t -> genSimpleType typeName t annotations
7178 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)
72178
73179genDependencies :: References a => a -> Gen ()
74180genDependencies a = forM_ (references a) $ \name -> do
@@ -97,7 +203,7 @@ genSimpleType typeName (Xsd.ListType _ _) _ = genUnsupported typeName
97203
98204genNewtype :: TypeName -> Xsd.QName -> [Xsd.Annotation] -> Gen ()
99205genNewtype tn base annots = do
100− fieldTypeName <- resolveTypeName base
206+ fieldTypeName <- tnPrefixed <$> resolveTypeName base
101207 mode <- getMode
102208 let
103209 typeName = tnPrefixed tn
@@ -143,7 +249,7 @@ genComplexType typeName t parentAnn = do
143249 let
144250 header = "\"" <> tnName typeName <> "\" =:= record "
145251 <> genTypeToText mode
146− fields <- maybe (return []) (genFields typeName) (Xsd.complexModelGroup t)
252+ fields <- genFields typeName (Xsd.complexContent t)
147253 writeCode $ makeComments typeName
148254 (parentAnn <> Xsd.complexAnnotations t)
149255 writeCode [header]
@@ -168,13 +274,28 @@ makeComments typeName annotations =
168274-- | Generate code for record fields
169275--
170276-- The first argument - record name
171−genFields :: TypeName -> Xsd.ModelGroup -> Gen [Text]
172−genFields typeName (Xsd.Sequence elements) =
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]
293+genFieldsForModel typeName (Xsd.Sequence elements) =
173294 catMaybes <$> mapM (genField typeName) elements
174−genFields _ (Xsd.Choice _) = do
295+genFieldsForModel _ (Xsd.Choice _) = do
175296 warn "choice: not implemented"
176297 return []
177−genFields _ (Xsd.All _) = do
298+genFieldsForModel _ (Xsd.All _) = do
178299 warn "all: not implemented"
179300 return []
180301
@@ -183,10 +304,15 @@ genField typeName e = do
183304 fieldName <- makeFieldName typeName (Xsd.elementName e)
184305
185306 fieldTypeName <- case Xsd.elementType e of
186− Xsd.Ref name -> resolveTypeName name
307+ Xsd.Ref name -> do
308+ tn <- tnPrefixed <$> resolveTypeName name
309+ exts <- extensions name
310+ case exts of
311+ [] -> return tn
312+ _ -> return ("Any" <> tn)
187313 Xsd.Inline t -> do
188314 genType (Xsd.elementAnnotations e) (Xsd.elementName e) t
189− resolveTypeName (Xsd.elementName e)
315+ tnPrefixed <$> resolveTypeName (Xsd.elementName e)
190316
191317 qualifier <- makeQualifier (Xsd.elementOccurs e)
192318
@@ -243,11 +369,6 @@ genUnsupported tn = do
243369 , ""
244370 ]
245371
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−
251372genHeader :: Options -> Gen ()
252373genHeader opts = do
253374 case oHeader opts of
@@ -270,17 +391,19 @@ genHeader opts = do
270391 ]
271392 where
272393 imports = case oMode opts of
273− Generator -> [ xmlWriter ]
394+ Generator -> [ xmlWriter, parentAttr ]
274395 Parser -> [ domParser ]
275− Both -> [ domParser, xmlWriter ]
276− xmlWriter = "import Text.XML.Writer"
277− domParser = "import Text.XML.DOM.Parser.FromDom"
396+ Both -> [ domParser, xmlWriter, parentAttr ]
397+ xmlWriter = "import Text.XML.Writer"
398+ parentAttr = "import Text.XML.ParentAttributes"
399+ domParser = "import Text.XML.DOM.Parser"
278400
279401-- | We populate the initial state with all built-in types to make sure
280402-- they will be correctly resolved
281−initialGenState :: Options -> Xsd.Schema -> GenState
282−initialGenState opts schema = GenState
283− { gsTypes = Xsd.schemaTypes schema
403+initialGenState :: Options -> Map Xsd.QName Xsd.Type -> GenState
404+initialGenState opts types = GenState
405+ { gsTypes = types
406+ , gsExtensions = collectExtensions types
284407 , gsKnownTypes = builtInTypes
285408 , gsBoundTypeName = Set.empty
286409 , gsBoundFields = Set.empty
@@ -288,3 +411,17 @@ initialGenState opts schema = GenState
288411 , gsCode = []
289412 , gsWarnings = []
290413 }
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