+import CLasH.Utils
+
+-- 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 = 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) = 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
+ return ()