diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-10-29 17:21:05 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-10-31 09:08:48 +0000 |
commit | 23600fb2016bd460e1e9d208441d4056f1359ee9 (patch) | |
tree | b90956bd81ea7dcf989ca3034e8268d0392bf4ae | |
parent | 446ced2fab5e221c724be4b4fbc6946e7959508f (diff) | |
download | haskell-23600fb2016bd460e1e9d208441d4056f1359ee9.tar.gz |
Normalise the type of an inferred let-binding
With the new constraint solver, we don't guarantee to fully-normalise
all constraints (if doing so is not necessary to solve them). So we
may end up with an inferred type like
f :: [F Int] -> Bool
which could be simplifed to
f :: [Char] -> Bool
if there is a suitable family instance declaration. This patch
does this normalisation, in TcBinds.mkExport
-rw-r--r-- | compiler/typecheck/TcBinds.lhs | 26 | ||||
-rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 7 |
2 files changed, 21 insertions, 12 deletions
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 9f3576debe..3741273884 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -31,8 +31,9 @@ import TcPat import TcMType import PatSyn import ConLike +import FamInstEnv( normaliseType ) +import FamInst( tcGetFamInstEnvs ) import Type( tidyOpenType ) -import FunDeps( growThetaTyVars ) import TyCon import TcType import TysPrim @@ -678,15 +679,22 @@ mkInferredPolyId :: Name -> [TyVar] -> TcThetaType -> TcType -> TcM Id -- the right type variables and theta to quantify over -- See Note [Validity of inferred types] mkInferredPolyId poly_name qtvs theta mono_ty - = addErrCtxtM (mk_bind_msg True False poly_name inferred_poly_ty) $ - do { checkValidType (InfSigCtxt poly_name) inferred_poly_ty - ; return (mkLocalId poly_name inferred_poly_ty) } - where - my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType mono_ty)) + = do { fam_envs <- tcGetFamInstEnvs + + ; let (_co, norm_mono_ty) = normaliseType fam_envs Nominal mono_ty + -- Unification may not have normalised the type, so do it + -- here to make it as uncomplicated as possible. + -- Example: f :: [F Int] -> Bool + -- should be rewritten to f :: [Char] -> Bool, if possible + my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType norm_mono_ty)) -- Include kind variables! Trac #7916 - my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order - my_theta = filter (quantifyPred my_tvs2) theta - inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty + my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order + my_theta = filter (quantifyPred my_tvs2) theta + inferred_poly_ty = mkSigmaTy my_tvs my_theta norm_mono_ty + + ; addErrCtxtM (mk_bind_msg True False poly_name inferred_poly_ty) $ + checkValidType (InfSigCtxt poly_name) inferred_poly_ty + ; return (mkLocalId poly_name inferred_poly_ty) } mk_bind_msg :: Bool -> Bool -> Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_bind_msg inferred want_ambig poly_name poly_ty tidy_env diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 8ec81188ea..e9a6f82f1d 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1645,11 +1645,12 @@ tcRnExpr hsc_env rdr_expr -- it might have a rank-2 type (e.g. :t runST) uniq <- newUnique ; let { fresh_it = itName uniq (getLoc rdr_expr) } ; - ((_tc_expr, res_ty), lie) <- captureConstraints $ - tcInferRho rn_expr ; + (((_tc_expr, res_ty), untch), lie) <- captureConstraints $ + captureUntouchables $ + tcInferRho rn_expr ; ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ {-# SCC "simplifyInfer" #-} - simplifyInfer True {- Free vars are closed -} + simplifyInfer untch False {- No MR for now -} [(fresh_it, res_ty)] lie ; |