[commit: ghc] wip/new-flatten-skolems-Oct14: Normalise the type of an inferred let-binding (23600fb)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/new-flatten-skolems-Oct14
Link       : http://ghc.haskell.org/trac/ghc/changeset/23600fb2016bd460e1e9d208441d4056f1359ee9/ghc

>---------------------------------------------------------------

commit 23600fb2016bd460e1e9d208441d4056f1359ee9
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Oct 29 17:21:05 2014 +0000

    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


>---------------------------------------------------------------

23600fb2016bd460e1e9d208441d4056f1359ee9
 compiler/typecheck/TcBinds.lhs    | 26 +++++++++++++++++---------
 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 9f3576d..3741273 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 8ec8118..e9a6f82 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 ;