From b9aa3bd5f003fe7604d0610629c3771245b9ef90 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <m.kooijman@student.utwente.nl>
Date: Fri, 12 Jun 2009 14:02:01 +0200
Subject: [PATCH] Make listBind support recursive bindings.

This allows listBind to process non-simplified Core modules.
---
 Flatten.hs    |  5 ++---
 Pretty.hs     |  3 +++
 Translator.hs | 39 +++++++++++++++------------------------
 3 files changed, 20 insertions(+), 27 deletions(-)

diff --git a/Flatten.hs b/Flatten.hs
index 8c4c7ab..d25ef73 100644
--- a/Flatten.hs
+++ b/Flatten.hs
@@ -54,11 +54,10 @@ markSignal use id = markSignals use [id]
 -- | Flatten a haskell function
 flattenFunction ::
   HsFunction                      -- ^ The function to flatten
-  -> CoreBind                     -- ^ The function value
+  -> (CoreBndr, CoreExpr)         -- ^ The function value
   -> FlatFunction                 -- ^ The resulting flat function
 
-flattenFunction _ (Rec _) = error "Recursive binders not supported"
-flattenFunction hsfunc bind@(NonRec var expr) =
+flattenFunction hsfunc (var, expr) =
   FlatFunction args res defs sigs
   where
     init_state        = ([], [], 0)
diff --git a/Pretty.hs b/Pretty.hs
index 0cc2b59..b2ac91d 100644
--- a/Pretty.hs
+++ b/Pretty.hs
@@ -132,6 +132,9 @@ instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
   pPrint (CoreSyn.Rec binds) =
     text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
 
+instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Expr b) where
+  pPrint = text . show
+
 instance Pretty AST.VHDLId where
   pPrint id = ForSyDe.Backend.Ppr.ppr id
 
diff --git a/Translator.hs b/Translator.hs
index 071e9d2..1ce9307 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -66,17 +66,14 @@ makeVHDL filename name stateful = do
 listBind :: String -> String -> IO ()
 listBind filename name = do
   core <- loadModule filename
-  let [bind] = findBinds core [name]
+  let [(b, expr)] = findBinds core [name]
   putStr "\n"
-  putStr $ prettyShow bind
+  putStr $ prettyShow expr
   putStr "\n\n"
-  putStr $ showSDoc $ ppr bind
+  putStr $ showSDoc $ ppr expr
+  putStr "\n\n"
+  putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
   putStr "\n\n"
-  case bind of
-    NonRec b expr -> do 
-      putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
-      putStr "\n\n"
-    otherwise -> return ()
 
 -- | Translate the binds with the given names from the given core module to
 --   VHDL. The Bool in the tuple makes the function stateful (True) or
@@ -94,7 +91,7 @@ moduleToVHDL core list = do
   return vhdl
   where
     -- Turns the given bind into VHDL
-    mkVHDL :: [CoreBind] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
+    mkVHDL :: [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
     mkVHDL binds statefuls = do
       -- Add the builtin functions
       --mapM addBuiltIn builtin_funcs
@@ -133,28 +130,24 @@ loadModule filename =
       return core
 
 -- | Extracts the named binds from the given module.
-findBinds :: HscTypes.CoreModule -> [String] -> [CoreBind]
-findBinds core names = Maybe.mapMaybe (findBind (cm_binds core)) names
+findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
+findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
 
 -- | Extract a named bind from the given list of binds
-findBind :: [CoreBind] -> String -> Maybe CoreBind
+findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
 findBind binds lookfor =
   -- This ignores Recs and compares the name of the bind with lookfor,
   -- disregarding any namespaces in OccName and extra attributes in Name and
   -- Var.
-  find (\b -> case b of 
-    Rec l -> False
-    NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
-  ) binds
+  find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
 
 -- | Processes the given bind as a top level bind.
 processBind ::
   Bool                       -- ^ Should this be stateful function?
-  -> CoreBind                -- ^ The bind to process
+  -> (CoreBndr, CoreExpr)    -- ^ The bind to process
   -> TranslatorState ()
 
-processBind _ (Rec _) = error "Recursive binders not supported"
-processBind stateful bind@(NonRec var expr) = do
+processBind stateful bind@(var, expr) = do
   -- Create the function signature
   let ty = CoreUtils.exprType expr
   let hsfunc = mkHsFunction var ty stateful
@@ -165,12 +158,10 @@ processBind stateful bind@(NonRec var expr) = do
 --   with them.
 flattenBind ::
   HsFunction                         -- The signature to flatten into
-  -> CoreBind                        -- The bind to flatten
+  -> (CoreBndr, CoreExpr)            -- The bind to flatten
   -> TranslatorState ()
 
-flattenBind _ (Rec _) = error "Recursive binders not supported"
-
-flattenBind hsfunc bind@(NonRec var expr) = do
+flattenBind hsfunc bind@(var, expr) = do
   -- Flatten the function
   let flatfunc = flattenFunction hsfunc bind
   -- Propagate state variables
@@ -284,7 +275,7 @@ resolvFunc hsfunc = do
   core <- getA tsCoreModule
   -- Find the named function
   let name = (hsFuncName hsfunc)
-  let bind = findBind (cm_binds core) name 
+  let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name 
   case bind of
     Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
     Just b  -> flattenBind hsfunc b
-- 
2.30.2