Fix #10045

Summary:
SPJ's solution is to only bring the `TcId` (which includes the type) of a
binder into scope when it had a non-partial type signature.

Take care of this by only storing the `TcId` in `TcSigInfo` of non-partial
type signatures, hence the change to `sig_poly_id :: Maybe TcId`. Only in case
of a `Just` will we bring the `TcId` in scope. We still need to know the name
of the binder, even when it has a partial type signature, so add a `sig_name
:: Name` field. The field `sig_partial :: Bool` is no longer necessary, so
reimplement `isPartialSig` in terms of `sig_poly_id`.

Note that the new test case fails, but not because of a panic, but because the
`Num a` constraint is missing. Adding an extra-constraints wildcard to
`copy`'s signature would fix it.

Test Plan: validate

Reviewers: simonpj, austin

Reviewed By: simonpj

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D646

GHC Trac Issues: #10045

7 files changed, 139 insertions, 41 deletions

diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 9d0bb551bf..acdaf8f876 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -544,16 +544,17 @@ tcPolyCheck :: RecFlag       -- Whether it's recursive after breaking
 --   it binds a single variable,
 --   it has a signature,
 tcPolyCheck rec_tc prag_fn
-            sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
+            sig@(TcSigInfo { sig_name = name, sig_poly_id = Just poly_id
+                           , sig_tvs = tvs_w_scoped
                            , sig_nwcs = sig_nwcs, sig_theta = theta
                            , sig_tau = tau, sig_loc = loc
                            , sig_warn_redundant = warn_redundant })
             bind
   = ASSERT( null sig_nwcs ) -- We should be in tcPolyInfer if there are wildcards
     do { ev_vars <- newEvVars theta
-       ; let ctxt      = FunSigCtxt (idName poly_id) warn_redundant
+       ; let ctxt      = FunSigCtxt name warn_redundant
              skol_info = SigSkol ctxt (mkPhiTy theta tau)
-             prag_sigs = prag_fn (idName poly_id)
+             prag_sigs = prag_fn name
              tvs = map snd tvs_w_scoped
        ; (ev_binds, (binds', [mono_info]))
             <- setSrcSpan loc $
@@ -640,11 +641,10 @@ mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id)
         ; poly_id <- case mb_sig of
               Nothing -> mkInferredPolyId poly_name qtvs inferred_theta mono_ty
               Just (TcPatSynInfo _) -> panic "mkExport"
-              Just sig | isPartialSig sig
-                       -> do { final_theta <- completeTheta inferred_theta sig
+              Just sig | Just id <- sig_poly_id sig
+                       -> return id
+              Just sig -> do { final_theta <- completeTheta inferred_theta sig
                              ; mkInferredPolyId poly_name qtvs final_theta mono_ty }
-                       | otherwise
-                       -> return (sig_id sig)
 
         -- NB: poly_id has a zonked type
         ; poly_id <- addInlinePrags poly_id prag_sigs
@@ -724,8 +724,7 @@ completeTheta :: TcThetaType -> TcSigInfo -> TcM TcThetaType
 completeTheta _ (TcPatSynInfo _)
   = panic "Extra-constraints wildcard not supported in a pattern signature"
 completeTheta inferred_theta
-              sig@(TcSigInfo { sig_id = poly_id
-                             , sig_extra_cts = mb_extra_cts
+              sig@(TcSigInfo { sig_extra_cts = mb_extra_cts
                              , sig_theta = annotated_theta })
   | Just loc <- mb_extra_cts
   = do { annotated_theta <- zonkTcThetaType annotated_theta
@@ -752,7 +751,7 @@ completeTheta inferred_theta
                    2 (text "with inferred constraints:")
                       <+> pprTheta inferred_diff
               , if suppress_hint then empty else pts_hint
-              , typeSigCtxt (idName poly_id) sig ]
+              , typeSigCtxt sig ]
 
 {-
 Note [Partial type signatures and generalisation]
@@ -843,13 +842,15 @@ where F is a non-injective type function.
 recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag)
 recoveryCode binder_names sig_fn
   = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
-        ; poly_ids <- mapM mk_dummy binder_names
+        ; let poly_ids = map mk_dummy binder_names
         ; return (emptyBag, poly_ids, if all is_closed poly_ids
                                       then TopLevel else NotTopLevel) }
   where
     mk_dummy name
-        | isJust (sig_fn name) = tcLookupId name        -- Had signature; look it up
-        | otherwise            = return (mkLocalId name forall_a_a)    -- No signature
+      | Just (TcSigInfo { sig_poly_id = Just poly_id }) <- sig_fn name
+      = poly_id
+      | otherwise
+      = mkLocalId name forall_a_a
 
     is_closed poly_id = isEmptyVarSet (tyVarsOfType (idType poly_id))
 
@@ -1348,7 +1349,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matc
        -- Both InferGen and CheckGen gives rise to LetLclBndr
     do  { mono_name <- newLocalName name
         ; let mono_id = mkLocalId mono_name (sig_tau sig)
-        ; addErrCtxt (typeSigCtxt name sig) $
+        ; addErrCtxt (typeSigCtxt sig) $
           emitWildcardHoleConstraints (sig_nwcs sig)
         ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
 
@@ -1507,7 +1508,10 @@ tcTySigs hs_sigs
   = checkNoErrs $   -- See Note [Fail eagerly on bad signatures]
     do { (ty_sigs_s, tyvarsl) <- unzip <$> mapAndRecoverM tcTySig hs_sigs
        ; let ty_sigs = concat ty_sigs_s
-             poly_ids = [id | TcSigInfo{ sig_id = id } <- ty_sigs]
+             poly_ids = [id | TcSigInfo { sig_poly_id = Just id } <- ty_sigs]
+             -- The returned [TcId] are the ones for which we have a
+             -- *complete* type signatures.
+             -- See Note [Complete and partial type signatures]
              env = mkNameEnv [(getName sig, sig) | sig <- ty_sigs]
        ; return (poly_ids, lookupNameEnv env, concat tyvarsl) }
 
@@ -1561,12 +1565,12 @@ instTcTySigFromId id
   = do { let loc = getSrcSpan id
        ; (tvs, theta, tau) <- tcInstType (tcInstSigTyVarsLoc loc)
                                          (idType id)
-       ; return (TcSigInfo { sig_id = id, sig_loc = loc
+       ; return (TcSigInfo { sig_name = idName id
+                           , sig_poly_id = Just id, sig_loc = loc
                            , sig_tvs = [(Nothing, tv) | tv <- tvs]
                            , sig_nwcs = []
                            , sig_theta = theta, sig_tau = tau
                            , sig_extra_cts = Nothing
-                           , sig_partial = False
                            , sig_warn_redundant = False
                                -- Do not report redundant constraints for
                                -- instance methods and record selectors
@@ -1580,13 +1584,16 @@ instTcTySig :: LHsType Name -> TcType    -- HsType and corresponding TcType
             -> TcM TcSigInfo
 instTcTySig hs_ty@(L loc _) sigma_ty extra_cts nwcs name
   = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
-       ; return (TcSigInfo { sig_id  = mkLocalId name sigma_ty
+       ; let mb_poly_id | isNothing extra_cts && null nwcs
+                        = Just $ mkLocalId name sigma_ty  -- non-partial
+                        | otherwise = Nothing  -- partial type signature
+       ; return (TcSigInfo { sig_name = name
+                           , sig_poly_id = mb_poly_id
                            , sig_loc = loc
                            , sig_tvs = findScopedTyVars hs_ty sigma_ty inst_tvs
                            , sig_nwcs = nwcs
                            , sig_theta = theta, sig_tau = tau
                            , sig_extra_cts = extra_cts
-                           , sig_partial = isJust extra_cts || not (null nwcs)
                            , sig_warn_redundant = True
                }) }
 
@@ -1773,12 +1780,12 @@ patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Nam
 patMonoBindsCtxt pat grhss
   = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss)
 
-typeSigCtxt :: Name -> TcSigInfo -> SDoc
-typeSigCtxt _    (TcPatSynInfo _)
+typeSigCtxt :: TcSigInfo -> SDoc
+typeSigCtxt (TcPatSynInfo _)
   = panic "Should only be called with a TcSigInfo"
-typeSigCtxt name (TcSigInfo { sig_id = _id, sig_tvs = tvs
-                            , sig_theta = theta, sig_tau = tau
-                            , sig_extra_cts = extra_cts })
+typeSigCtxt (TcSigInfo { sig_name = name, sig_tvs = tvs
+                       , sig_theta = theta, sig_tau = tau
+                       , sig_extra_cts = extra_cts })
   = sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name False) <> colon
         , nest 2 (pprSigmaTypeExtraCts (isJust extra_cts)
                   (mkSigmaTy (map snd tvs) theta tau)) ]
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index 4d6b3ce5b0..26c6a012a4 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -19,7 +19,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
 
 import HsSyn
 import TcEnv
-import TcPat( addInlinePrags )
+import TcPat( addInlinePrags, completeSigPolyId )
 import TcEvidence( idHsWrapper )
 import TcBinds
 import TcUnify
@@ -233,7 +233,10 @@ tcDefMeth clas tyvars this_dict binds_in
                               (L bind_loc lm_bind)
 
         ; let export = ABE { abe_poly  = global_dm_id
-                           , abe_mono  = sig_id local_dm_sig'
+                           -- We have created a complete type signature in
+                           -- instTcTySig, hence it is safe to call
+                           -- completeSigPolyId
+                           , abe_mono  = completeSigPolyId local_dm_sig'
                            , abe_wrap  = idHsWrapper
                            , abe_prags = IsDefaultMethod }
               full_bind = AbsBinds { abs_tvs      = tyvars
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 3d9e425c4b..9b07554a45 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -18,7 +18,7 @@ import TcTyClsDecls
 import TcClassDcl( tcClassDecl2,
                    HsSigFun, lookupHsSig, mkHsSigFun,
                    findMethodBind, instantiateMethod )
-import TcPat      ( addInlinePrags )
+import TcPat      ( addInlinePrags, completeSigPolyId )
 import TcRnMonad
 import TcValidity
 import TcMType
@@ -1387,7 +1387,9 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                  rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
                        HsVar dm_id
 
-                 local_meth_id = sig_id local_meth_sig
+                 -- A method always has a complete type signature,
+                 -- hence it is safe to call completeSigPolyId
+                 local_meth_id = completeSigPolyId local_meth_sig
                  meth_bind = mkVarBind local_meth_id (L inst_loc rhs)
                  meth_id1 = meth_id `setInlinePragma` dm_inline_prag
                         -- Copy the inline pragma (if any) from the default
@@ -1435,7 +1437,9 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
                            inst_tys sel_id
 
        ; let prags         = prag_fn (idName sel_id)
-             local_meth_id = sig_id local_meth_sig
+             -- A method always has a complete type signature, hence
+             -- it is safe to call completeSigPolyId
+             local_meth_id = completeSigPolyId local_meth_sig
              lm_bind       = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
                              -- Substitute the local_meth_name for the binder
                              -- NB: the binding is always a FunBind
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index daf0fbd756..7856413612 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -10,7 +10,7 @@ TcPat: Typechecking patterns
 
 module TcPat ( tcLetPat, TcSigFun, TcPragFun
              , TcSigInfo(..), TcPatSynInfo(..)
-             , findScopedTyVars, isPartialSig
+             , findScopedTyVars, isPartialSig, completeSigPolyId
              , LetBndrSpec(..), addInlinePrags, warnPrags
              , tcPat, tcPats, newNoSigLetBndr
              , addDataConStupidTheta, badFieldCon, polyPatSig ) where
@@ -47,7 +47,6 @@ import Util
 import Outputable
 import FastString
 import Control.Monad
-
 {-
 ************************************************************************
 *                                                                      *
@@ -137,7 +136,16 @@ type TcSigFun  = Name -> Maybe TcSigInfo
 
 data TcSigInfo
   = TcSigInfo {
-        sig_id     :: TcId,         --  *Polymorphic* binder for this value...
+        sig_name    :: Name,  -- The binder name of the type signature. When
+                              -- sig_id = Just id, then sig_name = idName id.
+
+        sig_poly_id :: Maybe TcId,
+                              -- Just <=> complete type signature of
+                              -- which the polymorphic type is known.
+                              -- Nothing <=> partial type signature of
+                              -- which the type is not yet fully
+                              -- known.
+                              -- See Note [Complete and partial type signatures]
 
         sig_tvs    :: [(Maybe Name, TcTyVar)],
                            -- Instantiated type and kind variables
@@ -161,9 +169,6 @@ data TcSigInfo
 
         sig_loc    :: SrcSpan,      -- The location of the signature
 
-        sig_partial :: Bool,        -- True <=> a partial type signature
-                                    -- containing wildcards
-
         sig_warn_redundant :: Bool  -- True <=> report redundant constraints
                                     --          when typechecking the value binding
                                     --          for this type signature
@@ -204,20 +209,30 @@ findScopedTyVars hs_ty sig_ty inst_tvs
     (sig_tvs,_)  = tcSplitForAllTys sig_ty
 
 instance NamedThing TcSigInfo where
-    getName TcSigInfo{ sig_id = id } = idName id
+    getName TcSigInfo{ sig_name = name } = name
     getName (TcPatSynInfo tpsi) = patsig_name tpsi
 
+
 instance Outputable TcSigInfo where
-    ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau })
-        = ppr id <+> dcolon <+> vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau)
-                                     , ppr (map fst tyvars) ]
+    ppr (TcSigInfo { sig_name = name, sig_poly_id = mb_poly_id, sig_tvs = tyvars
+                   , sig_theta = theta, sig_tau = tau })
+        = maybe (ppr name) ppr mb_poly_id <+> dcolon <+>
+          vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau)
+               , ppr (map fst tyvars) ]
     ppr (TcPatSynInfo tpsi) = text "TcPatSynInfo" <+> ppr tpsi
 
 instance Outputable TcPatSynInfo where
     ppr (TPSI{ patsig_name = name}) = ppr name
 
 isPartialSig :: TcSigInfo -> Bool
-isPartialSig = sig_partial
+isPartialSig (TcSigInfo { sig_poly_id = Nothing }) = True
+isPartialSig _ = False
+
+-- Helper for cases when we know for sure we have a complete type
+-- signature, e.g. class methods.
+completeSigPolyId :: TcSigInfo -> TcId
+completeSigPolyId (TcSigInfo { sig_poly_id = Just id }) = id
+completeSigPolyId _ = panic "completeSigPolyId"
 
 {-
 Note [Binding scoped type variables]
@@ -271,6 +286,20 @@ bound by C don't unify with the free variables of pat_ty, OR res_ty
 (or of course the environment).   Hence we need to keep track of the
 res_ty free vars.
 
+Note [Complete and partial type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A type signature is partial when it contains one or more wildcards.
+The wildcard can either be:
+* A (type) wildcard occurring in sig_theta or sig_tau. These are
+  stored in sig_nwcs.
+      f :: Bool -> _
+      g :: Eq _a => _a -> _a -> Bool
+* Or an extra-constraints wildcard, stored in sig_extra_cts:
+      h :: (Num a, _) => a -> a
+
+A type signature is a complete type signature when there are no
+wildcards in the type signature, i.e. iff sig_nwcs is empty and
+sig_extra_cts is Nothing.
 
 ************************************************************************
 *                                                                      *
@@ -287,7 +316,8 @@ tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty
           -- See Note [Typing patterns in pattern bindings]
   | LetGblBndr prags <- no_gen
   , Just sig <- lookup_sig bndr_name
-  = do { bndr_id <- addInlinePrags (sig_id sig) (prags bndr_name)
+  , Just poly_id <- sig_poly_id sig
+  = do { bndr_id <- addInlinePrags poly_id (prags bndr_name)
        ; traceTc "tcPatBndr(gbl,sig)" (ppr bndr_id $$ ppr (idType bndr_id))
        ; co <- unifyPatType (idType bndr_id) pat_ty
        ; return (co, bndr_id) }
diff --git a/testsuite/tests/partial-sigs/should_fail/Trac10045.hs b/testsuite/tests/partial-sigs/should_fail/Trac10045.hs
new file mode 100644
index 0000000000..e7c07470aa
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/Trac10045.hs
@@ -0,0 +1,8 @@
+module Trac10045 where
+
+newtype Meta = Meta ()
+
+foo (Meta ws1) =
+    let copy :: _
+        copy w from = copy w 1
+    in copy ws1 1
diff --git a/testsuite/tests/partial-sigs/should_fail/Trac10045.stderr b/testsuite/tests/partial-sigs/should_fail/Trac10045.stderr
new file mode 100644
index 0000000000..8c8e42f704
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_fail/Trac10045.stderr
@@ -0,0 +1,45 @@
+
+Trac10045.hs:6:17:
+    Found hole ‘_’ with type: t1 -> a -> t2
+    Where: ‘t1’ is a rigid type variable bound by
+                the inferred type of copy :: Num a => t1 -> a -> t2
+                at Trac10045.hs:7:9
+           ‘t2’ is a rigid type variable bound by
+                the inferred type of copy :: Num a => t1 -> a -> t2
+                at Trac10045.hs:7:9
+           ‘a’ is a rigid type variable bound by
+               the inferred type of copy :: Num a => t1 -> a -> t2
+               at Trac10045.hs:7:9
+    To use the inferred type, enable PartialTypeSignatures
+    Relevant bindings include
+      ws1 :: () (bound at Trac10045.hs:5:11)
+      foo :: Meta -> t (bound at Trac10045.hs:5:1)
+    In the type signature for ‘copy’: _
+    In the expression:
+      let
+        copy :: _
+        copy w from = copy w 1
+      in copy ws1 1
+    In an equation for ‘foo’:
+        foo (Meta ws1)
+          = let
+              copy :: _
+              copy w from = copy w 1
+            in copy ws1 1
+
+Trac10045.hs:7:9:
+    No instance for (Num a)
+    When checking that ‘copy’ has the specified type
+      copy :: forall t t1 a. t -> a -> t1
+    Probable cause: the inferred type is ambiguous
+    In the expression:
+      let
+        copy :: _
+        copy w from = copy w 1
+      in copy ws1 1
+    In an equation for ‘foo’:
+        foo (Meta ws1)
+          = let
+              copy :: _
+              copy w from = copy w 1
+            in copy ws1 1
diff --git a/testsuite/tests/partial-sigs/should_fail/all.T b/testsuite/tests/partial-sigs/should_fail/all.T
index 7e56d15c71..c49a36fe34 100644
--- a/testsuite/tests/partial-sigs/should_fail/all.T
+++ b/testsuite/tests/partial-sigs/should_fail/all.T
@@ -18,6 +18,7 @@ test('ScopedNamedWildcardsBad', normal, compile_fail, [''])
 test('TidyClash', normal, compile_fail, [''])
 # Bug
 test('TidyClash2', expect_fail, compile_fail, [''])
+test('Trac10045', normal, compile_fail, [''])
 test('UnnamedConstraintWildcard1', normal, compile_fail, [''])
 test('UnnamedConstraintWildcard2', normal, compile_fail, [''])
 test('WildcardInADT1', normal, compile_fail, [''])