[Git][ghc/ghc][wip/ghc-9.10] 13 commits: ghcup-metadata: Drop output_name field
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Wed May 8 05:02:18 UTC 2024
Ben Gamari pushed to branch wip/ghc-9.10 at Glasgow Haskell Compiler / GHC
Commits:
29ed876b by Ben Gamari at 2024-04-27T13:12:45-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.
- - - - -
1fb2344c by Alan Zimmerman at 2024-05-08T00:51:18-04:00
EPA: check-exact: check that the roundtrip reproduces the source
Closes #24670
(cherry picked from commit 981c2c2c5017cb7ae47babff4d2163324d7cbde6)
- - - - -
6f94f24a by Alan Zimmerman at 2024-05-08T00:52:01-04:00
EPA: Preserve comments in Match Pats
Closes #24708
Closes #24715
Closes #24734
(cherry picked from commit 1c2fd963d6fd78d1c752a21348c7db85f5d64df2)
- - - - -
da909f2c by Alan Zimmerman at 2024-05-08T00:52:25-04:00
EPA: Preserve comments for PrefixCon
Preserve comments in
fun (Con {- c1 -} a b)
= undefined
Closes #24736
(cherry picked from commit 40026ac30fcdbe84a551f445f5e20691c0527ded)
- - - - -
39faadee by Alan Zimmerman at 2024-05-08T00:53:39-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)
- - - - -
3658bbf2 by Alan Zimmerman at 2024-05-08T00:55:20-04:00
EPA: preserve comments in class and data decls
Fix checkTyClHdr which was discarding comments.
Closes #24755
(cherry picked from commit 35d34fde62cd9e0002ac42f10bf705552f5c654e)
- - - - -
73dc0545 by Alan Zimmerman at 2024-05-08T00:55:44-04:00
EPA: fix mkHsOpTyPV duplicating comments
Closes #24753
(cherry picked from commit 18f4ff84b323236f6dfd07f3bbc2842308a01e91)
- - - - -
fad75913 by Alan Zimmerman at 2024-05-08T00:56:05-04:00
EPA: preserve comments in data decls
Closes #24771
(cherry picked from commit 46328a49d988143111ab530d7907b9426b58311a)
- - - - -
30de1399 by Simon Peyton Jones at 2024-05-08T00:56:17-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)
- - - - -
9149b5ce by Andrew Lelechenko at 2024-05-08T00:56:35-04:00
Document that setEnv is not thread-safe
(cherry picked from commit a86167471a7a471fb75ae9ba6c641bd1e74bc16d)
- - - - -
63748a90 by Matthew Pickering at 2024-05-08T00:56:48-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)
- - - - -
569105e8 by Hécate Moonlight at 2024-05-08T01:01:11-04:00
Correct `@since` metadata in HpcFlags
It was introduced in base-4.20, not 4.22.
Fix #24721
(cherry picked from commit 9213478931b18402998c18f5c4e6f0ee09054b18)
- - - - -
4b3314f5 by Teo Camarasu at 2024-05-08T01:01:19-04:00
doc: Fix type error in hs_try_putmvar example
(cherry picked from commit 06f7db4001e4eee0f3076d949876f8f4af0eb6fb)
- - - - -
24 changed files:
- .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- 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/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
=====================================
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,9 @@ 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('CaseAltComments', [ignore_stderr, req_ppr_deps], makefile_test, ['CaseAltComments'])
+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/ea3839f64bf5dfc8373734f18d766766b024c026...4b3314f59fa0f66ceface97e5e97668e5e59feaa
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea3839f64bf5dfc8373734f18d766766b024c026...4b3314f59fa0f66ceface97e5e97668e5e59feaa
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/71784acd/attachment-0001.html>
More information about the ghc-commits
mailing list