@@ -18,6 +18,7 @@ import Data.Set as S
1818import Data.Text as T
1919import Data.Text.IO as T
2020import Data.Traversable
21+import Debug.Trace
2122import System.Environment
2223import System.IO
2324import Text.XSD
@@ -73,7 +74,7 @@ proceed' el = do
7374untwistDeps :: [Element] -> DatatypeMap -> ([(Text, Datatype)], [Element])
7475untwistDeps e dm = (dList, e')
7576 where
76− dList = execWriter $ do
77+ dList = nub $ execWriter $ do
7778 (a, (_,s)) <- runStateT sortDatatypesByDeps (dm, S.empty)
7879 return a
7980 (_, e') = execRWS sortElemsByDeps (M.fromList dList) e
@@ -83,6 +84,7 @@ sortElemsByDeps = do
8384 els <- get
8485 if Prelude.null els then pure () else do
8586 let first = Prelude.head els
87+ -- traceM $ "sortElemsByDeps: " <> show first
8688 case references first of
8789 [] -> proceed' first >> sortElemsByDeps
8890 xs -> do
@@ -95,6 +97,7 @@ sortElemsByDeps = do
9597
9698memberDatatype :: Text -> PreElemMonad Bool
9799memberDatatype ty = do
100+ -- traceM $ "memberDatatype: " <> show ty
98101 dm <- ask
99102 case M.lookup ty dm of
100103 Just typ -> return True
@@ -105,6 +108,7 @@ sortDatatypesByDeps = do
105108 (dm, s) <- get
106109 if M.null dm then pure () else do
107110 let first = Prelude.head (M.toList dm)
111+ traceM $ "sortDatatypesByDeps: " <> show first
108112 case references $ snd first of
109113 [] -> uncurry proceed first >> sortDatatypesByDeps
110114 xs -> do
@@ -114,6 +118,7 @@ sortDatatypesByDeps = do
114118
115119lookupDatatype :: Text -> PreMonad ()
116120lookupDatatype ty = do
121+ traceM $ "lookupDatatype: " <> show ty
117122 (dm, s) <- get
118123 let mTy = M.lookup ty dm
119124 case M.lookup ty dm of
@@ -121,7 +126,7 @@ lookupDatatype ty = do
121126 error $ "can't look up datatype: " <> show ty
122127 Just typ -> case references typ of
123128 [] -> proceed ty typ >> sortDatatypesByDeps
124− xs -> traverse_ lookupDatatype xs
129+ xs -> traverse_ lookupDatatype xs >> proceed ty typ
125130
126131class Capitalizable t where
127132 capitalize :: t -> t
@@ -183,21 +188,19 @@ generateIsoXml genType xsd@(XSD (e,d)) =
183188 generateIsoDatatype genType (Just t) d []
184189 for_ el (generateIsoRecord genType)
185190
186−toQualifier :: Int -> Maybe Int -> Text
187−toQualifier minOc (Just maxOc)
191+toQualifier :: Int -> Int -> Text
192+toQualifier minOc maxOc
188193 | minOc == 1 && maxOc == 1 = "!"
189194 | minOc == 0 && maxOc == 1 = "?"
190195 | minOc == 1 && maxOc > minOc = "+"
191196 | minOc == 1 && maxOc < minOc = error "maxOccurs < minOccurs"
192197 | otherwise = "*"
193−toQualifier _ Nothing = "*"
194198
195199header :: GenType -> Text
196200header genType = T.unlines $
197− [ "{-# LANGUAGE DuplicateRecordFields #-}"
201+ [ "module Dummy where"
198202 , ""
199− , "module Dummy where"
200− ""
203+ , "import Control.DeepSeq"
201204 , "import Data.THGen.XML"
202205 ] <> specImports <>
203206 [ "import Prelude hiding ((*), (+))"
@@ -326,21 +329,21 @@ generateNewtype genType n sat =
326329 cons = "Xml" <> capitalize n
327330 decons = "un" <> cons
328331 parser =
329− [ "instance FromDom " <> cons <> " where"
330− , " fromDom = " <> cons <> " fromDom"
332+ [ ""
333+ , "instance FromDom " <> cons <> " where"
334+ , " fromDom = " <> cons <> " <$> fromDom"
331335 ]
332336 in
333337 [ "newtype " <> cons
334338 , " = " <> cons
335339 , " { " <> decons <> " :: " <> simpleTypeToIsoType Plain sat
336− , " } deriving (Show, Eq" <> case genType of
340+ , " } deriving (Show, Eq, NFData" <> case genType of
337341 Parser -> ")"
338342 _ -> ", ToXML)"
339343 ] <> case genType of
340344 Generator -> []
341345 _ -> parser
342346
343−
344347generateEnum
345348 :: Text -- type name
346349 -> [Text] -- enums
@@ -391,5 +394,8 @@ main :: IO ()
391394main = do
392395 (inFile:mode:_) <- getArgs
393396 xml <- BL.readFile inFile
394− let Right xsd = parseXSD def xml
397+ let
398+ xsd = case parseXSD def xml of
399+ Right xsd -> xsd
400+ Left e -> error $ show e
395401 T.hPutStrLn stdout $ generateIsoXml (read mode) xsd