Improve listBindings output.

[matthijs/master-project/cλash.git] / cλash / CLasH / Utils / GhcTools.hs

diff --git a/cλash/CLasH/Utils/GhcTools.hs b/cλash/CLasH/Utils/GhcTools.hs
index c11b5486ffc0424aaaf6c3ca60084fc1fe8ce623..022a997eca180bf5040ca7eb349efbf6a0f9fcc4 100644 (file)
--- a/cλash/CLasH/Utils/GhcTools.hs
+++ b/cλash/CLasH/Utils/GhcTools.hs
@@ -19,6 +19,8 @@ import qualified Name
 import qualified Serialized
 import qualified Var
 import qualified Outputable
+import Outputable(($+$), (<+>), nest, empty, text, vcat)
+import qualified Class
 
 -- Local Imports
 import CLasH.Utils.Pretty
@@ -26,32 +28,50 @@ import CLasH.Translator.TranslatorTypes
 import CLasH.Translator.Annotations
 import CLasH.Utils
 
-listBindings :: FilePath -> [FilePath] -> IO [()]
+-- How far to indent the values after a Foo: header
+align = 20
+-- How far to indent all lines after the first
+indent = 5
+
+listBindings :: FilePath -> [FilePath] -> IO ()
 listBindings libdir filenames = do
   (cores,_,_) <- loadModules libdir filenames Nothing
-  let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
-  mapM (listBinding) binds
+  let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
+  mapM listBinding binds
+  putStr "\n=========================\n"
+  let classes = concatMap (HscTypes.typeEnvClasses . HscTypes.cm_types) cores
+  mapM listClass classes
+  return ()
+
+-- Slightly different version of hang, that always uses vcat instead of
+-- sep, so the first line of d2 preserves its nesting.
+hang' d1 n d2 = vcat [d1, nest n d2]
 
 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
-listBinding (b, e) = do
-  putStr "\nBinder: "
-  putStr $ show b
-  putStr "\nType of Binder: \n"
-  putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
-  putStr "\n\nExpression: \n"
-  putStr $ prettyShow e
-  putStr "\n\n"
-  putStr $ Outputable.showSDoc $ Outputable.ppr e
-  putStr "\n\nType of Expression: \n"
-  putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
-  putStr "\n\n"
+listBinding (b, e) = putStr $ Outputable.showSDoc $
+  (text "Binder:") <+> (text $ show b ++ "[" ++ show (Var.varUnique b) ++ "]")
+  $+$ nest indent (
+    hang' (text "Type of Binder:") align (Outputable.ppr $ Var.varType b)
+    $+$ hang' (text "Expression:") align (text $ prettyShow e)
+    $+$ nest align (Outputable.ppr e)
+    $+$ hang' (text "Type of Expression:") align (Outputable.ppr $ CoreUtils.exprType e)
+  )
+  $+$ (text "\n") -- Add an empty line
+
+listClass :: Class.Class -> IO ()
+listClass c = putStr $ Outputable.showSDoc $
+  (text "Class:") <+> (text $ show (Class.className c))
+  $+$ nest indent (
+    hang' (text "Selectors:") align (text $ show (Class.classSelIds c))
+  )
+  $+$ (text "\n") -- Add an empty line
   
 -- | Show the core structure of the given binds in the given file.
 listBind :: FilePath -> [FilePath] -> String -> IO ()
 listBind libdir filenames name = do
   (cores,_,_) <- loadModules libdir filenames Nothing
   bindings <- concatM $ mapM (findBinder (hasVarName name)) cores
-  mapM listBinding bindings
+  mapM_ listBinding bindings
   return ()
 
 -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
@@ -71,7 +91,7 @@ setDynFlag dflag = do
 -- just return an IO monad when they are evaluated).
 unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
 unsafeRunGhc libDir m =
-  System.IO.Unsafe.unsafePerformIO $ do
+  System.IO.Unsafe.unsafePerformIO $
       GHC.runGhc (Just libDir) $ do
         dflags <- GHC.getSessionDynFlags
         GHC.setSessionDynFlags dflags
@@ -87,7 +107,7 @@ loadModules ::
         , [EntitySpec]
         ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
 loadModules libdir filenames finder =
-  GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
+  GHC.defaultErrorHandler DynFlags.defaultDynFlags $
     GHC.runGhc (Just libdir) $ do
       dflags <- GHC.getSessionDynFlags
       GHC.setSessionDynFlags dflags
@@ -129,7 +149,7 @@ findExprs criteria core = do
   binders <- findBinder criteria core
   case binders of
     [] -> return Nothing
-    bndrs -> return $ Just $ (map snd bndrs)
+    bndrs -> return $ Just (map snd bndrs)
 
 findExpr ::
   Monad m =>
@@ -162,8 +182,7 @@ findBinder ::
   -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
 findBinder criteria core = do
   let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
-  critbinds <- Monad.filterM (criteria . fst) binds
-  return critbinds
+  Monad.filterM (criteria . fst) binds
 
 -- | Determine if a binder has an Annotation meeting a certain criteria
 isCLasHAnnotation ::
@@ -196,7 +215,7 @@ hasVarName ::
   String        -- ^ The name the binder has to have
   -> Var.Var    -- ^ The Binder
   -> m Bool     -- ^ Indicate if the binder has the name
-hasVarName lookfor bind = return $ lookfor == (Name.occNameString $ Name.nameOccName $ Name.getName bind)
+hasVarName lookfor bind = return $ lookfor == Name.occNameString (Name.nameOccName $ Name.getName bind)
 
 
 findInitStates ::