Normalise the type of an inferred let-binding
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 29 Oct 2014 17:21:05 +0000 (17:21 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 4 Nov 2014 10:37:59 +0000 (10:37 +0000)
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

compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcRnDriver.lhs

index 9f3576d..3741273 100644 (file)
@@ -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
index b628591..e6f7824 100644 (file)
@@ -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 ;