Refactor error recovery slightly

[ghc-hetmet.git] / compiler / typecheck / TcRnDriver.lhs

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 7c79e62..c744c15 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -125,7 +125,7 @@ tcRnModule :: HscEnv
 
 tcRnModule hsc_env hsc_src save_rn_syntax
         (L loc (HsModule maybe_mod export_ies 
-                         import_decls local_decls mod_deprec _ 
+                         import_decls local_decls mod_deprec
                          module_info maybe_doc))
  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 
@@ -170,8 +170,9 @@ tcRnModule hsc_env hsc_src save_rn_syntax
        tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ;
 
                -- Process the export list
+       traceRn (text "rn4a: before exports");
        tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
-       traceRn (text "rn4") ;
+       traceRn (text "rn4b: after exportss") ;
 
        -- Compare the hi-boot iface (if any) with the real thing
        -- Must be done after processing the exports
@@ -282,21 +283,26 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 
    let { ldecls  = map noLoc decls } ;
 
-       -- Deal with the type declarations; first bring their stuff
-       -- into scope, then rname them, then type check them
-   tcg_env  <- importsFromLocalDecls (mkFakeGroup ldecls) ;
+       -- bring the type and class decls into scope
+       -- ToDo: check that this doesn't need to extract the val binds.
+       --       It seems that only the type and class decls need to be in scope below because
+       --          (a) tcTyAndClassDecls doesn't need the val binds, and 
+       --          (b) tcExtCoreBindings doesn't need anything
+       --              (in fact, it might not even need to be in the scope of
+       --               this tcg_env at all)
+   tcg_env  <- importsFromLocalDecls False (mkFakeGroup ldecls) 
+               emptyUFM {- no fixity decls -} ;
 
    setGblEnv tcg_env $ do {
 
-   rn_decls <- rnTyClDecls ldecls ;
-   failIfErrsM ;
+   rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
 
        -- Dump trace of renaming part
    rnDump (ppr rn_decls) ;
 
        -- Typecheck them all together so that
        -- any mutually recursive types are done right
-   tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ;
+   tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ;
        -- Make the new type env available to stuff slurped from interface files
 
    setGblEnv tcg_env $ do {
@@ -385,6 +391,10 @@ tcRnSrcDecls boot_iface decls
                         tcg_rules = rules, tcg_fords = fords } = tcg_env
            ; all_binds = binds `unionBags` inst_binds } ;
 
+       failIfErrsM ;   -- Don't zonk if there have been errors
+                       -- It's a waste of time; and we may get debug warnings
+                       -- about strangely-typed TyCons!
+
        (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
 
        let { final_type_env = extendTypeEnvWithIds type_env bind_ids
@@ -404,8 +414,8 @@ tc_rn_src_decls boot_details ds
                -- If ds is [] we get ([], Nothing)
 
        -- Deal with decls up to, but not including, the first splice
-       (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ;
-               -- checkNoErrs: stop if renaming fails
+       (tcg_env, rn_decls) <- rnTopSrcDecls first_group ;
+               -- rnTopSrcDecls fails if there are any errors
 
        (tcg_env, tcl_env) <- setGblEnv tcg_env $ 
                              tcTopSrcDecls boot_details rn_decls ;
@@ -463,7 +473,7 @@ tcRnHsBootDecls decls
                -- Typecheck type/class decls
        ; traceTc (text "Tc2")
        ; let tycl_decls = hs_tyclds rn_group
-       ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)
+       ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls
        ; setGblEnv tcg_env     $ do {
 
                -- Typecheck instance decls
@@ -631,18 +641,12 @@ monad; it augments it and returns the new TcGblEnv.
 \begin{code}
 ------------------------------------------------
 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
+-- Fails if there are any errors
 rnTopSrcDecls group
- = do {        -- Bring top level binders into scope
-       tcg_env <- importsFromLocalDecls group ;
-       setGblEnv tcg_env $ do {
-
-       failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
+ = do { -- Rename the source decls (with no shadowing; error on duplicates)
+       (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ;
 
-               -- Rename the source decls
-       (tcg_env, rn_decls) <- rnSrcDecls group ;
-       failIfErrsM ;
-
-               -- save the renamed syntax, if we want it
+        -- save the renamed syntax, if we want it
        let { tcg_env'
                | Just grp <- tcg_rn_decls tcg_env
                  = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
@@ -653,7 +657,7 @@ rnTopSrcDecls group
        rnDump (ppr rn_decls) ;
 
        return (tcg_env', rn_decls)
-   }}
+   }
 
 ------------------------------------------------
 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
@@ -669,9 +673,8 @@ tcTopSrcDecls boot_details
                -- The latter come in via tycl_decls
         traceTc (text "Tc2") ;
 
-       tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ;
-       -- tcTyAndClassDecls recovers internally, but if anything gave rise to
-       -- an error we'd better stop now, to avoid a cascade
+       tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
+               -- If there are any errors, tcTyAndClassDecls fails here
        
        -- Make these type and class decls available to stuff slurped from interface files
        writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;