[Git][ghc/ghc][ghc-9.10] 15 commits: bindist: Fix xattr cleaning
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Wed May 8 22:03:59 UTC 2024
Ben Gamari pushed to branch ghc-9.10 at Glasgow Haskell Compiler / GHC
Commits:
b8c66bf3 by Rodrigo Mesquita at 2024-05-08T02:08:37-04:00
bindist: Fix xattr cleaning
The original fix (725343aa) was incorrect because it used the shell
bracket syntax which is the quoting syntax in autoconf, making the test
for existence be incorrect and therefore `xattr` was never run.
Fixes #24554
(cherry picked from commit e03760db6713068ad8ba953d2252ec12b3278c9b)
- - - - -
250c5df7 by Ben Gamari at 2024-05-08T02:08:37-04:00
ghcup-metadata: Drop output_name field
This is entirely redundant to the filename of the URL. There is no
compelling reason to name the downloaded file differently from its
source.
- - - - -
7b327164 by Alan Zimmerman at 2024-05-08T02:08:37-04:00
EPA: check-exact: check that the roundtrip reproduces the source
Closes #24670
(cherry picked from commit 981c2c2c5017cb7ae47babff4d2163324d7cbde6)
- - - - -
a8c27c7c by Alan Zimmerman at 2024-05-08T02:09:14-04:00
EPA: Preserve comments in Match Pats
Closes #24708
Closes #24715
Closes #24734
(cherry picked from commit 1c2fd963d6fd78d1c752a21348c7db85f5d64df2)
- - - - -
e8603c75 by Alan Zimmerman at 2024-05-08T02:09:27-04:00
EPA: Preserve comments for PrefixCon
Preserve comments in
fun (Con {- c1 -} a b)
= undefined
Closes #24736
(cherry picked from commit 40026ac30fcdbe84a551f445f5e20691c0527ded)
- - - - -
015a0430 by Alan Zimmerman at 2024-05-08T02:09:27-04:00
EPA: fix span for empty \case(s)
In
instance SDecide Nat where
SZero %~ (SSucc _) = Disproved (\case)
Ensure the span for the HsLam covers the full construct.
Closes #24748
(cherry picked from commit 167a56a003106ed84742e3970cc2189ffb98b0c7)
- - - - -
c5a65a7f by Alan Zimmerman at 2024-05-08T02:09:27-04:00
EPA: preserve comments in class and data decls
Fix checkTyClHdr which was discarding comments.
Closes #24755
(cherry picked from commit 35d34fde62cd9e0002ac42f10bf705552f5c654e)
- - - - -
43a7dc68 by Alan Zimmerman at 2024-05-08T02:09:27-04:00
EPA: fix mkHsOpTyPV duplicating comments
Closes #24753
(cherry picked from commit 18f4ff84b323236f6dfd07f3bbc2842308a01e91)
- - - - -
01eeecec by Alan Zimmerman at 2024-05-08T02:09:27-04:00
EPA: preserve comments in data decls
Closes #24771
(cherry picked from commit 46328a49d988143111ab530d7907b9426b58311a)
- - - - -
2c7a0cf7 by Simon Peyton Jones at 2024-05-08T02:09:27-04:00
Track in-scope variables in ruleCheckProgram
This small patch fixes #24726, by tracking in-scope variables
properly in -drule-check. Not hard to do!
(cherry picked from commit be1e60eec0ec37da41643af17d78c698ab2a7083)
- - - - -
4896c50b by Andrew Lelechenko at 2024-05-08T02:09:27-04:00
Document that setEnv is not thread-safe
(cherry picked from commit a86167471a7a471fb75ae9ba6c641bd1e74bc16d)
- - - - -
843f95b1 by Matthew Pickering at 2024-05-08T02:09:27-04:00
Don't depend on registerPackage function in Cabal
More recent versions of Cabal modify the behaviour of libAbiHash which
breaks our usage of registerPackage.
It is simpler to inline the part of registerPackage that we need and
avoid any additional dependency and complication using the higher-level
function introduces.
(cherry picked from commit 3fff09779d5830549ae455a15907b7bb9fe7859a)
- - - - -
720ff1f9 by Hécate Moonlight at 2024-05-08T02:09:27-04:00
Correct `@since` metadata in HpcFlags
It was introduced in base-4.20, not 4.22.
Fix #24721
(cherry picked from commit 9213478931b18402998c18f5c4e6f0ee09054b18)
- - - - -
7f9b05a8 by Teo Camarasu at 2024-05-08T02:09:27-04:00
doc: Fix type error in hs_try_putmvar example
(cherry picked from commit 06f7db4001e4eee0f3076d949876f8f4af0eb6fb)
- - - - -
d5f45368 by Cheng Shao at 2024-05-08T09:39:29+01:00
driver: always merge objects when possible
This patch makes the driver always merge objects with `ld -r` when
possible, and only fall back to calling `ar -L` when merge objects
command is unavailable. This completely reverts !8887 and !12313,
given more fixes in Cabal seems to be needed to avoid breaking certain
configurations and the maintainence cost is exceeding the behefits in
this case :/
(cherry picked from commit 631cefec222e2db951c58db0b15a8d80ef5549cb)
- - - - -
26 changed files:
- .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- distrib/configure.ac.in
- docs/users_guide/exts/ffi.rst
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
- libraries/ghc-internal/src/GHC/Internal/System/Environment.hs
- libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc
- testsuite/tests/parser/should_compile/T20846.stderr
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/MatchPatComments.hs
- testsuite/tests/printer/PprExportWarn.hs
- + testsuite/tests/printer/PrefixConComment.hs
- + testsuite/tests/printer/Test24748.hs
- + testsuite/tests/printer/Test24753.hs
- + testsuite/tests/printer/Test24755.hs
- + testsuite/tests/printer/Test24771.hs
- testsuite/tests/printer/all.T
- + testsuite/tests/simplCore/should_compile/T24726.hs
- + testsuite/tests/simplCore/should_compile/T24726.stderr
- testsuite/tests/simplCore/should_compile/all.T
- utils/check-exact/Main.hs
Changes:
=====================================
.gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
=====================================
@@ -65,7 +65,6 @@ eprint(f"Supported platforms: {job_mapping.keys()}")
class Artifact(NamedTuple):
job_name: str
download_name: str
- output_name: str
subdir: str
# Platform spec provides a specification which is agnostic to Job
@@ -75,11 +74,9 @@ class PlatformSpec(NamedTuple):
subdir: str
source_artifact = Artifact('source-tarball'
- , 'ghc-{version}-src.tar.xz'
, 'ghc-{version}-src.tar.xz'
, 'ghc-{version}' )
test_artifact = Artifact('source-tarball'
- , 'ghc-{version}-testsuite.tar.xz'
, 'ghc-{version}-testsuite.tar.xz'
, 'ghc-{version}/testsuite' )
@@ -164,11 +161,6 @@ def mk_one_metadata(release_mode, version, job_map, artifact):
, "dlSubdir": artifact.subdir.format(version=version)
, "dlHash" : h }
- # Only add dlOutput if it is inconsistent with the filename inferred from the URL
- output = artifact.output_name.format(version=version)
- if Path(urlparse(final_url).path).name != output:
- res["dlOutput"] = output
-
eprint(res)
return res
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -47,7 +47,7 @@ import GHC.Driver.Ppr( showSDoc )
import GHC.Core -- All of it
import GHC.Core.Subst
import GHC.Core.SimpleOpt ( exprIsLambda_maybe )
-import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars
+import GHC.Core.FVs ( exprFreeVars, bindFreeVars
, rulesFreeVarsDSet, exprsOrphNames )
import GHC.Core.Utils ( exprType, mkTick, mkTicks
, stripTicksTopT, stripTicksTopE
@@ -1887,41 +1887,59 @@ ruleCheckProgram ropts phase rule_pat rules binds
vcat [ p $$ line | p <- bagToList results ]
]
where
+ line = text (replicate 20 '-')
env = RuleCheckEnv { rc_is_active = isActive phase
, rc_id_unf = idUnfolding -- Not quite right
-- Should use activeUnfolding
, rc_pattern = rule_pat
, rc_rules = rules
, rc_ropts = ropts
- }
- results = unionManyBags (map (ruleCheckBind env) binds)
- line = text (replicate 20 '-')
+ , rc_in_scope = emptyInScopeSet }
+
+ results = go env binds
+
+ go _ [] = emptyBag
+ go env (bind:binds) = let (env', ds) = ruleCheckBind env bind
+ in ds `unionBags` go env' binds
+
+data RuleCheckEnv = RuleCheckEnv
+ { rc_is_active :: Activation -> Bool
+ , rc_id_unf :: IdUnfoldingFun
+ , rc_pattern :: String
+ , rc_rules :: Id -> [CoreRule]
+ , rc_ropts :: RuleOpts
+ , rc_in_scope :: InScopeSet }
+
+extendInScopeRC :: RuleCheckEnv -> Var -> RuleCheckEnv
+extendInScopeRC env@(RuleCheckEnv { rc_in_scope = in_scope }) v
+ = env { rc_in_scope = in_scope `extendInScopeSet` v }
-data RuleCheckEnv = RuleCheckEnv {
- rc_is_active :: Activation -> Bool,
- rc_id_unf :: IdUnfoldingFun,
- rc_pattern :: String,
- rc_rules :: Id -> [CoreRule],
- rc_ropts :: RuleOpts
-}
+extendInScopeListRC :: RuleCheckEnv -> [Var] -> RuleCheckEnv
+extendInScopeListRC env@(RuleCheckEnv { rc_in_scope = in_scope }) vs
+ = env { rc_in_scope = in_scope `extendInScopeSetList` vs }
-ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
+ruleCheckBind :: RuleCheckEnv -> CoreBind -> (RuleCheckEnv, Bag SDoc)
-- The Bag returned has one SDoc for each call site found
-ruleCheckBind env (NonRec _ r) = ruleCheck env r
-ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs]
+ruleCheckBind env (NonRec b r) = (env `extendInScopeRC` b, ruleCheck env r)
+ruleCheckBind env (Rec prs) = (env', unionManyBags (map (ruleCheck env') rhss))
+ where
+ (bs, rhss) = unzip prs
+ env' = env `extendInScopeListRC` bs
ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc
-ruleCheck _ (Var _) = emptyBag
-ruleCheck _ (Lit _) = emptyBag
-ruleCheck _ (Type _) = emptyBag
-ruleCheck _ (Coercion _) = emptyBag
-ruleCheck env (App f a) = ruleCheckApp env (App f a) []
-ruleCheck env (Tick _ e) = ruleCheck env e
-ruleCheck env (Cast e _) = ruleCheck env e
-ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e
-ruleCheck env (Lam _ e) = ruleCheck env e
-ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`
- unionManyBags [ruleCheck env r | Alt _ _ r <- as]
+ruleCheck _ (Var _) = emptyBag
+ruleCheck _ (Lit _) = emptyBag
+ruleCheck _ (Type _) = emptyBag
+ruleCheck _ (Coercion _) = emptyBag
+ruleCheck env (App f a) = ruleCheckApp env (App f a) []
+ruleCheck env (Tick _ e) = ruleCheck env e
+ruleCheck env (Cast e _) = ruleCheck env e
+ruleCheck env (Let bd e) = let (env', ds) = ruleCheckBind env bd
+ in ds `unionBags` ruleCheck env' e
+ruleCheck env (Lam b e) = ruleCheck (env `extendInScopeRC` b) e
+ruleCheck env (Case e b _ as) = ruleCheck env e `unionBags`
+ unionManyBags [ruleCheck (env `extendInScopeListRC` (b:bs)) r
+ | Alt _ bs r <- as]
ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc
ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)
@@ -1945,8 +1963,9 @@ ruleAppCheck_help env fn args rules
vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
vcat (map check_rule rules)]
where
- n_args = length args
- i_args = args `zip` [1::Int ..]
+ in_scope = rc_in_scope env
+ n_args = length args
+ i_args = args `zip` [1::Int ..]
rough_args = map roughTopName args
check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule
@@ -1976,10 +1995,8 @@ ruleAppCheck_help env fn args rules
mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,
not (isJust (match_fn rule_arg arg))]
- lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars
match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl
where
- in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)
renv = RV { rv_lcl = mkRnEnv2 in_scope
, rv_tmpls = mkVarSet rule_bndrs
, rv_fltR = mkEmptySubst in_scope
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -1040,13 +1040,17 @@ this is accomplished with the `ld -r` command. We rely on this for two ends:
The command used for object linking is set using the -pgmlm and -optlm
command-line options.
-Sadly, the LLD linker that we use on Windows does not support the `-r` flag
-needed to support object merging (see #21068). For this reason on Windows we do
-not support GHCi objects. To deal with foreign stubs we build a static archive
-of all of a module's object files instead merging them. Consequently, we can
-end up producing `.o` files which are in fact static archives. However,
-toolchains generally don't have a problem with this as they use file headers,
-not the filename, to determine the nature of inputs.
+However, `ld -r` is broken in some cases:
+
+ * The LLD linker that we use on Windows does not support the `-r`
+ flag needed to support object merging (see #21068). For this reason
+ on Windows we do not support GHCi objects.
+
+In these cases, we bundle a module's own object file with its foreign
+stub's object file, instead of merging them. Consequently, we can end
+up producing `.o` files which are in fact static archives. This can
+only work if `ar -L` is supported, so the archive `.o` files can be
+properly added to the final static library.
Note that this has somewhat non-obvious consequences when producing
initializers and finalizers. See Note [Initializers and finalizers in Cmm]
@@ -1072,7 +1076,7 @@ via gcc.
-- | See Note [Object merging].
joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO ()
joinObjectFiles hsc_env o_files output_fn
- | can_merge_objs && not dashLSupported = do
+ | can_merge_objs = do
let toolSettings' = toolSettings dflags
ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2486,9 +2486,8 @@ forall :: { Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }
| {- empty -} { noLoc ([], Nothing) }
constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }
- : infixtype {% fmap (reLoc. (fmap (\b -> (dataConBuilderCon b,
- dataConBuilderDetails b))))
- (runPV $1) }
+ : infixtype {% do { b <- runPV $1
+ ; return (sL1 b (dataConBuilderCon b, dataConBuilderDetails b)) }}
| '(#' usum_constr '#)' {% let (t, tag, arity) = $2 in pure (sLL $1 $3 $ mkUnboxedSumCon t tag arity)}
usum_constr :: { (LHsType GhcPs, Int, Int) } -- constructor for the data decls SumN#
@@ -2900,10 +2899,10 @@ aexp :: { ECP }
[mj AnnLam $1] }
| '\\' 'lcase' altslist(pats1)
{ ECP $ $3 >>= \ $3 ->
- mkHsLamPV (comb2 $1 $>) LamCase $3 [mj AnnLam $1,mj AnnCase $2] }
+ mkHsLamPV (comb3 $1 $2 $>) LamCase $3 [mj AnnLam $1,mj AnnCase $2] }
| '\\' 'lcases' altslist(argpats)
{ ECP $ $3 >>= \ $3 ->
- mkHsLamPV (comb2 $1 $>) LamCases $3 [mj AnnLam $1,mj AnnCases $2] }
+ mkHsLamPV (comb3 $1 $2 $>) LamCases $3 [mj AnnLam $1,mj AnnCases $2] }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
{% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
return $ ECP $
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -1244,7 +1244,7 @@ transferAnnsOnlyA (EpAnn a an cs) (EpAnn a' an' cs')
-- | Transfer comments from the annotations in the
-- first 'SrcSpanAnnA' argument to those in the second.
-transferCommentsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+transferCommentsOnlyA :: EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
transferCommentsOnlyA (EpAnn a an cs) (EpAnn a' an' cs')
= (EpAnn a an emptyComments, EpAnn a' an' (cs <> cs'))
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -205,11 +205,11 @@ mkClassDecl :: SrcSpan
-> P (LTyClDecl GhcPs)
mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn
- = do { let loc = noAnnSrcSpan loc'
- ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
- ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
+ = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
+ ; (cls, tparams, fixity, ann, cs) <- checkTyClHdr True tycl_hdr
; tyvars <- checkTyVars (text "class") whereDots cls tparams
; let anns' = annsIn Semi.<> ann
+ ; let loc = EpAnn (spanAsAnchor loc') noAnn cs
; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey)
, tcdCtxt = mcxt
, tcdLName = cls, tcdTyVars = tyvars
@@ -232,12 +232,13 @@ mkTyData :: SrcSpan
-> P (LTyClDecl GhcPs)
mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
ksig data_cons (L _ maybe_deriv) annsIn
- = do { let loc = noAnnSrcSpan loc'
- ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; let anns' = annsIn Semi.<> ann
- ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons
+ ; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
+ ; !cs' <- getCommentsFor loc'
+ ; let loc = EpAnn (spanAsAnchor loc') noAnn (cs' Semi.<> cs)
; return (L loc (DataDecl { tcdDExt = anns',
tcdLName = tc, tcdTyVars = tyvars,
tcdFixity = fixity,
@@ -264,14 +265,14 @@ mkTySynonym :: SrcSpan
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkTySynonym loc lhs rhs annsIn
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
; tyvars <- checkTyVars (text "type") equalsDots tc tparams
; let anns' = annsIn Semi.<> ann
- ; return (L (noAnnSrcSpan loc) (SynDecl
- { tcdSExt = anns'
- , tcdLName = tc, tcdTyVars = tyvars
- , tcdFixity = fixity
- , tcdRhs = rhs })) }
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' (SynDecl { tcdSExt = anns'
+ , tcdLName = tc, tcdTyVars = tyvars
+ , tcdFixity = fixity
+ , tcdRhs = rhs })) }
mkStandaloneKindSig
:: SrcSpan
@@ -304,8 +305,9 @@ mkTyFamInstEqn :: SrcSpan
-> [AddEpAnn]
-> P (LTyFamInstEqn GhcPs)
mkTyFamInstEqn loc bndrs lhs rhs anns
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
- ; return (L (noAnnSrcSpan loc) $ FamEqn
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' $ FamEqn
{ feqn_ext = anns `mappend` ann
, feqn_tycon = tc
, feqn_bndrs = bndrs
@@ -325,10 +327,11 @@ mkDataFamInst :: SrcSpan
-> P (LInstDecl GhcPs)
mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
ksig data_cons (L _ maybe_deriv) anns
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
- ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' (DataFamInstD noExtField (DataFamInstDecl
(FamEqn { feqn_ext = ann Semi.<> anns
, feqn_tycon = tc
, feqn_bndrs = bndrs
@@ -369,10 +372,10 @@ mkFamDecl :: SrcSpan
-> [AddEpAnn]
-> P (LTyClDecl GhcPs)
mkFamDecl loc info topLevel lhs ksig injAnn annsIn
- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
+ = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams
- ; return (L (noAnnSrcSpan loc) (FamDecl noExtField
- (FamilyDecl
+ ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+ ; return (L loc' (FamDecl noExtField (FamilyDecl
{ fdExt = annsIn Semi.<> ann
, fdTopLevel = topLevel
, fdInfo = info, fdLName = tc
@@ -1041,45 +1044,46 @@ checkTyClHdr :: Bool -- True <=> class header
-> P (LocatedN RdrName, -- the head symbol (type or class name)
[LHsTypeArg GhcPs], -- parameters of head symbol
LexicalFixity, -- the declaration is in infix format
- [AddEpAnn]) -- API Annotation for HsParTy
+ [AddEpAnn], -- API Annotation for HsParTy
-- when stripping parens
+ EpAnnComments) -- Accumulated comments from re-arranging
-- Well-formedness check and decomposition of type and class heads.
-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn])
-- Int :*: Bool into (:*:, [Int, Bool])
-- returning the pieces
checkTyClHdr is_cls ty
- = goL ty [] [] [] Prefix
+ = goL emptyComments ty [] [] [] Prefix
where
- goL (L l ty) acc ops cps fix = go l ty acc ops cps fix
+ goL cs (L l ty) acc ops cps fix = go cs l ty acc ops cps fix
-- workaround to define '*' despite StarIsType
- go ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
+ go cs ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
= do { addPsMessage (locA l) PsWarnStarBinder
; let name = mkOccNameFS tcClsName (starSym isUni)
; let a' = newAnns ll l an
; return (L a' (Unqual name), acc, fix
- , (reverse ops') ++ cps') }
+ , (reverse ops') ++ cps', cs) }
- go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
- | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps)
- go _ (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
- | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps)
+ go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
+ | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps, cs Semi.<> comments l)
+ go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
+ | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps, cs Semi.<> comments l)
where lhs = HsValArg noExtField t1
rhs = HsValArg noExtField t2
- go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix
+ go cs l (HsParTy _ ty) acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix
where
(o,c) = mkParensEpAnn (realSrcSpan (locA l))
- go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg noExtField t2:acc) ops cps fix
- go _ (HsAppKindTy at ty ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix
- go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
+ go cs l (HsAppTy _ t1 t2) acc ops cps fix = goL (cs Semi.<> comments l) t1 (HsValArg noExtField t2:acc) ops cps fix
+ go cs l (HsAppKindTy at ty ki) acc ops cps fix = goL (cs Semi.<> comments l) ty (HsTypeArg at ki:acc) ops cps fix
+ go cs l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
= return (L (l2l l) (nameRdrName tup_name)
- , map (HsValArg noExtField) ts, fix, (reverse ops)++cps)
+ , map (HsValArg noExtField) ts, fix, (reverse ops)++cps, cs Semi.<> comments l)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
| otherwise = getName (tupleTyCon Boxed arity)
-- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?)
- go l _ _ _ _ _
+ go _ l _ _ _ _ _
= addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
(PsErrMalformedTyOrClDecl ty)
@@ -1211,33 +1215,34 @@ checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (L
checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)
checkLArgPat :: LocatedA (ArgPatBuilder GhcPs) -> PV (LPat GhcPs)
-checkLArgPat (L l (ArgPatBuilderVisPat p))
- = checkPat l (L l p) [] []
+checkLArgPat (L l (ArgPatBuilderVisPat p)) = checkLPat (L l p)
checkLArgPat (L l (ArgPatBuilderArgPat p)) = return (L l p)
checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
-checkLPat e@(L l _) = checkPat l e [] []
-
-checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]
- -> PV (LPat GhcPs)
-checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
- | isRdrDataCon c = return . L loc $ ConPat
+checkLPat (L l@(EpAnn anc an _) p) = do
+ (L l' p', cs) <- checkPat (EpAnn anc an emptyComments) emptyComments (L l p) [] []
+ return (L (addCommentsToEpAnn l' cs) p')
+
+checkPat :: SrcSpanAnnA -> EpAnnComments -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]
+ -> PV (LPat GhcPs, EpAnnComments)
+checkPat loc cs (L l e@(PatBuilderVar (L ln c))) tyargs args
+ | isRdrDataCon c = return (L loc $ ConPat
{ pat_con_ext = noAnn -- AZ: where should this come from?
, pat_con = L ln c
, pat_args = PrefixCon tyargs args
- }
+ }, comments l Semi.<> cs)
| (not (null args) && patIsRec c) = do
ctx <- askParseContext
patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx
-checkPat loc (L _ (PatBuilderAppType f at t)) tyargs args =
- checkPat loc f (HsConPatTyArg at t : tyargs) args
-checkPat loc (L _ (PatBuilderApp f e)) [] args = do
+checkPat loc cs (L la (PatBuilderAppType f at t)) tyargs args =
+ checkPat loc (cs Semi.<> comments la) f (HsConPatTyArg at t : tyargs) args
+checkPat loc cs (L la (PatBuilderApp f e)) [] args = do
p <- checkLPat e
- checkPat loc f [] (p : args)
-checkPat loc (L l e) [] [] = do
+ checkPat loc (cs Semi.<> comments la) f [] (p : args)
+checkPat loc cs (L l e) [] [] = do
p <- checkAPat loc e
- return (L l p)
-checkPat loc e _ _ = do
+ return (L l p, cs)
+checkPat loc _ e _ _ = do
details <- fromParseContext <$> askParseContext
patFail (locA loc) (PsErrInPat (unLoc e) details)
@@ -1346,13 +1351,13 @@ checkFunBind :: SrcStrictness
-> [LocatedA (ArgPatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBind GhcPs)
-checkFunBind strictness locF ann fun is_infix pats (L _ grhss)
+checkFunBind strictness locF ann (L lf fun) is_infix pats (L _ grhss)
= do ps <- runPV_details extraDetails (mapM checkLArgPat pats)
let match_span = noAnnSrcSpan $ locF
- return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span)
+ return (makeFunBind (L (l2l lf) fun) (L (noAnnSrcSpan $ locA match_span)
[L match_span (Match { m_ext = ann
, m_ctxt = FunRhs
- { mc_fun = fun
+ { mc_fun = L lf fun
, mc_fixity = is_infix
, mc_strictness = strictness }
, m_pats = ps
@@ -1361,7 +1366,7 @@ checkFunBind strictness locF ann fun is_infix pats (L _ grhss)
-- That isn't quite right, but it'll do for now.
where
extraDetails
- | Infix <- is_infix = ParseContext (Just $ unLoc fun) NoIncompleteDoBlock
+ | Infix <- is_infix = ParseContext (Just fun) NoIncompleteDoBlock
| otherwise = noParseContext
makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
@@ -1433,20 +1438,27 @@ isFunLhs e = go e [] [] []
where
mk = fmap ArgPatBuilderVisPat
- go (L _ (PatBuilderVar (L loc f))) es ops cps
- | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, (reverse ops) ++ cps))
- go (L _ (PatBuilderApp f e)) es ops cps = go f (mk e:es) ops cps
- go (L l (PatBuilderPar _ e _)) es@(_:_) ops cps = go e es (o:ops) (c:cps)
+ go (L l (PatBuilderVar (L loc f))) es ops cps
+ | not (isRdrDataCon f) = do
+ let (_l, loc') = transferCommentsOnlyA l loc
+ return (Just (L loc' f, Prefix, es, (reverse ops) ++ cps))
+ go (L l (PatBuilderApp (L lf f) e)) es ops cps = do
+ let (_l, lf') = transferCommentsOnlyA l lf
+ go (L lf' f) (mk e:es) ops cps
+ go (L l (PatBuilderPar _ (L le e) _)) es@(_:_) ops cps = go (L le' e) es (o:ops) (c:cps)
-- NB: es@(_:_) means that there must be an arg after the parens for the
-- LHS to be a function LHS. This corresponds to the Haskell Report's definition
-- of funlhs.
where
+ (_l, le') = transferCommentsOnlyA l le
(o,c) = mkParensEpAnn (realSrcSpan $ locA l)
- go (L loc (PatBuilderOpApp l (L loc' op) r anns)) es ops cps
+ go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r anns)) es ops cps
| not (isRdrDataCon op) -- We have found the function!
- = return (Just (L loc' op, Infix, (mk l:mk r:es), (anns ++ reverse ops ++ cps)))
+ = do { let (_l, ll') = transferCommentsOnlyA loc ll
+ ; return (Just (L loc' op, Infix, (mk (L ll' l):mk r:es), (anns ++ reverse ops ++ cps))) }
| otherwise -- Infix data con; keep going
- = do { mb_l <- go l es ops cps
+ = do { let (_l, ll') = transferCommentsOnlyA loc ll
+ ; mb_l <- go (L ll' l) es ops cps
; return (reassociate =<< mb_l) }
where
reassociate (op', Infix, j : L k_loc (ArgPatBuilderVisPat k) : es', anns')
@@ -1455,12 +1467,13 @@ isFunLhs e = go e [] [] []
op_app = mk $ L loc (PatBuilderOpApp (L k_loc k)
(L loc' op) r (reverse ops ++ cps))
reassociate _other = Nothing
- go (L _ (PatBuilderAppType pat tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps
- = go pat (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps
+ go (L l (PatBuilderAppType (L lp pat) tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps
+ = go (L lp' pat) (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps
where invis_pat = InvisPat tok ty_pat
anc' = case tok of
NoEpTok -> anc
EpTok l -> widenAnchor anc [AddEpAnn AnnAnyclass l]
+ (_l, lp') = transferCommentsOnlyA l lp
go _ _ _ _ = return Nothing
data ArgPatBuilder p
@@ -2048,28 +2061,32 @@ instance DisambTD (HsType GhcPs) where
mkHsAppTyHeadPV = return
mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)
mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki)
- mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2)
+ mkHsOpTyPV prom t1 op t2 = do
+ let (L l ty) = mkLHsOpTy prom t1 op t2
+ !cs <- getCommentsFor (locA l)
+ return (L (addCommentsToEpAnn l cs) ty)
mkUnpackednessPV = addUnpackednessP
-dataConBuilderCon :: DataConBuilder -> LocatedN RdrName
-dataConBuilderCon (PrefixDataConBuilder _ dc) = dc
-dataConBuilderCon (InfixDataConBuilder _ dc _) = dc
+dataConBuilderCon :: LocatedA DataConBuilder -> LocatedN RdrName
+dataConBuilderCon (L _ (PrefixDataConBuilder _ dc)) = dc
+dataConBuilderCon (L _ (InfixDataConBuilder _ dc _)) = dc
-dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs
+dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs
-- Detect when the record syntax is used:
-- data T = MkT { ... }
-dataConBuilderDetails (PrefixDataConBuilder flds _)
+dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
| [L (EpAnn anc _ cs) (HsRecTy an fields)] <- toList flds
= RecCon (L (EpAnn anc an cs) fields)
-- Normal prefix constructor, e.g. data T = MkT A B C
-dataConBuilderDetails (PrefixDataConBuilder flds _)
+dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
= PrefixCon noTypeArgs (map hsLinear (toList flds))
-- Infix constructor, e.g. data T = Int :! Bool
-dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)
- = InfixCon (hsLinear lhs) (hsLinear rhs)
+dataConBuilderDetails (L (EpAnn _ _ csl) (InfixDataConBuilder (L (EpAnn anc ann csll) lhs) _ rhs))
+ = InfixCon (hsLinear (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsLinear rhs)
+
instance DisambTD DataConBuilder where
mkHsAppTyHeadPV = tyToDataConBuilder
@@ -2090,8 +2107,9 @@ instance DisambTD DataConBuilder where
mkHsOpTyPV prom lhs tc rhs = do
check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative
data_con <- eitherToP $ tyConToDataCon tc
+ !cs <- getCommentsFor (locA l)
checkNotPromotedDataCon prom data_con
- return $ L l (InfixDataConBuilder lhs data_con rhs)
+ return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)
where
l = combineLocsA lhs rhs
check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
@@ -3212,8 +3230,8 @@ mkSumOrTuplePat l Boxed a at Sum{} _ =
mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy prom x op y =
- let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y
- in L loc (mkHsOpTy prom x op y)
+ let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y
+ in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y)
mkMultTy :: EpToken "%" -> LHsType GhcPs -> EpUniToken "->" "→" -> HsArrow GhcPs
mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr
=====================================
distrib/configure.ac.in
=====================================
@@ -114,16 +114,16 @@ if test "$HostOS" = "darwin"; then
# The following is the work around suggested by @carter in #17418 during
# install time. This should help us with code signing issues by removing
# extended attributes from all files.
- XATTR=${XATTR:-/usr/bin/xattr}
+ XATTR="${XATTR:-/usr/bin/xattr}"
- if [ -e "${XATTR}" ]; then
+ if test -e "${XATTR}"; then
# Instead of cleaning the attributes of the ghc-toolchain binary only,
# we clean them from all files in the bin/ and lib/ directories, as it additionally future
# proofs running executables from the bindist besides ghc-toolchain at configure time, and
# we can avoid figuring out the path to the ghc-toolchain dynlib specifically.
- /usr/bin/xattr -rc bin/
- /usr/bin/xattr -rc lib/
+ "$XATTR" -rc bin/
+ "$XATTR" -rc lib/
fi
fi
=====================================
docs/users_guide/exts/ffi.rst
=====================================
@@ -998,7 +998,7 @@ the data. We can do it like this:
sp <- newStablePtrPrimMVar mvar
fp <- mallocForeignPtr
withForeignPtr fp $ \presult -> do
- cap <- threadCapability =<< myThreadId
+ (cap, _) <- threadCapability =<< myThreadId
scheduleCallback sp cap presult
takeMVar mvar `onException`
forkIO (do takeMVar mvar; touchForeignPtr fp)
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -31,6 +31,7 @@ import qualified Distribution.PackageDescription.Parsec as C
import qualified Distribution.Simple.Compiler as C
import qualified Distribution.Simple.Program.Db as C
import qualified Distribution.Simple as C
+import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.Program.Builtin as C
import qualified Distribution.Simple.Utils as C
import qualified Distribution.Simple.Program.Types as C
@@ -363,12 +364,11 @@ registerPackage rs context = do
need [setupConfig] -- This triggers 'configurePackage'
pd <- packageDescription <$> readContextData context
db_path <- packageDbPath (PackageDbLoc (stage context) (iplace context))
- dist_dir <- Context.buildPath context
pid <- pkgUnitId (stage context) (package context)
-- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path
-- from the local build info @lbi at .
lbi <- liftIO $ C.getPersistBuildConfig cPath
- liftIO $ register db_path pid dist_dir pd lbi
+ liftIO $ register db_path pid pd lbi
-- Then after the register, which just writes the .conf file, do the recache step.
buildWithResources rs $
target context (GhcPkg Recache (stage context)) [] []
@@ -377,25 +377,23 @@ registerPackage rs context = do
-- into a different package database to the one it was configured against.
register :: FilePath
-> String -- ^ Package Identifier
- -> FilePath
-> C.PackageDescription
-> LocalBuildInfo
-> IO ()
-register pkg_db pid build_dir pd lbi
+register pkg_db pid pd lbi
= withLibLBI pd lbi $ \lib clbi -> do
- absPackageDBs <- C.absolutePackageDBPaths packageDbs
- installedPkgInfo <- C.generateRegistrationInfo
- C.silent pd lib lbi clbi False reloc build_dir
- (C.registrationPackageDB absPackageDBs)
-
+ when reloc $ error "register does not support reloc"
+ installedPkgInfo <- generateRegistrationInfo pd lbi lib clbi
writeRegistrationFile installedPkgInfo
where
regFile = pkg_db </> pid <.> "conf"
reloc = relocatable lbi
- -- Using a specific package db here is why we have to copy the function from Cabal.
- packageDbs = [C.SpecificPackageDB pkg_db]
+
+ generateRegistrationInfo pkg lbi lib clbi = do
+ abi_hash <- C.mkAbiHash <$> GHC.libAbiHash C.silent pkg lbi lib clbi
+ return (C.absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi)
writeRegistrationFile installedPkgInfo = do
writeUTF8File regFile (CP.showInstalledPackageInfo installedPkgInfo)
=====================================
libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
=====================================
@@ -399,14 +399,14 @@ data ParFlags = ParFlags
-- | Parameters pertaining to Haskell program coverage (HPC)
--
--- @since base-4.22.0.0
+-- @since base-4.20.0.0
data HpcFlags = HpcFlags
{ writeTixFile :: Bool
-- ^ Controls whether the @<program>.tix@ file should be
-- written after the execution of the program.
}
- deriving (Show -- ^ @since base-4.22.0.0
- , Generic -- ^ @since base-4.22.0.0
+ deriving (Show -- ^ @since base-4.20.0.0
+ , Generic -- ^ @since base-4.20.0.0
)
-- | Parameters of the runtime system
--
=====================================
libraries/ghc-internal/src/GHC/Internal/System/Environment.hs
=====================================
@@ -225,6 +225,13 @@ ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv"
-- Throws `Control.Exception.IOException` if @name@ is the empty string or
-- contains an equals sign.
--
+-- Beware that this function must not be executed concurrently
+-- with 'getEnv', 'lookupEnv', 'getEnvironment' and such. One thread
+-- reading environment variables at the same time with another one modifying them
+-- can result in a segfault, see
+-- [Setenv is not Thread Safe](https://www.evanjones.ca/setenv-is-not-thread-safe.html)
+-- for discussion.
+--
-- @since base-4.7.0.0
setEnv :: String -> String -> IO ()
setEnv key_ value_
@@ -269,6 +276,13 @@ foreign import ccall unsafe "putenv" c_putenv :: CString -> IO CInt
-- Throws `Control.Exception.IOException` if @name@ is the empty string or
-- contains an equals sign.
--
+-- Beware that this function must not be executed concurrently
+-- with 'getEnv', 'lookupEnv', 'getEnvironment' and such. One thread
+-- reading environment variables at the same time with another one modifying them
+-- can result in a segfault, see
+-- [Setenv is not Thread Safe](https://www.evanjones.ca/setenv-is-not-thread-safe.html)
+-- for discussion.
+--
-- @since base-4.7.0.0
unsetEnv :: String -> IO ()
#if defined(mingw32_HOST_OS)
=====================================
libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc
=====================================
@@ -109,6 +109,13 @@ getEnvDefault name fallback = fromMaybe fallback <$> getEnv name
-- | Like 'GHC.Internal.System.Environment.setEnv', but allows blank environment values
-- and mimics the function signature of 'System.Posix.Env.setEnv' from the
-- @unix@ package.
+--
+-- Beware that this function must not be executed concurrently
+-- with 'getEnv', 'lookupEnv', 'getEnvironment' and such. One thread
+-- reading environment variables at the same time with another one modifying them
+-- can result in a segfault, see
+-- [Setenv is not Thread Safe](https://www.evanjones.ca/setenv-is-not-thread-safe.html)
+-- for discussion.
setEnv ::
String {- ^ variable name -} ->
String {- ^ variable value -} ->
@@ -151,6 +158,13 @@ foreign import ccall unsafe "setenv"
-- | Like 'GHC.Internal.System.Environment.unsetEnv', but allows for the removal of
-- blank environment variables. May throw an exception if the underlying
-- platform doesn't support unsetting of environment variables.
+--
+-- Beware that this function must not be executed concurrently
+-- with 'getEnv', 'lookupEnv', 'getEnvironment' and such. One thread
+-- reading environment variables at the same time with another one modifying them
+-- can result in a segfault, see
+-- [Setenv is not Thread Safe](https://www.evanjones.ca/setenv-is-not-thread-safe.html)
+-- for discussion.
unsetEnv :: String -> IO ()
#if defined(mingw32_HOST_OS)
unsetEnv key = withCWString key $ \k -> do
=====================================
testsuite/tests/parser/should_compile/T20846.stderr
=====================================
@@ -71,11 +71,7 @@
(L
(EpAnn
(EpaSpan { T20846.hs:4:1-6 })
- (NameAnn
- (NameParens)
- (EpaSpan { T20846.hs:4:1 })
- (EpaSpan { T20846.hs:4:2-5 })
- (EpaSpan { T20846.hs:4:6 })
+ (NameAnnTrailing
[])
(EpaComments
[]))
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -826,3 +826,33 @@ Test24533:
PprLetIn:
$(CHECK_PPR) $(LIBDIR) PprLetIn.hs
$(CHECK_EXACT) $(LIBDIR) PprLetIn.hs
+
+.PHONY: CaseAltComments
+CaseAltComments:
+ $(CHECK_PPR) $(LIBDIR) CaseAltComments.hs
+ $(CHECK_EXACT) $(LIBDIR) CaseAltComments.hs
+
+.PHONY: MatchPatComments
+MatchPatComments:
+ $(CHECK_PPR) $(LIBDIR) MatchPatComments.hs
+ $(CHECK_EXACT) $(LIBDIR) MatchPatComments.hs
+
+.PHONY: Test24748
+Test24748:
+ $(CHECK_PPR) $(LIBDIR) Test24748.hs
+ $(CHECK_EXACT) $(LIBDIR) Test24748.hs
+
+.PHONY: Test24755
+Test24755:
+ $(CHECK_PPR) $(LIBDIR) Test24755.hs
+ $(CHECK_EXACT) $(LIBDIR) Test24755.hs
+
+.PHONY: Test24753
+Test24753:
+ $(CHECK_PPR) $(LIBDIR) Test24753.hs
+ $(CHECK_EXACT) $(LIBDIR) Test24753.hs
+
+.PHONY: Test24771
+Test24771:
+ $(CHECK_PPR) $(LIBDIR) Test24771.hs
+ $(CHECK_EXACT) $(LIBDIR) Test24771.hs
=====================================
testsuite/tests/printer/MatchPatComments.hs
=====================================
@@ -0,0 +1,16 @@
+module MatchPatComments where
+
+expandProcess
+ outCHAs -- c0
+ locationDescr =
+ blah
+
+next
+ ( steps -- c1
+ , ys -- c2
+ ) x -- c3
+ = (steps, x, ys)
+
+makeProjection
+ Function{funMutual = VV, -- c4
+ funAbstr = ConcreteDef} = undefined
=====================================
testsuite/tests/printer/PprExportWarn.hs
=====================================
@@ -6,12 +6,12 @@ module PprExportWarning (
reallyreallyreallyreallyreallyreallyreallyreallylongname,
{-# DEPRECATED "Just because" #-} Bar(Bar1, Bar2),
{-# WARNING "Just because" #-} name,
- {-# DEPRECATED ["Reason",
- "Another reason"] #-}
+ {-# DEPRECATED ["Reason",
+ "Another reason"] #-}
Baz,
{-# DEPRECATED [ ] #-} module GHC,
{-# WARNING "Dummy Pattern" #-} pattern Dummy,
- Foo'(..),
+ Foo'(..),
reallyreallyreallyreallyreallyreallyreallyreallylongname',
Bar'(Bar1, Bar2), name', Baz', module Data.List, pattern Dummy'
) where
=====================================
testsuite/tests/printer/PrefixConComment.hs
=====================================
@@ -0,0 +1,4 @@
+module PrefixConComment where
+
+fun (Con {- c1 -} a {- c2 -} b {- c3 -})
+ = undefined
=====================================
testsuite/tests/printer/Test24748.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE LambdaCase #-}
+module Test24748 where
+
+instance SDecide Nat where
+ SZero %~ (SSucc _) = Disproved (\case)
+
+foo = (\case)
+bar = (\cases)
=====================================
testsuite/tests/printer/Test24753.hs
=====================================
@@ -0,0 +1,8 @@
+module Test24753 where
+
+type ErrorChoiceApi
+ = "path0" :> Get '[JSON] Int -- c0
+ :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- c4
+ :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- c5
+ :<|> "path5" :> (ReqBody '[JSON] Int :> Post '[PlainText] Int -- c6
+ :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- c7
=====================================
testsuite/tests/printer/Test24755.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+module Test24755 where
+
+class
+ a -- c1
+ :+ -- c2
+ b -- c3
=====================================
testsuite/tests/printer/Test24771.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+module Test24771 where
+
+data Foo
+ = Int -- c1
+ :* -- c2
+ String -- c3
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -198,3 +198,8 @@ test('ListTuplePuns', extra_files(['ListTuplePuns.hs']), ghci_script, ['ListTupl
test('AnnotationNoListTuplePuns', [ignore_stderr, req_ppr_deps], makefile_test, ['AnnotationNoListTuplePuns'])
test('Test24533', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24533'])
test('PprLetIn', [ignore_stderr, req_ppr_deps], makefile_test, ['PprLetIn'])
+test('MatchPatComments', [ignore_stderr, req_ppr_deps], makefile_test, ['MatchPatComments'])
+test('Test24748', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24748'])
+test('Test24755', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24755'])
+test('Test24753', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24753'])
+test('Test24771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24771'])
=====================================
testsuite/tests/simplCore/should_compile/T24726.hs
=====================================
@@ -0,0 +1,26 @@
+{-# OPTIONS_GHC -drule-check concatMap #-}
+ -- This rule-check thing crashed #24726
+
+module T24726 where
+
+data Stream a = forall s. Stream (s -> ()) s
+
+concatMapS :: (a -> Stream b) -> Stream a -> Stream b
+concatMapS f (Stream next0 s0) = Stream undefined undefined
+{-# INLINE [1] concatMapS #-}
+
+concatMapS' :: (s -> ()) -> (a -> s) -> Stream a -> Stream b
+concatMapS' = undefined
+
+{-# RULES "concatMap" forall step f. concatMapS (\x -> Stream step (f x)) = concatMapS' step f #-}
+
+replicateStep :: a -> b
+replicateStep _ = undefined
+{-# INLINE replicateStep #-}
+
+replicateS :: Int -> a -> Stream a
+replicateS n x0 = Stream replicateStep undefined
+{-# INLINE replicateS #-}
+
+foo1 :: Stream Int -> Stream Int
+foo1 = concatMapS (replicateS 2)
=====================================
testsuite/tests/simplCore/should_compile/T24726.stderr
=====================================
@@ -0,0 +1,36 @@
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
+
+==================== Rule check ====================
+Rule check results:
+--------------------
+Expression: concatMapS @(*) @Int @Int foo1
+Rule "concatMap": all arguments match (considered individually), but rule as a whole does not
+--------------------
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -515,3 +515,4 @@ test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typea
test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24370', normal, compile, ['-O'])
test('T24551', normal, compile, ['-O -dcore-lint'])
+test('T24726', normal, compile, ['-dcore-lint -dsuppress-uniques'])
=====================================
utils/check-exact/Main.hs
=====================================
@@ -128,7 +128,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Ppr034.hs" Nothing
-- "../../testsuite/tests/printer/Ppr035.hs" Nothing
-- "../../testsuite/tests/printer/Ppr036.hs" Nothing
- "../../testsuite/tests/printer/Ppr037.hs" Nothing
+ "../../testsuite/tests/printer/MatchPatComments.hs" Nothing
-- "../../testsuite/tests/printer/Ppr038.hs" Nothing
-- "../../testsuite/tests/printer/Ppr039.hs" Nothing
-- "../../testsuite/tests/printer/Ppr040.hs" Nothing
@@ -319,8 +319,10 @@ testOneFile _ libdir fileName mchanger = do
expectedSource <- readFile newFileExpected
changedSource <- readFile newFileChanged
return (expectedSource == changedSource, expectedSource, changedSource)
- Nothing -> return (True, "", "")
-
+ Nothing -> do
+ expectedSource <- readFile fileName
+ changedSource <- readFile newFile
+ return (expectedSource == changedSource, expectedSource, changedSource)
(p',_) <- parseOneFile libdir newFile
let newAstStr :: String
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c6375b9a804ac7fca1e82eb6fcfc8594c67c5f5...d5f453687549b700acf84a0cefed0efd7e274224
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c6375b9a804ac7fca1e82eb6fcfc8594c67c5f5...d5f453687549b700acf84a0cefed0efd7e274224
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/20240508/a0654b1d/attachment-0001.html>
More information about the ghc-commits
mailing list