diff options
| author | Jakob Bruenker <jakob.bruenker@gmail.com> | 2022-03-29 18:56:50 +0200 |
|---|---|---|
| committer | Matthew Pickering <matthewtpickering@gmail.com> | 2022-04-01 11:08:28 +0100 |
| commit | df65d732d6a39e6d0a7886dc5faa265caece3ce0 (patch) | |
| tree | 4eef88396dad109f0b25308793c36c575942b669 | |
| parent | 265477593865f436fe97c903cc20d7d448a66b79 (diff) | |
| download | haskell-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.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/arrows/gadt/ArrowGADTKappa.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/ghci/should_run/T21300.script | 4 | ||||
| -rw-r--r-- | testsuite/tests/ghci/should_run/T21300.stdout | 6 | ||||
| -rw-r--r-- | testsuite/tests/ghci/should_run/all.T | 1 |
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']) |