[Git][ghc/ghc][master] Fix signature lookup in instance declarations
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sun Dec 15 23:38:09 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
bfacc086 by Simon Peyton Jones at 2024-12-15T18:36:05-05:00
Fix signature lookup in instance declarations
This fixes a bug introduced by the fix to #16610
- - - - -
6 changed files:
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Env.hs
- + testsuite/tests/rename/should_fail/T25437.hs
- + testsuite/tests/rename/should_fail/T25437.stderr
- testsuite/tests/rename/should_fail/T5001b.stderr
- testsuite/tests/rename/should_fail/all.T
Changes:
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -956,7 +956,8 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
; let (spec_prags, other_sigs) = partition (isSpecLSig <||> isSpecInstLSig) sigs
bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds')
sig_ctxt | is_cls_decl = ClsDeclCtxt cls
- | otherwise = InstDeclCtxt bound_nms
+ | otherwise = InstDeclCtxt (mkOccEnv [ (nameOccName n, n)
+ | n <- nonDetEltsUniqSet bound_nms ])
; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags
; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $
renameSigs sig_ctxt other_sigs
@@ -1071,18 +1072,9 @@ renameSigs ctxt sigs
; return (good_sigs, sig_fvs) }
----------------------
--- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
--- because this won't work for:
--- instance Foo T where
--- {-# INLINE op #-}
--- Baz.op = ...
--- We'll just rename the INLINE prag to refer to whatever other 'op'
--- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
--- Doesn't seem worth much trouble to sort this.
-
renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
renameSig ctxt sig@(TypeSig _ vs ty)
- = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs
+ = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; let doc = TypeSigCtx (ppr_sig_bndrs vs)
; (new_ty, fvs) <- rnHsSigWcType doc ty
; return (TypeSig noAnn new_vs new_ty, fvs) }
@@ -1091,7 +1083,7 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
= do { defaultSigs_on <- xoptM LangExt.DefaultSignatures
; when (is_deflt && not defaultSigs_on) $
addErr (TcRnUnexpectedDefaultSig sig)
- ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs
+ ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty
; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) }
where
@@ -1119,7 +1111,7 @@ renameSig _ (SpecInstSig (_, src) ty)
renameSig ctxt sig@(SpecSig _ v tys inl)
= do { new_v <- case ctxt of
TopSigCtxt {} -> lookupLocatedOccRn v
- _ -> lookupSigOccRnN ctxt sig v
+ _ -> lookupSigOccRn ctxt sig v
; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
; return (SpecSig noAnn new_v new_ty inl, fvs) }
where
@@ -1130,7 +1122,7 @@ renameSig ctxt sig@(SpecSig _ v tys inl)
; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
renameSig ctxt sig@(InlineSig _ v s)
- = do { new_v <- lookupSigOccRnN ctxt sig v
+ = do { new_v <- lookupSigOccRn ctxt sig v
; return (InlineSig noAnn new_v s, emptyFVs) }
renameSig ctxt (FixSig _ fsig)
@@ -1138,11 +1130,11 @@ renameSig ctxt (FixSig _ fsig)
; return (FixSig noAnn new_fsig, emptyFVs) }
renameSig ctxt sig@(MinimalSig (_, s) (L l bf))
- = do new_bf <- bfTraverse (lookupSigOccRnN ctxt sig) bf
+ = do new_bf <- bfTraverse (lookupSigOccRn ctxt sig) bf
return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs)
renameSig ctxt sig@(PatSynSig _ vs ty)
- = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs
+ = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty
; return (PatSynSig noAnn new_vs ty', fvs) }
where
@@ -1150,7 +1142,7 @@ renameSig ctxt sig@(PatSynSig _ vs ty)
<+> ppr_sig_bndrs vs)
renameSig ctxt sig@(SCCFunSig (_, st) v s)
- = do { new_v <- lookupSigOccRnN ctxt sig v
+ = do { new_v <- lookupSigOccRn ctxt sig v
; return (SCCFunSig (noAnn, st) new_v s, emptyFVs) }
-- COMPLETE Sigs can refer to imported IDs which is why we use
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.Rename.Env (
ChildLookupResult(..),
lookupSubBndrOcc_helper,
- HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigOccRnN,
+ HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
lookupSigCtxtOccRn,
lookupInstDeclBndr, lookupFamInstName,
@@ -2072,6 +2072,28 @@ data HsSigCtxt = ... | TopSigCtxt NameSet | ....
f :: C a => a -> a -- No, not ok
class C a where
f :: a -> a
+
+Note [Signatures in instance decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ class C a where
+ op :: a -> a
+ nop :: a -> a
+
+ instance C ty where
+ bop :: [a] -> [a]
+ bop x = x
+
+ nop :: [a] -> [a]
+
+When renameing the `bop` binding we'll give it an UnboundName (still with
+OccName "bop") because `bop` is not a method of C. Then
+
+* when doing lookupSigOcc on `bop :: blah` we want to find `bop`, even though it
+ is an UnboundName (failing to do this causes #16610, and #25437)
+
+* When doing lookupSigOcc on `nop :: blah` we want to complain that there
+ is no accompanying binding, even though `nop` is a class method
-}
data HsSigCtxt
@@ -2079,8 +2101,8 @@ data HsSigCtxt
-- See Note [Signatures for top level things]
| LocalBindCtxt NameSet -- In a local binding, binding these names
| ClsDeclCtxt Name -- Class decl for this class
- | InstDeclCtxt NameSet -- Instance decl whose user-written method
- -- bindings are for these methods
+ | InstDeclCtxt (OccEnv Name) -- Instance decl whose user-written method
+ -- bindings are described by this OccEnv
| HsBootCtxt NameSet -- Top level of a hs-boot file, binding these names
| RoleAnnotCtxt NameSet -- A role annotation, with the names of all types
-- in the group
@@ -2095,14 +2117,10 @@ instance Outputable HsSigCtxt where
lookupSigOccRn :: HsSigCtxt
-> Sig GhcPs
- -> LocatedA RdrName -> RnM (LocatedA Name)
+ -> GenLocated (EpAnn ann) RdrName
+ -> RnM (GenLocated (EpAnn ann) Name)
lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)
-lookupSigOccRnN :: HsSigCtxt
- -> Sig GhcPs
- -> LocatedN RdrName -> RnM (LocatedN Name)
-lookupSigOccRnN ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)
-
-- | Lookup a name in relation to the names in a 'HsSigCtxt'
lookupSigCtxtOccRn :: HsSigCtxt
-> SDoc -- ^ description of thing we're looking up,
@@ -2155,34 +2173,37 @@ lookupBindGroupOcc ctxt what rdr_name also_try_tycon_ns ns_spec
RoleAnnotCtxt ns -> lookup_top (elem_name_set_with_namespace ns)
LocalBindCtxt ns -> lookup_group ns
ClsDeclCtxt cls -> lookup_cls_op cls
- InstDeclCtxt ns -> if uniqSetAny isUnboundName ns -- #16610
- then return $ NE.singleton $ Right $ mkUnboundNameRdr rdr_name
- else lookup_top (elem_name_set_with_namespace ns)
+ InstDeclCtxt occ_env-> lookup_inst occ_env
where
elem_name_set_with_namespace ns n = check_namespace n && (n `elemNameSet` ns)
check_namespace = coveredByNamespaceSpecifier ns_spec . nameNameSpace
namespace = occNameSpace occ
- occ = rdrNameOcc rdr_name
- relevant_gres =
- RelevantGREs
- { includeFieldSelectors = WantBoth
- , lookupVariablesForFields = True
- , lookupTyConsAsWell = also_try_tycon_ns }
- ok_gre = greIsRelevant relevant_gres namespace
+ occ = rdrNameOcc rdr_name
+ ok_gre = greIsRelevant relevant_gres namespace
+ relevant_gres = RelevantGREs { includeFieldSelectors = WantBoth
+ , lookupVariablesForFields = True
+ , lookupTyConsAsWell = also_try_tycon_ns }
finish err gre
| ok_gre gre
- = NE.singleton (Right $ greName gre)
+ = NE.singleton (Right (greName gre))
| otherwise
= NE.singleton (Left err)
+ succeed_with n = return $ NE.singleton $ Right n
+
lookup_cls_op cls
= NE.singleton <$> lookupSubBndrOcc AllDeprecationWarnings cls doc rdr_name
where
doc = text "method of class" <+> quotes (ppr cls)
+ lookup_inst occ_env -- See Note [Signatures in instance decls]
+ = case lookupOccEnv occ_env occ of
+ Nothing -> bale_out_with []
+ Just n -> succeed_with n
+
lookup_top keep_me
= do { env <- getGlobalRdrEnv
; let occ = rdrNameOcc rdr_name
@@ -2205,7 +2226,7 @@ lookupBindGroupOcc ctxt what rdr_name also_try_tycon_ns ns_spec
; let candidates_msg = candidates $ localRdrEnvElts env
; case mname of
Just n
- | n `elemNameSet` bound_names -> return $ NE.singleton $ Right n
+ | n `elemNameSet` bound_names -> succeed_with n
| otherwise -> bale_out_with local_msg
Nothing -> bale_out_with candidates_msg }
=====================================
testsuite/tests/rename/should_fail/T25437.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module T25437 where
+
+class C a where
+ foo :: Int -> Maybe a
+
+instance C (Maybe x) where
+ foo :: Int -> Maybe [a]
+
+instance C [x] where
+ foo :: forall b. Int -> Maybe [b]
+ foo _ = Just @[b] []
+
+ something :: x -> x
+ something = ()
=====================================
testsuite/tests/rename/should_fail/T25437.stderr
=====================================
@@ -0,0 +1,5 @@
+T25437.hs:9:3: error: [GHC-44432]
+ The class method signature for ‘foo’ lacks an accompanying binding
+
+T25437.hs:16:3: error: [GHC-54721]
+ ‘something’ is not a (visible) method of class ‘C’
=====================================
testsuite/tests/rename/should_fail/T5001b.stderr
=====================================
@@ -1,5 +1,4 @@
T5001b.hs:10:17: error: [GHC-44432]
The INLINE pragma for ‘genum’ lacks an accompanying binding
- Suggested fix:
- Move the INLINE pragma to the declaration site of ‘genum’.
+
=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -231,3 +231,4 @@ test('T14032c', normal, compile_fail, [''])
test('T14032f', normal, compile_fail, [''])
test('T23501_fail', normal, compile_fail, [''])
test('T23501_fail_ext', normal, compile_fail, [''])
+test('T25437', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bfacc086604c18e30758772a05a8c81e3a4e01bc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bfacc086604c18e30758772a05a8c81e3a4e01bc
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241215/716c845b/attachment-0001.html>
More information about the ghc-commits
mailing list