[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Repair `codes` test on OpenBSD by explicitly requesting extended RE
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Aug 29 12:27:05 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
4f5fb500 by Greg Steuck at 2023-08-29T07:55:13-04:00
Repair `codes` test on OpenBSD by explicitly requesting extended RE
- - - - -
dd4f4228 by Vasily Sterekhov at 2023-08-29T08:26:33-04:00
Add test for #23540
`T23540.hs` makes use of `explainEv` from `HieQueries.hs`, so
`explainEv` has been moved to `TestUtils.hs`.
- - - - -
57e0e74c by Vasily Sterekhov at 2023-08-29T08:26:33-04:00
Add test for #23120
- - - - -
9451ec3c by Vasily Sterekhov at 2023-08-29T08:26:33-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]
- - - - -
05c05e99 by Sylvain Henry at 2023-08-29T08:26:44-04:00
ghc-heap: rename C file (fix #23898)
- - - - -
6c48c966 by Krzysztof Gogolewski at 2023-08-29T08:26:44-04:00
Misc cleanup
- Builtin.PrimOps: ReturnsAlg was used only for unboxed tuples.
Rename to ReturnsTuple.
- Builtin.Utils: use SDoc for a panic message.
The comment about <<details unavailable>> was obsoleted by e8d356773b56.
- TagCheck: fix wrong logic. It was zipping a list 'args' with its
version 'args_cmm' after filtering.
- Core.Type: remove an outdated 1999 comment about unlifted polymorphic types
- hadrian: remove leftover debugging print
- - - - -
e3cde906 by Krzysztof Gogolewski at 2023-08-29T08:26:45-04:00
Add a regression test for #23903
The bug has been fixed by commit bad2f8b8aa8424.
- - - - -
30 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/Builtin/Types/Prim.hs
- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Core/Type.hs
- 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/StgToCmm/Prim.hs
- compiler/GHC/StgToCmm/TagCheck.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Types/Id.hs
- ghc/GHCi/UI/Info.hs
- hadrian/src/Rules/Test.hs
- libraries/ghc-heap/cbits/Stack.c → libraries/ghc-heap/cbits/Stack_c.c
- libraries/ghc-heap/ghc-heap.cabal.in
- linters/lint-codes/LintCodes/Coverage.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
- + testsuite/tests/rep-poly/T23903.hs
- + testsuite/tests/rep-poly/T23903.stderr
- testsuite/tests/rep-poly/all.T
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -35,7 +35,7 @@ import GHC.Builtin.Types
import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique )
import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS )
-import GHC.Core.TyCon ( TyCon, isPrimTyCon, PrimRep(..) )
+import GHC.Core.TyCon ( isPrimTyCon, isUnboxedTupleTyCon, PrimRep(..) )
import GHC.Core.Type
import GHC.Cmm.Type
@@ -55,6 +55,7 @@ import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
import GHC.Utils.Outputable
+import GHC.Utils.Panic
import GHC.Data.FastString
@@ -857,7 +858,7 @@ primOpSig op
data PrimOpResultInfo
= ReturnsPrim PrimRep
- | ReturnsAlg TyCon
+ | ReturnsTuple
-- Some PrimOps need not return a manifest primitive or algebraic value
-- (i.e. they might return a polymorphic value). These PrimOps *must*
@@ -868,7 +869,8 @@ getPrimOpResultInfo op
= case (primOpInfo op) of
Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon)
GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc)
- | otherwise -> ReturnsAlg tc
+ | isUnboxedTupleTyCon tc -> ReturnsTuple
+ | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op)
where
tc = tyConAppTyCon ty
-- All primops return a tycon-app result
=====================================
compiler/GHC/Builtin/Types/Prim.hs
=====================================
@@ -758,8 +758,10 @@ Wrinkles
are not /apart/: see Note [Type and Constraint are not apart]
(W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and
- aBSENT_CONSTRAINT_ERROR_ID for vaues of kind Constraint. Ditto noInlineId
- vs noInlineConstraintId in GHC.Types.Id.Make; see Note [inlineId magic].
+ aBSENT_CONSTRAINT_ERROR_ID for types of kind Constraint.
+ See Note [Type vs Constraint for error ids] in GHC.Core.Make.
+ Ditto noInlineId vs noInlineConstraintId in GHC.Types.Id.Make;
+ see Note [inlineId magic].
(W3) We need a TypeOrConstraint flag in LitRubbish.
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -67,7 +67,7 @@ import GHC.Types.Id.Make
import GHC.Types.Unique.FM
import GHC.Types.Unique.Map
import GHC.Types.TyThing
-import GHC.Types.Unique ( isValidKnownKeyUnique )
+import GHC.Types.Unique ( isValidKnownKeyUnique, pprUniqueAlways )
import GHC.Utils.Outputable
import GHC.Utils.Misc as Utils
@@ -79,7 +79,7 @@ import GHC.Unit.Module.ModIface (IfaceExport)
import GHC.Data.List.SetOps
import Control.Applicative ((<|>))
-import Data.List ( intercalate , find )
+import Data.List ( find )
import Data.Maybe
{-
@@ -116,12 +116,8 @@ Note [About wired-in things]
knownKeyNames :: [Name]
knownKeyNames
| debugIsOn
- , Just badNamesStr <- knownKeyNamesOkay all_names
- = panic ("badAllKnownKeyNames:\n" ++ badNamesStr)
- -- NB: We can't use ppr here, because this is sometimes evaluated in a
- -- context where there are no DynFlags available, leading to a cryptic
- -- "<<details unavailable>>" error. (This seems to happen only in the
- -- stage 2 compiler, for reasons I [Richard] have no clue of.)
+ , Just badNamesDoc <- knownKeyNamesOkay all_names
+ = pprPanic "badAllKnownKeyNames" badNamesDoc
| otherwise
= all_names
where
@@ -161,16 +157,15 @@ knownKeyNames
Nothing -> []
-- | Check the known-key names list of consistency.
-knownKeyNamesOkay :: [Name] -> Maybe String
+knownKeyNamesOkay :: [Name] -> Maybe SDoc
knownKeyNamesOkay all_names
| ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names
- = Just $ " Out-of-range known-key uniques: ["
- ++ intercalate ", " (map (occNameString . nameOccName) ns) ++
- "]"
+ = Just $ text " Out-of-range known-key uniques: " <>
+ brackets (pprWithCommas (ppr . nameOccName) ns)
| null badNamesPairs
= Nothing
| otherwise
- = Just badNamesStr
+ = Just badNamesDoc
where
namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n)
emptyUFM all_names
@@ -178,14 +173,14 @@ knownKeyNamesOkay all_names
badNamesPairs = nonDetUFMToList badNamesEnv
-- It's OK to use nonDetUFMToList here because the ordering only affects
-- the message when we get a panic
- badNamesStrs = map pairToStr badNamesPairs
- badNamesStr = unlines badNamesStrs
-
- pairToStr (uniq, ns) = " " ++
- show uniq ++
- ": [" ++
- intercalate ", " (map (occNameString . nameOccName) ns) ++
- "]"
+ badNamesDoc :: SDoc
+ badNamesDoc = vcat $ map pairToDoc badNamesPairs
+
+ pairToDoc :: (Unique, [Name]) -> SDoc
+ pairToDoc (uniq, ns) = text " " <>
+ pprUniqueAlways uniq <>
+ text ": " <>
+ brackets (pprWithCommas (ppr . nameOccName) ns)
-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a
-- known-key thing.
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -2302,8 +2302,6 @@ isUnliftedType :: HasDebugCallStack => Type -> Bool
-- isUnliftedType returns True for forall'd unlifted types:
-- x :: forall a. Int#
-- I found bindings like these were getting floated to the top level.
- -- They are pretty bogus types, mind you. It would be better never to
- -- construct them
isUnliftedType ty =
case typeLevity_maybe ty of
Just Lifted -> False
=====================================
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/StgToCmm/Prim.hs
=====================================
@@ -1717,11 +1717,9 @@ emitPrimOp cfg primop =
-> do reg <- newTemp (primRepCmmType platform rep)
pure [reg]
- ReturnsAlg tycon | isUnboxedTupleTyCon tycon
+ ReturnsTuple
-> do (regs, _hints) <- newUnboxedTupleRegs res_ty
pure regs
-
- _ -> panic "cgOpApp"
f regs
pure $ map (CmmReg . CmmLocal) regs
=====================================
compiler/GHC/StgToCmm/TagCheck.hs
=====================================
@@ -133,10 +133,10 @@ emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode ()
emitArgTagCheck info marks args = whenCheckTags $ do
mod <- getModuleName
let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args
- arg_infos <- mapM getCgIdInfo cbv_args
- let arg_cmms = map idInfoToAmode arg_infos
- mk_msg arg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg)
- zipWithM_ emitTagAssertion (map mk_msg args) (arg_cmms)
+ forM_ cbv_args $ \arg -> do
+ cginfo <- getCgIdInfo arg
+ let msg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg)
+ emitTagAssertion msg (idInfoToAmode cginfo)
taggedCgInfo :: CgIdInfo -> Bool
taggedCgInfo cg_info
=====================================
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
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -563,8 +563,7 @@ isJoinId id
-- | Doesn't return strictness marks
idJoinPointHood :: Var -> JoinPointHood
idJoinPointHood id
- | isId id = assertPpr (isId id) (ppr id) $
- case Var.idDetails id of
+ | isId id = case Var.idDetails id of
JoinId arity _marks -> JoinPoint arity
_ -> NotJoinPoint
| otherwise = NotJoinPoint
=====================================
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,_)
=====================================
hadrian/src/Rules/Test.hs
=====================================
@@ -345,7 +345,6 @@ needTestsuitePackages stg = do
cross <- flag CrossCompiling
when (not cross) $ needIservBins stg
root <- buildRoot
- liftIO $ print stg
-- require the shims for testing stage1
when (stg == stage0InTree) $ do
-- Windows not supported as the wrapper scripts don't work on windows.. we could
=====================================
libraries/ghc-heap/cbits/Stack.c → libraries/ghc-heap/cbits/Stack_c.c
=====================================
=====================================
libraries/ghc-heap/ghc-heap.cabal.in
=====================================
@@ -31,7 +31,7 @@ library
if !os(ghcjs)
cmm-sources: cbits/HeapPrim.cmm
cbits/Stack.cmm
- c-sources: cbits/Stack.c
+ c-sources: cbits/Stack_c.c
default-extensions: NoImplicitPrelude
=====================================
linters/lint-codes/LintCodes/Coverage.hs
=====================================
@@ -26,7 +26,7 @@ getCoveredCodes =
-- Run git grep on .stdout and .stderr files in the testsuite subfolder.
do { codes <- lines
<$> readProcess "git"
- [ "grep", "-oh", codeRegex
+ [ "grep", "-Eoh", codeRegex
-- -oh: only show the match, and omit the filename.
, "--", ":/testsuite/*.stdout", ":/testsuite/*.stderr"
, ":!*/codes.stdout" -- Don't include the output of this test itself.
@@ -35,7 +35,7 @@ getCoveredCodes =
-- | Regular expression to parse a diagnostic code.
codeRegex :: String
-codeRegex = "\\[[A-Za-z]\\+-[0-9]\\+\\]"
+codeRegex = "\\[[A-Za-z]+-[0-9]+\\]"
-- | Turn a string that matches the 'codeRegex' regular expression
-- into its corresponding 'DiagnosticCode'.
=====================================
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'])
=====================================
testsuite/tests/rep-poly/T23903.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE GHC2021, AllowAmbiguousTypes, DataKinds, MagicHash, TypeFamilies #-}
+module T23903 where
+
+import Data.Kind(Type)
+import GHC.Exts(Float#, Int#, RuntimeRep(FloatRep, IntRep), TYPE)
+
+type Rep :: Type -> RuntimeRep
+type family Rep t where
+ Rep Int = IntRep
+ Rep Float = FloatRep
+
+type Unbox :: forall (t :: Type) -> TYPE (Rep t)
+type family Unbox t where
+ Unbox Int = Int#
+ Unbox Float = Float#
+
+type family a #-> b where
+ a #-> b = Unbox a -> b
+
+f :: a #-> ()
+f _ = ()
=====================================
testsuite/tests/rep-poly/T23903.stderr
=====================================
@@ -0,0 +1,10 @@
+
+T23903.hs:21:1: error: [GHC-55287]
+ • The first pattern in the equation for ‘f’
+ does not have a fixed runtime representation.
+ Its type is:
+ p0 :: TYPE c0
+ Cannot unify ‘Rep a’ with the type variable ‘c0’
+ because the former is not a concrete ‘RuntimeRep’.
+ • The equation for ‘f’ has one value argument,
+ but its type ‘a #-> ()’ has none
=====================================
testsuite/tests/rep-poly/all.T
=====================================
@@ -36,6 +36,7 @@ test('T23051', normal, compile_fail, [''])
test('T23153', normal, compile_fail, [''])
test('T23154', normal, compile_fail, [''])
test('T23176', normal, compile_fail, ['-XPartialTypeSignatures -fdefer-out-of-scope-variables'])
+test('T23903', normal, compile_fail, [''])
test('EtaExpandDataCon', normal, compile, ['-O'])
test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/467847d5ea7e9fecbf6acf301652d5141a432687...e3cde906bcc5860f51faaf0a6962c74404ac00ec
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/467847d5ea7e9fecbf6acf301652d5141a432687...e3cde906bcc5860f51faaf0a6962c74404ac00ec
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/467aedc6/attachment-0001.html>
More information about the ghc-commits
mailing list