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