[Git][ghc/ghc][wip/t22695] Only store Name in FunRhs rather than Id with knot-tied fields
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Wed Jan 4 23:01:02 UTC 2023
Matthew Pickering pushed to branch wip/t22695 at Glasgow Haskell Compiler / GHC
Commits:
3ec60ef6 by Matthew Pickering at 2023-01-04T23:00:47+00:00
Only store Name in FunRhs rather than Id with knot-tied fields
All the issues here have been caused by #18758.
The goal of the ticket is to be able to talk about things like
`LTyClDecl GhcTc`. In the case of HsMatchContext,
the correct "context" is whatever we want, and in fact storing just a
`Name` is sufficient and correct context, even if the rest of the AST is
storing typechecker Ids.
So this reverts (#20415, !5579) which intended to get closed to #18758 but
didn't really and introduced a few subtle bugs.
Printing of an error message in #22695 would just hang, because we would
attempt to print the `Id` in debug mode to assertain whether it was
empty or not. Printing the Name is fine for the error message.
Another consequence is that when `-dppr-debug` was enabled the compiler would
hang because the debug printing of the Id would try and print fields
which were not populated yet.
This also led to 32070e6c2e1b4b7c32530a9566fe14543791f9a6 having to add
a workaround for the `checkArgs` function which was probably a very
similar bug to #22695.
Fixes #22695
- - - - -
15 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Match.hs-boot
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- + testsuite/tests/ghci/scripts/T22695.script
- + testsuite/tests/ghci/scripts/T22695.stderr
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -2002,7 +2002,7 @@ matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
matchSeparator PatSyn = panic "unused"
-pprMatchContext :: (Outputable (IdP p), UnXRec p)
+pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=> HsMatchContext p -> SDoc
pprMatchContext ctxt
| want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
@@ -2013,10 +2013,10 @@ pprMatchContext ctxt
want_an (ArrowMatchCtxt KappaExpr) = True
want_an _ = False
-pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)
+pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=> HsMatchContext p -> SDoc
pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for"
- <+> quotes (ppr (unXRec @p fun))
+ <+> quotes (ppr (unXRec @(NoGhcTc p) fun))
pprMatchContextNoun CaseAlt = text "case alternative"
pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant
<+> text "alternative"
@@ -2032,10 +2032,10 @@ pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
$$ pprAStmtContext ctxt
pprMatchContextNoun PatSyn = text "pattern synonym declaration"
-pprMatchContextNouns :: forall p. (Outputable (IdP p), UnXRec p)
+pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=> HsMatchContext p -> SDoc
pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for"
- <+> quotes (ppr (unXRec @p fun))
+ <+> quotes (ppr (unXRec @(NoGhcTc p) fun))
pprMatchContextNouns PatBindGuards = text "pattern binding guards"
pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c
pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in"
@@ -2056,7 +2056,7 @@ pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_varia
pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's'
-----------------
-pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)
+pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=> HsStmtContext p -> SDoc
pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour
pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -863,7 +863,7 @@ mkSimpleGeneratedFunBind loc fun pats expr
emptyLocalBinds]
-- | Make a prefix, non-strict function 'HsMatchContext'
-mkPrefixFunRhs :: LIdP p -> HsMatchContext p
+mkPrefixFunRhs :: LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs n = FunRhs { mc_fun = n
, mc_fixity = Prefix
, mc_strictness = NoSrcStrict }
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -957,7 +957,7 @@ instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where
name' :: LocatedN Name
name' = case hiePass @p of
HieRn -> name
- HieTc -> fmap varName name
+ HieTc -> name
toHie (StmtCtxt a) = toHie a
toHie _ = pure []
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -927,14 +927,10 @@ instance Diagnostic TcRnMessage where
same_rec_group_msg = text "it is defined and used in the same recursive group"
TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches)
-> mkSimpleDecorated $
- (vcat [ pprArgsContext argsContext <+>
+ (vcat [ pprMatchContextNouns argsContext <+>
text "have different numbers of arguments"
, nest 2 (ppr (getLocA match1))
, nest 2 (ppr (getLocA (NE.head bad_matches)))])
- where
- pprArgsContext = \case
- EquationArgs name -> (text "Equations for" <+>) . quotes $ ppr name
- PatternArgs matchCtx -> pprMatchContextNouns matchCtx
TcRnCannotBindScopedTyVarInPatSig sig_tvs
-> mkSimpleDecorated $
hang (text "You cannot bind scoped type variable"
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2094,7 +2094,7 @@ data TcRnMessage where
typecheck/should_fail/T20768_fail
-}
TcRnMatchesHaveDiffNumArgs
- :: !MatchArgsContext
+ :: !(HsMatchContext GhcTc) -- ^ Pattern match specifics
-> !MatchArgBadMatches
-> TcRnMessage
=====================================
compiler/GHC/Tc/Gen/Arrow.hs
=====================================
@@ -172,7 +172,6 @@ tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty
= addErrCtxt (cmdCtxt cmd)
do { let match_ctxt = ArrowLamCaseAlt lc_variant
- ; checkPatCounts (ArrowMatchCtxt match_ctxt) match
; (wrap, match') <-
tcCmdMatchLambda env match_ctxt match cmd_ty
; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) }
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -624,7 +624,7 @@ tcPolyCheck prag_fn
-- See Note [Relevant bindings and the binder stack]
setSrcSpanA bind_loc $
- tcMatchesFun (L nm_loc mono_id) matches
+ tcMatchesFun (L nm_loc (idName mono_id)) matches
(mkCheckExpType rho_ty)
-- We make a funny AbsBinds, abstracting over nothing,
@@ -1263,18 +1263,14 @@ tcMonoBinds is_rec sig_fn no_gen
| NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
, Nothing <- sig_fn name -- ...with no type signature
= setSrcSpanA b_loc $
- do { ((co_fn, matches'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) ->
- -- See Note [fixM for rhs_ty in tcMonoBinds]
- do { mono_id <- newLetBndr no_gen name ManyTy rhs_ty
- ; (matches', rhs_ty')
- <- tcInfer $ \ exp_ty ->
+ do { ((co_fn, matches'), rhs_ty')
+ <- tcInfer $ \ exp_ty ->
tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
-- We extend the error context even for a non-recursive
-- function so that in type error messages we show the
-- type of the thing whose rhs we are type checking
- tcMatchesFun (L nm_loc mono_id) matches exp_ty
- ; return (matches', mono_id, rhs_ty')
- }
+ tcMatchesFun (L nm_loc name) matches exp_ty
+ ; mono_id <- newLetBndr no_gen name ManyTy rhs_ty'
; return (unitBag $ L b_loc $
FunBind { fun_id = L nm_loc mono_id,
@@ -1388,19 +1384,6 @@ 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.
-Note [fixM for rhs_ty in tcMonoBinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In order to create mono_id we need rhs_ty but we don't have it yet,
-we only get it from tcMatchesFun later (which needs mono_id to put
-into HsMatchContext for pretty printing). To solve this, create
-a thunk of rhs_ty with fixM that we fill in later.
-
-This is fine only because neither newLetBndr or tcMatchesFun look
-at the varType field of the Id. tcMatchesFun only looks at idName
-of mono_id.
-
-Also see #20415 for the bigger picture of why tcMatchesFun needs
-mono_id in the first place.
-}
@@ -1528,7 +1511,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
= tcExtendIdBinderStackForRhs [info] $
tcExtendTyVarEnvForRhs mb_sig $
do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
- ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) mono_id)
+ ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id))
matches (mkCheckExpType $ idType mono_id)
; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id
, fun_matches = matches'
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -31,7 +31,6 @@ module GHC.Tc.Gen.Match
, tcBody
, tcDoStmt
, tcGuardStmt
- , checkPatCounts
)
where
@@ -93,12 +92,12 @@ is used in error messages. It checks that all the equations have the
same number of arguments before using @tcMatches@ to do the work.
-}
-tcMatchesFun :: LocatedN Id -- MatchContext Id
+tcMatchesFun :: LocatedN Name -- MatchContext Id
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType -- Expected type of function
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-- Returns type of body
-tcMatchesFun fun_id matches exp_ty
+tcMatchesFun fun_name matches exp_ty
= do { -- Check that they all have the same no of arguments
-- Location is in the monad, set the caller so that
-- any inter-equation error messages get some vaguely
@@ -106,9 +105,7 @@ tcMatchesFun fun_id matches exp_ty
-- ann-grabbing, because we don't always have annotations in
-- hand when we call tcMatchesFun...
traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
- -- We can't easily call checkPatCounts here because fun_id can be an
- -- unfilled thunk
- ; checkArgCounts fun_name matches
+ ; checkArgCounts what matches
; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->
-- NB: exp_type may be polymorphic, but
@@ -122,17 +119,11 @@ tcMatchesFun fun_id matches exp_ty
-- a multiplicity argument, and scale accordingly.
tcMatches match_ctxt pat_tys rhs_ty matches }
where
- fun_name = idName (unLoc fun_id)
arity = matchGroupArity matches
- herald = ExpectedFunTyMatches (NameThing fun_name) matches
+ herald = ExpectedFunTyMatches (NameThing (unLoc fun_name)) matches
ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True
-- But that's wrong for f :: Int -> forall a. blah
- what = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness }
- -- Careful: this fun_id could be an unfilled
- -- thunk from fixM in tcMonoBinds, so we're
- -- not allowed to look at it, except for
- -- idName.
- -- See Note [fixM for rhs_ty in tcMonoBinds]
+ what = FunRhs { mc_fun = fun_name, mc_fixity = Prefix, mc_strictness = strictness }
match_ctxt = MC { mc_what = what, mc_body = tcBody }
strictness
| [L _ match] <- unLoc $ mg_alts matches
@@ -164,8 +155,7 @@ tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda herald match_ctxt match res_ty
- = do { checkPatCounts (mc_what match_ctxt) match
- ; matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do
+ = do { matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do
-- checking argument counts since this is also used for \cases
tcMatches match_ctxt pat_tys rhs_ty match }
where
@@ -1136,28 +1126,16 @@ the variables they bind into scope, and typecheck the thing_inside.
\subsection{Errors and contexts}
* *
************************************************************************
-
- at checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same
-number of args are used in each equation.
-}
+-- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same
+-- number of args are used in each equation.
checkArgCounts :: AnnoBody body
- => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()
-checkArgCounts = check_match_pats . EquationArgs
-
--- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same
--- number of patterns are used in each alternative
-checkPatCounts :: AnnoBody body
- => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))
- -> TcM ()
-checkPatCounts = check_match_pats . PatternArgs
-
-check_match_pats :: AnnoBody body
- => MatchArgsContext -> MatchGroup GhcRn (LocatedA (body GhcRn))
- -> TcM ()
-check_match_pats _ (MG { mg_alts = L _ [] })
+ => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))
+ -> TcM ()
+checkArgs _ (MG { mg_alts = L _ [] })
= return ()
-check_match_pats matchContext (MG { mg_alts = L _ (match1:matches) })
+checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) })
| Just bad_matches <- mb_bad_matches
= failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext
$ MatchArgMatches match1 bad_matches
=====================================
compiler/GHC/Tc/Gen/Match.hs-boot
=====================================
@@ -5,13 +5,13 @@ import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType )
import GHC.Tc.Types ( TcM )
import GHC.Hs.Extension ( GhcRn, GhcTc )
import GHC.Parser.Annotation ( LocatedN )
-import GHC.Types.Id (Id)
+import GHC.Types.Name (Name)
tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-tcMatchesFun :: LocatedN Id
+tcMatchesFun :: LocatedN Name
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -838,7 +838,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
args body]
, mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated
}
- match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) []
+ match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) []
(mkHsLams (rr_tv:res_tv:univ_tvs)
req_dicts body')
(EmptyLocalBinds noExtField)
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -1533,7 +1533,9 @@ data HsMatchContext p
= FunRhs
-- ^ A pattern matching on an argument of a
-- function binding
- { mc_fun :: LIdP p -- ^ function binder of @f@
+ { mc_fun :: LIdP (NoGhcTc p) -- ^ function binder of @f@
+ -- See #20415 for a long discussion about
+ -- this field and why it uses NoGhcTc.
, mc_fixity :: LexicalFixity -- ^ fixing of @f@
, mc_strictness :: SrcStrictness -- ^ was @f@ banged?
-- See Note [FunBind vs PatBind]
=====================================
testsuite/tests/ghci/scripts/T22695.script
=====================================
@@ -0,0 +1 @@
+test x | Just <- x = x
=====================================
testsuite/tests/ghci/scripts/T22695.stderr
=====================================
@@ -0,0 +1,8 @@
+
+<interactive>:1:10: error:
+ • The constructor ‘Just’ should have 1 argument, but has been given none
+ • In the pattern: Just
+ In a stmt of a pattern guard for
+ an equation for ‘test’:
+ Just <- x
+ In an equation for ‘test’: test x | Just <- x = x
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -370,3 +370,4 @@ test('T21110', [extra_files(['T21110A.hs'])], ghci_script,
test('T17830', [filter_stdout_lines(r'======.*')], ghci_script, ['T17830.script'])
test('T21294a', normal, ghci_script, ['T21294a.script'])
test('T21507', normal, ghci_script, ['T21507.script'])
+test('T22695', normal, ghci_script, ['T22695.script'])
=====================================
testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
=====================================
@@ -1560,7 +1560,7 @@
(FunRhs
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 })
- {Var: main})
+ {Name: main})
(Prefix)
(NoSrcStrict))
[]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ec60ef6842cc2d3965e2652980f9b589a0ca4ba
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ec60ef6842cc2d3965e2652980f9b589a0ca4ba
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/20230104/8307d4ad/attachment-0001.html>
More information about the ghc-commits
mailing list