[project @ 1999-12-09 12:30:56 by simonpj]

[ghc-hetmet.git] / ghc / compiler / rename / Rename.lhs

diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 8926aeb..e1381ba 100644 (file)
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -72,18 +72,13 @@ renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc
   =    -- Initialise the renamer monad
     initRn mod_name us (mkSearchPath opt_HiMap) loc
           (rename this_mod)                            >>=
-       \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) ->
+       \ ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) ->
 
        -- Check for warnings
     printErrorsAndWarnings rn_errs_bag rn_warns_bag    >>
 
-       -- Dump output, if any
-    (case maybe_rn_stuff of
-       Nothing  -> return ()
-       Just results@(_, rn_mod, _, _, _)
-                -> dumpIfSet opt_D_dump_rn "Renamer:"
-                             (ppr rn_mod)
-    )                                                  >>
+       -- Dump any debugging output
+    dump_action                                        >>
 
        -- Return results
     if not (isEmptyBag rn_errs_bag) then
@@ -94,15 +89,15 @@ renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc
 
 
 \begin{code}
-rename this_mod@(HsModule mod_name vers exports imports local_decls loc)
+rename this_mod@(HsModule mod_name vers _ imports local_decls loc)
   =    -- FIND THE GLOBAL NAME ENVIRONMENT
     getGlobalNames this_mod                    `thenRn` \ maybe_stuff ->
 
        -- CHECK FOR EARLY EXIT
     if not (maybeToBool maybe_stuff) then
        -- Everything is up to date; no need to recompile further
-       rnStats []              `thenRn_`
-       returnRn Nothing
+       rnDump [] []            `thenRn` \ dump_action ->
+       returnRn (Nothing, dump_action)
     else
     let
        Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff
@@ -122,18 +117,21 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc)
                -- override the implicit ones. 
     in
     slurpImpDecls real_source_fvs      `thenRn` \ rn_imp_decls ->
+    let
+       rn_all_decls       = rn_imp_decls ++ rn_local_decls 
+    in
 
        -- EXIT IF ERRORS FOUND
-    checkErrsRn                                `thenRn` \ no_errs_so_far ->
+    checkErrsRn                                        `thenRn` \ no_errs_so_far ->
     if not no_errs_so_far then
        -- Found errors already, so exit now
-       rnStats []              `thenRn_`
-       returnRn Nothing
+       rnDump rn_imp_decls rn_all_decls        `thenRn` \ dump_action ->
+       returnRn (Nothing, dump_action)
     else
 
        -- GENERATE THE VERSION/USAGE INFO
-    getImportVersions mod_name exports                 `thenRn` \ my_usages ->
-    getNameSupplyRn                                    `thenRn` \ name_supply ->
+    getImportVersions mod_name export_env      `thenRn` \ my_usages ->
+    getNameSupplyRn                            `thenRn` \ name_supply ->
 
        -- REPORT UNUSED NAMES
     reportUnusedNames gbl_env global_avail_env
@@ -144,18 +142,17 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc)
     let
        has_orphans        = any isOrphanDecl rn_local_decls
        direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports]
-       rn_all_decls       = rn_imp_decls ++ rn_local_decls 
        renamed_module = HsModule mod_name vers 
                                  trashed_exports trashed_imports
                                  rn_all_decls
                                  loc
     in
-    rnStats rn_imp_decls       `thenRn_`
+    rnDump rn_imp_decls        rn_all_decls            `thenRn` \ dump_action ->
     returnRn (Just (mkThisModule mod_name,
                    renamed_module, 
                    (has_orphans, my_usages, export_env),
                    name_supply,
-                   direct_import_mods))
+                   direct_import_mods), dump_action)
   where
     trashed_exports  = {-trace "rnSource:trashed_exports"-} Nothing
     trashed_imports  = {-trace "rnSource:trashed_imports"-} []
@@ -214,9 +211,20 @@ isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _))
 isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _))
   = check lhs
   where
-    check (HsVar v)   = not (isLocallyDefined v)
-    check (HsApp f a) = check f && check a
-    check other              = True
+       -- At the moment we just check for common LHS forms
+       -- Expand as necessary.  Getting it wrong just means
+       -- more orphans than necessary
+    check (HsVar v)      = not (isLocallyDefined v)
+    check (HsApp f a)    = check f && check a
+    check (HsLit _)      = False
+    check (OpApp l o _ r) = check l && check o && check r
+    check (NegApp e _)    = check e
+    check (HsPar e)      = check e
+    check (SectionL e o)  = check e && check o
+    check (SectionR o e)  = check e && check o
+
+    check other                  = True        -- Safe fall through
+
 isOrphanDecl other = False
 \end{code}
 
@@ -399,7 +407,7 @@ vars of the source program, and extracts from the decl the gate names.
 getGates source_fvs (SigD (IfaceSig _ ty _ _))
   = extractHsTyNames ty
 
-getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _))
+getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _))
   = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
                       (map getTyVarName tvs)
     `addOneToNameSet` cls
@@ -482,7 +490,7 @@ getInstDeclGates other                                  = emptyFVs
 %*********************************************************
 
 \begin{code}
-reportUnusedNames gbl_env avail_env (ExportEnv export_avails _) mentioned_names
+reportUnusedNames gbl_env avail_env (ExportEnv export_avails _ _) mentioned_names
   = let
        used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
 
@@ -517,18 +525,20 @@ reportableUnusedName name
     explicitlyImported other                                = False
        -- Don't report others
 
-rnStats :: [RenamedHsDecl] -> RnMG ()
-rnStats imp_decls
+rnDump  :: [RenamedHsDecl]     -- Renamed imported decls
+       -> [RenamedHsDecl]      -- Renamed local decls
+       -> RnMG (IO ())
+rnDump imp_decls decls
         | opt_D_dump_rn_trace || 
          opt_D_dump_rn_stats ||
          opt_D_dump_rn 
-       = getRnStats imp_decls          `thenRn` \ msg ->
-         ioToRnM (printErrs msg)       `thenRn_`
-         returnRn ()
+       = getRnStats imp_decls          `thenRn` \ stats_msg ->
 
-       | otherwise = returnRn ()
-\end{code}
+         returnRn (printErrs stats_msg >> 
+                   dumpIfSet opt_D_dump_rn "Renamer:" (vcat (map ppr decls)))
 
+       | otherwise = returnRn (return ())
+\end{code}
 
 
 %*********************************************************