@@ -1,452 +1,266 @@
1−{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE LambdaCase #-}
31{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TupleSections #-}
52
63module Main
7− ( main
8− ) where
4+( main
5+)
6+where
97
10−import Control.Monad.RWS.CPS (RWS, execRWS)
11−import Control.Monad.Reader
12−import Control.Monad.State.Strict
13−import Control.Monad.Writer.CPS (Writer, tell, execWriter)
14−import Data.ByteString.Lazy as BL
15−import Data.Char as C
16−import Data.Default
17−import Data.Foldable as F
18−import Data.List as L
19−import Data.Map.Strict as M
20−import Data.Set as S
21−import Data.Text as T
22−import Data.Text.IO as T
23−import Data.Traversable
24−import Debug.Trace
25−import System.IO
26−import Text.XSD
27−import Options
8+import Data.Text (Text)
9+import qualified Data.Text as Text
10+import qualified Data.Text.IO as Text
2811import Data.Maybe
12+import qualified Data.Set as Set
13+import Data.Map (Map)
14+import qualified Data.Map as Map
15+import Control.Monad
16+import qualified System.IO as IO
17+import qualified Xsd
2918
19+import Options
20+import Gen
21+import References
22+import BuiltInTypes
3023
31−makeNamePrefix :: Text -> Text
32−makeNamePrefix = T.map C.toLower . T.filter (\c -> C.isUpper c || C.isDigit c)
33−
34−type GenMonad = ReaderT DatatypeMap (Writer Text)
35−
36−class Fields a where
37− fields :: a -> [Text]
38−
39−instance Fields Datatype where
40− fields (TypeComplex ty) = fields ty
41− fields (TypeSimple ty) = fields ty
42−
43−instance Fields SimpleType where
44− fields ty@(STAtomic tyName _ _ restrictions) = if shouldBeNewtype ty
45− then [getNewtypeUnconsName tyName]
46− else getEnumeratedCode restrictions
47−
48−instance Fields ComplexType where
49− fields (ComplexType _ _ _ (Just g)) = fields g
50− fields (ComplexType _ _ _ Nothing) = []
51−
52−instance Fields ModelGroupSchema where
53− fields (CTSequence els) = snd . name <$> els
54− fields (CTChoice els) = snd . name <$> els
55− fields (CTAll els) = snd . name <$> els
56−
57−class References a where
58− references :: a -> [Text]
59−
60−instance References Datatype where
61− references (TypeComplex (ComplexType _ _ _ mmgs)) =
62− case mmgs of
63− Just mgs -> case mgs of
64− CTSequence els -> F.concatMap references els
65− CTChoice els -> F.concatMap references els
66− CTAll els -> F.concatMap references els
67− Nothing -> []
68− references (TypeSimple _) = []
69−
70−instance References Element where
71− references (Element _ t _ _ _) = references t
72−
73−instance References DatatypeRef where
74− references (DatatypeRef ty) = [ty]
75− references (InlineComplex dt) = references dt
76−
77−instance References a => References [a] where
78− references = F.concatMap references
79−
80−-- | 'DatatypeMap' are the types left to process
81−-- 'S.Set Text' are the types already processed.
82−type PreMonad = StateT (DatatypeMap, S.Set Text) (Writer [(Text, Datatype)])
83−
84−type PreElemMonad = RWS DatatypeMap [Element] [Element]
85−
86−-- | Marks the given type as processed.
87−proceed :: Text -> Datatype -> PreMonad ()
88−proceed t dt = do
89− tell [(t, dt)]
90− modify $ \(f,s) -> (M.delete t f, S.insert t s)
91−
92−-- | Marks element as processed.
93−proceed' :: Element -> PreElemMonad ()
94−proceed' el = do
95− tell [el]
96− modify $ L.delete el
97−
98−untwistDeps :: [Element] -> DatatypeMap -> ([(Text, Datatype)], [Element])
99−untwistDeps e dm = (dList, e')
100− where
101− dList = disambiguateNames . nub . execWriter $ do
102− (a, _) <- runStateT sortDatatypesByDeps (dm, S.empty)
103− return a
104− (_, e') = execRWS sortElemsByDeps (M.fromList dList) e
105−
106−type Abbreviation = Text
107−type Subelement = Text
108−type DisambiguaterMonad = State (M.Map Abbreviation (S.Set Subelement))
109−
110−-- | If any two datatypes with the same name abbreviation ('makeNamePrefix')
111−-- have any fields in common, then one of them gets a \"2\" appended to it
112−-- (\"_2\" if the last character of the name was a digit).
113−-- Repeat the same process until there are no conflicts.
114−-- If we have already appended a \"2\" to a datatype and it still has conflicts,
115−-- we change the 2 to a 3, a 3 to a 4 and so on.
116−disambiguateNames :: [(Text, Datatype)] -> [(Text, Datatype)]
117−disambiguateNames = flip evalState mempty . mapM disambiguateName
118− where
119− disambiguateName :: (Text, Datatype) -> DisambiguaterMonad (Text, Datatype)
120− disambiguateName (tyName', dt) = do
121− let rNames = S.fromList $ fields dt
122− (, dt) <$> attempt tyName' rNames 1
123− where
124− attempt :: Abbreviation -> S.Set Subelement -> Int -> DisambiguaterMonad Text
125− attempt tyName fieldNames n = do
126− processedTypes <- get
127− let
128− newTyName
129− | n == 1 = tyName
130− | shouldSeparateNumber = tyName <> "_" <> T.pack (show n)
131− | otherwise = tyName <> T.pack (show n)
132− abr = makeNamePrefix newTyName
133− case M.lookup abr processedTypes of
134− Just usedNames ->
135− if S.null $ S.intersection fieldNames usedNames
136− then modify (M.adjust (S.union fieldNames) abr) >> return newTyName
137− else attempt tyName fieldNames (n + 1)
138− Nothing -> modify (M.insert abr fieldNames) >> return newTyName
139− shouldSeparateNumber = isDigit $ T.last tyName'
140−
141−sortElemsByDeps :: PreElemMonad ()
142−sortElemsByDeps = do
143− els <- get
144− if Prelude.null els then pure () else do
145− let first = Prelude.head els
146− -- traceM $ "sortElemsByDeps: " <> show first
147− case references first of
148− [] -> proceed' first >> sortElemsByDeps
149− xs -> do
150− results <- traverse memberDatatype xs
151− if L.and results
152− then proceed' first >> sortElemsByDeps
153− else do
154− let failed = fmap snd $ L.filter (not . fst) $ L.zip results xs
155− error $ "impossible to lookup types: " <> show failed
156−
157−memberDatatype :: Text -> PreElemMonad Bool
158−memberDatatype ty = do
159− -- traceM $ "memberDatatype: " <> show ty
160− dm <- ask
161− case M.lookup ty dm of
162− Just _ -> return True
163− Nothing -> return False
164−
165−sortDatatypesByDeps :: PreMonad ()
166−sortDatatypesByDeps = do
167− (dm, _) <- get
168− if M.null dm then pure () else do
169− let first = Prelude.head (M.toList dm)
170− traceM $ "sortDatatypesByDeps: " <> show first
171− case references $ snd first of
172− [] -> uncurry proceed first >> sortDatatypesByDeps
173− xs -> do
174− traverse_ lookupDatatype xs
175− uncurry proceed first
176− sortDatatypesByDeps
177−
178−lookupDatatype :: Text -> PreMonad ()
179−lookupDatatype ty = do
180− traceM $ "lookupDatatype: " <> show ty
181− (dm, s) <- get
182− case M.lookup ty dm of
183− Nothing -> if S.member ty s then pure () else
184− error $ "can't look up datatype: " <> show ty
185− Just typ -> case references typ of
186− [] -> proceed ty typ
187− xs -> traverse_ lookupDatatype xs >> proceed ty typ
188−
189−class Capitalizable t where
190− capitalize :: t -> t
191−
192−instance Capitalizable String where
193− capitalize [] = []
194− capitalize (a:as) = C.toUpper a : as
195−
196−instance Capitalizable Text where
197− capitalize t
198− | T.null t = t
199− | otherwise = T.singleton (C.toUpper (T.head t)) <> T.tail t
200−
201−data DataFlavour = QQ | Plain
202−
203−-- TODO: improve after moving some XML types to xml-isogen
204−simpleTypeToIsoType :: DataFlavour -> SimpleAtomicType -> Text
205−simpleTypeToIsoType fl = \case
206− STAnyURI -> wrap fl "Text"
207− STBase64Binary -> wrap fl "ByteString"
208− STBoolean -> wrap fl "Bool"
209− STDate -> wrap fl "Date \"%YYYYj\""
210− STDateTime -> wrap fl "Text"
211− STDateTimeStamp -> wrap fl "Text"
212− STDecimal DTDecimal -> wrap fl "Double"
213− (STDecimal _) -> wrap fl "Integer"
214− STDouble -> wrap fl "Double"
215− (STDuration _) -> wrap fl "Integer"
216− STFloat -> wrap fl "Float"
217− STGDay -> wrap fl "Day"
218− STGMonth -> wrap fl "Text"
219− STGMonthDay -> wrap fl "Text"
220− STGYear -> wrap fl "Text"
221− STGYearMonth -> wrap fl "Text"
222− STHexBinary -> wrap fl "Text"
223− STNOTATION -> wrap fl "Text"
224− STQName -> wrap fl "Text"
225− (STString _) -> wrap fl "Text"
226− STTime -> wrap fl "Text"
227− where
228− wrap QQ t = "[t|" <> t <> "|]"
229− wrap Plain t = t
230−
231−tellGen
232− :: [Text] -- generated code
233− -> Text -- comment
234− -> GenMonad ()
235−tellGen code comment =
236− tell $ "\n" <> comment <> T.unlines code
237−
238−runGen :: DatatypeMap -> GenMonad a -> Text
239−runGen dm act = execWriter $ runReaderT act dm
240−
241−generateIsoXml :: Maybe Header -> ModuleName -> GenType -> XSD -> Text
242−generateIsoXml mHeader name genType (XSD (e,dm)) =
24+main :: IO ()
25+main = do
26+ opts <- getOptions
27+ schema <- Xsd.getSchema (oInput opts)
28+ res <- either fail return
29+ (generate opts schema)
30+ mapM_ (Text.hPutStrLn IO.stderr) (resultWarnings res)
31+ Text.putStrLn (resultCode res)
32+
33+data Result = Result
34+ { resultCode :: Text
35+ , resultWarnings :: [Text]
36+ }
37+
38+generate :: Options -> Xsd.Schema -> Either String Result
39+generate opts schema = do
40+ s <- runGen (initialGenState opts schema) $ do
41+ genHeader opts
42+ genTypes (Xsd.schemaTypes schema)
43+ genElements (Xsd.schemaElements schema)
44+ Right Result
45+ { resultCode = Text.unlines (reverse (gsCode s))
46+ , resultWarnings = reverse (gsWarnings s)
47+ }
48+
49+genTypes :: Map Xsd.QName Xsd.Type -> Gen ()
50+genTypes types = mapM_ (uncurry genTopType) . Map.toList $ types
51+
52+genElements :: Map Xsd.QName Xsd.Element -> Gen ()
53+genElements = mapM_ genElement
54+
55+genTopType :: Xsd.QName -> Xsd.Type -> Gen ()
56+genTopType = genType []
57+
58+genType :: [Xsd.Annotation] -> Xsd.QName -> Xsd.Type -> Gen ()
59+genType annotations name tp = do
60+ known <- knownTypeName name
61+ case known of
62+ Just _ -> return () -- already generated
63+ Nothing -> do
64+ -- we should generate dependencies before the type itself to make
65+ -- sure they are in scope when xml-isogen quotes them
66+ -- (stage restriction in TH)
67+ genDependencies tp
68+ typeName <- makeTypeName name tp
69+ case tp of
70+ Xsd.TypeSimple t -> genSimpleType typeName t annotations
71+ Xsd.TypeComplex t -> genComplexType typeName t annotations
72+
73+genDependencies :: References a => a -> Gen ()
74+genDependencies a = forM_ (references a) $ \name -> do
75+ known <- knownTypeName name
76+ case known of
77+ Just _ -> return () -- already generated
78+ Nothing -> do
79+ tp <- resolveType name
80+ genTopType name tp
81+
82+genSimpleType :: TypeName -> Xsd.SimpleType -> [Xsd.Annotation]-> Gen ()
83+genSimpleType tn (Xsd.AtomicType restriction ann) parentAnn = do
24384 let
244− (dList, el) = untwistDeps e dm
245− in (header mHeader name genType <>) . runGen dm $ do
246− for_ dList $ \(t,dt) ->
247− generateIsoDatatype genType t dt []
248− for_ el (generateIsoRecord genType)
249−
250−toQualifier :: Int -> Int -> Text
251−toQualifier minOc maxOc
252− | minOc == 1 && maxOc == 1 = "!"
253− | minOc == 0 && maxOc == 1 = "?"
254− | minOc == 1 && maxOc > minOc = "+"
255− | minOc == 1 && maxOc < minOc = error "maxOccurs < minOccurs"
256− | otherwise = "*"
257−
258−header :: Maybe Header -> ModuleName -> GenType -> Text
259−header mHeader name genType = T.unlines $
260− maybeToList (T.unlines . fmap ("-- " <>) . T.lines <$> mHeader) <>
261− [ "module " <> name <> " where"
85+ typeName = tnPrefixed tn
86+ fieldName = "un" <> typeName
87+ baseName r = case Xsd.restrictionBase r of
88+ Xsd.Ref n -> Just n
89+ Xsd.Inline (Xsd.AtomicType r' _) -> baseName r'
90+ Xsd.Inline (Xsd.ListType _ _) -> Nothing
91+ case baseName restriction of
92+ Nothing -> genUnsupported tn
93+ Just base -> do
94+ fieldTypeName <- resolveTypeName base
95+ mode <- getMode
96+ let
97+ toxml = case mode of
98+ Parser -> ""
99+ _ -> ", ToXML"
100+ writeCode $ makeComments tn (parentAnn <> ann)
101+ writeCode
102+ [ "newtype " <> typeName
103+ , " = " <> typeName
104+ , " { " <> fieldName <> " :: " <> fieldTypeName
105+ , " } deriving (Show, Eq, NFData" <> toxml <> ")"
106+ , ""
107+ ]
108+ unless (mode == Generator) $ writeCode
109+ [ "instance FromDom " <> typeName <> " where"
110+ , " fromDom = " <> typeName <> " <$> fromDom"
111+ , ""
112+ ]
113+
114+genSimpleType typeName (Xsd.ListType _ _) _ = genUnsupported typeName
115+
116+genComplexType :: TypeName -> Xsd.ComplexType -> [Xsd.Annotation] -> Gen ()
117+genComplexType typeName t parentAnn = do
118+ mode <- getMode
119+ let
120+ header = "\"" <> tnName typeName <> "\" =:= record "
121+ <> genTypeToText mode
122+ fields <- maybe (return []) (genFields typeName) (Xsd.complexModelGroup t)
123+ writeCode $ makeComments typeName
124+ (parentAnn <> Xsd.complexAnnotations t)
125+ writeCode [header]
126+ writeCode fields
127+ writeCode [""]
128+
129+makeComments :: TypeName -> [Xsd.Annotation] -> [Text]
130+makeComments typeName annotations =
131+ [ "{-"
132+ , "Generated from: " <> prefix <> name
262133 , ""
263− , "import Control.DeepSeq"
264− , "import Data.THGen.XML"
265− ] <> specImports <>
266− [ "import Prelude hiding ((*), (+))"
267− , "" ]
268− where
269− specImports = case genType of
270− Generator -> [ xmlWriter ]
271− Parser -> [ domParser ]
272− Both -> [ domParser, xmlWriter ]
273− xmlWriter, domParser :: Text
274− xmlWriter = "import Text.XML.Writer"
275− domParser = "import Text.XML.DOM.Parser.FromDom"
276−
277−quote :: Text -> Text
278−quote t = "\"" <> t <> "\""
279−
280−generateIsoRecord :: GenType -> Element -> GenMonad ()
281−generateIsoRecord
282− genType
283− (Element (_, laxName) elXtype _ _ elAnnotations) = do
284− written <- ask
285− case elXtype of
286− InlineComplex dt ->
287− generateIsoDatatype genType laxName dt elAnnotations
288− DatatypeRef nam -> if M.member nam written
289− then pure ()
290− else error $ "Implementation failure: "
291− <> show nam <> " type never encountered before"
292−
293−data CommentType = Haddock | Regular
294−
295−toComment :: CommentType -> [Annotation] -> Text
296−toComment ct ann = case texts of
297− [] -> ""
298− (h:tl) -> T.unlines ((prefix <> h) : fmap ("-- "<>) tl)
299− where
300− texts = stripTexts $ F.concatMap (wrap80 . fromDocumentation) ann
301− stripTexts = \case
302− [] -> []
303− l@(h:tl) -> if T.all (\x -> x == ' ' || x == '\n') h then stripTexts tl else l
304− prefix = case ct of
305− Haddock -> "-- | "
306− Regular -> "-- "
307−
308−fromDocumentation :: Annotation -> Text
309−fromDocumentation (Documentation t) = t
310−
311−wrap80 :: Text -> [Text]
312−wrap80 = L.foldl' go [] . T.split (==' ')
134+ ] <> map makeDoc annotations <>
135+ [ "-}"
136+ , ""
137+ ]
313138 where
314− go [] e = [e]
315− go l e =
316− let last' = L.last l
317− in if T.length last' + T.length e >= 73 -- 80 minus "-- | " and ' '
318− then l <> pure e
319− else L.init l <> [L.last l <> " " <> e]
320−
321−generateIsoDatatype
322− :: GenType
323− -> Text
324− -> Datatype
325− -> [Annotation]
326− -> GenMonad ()
327− -- ^ (type name for lookups, generated code)
328−generateIsoDatatype
329− genType
330− eName
331− (TypeComplex (ComplexType _ _ tyAnnotations mGroupSchema))
332− annotationsRec =
333− case mGroupSchema of
334− Just groupSchema -> case groupSchema of
335− CTSequence elements -> do
336− tyFields <- for elements (generateIsoField genType)
337− let
338− comment = toComment Haddock $ annotationsRec
339− <> [Documentation ""]
340− <> tyAnnotations
341− tyHeader =
342− quote (capitalize eName)
343− <> " =:= record "
344− <> genTypeToText genType
345− tellGen (tyHeader : tyFields) comment
346− CTChoice _ -> error "'Choice' group not supported yet"
347− CTAll _ -> error "'All' group not supported yet"
348− Nothing -> error $ "No group schema provided for type: " <> T.unpack eName
349−generateIsoDatatype
350− genType
351− eName
352− (TypeSimple ty@(STAtomic iName sat tyAnnotations restrictions))
353− annotationsRec = do
354− let
355− comment =
356− toComment Haddock $ annotationsRec
357− <> [Documentation ""]
358− <> tyAnnotations
359− if not (shouldBeNewtype ty)
360− then tellGen
361− (generateEnum
362− (quote $ capitalize eName)
363− (getEnumeratedCode restrictions))
364− comment
365− else
366− tellGen (generateNewtype genType iName sat) comment
367−
368−getEnumeratedCode :: [Restriction] -> [Text]
369−getEnumeratedCode = F.concatMap fromEnumeration . Prelude.filter isEnumeration
139+ qname = tnQName typeName
140+ name = Xsd.qnName qname
141+ prefix = maybe "" ((<> ":") . Xsd.fromNamespace) (Xsd.qnNamespace qname)
142+ makeDoc (Xsd.Documentation docs) = docs
143+
144+-- | Generate code for record fields
145+--
146+-- The first argument - record name
147+genFields :: TypeName -> Xsd.ModelGroup -> Gen [Text]
148+genFields typeName (Xsd.Sequence elements) =
149+ catMaybes <$> mapM (genField typeName) elements
150+genFields _ (Xsd.Choice _) = do
151+ warn "choice: not implemented"
152+ return []
153+genFields _ (Xsd.All _) = do
154+ warn "all: not implemented"
155+ return []
156+
157+genField :: TypeName -> Xsd.Element -> Gen (Maybe Text)
158+genField typeName e = do
159+ fieldName <- makeFieldName typeName (Xsd.elementName e)
160+
161+ fieldTypeName <- case Xsd.elementType e of
162+ Xsd.Ref name -> resolveTypeName name
163+ Xsd.Inline t -> do
164+ genType (Xsd.elementAnnotations e) (Xsd.elementName e) t
165+ resolveTypeName (Xsd.elementName e)
166+
167+ qualifier <- makeQualifier (Xsd.elementOccurs e)
168+
169+ return $ Just $ mconcat
170+ [ " "
171+ , qualifier
172+ , " \""
173+ , fieldName
174+ , "\" [t|"
175+ , fieldTypeName
176+ , "|]"
177+ ]
178+
179+makeQualifier :: (Int, Xsd.MaxOccurs) -> Gen Text
180+makeQualifier (minOcc, maxOcc) = case maxOcc of
181+ Xsd.MaxOccursUnbound -> toQualifier minOcc maxBound
182+ Xsd.MaxOccurs v -> toQualifier minOcc v
183+
184+toQualifier :: Int -> Int -> Gen Text
185+toQualifier 1 1 = return "!"
186+toQualifier 0 1 = return "?"
187+toQualifier 1 maxOcc
188+ | maxOcc < 1
189+ = genError "maxOccurs < minOccurs"
190+toQualifier 1 maxOcc
191+ | maxOcc > 1
192+ = return "+"
193+toQualifier _ _ = return "*"
194+
195+genUnsupported :: TypeName -> Gen ()
196+genUnsupported tn = do
197+ let typeName = tnPrefixed tn
198+ warn $ "generating stub for unsupported construct in " <> typeName
199+ mode <- getMode
200+ writeCode (makeComments tn [])
201+ writeCode
202+ [ "data " <> typeName <> " = " <> typeName
203+ , " deriving (Eq, Show)"
204+ , ""
205+ , "instance NFData " <> typeName <> " where"
206+ , " rnf _ = ()"
207+ , ""
208+ ]
209+
210+ unless (mode == Parser) $ writeCode
211+ [ "instance ToXML " <> typeName <> " where"
212+ , " toXML _ = comment \"" <> typeName <> "\""
213+ , ""
214+ ]
215+
216+ unless (mode == Generator) $ writeCode
217+ [ "instance FromDom " <> typeName <> " where"
218+ , " fromDom = undefined"
219+ , ""
220+ ]
221+
222+genElement :: Xsd.Element -> Gen ()
223+genElement e = case Xsd.elementType e of
224+ Xsd.Ref _ -> return ()
225+ Xsd.Inline t -> genType (Xsd.elementAnnotations e) (Xsd.elementName e) t
226+
227+genHeader :: Options -> Gen ()
228+genHeader opts = do
229+ case oHeader opts of
230+ Nothing -> return ()
231+ Just h -> do
232+ writeCode . fmap ("-- " <>) . Text.lines $ h
233+ writeCode [""]
234+
235+ writeCode
236+ [ "module " <> oModule opts <> " where"
237+ , ""
238+ , "import Control.DeepSeq"
239+ , "import Data.THGen.XML"
240+ ]
241+ writeCode imports
242+ writeCode
243+ [ "import Prelude hiding ((*), (+))"
244+ , ""
245+ , ""
246+ ]
370247 where
371− fromEnumeration (Enumeration x) = x
372−
373−isEnumeration :: Restriction -> Bool
374−isEnumeration (Enumeration _) = True
375−
376−shouldBeNewtype :: SimpleType -> Bool
377−shouldBeNewtype (STAtomic _ _ _ restrictions) =
378− not . Prelude.any isEnumeration $ restrictions
379−
380−getNewtypeConsName :: Text -> Text
381−getNewtypeConsName = ("Xml" <>) . capitalize
382−
383−getNewtypeUnconsName :: Text -> Text
384−getNewtypeUnconsName = ("un" <>) . getNewtypeConsName
385−
386−generateNewtype :: GenType -> Text -> SimpleAtomicType -> [Text]
387−generateNewtype genType n sat =
388− let
389− constructor = getNewtypeConsName n
390− decons = getNewtypeUnconsName n
391− parser =
392− [ ""
393− , "instance FromDom " <> constructor <> " where"
394− , " fromDom = " <> constructor <> " <$> fromDom"
395− ]
396− in
397− [ "newtype " <> constructor
398− , " = " <> constructor
399− , " { " <> decons <> " :: " <> simpleTypeToIsoType Plain sat
400− , " } deriving (Show, Eq, NFData" <> case genType of
401− Parser -> ")"
402− _ -> ", ToXML)"
403− ] <> case genType of
404− Generator -> []
405− _ -> parser
406−
407−generateEnum
408− :: Text -- type name
409− -> [Text] -- enums
410− -> [Text] -- generated code
411−generateEnum enumName enums =
412− let
413− enumHeader = enumName <> " Exhaustive =:= enum Both"
414− eFields = ("& "<>) <$> enums
415− in pure enumHeader <> eFields
416−
417−lookupSimpleType
418− :: DatatypeRef
419− -> GenMonad (Maybe Text)
420−lookupSimpleType (InlineComplex _) = pure Nothing
421−lookupSimpleType (DatatypeRef tyName) =
422− asks (M.lookup tyName) >>= \case
423− Just (TypeComplex _) -> pure Nothing
424− Just (TypeSimple (STAtomic nam _ _ _)) -> pure $ Just nam
425− Nothing -> error $ "can't look up type: " <> show tyName
426−
427−generateIsoField :: GenType -> Element -> GenMonad Text
428−generateIsoField
429− genType
430− (Element (_, fieldName) fieldXtype minOc maxOc fieldAnnotations) = do
431− let
432− qualifier = toQualifier minOc maxOc
433− line <- lookupSimpleType fieldXtype >>= \case
434− Just tyName ->
435− pure $ quote fieldName <> " [t|Xml" <> tyName <> "|]"
436− Nothing -> case fieldXtype of
437− InlineComplex dt -> do
438− generateIsoDatatype genType (capitalize fieldName) dt fieldAnnotations
439− pure $ quote fieldName
440− DatatypeRef ref ->
441− pure $ quote fieldName <> " [t|Xml" <> capitalize ref <> "|]"
442− pure $ " " <> qualifier <> " " <> line
443−
444−main :: IO ()
445−main = do
446− Options{..} <- getOptions
447− xml <- BL.readFile oInput
448− let
449− xsd = case parseXSD def xml of
450− Right xsd' -> xsd'
451− Left e -> error $ show e
452− T.hPutStrLn stdout $ generateIsoXml oHeader oModule oMode xsd
248+ imports = case oMode opts of
249+ Generator -> [ xmlWriter ]
250+ Parser -> [ domParser ]
251+ Both -> [ domParser, xmlWriter ]
252+ xmlWriter = "import Text.XML.Writer"
253+ domParser = "import Text.XML.DOM.Parser.FromDom"
254+
255+-- | We populate the initial state with all built-in types to make sure
256+-- they will be correctly resolved
257+initialGenState :: Options -> Xsd.Schema -> GenState
258+initialGenState opts schema = GenState
259+ { gsTypes = Xsd.schemaTypes schema
260+ , gsKnownTypes = builtInTypes
261+ , gsBoundTypeName = Set.empty
262+ , gsBoundFields = Set.empty
263+ , gsMode = oMode opts
264+ , gsCode = []
265+ , gsWarnings = []
266+ }