diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-11-19 00:34:42 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-12-11 22:40:08 -0500 |
commit | f9f9f030d77ee6fb882897246a67b527937b8f66 (patch) | |
tree | 56b65ba78ded001f22e75bbac9bf10c110e81ecc /testsuite/tests/arrows | |
parent | 5feb9b2dad0ce609e3cfb537a6ca758a09a6898e (diff) | |
download | haskell-f9f9f030d77ee6fb882897246a67b527937b8f66.tar.gz |
Arrows: correctly query arrow methods (#17423)
Consider the following code:
proc (C x y) -> ...
Before this patch, the evidence binding for the Arrow dictionary was
attached to the C pattern:
proc (C x y) { $dArrow = ... } -> ...
But then when we desugar this, we use arrow operations ("arr", ">>>"...)
specialised for this arrow:
let
arr_xy = arr $dArrow -- <-- Not in scope!
...
in
arr_xy (\(C x y) { $dArrow = ... } -> ...)
This patch allows arrow operations to be type-checked before the proc
itself, avoiding this issue.
Fix #17423
Diffstat (limited to 'testsuite/tests/arrows')
-rw-r--r-- | testsuite/tests/arrows/should_compile/T17423.hs | 37 | ||||
-rw-r--r-- | testsuite/tests/arrows/should_compile/all.T | 1 |
2 files changed, 38 insertions, 0 deletions
diff --git a/testsuite/tests/arrows/should_compile/T17423.hs b/testsuite/tests/arrows/should_compile/T17423.hs new file mode 100644 index 0000000000..35023f0612 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/T17423.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE Arrows, GADTs #-} + +module Main where + +import Control.Arrow +import Control.Category +import Prelude hiding (id, (.)) + +data DecoType a where + -- | Icons and colours for @False@ and @True@ respectively. + DecoBool :: Maybe (String, String) -> Maybe (Int, Int) -> DecoType Bool + -- | Icons and colours for ranges within type @a@. + DecoRange :: String -> DecoType a + +-- Sub-dialog for designing decorated booleans. +decoBoolDialog :: Gadget (DecoType Bool) (DecoType Bool) +decoBoolDialog = + -- arr (\(DecoBool i c) -> (i, c)) >>> (icons *** colours) >>> arr (uncurry DecoBool) + proc (DecoBool i c) -> do -- Compiler panic in GHC 8.6.5. + i1 <- id -< i + c1 <- id -< c + returnA -< DecoBool i1 c1 + + + +data Gadget b c = Pure (b -> c) + +instance Category Gadget where + id = Pure id + Pure g1 . Pure g2 = Pure $ g1 . g2 + +instance Arrow Gadget where + arr = Pure + first (Pure f) = Pure $ \(b, b1) -> (f b, b1) + + +main = putStrLn "Hello world." diff --git a/testsuite/tests/arrows/should_compile/all.T b/testsuite/tests/arrows/should_compile/all.T index 279dd109dd..b47cea0538 100644 --- a/testsuite/tests/arrows/should_compile/all.T +++ b/testsuite/tests/arrows/should_compile/all.T @@ -16,3 +16,4 @@ test('T5283', normal, compile, ['']) test('T5267', expect_broken(5267), compile, ['']) test('T5022', normalise_fun(normalise_errmsg), compile, ['']) test('T5333', normal, compile, ['']) +test('T17423', normal, compile, ['']) |