initial work on Traverse AST transformations

Convert/AlwaysKW.hs

@@ -6,20 +6,19 @@
 
 module Convert.AlwaysKW (convert) where
 
-import Convert.Template.ModuleItem (moduleItemConverter)
-
+import Convert.Traverse
 import Language.SystemVerilog.AST
 
 convert :: AST -> AST
-convert = moduleItemConverter convertModuleItem
+convert = traverseDescriptions $ traverseModuleItems replaceAlwaysKW
 
 -- Conversions:
 -- `always_comb` -> `always @*`
 -- `always_ff` -> `always`
 
-convertModuleItem :: ModuleItem -> ModuleItem
-convertModuleItem (AlwaysC AlwaysComb stmt) =
+replaceAlwaysKW :: ModuleItem -> ModuleItem
+replaceAlwaysKW (AlwaysC AlwaysComb stmt) =
     AlwaysC Always $ Timing SenseStar stmt
-convertModuleItem (AlwaysC AlwaysFF stmt) =
+replaceAlwaysKW (AlwaysC AlwaysFF stmt) =
     AlwaysC Always stmt
-convertModuleItem other = other
+replaceAlwaysKW other = other

Convert/CaseKW.hs

@@ -11,17 +11,15 @@
 
 module Convert.CaseKW (convert) where
 
-import Convert.Template.Stmt (stmtConverter)
-
+import Convert.Traverse
 import Language.SystemVerilog.AST
 
 convert :: AST -> AST
-convert = stmtConverter convertStmt
+convert = traverseDescriptions (traverseModuleItems (traverseStmts convertStmt))
 
 -- Conversions:
 -- `casez` -> `case` with wildcards (?, z) expanded
 -- `casex` -> `case` with wildcards (?, z, x) expanded
-
 -- to be either 0 or 1
 
 wildcards :: CaseKW -> [Char]

Convert/StarPort.hs

@@ -6,32 +6,27 @@
 
 module Convert.StarPort (convert) where
 
-import Data.Maybe
+import Data.Maybe (mapMaybe)
 import qualified Data.Map.Strict as Map
 
+import Convert.Traverse
 import Language.SystemVerilog.AST
 
-type ModulePorts = Map.Map String [String]
-
 convert :: AST -> AST
-convert descriptions = map (convertDescription portsInfo) descriptions
+convert descriptions =
+    traverseDescriptions (traverseModuleItems mapInstance) descriptions
     where
-        portsInfo = Map.fromList $ mapMaybe getPorts descriptions
+        modulePorts = Map.fromList $ mapMaybe getPorts descriptions
         getPorts :: Description -> Maybe (Identifier, [Identifier])
         getPorts (Module name ports _) = Just (name, ports)
         getPorts _ = Nothing
 
-convertDescription :: ModulePorts -> Description -> Description
-convertDescription info (Module name ports items) =
-    Module name ports $ map (convertModuleItem info) items
-convertDescription _ other = other
-
-convertModuleItem :: ModulePorts -> ModuleItem -> ModuleItem
-convertModuleItem info (Instance m p x Nothing) =
-    Instance m p x (Just portBindings)
-    where
-        ports = case Map.lookup m info of
-            Nothing -> error $ "could not convert `.*` in instantiation of " ++ m
-            Just l -> l
-        portBindings = map (\port -> (port, Just $ Ident port)) ports
-convertModuleItem _ other = other
+        mapInstance :: ModuleItem -> ModuleItem
+        mapInstance (Instance m p x Nothing) =
+            Instance m p x (Just portBindings)
+            where
+                ports = case Map.lookup m modulePorts of
+                    Nothing -> error $ "could not convert `.*` in instantiation of " ++ m
+                    Just l -> l
+                portBindings = map (\port -> (port, Just $ Ident port)) ports
+        mapInstance other = other

Convert/Template/ModuleItem.hs

-{- sv2v
- - Author: Zachary Snow <zach@zachjs.com>
- -
- - Template converter for ModuleItem transformations
- -
- - Also has coverage for ModuleItems inside of generate blocks
- -}
-
-module Convert.Template.ModuleItem (moduleItemConverter) where
-
-import Data.Maybe
-import Language.SystemVerilog.AST
-
-type Converter = ModuleItem -> ModuleItem
-
-moduleItemConverter :: Converter -> (AST -> AST)
-moduleItemConverter f = convert f
-
-convert :: Converter -> AST -> AST
-convert f modules = map (convertDescription f) modules
-
-convertDescription :: Converter -> Description -> Description
-convertDescription f (Module name ports items) =
-    Module name ports $ map (convertModuleItem f) items
-convertDescription _ (Typedef a b) = Typedef a b
-
-convertModuleItem :: Converter -> ModuleItem -> ModuleItem
-convertModuleItem f (Generate items) = f $ Generate $ map (convertGenItem f) items
-convertModuleItem f other = f other
-
-convertGenItem :: Converter -> GenItem -> GenItem
-convertGenItem f item = convertGenItem' item
-    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' = if def == Nothing
-                    then Nothing
-                    else Just $ convertGenItem' $ fromJust def

Convert/Template/Stmt.hs

-{- sv2v
- - Author: Zachary Snow <zach@zachjs.com>
- -
- - Template converter for Stmt transformations
- -}
-
-module Convert.Template.Stmt (stmtConverter) where
-
-import Convert.Template.ModuleItem (moduleItemConverter)
-import Language.SystemVerilog.AST
-
-type Converter = Stmt -> Stmt
-
-stmtConverter :: Converter -> (AST -> AST)
-stmtConverter = moduleItemConverter . convertModuleItem
-
-convertModuleItem :: Converter -> ModuleItem -> ModuleItem
-convertModuleItem f (AlwaysC kw stmt) =
-    AlwaysC kw (convertStmt f stmt)
-convertModuleItem f (Function ret name decls stmt) =
-    Function ret name decls (convertStmt f stmt)
-convertModuleItem _ other = other
-
-convertStmt :: Converter -> (Stmt -> Stmt)
-convertStmt f = f . convertStmt'
-    where
-        cs :: Stmt -> Stmt
-        cs = convertStmt f
-        convertStmt' :: Stmt -> Stmt
-        convertStmt' (Block decls stmts) = Block decls (map cs stmts)
-        convertStmt' (Case kw expr cases def) =
-            Case kw expr cases' def'
-            where
-                cases' = map (\(exprs, stmt) -> (exprs, cs stmt)) cases
-                def' = maybe Nothing (Just . cs) def
-        convertStmt' (AsgnBlk lhs expr) = AsgnBlk lhs expr
-        convertStmt' (Asgn    lhs expr) = Asgn    lhs expr
-        convertStmt' (For a b c stmt) = For a b c (cs stmt)
-        convertStmt' (If e s1 s2) = If e (cs s1) (cs s2)
-        convertStmt' (Timing sense stmt) = Timing sense (cs stmt)
-        convertStmt' (Null) = Null

Convert/Traverse.hs

+{- sv2v
+ - Author: Zachary Snow <zach@zachjs.com>
+ -
+ - Utilities for traversing AST transformations.
+ -}
+
+module Convert.Traverse
+( MapperM
+, Mapper
+, unmonad
+, traverseDescriptionsM
+, traverseDescriptions
+, traverseModuleItemsM
+, traverseModuleItems
+, traverseStmtsM
+, traverseStmts
+) where
+
+import Control.Monad.State
+import Data.Maybe
+import Language.SystemVerilog.AST
+
+type MapperM s t = t -> (State s) t
+type Mapper t = t -> t
+
+unmonad :: (MapperM () a -> MapperM () b) -> Mapper a -> Mapper b
+unmonad traverser mapper thing =
+    evalState (traverser (return . mapper) thing) ()
+
+traverseDescriptionsM :: MapperM s Description -> MapperM s AST
+traverseDescriptionsM mapper descriptions =
+    mapM mapper descriptions
+
+traverseDescriptions :: Mapper Description -> Mapper AST
+traverseDescriptions = unmonad traverseDescriptionsM
+
+traverseModuleItemsM :: MapperM s ModuleItem -> MapperM s Description
+traverseModuleItemsM mapper (Module name ports items) =
+    mapM fullMapper items >>= return . Module name ports
+    where
+        fullMapper (Generate genItems) =
+            mapM genItemMapper genItems >>= mapper . Generate
+        fullMapper other = mapper other
+        -- maps all ModuleItems within the given GenItem
+        genItemMapper (GenBlock x subItems) =
+            mapM genItemMapper subItems >>= return . GenBlock x
+        genItemMapper (GenFor a b c d subItems) =
+            mapM genItemMapper subItems >>= return . GenFor a b c d
+        genItemMapper (GenIf e i1 i2) = do
+            i1' <- genItemMapper i1
+            i2' <- genItemMapper i2
+            return $ GenIf e i1' i2'
+        genItemMapper (GenNull) = return GenNull
+        genItemMapper (GenModuleItem moduleItem) =
+            fullMapper moduleItem >>= return . GenModuleItem
+        genItemMapper (GenCase e cases def) = do
+            caseItems <- mapM (genItemMapper . snd) cases
+            let cases' = zip (map fst cases) caseItems
+            def' <- if def == Nothing
+                    then return Nothing
+                    else genItemMapper (fromJust def) >>= \x -> return $ Just x
+            return $ GenCase e cases' def'
+traverseModuleItemsM _ orig = return orig
+
+traverseModuleItems :: Mapper ModuleItem -> Mapper Description
+traverseModuleItems = unmonad traverseModuleItemsM
+
+traverseStmtsM :: MapperM s Stmt -> MapperM s ModuleItem
+traverseStmtsM mapper = moduleItemMapper
+    where
+        moduleItemMapper (AlwaysC kw stmt) =
+            fullMapper stmt >>= return . AlwaysC kw
+        moduleItemMapper (Function ret name decls stmt) =
+            fullMapper stmt >>= return . Function ret name decls
+        moduleItemMapper other = return $ other
+        fullMapper stmt = mapper stmt >>= cs
+        cs (Block decls stmts) = mapM fullMapper stmts >>= return . Block decls
+        cs (Case kw expr cases def) = do
+            caseStmts <- mapM fullMapper $ map snd cases
+            let cases' = zip (map fst cases) caseStmts
+            def' <- if def == Nothing
+                    then return Nothing
+                    else fullMapper (fromJust def) >>= \x -> return $ Just x
+            return $ Case kw expr cases' def'
+        cs (AsgnBlk lhs expr) = return $ AsgnBlk lhs expr
+        cs (Asgn    lhs expr) = return $ Asgn    lhs expr
+        cs (For a b c stmt) = fullMapper stmt >>= return . For a b c
+        cs (If e s1 s2) = do
+            s1' <- fullMapper s1
+            s2' <- fullMapper s2
+            return $ If e s1' s2'
+        cs (Timing sense stmt) = fullMapper stmt >>= return . Timing sense
+        cs (Null) = return Null
+
+traverseStmts :: Mapper Stmt -> Mapper ModuleItem
+traverseStmts = unmonad traverseStmtsM

sv2v.cabal

@@ -50,7 +50,8 @@ executable sv2v
   build-depends:
     array,
     base,
-    containers
+    containers,
+    mtl
   other-modules:
     Language.SystemVerilog
     Language.SystemVerilog.AST
@@ -66,8 +67,7 @@ executable sv2v
     Convert.PackedArrayFlatten
     Convert.StarPort
     Convert.Typedef
-    Convert.Template.ModuleItem
-    Convert.Template.Stmt
+    Convert.Traverse
   ghc-options:
     -O3
     -threaded