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