@@ -1,450 +1,407 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE LambdaCase #-}
13{-# LANGUAGE OverloadedStrings #-}
24
35module 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
6+ ( main
7+ ) where
8+
9+import Control.Monad.RWS.CPS (RWS, execRWS)
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
14+import Data.Char as C
15+import Data.Default
16+import Data.Foldable as F
17+import Data.List as L
18+import Data.Map.Strict as M
19+import Data.Set as S
20+import Data.Text as T
21+import Data.Text.IO as T
22+import Data.Traversable
23+import Debug.Trace
24+import System.Environment
25+import System.IO
26+import Text.XSD
27+
28+
29+data GenType = Parser | Generator | Both
30+ deriving (Read, Show)
31+
32+genTypeToText :: GenType -> Text
33+genTypeToText Parser = "Parser"
34+genTypeToText Generator = "Generator"
35+genTypeToText Both = "Both"
36+
37+type GenMonad = ReaderT DatatypeMap (Writer Text)
38+
39+class References a where
40+ references :: a -> [Text]
41+
42+instance References Datatype where
43+ references (TypeComplex (ComplexType _ _ _ mmgs)) =
44+ case mmgs of
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
49+ Nothing -> []
50+ references (TypeSimple _) = []
51+
52+instance References Element where
53+ references (Element _ t _ _ _) = references t
54+
55+instance References DatatypeRef where
56+ references (DatatypeRef ty) = [ty]
57+ references (InlineComplex dt) = references dt
58+
59+instance References a => References [a] where
60+ references = F.concatMap references
61+
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)])
65+
66+type PreElemMonad = RWS DatatypeMap [Element] [Element]
67+
68+-- | Marks the given type as processed.
69+proceed :: Text -> Datatype -> PreMonad ()
70+proceed t dt = do
71+ tell [(t, dt)]
72+ modify $ \(f,s) -> (M.delete t f, S.insert t s)
73+
74+-- | Marks element as processed.
75+proceed' :: Element -> PreElemMonad ()
76+proceed' el = do
77+ tell [el]
78+ modify $ L.delete el
79+
80+untwistDeps :: [Element] -> DatatypeMap -> ([(Text, Datatype)], [Element])
81+untwistDeps e dm = (dList, e')
82+ where
83+ dList = nub $ execWriter $ do
84+ (a, _) <- runStateT sortDatatypesByDeps (dm, S.empty)
85+ return a
86+ (_, e') = execRWS sortElemsByDeps (M.fromList dList) e
87+
88+sortElemsByDeps :: PreElemMonad ()
89+sortElemsByDeps = do
90+ els <- get
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
96+ xs -> do
97+ results <- traverse memberDatatype xs
98+ if L.and results
99+ then proceed' first >> sortElemsByDeps
100+ else do
101+ let failed = fmap snd $ L.filter (not . fst) $ L.zip results xs
102+ error $ "impossible to lookup types: " <> show failed
103+
104+memberDatatype :: Text -> PreElemMonad Bool
105+memberDatatype ty = do
106+ -- traceM $ "memberDatatype: " <> show ty
107+ dm <- ask
108+ case M.lookup ty dm of
109+ Just _ -> return True
110+ Nothing -> return False
111+
112+sortDatatypesByDeps :: PreMonad ()
113+sortDatatypesByDeps = do
114+ (dm, _) <- get
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
120+ xs -> do
121+ traverse_ lookupDatatype xs
122+ uncurry proceed first
123+ sortDatatypesByDeps
124+
125+lookupDatatype :: Text -> PreMonad ()
126+lookupDatatype ty = do
127+ traceM $ "lookupDatatype: " <> show ty
128+ (dm, s) <- get
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
135+
136+class Capitalizable t where
137+ capitalize :: t -> t
138+
139+instance Capitalizable String where
140+ capitalize [] = []
141+ capitalize (a:as) = C.toUpper a : as
142+
143+instance Capitalizable Text where
144+ capitalize t
145+ | T.null t = t
146+ | otherwise = T.singleton (C.toUpper (T.head t)) <> T.tail t
147+
148+data DataFlavour = QQ | Plain
149+
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"
174+ where
175+ wrap QQ t = "[t|" <> t <> "|]"
176+ wrap Plain t = t
24177
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
178+tellGen
179+ :: [Text] -- generated code
180+ -> Text -- comment
181+ -> GenMonad ()
182+tellGen code comment =
183+ tell $ "\n" <> comment <> T.unlines code
184+
185+runGen :: DatatypeMap -> GenMonad a -> Text
186+runGen dm act = execWriter $ runReaderT act dm
187+
188+generateIsoXml :: GenType -> XSD -> Text
189+generateIsoXml genType (XSD (e,dm)) =
41190 let
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
191+ (dList, el) = untwistDeps e dm
192+ in (header genType <>) . runGen dm $ do
193+ for_ dList $ \(t,dt) ->
194+ generateIsoDatatype genType t dt []
195+ for_ el (generateIsoRecord genType)
196+
197+toQualifier :: Int -> Int -> Text
198+toQualifier minOc maxOc
199+ | minOc == 1 && maxOc == 1 = "!"
200+ | minOc == 0 && maxOc == 1 = "?"
201+ | minOc == 1 && maxOc > minOc = "+"
202+ | minOc == 1 && maxOc < minOc = error "maxOccurs < minOccurs"
203+ | otherwise = "*"
204+
205+header :: GenType -> Text
206+header genType = T.unlines $
207+ [ "module Dummy where"
208+ , ""
209+ , "import Control.DeepSeq"
210+ , "import Data.THGen.XML"
211+ ] <> specImports <>
212+ [ "import Prelude hiding ((*), (+))"
213+ , "" ]
214+ where
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"
222+
223+quote :: Text -> Text
224+quote t = "\"" <> t <> "\""
225+
226+-- | Nothing means unknown name
227+typeName :: DatatypeRef -> Maybe Text
228+typeName (InlineComplex dt) = result
229+ where
230+ result = case dt of
231+ TypeComplex (ComplexType n _ _ _) -> n
232+ TypeSimple (STAtomic _ sat _ _) -> Just $ simpleTypeToIsoType QQ sat
233+typeName (DatatypeRef t) = Just t
234+
235+generateIsoRecord :: GenType -> Element -> GenMonad ()
236+generateIsoRecord
237+ genType
238+ (Element (_, laxName) elXtype _ _ elAnnotations) = do
239+ written <- ask
240+ case elXtype of
241+ InlineComplex dt ->
242+ generateIsoDatatype genType laxName dt elAnnotations
243+ DatatypeRef nam -> if M.member nam written
244+ then pure ()
245+ else error $ "Implementation failure: "
246+ <> show nam <> " type never encountered before"
247+
248+data CommentType = Haddock | Regular
249+
250+toComment :: CommentType -> [Annotation] -> Text
251+toComment ct ann = case texts of
252+ [] -> ""
253+ (h:tl) -> T.unlines ((prefix <> h) : fmap ("-- "<>) tl)
254+ where
255+ texts = stripTexts $ F.concatMap (wrap80 . fromDocumentation) ann
256+ stripTexts = \case
257+ [] -> []
258+ l@(h:tl) -> if T.all (\x -> x == ' ' || x == '\n') h then stripTexts tl else l
259+ prefix = case ct of
260+ Haddock -> "-- | "
261+ Regular -> "-- "
262+
263+fromDocumentation :: Annotation -> Text
264+fromDocumentation (Documentation t) = t
265+
266+wrap80 :: Text -> [Text]
267+wrap80 = L.foldl' go [] . T.split (==' ')
54268 where
55− step types (_, e) = case Xsd.elementType e of
56− Xsd.Ref _ -> types
57− Xsd.Inline t -> Map.insert (Xsd.elementName e) t types
58−
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
269+ go [] e = [e]
270+ go l e =
271+ let last' = L.last l
272+ in if T.length last' + T.length e >= 73 -- 80 minus "-- | " and ' '
273+ then l <> pure e
274+ else L.init l <> [L.last l <> " " <> e]
275+
276+generateIsoDatatype
277+ :: GenType
278+ -> (Maybe Text) -- ^ Explicitly provided name, used for inline complexType's
279+ -> Datatype
280+ -> [Annotation]
281+ -> GenMonad ()
282+ -- ^ (type name for lookups, generated code)
283+generateIsoDatatype
284+ genType
285+ eName
286+ (TypeComplex (ComplexType iName attrs annotations mGroupSchema))
287+ annotationsRec = do
288+ name <- case eName of
289+ Just name -> pure name
290+ Nothing -> case iName of
291+ Just name' -> pure name'
292+ Nothing -> error $ "[generateIsoDatatype] no name was provided"
293+ case mGroupSchema of
294+ Just groupSchema -> case groupSchema of
295+ CTSequence elems -> do
296+ fields <- for elems (generateIsoField genType)
97297 let
98− n' = case exts' of
99− [] -> tn
100− _ -> "Any" <> tn
101− return (" | The" <> n' <> " !" <> n')
102− constructors <- mapM mkConstructor types
103− writeCode constructors
104− writeCode
105− [ " deriving (Eq, Show)"
106− , ""
107− ]
108− writeCode
109− [ "instance NFData Any" <> baseTypeName <> " where"
110− , " rnf = rwhnf"
111− , " "
112− ]
113− mode <- getMode
114− unless (mode == Generator) $ do
115− writeCode
116− [ "instance FromDom Any" <> baseTypeName <> " where"
117− , " fromDom = do"
118− , " tp <- parseAttribute"
119− , " (matchName " <>
120− "\"{http://www.w3.org/2001/XMLSchema-instance}type\")"
121− , " Right"
122− , " case tp of"
123− ]
124− let
125− mkClause n = do
126− tn <- resolveTypeName n
127− exts' <- extensions n
128− n' <- case exts' of
129− [] -> return (tnPrefixed tn)
130− _ | n == base -> return (tnPrefixed tn)
131− _ -> return ("Any" <> tnPrefixed tn)
132− return $ mconcat
133− [ " \""
134− , tnName tn
135− , "\" -> The"
136− , n'
137− , " <$> fromDom"
138− ]
139− clauses <- mapM mkClause (base : map fst types)
140− writeCode clauses
141− writeCode
142− [ " _ -> 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
298+ comment = toComment Haddock $ annotationsRec
299+ <> [Documentation ""]
300+ <> annotations
301+ header =
302+ (quote $ capitalize name)
303+ <> " =:= record "
304+ <> genTypeToText genType
305+ tellGen (header : fields) comment
306+generateIsoDatatype
307+ genType
308+ eName
309+ (TypeSimple (STAtomic iName sat annotations restrictions))
310+ annotationsRec = do
311+ name <- case eName of
312+ Just name -> pure name
313+ Nothing -> pure iName
314+ let
315+ comment =
316+ toComment Haddock $ annotationsRec
317+ <> [Documentation ""]
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
324+ then tellGen
325+ (generateEnum
326+ (quote $ capitalize name)
327+ (F.concatMap fromEnumeration enums))
328+ comment
329+ else
330+ tellGen (generateNewtype genType iName sat) comment
331+
332+generateNewtype :: GenType -> Text -> SimpleAtomicType -> [Text]
333+generateNewtype genType n sat =
193334 let
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
335+ cons = "Xml" <> capitalize n
336+ decons = "un" <> cons
337+ parser =
338+ [ ""
339+ , "instance FromDom " <> cons <> " where"
340+ , " fromDom = " <> cons <> " <$> fromDom"
341+ ]
342+ in
343+ [ "newtype " <> cons
344+ , " = " <> cons
345+ , " { " <> decons <> " :: " <> simpleTypeToIsoType Plain sat
346+ , " } deriving (Show, Eq, NFData" <> case genType of
347+ Parser -> ")"
348+ _ -> ", ToXML)"
349+ ] <> case genType of
350+ Generator -> []
351+ _ -> parser
352+
353+generateEnum
354+ :: Text -- type name
355+ -> [Text] -- enums
356+ -> [Text] -- generated code
357+generateEnum enumName enums =
215358 let
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
359+ enumHeader = enumName <> " Exhaustive =:= enum Both"
360+ eFields = ("& "<>) <$> enums
361+ in pure enumHeader <> eFields
362+
363+-- | Returns Just baseTypeName if type is simple, Nothing - otherwise
364+lookupSimpleBaseType
365+ :: DatatypeRef
366+ -> GenMonad (Maybe SimpleAtomicType)
367+lookupSimpleBaseType (InlineComplex _) = pure Nothing
368+lookupSimpleBaseType (DatatypeRef tyName) = do
369+ M.lookup tyName <$> ask >>= \case
370+ Just (TypeComplex _) -> pure Nothing
371+ Just (TypeSimple (STAtomic _ sat _ _)) -> pure $ Just sat
372+ Nothing -> error $ "can't look up type: " <> show tyName
373+
374+lookupSimpleType
375+ :: DatatypeRef
376+ -> GenMonad (Maybe Text)
377+lookupSimpleType (InlineComplex _) = pure Nothing
378+lookupSimpleType (DatatypeRef tyName) =
379+ asks (M.lookup tyName) >>= \case
380+ Just (TypeComplex _) -> pure Nothing
381+ Just (TypeSimple (STAtomic nam _ _ _)) -> pure $ Just nam
382+ Nothing -> error $ "can't look up type: " <> show tyName
383+
384+generateIsoField :: GenType -> Element -> GenMonad Text
385+generateIsoField genType (Element (_, name) xtype minOc maxOc annotations) = do
238386 let
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)
387+ qualifier = toQualifier minOc maxOc
388+ line <- lookupSimpleType xtype >>= \case
389+ Just tyName -> do
390+ pure $ quote name <> " [t|Xml" <> tyName <> "|]"
391+ Nothing -> case xtype of
392+ InlineComplex dt -> do
393+ generateIsoDatatype genType (Just $ capitalize name) dt annotations
394+ pure $ quote name
395+ DatatypeRef ref ->
396+ pure $ quote name <> " [t|Xml" <> capitalize ref <> "|]"
397+ pure $ " " <> qualifier <> " " <> line
334398
399+main :: IO ()
400+main = do
401+ (inFile:mode:_) <- getArgs
402+ xml <- BL.readFile inFile
335403 let
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
404+ xsd = case parseXSD def xml of
405+ Right xsd' -> xsd'
406+ Left e -> error $ show e
407+ T.hPutStrLn stdout $ generateIsoXml (read mode) xsd