Fix panic trying to -ddump-parsed-ast for implicit fixitywip/az/T20846

A declaration such as

    infixr ++++

is supplied with an implicit fixity of 9 in the parser, but uses
an invalid SrcSpan to capture this. Use of this span triggers a panic.

Fix the problem by not recording an exact print annotation for the
non-existent fixity source.

Closes #20846

7 files changed, 185 insertions, 8 deletions

diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index d768ef2d04..b7c2655f36 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1158,10 +1158,10 @@ impspec :: { Located (Bool, LocatedL [LIE GhcPs]) }
 -----------------------------------------------------------------------------
 -- Fixity Declarations
 
-prec    :: { Located (SourceText,Int) }
-        : {- empty -}           { noLoc (NoSourceText,9) }
+prec    :: { Maybe (Located (SourceText,Int)) }
+        : {- empty -}           { Nothing }
         | INTEGER
-                 { sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1))) }
+                 { Just (sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1)))) }
 
 infix   :: { Located FixityDirection }
         : 'infix'                               { sL1 $1 InfixN  }
@@ -2552,10 +2552,18 @@ sigdecl :: { LHsDecl GhcPs }
                  ; acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ SigD noExtField (sig cs) ) }}
 
         | infix prec ops
-              {% checkPrecP $2 $3 >>
-                 acsA (\cs -> sLL $1 $> $ SigD noExtField
-                        (FixSig (EpAnn (glR $1) [mj AnnInfix $1,mj AnnVal $2] cs) (FixitySig noExtField (fromOL $ unLoc $3)
-                                (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) }
+             {% do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 $3
+                                                      ; pure (mj AnnVal l2) })
+                                       $2
+                   ; let (fixText, fixPrec) = case $2 of
+                                                -- If an explicit precedence isn't supplied,
+                                                -- it defaults to maxPrecedence
+                                                Nothing -> (NoSourceText, maxPrecedence)
+                                                Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)
+                   ; acsA (\cs -> sLL $1 $> $ SigD noExtField
+                            (FixSig (EpAnn (glR $1) (mj AnnInfix $1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc $3)
+                                    (Fixity fixText fixPrec (unLoc $1)))))
+                   }}
 
         | pattern_synonym_sig   { sL1 $1 . SigD noExtField . unLoc $ $1 }
 
diff --git a/testsuite/tests/parser/should_compile/T20846.hs b/testsuite/tests/parser/should_compile/T20846.hs
new file mode 100644
index 0000000000..7d67ce73b4
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T20846.hs
@@ -0,0 +1,4 @@
+module T20846 where
+
+infixr ++++
+(++++) = undefined
diff --git a/testsuite/tests/parser/should_compile/T20846.stderr b/testsuite/tests/parser/should_compile/T20846.stderr
new file mode 100644
index 0000000000..f68526360d
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T20846.stderr
@@ -0,0 +1,155 @@
+
+==================== Parser AST ====================
+
+(L
+ { T20846.hs:1:1 }
+ (HsModule
+  (EpAnn
+   (Anchor
+    { T20846.hs:1:1 }
+    (UnchangedAnchor))
+   (AnnsModule
+    [(AddEpAnn AnnModule (EpaSpan { T20846.hs:1:1-6 }))
+    ,(AddEpAnn AnnWhere (EpaSpan { T20846.hs:1:15-19 }))]
+    (AnnList
+     (Nothing)
+     (Nothing)
+     (Nothing)
+     []
+     []))
+   (EpaCommentsBalanced
+    []
+    [(L
+      (Anchor
+       { T20846.hs:5:1 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaEofComment)
+       { T20846.hs:5:1 }))]))
+  (VirtualBraces
+   (1))
+  (Just
+   (L
+    (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:1:8-13 })
+    {ModuleName: T20846}))
+  (Nothing)
+  []
+  [(L
+    (SrcSpanAnn (EpAnn
+                 (Anchor
+                  { T20846.hs:3:1-11 }
+                  (UnchangedAnchor))
+                 (AnnListItem
+                  [])
+                 (EpaComments
+                  [])) { T20846.hs:3:1-11 })
+    (SigD
+     (NoExtField)
+     (FixSig
+      (EpAnn
+       (Anchor
+        { T20846.hs:3:1-6 }
+        (UnchangedAnchor))
+       [(AddEpAnn AnnInfix (EpaSpan { T20846.hs:3:1-6 }))]
+       (EpaComments
+        []))
+      (FixitySig
+       (NoExtField)
+       [(L
+         (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:3:8-11 })
+         (Unqual
+          {OccName: ++++}))]
+       {Fixity: infixr 9}))))
+  ,(L
+    (SrcSpanAnn (EpAnn
+                 (Anchor
+                  { T20846.hs:4:1-18 }
+                  (UnchangedAnchor))
+                 (AnnListItem
+                  [])
+                 (EpaComments
+                  [])) { T20846.hs:4:1-18 })
+    (ValD
+     (NoExtField)
+     (FunBind
+      (NoExtField)
+      (L
+       (SrcSpanAnn (EpAnn
+                    (Anchor
+                     { T20846.hs:4:1-6 }
+                     (UnchangedAnchor))
+                    (NameAnn
+                     (NameParens)
+                     (EpaSpan { T20846.hs:4:1 })
+                     (EpaSpan { T20846.hs:4:2-5 })
+                     (EpaSpan { T20846.hs:4:6 })
+                     [])
+                    (EpaComments
+                     [])) { T20846.hs:4:1-6 })
+       (Unqual
+        {OccName: ++++}))
+      (MG
+       (NoExtField)
+       (L
+        (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:4:1-18 })
+        [(L
+          (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:4:1-18 })
+          (Match
+           (EpAnn
+            (Anchor
+             { T20846.hs:4:1-18 }
+             (UnchangedAnchor))
+            []
+            (EpaComments
+             []))
+           (FunRhs
+            (L
+             (SrcSpanAnn (EpAnn
+                          (Anchor
+                           { T20846.hs:4:1-6 }
+                           (UnchangedAnchor))
+                          (NameAnn
+                           (NameParens)
+                           (EpaSpan { T20846.hs:4:1 })
+                           (EpaSpan { T20846.hs:4:2-5 })
+                           (EpaSpan { T20846.hs:4:6 })
+                           [])
+                          (EpaComments
+                           [])) { T20846.hs:4:1-6 })
+             (Unqual
+              {OccName: ++++}))
+            (Prefix)
+            (NoSrcStrict))
+           []
+           (GRHSs
+            (EpaComments
+             [])
+            [(L
+              (SrcSpanAnn
+               (EpAnnNotUsed)
+               { T20846.hs:4:8-18 })
+              (GRHS
+               (EpAnn
+                (Anchor
+                 { T20846.hs:4:8-18 }
+                 (UnchangedAnchor))
+                (GrhsAnn
+                 (Nothing)
+                 (AddEpAnn AnnEqual (EpaSpan { T20846.hs:4:8 })))
+                (EpaComments
+                 []))
+               []
+               (L
+                (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:4:10-18 })
+                (HsVar
+                 (NoExtField)
+                 (L
+                  (SrcSpanAnn (EpAnnNotUsed) { T20846.hs:4:10-18 })
+                  (Unqual
+                   {OccName: undefined}))))))]
+            (EmptyLocalBinds
+             (NoExtField)))))])
+       (FromSource))
+      [])))]
+  (Nothing)
+  (Nothing)))
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index 5f81a651c3..8820d7545a 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -180,4 +180,5 @@ test('T19521', normal, compile, [''])
 test('T20186', normal, compile, [''])
 test('T20452', normal, compile, [''])
 
-test('DumpSemis',      normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
+test('DumpSemis', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
+test('T20846',    normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
\ No newline at end of file
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 95364cc563..749315c60a 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -743,3 +743,8 @@ Test20258:
 Test20297:
 	$(CHECK_PPR)   $(LIBDIR) Test20297.hs
 	$(CHECK_EXACT) $(LIBDIR) Test20297.hs
+
+.PHONY: Test20846
+Test20846:
+	$(CHECK_PPR)   $(LIBDIR) Test20846.hs
+	$(CHECK_EXACT) $(LIBDIR) Test20846.hs
diff --git a/testsuite/tests/printer/Test20846.hs b/testsuite/tests/printer/Test20846.hs
new file mode 100644
index 0000000000..6a5bd48d59
--- /dev/null
+++ b/testsuite/tests/printer/Test20846.hs
@@ -0,0 +1,3 @@
+module Test20846 where
+
+infixr ++++
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 18ba7ca5d7..3d7c28e453 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -175,3 +175,4 @@ test('PprCommentPlacement2', [ignore_stderr, req_ppr_deps], makefile_test, ['Ppr
 test('Test20243', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20243'])
 test('Test20258', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20258'])
 test('Test20297', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20297'])
+test('Test20846', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20846'])