[Git][ghc/ghc][master] 3 commits: Add test for #23540
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Aug 29 16:07:54 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
6bbde581 by Vasily Sterekhov at 2023-08-29T12:06:58-04:00
Add test for #23540
`T23540.hs` makes use of `explainEv` from `HieQueries.hs`, so
`explainEv` has been moved to `TestUtils.hs`.
- - - - -
257bb3bd by Vasily Sterekhov at 2023-08-29T12:06:58-04:00
Add test for #23120
- - - - -
4f192947 by Vasily Sterekhov at 2023-08-29T12:06:58-04:00
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]
- - - - -
16 changed files:
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- ghc/GHCi/UI/Info.hs
- testsuite/tests/hiefile/should_run/HieQueries.hs
- + testsuite/tests/hiefile/should_run/T23120.hs
- + testsuite/tests/hiefile/should_run/T23120.stdout
- + testsuite/tests/hiefile/should_run/T23540.hs
- + testsuite/tests/hiefile/should_run/T23540.stdout
- testsuite/tests/hiefile/should_run/TestUtils.hs
- testsuite/tests/hiefile/should_run/all.T
Changes:
=====================================
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)
=====================================
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
=====================================
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
=====================================
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)
=====================================
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
=====================================
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
=====================================
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) $
=====================================
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
=====================================
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,_)
=====================================
testsuite/tests/hiefile/should_run/HieQueries.hs
=====================================
@@ -33,22 +33,3 @@ main = do
explainEv df hf refmap point
explainEv df hf refmap point'
return ()
-
-explainEv :: DynFlags -> HieFile -> RefMap Int -> (Int,Int) -> IO ()
-explainEv df hf refmap point = do
- putStrLn $ replicate 26 '='
- putStrLn $ "At point " ++ show point ++ ", we found:"
- putStrLn $ replicate 26 '='
- putStr $ drawForest ptrees
- where
- trees = getEvidenceTreesAtPoint hf refmap point
-
- ptrees = fmap (pprint . fmap expandType) <$> trees
-
- expandType = text . renderHieType df .
- flip recoverFullType (hie_types hf)
-
- pretty = unlines . (++["└"]) . ("┌":) . map ("│ "++) . lines
-
- pprint = pretty . render df
-
=====================================
testsuite/tests/hiefile/should_run/T23120.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE GHC2021 #-}
+
+module Main where
+
+import TestUtils
+import qualified Data.Map.Strict as Map
+import Data.Either
+import Data.Maybe
+import GHC.Plugins (nameOccName, occNameString)
+
+f :: Int -> Int -> Bool
+f x = (x ==)
+ -- ^ point
+
+point :: (Int,Int)
+point = (12,10)
+
+main = do
+ (df, hf) <- readTestHie "T23120.hie"
+ let ast = fromMaybe (error "nothing") $ selectPoint hf point
+ idents = sourcedNodeIdents $ sourcedNodeInfo ast
+ names = rights $ Map.keys idents
+ mapM_ (print . occNameString . nameOccName) names
=====================================
testsuite/tests/hiefile/should_run/T23120.stdout
=====================================
@@ -0,0 +1,2 @@
+"=="
+"$dEq"
=====================================
testsuite/tests/hiefile/should_run/T23540.hs
=====================================
@@ -0,0 +1,111 @@
+{-# LANGUAGE OverloadedLists, TypeFamilies, ApplicativeDo, NPlusKPatterns #-}
+
+module Main where
+
+import TestUtils
+import GHC.IsList ( IsList(..) )
+
+data Modulo1 = Zero deriving (Eq, Ord, Enum)
+
+instance Num Modulo1 where
+ fromInteger _ = Zero
+ (+) _ _ = Zero
+
+zero :: Modulo1
+zero = 0
+ -- ^ 1
+
+data Identity a = Identity a
+
+instance Functor Identity where
+ fmap f (Identity x) = Identity (f x)
+instance Applicative Identity where
+ pure = Identity
+ Identity f <*> Identity x = Identity (f x)
+instance Monad Identity where
+ Identity x >>= f = f x
+
+foo :: Identity Integer
+foo = do
+ _x <- Identity 1
+ -- ^ 2
+ Identity 2
+
+data BetterList x = Nil | Cons x (BetterList x)
+
+instance IsList (BetterList x) where
+ type Item (BetterList x) = x
+ fromList = foldr Cons Nil
+ toList Nil = []
+ toList (Cons x xs) = x : toList xs
+
+list :: BetterList Modulo1
+list = [0, 1, 2, 3, Zero]
+ -- ^ 3 ^ 4 ^ 5
+
+data Letter = A | B | C deriving Enum
+
+letters :: [Letter]
+letters = [A .. C]
+ -- ^ 6
+
+data Identity' a = Identity' a
+
+instance Functor Identity' where
+ fmap f (Identity' x) = Identity' (f x)
+instance Applicative Identity' where
+ pure = Identity'
+ Identity' f <*> Identity' x = Identity' (f x)
+
+bar :: Identity' Integer
+bar = do
+ -- ^ 7
+ a <- Identity' 1
+ b <- Identity' 2
+ pure (a + b)
+
+isZero :: Modulo1 -> Bool
+isZero n = case n of
+ 0 -> True
+-- ^ 8
+ _ -> False
+
+instance Real Modulo1 where
+ toRational _ = 0
+
+instance Integral Modulo1 where
+ toInteger _ = 0
+ quotRem _ _ = (0, 0)
+
+isPlusOne :: Modulo1 -> Bool
+isPlusOne n = case n of
+ (a + 1) -> True
+ -- ^ 9
+ _ -> False
+
+point1, point2, point3, point4, point5, point6, point7, point8, point9 :: (Int, Int)
+point1 = (15, 8)
+
+point2 = (30, 8)
+
+point3 = (43, 8)
+
+point4 = (43, 15)
+
+point5 = (43, 21)
+
+point6 = (49, 14)
+
+point7 = (61, 7)
+
+point8 = (69, 4)
+
+point9 = (82, 6)
+
+points :: [(Int, Int)]
+points = [point1, point2, point3, point4, point5, point6, point7, point8, point9]
+
+main = do
+ (df, hf) <- readTestHie "T23540.hie"
+ let refmap = generateReferencesMap . getAsts $ hie_asts hf
+ mapM_ (explainEv df hf refmap) points
=====================================
testsuite/tests/hiefile/should_run/T23540.stdout
=====================================
@@ -0,0 +1,234 @@
+==========================
+At point (15,8), we found:
+==========================
+┌
+│ $dNum at T23540.hs:1:1, of type: Num Modulo1
+│ is an evidence variable bound by a let, depending on: [$dNum]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $dNum at T23540.hs:1:1, of type: Num Modulo1
+ │ is an evidence variable bound by a let, depending on: [$fNumModulo1]
+ │ with scope: ModuleScope
+ │
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ $fNumModulo1 at T23540.hs:10:10-20, of type: Num Modulo1
+ │ is an evidence variable bound by an instance of class Num
+ │ with scope: ModuleScope
+ │
+ │ Defined at T23540.hs:10:10
+ └
+
+==========================
+At point (30,8), we found:
+==========================
+┌
+│ $dMonad at T23540.hs:1:1, of type: Monad Identity
+│ is an evidence variable bound by a let, depending on: [$fMonadIdentity]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $fMonadIdentity at T23540.hs:25:10-23, of type: Monad Identity
+ │ is an evidence variable bound by an instance of class Monad
+ │ with scope: ModuleScope
+ │
+ │ Defined at T23540.hs:25:10
+ └
+
+==========================
+At point (43,8), we found:
+==========================
+┌
+│ $dIsList at T23540.hs:1:1, of type: IsList (BetterList Modulo1)
+│ is an evidence variable bound by a let, depending on: [$fIsListBetterList]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $fIsListBetterList at T23540.hs:36:10-30, of type: forall x. IsList (BetterList x)
+ │ is an evidence variable bound by an instance of class IsList
+ │ with scope: ModuleScope
+ │
+ │ Defined at T23540.hs:36:10
+ └
+
+==========================
+At point (43,15), we found:
+==========================
+┌
+│ $dNum at T23540.hs:1:1, of type: Num Modulo1
+│ is an evidence variable bound by a let, depending on: [$dNum]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $dNum at T23540.hs:1:1, of type: Num Modulo1
+ │ is an evidence variable bound by a let, depending on: [$fNumModulo1]
+ │ with scope: ModuleScope
+ │
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ $fNumModulo1 at T23540.hs:10:10-20, of type: Num Modulo1
+ │ is an evidence variable bound by an instance of class Num
+ │ with scope: ModuleScope
+ │
+ │ Defined at T23540.hs:10:10
+ └
+
+==========================
+At point (43,21), we found:
+==========================
+==========================
+At point (49,14), we found:
+==========================
+┌
+│ $dEnum at T23540.hs:1:1, of type: Enum (Item [Letter])
+│ is an evidence variable bound by a let, depending on: [$dEnum]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $dEnum at T23540.hs:1:1, of type: Enum Letter
+ │ is an evidence variable bound by a let, depending on: [$fEnumLetter]
+ │ with scope: ModuleScope
+ │
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ $fEnumLetter at T23540.hs:46:34-37, of type: Enum Letter
+ │ is an evidence variable bound by an instance of class Enum
+ │ with scope: ModuleScope
+ │
+ │ Defined at T23540.hs:46:34
+ └
+
+==========================
+At point (61,7), we found:
+==========================
+┌
+│ $dFunctor at T23540.hs:1:1, of type: Functor Identity'
+│ is an evidence variable bound by a let, depending on: [$fFunctorIdentity']
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $fFunctorIdentity' at T23540.hs:54:10-26, of type: Functor Identity'
+ │ is an evidence variable bound by an instance of class Functor
+ │ with scope: ModuleScope
+ │
+ │ Defined at T23540.hs:54:10
+ └
+
+┌
+│ $dApplicative at T23540.hs:1:1, of type: Applicative Identity'
+│ is an evidence variable bound by a let, depending on: [$fApplicativeIdentity']
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $fApplicativeIdentity' at T23540.hs:56:10-30, of type: Applicative Identity'
+ │ is an evidence variable bound by an instance of class Applicative
+ │ with scope: ModuleScope
+ │
+ │ Defined at T23540.hs:56:10
+ └
+
+==========================
+At point (69,4), we found:
+==========================
+┌
+│ $dEq at T23540.hs:1:1, of type: Eq Modulo1
+│ is an evidence variable bound by a let, depending on: [$fEqModulo1]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $fEqModulo1 at T23540.hs:8:31-32, of type: Eq Modulo1
+ │ is an evidence variable bound by an instance of class Eq
+ │ with scope: ModuleScope
+ │
+ │ Defined at T23540.hs:8:31
+ └
+
+┌
+│ $dNum at T23540.hs:1:1, of type: Num Modulo1
+│ is an evidence variable bound by a let, depending on: [$dNum]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $dNum at T23540.hs:1:1, of type: Num Modulo1
+ │ is an evidence variable bound by a let, depending on: [$fNumModulo1]
+ │ with scope: ModuleScope
+ │
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ $fNumModulo1 at T23540.hs:10:10-20, of type: Num Modulo1
+ │ is an evidence variable bound by an instance of class Num
+ │ with scope: ModuleScope
+ │
+ │ Defined at T23540.hs:10:10
+ └
+
+==========================
+At point (82,6), we found:
+==========================
+┌
+│ $dOrd at T23540.hs:1:1, of type: Ord Modulo1
+│ is an evidence variable bound by a let, depending on: [$fOrdModulo1]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $fOrdModulo1 at T23540.hs:8:35-37, of type: Ord Modulo1
+ │ is an evidence variable bound by an instance of class Ord
+ │ with scope: ModuleScope
+ │
+ │ Defined at T23540.hs:8:35
+ └
+
+┌
+│ $dNum at T23540.hs:1:1, of type: Num Modulo1
+│ is an evidence variable bound by a let, depending on: [$fNumModulo1]
+│ with scope: ModuleScope
+│
+│ Defined at <no location info>
+└
+|
+`- ┌
+ │ $fNumModulo1 at T23540.hs:10:10-20, of type: Num Modulo1
+ │ is an evidence variable bound by an instance of class Num
+ │ with scope: ModuleScope
+ │
+ │ Defined at T23540.hs:10:10
+ └
\ No newline at end of file
=====================================
testsuite/tests/hiefile/should_run/TestUtils.hs
=====================================
@@ -1,5 +1,6 @@
module TestUtils
- ( readTestHie
+ ( explainEv
+ , readTestHie
, render
, text
, SDoc
@@ -44,3 +45,21 @@ render df = renderWithContext (initSDocContext df defaultUserStyle) . ppr
text :: String -> SDoc
text = O.text -- SDoc-only version
+
+explainEv :: DynFlags -> HieFile -> RefMap Int -> (Int,Int) -> IO ()
+explainEv df hf refmap point = do
+ putStrLn $ replicate 26 '='
+ putStrLn $ "At point " ++ show point ++ ", we found:"
+ putStrLn $ replicate 26 '='
+ putStr $ drawForest ptrees
+ where
+ trees = getEvidenceTreesAtPoint hf refmap point
+
+ ptrees = fmap (pprint . fmap expandType) <$> trees
+
+ expandType = text . renderHieType df .
+ flip recoverFullType (hie_types hf)
+
+ pretty = unlines . (++["└"]) . ("┌":) . map ("│ "++) . lines
+
+ pprint = pretty . render df
=====================================
testsuite/tests/hiefile/should_run/all.T
=====================================
@@ -5,3 +5,5 @@ test('T23492', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUti
test('RecordDotTypes', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('SpliceTypes', [req_th, extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('HieVdq', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
+test('T23540', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
+test('T23120', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4f5fb500148485dcbf407ab428f044ae879a3bcc...4f192947e81fa34435fdebfcf1f9d449b7944f34
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4f5fb500148485dcbf407ab428f044ae879a3bcc...4f192947e81fa34435fdebfcf1f9d449b7944f34
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/20230829/81818f0d/attachment-0001.html>
More information about the ghc-commits
mailing list