[Git][ghc/ghc][master] RecordCon lookup: don't allow a TyCon
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Sep 5 00:23:12 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
da306610 by sheaf at 2024-09-04T20:22:41-04:00
RecordCon lookup: don't allow a TyCon
This commit adds extra logic when looking up a record constructor.
If GHC.Rename.Env.lookupOccRnConstr returns a TyCon (as it may, due to
the logic explained in Note [Pattern to type (P2T) conversion]),
we emit an error saying that the data constructor is not in scope.
This avoids the compiler falling over shortly thereafter, in the call to
'lookupConstructorInfo' inside 'GHC.Rename.Env.lookupRecFieldOcc',
because the record constructor would not have been a ConLike.
Fixes #25056
- - - - -
14 changed files:
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Env.hs
- + testsuite/tests/rename/should_fail/T25056.hs
- + testsuite/tests/rename/should_fail/T25056.stderr
- + testsuite/tests/rename/should_fail/T25056a.hs
- + testsuite/tests/rename/should_fail/T25056b.hs
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/typecheck/should_fail/T23739b.hs
- testsuite/tests/typecheck/should_fail/T23739b.stderr
- + testsuite/tests/typecheck/should_fail/T23739c.hs
- + testsuite/tests/typecheck/should_fail/T23739c.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -442,6 +442,7 @@ lookupConstructorInfo con_name
; case info of
IAmConLike con_info -> return con_info
UnboundGRE -> return $ ConInfo (ConIsData []) ConHasPositionalArgs
+ IAmTyCon {} -> failIllegalTyCon WL_Constructor con_name
_ -> pprPanic "lookupConstructorInfo: not a ConLike" $
vcat [ text "name:" <+> ppr con_name ]
}
@@ -1035,24 +1036,12 @@ lookupOccRn' which_suggest rdr_name
lookupOccRn :: RdrName -> RnM Name
lookupOccRn = lookupOccRn' WL_Anything
--- lookupOccRnConstr looks up an occurrence of a RdrName and displays
--- constructors and pattern synonyms as suggestions if it is not in scope
+-- | Look up an occurrence of a 'RdrName'.
--
--- There is a fallback to the type level, when the first lookup fails.
--- This is required to implement a pat-to-type transformation
--- (See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
--- Consider this example:
+-- Displays constructors and pattern synonyms as suggestions if
+-- it is not in scope.
--
--- data VisProxy a where VP :: forall a -> VisProxy a
---
--- f :: VisProxy Int -> ()
--- f (VP Int) = ()
---
--- Here `Int` is actually a type, but it stays on position where
--- we expect a data constructor.
---
--- In all other cases we just use this additional lookup for better
--- error messaging (See Note [Promotion]).
+-- See Note [lookupOccRnConstr]
lookupOccRnConstr :: RdrName -> RnM Name
lookupOccRnConstr rdr_name
= do { mb_gre <- lookupOccRn_maybe rdr_name
@@ -1064,6 +1053,28 @@ lookupOccRnConstr rdr_name
Just gre -> return $ greName gre
Nothing -> reportUnboundName' WL_Constructor rdr_name} }
+{- Note [lookupOccRnConstr]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+lookupOccRnConstr looks up a data constructor or pattern synonym. Simple.
+
+However, there is a fallback to the type level when the lookup fails.
+This is required to implement a pat-to-type transformation
+(See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
+
+Consider this example:
+
+ data VisProxy a where VP :: forall a -> VisProxy a
+
+ f :: VisProxy Int -> ()
+ f (VP Int) = ()
+
+Here `Int` is actually a type, but it occurs in a position in which we expect
+a data constructor.
+
+In all other cases we just use this additional lookup for better
+error messaging (See Note [Promotion]).
+-}
+
-- lookupOccRnRecField looks up an occurrence of a RdrName and displays
-- record fields as suggestions if it is not in scope
lookupOccRnRecField :: RdrName -> RnM Name
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -539,9 +539,9 @@ rnExpr (ExplicitSum _ alt arity expr)
= do { (expr', fvs) <- rnLExpr expr
; return (ExplicitSum noExtField alt arity expr', fvs) }
-rnExpr (RecordCon { rcon_con = con_id
+rnExpr (RecordCon { rcon_con = con_rdr
, rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
- = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id
+ = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_rdr
; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
; (flds', fvss) <- mapAndUnzipM rn_field flds
; let rec_binds' = HsRecFields { rec_ext = noExtField, rec_flds = flds', rec_dotdot = dd }
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -841,7 +841,7 @@ tc_infer_id id_name
AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con
AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps
- (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything tc -- TyCon or TcTyCon
+ (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything (tyConName tc)
ATyVar name _ -> failIllegalTyVal name
_ -> failWithTc $ TcRnExpectedValueId thing }
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -280,7 +280,7 @@ tcLookupConLike name = do
thing <- tcLookupGlobal name
case thing of
AConLike cl -> return cl
- ATyCon tc -> failIllegalTyCon WL_Constructor tc
+ ATyCon {} -> failIllegalTyCon WL_Constructor name
_ -> wrongThingErr WrongThingConLike (AGlobal thing) name
tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent
@@ -353,19 +353,20 @@ instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
lookupThing = tcLookupGlobal
-- Illegal term-level use of type things
-failIllegalTyCon :: WhatLooking -> TyCon -> TcM a
+failIllegalTyCon :: WhatLooking -> Name -> TcM a
failIllegalTyVal :: Name -> TcM a
(failIllegalTyCon, failIllegalTyVal) = (fail_tycon, fail_tyvar)
where
- fail_tycon what_looking tc = do
+ fail_tycon what_looking tc_nm = do
gre <- getGlobalRdrEnv
- let nm = tyConName tc
- pprov = case lookupGRE_Name gre nm of
+ let mb_gre = lookupGRE_Name gre tc_nm
+ pprov = case mb_gre of
Just gre -> nest 2 (pprNameProvenance gre)
Nothing -> empty
- err | isClassTyCon tc = ClassTE
- | otherwise = TyConTE
- fail_with_msg what_looking dataName nm pprov err
+ err = case greInfo <$> mb_gre of
+ Just (IAmTyCon ClassFlavour) -> ClassTE
+ _ -> TyConTE
+ fail_with_msg what_looking dataName tc_nm pprov err
fail_tyvar nm =
let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))
=====================================
testsuite/tests/rename/should_fail/T25056.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE RecordWildCards #-}
+module T25056 where
+
+import T25056b
+
+foo :: T -> ()
+foo (T { unT = x }) = x
=====================================
testsuite/tests/rename/should_fail/T25056.stderr
=====================================
@@ -0,0 +1,5 @@
+T25056.hs:7:10: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘T’
+ • imported from ‘T25056b’ at T25056.hs:4:1-14
+ (and originally defined in ‘T25056a’ at T25056a.hs:8:1-14)
+
=====================================
testsuite/tests/rename/should_fail/T25056a.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE PatternSynonyms #-}
+module T25056a
+ ( T
+ , T_(unT)
+ , pattern T
+ ) where
+
+type T = T_ ()
+
+data T_ a = PrivateT { unT_ :: a }
+
+pattern T :: a -> T_ a
+pattern T { unT } <- PrivateT { unT_ = unT }
=====================================
testsuite/tests/rename/should_fail/T25056b.hs
=====================================
@@ -0,0 +1,3 @@
+module T25056b (T, T_(..)) where
+
+import T25056a (T, T_(..))
=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -222,6 +222,7 @@ test('T23740g', normal, compile_fail, [''])
test('T23740h', normal, compile_fail, [''])
test('T23740i', req_th, compile_fail, [''])
test('T23740j', normal, compile_fail, [''])
+test('T25056', [extra_files(['T25056a.hs', 'T25056b.hs'])], multimod_compile_fail, ['T25056', '-v0'])
test('Or3', normal, compile_fail, [''])
test('T23570', [extra_files(['T23570_aux.hs'])], multimod_compile_fail, ['T23570', '-v0'])
test('T23570b', [extra_files(['T23570_aux.hs'])], multimod_compile, ['T23570b', '-v0'])
=====================================
testsuite/tests/typecheck/should_fail/T23739b.hs
=====================================
@@ -8,7 +8,4 @@ g1 :: Int -> Unit
g1 Int = ()
g2 :: Int
-g2 = Int{}
-
-g3 :: Int
-g3 = Int
+g2 = Int
=====================================
testsuite/tests/typecheck/should_fail/T23739b.stderr
=====================================
@@ -6,16 +6,9 @@ T23739b.hs:8:4: error: [GHC-01928]
In an equation for ‘g1’: g1 Int = ()
T23739b.hs:11:6: error: [GHC-01928]
- • Illegal term-level use of the type constructor ‘Int’
- • imported from ‘Prelude’ at T23739b.hs:2:8-14
- (and originally defined in ‘GHC.Types’)
- • In the expression: Int {}
- In an equation for ‘g2’: g2 = Int {}
-
-T23739b.hs:14:6: error: [GHC-01928]
• Illegal term-level use of the type constructor ‘Int’
• imported from ‘Prelude’ at T23739b.hs:2:8-14
(and originally defined in ‘GHC.Types’)
• In the expression: Int
- In an equation for ‘g3’: g3 = Int
+ In an equation for ‘g2’: g2 = Int
=====================================
testsuite/tests/typecheck/should_fail/T23739c.hs
=====================================
@@ -0,0 +1,8 @@
+
+module T23739c where
+
+import Data.Tuple.Experimental
+import GHC.TypeLits
+
+g :: Int
+g = Int{}
=====================================
testsuite/tests/typecheck/should_fail/T23739c.stderr
=====================================
@@ -0,0 +1,7 @@
+T23739c.hs:8:5: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Int’
+ • imported from ‘Prelude’ at T23739c.hs:2:8-14
+ (and originally defined in ‘GHC.Types’)
+ • In the expression: Int {}
+ In an equation for ‘g’: g = Int {}
+
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -727,5 +727,6 @@ test('T17594g', normal, compile_fail, [''])
test('T24470a', normal, compile_fail, [''])
test('T24553', normal, compile_fail, [''])
test('T23739b', normal, compile_fail, [''])
+test('T23739c', normal, compile_fail, [''])
test('T24868', normal, compile_fail, [''])
test('T24938', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/da306610b9e58cfb7cf2530ebeec7ee8ad17183a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/da306610b9e58cfb7cf2530ebeec7ee8ad17183a
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/20240904/d351a866/attachment-0001.html>
More information about the ghc-commits
mailing list