[Git][ghc/ghc][wip/az/T24736-epa-prefixcon-comments] 3 commits: testsuite: Handle exceptions in framework_fail when testdir is not initialised
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Wed May 1 07:43:52 UTC 2024
Alan Zimmerman pushed to branch wip/az/T24736-epa-prefixcon-comments at Glasgow Haskell Compiler / GHC
Commits:
c56d728e by Zubin Duggal at 2024-04-30T22:45:09-04:00
testsuite: Handle exceptions in framework_fail when testdir is not initialised
When `framework_fail` is called before initialising testdir, it would fail with
an exception reporting the testdir not being initialised instead of the actual failure.
Ensure we report the actual reason for the failure instead of failing in this way.
One way this can manifest is when trying to run a test that doesn't exist using `--only`
- - - - -
d5bea4d6 by Alan Zimmerman at 2024-04-30T22:45:45-04:00
EPA: Fix range for GADT decl with sig only
Closes #24714
- - - - -
144893b9 by Alan Zimmerman at 2024-05-01T08:43:12+01:00
EPA: Preserve comments for PrefixCon
Preserve comments in
fun (Con {- c1 -} a b)
= undefined
Closes #24736
- - - - -
8 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- testsuite/driver/testlib.py
- testsuite/tests/parser/should_compile/T20846.stderr
- + testsuite/tests/printer/DataDeclShort.hs
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/PrefixConComment.hs
- testsuite/tests/printer/all.T
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1303,7 +1303,7 @@ ty_decl :: { LTyClDecl GhcPs }
| type_data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
maybe_derivings
- {% mkTyData (comb4 $1 $3 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3
+ {% mkTyData (comb5 $1 $3 $4 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3
(snd $ unLoc $4) (snd $ unLoc $5)
(fmap reverse $6)
((fstOf3 $ unLoc $1)++(fst $ unLoc $4)++(fst $ unLoc $5)) }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1210,37 +1210,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 = do
- let (_l', loc') = transferCommentsOnlyA l loc
- return . L loc' $ ConPat
- { pat_con_ext = noAnn -- AZ: where should this come from?
- , pat_con = L ln c
- , pat_args = PrefixCon tyargs args
- }
+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 (L lf f) at t)) tyargs args = do
- let (loc', lf') = transferCommentsOnlyA loc lf
- checkPat loc' (L lf' f) (HsConPatTyArg at t : tyargs) args
-checkPat loc (L _ (PatBuilderApp f (L le e))) [] args = do
- let (loc', le') = transferCommentsOnlyA loc le
- p <- checkLPat (L le' e)
- checkPat loc' f [] (p : args)
-checkPat loc (L l e) [] [] = 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 (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)
@@ -1349,13 +1346,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
@@ -1364,7 +1361,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)]
=====================================
testsuite/driver/testlib.py
=====================================
@@ -1542,7 +1542,13 @@ def override_options(pre_cmd):
def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str) -> None:
opts = getTestOpts()
- directory = re.sub(r'^\.[/\\]', '', str(opts.testdir))
+ # framework_fail can be called before testdir is initialised,
+ # so we need to take care not to blow up with the wrong way
+ # and report the actual reason for the failure.
+ try:
+ directory = re.sub(r'^\.[/\\]', '', str(opts.testdir))
+ except:
+ directory = ''
full_name = '%s(%s)' % (name, way)
if_verbose(1, '*** framework failure for %s %s ' % (full_name, reason))
name2 = name if name is not None else TestName('none')
=====================================
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/DataDeclShort.hs
=====================================
@@ -0,0 +1,8 @@
+module DataDeclShort where
+
+data GenericOptions
+ :: fieldLabelModifier
+ -> tagSingleConstructors
+ -> Type
+
+x = 1
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -836,3 +836,8 @@ CaseAltComments:
MatchPatComments:
$(CHECK_PPR) $(LIBDIR) MatchPatComments.hs
$(CHECK_EXACT) $(LIBDIR) MatchPatComments.hs
+
+.PHONY: DataDeclShort
+DataDeclShort:
+ $(CHECK_PPR) $(LIBDIR) DataDeclShort.hs
+ $(CHECK_EXACT) $(LIBDIR) DataDeclShort.hs
=====================================
testsuite/tests/printer/PrefixConComment.hs
=====================================
@@ -0,0 +1,4 @@
+module PrefixConComment where
+
+fun (Con {- c1 -} a {- c2 -} b {- c3 -})
+ = undefined
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -200,3 +200,4 @@ 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('DataDeclShort', [ignore_stderr, req_ppr_deps], makefile_test, ['DataDeclShort'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1cb0245a9d0ec0e067b54342d831c3869a7323df...144893b946a3f12494450fc6297494d77bdb99f6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1cb0245a9d0ec0e067b54342d831c3869a7323df...144893b946a3f12494450fc6297494d77bdb99f6
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/20240501/7fe524c3/attachment-0001.html>
More information about the ghc-commits
mailing list