Commit a6e7654b authored by Simon Peyton Jones's avatar Simon Peyton Jones

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
parent e11e1b80
......@@ -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
......
......@@ -1641,11 +1641,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 ;
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment