summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJakob Bruenker <jakob.bruenker@gmail.com>2022-03-29 18:56:50 +0200
committerMatthew Pickering <matthewtpickering@gmail.com>2022-04-01 11:08:28 +0100
commitdf65d732d6a39e6d0a7886dc5faa265caece3ce0 (patch)
tree4eef88396dad109f0b25308793c36c575942b669
parent265477593865f436fe97c903cc20d7d448a66b79 (diff)
downloadhaskell-df65d732d6a39e6d0a7886dc5faa265caece3ce0.tar.gz
Fix panic when pretty printing HsCmdLam
When pretty printing a HsCmdLam with more than one argument, GHC panicked because of a missing case. This fixes that. Closes #21300
-rw-r--r--compiler/GHC/Hs/Expr.hs4
-rw-r--r--testsuite/tests/arrows/gadt/ArrowGADTKappa.stderr4
-rw-r--r--testsuite/tests/ghci/should_run/T21300.script4
-rw-r--r--testsuite/tests/ghci/should_run/T21300.stdout6
-rw-r--r--testsuite/tests/ghci/should_run/all.T1
5 files changed, 17 insertions, 2 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index accdd189ec..e4ce67d5cf 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1406,6 +1406,10 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
LambdaExpr -> (char '\\', pats)
+ ArrowMatchCtxt KappaExpr -> (char '\\', pats)
+
+ ArrowMatchCtxt ProcExpr -> (text "proc", pats)
+
_ -> case pats of
[] -> (empty, [])
[pat] -> (ppr pat, []) -- No parens around the single pat in a case
diff --git a/testsuite/tests/arrows/gadt/ArrowGADTKappa.stderr b/testsuite/tests/arrows/gadt/ArrowGADTKappa.stderr
index 0241dc9739..e9b21a297f 100644
--- a/testsuite/tests/arrows/gadt/ArrowGADTKappa.stderr
+++ b/testsuite/tests/arrows/gadt/ArrowGADTKappa.stderr
@@ -2,5 +2,5 @@
ArrowGADTKappa.hs:17:26: error:
• Proc patterns cannot use existential or GADT data constructors
• In the pattern: MkG g
- In an arrow kappa abstraction: (MkG g) -> show -< g
- In the command: (id -< x) `handleG` (MkG g) -> show -< g
+ In an arrow kappa abstraction: \ (MkG g) -> show -< g
+ In the command: (id -< x) `handleG` \ (MkG g) -> show -< g
diff --git a/testsuite/tests/ghci/should_run/T21300.script b/testsuite/tests/ghci/should_run/T21300.script
new file mode 100644
index 0000000000..2e3bc77b65
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T21300.script
@@ -0,0 +1,4 @@
+:set -XArrows -XBlockArguments
+import Control.Arrow
+:set -ddump-tc -dsuppress-uniques
+(proc 'a' -> (| id \'b' 'c'-> returnA -< 'c' |) 'b' 'c') 'a'
diff --git a/testsuite/tests/ghci/should_run/T21300.stdout b/testsuite/tests/ghci/should_run/T21300.stdout
new file mode 100644
index 0000000000..56c4297029
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T21300.stdout
@@ -0,0 +1,6 @@
+Bound Ids interactive:Ghci2.it
+Typechecked expr do let it
+ = (proc 'a' -> (| id \ 'b' 'c' -> returnA -< 'c' |) 'b' 'c') 'a'
+ print it
+ GHC.Base.returnIO [Unsafe.Coerce.unsafeCoerce# it]
+'c'
diff --git a/testsuite/tests/ghci/should_run/all.T b/testsuite/tests/ghci/should_run/all.T
index 77c17a995c..96a12b47a5 100644
--- a/testsuite/tests/ghci/should_run/all.T
+++ b/testsuite/tests/ghci/should_run/all.T
@@ -82,3 +82,4 @@ test('T19733', just_ghci, compile_and_run, [''])
test('T19628', [extra_files(['T19628a.hs']), only_ways(['ghci']) ], compile_and_run, [''])
test('T21052', just_ghci, ghci_script, ['T21052.script'])
+test('T21300', just_ghci, ghci_script, ['T21300.script'])