Add hook to fam inst consistency check to GHCi/--make
[ghc.git] / compiler / typecheck / TcRnDriver.lhs
index 94c55a7..9c9c71f 100644 (file)
@@ -12,6 +12,7 @@ module TcRnDriver (
        tcRnLookupName,
        tcRnGetInfo,
        getModuleExports, 
+        tcRnRecoverDataCon,
 #endif
        tcRnModule, 
        tcTopSrcDecls,
@@ -37,6 +38,7 @@ import TcExpr
 import TcRnMonad
 import TcType
 import Inst
+import FamInst
 import InstEnv
 import FamInstEnv
 import TcBinds
@@ -64,13 +66,15 @@ import Module
 import UniqFM
 import Name
 import NameSet
-import NameEnv
 import TyCon
 import SrcLoc
 import HscTypes
 import Outputable
+import Breakpoints
 
 #ifdef GHCI
+import Linker
+import DataCon
 import TcHsType
 import TcMType
 import TcMatches
@@ -173,6 +177,13 @@ tcRnModule hsc_env hsc_src save_rn_syntax
        loadOrphanModules (imp_orphs  imports) False ;
        loadOrphanModules (imp_finsts imports) True  ;
 
+       traceRn (text "rn1: checking family instance consistency") ;
+       let { directlyImpMods =   map (\(mod, _, _) -> mod) 
+                               . moduleEnvElts 
+                               . imp_mods 
+                               $ imports } ;
+       checkFamInstConsistency (imp_finsts imports) directlyImpMods ;
+
        traceRn (text "rn1a") ;
                -- Rename and type check the declarations
        tcg_env <- if isHsBoot hsc_src then
@@ -181,6 +192,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax
                        tcRnSrcDecls local_decls ;
        setGblEnv tcg_env               $ do {
 
+       failIfErrsM ;   -- reportDeprecations crashes sometimes 
+                       -- as a result of typechecker repairs (e.g. unboundNames)
        traceRn (text "rn3") ;
 
                -- Report the use of any deprecated things
@@ -193,6 +206,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax
                -- Process the export list
        (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ;
                  
+       traceRn (text "rn4") ;
+
                -- Rename the Haddock documentation header 
        rn_module_doc <- rnMbHsDoc maybe_doc ;
 
@@ -294,7 +309,9 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                mg_rdr_env   = emptyGlobalRdrEnv,
                                mg_fix_env   = emptyFixityEnv,
                                mg_deprecs   = NoDeprecs,
-                               mg_foreign   = NoStubs
+                               mg_foreign   = NoStubs,
+                               mg_hpc_info  = noHpcInfo,
+                                mg_dbg_sites = noDbgSites
                    } } ;
 
    tcCoreDump mod_guts ;
@@ -326,29 +343,34 @@ tcRnSrcDecls decls
        boot_iface <- tcHiBootIface mod ;
 
                -- Do all the declarations
-       (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ;
+       (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ;
 
+            --         Finish simplifying class constraints
+            -- 
             -- tcSimplifyTop deals with constant or ambiguous InstIds.  
             -- How could there be ambiguous ones?  They can only arise if a
-            -- top-level decl falls under the monomorphism
-            -- restriction, and no subsequent decl instantiates its
-            -- type.  (Usually, ambiguous type variables are resolved
-            -- during the generalisation step.)
+            -- top-level decl falls under the monomorphism restriction
+            -- and no subsequent decl instantiates its type.
+            --
+            -- We do this after checkMain, so that we use the type info 
+            -- thaat checkMain adds
+            -- 
+            -- We do it with both global and local env in scope:
+            --  * the global env exposes the instances to tcSimplifyTop
+            --  * the local env exposes the local Ids to tcSimplifyTop, 
+            --    so that we get better error messages (monomorphism restriction)
         traceTc (text "Tc8") ;
        inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
-               -- Setting the global env exposes the instances to tcSimplifyTop
-               -- Setting the local env exposes the local Ids to tcSimplifyTop, 
-               -- so that we get better error messages (monomorphism restriction)
 
            -- Backsubstitution.  This must be done last.
            -- Even tcSimplifyTop may do some unification.
         traceTc (text "Tc9") ;
-       let { (tcg_env, _) = tc_envs ;
-             TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, 
-                        tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
+       let { (tcg_env, _) = tc_envs
+           ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, 
+                        tcg_rules = rules, tcg_fords = fords } = tcg_env
+           ; all_binds = binds `unionBags` inst_binds } ;
 
-       (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
-                                                          rules fords ;
+       (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
 
        let { final_type_env = extendTypeEnvWithIds type_env bind_ids
            ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
@@ -372,21 +394,17 @@ tc_rn_src_decls boot_details ds
  = do { let { (first_group, group_tail) = findSplice ds } ;
                -- If ds is [] we get ([], Nothing)
 
-       -- Type check the decls up to, but not including, the first splice
-       tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ;
-
-       -- Bale out if errors; for example, error recovery when checking
-       -- the RHS of 'main' can mean that 'main' is not in the envt for 
-       -- the subsequent checkMain test
-       failIfErrsM ;
-
-       setEnvs tc_envs $
+       -- Deal with decls up to, but not including, the first splice
+       (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ;
+               -- checkNoErrs: don't typecheck if renaming failed
+       tc_envs <- setGblEnv tcg_env $ 
+                  tcTopSrcDecls boot_details rn_decls ;
 
        -- If there is no splice, we're nearly done
+       setEnvs tc_envs $ 
        case group_tail of {
-          Nothing -> do {      -- Last thing: check for `main'
-                          tcg_env <- checkMain ;
-                          return (tcg_env, tcl_env) 
+          Nothing -> do { tcg_env <- checkMain ;       -- Check for `main'
+                          return (tcg_env, snd tc_envs) 
                      } ;
 
        -- If there's a splice, we must carry on
@@ -396,8 +414,8 @@ tc_rn_src_decls boot_details ds
 #else
 
        -- Rename the splice expression, and get its supporting decls
-       (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
-       failIfErrsM ;   -- Don't typecheck if renaming failed
+       (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
+               -- checkNoErrs: don't typecheck if renaming failed
        rnDump (ppr rn_splice_expr) ;
 
        -- Execute the splice
@@ -407,7 +425,7 @@ tc_rn_src_decls boot_details ds
        setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
        tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
 #endif /* GHCI */
-    }}}
+    } } }
 \end{code}
 
 %************************************************************************
@@ -454,7 +472,7 @@ tcRnHsBootDecls decls
        ; gbl_env <- getGblEnv 
        
                -- Make the final type-env
-               -- Include the dfun_ids so that their type sigs get
+               -- Include the dfun_ids so that their type sigs
                -- are written into the interface file
        ; let { type_env0 = tcg_type_env gbl_env
              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
@@ -558,17 +576,6 @@ declarations.  It expects there to be an incoming TcGblEnv in the
 monad; it augments it and returns the new TcGblEnv.
 
 \begin{code}
-tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
-       -- Returns the variables free in the decls, for unused-binding reporting
-tcRnGroup boot_details decls
- = do {                -- Rename the declarations
-       (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
-       setGblEnv tcg_env $ do {
-
-               -- Typecheck the declarations
-       tcTopSrcDecls boot_details rn_decls 
-  }}
-
 ------------------------------------------------
 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 rnTopSrcDecls group
@@ -1034,12 +1041,11 @@ 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)      <- getLIE (tcInferRho rn_expr) ;
-    ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
+    ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
     tcSimplifyInteractive lie_top ;
-    qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
 
-    let { all_expr_ty = mkForAllTys qtvs' $
-                       mkFunTys (map idType dict_ids)  $
+    let { all_expr_ty = mkForAllTys qtvs $
+                       mkFunTys (map (idType . instToId) dict_insts)   $
                        res_ty } ;
     zonkTcType all_expr_ty
     }
@@ -1086,19 +1092,32 @@ tcRnType hsc_env ictxt rdr_type
 -- could not be found.
 getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
 getModuleExports hsc_env mod
-  = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
-
-tcGetModuleExports :: Module -> TcM [AvailInfo]
-tcGetModuleExports mod = do
-  let doc = ptext SLIT("context for compiling statements")
-  iface <- initIfaceTcRn $ loadSysInterface doc mod
-  loadOrphanModules (dep_orphs (mi_deps iface)) False 
-               -- Load any orphan-module interfaces,
-               -- so their instances are visible
-  loadOrphanModules (dep_finsts (mi_deps iface)) True
-               -- Load any family instance-module interfaces,
-               -- so all family instances are visible
-  ifaceExportNames (mi_exports iface)
+  = let
+      ic        = hsc_IC hsc_env
+      checkMods = ic_toplev_scope ic ++ ic_exports ic
+    in
+    initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod checkMods)
+
+-- Get the export avail info and also load all orphan and family-instance
+-- modules.  Finally, check that the family instances of all modules in the
+-- interactive context are consistent (these modules are in the second
+-- argument).
+tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo]
+tcGetModuleExports mod directlyImpMods
+  = do { let doc = ptext SLIT("context for compiling statements")
+       ; iface <- initIfaceTcRn $ loadSysInterface doc mod
+
+               -- Load any orphan-module and family instance-module
+               -- interfaces, so their instances are visible.
+       ; loadOrphanModules (dep_orphs (mi_deps iface)) False 
+       ; loadOrphanModules (dep_finsts (mi_deps iface)) True
+
+                -- Check that the family instances of all directly loaded
+                -- modules are consistent.
+       ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods
+
+       ; ifaceExportNames (mi_exports iface)
+       }
 
 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
 tcRnLookupRdrName hsc_env rdr_name 
@@ -1135,6 +1154,12 @@ lookup_rdr_name rdr_name = do {
     return good_names
  }
 
+tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon) 
+tcRnRecoverDataCon hsc_env a
+  = initTcPrintErrors hsc_env iNTERACTIVE $ 
+    setInteractiveContext hsc_env (hsc_IC hsc_env) $
+     do name    <- recoverDataCon a
+        tcLookupDataCon name
 
 tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
 tcRnLookupName hsc_env name
@@ -1170,7 +1195,6 @@ tcRnGetInfo hsc_env name
     ispecs <- lookupInsts (icPrintUnqual ictxt) thing
     return (thing, fixity, ispecs)
 
-
 lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
 -- Filter the instances by the ones whose tycons (or clases resp) 
 -- are in scope unqualified.  Otherwise we list a whole lot too many!
@@ -1269,6 +1293,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
                        tcg_rules     = rules,
                        tcg_imports   = imports })
   = vcat [ ppr_types insts type_env
+        , ppr_tycons fam_insts type_env
         , ppr_insts insts
         , ppr_fam_insts fam_insts
         , vcat (map ppr rules)
@@ -1297,6 +1322,17 @@ ppr_types insts type_env
        -- that the type checker has invented.  Top-level user-defined things 
        -- have External names.
 
+ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
+ppr_tycons fam_insts type_env
+  = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons)
+  where
+    fi_tycons = map famInstTyCon fam_insts
+    tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
+    want_tycon tycon | opt_PprStyle_Debug = True
+                    | otherwise          = not (isImplicitTyCon tycon) &&
+                                           isExternalName (tyConName tycon) &&
+                                           not (tycon `elem` fi_tycons)
+
 ppr_insts :: [Instance] -> SDoc
 ppr_insts []     = empty
 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
@@ -1314,6 +1350,16 @@ ppr_sigs ids
     le_sig id1 id2 = getOccName id1 <= getOccName id2
     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
 
+ppr_tydecls :: [TyCon] -> SDoc
+ppr_tydecls tycons
+       -- Print type constructor info; sort by OccName 
+  = vcat (map ppr_tycon (sortLe le_sig tycons))
+  where
+    le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
+    ppr_tycon tycon 
+      | isCoercionTyCon tycon = ptext SLIT("coercion") <+> ppr tycon
+      | otherwise             = ppr (tyThingToIfaceDecl (ATyCon tycon))
+
 ppr_rules :: [CoreRule] -> SDoc
 ppr_rules [] = empty
 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),