Do dependency analysis when kind-checking type declarations

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

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index a42e85d..773f307 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -290,7 +290,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 
    setEnvs tc_envs $ do {
 
-   rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
+   (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ;
 
        -- Dump trace of renaming part
    rnDump (ppr rn_decls) ;
@@ -348,7 +348,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 
 mkFakeGroup :: [LTyClDecl a] -> HsGroup a
 mkFakeGroup decls -- Rather clumsy; lots of unused fields
-  = emptyRdrGroup { hs_tyclds = decls }
+  = emptyRdrGroup { hs_tyclds = [decls] }
 \end{code}
 
 
@@ -364,7 +364,7 @@ tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
        -- Reason: solely to report unused imports and bindings
 tcRnSrcDecls boot_iface decls
  = do {        -- Do all the declarations
-       (tc_envs, lie) <- getConstraints $ tc_rn_src_decls boot_iface decls ;
+       (tc_envs, lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
       ; traceTc "Tc8" empty ;
       ; setEnvs tc_envs $ 
    do { 
@@ -394,20 +394,22 @@ tcRnSrcDecls boot_iface decls
        -- Even simplifyTop may do some unification.
         -- This pass also warns about missing type signatures
        let { (tcg_env, _) = tc_envs
-           ; TcGblEnv { tcg_type_env = type_env,
-                        tcg_binds    = binds,
-                        tcg_sigs     = sig_ns,
-                        tcg_ev_binds = cur_ev_binds,
-                        tcg_rules    = rules,
-                        tcg_fords    = fords } = tcg_env
+           ; TcGblEnv { tcg_type_env  = type_env,
+                        tcg_binds     = binds,
+                        tcg_sigs      = sig_ns,
+                        tcg_ev_binds  = cur_ev_binds,
+                        tcg_imp_specs = imp_specs,
+                        tcg_rules     = rules,
+                        tcg_fords     = fords } = tcg_env
             ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
 
-       (bind_ids, ev_binds', binds', fords', rules') 
-            <- zonkTopDecls all_ev_binds binds sig_ns rules fords ;
+       (bind_ids, ev_binds', binds', fords', imp_specs', rules') 
+            <- zonkTopDecls all_ev_binds binds sig_ns rules imp_specs fords ;
        
        let { final_type_env = extendTypeEnvWithIds type_env bind_ids
            ; tcg_env' = tcg_env { tcg_binds    = binds',
                                   tcg_ev_binds = ev_binds',
+                                  tcg_imp_specs = imp_specs',
                                   tcg_rules    = rules', 
                                   tcg_fords    = fords' } } ;
 
@@ -480,7 +482,7 @@ tcRnHsBootDecls decls
                   hs_ruleds = rule_decls, 
                   hs_annds  = _,
                   hs_valds  = val_binds }) <- rnTopSrcDecls first_group
-       ; (gbl_env, lie) <- getConstraints $ setGblEnv tcg_env $ do {
+       ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
 
 
                -- Check for illegal declarations
@@ -502,7 +504,7 @@ tcRnHsBootDecls decls
                -- Family instance declarations are rejected here
        ; traceTc "Tc3" empty
        ; (tcg_env, inst_infos, _deriv_binds) 
-            <- tcInstDecls1 tycl_decls inst_decls deriv_decls
+            <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls
        ; setGblEnv tcg_env     $ do {
 
                -- Typecheck value declarations
@@ -844,7 +846,7 @@ tcTopSrcDecls boot_details
                -- and import the supporting declarations
         traceTc "Tc3" empty ;
        (tcg_env, inst_infos, deriv_binds) 
-            <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
+            <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls;
        setGblEnv tcg_env       $ do {
 
                -- Foreign import declarations next. 
@@ -860,20 +862,20 @@ tcTopSrcDecls boot_details
                -- Now GHC-generated derived bindings, generics, and selectors
                -- Do not generate warnings from compiler-generated code;
                -- hence the use of discardWarnings
-       (tc_aux_binds,   tcl_env) <- discardWarnings (tcTopBinds aux_binds) ;
-       (tc_deriv_binds, tcl_env) <- setLclTypeEnv tcl_env $ 
-                                    discardWarnings (tcTopBinds deriv_binds) ;
+       (tc_aux_binds,   specs1, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ;
+       (tc_deriv_binds, specs2, tcl_env) <- setLclTypeEnv tcl_env $ 
+                                            discardWarnings (tcTopBinds deriv_binds) ;
 
                -- Value declarations next
         traceTc "Tc5" empty ;
-       (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $
-                                  tcTopBinds val_binds;
+       (tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $
+                                          tcTopBinds val_binds;
 
         setLclTypeEnv tcl_env $ do {   -- Environment doesn't change now
 
                -- Second pass over class and instance declarations, 
         traceTc "Tc6" empty ;
-       inst_binds <- tcInstDecls2 tycl_decls inst_infos ;
+       inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
 
                -- Foreign exports
         traceTc "Tc7" empty ;
@@ -900,6 +902,7 @@ tcTopSrcDecls boot_details
                -- Extend the GblEnv with the (as yet un-zonked) 
                -- bindings, rules, foreign decls
            ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
+                                , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ specs3
                                  , tcg_sigs  = tcg_sigs tcg_env `unionNameSets` sig_names
                                 , tcg_rules = tcg_rules tcg_env ++ rules
                                 , tcg_anns  = tcg_anns tcg_env ++ annotations
@@ -1079,7 +1082,8 @@ tcRnStmt hsc_env ictxt rdr_stmt
     setInteractiveContext hsc_env ictxt $ do {
 
     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
-    (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] (return ((), emptyFVs)) ;
+    (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ ->
+                             return ((), emptyFVs) ;
     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
     failIfErrsM ;
     rnDump (ppr rn_stmt) ;
@@ -1271,7 +1275,7 @@ tcGhciStmts stmts
 
        -- OK, we're ready to typecheck the stmts
        traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
-       ((tc_stmts, ids), lie) <- getConstraints $ tc_io_stmts stmts $ \ _ ->
+       ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ ->
                                           mapM tcLookupId names ;
                                        -- Look up the names right in the middle,
                                        -- where they will all be in scope
@@ -1304,8 +1308,8 @@ tcRnExpr hsc_env ictxt rdr_expr
 
        -- Now typecheck the expression; 
        -- it might have a rank-2 type (e.g. :t runST)
-    ((_tc_expr, res_ty), lie)  <- getConstraints (tcInferRho rn_expr) ;
-    ((qtvs, dicts, _), lie_top) <- getConstraints (simplifyInfer False {- No MR for now -}
+    ((_tc_expr, res_ty), lie)  <- captureConstraints (tcInferRho rn_expr) ;
+    ((qtvs, dicts, _), lie_top) <- captureConstraints (simplifyInfer False {- No MR for now -}
                                                       (tyVarsOfType res_ty) lie)  ;
     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings