@@ -23,6 +23,14 @@ import System.IO
2323import Text.XSD
2424
2525
26+data GenType = Parser | Generator | Both
27+ deriving (Read, Show)
28+
29+genTypeToText :: GenType -> Text
30+genTypeToText Parser = "Parser"
31+genTypeToText Generator = "Generator"
32+genTypeToText Both = "Both"
33+
2634type GenMonad = ReaderT DatatypeMap (Writer Text)
2735
2836class References a where
@@ -166,14 +174,14 @@ tellGen code comment = do
166174runGen :: DatatypeMap -> GenMonad a -> Text
167175runGen dm act = execWriter $ runReaderT act dm
168176
169−generateIsoXml :: XSD -> Text
170−generateIsoXml xsd@(XSD (e,d)) =
177+generateIsoXml :: GenType -> XSD -> Text
178+generateIsoXml genType xsd@(XSD (e,d)) =
171179 let
172180 (dList, el) = untwistDeps e d
173− in (header <>) . runGen d $ do
181+ in (header genType <>) . runGen d $ do
174182 for_ dList $ \(t,d) -> do
175− generateIsoDatatype (Just t) d []
176− for_ el generateIsoRecord
183+ generateIsoDatatype genType (Just t) d []
184+ for_ el (generateIsoRecord genType)
177185
178186toQualifier :: Int -> Maybe Int -> Text
179187toQualifier minOc (Just maxOc)
@@ -184,12 +192,24 @@ toQualifier minOc (Just maxOc)
184192 | otherwise = "*"
185193toQualifier _ Nothing = "*"
186194
187−header :: Text
188−header = T.unlines
189− [ "module Dummy where"
195+header :: GenType -> Text
196+header genType = T.unlines $
197+ [ "{-# LANGUAGE DuplicateRecordFields #-}"
190198 , ""
199+ , "module Dummy where"
200+ ""
191201 , "import Data.THGen.XML"
202+ ] <> specImports <>
203+ [ "import Prelude hiding ((*), (+))"
192204 , "" ]
205+ where
206+ specImports = case genType of
207+ Generator -> [ xmlWriter ]
208+ Parser -> [ domParser ]
209+ Both -> [ domParser, xmlWriter ]
210+ xmlWriter, domParser :: Text
211+ xmlWriter = "import Text.XML.Writer"
212+ domParser = "import Text.XML.DOM.Parser.FromDom"
193213
194214quote :: Text -> Text
195215quote t = "\"" <> t <> "\""
@@ -203,15 +223,18 @@ typeName (InlineComplex dt) = result
203223 TypeSimple (STAtomic _ sat _ _) -> Just $ simpleTypeToIsoType QQ sat
204224typeName (DatatypeRef t) = Just t
205225
206−generateIsoRecord :: Element -> GenMonad ()
207−generateIsoRecord (Element (_, laxName) xtype minOc maxOc annotations) = do
208− written <- ask
209− case xtype of
210− InlineComplex dt -> generateIsoDatatype (Just laxName) dt annotations
211− DatatypeRef nam -> if M.member nam written
212− then pure ()
213− else error $ "Implementation failure: "
214− <> show nam <> " type never encountered before"
226+generateIsoRecord :: GenType -> Element -> GenMonad ()
227+generateIsoRecord
228+ genType
229+ (Element (_, laxName) xtype minOc maxOc annotations) = do
230+ written <- ask
231+ case xtype of
232+ InlineComplex dt ->
233+ generateIsoDatatype genType (Just laxName) dt annotations
234+ DatatypeRef nam -> if M.member nam written
235+ then pure ()
236+ else error $ "Implementation failure: "
237+ <> show nam <> " type never encountered before"
215238
216239data CommentType = Haddock | Regular
217240
@@ -242,12 +265,14 @@ wrap80 = L.foldl' go [] . T.split (==' ')
242265 else L.init l <> [L.last l <> " " <> e]
243266
244267generateIsoDatatype
245− :: (Maybe Text) -- ^ Explicitly provided name, used for inline complexType's
268+ :: GenType
269+ -> (Maybe Text) -- ^ Explicitly provided name, used for inline complexType's
246270 -> Datatype
247271 -> [Annotation]
248272 -> GenMonad ()
249273 -- ^ (type name for lookups, generated code)
250274generateIsoDatatype
275+ genType
251276 eName
252277 (TypeComplex (ComplexType iName attrs annotations mGroupSchema))
253278 annotationsRec = do
@@ -259,14 +284,18 @@ generateIsoDatatype
259284 case mGroupSchema of
260285 Just groupSchema -> case groupSchema of
261286 CTSequence elems -> do
262− fields <- for elems generateIsoField
287+ fields <- for elems (generateIsoField genType)
263288 let
264289 comment = toComment Haddock $ annotationsRec
265290 <> [Documentation ""]
266291 <> annotations
267− header = (quote $ capitalize name) <> " =:= record Both"
292+ header =
293+ (quote $ capitalize name)
294+ <> " =:= record "
295+ <> genTypeToText genType
268296 tellGen (header : fields) comment
269297generateIsoDatatype
298+ genType
270299 eName
271300 (TypeSimple (STAtomic iName sat annotations restrictions))
272301 annotationsRec = do
@@ -289,19 +318,28 @@ generateIsoDatatype
289318 (F.concatMap fromEnumeration enums))
290319 comment
291320 else do
292− tellGen (generateNewtype iName sat) comment
321+ tellGen (generateNewtype genType iName sat) comment
293322
294−generateNewtype :: Text -> SimpleAtomicType -> [Text]
295−generateNewtype n sat =
323+generateNewtype :: GenType -> Text -> SimpleAtomicType -> [Text]
324+generateNewtype genType n sat =
296325 let
297326 cons = "Xml" <> capitalize n
298327 decons = "un" <> cons
328+ parser =
329+ [ "instance FromDom " <> cons <> " where"
330+ , " fromDom = " <> cons <> " fromDom"
331+ ]
299332 in
300333 [ "newtype " <> cons
301334 , " = " <> cons
302335 , " { " <> decons <> " :: " <> simpleTypeToIsoType Plain sat
303− , " } deriving (FromDom, ToXML)"
304− ]
336+ , " } deriving (Show, Eq" <> case genType of
337+ Parser -> ")"
338+ _ -> ", ToXML)"
339+ ] <> case genType of
340+ Generator -> []
341+ _ -> parser
342+
305343
306344generateEnum
307345 :: Text -- type name
@@ -334,8 +372,8 @@ lookupSimpleType (DatatypeRef tyName) = do
334372 Just (TypeSimple (STAtomic nam _ _ _)) -> pure $ Just nam
335373 Nothing -> error $ "can't look up type: " <> show tyName
336374
337−generateIsoField :: Element -> GenMonad Text
338−generateIsoField (Element (_, name) xtype minOc maxOc annotations) = do
375+generateIsoField :: GenType -> Element -> GenMonad Text
376+generateIsoField genType (Element (_, name) xtype minOc maxOc annotations) = do
339377 let
340378 qualifier = toQualifier minOc maxOc
341379 line <- lookupSimpleType xtype >>= \case
@@ -343,7 +381,7 @@ generateIsoField (Element (_, name) xtype minOc maxOc annotations) = do
343381 pure $ quote name <> " [t|Xml" <> tyName <> "|]"
344382 Nothing -> case xtype of
345383 InlineComplex dt -> do
346− generateIsoDatatype (Just $ capitalize name) dt annotations
384+ generateIsoDatatype genType (Just $ capitalize name) dt annotations
347385 pure $ quote name
348386 DatatypeRef ref ->
349387 pure $ quote name <> " [t|Xml" <> capitalize ref <> "|]"
@@ -351,7 +389,7 @@ generateIsoField (Element (_, name) xtype minOc maxOc annotations) = do
351389
352390main :: IO ()
353391main = do
354− (inFile:_) <- getArgs
392+ (inFile:mode:_) <- getArgs
355393 xml <- BL.readFile inFile
356394 let Right xsd = parseXSD def xml
357− T.hPutStrLn stdout $ generateIsoXml xsd
395+ T.hPutStrLn stdout $ generateIsoXml (read mode) xsd