@@ -1,450 +1,407 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE LambdaCase #-}
1{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
8−import Data.Text (Text)
9+import Control.Monad.RWS.CPS (RWS, execRWS)
9−import qualified Data.Text as Text
10+import Control.Monad.Reader
11+import Control.Monad.State.Strict
12+import Control.Monad.Writer.CPS (Writer, tell, execWriter)
13+import Data.ByteString.Lazy as BL
10−import qualified Data.Text.IO as Text
14+import Data.Char as C
11−import Data.Maybe
15+import Data.Default
16+import Data.Foldable as F
12−import qualified Data.List as List
17+import Data.List as L
18+import Data.Map.Strict as M
13−import qualified Data.Set as Set
19+import Data.Set as S
14−import Data.Map (Map)
20+import Data.Text as T
15−import qualified Data.Map as Map
21+import Data.Text.IO as T
16−import Control.Monad
22+import Data.Traversable
17−import qualified System.IO as IO
23+import Debug.Trace
18−import qualified Xsd
24+import System.Environment
20−import Options
26+import Text.XSD
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]
22−import References
42+instance References Datatype where
23−import BuiltInTypes
43+ references (TypeComplex (ComplexType _ _ _ mmgs)) =
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 <> "|]"
25−main :: IO ()
178+tellGen
26−main = do
179+ :: [Text] -- generated code
27− opts <- getOptions
180+ -> Text -- comment
28− schema <- Xsd.getSchema (oInput opts)
181+ -> GenMonad ()
29− res <- either fail return
182+tellGen code comment =
30− (generate opts schema)
183+ tell $ "\n" <> comment <> T.unlines code
31− mapM_ (Text.hPutStrLn IO.stderr) (resultWarnings res)
184+
32− Text.putStrLn (resultCode res)
185+runGen :: DatatypeMap -> GenMonad a -> Text
33−
186+runGen dm act = execWriter $ runReaderT act dm
34−data Result = Result
187+
35− { resultCode :: Text
188+generateIsoXml :: GenType -> XSD -> Text
36− , resultWarnings :: [Text]
189+generateIsoXml genType (XSD (e,dm)) =
39−generate :: Options -> Xsd.Schema -> Either String Result
40−generate opts schema = do
42− types = Map.union (Xsd.schemaTypes schema)
191+ (dList, el) = untwistDeps e dm
43− (elementsToTypes (Xsd.schemaElements schema))
192+ in (header genType <>) . runGen dm $ do
44− s <- runGen (initialGenState opts types) $ do
193+ for_ dList $ \(t,dt) ->
45− genHeader opts
194+ generateIsoDatatype genType t dt []
46− genTypes types
195+ for_ el (generateIsoRecord genType)
48− { resultCode = Text.unlines (reverse (gsCode s))
197+toQualifier :: Int -> Int -> Text
49− , resultWarnings = reverse (gsWarnings s)
198+toQualifier minOc maxOc
50− }
199+ | minOc == 1 && maxOc == 1 = "!"
51−
200+ | minOc == 0 && maxOc == 1 = "?"
52−elementsToTypes :: Map Xsd.QName Xsd.Element -> Map Xsd.QName Xsd.Type
201+ | minOc == 1 && maxOc > minOc = "+"
53−elementsToTypes = List.foldl' step Map.empty . Map.toList
202+ | minOc == 1 && maxOc < minOc = error "maxOccurs < minOccurs"
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 (==' ')
55− step types (_, e) = case Xsd.elementType e of
269+ go [] e = [e]
56− Xsd.Ref _ -> types
270+ go l e =
57− Xsd.Inline t -> Map.insert (Xsd.elementName e) t types
271+ let last' = L.last l
58−
272+ in if T.length last' + T.length e >= 73 -- 80 minus "-- | " and ' '
59−genTypes :: Map Xsd.QName Xsd.Type -> Gen ()
273+ then l <> pure e
60−genTypes types = mapM_ (uncurry genTopType) . Map.toList $ types
274+ else L.init l <> [L.last l <> " " <> e]
62−genTopType :: Xsd.QName -> Xsd.Type -> Gen ()
276+generateIsoDatatype
63−genTopType = genType []
277+ :: GenType
64−
278+ -> (Maybe Text) -- ^ Explicitly provided name, used for inline complexType's
65−genType :: [Xsd.Annotation] -> Xsd.QName -> Xsd.Type -> Gen ()
280+ -> [Annotation]
66−genType annotations name tp = do
281+ -> GenMonad ()
67− known <- knownTypeName name
282+ -- ^ (type name for lookups, generated code)
68− case known of
283+generateIsoDatatype
69− Just _ -> return () -- already generated
284+ genType
70− Nothing -> do
285+ eName
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
78− Xsd.TypeComplex t -> genComplexType typeName t annotations
286+ (TypeComplex (ComplexType iName attrs annotations mGroupSchema))
79− genExtension name
287+ annotationsRec = do
81−genExtension :: Xsd.QName -> Gen ()
82−genExtension base = do
83− exts <- extensions base
84− case exts of
288+ name <- case eName of
85− [] -> return ()
289+ Just name -> pure name
86− types -> do
290+ Nothing -> case iName of
87− mapM_ (uncurry genTopType) types
291+ Just name' -> pure name'
88− baseTypeName <- tnPrefixed <$> resolveTypeName base
292+ Nothing -> error $ "[generateIsoDatatype] no name was provided"
89− writeCode
293+ case mGroupSchema of
90− [ "data Any" <> baseTypeName
294+ Just groupSchema -> case groupSchema of
91− , " = The" <> baseTypeName <> " !" <> baseTypeName
295+ CTSequence elems -> do
92− ]
296+ fields <- for elems (generateIsoField genType)
94− mkConstructor (n, _) = do
95− tn <- tnPrefixed <$> resolveTypeName n
96− exts' <- extensions n
98− n' = case exts' of
298+ comment = toComment Haddock $ annotationsRec
99− [] -> tn
299+ <> [Documentation ""]
100− _ -> "Any" <> tn
300+ <> annotations
101− return (" | The" <> n' <> " !" <> n')
301+ header =
102− constructors <- mapM mkConstructor types
302+ (quote $ capitalize name)
103− writeCode constructors
303+ <> " =:= record "
104− writeCode
304+ <> genTypeToText genType
105− [ " deriving (Eq, Show)"
305+ tellGen (header : fields) comment
106− , ""
306+generateIsoDatatype
109− [ "instance NFData Any" <> baseTypeName <> " where"
309+ (TypeSimple (STAtomic iName sat annotations restrictions))
110− , " rnf = rwhnf"
310+ annotationsRec = do
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
185− case known of
311+ name <- case eName of
186− Just _ -> return () -- already generated
312+ Just name -> pure name
187− Nothing -> do
313+ Nothing -> pure iName
188− tp <- resolveType name
314+ let
189− genTopType name tp
315+ comment =
190−
316+ toComment Haddock $ annotationsRec
191−genSimpleType :: TypeName -> Xsd.SimpleType -> [Xsd.Annotation]-> Gen ()
317+ <> [Documentation ""]
192−genSimpleType tn (Xsd.AtomicType restriction ann) parentAnn = do
318+ <> annotations
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 =
194− baseName r = case Xsd.simpleRestrictionBase r of
335+ cons = "Xml" <> capitalize n
195− Xsd.Ref n -> Just n
336+ decons = "un" <> cons
196− Xsd.Inline (Xsd.AtomicType r' _) -> baseName r'
337+ parser =
197− Xsd.Inline (Xsd.ListType _ _) -> Nothing
338+ [ ""
198− Xsd.Inline (Xsd.UnionType _ _) -> Nothing
339+ , "instance FromDom " <> cons <> " where"
199− case baseName restriction of
340+ , " fromDom = " <> cons <> " <$> fromDom"
201− | isEnum restriction
342+ in
202− -> genEnum tn
343+ [ "newtype " <> cons
203− (Xsd.simpleRestrictionConstraints restriction)
344+ , " = " <> cons
204− (parentAnn <> ann)
345+ , " { " <> decons <> " :: " <> simpleTypeToIsoType Plain sat
205− Just base ->
346+ , " } deriving (Show, Eq, NFData" <> case genType of
206− genNewtype tn base (parentAnn <> ann)
347+ Parser -> ")"
207− _ -> genUnsupported tn
348+ _ -> ", ToXML)"
208−genSimpleType typeName (Xsd.ListType _ _) _ = genUnsupported typeName
349+ ] <> case genType of
209−genSimpleType typeName (Xsd.UnionType _ _) _ = genUnsupported typeName
350+ Generator -> []
211−genNewtype :: TypeName -> Xsd.QName -> [Xsd.Annotation] -> Gen ()
352+
212−genNewtype tn base annots = do
353+generateEnum
213− fieldTypeName <- tnPrefixed <$> resolveTypeName base
354+ :: Text -- type name
214− mode <- getMode
355+ -> [Text] -- enums
356+ -> [Text] -- generated code
357+generateEnum enumName enums =
216− typeName = tnPrefixed tn
359+ enumHeader = enumName <> " Exhaustive =:= enum Both"
217− fieldName = "un" <> typeName
360+ eFields = ("& "<>) <$> enums
218− toxml = case mode of
361+ in pure enumHeader <> eFields
220− _ -> ", ToXML"
363+-- | Returns Just baseTypeName if type is simple, Nothing - otherwise
221− writeCode $ makeComments tn annots
364+lookupSimpleBaseType
222− writeCode
365+ :: DatatypeRef
223− [ "newtype " <> typeName
366+ -> GenMonad (Maybe SimpleAtomicType)
224− , " = " <> typeName
367+lookupSimpleBaseType (InlineComplex _) = pure Nothing
225− , " { " <> fieldName <> " :: " <> fieldTypeName
368+lookupSimpleBaseType (DatatypeRef tyName) = do
226− , " } deriving (Show, Eq, NFData" <> toxml <> ")"
369+ M.lookup tyName <$> ask >>= \case
227− , ""
370+ Just (TypeComplex _) -> pure Nothing
228− ]
371+ Just (TypeSimple (STAtomic _ sat _ _)) -> pure $ Just sat
229− unless (mode == Generator) $ writeCode
372+ Nothing -> error $ "can't look up type: " <> show tyName
230− [ "instance FromDom " <> typeName <> " where"
373+
231− , " fromDom = " <> typeName <> " <$> fromDom"
374+lookupSimpleType
232− , ""
375+ :: DatatypeRef
233− ]
376+ -> GenMonad (Maybe Text)
234−
377+lookupSimpleType (InlineComplex _) = pure Nothing
235−genEnum :: TypeName -> [Xsd.Constraint] -> [Xsd.Annotation] -> Gen ()
378+lookupSimpleType (DatatypeRef tyName) =
236−genEnum tn constraints annots = do
379+ asks (M.lookup tyName) >>= \case
237− mode <- getMode
380+ Just (TypeComplex _) -> pure Nothing
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
239− values = map toValue constraints
387+ qualifier = toQualifier minOc maxOc
240− toValue (Xsd.Enumeration v) = v
388+ line <- lookupSimpleType xtype >>= \case
241− enumLines <- forM values $ \v -> do
389+ Just tyName -> do
242− enumName <- makeEnumName v
390+ pure $ quote name <> " [t|Xml" <> tyName <> "|]"
243− return (" & \"" <> enumName <> "\"")
391+ Nothing -> case xtype of
244− writeCode $ makeComments tn annots
392+ InlineComplex dt -> do
245− writeCode $ "\"" <> tnName tn <> "\" Exhaustive =:= enum "
393+ generateIsoDatatype genType (Just $ capitalize name) dt annotations
246− <> genTypeToText mode : enumLines
394+ pure $ quote name
247− writeCode [""]
395+ DatatypeRef ref ->
248−
396+ pure $ quote name <> " [t|Xml" <> capitalize ref <> "|]"
249−isEnum :: Xsd.SimpleRestriction -> Bool
397+ pure $ " " <> qualifier <> " " <> line
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
336− fieldType = if Xsd.elementNillable e
404+ xsd = case parseXSD def xml of
337− then "Nillable " <> fieldTypeName
405+ Right xsd' -> xsd'
338− else fieldTypeName
406+ Left e -> error $ show e
339−
407+ T.hPutStrLn stdout $ generateIsoXml (read mode) xsd
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)