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 <[email protected]> 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
