@@ -1,407 +1,450 @@
1−{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
9−import Control.Monad.RWS.CPS (RWS, execRWS)
8+import Data.Text (Text)
10−import Control.Monad.Reader
9+import qualified Data.Text as Text
11−import Control.Monad.State.Strict
12−import Control.Monad.Writer.CPS (Writer, tell, execWriter)
13−import Data.ByteString.Lazy as BL
14−import Data.Char as C
10+import qualified Data.Text.IO as Text
15−import Data.Default
11+import Data.Maybe
16−import Data.Foldable as F
17−import Data.List as L
12+import qualified Data.List as List
18−import Data.Map.Strict as M
19−import Data.Set as S
13+import qualified Data.Set as Set
20−import Data.Text as T
14+import Data.Map (Map)
21−import Data.Text.IO as T
15+import qualified Data.Map as Map
22−import Data.Traversable
16+import Control.Monad
23−import Debug.Trace
17+import qualified System.IO as IO
24−import System.Environment
18+import qualified Xsd
26−import Text.XSD
20+import Options
29−data GenType = Parser | Generator | Both
30− deriving (Read, Show)
32−genTypeToText :: GenType -> Text
33−genTypeToText Parser = "Parser"
34−genTypeToText Generator = "Generator"
35−genTypeToText Both = "Both"
37−type GenMonad = ReaderT DatatypeMap (Writer Text)
39−class References a where
40− references :: a -> [Text]
42−instance References Datatype where
22+import References
43− references (TypeComplex (ComplexType _ _ _ mmgs)) =
23+import BuiltInTypes
45− Just mgs -> case mgs of
46− CTSequence els -> F.concatMap references els
47− CTChoice els -> F.concatMap references els
48− CTAll els -> F.concatMap references els
50− references (TypeSimple _) = []
52−instance References Element where
53− references (Element _ t _ _ _) = references t
55−instance References DatatypeRef where
56− references (DatatypeRef ty) = [ty]
57− references (InlineComplex dt) = references dt
59−instance References a => References [a] where
60− references = F.concatMap references
62−-- | 'DatatypeMap' are the types left to process
63−-- 'S.Set Text' are the types already processed.
64−type PreMonad = StateT (DatatypeMap, S.Set Text) (Writer [(Text, Datatype)])
66−type PreElemMonad = RWS DatatypeMap [Element] [Element]
68−-- | Marks the given type as processed.
69−proceed :: Text -> Datatype -> PreMonad ()
72− modify $ \(f,s) -> (M.delete t f, S.insert t s)
74−-- | Marks element as processed.
75−proceed' :: Element -> PreElemMonad ()
80−untwistDeps :: [Element] -> DatatypeMap -> ([(Text, Datatype)], [Element])
81−untwistDeps e dm = (dList, e')
83− dList = nub $ execWriter $ do
84− (a, _) <- runStateT sortDatatypesByDeps (dm, S.empty)
86− (_, e') = execRWS sortElemsByDeps (M.fromList dList) e
88−sortElemsByDeps :: PreElemMonad ()
91− if Prelude.null els then pure () else do
92− let first = Prelude.head els
93− -- traceM $ "sortElemsByDeps: " <> show first
94− case references first of
95− [] -> proceed' first >> sortElemsByDeps
97− results <- traverse memberDatatype xs
99− then proceed' first >> sortElemsByDeps
101− let failed = fmap snd $ L.filter (not . fst) $ L.zip results xs
102− error $ "impossible to lookup types: " <> show failed
104−memberDatatype :: Text -> PreElemMonad Bool
105−memberDatatype ty = do
106− -- traceM $ "memberDatatype: " <> show ty
108− case M.lookup ty dm of
109− Just _ -> return True
110− Nothing -> return False
112−sortDatatypesByDeps :: PreMonad ()
113−sortDatatypesByDeps = do
115− if M.null dm then pure () else do
116− let first = Prelude.head (M.toList dm)
117− traceM $ "sortDatatypesByDeps: " <> show first
118− case references $ snd first of
119− [] -> uncurry proceed first >> sortDatatypesByDeps
121− traverse_ lookupDatatype xs
122− uncurry proceed first
125−lookupDatatype :: Text -> PreMonad ()
126−lookupDatatype ty = do
127− traceM $ "lookupDatatype: " <> show ty
129− case M.lookup ty dm of
130− Nothing -> if S.member ty s then pure () else
131− error $ "can't look up datatype: " <> show ty
132− Just typ -> case references typ of
133− [] -> proceed ty typ
134− xs -> traverse_ lookupDatatype xs >> proceed ty typ
136−class Capitalizable t where
137− capitalize :: t -> t
139−instance Capitalizable String where
141− capitalize (a:as) = C.toUpper a : as
143−instance Capitalizable Text where
146− | otherwise = T.singleton (C.toUpper (T.head t)) <> T.tail t
148−data DataFlavour = QQ | Plain
150−-- TODO: improve after moving some XML types to xml-isogen
151−simpleTypeToIsoType :: DataFlavour -> SimpleAtomicType -> Text
152−simpleTypeToIsoType fl = \case
153− STAnyURI -> wrap fl "Text"
154− STBase64Binary -> wrap fl "ByteString"
155− STBoolean -> wrap fl "Bool"
156− STDate -> wrap fl "Date \"%YYYYj\""
157− STDateTime -> wrap fl "Text"
158− STDateTimeStamp -> wrap fl "Text"
159− STDecimal DTDecimal -> wrap fl "Double"
160− (STDecimal _) -> wrap fl "Integer"
161− STDouble -> wrap fl "Double"
162− (STDuration _) -> wrap fl "Integer"
163− STFloat -> wrap fl "Float"
164− STGDay -> wrap fl "Day"
165− STGMonth -> wrap fl "Text"
166− STGMonthDay -> wrap fl "Text"
167− STGYear -> wrap fl "Text"
168− STGYearMonth -> wrap fl "Text"
169− STHexBinary -> wrap fl "Text"
170− STNOTATION -> wrap fl "Text"
171− STQName -> wrap fl "Text"
172− (STString _) -> wrap fl "Text"
173− STTime -> wrap fl "Text"
175− wrap QQ t = "[t|" <> t <> "|]"
179− :: [Text] -- generated code
182−tellGen code comment =
183− tell $ "\n" <> comment <> T.unlines code
185−runGen :: DatatypeMap -> GenMonad a -> Text
25+main :: IO ()
186−runGen dm act = execWriter $ runReaderT act dm
26+main = do
187−
27+ opts <- getOptions
188−generateIsoXml :: GenType -> XSD -> Text
28+ schema <- Xsd.getSchema (oInput opts)
189−generateIsoXml genType (XSD (e,dm)) =
29+ res <- either fail return
30+ (generate opts schema)
31+ mapM_ (Text.hPutStrLn IO.stderr) (resultWarnings res)
32+ Text.putStrLn (resultCode res)
36+ , resultWarnings :: [Text]
39+generate :: Options -> Xsd.Schema -> Either String Result
40+generate opts schema = do
191− (dList, el) = untwistDeps e dm
42+ types = Map.union (Xsd.schemaTypes schema)
192− in (header genType <>) . runGen dm $ do
43+ (elementsToTypes (Xsd.schemaElements schema))
193− for_ dList $ \(t,dt) ->
44+ s <- runGen (initialGenState opts types) $ do
194− generateIsoDatatype genType t dt []
45+ genHeader opts
195− for_ el (generateIsoRecord genType)
46+ genTypes types
197−toQualifier :: Int -> Int -> Text
48+ { resultCode = Text.unlines (reverse (gsCode s))
198−toQualifier minOc maxOc
49+ , resultWarnings = reverse (gsWarnings s)
199− | minOc == 1 && maxOc == 1 = "!"
50+ }
200− | minOc == 0 && maxOc == 1 = "?"
51+
201− | minOc == 1 && maxOc > minOc = "+"
52+elementsToTypes :: Map Xsd.QName Xsd.Element -> Map Xsd.QName Xsd.Type
202− | minOc == 1 && maxOc < minOc = error "maxOccurs < minOccurs"
53+elementsToTypes = List.foldl' step Map.empty . Map.toList
205−header :: GenType -> Text
206−header genType = T.unlines $
207− [ "module Dummy where"
209− , "import Control.DeepSeq"
210− , "import Data.THGen.XML"
212− [ "import Prelude hiding ((*), (+))"
215− specImports = case genType of
216− Generator -> [ xmlWriter ]
217− Parser -> [ domParser ]
218− Both -> [ domParser, xmlWriter ]
219− xmlWriter, domParser :: Text
220− xmlWriter = "import Text.XML.Writer"
221− domParser = "import Text.XML.DOM.Parser.FromDom"
223−quote :: Text -> Text
224−quote t = "\"" <> t <> "\""
226−-- | Nothing means unknown name
227−typeName :: DatatypeRef -> Maybe Text
228−typeName (InlineComplex dt) = result
231− TypeComplex (ComplexType n _ _ _) -> n
232− TypeSimple (STAtomic _ sat _ _) -> Just $ simpleTypeToIsoType QQ sat
233−typeName (DatatypeRef t) = Just t
235−generateIsoRecord :: GenType -> Element -> GenMonad ()
238− (Element (_, laxName) elXtype _ _ elAnnotations) = do
242− generateIsoDatatype genType laxName dt elAnnotations
243− DatatypeRef nam -> if M.member nam written
245− else error $ "Implementation failure: "
246− <> show nam <> " type never encountered before"
248−data CommentType = Haddock | Regular
250−toComment :: CommentType -> [Annotation] -> Text
251−toComment ct ann = case texts of
253− (h:tl) -> T.unlines ((prefix <> h) : fmap ("-- "<>) tl)
255− texts = stripTexts $ F.concatMap (wrap80 . fromDocumentation) ann
258− l@(h:tl) -> if T.all (\x -> x == ' ' || x == '\n') h then stripTexts tl else l
263−fromDocumentation :: Annotation -> Text
264−fromDocumentation (Documentation t) = t
266−wrap80 :: Text -> [Text]
267−wrap80 = L.foldl' go [] . T.split (==' ')
269− go [] e = [e]
55+ step types (_, e) = case Xsd.elementType e of
270− go l e =
56+ Xsd.Ref _ -> types
271− let last' = L.last l
57+ Xsd.Inline t -> Map.insert (Xsd.elementName e) t types
272− in if T.length last' + T.length e >= 73 -- 80 minus "-- | " and ' '
58+
273− then l <> pure e
59+genTypes :: Map Xsd.QName Xsd.Type -> Gen ()
274− else L.init l <> [L.last l <> " " <> e]
60+genTypes types = mapM_ (uncurry genTopType) . Map.toList $ types
276−generateIsoDatatype
62+genTopType :: Xsd.QName -> Xsd.Type -> Gen ()
277− :: GenType
63+genTopType = genType []
278− -> (Maybe Text) -- ^ Explicitly provided name, used for inline complexType's
64+
280− -> [Annotation]
65+genType :: [Xsd.Annotation] -> Xsd.QName -> Xsd.Type -> Gen ()
281− -> GenMonad ()
66+genType annotations name tp = do
282− -- ^ (type name for lookups, generated code)
67+ known <- knownTypeName name
283−generateIsoDatatype
68+ case known of
284− genType
69+ Just _ -> return () -- already generated
285− eName
70+ Nothing -> do
71+ -- we should generate dependencies before the type itself to make
72+ -- sure they are in scope when xml-isogen quotes them
73+ -- (stage restriction in TH)
75+ typeName <- makeTypeName name tp
77+ Xsd.TypeSimple t -> genSimpleType typeName t annotations
286− (TypeComplex (ComplexType iName attrs annotations mGroupSchema))
78+ Xsd.TypeComplex t -> genComplexType typeName t annotations
287− annotationsRec = do
79+ genExtension name
81+genExtension :: Xsd.QName -> Gen ()
82+genExtension base = do
83+ exts <- extensions base
288− name <- case eName of
84+ case exts of
289− Just name -> pure name
85+ [] -> return ()
290− Nothing -> case iName of
86+ types -> do
291− Just name' -> pure name'
87+ mapM_ (uncurry genTopType) types
292− Nothing -> error $ "[generateIsoDatatype] no name was provided"
88+ baseTypeName <- tnPrefixed <$> resolveTypeName base
293− case mGroupSchema of
89+ writeCode
294− Just groupSchema -> case groupSchema of
90+ [ "data Any" <> baseTypeName
295− CTSequence elems -> do
91+ , " = The" <> baseTypeName <> " !" <> baseTypeName
296− fields <- for elems (generateIsoField genType)
92+ ]
94+ mkConstructor (n, _) = do
95+ tn <- tnPrefixed <$> resolveTypeName n
96+ exts' <- extensions n
298− comment = toComment Haddock $ annotationsRec
98+ n' = case exts' of
299− <> [Documentation ""]
99+ [] -> tn
300− <> annotations
100+ _ -> "Any" <> tn
301− header =
101+ return (" | The" <> n' <> " !" <> n')
302− (quote $ capitalize name)
102+ constructors <- mapM mkConstructor types
303− <> " =:= record "
103+ writeCode constructors
304− <> genTypeToText genType
104+ writeCode
305− tellGen (header : fields) comment
105+ [ " deriving (Eq, Show)"
306−generateIsoDatatype
106+ , ""
309− (TypeSimple (STAtomic iName sat annotations restrictions))
109+ [ "instance NFData Any" <> baseTypeName <> " where"
310− annotationsRec = do
110+ , " rnf = rwhnf"
114+ unless (mode == Generator) $ do
116+ [ "instance FromDom Any" <> baseTypeName <> " where"
118+ , " tp <- parseAttribute"
120+ "\"{http://www.w3.org/2001/XMLSchema-instance}type\")"
126+ tn <- resolveTypeName n
127+ exts' <- extensions n
129+ [] -> return (tnPrefixed tn)
130+ _ | n == base -> return (tnPrefixed tn)
131+ _ -> return ("Any" <> tnPrefixed tn)
139+ clauses <- mapM mkClause (base : map fst types)
142+ [ " _ -> throwParserError (PEOther \"Unexpected type\")"
145+ unless (mode == Parser) $ do
147+ [ "instance ToXML Any" <> baseTypeName <> " where"
148+ , " toXML (The" <> baseTypeName <> " a) = toXML a"
151+ mkClause (n, _) = do
152+ tn <- tnPrefixed <$> resolveTypeName n
153+ exts' <- extensions n
158+ return (" toXML (The" <> n' <> " a) = toXML a")
159+ clauses <- mapM mkClause types
163+ [ "instance ToXmlParentAttributes Any" <> baseTypeName <> " where"
167+ tn <- resolveTypeName n
168+ exts' <- extensions n
170+ [] -> return (tnPrefixed tn)
171+ _ | n == base -> return (tnPrefixed tn)
172+ _ -> return ("Any" <> tnPrefixed tn)
174+ [ " toXmlParentAttributes (The" <> n' <> " a) ="
175+ , " (\"{http://www.w3.org/2001/XMLSchema-instance}type\", \""
176+ <> tnName tn <> "\")"
177+ , " : toXmlParentAttributes a"
179+ attrLines <- mapM toAttrLine (base : map fst types)
180+ writeCode (concat attrLines)
182+genDependencies :: References a => a -> Gen ()
183+genDependencies a = forM_ (references a) $ \name -> do
184+ known <- knownTypeName name
311− name <- case eName of
185+ case known of
312− Just name -> pure name
186+ Just _ -> return () -- already generated
313− Nothing -> pure iName
187+ Nothing -> do
314− let
188+ tp <- resolveType name
315− comment =
189+ genTopType name tp
316− toComment Haddock $ annotationsRec
190+
317− <> [Documentation ""]
191+genSimpleType :: TypeName -> Xsd.SimpleType -> [Xsd.Annotation]-> Gen ()
318− <> annotations
192+genSimpleType tn (Xsd.AtomicType restriction ann) parentAnn = do
319− isEnumeration (Enumeration _) = True
320− fromEnumeration (Enumeration x) = x
321− enums = Prelude.filter isEnumeration restrictions
322− typeStr = simpleTypeToIsoType QQ sat
323− if Prelude.length enums > 0
326− (quote $ capitalize name)
327− (F.concatMap fromEnumeration enums))
330− tellGen (generateNewtype genType iName sat) comment
332−generateNewtype :: GenType -> Text -> SimpleAtomicType -> [Text]
333−generateNewtype genType n sat =
335− cons = "Xml" <> capitalize n
194+ baseName r = case Xsd.simpleRestrictionBase r of
336− decons = "un" <> cons
195+ Xsd.Ref n -> Just n
337− parser =
196+ Xsd.Inline (Xsd.AtomicType r' _) -> baseName r'
338− [ ""
197+ Xsd.Inline (Xsd.ListType _ _) -> Nothing
339− , "instance FromDom " <> cons <> " where"
198+ Xsd.Inline (Xsd.UnionType _ _) -> Nothing
340− , " fromDom = " <> cons <> " <$> fromDom"
199+ case baseName restriction of
342− in
201+ | isEnum restriction
343− [ "newtype " <> cons
202+ -> genEnum tn
344− , " = " <> cons
203+ (Xsd.simpleRestrictionConstraints restriction)
345− , " { " <> decons <> " :: " <> simpleTypeToIsoType Plain sat
204+ (parentAnn <> ann)
346− , " } deriving (Show, Eq, NFData" <> case genType of
205+ Just base ->
347− Parser -> ")"
206+ genNewtype tn base (parentAnn <> ann)
348− _ -> ", ToXML)"
207+ _ -> genUnsupported tn
349− ] <> case genType of
208+genSimpleType typeName (Xsd.ListType _ _) _ = genUnsupported typeName
350− Generator -> []
209+genSimpleType typeName (Xsd.UnionType _ _) _ = genUnsupported typeName
352−
211+genNewtype :: TypeName -> Xsd.QName -> [Xsd.Annotation] -> Gen ()
353−generateEnum
212+genNewtype tn base annots = do
354− :: Text -- type name
213+ fieldTypeName <- tnPrefixed <$> resolveTypeName base
355− -> [Text] -- enums
214+ mode <- getMode
356− -> [Text] -- generated code
357−generateEnum enumName enums =
359− enumHeader = enumName <> " Exhaustive =:= enum Both"
216+ typeName = tnPrefixed tn
360− eFields = ("& "<>) <$> enums
217+ fieldName = "un" <> typeName
361− in pure enumHeader <> eFields
218+ toxml = case mode of
363−-- | Returns Just baseTypeName if type is simple, Nothing - otherwise
220+ _ -> ", ToXML"
364−lookupSimpleBaseType
221+ writeCode $ makeComments tn annots
365− :: DatatypeRef
222+ writeCode
366− -> GenMonad (Maybe SimpleAtomicType)
223+ [ "newtype " <> typeName
367−lookupSimpleBaseType (InlineComplex _) = pure Nothing
224+ , " = " <> typeName
368−lookupSimpleBaseType (DatatypeRef tyName) = do
225+ , " { " <> fieldName <> " :: " <> fieldTypeName
369− M.lookup tyName <$> ask >>= \case
226+ , " } deriving (Show, Eq, NFData" <> toxml <> ")"
370− Just (TypeComplex _) -> pure Nothing
227+ , ""
371− Just (TypeSimple (STAtomic _ sat _ _)) -> pure $ Just sat
228+ ]
372− Nothing -> error $ "can't look up type: " <> show tyName
229+ unless (mode == Generator) $ writeCode
373−
230+ [ "instance FromDom " <> typeName <> " where"
374−lookupSimpleType
231+ , " fromDom = " <> typeName <> " <$> fromDom"
375− :: DatatypeRef
232+ , ""
376− -> GenMonad (Maybe Text)
233+ ]
377−lookupSimpleType (InlineComplex _) = pure Nothing
234+
378−lookupSimpleType (DatatypeRef tyName) =
235+genEnum :: TypeName -> [Xsd.Constraint] -> [Xsd.Annotation] -> Gen ()
379− asks (M.lookup tyName) >>= \case
236+genEnum tn constraints annots = do
380− Just (TypeComplex _) -> pure Nothing
237+ mode <- getMode
381− Just (TypeSimple (STAtomic nam _ _ _)) -> pure $ Just nam
382− Nothing -> error $ "can't look up type: " <> show tyName
384−generateIsoField :: GenType -> Element -> GenMonad Text
385−generateIsoField genType (Element (_, name) xtype minOc maxOc annotations) = do
387− qualifier = toQualifier minOc maxOc
239+ values = map toValue constraints
388− line <- lookupSimpleType xtype >>= \case
240+ toValue (Xsd.Enumeration v) = v
389− Just tyName -> do
241+ enumLines <- forM values $ \v -> do
390− pure $ quote name <> " [t|Xml" <> tyName <> "|]"
242+ enumName <- makeEnumName v
391− Nothing -> case xtype of
243+ return (" & \"" <> enumName <> "\"")
392− InlineComplex dt -> do
244+ writeCode $ makeComments tn annots
393− generateIsoDatatype genType (Just $ capitalize name) dt annotations
245+ writeCode $ "\"" <> tnName tn <> "\" Exhaustive =:= enum "
394− pure $ quote name
246+ <> genTypeToText mode : enumLines
395− DatatypeRef ref ->
247+ writeCode [""]
396− pure $ quote name <> " [t|Xml" <> capitalize ref <> "|]"
248+
397− pure $ " " <> qualifier <> " " <> line
249+isEnum :: Xsd.SimpleRestriction -> Bool
250+isEnum = any isEnumConstraint . Xsd.simpleRestrictionConstraints
252+ isEnumConstraint (Xsd.Enumeration _) = True
254+genComplexType :: TypeName -> Xsd.ComplexType -> [Xsd.Annotation] -> Gen ()
255+genComplexType typeName t parentAnn = do
258+ header = "\"" <> tnName typeName <> "\" =:= record "
259+ <> genTypeToText mode
260+ fields <- genFields typeName (Xsd.complexContent t)
261+ writeCode $ makeComments typeName
262+ (parentAnn <> Xsd.complexAnnotations t)
267+makeComments :: TypeName -> [Xsd.Annotation] -> [Text]
268+makeComments typeName annotations = if null annotations
278+ ] <> map makeDoc annotations <>
282+ generated = "Generated from: " <> prefix <> name
283+ qname = tnQName typeName
284+ name = Xsd.qnName qname
285+ prefix = maybe "" ((<> ":") . Xsd.fromNamespace) (Xsd.qnNamespace qname)
286+ makeDoc (Xsd.Documentation docs) = docs
288+-- | Generate code for record fields
290+-- The first argument - record name
291+genFields :: TypeName -> Xsd.Content -> Gen [Text]
292+genFields typeName (Xsd.ContentPlain c) =
293+ maybe (return []) (genFieldsForModel typeName) (Xsd.plainContentModel c)
294+genFields _ (Xsd.ContentSimple _) = return []
295+genFields typeName (Xsd.ContentComplex (Xsd.ComplexContentExtension e)) = do
296+ base <- resolveType (Xsd.complexExtensionBase e)
297+ genDependencies base
298+ baseFields <- case base of
299+ Xsd.TypeComplex t -> genFields typeName (Xsd.complexContent t)
301+ fields <- maybe (return []) (genFieldsForModel typeName)
302+ (Xsd.complexExtensionModel e)
303+ return (baseFields ++ fields)
304+genFields _ (Xsd.ContentComplex (Xsd.ComplexContentRestriction _)) =
307+genFieldsForModel :: TypeName -> Xsd.ModelGroup -> Gen [Text]
308+genFieldsForModel typeName (Xsd.Sequence elements) =
309+ catMaybes <$> mapM (genField typeName) elements
310+genFieldsForModel _ (Xsd.Choice _) = do
311+ warn "choice: not implemented"
313+genFieldsForModel _ (Xsd.All _) = do
314+ warn "all: not implemented"
317+genField :: TypeName -> Xsd.RefOr Xsd.Element -> Gen (Maybe Text)
318+genField _ (Xsd.Ref _) = return Nothing
319+genField typeName (Xsd.Inline e) = do
320+ fieldName <- makeFieldName typeName (Xsd.elementName e)
322+ fieldTypeName <- case Xsd.elementType e of
324+ tn <- tnPrefixed <$> resolveTypeName name
325+ exts <- extensions name
328+ _ -> return ("Any" <> tn)
330+ genType (Xsd.elementAnnotations e) (Xsd.elementName e) t
331+ tnPrefixed <$> resolveTypeName (Xsd.elementName e)
333+ qualifier <- makeQualifier (Xsd.elementOccurs e)
401− (inFile:mode:_) <- getArgs
402− xml <- BL.readFile inFile
404− xsd = case parseXSD def xml of
336+ fieldType = if Xsd.elementNillable e
405− Right xsd' -> xsd'
337+ then "Nillable " <> fieldTypeName
406− Left e -> error $ show e
338+ else fieldTypeName
407− T.hPutStrLn stdout $ generateIsoXml (read mode) xsd
339+
340+ return $ Just $ mconcat
350+makeQualifier :: (Int, Xsd.MaxOccurs) -> Gen Text
351+makeQualifier (minOcc, maxOcc) = case maxOcc of
352+ Xsd.MaxOccursUnbound -> toQualifier minOcc maxBound
353+ Xsd.MaxOccurs v -> toQualifier minOcc v
355+toQualifier :: Int -> Int -> Gen Text
356+toQualifier 1 1 = return "!"
357+toQualifier 0 1 = return "?"
360+ = genError "maxOccurs < minOccurs"
364+toQualifier _ _ = return "*"
366+genUnsupported :: TypeName -> Gen ()
367+genUnsupported tn = do
368+ let typeName = tnPrefixed tn
369+ warn $ "generating stub for unsupported construct in " <> typeName
371+ writeCode (makeComments tn [])
373+ [ "data " <> typeName <> " = " <> typeName
374+ , " deriving (Eq, Show)"
376+ , "instance NFData " <> typeName <> " where"
381+ unless (mode == Parser) $ writeCode
382+ [ "instance ToXML " <> typeName <> " where"
383+ , " toXML _ = comment \"" <> typeName <> "\""
387+ unless (mode == Generator) $ writeCode
388+ [ "instance FromDom " <> typeName <> " where"
389+ , " fromDom = undefined"
393+genHeader :: Options -> Gen ()
395+ case oHeader opts of
396+ Nothing -> return ()
398+ writeCode . fmap ("-- " <>) . Text.lines $ h
402+ [ "{-# OPTIONS_GHC -Wno-unused-imports #-}"
403+ , "module " <> oModule opts <> " where"
405+ , "import Control.DeepSeq"
406+ , "import Data.Scientific"
407+ , "import Data.THGen.XML"
411+ [ "import Prelude hiding ((*), (+))"
416+ imports = case oMode opts of
417+ Generator -> [ xmlWriter, parentAttr ]
418+ Parser -> [ domParser ]
419+ ParserAndGenerator -> [ domParser, xmlWriter, parentAttr ]
420+ xmlWriter = "import Text.XML.Writer"
421+ parentAttr = "import Text.XML.ParentAttributes"
422+ domParser = "import Text.XML.DOM.Parser"
424+-- | We populate the initial state with all built-in types to make sure
425+-- they will be correctly resolved
426+initialGenState :: Options -> Map Xsd.QName Xsd.Type -> GenState
427+initialGenState opts types = GenState
429+ , gsExtensions = collectExtensions types
430+ , gsKnownTypes = builtInTypes
431+ , gsBoundTypeName = Set.empty
432+ , gsBoundFields = Set.empty
433+ , gsMode = oMode opts
439+ :: Map Xsd.QName Xsd.Type
440+ -> Map Xsd.QName [(Xsd.QName, Xsd.Type)]
441+collectExtensions = List.foldl' step Map.empty . Map.toList
443+ step exts (n, t) = case baseOf t of
445+ Just base -> Map.insertWith (++) base [(n, t)] exts
446+ baseOf (Xsd.TypeSimple _) = Nothing
447+ baseOf (Xsd.TypeComplex t) = case Xsd.complexContent t of
448+ Xsd.ContentComplex (Xsd.ComplexContentExtension e) ->
449+ Just (Xsd.complexExtensionBase e)