[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