@@ -2,7 +2,9 @@
22{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE OverloadedStrings #-}
44
5−module Main where
5+module Main
6+ ( main
7+ ) where
68
79import Control.Monad.RWS.CPS (RWS, execRWS)
810import Control.Monad.Reader
@@ -57,15 +59,19 @@ instance References DatatypeRef where
5759instance References a => References [a] where
5860 references = F.concatMap references
5961
62+-- | 'DatatypeMap' are the types left to process
63+-- 'S.Set Text' are the types already processed.
6064type PreMonad = StateT (DatatypeMap, S.Set Text) (Writer [(Text, Datatype)])
6165
6266type PreElemMonad = RWS DatatypeMap [Element] [Element]
6367
68+-- | Marks the given type as processed.
6469proceed :: Text -> Datatype -> PreMonad ()
6570proceed t dt = do
6671 tell [(t, dt)]
6772 modify $ \(f,s) -> (M.delete t f, S.insert t s)
6873
74+-- | Marks element as processed.
6975proceed' :: Element -> PreElemMonad ()
7076proceed' el = do
7177 tell [el]
@@ -75,7 +81,7 @@ untwistDeps :: [Element] -> DatatypeMap -> ([(Text, Datatype)], [Element])
7581untwistDeps e dm = (dList, e')
7682 where
7783 dList = nub $ execWriter $ do
78− (a, (_,s)) <- runStateT sortDatatypesByDeps (dm, S.empty)
84+ (a, _) <- runStateT sortDatatypesByDeps (dm, S.empty)
7985 return a
8086 (_, e') = execRWS sortElemsByDeps (M.fromList dList) e
8187
@@ -89,7 +95,7 @@ sortElemsByDeps = do
8995 [] -> proceed' first >> sortElemsByDeps
9096 xs -> do
9197 results <- traverse memberDatatype xs
92− if L.all id results
98+ if L.and results
9399 then proceed' first >> sortElemsByDeps
94100 else do
95101 let failed = fmap snd $ L.filter (not . fst) $ L.zip results xs
@@ -100,12 +106,12 @@ memberDatatype ty = do
100106 -- traceM $ "memberDatatype: " <> show ty
101107 dm <- ask
102108 case M.lookup ty dm of
103− Just typ -> return True
109+ Just _ -> return True
104110 Nothing -> return False
105111
106112sortDatatypesByDeps :: PreMonad ()
107113sortDatatypesByDeps = do
108− (dm, s) <- get
114+ (dm, _) <- get
109115 if M.null dm then pure () else do
110116 let first = Prelude.head (M.toList dm)
111117 traceM $ "sortDatatypesByDeps: " <> show first
@@ -120,12 +126,11 @@ lookupDatatype :: Text -> PreMonad ()
120126lookupDatatype ty = do
121127 traceM $ "lookupDatatype: " <> show ty
122128 (dm, s) <- get
123− let mTy = M.lookup ty dm
124129 case M.lookup ty dm of
125− Nothing -> if S.member ty s then pure () else do
130+ Nothing -> if S.member ty s then pure () else
126131 error $ "can't look up datatype: " <> show ty
127132 Just typ -> case references typ of
128− [] -> proceed ty typ >> sortDatatypesByDeps
133+ [] -> proceed ty typ -- >> sortDatatypesByDeps -- Pretty sure this was a bug
129134 xs -> traverse_ lookupDatatype xs >> proceed ty typ
130135
131136class Capitalizable t where
@@ -174,19 +179,19 @@ tellGen
174179 :: [Text] -- generated code
175180 -> Text -- comment
176181 -> GenMonad ()
177−tellGen code comment = do
182+tellGen code comment =
178183 tell $ "\n" <> comment <> T.unlines code
179184
180185runGen :: DatatypeMap -> GenMonad a -> Text
181186runGen dm act = execWriter $ runReaderT act dm
182187
183188generateIsoXml :: GenType -> XSD -> Text
184−generateIsoXml genType xsd@(XSD (e,d)) =
189+generateIsoXml genType (XSD (e,dm)) =
185190 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 []
191+ (dList, el) = untwistDeps e dm
192+ in (header genType <>) . runGen dm $ do
193+ for_ dList $ \(t,dt) ->
194+ generateIsoDatatype genType t dt []
190195 for_ el (generateIsoRecord genType)
191196
192197toQualifier :: Int -> Int -> Text
@@ -230,11 +235,11 @@ typeName (DatatypeRef t) = Just t
230235generateIsoRecord :: GenType -> Element -> GenMonad ()
231236generateIsoRecord
232237 genType
233− (Element (_, laxName) xtype minOc maxOc annotations) = do
238+ (Element (_, laxName) elXtype _ _ elAnnotations) = do
234239 written <- ask
235− case xtype of
240+ case elXtype of
236241 InlineComplex dt ->
237− generateIsoDatatype genType (Just laxName) dt annotations
242+ generateIsoDatatype genType laxName dt elAnnotations
238243 DatatypeRef nam -> if M.member nam written
239244 then pure ()
240245 else error $ "Implementation failure: "
@@ -264,7 +269,7 @@ wrap80 = L.foldl' go [] . T.split (==' ')
264269 go [] e = [e]
265270 go l e =
266271 let last' = L.last l
267− in if (T.length last') + T.length e >= 73 -- 80 minus "-- | " and ' '
272+ in if T.length last' + T.length e >= 73 -- 80 minus "-- | " and ' '
268273 then l <> pure e
269274 else L.init l <> [L.last l <> " " <> e]
270275
@@ -321,7 +326,7 @@ generateIsoDatatype
321326 (quote $ capitalize name)
322327 (F.concatMap fromEnumeration enums))
323328 comment
324− else do
329+ else
325330 tellGen (generateNewtype genType iName sat) comment
326331
327332generateNewtype :: GenType -> Text -> SimpleAtomicType -> [Text]
@@ -349,11 +354,11 @@ generateEnum
349354 :: Text -- type name
350355 -> [Text] -- enums
351356 -> [Text] -- generated code
352−generateEnum name enums =
357+generateEnum enumName enums =
353358 let
354− header = name <> " Exhaustive =:= enum Both"
359+ enumHeader = enumName <> " Exhaustive =:= enum Both"
355360 eFields = ("& "<>) <$> enums
356− in pure header <> eFields
361+ in pure enumHeader <> eFields
357362
358363-- | Returns Just baseTypeName if type is simple, Nothing - otherwise
359364lookupSimpleBaseType
@@ -370,11 +375,11 @@ lookupSimpleType
370375 :: DatatypeRef
371376 -> GenMonad (Maybe Text)
372377lookupSimpleType (InlineComplex _) = pure Nothing
373−lookupSimpleType (DatatypeRef tyName) = do
374− M.lookup tyName <$> ask >>= \case
378+lookupSimpleType (DatatypeRef tyName) =
379+ asks (M.lookup tyName) >>= \case
375380 Just (TypeComplex _) -> pure Nothing
376381 Just (TypeSimple (STAtomic nam _ _ _)) -> pure $ Just nam
377− Nothing -> error $ "can't look up type: " <> show tyName
382+ Nothing -> error $ "can't look up type: " <> show tyName
378383
379384generateIsoField :: GenType -> Element -> GenMonad Text
380385generateIsoField genType (Element (_, name) xtype minOc maxOc annotations) = do
@@ -397,6 +402,6 @@ main = do
397402 xml <- BL.readFile inFile
398403 let
399404 xsd = case parseXSD def xml of
400− Right xsd -> xsd
405+ Right xsd' -> xsd'
401406 Left e -> error $ show e
402407 T.hPutStrLn stdout $ generateIsoXml (read mode) xsd