Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : type-holes-branch
http://hackage.haskell.org/trac/ghc/changeset/f2d090d69cf7f1b639ad7164420ffd1a83aad07c >--------------------------------------------------------------- commit f2d090d69cf7f1b639ad7164420ffd1a83aad07c Author: Thijs Alkemade <[email protected]> Date: Thu Jan 12 18:07:35 2012 +0100 Fixed stuff that got changed: * simplifyInfer now takes a bool as first argument, and returns another argument * itName needs a SrcLoc too * PredTy is gone >--------------------------------------------------------------- compiler/typecheck/TcExpr.lhs | 1 - compiler/typecheck/TcRnDriver.lhs | 24 +++++++++++++----------- 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 719af0d..ab513f8 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -233,7 +233,6 @@ tcExpr (HsHole s) res_ty liftIO $ putStrLn ("tcExpr.HsHole @(" ++ (showSDoc $ ppr s) ++ "): " ++ (showSDoc $ ppr meta)) x -> liftIO $ putStrLn ("tcExpr.HsHole: No idea how to handle " ++ (showSDoc $ ppr x)) printTy (ForAllTy _ _) = liftIO $ putStrLn ("tcExpr.HsHole: ForAllTy") - printTy (PredTy _) = liftIO $ putStrLn ("tcExpr.HsHole: ForAllTy") printTy (AppTy _ _) = liftIO $ putStrLn ("tcExpr.HsHole: AppTy") printTy (TyConApp t tys) = liftIO $ putStrLn ("tcExpr.HsHole: TyConApp " ++ (showSDoc $ ppr t) ++ " " ++ (showSDoc $ ppr tys)) printTy t = liftIO $ putStrLn ("tcExpr.HsHole: something else: " ++ (showSDoc $ ppr t)) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 2b468b0..af82a70 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -228,7 +228,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax holes <- readTcRef $ tcl_holes l ; 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) + zonked_holes <- mapM (\(s, (ty, wcs)) -> liftM (\t -> (s, split t)) $ inferHole ty wcs s) $ Map.toList holes ; let { (env, tys) = foldr tidy (emptyTidyEnv, []) zonked_holes @@ -242,16 +242,18 @@ tcRnModule hsc_env hsc_src save_rn_syntax }}}} 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 - } + inferHole :: Type -> TcRef WantedConstraints -> SrcSpan -> TcM Type + inferHole ty wcs s = do { + lie <- readTcRef wcs ; + uniq <- newUnique ; + let { fresh_it = itName uniq s } ; + ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ simplifyInfer + False + False {- No MR for now -} + [(fresh_it, ty)] + lie ; + zonkTcType $ mkForAllTys qtvs $ mkPiTypes dicts ty + } implicitPreludeWarn :: SDoc _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
