Add right-to-left rule for pattern bindings

Fix #18323 by adding a few lines of code to handle non-recursive pattern bindings. see GHC.Tc.Gen.Bind Note [Special case for non-recursive pattern bindings] Alas, this confused the pattern-match overlap checker; see #18323. Note that this patch only affects pattern bindings like that for (x,y) in this program combine :: (forall a . [a] -> a) -> [forall a. a -> a] -> ((forall a . [a] -> a), [forall a. a -> a]) breaks = let (x,y) = combine head ids in x y True We need ImpredicativeTypes for those [forall a. a->a] types to be valid. And with ImpredicativeTypes the old, unprincipled "allow unification variables to unify with a polytype" story actually works quite well. So this test compiles fine (if delicatedly) with old GHCs; but not with QuickLook unless we add this patch
author: Simon Peyton Jones <simonpj@microsoft.com> 2020-07-28 10:55:25 +0100
committer: Marge Bot <ben+marge-bot@smart-cactus.org> 2020-08-19 18:48:14 -0400
commit: eb9bdaef6024558696e1e50b12d7fefb70483a9f (patch)
tree: c6d13c6f1fb212746a627397e13308c830e9635f /compiler/GHC/Tc/Gen
parent: 731c8d3bc5a84515793e5dadb26adf52f9280e13 (diff)
download: haskell-eb9bdaef6024558696e1e50b12d7fefb70483a9f.tar.gz
3 files changed, 110 insertions, 31 deletions
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 7cf3126bbf..d52b3dd1cd 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -1274,20 +1274,15 @@ tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking pur
             -> TcSigFun -> LetBndrSpec
             -> [LHsBind GhcRn]
             -> TcM (LHsBinds GhcTc, [MonoBindInfo])
+
+-- SPECIAL CASE 1: see Note [Inference for non-recursive function bindings]
 tcMonoBinds is_rec sig_fn no_gen
            [ L b_loc (FunBind { fun_id = L nm_loc name
                               , fun_matches = matches })]
                              -- Single function binding,
   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
   , Nothing <- sig_fn name   -- ...with no type signature
-  =     -- Note [Single function non-recursive binding special-case]
-        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-        -- In this very special case we infer the type of the
-        -- right hand side first (it may have a higher-rank type)
-        -- and *then* make the monomorphic Id for the LHS
-        -- e.g.         f = \(x::forall a. a->a) -> <body>
-        --      We want to infer a higher-rank type for f
-    setSrcSpan b_loc    $
+  = setSrcSpan b_loc    $
     do  { ((co_fn, matches'), rhs_ty)
             <- tcInfer $ \ exp_ty ->
                tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
@@ -1305,6 +1300,29 @@ tcMonoBinds is_rec sig_fn no_gen
                        , mbi_sig       = Nothing
                        , mbi_mono_id   = mono_id }]) }
 
+-- SPECIAL CASE 2: see Note [Inference for non-recursive pattern bindings]
+tcMonoBinds is_rec sig_fn no_gen
+           [L b_loc (PatBind { pat_lhs = pat, pat_rhs = grhss })]
+  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
+  , all (isNothing . sig_fn) bndrs
+  = addErrCtxt (patMonoBindsCtxt pat grhss) $
+    do { (grhss', pat_ty) <- tcInfer $ \ exp_ty ->
+                             tcGRHSsPat grhss exp_ty
+
+       ; let exp_pat_ty :: Scaled ExpSigmaType
+             exp_pat_ty = unrestricted (mkCheckExpType pat_ty)
+       ; (pat', mbis) <- tcLetPat (const Nothing) no_gen pat exp_pat_ty $
+                         mapM lookupMBI bndrs
+
+       ; return ( unitBag $ L b_loc $
+                     PatBind { pat_lhs = pat', pat_rhs = grhss'
+                             , pat_ext = pat_ty, pat_ticks = ([],[]) }
+
+                , mbis ) }
+  where
+    bndrs = collectPatBinders pat
+
+-- GENERAL CASE
 tcMonoBinds _ sig_fn no_gen binds
   = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
 
@@ -1327,6 +1345,66 @@ tcMonoBinds _ sig_fn no_gen binds
 
         ; return (listToBag binds', mono_infos) }
 
+{- Note [Special case for non-recursive function bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the special case of
+* A non-recursive FunBind
+* With no type signature
+we infer the type of the right hand side first (it may have a
+higher-rank type) and *then* make the monomorphic Id for the LHS e.g.
+   f = \(x::forall a. a->a) -> <body>
+
+We want to infer a higher-rank type for f
+
+Note [Special case for non-recursive pattern bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the special case of
+* A pattern binding
+* With no type signature for any of the binders
+we can /infer/ the type of the RHS, and /check/ the pattern
+against that type.  For example (#18323)
+
+  ids :: [forall a. a -> a]
+  combine :: (forall a . [a] -> a) -> [forall a. a -> a]
+          -> ((forall a . [a] -> a), [forall a. a -> a])
+
+  (x,y) = combine head ids
+
+with -XImpredicativeTypes we can infer a good type for
+(combine head ids), and use that to tell us the polymorphic
+types of x and y.
+
+We don't need to check -XImpredicativeTypes beucase without it
+these types like [forall a. a->a] are illegal anyway, so this
+special case code only really has an effect if -XImpredicativeTypes
+is on.  Small exception:
+  (x) = e
+is currently treated as a pattern binding so, even absent
+-XImpredicativeTypes, we will get a small improvement in behaviour.
+But I don't think it's worth an extension flag.
+
+Why do we require no type signatures on /any/ of the binders?
+Consider
+   x :: forall a. a->a
+   y :: forall a. a->a
+   (x,y) = (id,id)
+
+Here we should /check/ the RHS with expected type
+  (forall a. a->a, forall a. a->a).
+
+If we have no signatures, we can the approach of this Note
+to /infer/ the type of the RHS.
+
+But what if we have some signatures, but not all? Say this:
+  p :: forall a. a->a
+  (p,q) = (id,  (\(x::forall b. b->b). x True))
+
+Here we want to push p's signature inwards, i.e. /checking/, to
+correctly elaborate 'id'. But we want to /infer/ q's higher rank
+type.  There seems to be no way to do this.  So currently we only
+switch to inference when we have no signature for any of the binders.
+-}
+
 
 ------------------------
 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
@@ -1394,7 +1472,7 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
                  -- The above inferred type get an unrestricted multiplicity. It may be
                  -- worth it to try and find a finer-grained multiplicity here
                  -- if examples warrant it.
-               mapM lookup_info nosig_names
+               mapM lookupMBI nosig_names
 
         ; let mbis = sig_mbis ++ nosig_mbis
 
@@ -1412,19 +1490,19 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
                       Just (TcIdSig sig) -> Right (name, sig)
                       _                  -> Left name
 
-      -- After typechecking the pattern, look up the binder
-      -- names that lack a signature, which the pattern has brought
-      -- into scope.
-    lookup_info :: Name -> TcM MonoBindInfo
-    lookup_info name
-      = do { mono_id <- tcLookupId name
-           ; return (MBI { mbi_poly_name = name
-                         , mbi_sig       = Nothing
-                         , mbi_mono_id   = mono_id }) }
-
 tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
         -- AbsBind, VarBind impossible
 
+lookupMBI :: Name -> TcM MonoBindInfo
+-- After typechecking the pattern, look up the binder
+-- names that lack a signature, which the pattern has brought
+-- into scope.
+lookupMBI name
+  = do { mono_id <- tcLookupId name
+       ; return (MBI { mbi_poly_name = name
+                     , mbi_sig       = Nothing
+                     , mbi_mono_id   = mono_id }) }
+
 -------------------
 tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
 tcLhsSigId no_gen (name, sig)
@@ -1467,15 +1545,9 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
     tcExtendIdBinderStackForRhs infos        $
     do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
-                    tcScalingUsage Many $
-                    -- Like in tcMatchesFun, this scaling happens because all
-                    -- let bindings are unrestricted. A difference, here, is
-                    -- that when this is not the case, any more, we will have to
-                    -- make sure that the pattern is strict, otherwise this will
-                    -- be desugar to incorrect code.
-                    tcGRHSsPat grhss pat_ty
+                    tcGRHSsPat grhss (mkCheckExpType pat_ty)
         ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
-                           , pat_ext = NPatBindTc emptyNameSet pat_ty
+                           , pat_ext = pat_ty
                            , pat_ticks = ([],[]) } )}
 
 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index b68e0db87c..d978f5dbf3 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -157,10 +157,17 @@ tcMatchLambda herald match_ctxt match res_ty
 
 -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 
-tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType
+tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
            -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
 -- Used for pattern bindings
-tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty)
+tcGRHSsPat grhss res_ty
+  = tcScalingUsage Many $
+      -- Like in tcMatchesFun, this scaling happens because all
+      -- let bindings are unrestricted. A difference, here, is
+      -- that when this is not the case, any more, we will have to
+      -- make sure that the pattern is strict, otherwise this will
+      -- desugar to incorrect code.
+    tcGRHSs match_ctxt grhss res_ty
   where
     match_ctxt = MC { mc_what = PatBindRhs,
                       mc_body = tcBody }
diff --git a/compiler/GHC/Tc/Gen/Match.hs-boot b/compiler/GHC/Tc/Gen/Match.hs-boot
index 692d04b884..bb194a3cf1 100644
--- a/compiler/GHC/Tc/Gen/Match.hs-boot
+++ b/compiler/GHC/Tc/Gen/Match.hs-boot
@@ -2,13 +2,13 @@ module GHC.Tc.Gen.Match where
 import GHC.Hs           ( GRHSs, MatchGroup, LHsExpr )
 import GHC.Tc.Types.Evidence  ( HsWrapper )
 import GHC.Types.Name   ( Name )
-import GHC.Tc.Utils.TcType( ExpSigmaType, TcRhoType )
+import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType )
 import GHC.Tc.Types     ( TcM )
 import GHC.Types.SrcLoc ( Located )
 import GHC.Hs.Extension ( GhcRn, GhcTc )
 
 tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)
-              -> TcRhoType
+              -> ExpRhoType
               -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
 
 tcMatchesFun :: Located Name
author	Simon Peyton Jones <simonpj@microsoft.com>	2020-07-28 10:55:25 +0100
committer	Marge Bot <ben+marge-bot@smart-cactus.org>	2020-08-19 18:48:14 -0400
commit	eb9bdaef6024558696e1e50b12d7fefb70483a9f (patch)
tree	c6d13c6f1fb212746a627397e13308c830e9635f /compiler/GHC/Tc/Gen
parent	731c8d3bc5a84515793e5dadb26adf52f9280e13 (diff)
download	haskell-eb9bdaef6024558696e1e50b12d7fefb70483a9f.tar.gz