[commit: ghc] type-holes-branch: Make sure the holes have the right class constrains when checking a full module. (9a0ce24)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : type-holes-branch

http://hackage.haskell.org/trac/ghc/changeset/9a0ce24aa7d21f09b036866b68f552c936f61518

>---------------------------------------------------------------

commit 9a0ce24aa7d21f09b036866b68f552c936f61518
Author: Thijs Alkemade <thijsalkemade at gmail.com>
Date:   Thu Jan 12 16:55:54 2012 +0100

    Make sure the holes have the right class constrains when checking a full module.

>---------------------------------------------------------------

 compiler/typecheck/TcExpr.lhs     |    2 +-
 compiler/typecheck/TcRnDriver.lhs |   23 ++++++++++++++++++++---
 compiler/typecheck/TcRnTypes.lhs  |    2 +-
 3 files changed, 22 insertions(+), 5 deletions(-)

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 14d5708..719af0d 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -226,7 +226,7 @@ tcExpr (HsHole s) res_ty
          printTy res_ty ;
          (g, l) <- getEnvs ;
          holes <- readTcRef $ tcl_holes l ;
-         writeTcRef (tcl_holes l) (Map.insert s res_ty holes) ;
+         writeTcRef (tcl_holes l) (Map.insert s (res_ty, tcl_lie l) holes) ;
          return (HsHole s) }
        where printTy (TyVarTy ty) = case tcTyVarDetails ty of
                                           (MetaTv _ io) -> do meta <- readTcRef io ;
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 2cf0979..2b468b0 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -226,17 +226,32 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 
 	(_, l) <- getEnvs ;
 	holes <- readTcRef $ tcl_holes l ;
-	zonked_holes <- mapM (\(s, ty) -> liftM (\t -> (s, t)) $ zonkTcType ty)
+	lie <- readTcRef $ tcl_lie l ;
+	liftIO $ putStrLn ("tcRnModule0: " ++ (showSDoc $ ppr $ lie)) ;
+	zonked_holes <- mapM (\(s, (ty, wcs)) -> liftM (\t -> (s, split t)) $ inferHole ty wcs)
 				$ Map.toList holes ;
 	let {
 		(env, tys) = foldr tidy (emptyTidyEnv, []) zonked_holes
             } ;
 	liftIO $ putStrLn ("tcRnModule: " ++ (showSDoc $ ppr $ tys)) ;
 	liftIO $ putStrLn ("tcRnModule2: " ++ (showSDoc $ ppr env)) ;
+	lie' <- readTcRef $ tcl_lie l ;
+	liftIO $ putStrLn ("tcRnModule0: " ++ (showSDoc $ ppr $ lie')) ;
 
     	return tcg_env
     }}}}
     where tidy (s, ty) (env, tys) = let (env', ty') = tidyOpenType env ty in (env', (s, ty') : tys)
+    	  split t = let (_, ctxt, ty') = tcSplitSigmaTy $ tidyTopType t in mkPhiTy ctxt ty'
+    	  inferHole :: Type -> TcRef WantedConstraints -> TcM Type
+    	  inferHole ty wcs = do {
+    	  						lie <- readTcRef wcs ;
+						    	uniq <- newUnique ;
+					    	    let { fresh_it  = itName uniq } ;
+					    	  	((qtvs, dicts, _), lie_top) <- captureConstraints $ simplifyInfer TopLevel False {- No MR for now -}
+					                                             	    		[(fresh_it, ty)]
+					                                                 			lie ;
+					            zonkTcType $ mkForAllTys qtvs $ mkPiTypes dicts ty
+						    	}
 
 
 implicitPreludeWarn :: SDoc
@@ -453,6 +468,8 @@ tcRnSrcDecls boot_iface decls
                         simplifyTop lie ;
         traceTc "Tc9" empty ;
 
+        liftIO $ putStrLn ("tcRnSrcDecls: " ++ (showSDoc $ ppr lie)) ;
+
 	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!
@@ -1449,10 +1466,10 @@ tcRnExpr hsc_env ictxt rdr_expr
     (_, l) <- getEnvs ;
     holes <- readTcRef $ tcl_holes l ;
     zonked_holes <- mapM (\(s, ty) -> liftM (\t -> (s, t)) $ zonkTcType ty)
-				$ Map.toList $ Map.map (\ty -> mkForAllTys qtvs $ mkPiTypes dicts ty) $ holes ;
+				$ Map.toList $ Map.map (\(ty, _) -> mkForAllTys qtvs $ mkPiTypes dicts ty) $ holes ;
     let { (env, tys) = foldr tidy (emptyTidyEnv, []) zonked_holes } ;
     liftIO $ putStrLn ("tcRnExpr2: " ++ (showSDoc $ ppr $ map (\(s, t) -> (s, split t)) tys)) ;
-    liftIO $ putStrLn ("tcRnExpr3: " ++ (showSDoc $ ppr env)) ;
+    liftIO $ putStrLn ("tcRnExpr3: " ++ (showSDoc $ ppr dicts)) ;
 
     return $ snd $ tidyOpenType env result
     }
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index f9271c9..695028b 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -441,7 +441,7 @@ data TcLclEnv		-- Changes as we move inside an expression
 	tcl_untch :: Unique,	    -- Any TcMetaTyVar with 
 		     		    --     unique >= tcl_untch is touchable
 		     		    --     unique <  tcl_untch is untouchable
-	tcl_holes :: TcRef (Map.Map SrcSpan Type)
+	tcl_holes :: TcRef (Map.Map SrcSpan (Type, TcRef WantedConstraints))
     }
 
 type TcTypeEnv = NameEnv TcTyThing