From 4f192947e81fa34435fdebfcf1f9d449b7944f34 Mon Sep 17 00:00:00 2001
From: Vasily Sterekhov <89035-ryndubei@users.noreply.gitlab.haskell.org>
Date: Thu, 24 Aug 2023 01:33:36 +0100
Subject: [PATCH] Make some evidence uses reachable by toHie
Resolves #23540, #23120
This adds spans to certain expressions in the typechecker and renamer,
and lets 'toHie' make use of those spans. Therefore the relevant
evidence uses for the following syntax will now show up under the
expected nodes in 'HieAst's:
- Overloaded literals ('IsString', 'Num', 'Fractional')
- Natural patterns and N+k patterns ('Eq', 'Ord', and instances from the
overloaded literals being matched on)
- Arithmetic sequences ('Enum')
- Monadic bind statements ('Monad')
- Monadic body statements ('Monad', 'Alternative')
- ApplicativeDo ('Applicative', 'Functor')
- Overloaded lists ('IsList')
Also see Note [Source locations for implicit function calls]
In the process of handling overloaded lists I added an extra 'SrcSpan'
field to 'VAExpansion' - this allows us to more accurately reconstruct
the locations from the renamer in 'rebuildHsApps'. This also happens to
fix #23120.
See the additions to Note [Looking through HsExpanded]
---
compiler/GHC/Hs/Utils.hs | 22 ++++---
compiler/GHC/Iface/Ext/Ast.hs | 90 +++++++++++++++++++++++++---
compiler/GHC/Rename/Expr.hs | 11 +++-
compiler/GHC/Rename/Pat.hs | 3 +-
compiler/GHC/Rename/Utils.hs | 7 ++-
compiler/GHC/Tc/Gen/App.hs | 2 +-
compiler/GHC/Tc/Gen/Head.hs | 34 ++++++++---
compiler/GHC/Tc/Utils/Instantiate.hs | 4 +-
ghc/GHCi/UI/Info.hs | 5 ++
9 files changed, 147 insertions(+), 31 deletions(-)
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 6e805fe19b3e..bf35ef46ec13 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -42,7 +42,7 @@ just attach noSrcSpan to everything.
module GHC.Hs.Utils(
-- * Terms
- mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,
+ mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith, mkHsSyntaxApps,
mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
@@ -282,6 +282,17 @@ mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
<.> mkWpEvLams dicts) expr
+mkHsSyntaxApps :: SrcSpanAnnA -> SyntaxExprTc -> [LHsExpr GhcTc]
+ -> LHsExpr GhcTc
+mkHsSyntaxApps ann (SyntaxExprTc { syn_expr = fun
+ , syn_arg_wraps = arg_wraps
+ , syn_res_wrap = res_wrap }) args
+ = mkLHsWrap res_wrap (foldl' mkHsApp (L ann fun) (zipWithEqual "mkHsSyntaxApps"
+ mkLHsWrap arg_wraps args))
+mkHsSyntaxApps _ NoSyntaxExprTc args = pprPanic "mkHsSyntaxApps" (ppr args)
+ -- this function should never be called in scenarios where there is no
+ -- syntax expr
+
-- |A simple case alternative with a single pattern, no binds, no guards;
-- pre-typechecking
mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
@@ -516,14 +527,7 @@ nlHsApp f x = noLocA (HsApp noComments f (mkLHsPar x))
nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc]
-> LHsExpr GhcTc
-nlHsSyntaxApps (SyntaxExprTc { syn_expr = fun
- , syn_arg_wraps = arg_wraps
- , syn_res_wrap = res_wrap }) args
- = mkLHsWrap res_wrap (foldl' nlHsApp (noLocA fun) (zipWithEqual "nlHsSyntaxApps"
- mkLHsWrap arg_wraps args))
-nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args)
- -- this function should never be called in scenarios where there is no
- -- syntax expr
+nlHsSyntaxApps = mkHsSyntaxApps noSrcSpanA
nlHsApps :: IsSrcSpanAnn p a
=> IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 3558277b20ed..6d4d39117bb3 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -12,6 +12,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
+{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-orphans #-} -- For the HasLoc instances
@@ -1010,10 +1011,14 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
]
LitPat _ _ ->
[]
- NPat _ _ _ _ ->
- []
- NPlusKPat _ n _ _ _ _ ->
+ NPat _ (L loc lit) _ eq ->
+ [ toHie $ L (l2l loc :: SrcSpanAnnA) lit
+ , toHieSyntax (L ospan eq)
+ ]
+ NPlusKPat _ n (L loc lit) _ ord _ ->
[ toHie $ C (PatternBind scope pscope rsp) n
+ , toHie $ L (l2l loc :: SrcSpanAnnA) lit
+ , toHieSyntax (L ospan ord)
]
SigPat _ pat sig ->
[ toHie $ PS rsp scope pscope pat
@@ -1055,6 +1060,23 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
L spn $ HsFieldBind x lbl (PS rsp scope fscope pat) pun
scoped_fds = listScopes pscope fds
+toHieSyntax :: forall p. HiePass p => LocatedA (SyntaxExpr (GhcPass p)) -> HieM [HieAST Type]
+toHieSyntax s = local (const GeneratedInfo) $ case hiePass @p of
+ HieRn -> toHie s
+ HieTc -> toHie s
+
+instance ToHie (LocatedA SyntaxExprRn) where
+ toHie (L mspan (SyntaxExprRn expr)) = toHie (L mspan expr)
+ toHie (L _ NoSyntaxExprRn) = pure []
+
+instance ToHie (LocatedA SyntaxExprTc) where
+ toHie (L mspan (SyntaxExprTc expr w1 w2)) = concatM
+ [ toHie (L mspan expr)
+ , concatMapM (toHie . L mspan) w1
+ , toHie (L mspan w2)
+ ]
+ toHie (L _ NoSyntaxExprTc) = pure []
+
instance ToHie (TScoped (HsPatSigType GhcRn)) where
toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $
[ bindingsOnly $ map (C $ TyVarBind (mkScopeA span) sc) (wcs++tvs)
@@ -1088,6 +1110,50 @@ instance ( ToHie (LocatedA (body (GhcPass p)))
, toHie body
]
+{-
+Note [Source locations for implicit function calls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+While calls to e.g. 'fromString' with -XOverloadedStrings do not actually
+appear in the source code, giving their HsWrapper the location of the
+overloaded bit of syntax that triggered them is useful for assigning
+their type class evidence uses to the right location in the HIE AST.
+Without this, we only get type class instance information under the
+expected top-level node if the type had to be inferred. (#23540)
+
+We currently handle the following constructors with this in mind,
+all largely in the renamer as their locations are normally inherited by
+the typechecker:
+
+ * HsOverLit, where we assign the SrcSpan of the overloaded literal
+ to ol_from_fun.
+ * HsDo, where we give the SrcSpan of the entire do block to each
+ ApplicativeStmt.
+ * HsExpanded ExplicitList{}, where we give the SrcSpan of the original
+ list expression to the 'fromListN' call.
+
+In order for the implicit function calls to not be confused for actual
+occurrences of functions in the source code, most of this extra information
+is put under 'GeneratedInfo'.
+-}
+
+whenPostTc :: forall p t m. (HiePass p, Applicative t, Monoid m) => ((p ~ 'Typechecked) => t m) -> t m
+whenPostTc a = case hiePass @p of
+ HieTc -> a
+ HieRn -> pure mempty
+
+-- | Helper function for a common pattern where we are only interested in
+-- implicit evidence information: runs only post-typecheck and marks the
+-- current 'NodeOrigin' as generated.
+whenPostTcGen :: forall p. HiePass p => ((p ~ 'Typechecked) => HieM [HieAST Type]) -> HieM [HieAST Type]
+whenPostTcGen a = local (const GeneratedInfo) $ whenPostTc @p a
+
+instance HiePass p => ToHie (LocatedA (HsOverLit (GhcPass p))) where
+ toHie (L span (OverLit x _)) = whenPostTcGen @p $ concatM $ case x of
+ OverLitTc _ witness _ ->
+ [ toHie (L span witness)
+ ]
+ -- See Note [Source locations for implicit function calls]
+
instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
HsVar _ (L _ var) ->
@@ -1100,7 +1166,9 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
]
HsOverLabel {} -> []
HsIPVar _ _ -> []
- HsOverLit _ _ -> []
+ HsOverLit _ o ->
+ [ toHie (L mspan o)
+ ]
HsLit _ _ -> []
HsLam _ mg ->
[ toHie mg
@@ -1186,8 +1254,9 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
[ toHie expr
, toHie $ TS (ResolvedScopes [mkLScopeA expr]) sig
]
- ArithSeq _ _ info ->
+ ArithSeq enum _ info ->
[ toHie info
+ , whenPostTcGen @p $ toHie (L mspan enum)
]
HsPragE _ _ expr ->
[ toHie expr
@@ -1261,15 +1330,22 @@ instance ( ToHie (LocatedA (body (GhcPass p)))
LastStmt _ body _ _ ->
[ toHie body
]
- BindStmt _ pat body ->
+ BindStmt monad pat body ->
[ toHie $ PS (getRealSpan $ getLocA body) scope NoScope pat
, toHie body
+ , whenPostTcGen @p $
+ toHieSyntax $ L span (xbstc_bindOp monad)
]
ApplicativeStmt _ stmts _ ->
[ concatMapM (toHie . RS scope . snd) stmts
+ , let applicative_or_functor = map fst stmts
+ in whenPostTcGen @p $
+ concatMapM (toHieSyntax . L span) applicative_or_functor
]
- BodyStmt _ body _ _ ->
+ BodyStmt _ body monad alternative ->
[ toHie body
+ , whenPostTc @p $
+ concatMapM (toHieSyntax . L span) [monad, alternative]
]
LetStmt _ binds ->
[ toHie $ RS scope binds
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index e51a515c511c..758da90e8628 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -46,7 +46,7 @@ import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames
, warnUnusedLocalBinds, typeAppErr
, checkUnusedRecordWildcard
, wrapGenSpan, genHsIntegralLit, genHsTyLit
- , genHsVar, genLHsVar, genHsApp, genHsApps
+ , genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps'
, genAppType, isIrrefutableHsPatRn )
import GHC.Rename.Unbound ( reportUnboundName )
import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnTypedSplice, rnUntypedSpliceExpr, checkThLocalName )
@@ -450,10 +450,11 @@ rnExpr (ExplicitList _ exps)
then return (ExplicitList noExtField exps', fvs)
else
do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
+ ; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls]
; let rn_list = ExplicitList noExtField exps'
lit_n = mkIntegralLit (length exps)
hs_lit = genHsIntegralLit lit_n
- exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list]
+ exp_list = genHsApps' (L (noAnnSrcSpan loc) from_list_n_name) [hs_lit, wrapGenSpan rn_list]
; return ( mkExpandedExpr rn_list exp_list
, fvs `plusFV` fvs') } }
@@ -2415,7 +2416,11 @@ mkApplicativeStmt ctxt args need_join body_stmts
; return (Just join_op, fvs) }
else
return (Nothing, emptyNameSet)
- ; let applicative_stmt = noLocA $ ApplicativeStmt noExtField
+ -- We cannot really say where the ApplicativeStmt is located with more accuracy
+ -- than the span of the do-block, but it is better than nothing for IDE info
+ -- See Note [Source locations for implicit function calls]
+ ; loc <- getSrcSpanM
+ ; let applicative_stmt = L (noAnnSrcSpan loc) $ ApplicativeStmt noExtField
(zip (fmap_op : repeat ap_op) args)
mb_join
; return ( applicative_stmt : body_stmts
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 331cfdd99789..d9519c18a99f 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -1111,9 +1111,10 @@ rnOverLit origLit
}
; let std_name = hsOverLitName val
; (from_thing_name, fvs1) <- lookupSyntaxName std_name
+ ; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast
; let rebindable = from_thing_name /= std_name
lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable
- , ol_from_fun = noLocA from_thing_name } }
+ , ol_from_fun = L (noAnnSrcSpan loc) from_thing_name } }
; if isNegativeZeroOverLit lit'
then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName
; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index e947fd3156f4..d8cda861d63f 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -21,7 +21,7 @@ module GHC.Rename.Utils (
DeprecationWarnings(..), warnIfDeprecated,
checkUnusedRecordWildcard,
badQualBndrErr, typeAppErr, badFieldConErr,
- wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genLHsApp,
+ wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genLHsApp,
genAppType,
genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat,
genVarPat, genWildPat,
@@ -722,6 +722,11 @@ wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps fun args = foldl genHsApp (genHsVar fun) args
+-- | Keeps the span given to the 'Name' for the application head only
+genHsApps' :: LocatedN Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
+genHsApps' (L _ fun) [] = genHsVar fun
+genHsApps' (L loc fun) (arg:args) = foldl genHsApp (unLoc $ mkHsApp (L (l2l loc) $ genHsVar fun) arg) args
+
genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index e12160e547fd..5fd815d48d19 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -528,7 +528,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
; go emptyVarSet [] [] fun_sigma rn_args }
where
fun_orig = exprCtOrigin (case fun_ctxt of
- VAExpansion e _ -> e
+ VAExpansion e _ _ -> e
VACall e _ _ -> e)
-- These are the type variables which must be instantiated to concrete
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 038c842d579e..f771a0b84db5 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -204,6 +204,10 @@ data AppCtxt
(HsExpr GhcRn) -- Inside an expansion of this expression
SrcSpan -- The SrcSpan of the expression
-- noSrcSpan if outermost; see Note [AppCtxt]
+ SrcSpan -- The SrcSpan of the application as specified
+ -- inside the expansion.
+ -- Used for accurately reconstructing the
+ -- original SrcSpans in 'rebuildHsApps'.
| VACall
(HsExpr GhcRn) Int -- In the third argument of function f
@@ -238,7 +242,7 @@ a second time.
-}
appCtxtLoc :: AppCtxt -> SrcSpan
-appCtxtLoc (VAExpansion _ l) = l
+appCtxtLoc (VAExpansion _ l _) = l
appCtxtLoc (VACall _ _ l) = l
insideExpansion :: AppCtxt -> Bool
@@ -246,7 +250,7 @@ insideExpansion (VAExpansion {}) = True
insideExpansion (VACall {}) = False
instance Outputable AppCtxt where
- ppr (VAExpansion e _) = text "VAExpansion" <+> ppr e
+ ppr (VAExpansion e _ _) = text "VAExpansion" <+> ppr e
ppr (VACall f n _) = text "VACall" <+> int n <+> ppr f
type family XPass p where
@@ -310,7 +314,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
-- See Note [Looking through HsExpanded]
go (XExpr (HsExpanded orig fun)) ctxt args
- = go fun (VAExpansion orig (appCtxtLoc ctxt))
+ = go fun (VAExpansion orig (appCtxtLoc ctxt) (appCtxtLoc ctxt))
(EWrap (EExpand orig) : args)
-- See Note [Looking through Template Haskell splices in splitHsApps]
@@ -339,11 +343,11 @@ splitHsApps e = go e (top_ctxt 0 e) []
set :: SrcAnn ann -> AppCtxt -> AppCtxt
set l (VACall f n _) = VACall f n (locA l)
- set _ ctxt@(VAExpansion {}) = ctxt
+ set l (VAExpansion orig ol _) = VAExpansion orig ol (locA l)
dec :: SrcAnn ann -> AppCtxt -> AppCtxt
dec l (VACall f n _) = VACall f (n-1) (locA l)
- dec _ ctxt@(VAExpansion {}) = ctxt
+ dec l (VAExpansion orig ol _) = VAExpansion orig ol (locA l)
-- | Rebuild an application: takes a type-checked application head
-- expression together with arguments in the form of typechecked 'HsExprArg's
@@ -390,7 +394,9 @@ rebuild_hs_apps fun ctxt (arg : args)
EWrap (EHsWrap wrap)
-> rebuild_hs_apps (mkHsWrap wrap fun) ctxt args
where
- lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun
+ lfun = L (noAnnSrcSpan $ appCtxtLoc' ctxt) fun
+ appCtxtLoc' (VAExpansion _ _ l) = l
+ appCtxtLoc' v = appCtxtLoc v
{- Note [Representation-polymorphic Ids with no binding]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -775,6 +781,19 @@ labels (#19154) won't work.
It's easy to achieve this: `splitHsApps` unwraps `HsExpanded`.
+In order to be able to more accurately reconstruct the original `SrcSpan`s
+from the renamer in `rebuildHsApps`, we also have to track the `SrcSpan`
+of the current application in `VAExpansion` when unwrapping `HsExpanded`
+in `splitHsApps`, just as we track it in a non-expanded expression.
+
+Previously, `rebuildHsApps` substituted the location of the original
+expression as given by `splitHsApps` for this. As a result, the application
+head in expanded expressions, e.g. the call to `fromListN`, would either
+have `noSrcSpan` set as its location post-typecheck, or get the location
+of the original expression, depending on whether the `XExpr` given to
+`splitHsApps` is in the outermost layer. The span it got in the renamer
+would always be discarded, causing #23120.
+
Note [Looking through Template Haskell splices in splitHsApps]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When typechecking an application, we must look through untyped TH splices in
@@ -869,7 +888,7 @@ addHeadCtxt fun_ctxt thing_inside
| otherwise
= setSrcSpan fun_loc $
case fun_ctxt of
- VAExpansion orig _ -> addExprCtxt orig thing_inside
+ VAExpansion orig _ _ -> addExprCtxt orig thing_inside
VACall {} -> thing_inside
where
fun_loc = appCtxtLoc fun_ctxt
@@ -1064,6 +1083,7 @@ tcInferOverLit lit@(OverLit { ol_val = val
(1, []) from_ty
; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)
+ -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast
; let lit_expr = L (l2l loc) $ mkHsWrapCo co $
HsLit noAnn hs_lit
from_expr = mkHsWrap (wrap2 <.> wrap1) $
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 23af3cf3cb6b..66c1df732e3e 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -691,14 +691,14 @@ newNonTrivialOverloadedLit :: HsOverLit GhcRn
-> ExpRhoType
-> TcM (HsOverLit GhcTc)
newNonTrivialOverloadedLit
- lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable (L _ meth_name) })
+ lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable (L loc meth_name) })
res_ty
= do { hs_lit <- mkOverLit val
; let lit_ty = hsLitType hs_lit
; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
[synKnownType lit_ty] res_ty $
\_ _ -> return ()
- ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
+ ; let L _ witness = mkHsSyntaxApps (l2l loc) fi' [nlHsLit hs_lit]
; res_ty <- readExpType res_ty
; return (lit { ol_ext = OverLitTc { ol_rebindable = rebindable
, ol_witness = witness
diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs
index 505a1da68fd1..568afd288be4 100644
--- a/ghc/GHCi/UI/Info.hs
+++ b/ghc/GHCi/UI/Info.hs
@@ -381,9 +381,14 @@ processAllTypeCheckedModule tcm
-- | Variant of @syb@'s @everything@ (which summarises all nodes
-- in top-down, left-to-right order) with a stop-condition on 'NameSet's
+ -- and 'OverLitTc'
everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingAllSpans k z f x
| (False `mkQ` (const True :: NameSet -> Bool)) x = z
+ -- Exception for OverLitTc: we have SrcSpans in the ol_witness field,
+ -- but it's there only for HIE file info (see Note [Source locations for implicit function calls]).
+ -- T16804 fails without this.
+ | (False `mkQ` (const True :: OverLitTc -> Bool)) x = z
| otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)
cmpSpan (_,a,_) (_,b,_)
--
GitLab