more fleshed out Traverse module

Convert/CaseKW.hs

@@ -6,7 +6,7 @@
  - Note that this conversion does not completely replicate the behavior of
  - `casex` and `casez` in cases where that case expression itself (rather than
  - just the case item patterns) contains wildcard values. This is apparently
- - rarely ever intentially done.
+ - rarely ever intentionally done.
  -}
 
 module Convert.CaseKW (convert) where
@@ -33,16 +33,15 @@ possibilities = ['0', '1']
 explodeBy :: [Char] -> String -> [String]
 explodeBy _ "" = [""]
 explodeBy wilds (x : xs) =
-    [(:)] <*> chars <*> prev
-    where
-        chars = if elem x wilds then possibilities else [x]
-        prev = explodeBy wilds xs
+    (map (:) chars) <*> (explodeBy wilds xs)
+    where chars = if elem x wilds then possibilities else [x]
 
 expandExpr :: [Char] -> Expr -> [Expr]
 expandExpr wilds (Number s) = map Number $ explodeBy wilds s
 expandExpr [] other = [other]
 -- TODO: Hopefully they only give us constant expressions...
-expandExpr _ other = error $ "CaseKW conversione encountered case that was not a number, which is dubious..." ++ (show other)
+-- TODO: We could be given a constant identifier...
+expandExpr _ other = error $ "CaseKW conversion encountered case that was not a number, which is dubious..." ++ (show other)
 
 -- Note that we don't have to convert the statements within the cases, as the
 -- conversion template takes care of that for us.

Convert/Logic.hs

@@ -13,65 +13,34 @@
 
 module Convert.Logic (convert) where
 
+import Control.Monad.Writer
 import qualified Data.Set as Set
 
+import Convert.Traverse
 import Language.SystemVerilog.AST
 
 type RegIdents = Set.Set String
 
 convert :: AST -> AST
-convert descriptions = map convertDescription descriptions
+convert = traverseDescriptions convertDescription
 
 convertDescription :: Description -> Description
-convertDescription (Module name ports items) =
-    Module name ports $ map (convertModuleItem idents) items
+convertDescription orig =
+    traverseModuleItems convertModuleItem orig
     where
-        idents = Set.unions $ map getRegIdents items
-convertDescription other = other
-
-getStmtLHSs :: Stmt -> [LHS]
-getStmtLHSs (Block _ stmts) = concat $ map getStmtLHSs stmts
-getStmtLHSs (Case kw e cases (Just stmt)) = (getStmtLHSs stmt) ++ (getStmtLHSs $ Case kw e cases Nothing)
-getStmtLHSs (Case _  _ cases Nothing) = concat $ map getStmtLHSs $ map snd cases
-getStmtLHSs (AsgnBlk lhs _) = [lhs]
-getStmtLHSs (Asgn    lhs _) = [lhs]
-getStmtLHSs (For _ _ _ stmt) = getStmtLHSs stmt
-getStmtLHSs (If _ s1 s2) = (getStmtLHSs s1) ++ (getStmtLHSs s2)
-getStmtLHSs (Timing _ s) = getStmtLHSs s
-getStmtLHSs (Null) = []
-
-getLHSIdents :: LHS -> [Identifier]
-getLHSIdents (LHS       vx  ) = [vx]
-getLHSIdents (LHSBit    vx _) = [vx]
-getLHSIdents (LHSRange  vx _) = [vx]
-getLHSIdents (LHSConcat lhss) = concat $ map getLHSIdents lhss
-
-getRegIdents :: ModuleItem -> RegIdents
-getRegIdents (AlwaysC _ stmt) =
-    Set.fromList idents
-    where
-        lhss = getStmtLHSs stmt
-        idents = concat $ map getLHSIdents lhss
-getRegIdents _ = Set.empty
-
-convertModuleItem :: RegIdents -> ModuleItem -> ModuleItem
-convertModuleItem idents (MIDecl (Variable dir (Logic mr) ident a me)) =
-    MIDecl $ Variable dir (t mr) ident a me
-    where
-        t = if Set.member ident idents then Reg else Wire
-convertModuleItem idents (Generate items) = Generate $ map (convertGenItem $ convertModuleItem idents) items
-convertModuleItem _ other = other
-
-convertGenItem :: (ModuleItem -> ModuleItem) -> GenItem -> GenItem
-convertGenItem f item = convertGenItem' item
+        idents = execWriter (collectModuleItemsM regIdents orig)
+        convertModuleItem :: ModuleItem -> ModuleItem
+        convertModuleItem (MIDecl (Variable dir (Logic mr) ident a me)) =
+            MIDecl $ Variable dir (t mr) ident a me
+            where t = if Set.member ident idents then Reg else Wire
+        convertModuleItem other = other
+
+regIdents :: ModuleItem -> Writer RegIdents ()
+regIdents (AlwaysC _ stmt) = collectStmtLHSsM idents stmt
     where
-        convertGenItem' :: GenItem -> GenItem
-        convertGenItem' (GenBlock x items) = GenBlock x $ map convertGenItem' items
-        convertGenItem' (GenFor a b c d items) = GenFor a b c d $ map convertGenItem' items
-        convertGenItem' (GenIf e i1 i2) = GenIf e (convertGenItem' i1) (convertGenItem' i2)
-        convertGenItem' (GenNull) = GenNull
-        convertGenItem' (GenModuleItem moduleItem) = GenModuleItem $ f moduleItem
-        convertGenItem' (GenCase e cases def) = GenCase e cases' def'
-            where
-                cases' = zip (map fst cases) (map (convertGenItem' . snd) cases)
-                def' = fmap convertGenItem' def
+        idents :: LHS -> Writer RegIdents ()
+        idents (LHS       vx  ) = tell $ Set.singleton vx
+        idents (LHSBit    vx _) = tell $ Set.singleton vx
+        idents (LHSRange  vx _) = tell $ Set.singleton vx
+        idents (LHSConcat lhss) = mapM idents lhss >>= \_ -> return ()
+regIdents _ = return ()

Convert/StarPort.hs

@@ -6,7 +6,7 @@
 
 module Convert.StarPort (convert) where
 
-import Data.Maybe (mapMaybe)
+import Control.Monad.Writer
 import qualified Data.Map.Strict as Map
 
 import Convert.Traverse
@@ -16,10 +16,10 @@ convert :: AST -> AST
 convert descriptions =
     traverseDescriptions (traverseModuleItems mapInstance) descriptions
     where
-        modulePorts = Map.fromList $ mapMaybe getPorts descriptions
-        getPorts :: Description -> Maybe (Identifier, [Identifier])
-        getPorts (Module name ports _) = Just (name, ports)
-        getPorts _ = Nothing
+        modulePorts = execWriter $ collectDescriptionsM getPorts descriptions
+        getPorts :: Description -> Writer (Map.Map Identifier [Identifier]) ()
+        getPorts (Module name ports _) = tell $ Map.singleton name ports
+        getPorts _ = return ()
 
         mapInstance :: ModuleItem -> ModuleItem
         mapInstance (Instance m p x Nothing) =

Convert/Traverse.hs

@@ -8,36 +8,51 @@ module Convert.Traverse
 ( MapperM
 , Mapper
 , unmonad
+, collectify
 , traverseDescriptionsM
 , traverseDescriptions
+, collectDescriptionsM
 , traverseModuleItemsM
 , traverseModuleItems
+, collectModuleItemsM
 , traverseStmtsM
 , traverseStmts
+, collectStmtsM
+, traverseStmtLHSsM
+, traverseStmtLHSs
+, collectStmtLHSsM
 ) where
 
 import Control.Monad.State
 import Language.SystemVerilog.AST
 
-type MapperM s t = t -> (State s) t
+type MapperM m t = t -> m t
 type Mapper t = t -> t
+type CollectorM m t = t -> m ()
 
-unmonad :: (MapperM () a -> MapperM () b) -> Mapper a -> Mapper b
+unmonad :: (MapperM (State ()) a -> MapperM (State ()) b) -> Mapper a -> Mapper b
 unmonad traverser mapper thing =
     evalState (traverser (return . mapper) thing) ()
 
-traverseDescriptionsM :: MapperM s Description -> MapperM s AST
+collectify :: Monad m => (MapperM m a -> MapperM m b) -> CollectorM m a -> CollectorM m b
+collectify traverser collector thing =
+    traverser mapper thing >>= \_ -> return ()
+    where mapper x = collector x >>= \() -> return x
+
+traverseDescriptionsM :: Monad m => MapperM m Description -> MapperM m AST
 traverseDescriptionsM mapper descriptions =
     mapM mapper descriptions
 
 traverseDescriptions :: Mapper Description -> Mapper AST
 traverseDescriptions = unmonad traverseDescriptionsM
+collectDescriptionsM :: Monad m => CollectorM m Description -> CollectorM m AST
+collectDescriptionsM = collectify traverseDescriptionsM
 
 maybeDo :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
 maybeDo _ Nothing = return Nothing
 maybeDo fun (Just val) = fun val >>= return . Just
 
-traverseModuleItemsM :: MapperM s ModuleItem -> MapperM s Description
+traverseModuleItemsM :: Monad m => MapperM m ModuleItem -> MapperM m Description
 traverseModuleItemsM mapper (Module name ports items) =
     mapM fullMapper items >>= return . Module name ports
     where
@@ -65,8 +80,10 @@ traverseModuleItemsM _ orig = return orig
 
 traverseModuleItems :: Mapper ModuleItem -> Mapper Description
 traverseModuleItems = unmonad traverseModuleItemsM
+collectModuleItemsM :: Monad m => CollectorM m ModuleItem -> CollectorM m Description
+collectModuleItemsM = collectify traverseModuleItemsM
 
-traverseStmtsM :: MapperM s Stmt -> MapperM s ModuleItem
+traverseStmtsM :: Monad m => MapperM m Stmt -> MapperM m ModuleItem
 traverseStmtsM mapper = moduleItemMapper
     where
         moduleItemMapper (AlwaysC kw stmt) =
@@ -74,6 +91,19 @@ traverseStmtsM mapper = moduleItemMapper
         moduleItemMapper (Function ret name decls stmt) =
             fullMapper stmt >>= return . Function ret name decls
         moduleItemMapper other = return $ other
+        fullMapper = traverseNestedStmtsM mapper
+
+traverseStmts :: Mapper Stmt -> Mapper ModuleItem
+traverseStmts = unmonad traverseStmtsM
+collectStmtsM :: Monad m => CollectorM m Stmt -> CollectorM m ModuleItem
+collectStmtsM = collectify traverseStmtsM
+
+-- private utility for turning a thing which maps over a single lever of
+-- statements into one that maps over the nested statements first, then the
+-- higher levels up
+traverseNestedStmtsM :: Monad m => MapperM m Stmt -> MapperM m Stmt
+traverseNestedStmtsM mapper = fullMapper
+    where
         fullMapper stmt = mapper stmt >>= cs
         cs (Block decls stmts) = mapM fullMapper stmts >>= return . Block decls
         cs (Case kw expr cases def) = do
@@ -91,5 +121,14 @@ traverseStmtsM mapper = moduleItemMapper
         cs (Timing sense stmt) = fullMapper stmt >>= return . Timing sense
         cs (Null) = return Null
 
-traverseStmts :: Mapper Stmt -> Mapper ModuleItem
-traverseStmts = unmonad traverseStmtsM
+traverseStmtLHSsM :: Monad m => MapperM m LHS -> MapperM m Stmt
+traverseStmtLHSsM mapper = traverseNestedStmtsM stmtMapper
+    where
+        stmtMapper (AsgnBlk lhs expr) = mapper lhs >>= \lhs' -> return $ AsgnBlk lhs' expr
+        stmtMapper (Asgn    lhs expr) = mapper lhs >>= \lhs' -> return $ Asgn    lhs' expr
+        stmtMapper other = return other
+
+traverseStmtLHSs :: Mapper LHS -> Mapper Stmt
+traverseStmtLHSs = unmonad traverseStmtLHSsM
+collectStmtLHSsM :: Monad m => CollectorM m LHS -> CollectorM m Stmt
+collectStmtLHSsM = collectify traverseStmtLHSsM