[commit: ghc] master: Add regression test for #14172 (00f7e28)
git at git.haskell.org
git at git.haskell.org
Sat May 26 15:40:15 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/00f7e2850396c69938ddb017bc8d87ca1ecd882a/ghc
>---------------------------------------------------------------
commit 00f7e2850396c69938ddb017bc8d87ca1ecd882a
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date: Sat May 26 11:39:26 2018 -0400
Add regression test for #14172
Commit 433b80dec1cfef787fc1327a9eada1791b11c12e fixed #14172. Let's
add a regression test to ensure that it stays fixed.
>---------------------------------------------------------------
00f7e2850396c69938ddb017bc8d87ca1ecd882a
testsuite/tests/polykinds/T14172.hs | 7 ++
testsuite/tests/polykinds/T14172.stderr | 40 ++++++++++
.../T13585a.hs => polykinds/T14172a.hs} | 86 +++++++++-------------
testsuite/tests/polykinds/all.T | 1 +
4 files changed, 84 insertions(+), 50 deletions(-)
diff --git a/testsuite/tests/polykinds/T14172.hs b/testsuite/tests/polykinds/T14172.hs
new file mode 100644
index 0000000..10fff5a
--- /dev/null
+++ b/testsuite/tests/polykinds/T14172.hs
@@ -0,0 +1,7 @@
+module T14172 where
+
+import Data.Functor.Compose
+import T14172a
+
+traverseCompose :: (a -> f b) -> g a -> f (h _)
+traverseCompose = _Wrapping Compose . traverse
diff --git a/testsuite/tests/polykinds/T14172.stderr b/testsuite/tests/polykinds/T14172.stderr
new file mode 100644
index 0000000..487b006
--- /dev/null
+++ b/testsuite/tests/polykinds/T14172.stderr
@@ -0,0 +1,40 @@
+
+T14172.hs:6:46: error:
+ • Found type wildcard ‘_’ standing for ‘a'’
+ Where: ‘a'’ is a rigid type variable bound by
+ the inferred type of
+ traverseCompose :: (a -> f b) -> g a -> f (h a')
+ at T14172.hs:7:1-46
+ To use the inferred type, enable PartialTypeSignatures
+ • In the type signature:
+ traverseCompose :: (a -> f b) -> g a -> f (h _)
+
+T14172.hs:7:19: error:
+ • Occurs check: cannot construct the infinite type: a ~ g'1 a
+ Expected type: (f'0 a -> f (f'0 b))
+ -> Compose f'0 g'1 a -> f (h a')
+ Actual type: (Unwrapped (Compose f'0 g'1 a)
+ -> f (Unwrapped (h a')))
+ -> Compose f'0 g'1 a -> f (h a')
+ • In the first argument of ‘(.)’, namely ‘_Wrapping Compose’
+ In the expression: _Wrapping Compose . traverse
+ In an equation for ‘traverseCompose’:
+ traverseCompose = _Wrapping Compose . traverse
+ • Relevant bindings include
+ traverseCompose :: (a -> f b) -> g a -> f (h a')
+ (bound at T14172.hs:7:1)
+
+T14172.hs:7:19: error:
+ • Couldn't match type ‘g’ with ‘Compose f'0 g'1’
+ ‘g’ is a rigid type variable bound by
+ the inferred type of
+ traverseCompose :: (a -> f b) -> g a -> f (h a')
+ at T14172.hs:7:1-46
+ Expected type: (a -> f b) -> g a -> f (h a')
+ Actual type: (a -> f b) -> Compose f'0 g'1 a -> f (h a')
+ • In the expression: _Wrapping Compose . traverse
+ In an equation for ‘traverseCompose’:
+ traverseCompose = _Wrapping Compose . traverse
+ • Relevant bindings include
+ traverseCompose :: (a -> f b) -> g a -> f (h a')
+ (bound at T14172.hs:7:1)
diff --git a/testsuite/tests/typecheck/should_compile/T13585a.hs b/testsuite/tests/polykinds/T14172a.hs
similarity index 50%
copy from testsuite/tests/typecheck/should_compile/T13585a.hs
copy to testsuite/tests/polykinds/T14172a.hs
index fda3d70..b831372 100644
--- a/testsuite/tests/typecheck/should_compile/T13585a.hs
+++ b/testsuite/tests/polykinds/T14172a.hs
@@ -1,81 +1,67 @@
-{-# LANGUAGE KindSignatures, RankNTypes, TypeFamilies, MultiParamTypeClasses, FlexibleInstances,UndecidableInstances #-}
-
-module T13585a where
-
-import Data.Monoid (First(..))
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T14172a where
+
+import Data.Coerce
+import Data.Functor.Compose
import Data.Functor.Identity
class Profunctor p where
dimap :: (a -> b) -> (c -> d) -> p b c -> p a d
- dimap f g = lmap f . rmap g
+ (#.) :: Coercible c b => (b -> c) -> p a b -> p a c
+
+instance Profunctor (->) where
+ dimap ab cd bc = cd . bc . ab
{-# INLINE dimap #-}
+ (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b
+ {-# INLINE (#.) #-}
- lmap :: (a -> b) -> p b c -> p a c
- lmap f = dimap f id
- {-# INLINE lmap #-}
+type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
+type Iso' s a = Iso s s a a
- rmap :: (b -> c) -> p a b -> p a c
- rmap = dimap id
- {-# INLINE rmap #-}
+iso :: (s -> a) -> (b -> t) -> Iso s t a b
+iso sa bt = dimap sa (fmap bt)
+{-# INLINE iso #-}
+type AnIso s t a b = Exchange a b a (Identity b) -> Exchange a b s (Identity t)
data Exchange a b s t = Exchange (s -> a) (b -> t)
-instance Functor (Exchange a b s) where
- fmap f (Exchange sa bt) = Exchange sa (f . bt)
- {-# INLINE fmap #-}
-
instance Profunctor (Exchange a b) where
dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
{-# INLINE dimap #-}
- lmap f (Exchange sa bt) = Exchange (sa . f) bt
- {-# INLINE lmap #-}
- rmap f (Exchange sa bt) = Exchange sa (f . bt)
- {-# INLINE rmap #-}
-
-
+ (#.) _ = coerce
+ {-# INLINE ( #. ) #-}
withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso ai k = case ai (Exchange id Identity) of
- Exchange sa bt -> k sa (runIdentity undefined bt)
+ Exchange sa bt -> k sa (runIdentity #. bt)
{-# INLINE withIso #-}
-type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
-type Iso' s a = Iso s s a a
-type AnIso s t a b = Exchange a b a (Identity b) -> Exchange a b s (Identity t)
+class Wrapped s where
+ type Unwrapped s :: *
+ _Wrapped' :: Iso' s (Unwrapped s)
+
+class Wrapped s => Rewrapped (s :: *) (t :: *)
class (Rewrapped s t, Rewrapped t s) => Rewrapping s t
instance (Rewrapped s t, Rewrapped t s) => Rewrapping s t
-
-instance (t ~ First b) => Rewrapped (First a) t
-instance Wrapped (First a) where
- type Unwrapped (First a) = Maybe a
- _Wrapped' = iso getFirst First
- {-# INLINE _Wrapped' #-}
-
-class Wrapped s => Rewrapped (s :: *) (t :: *)
-
-class Wrapped s where
- type Unwrapped s :: *
- _Wrapped' :: Iso' s (Unwrapped s)
+instance (t ~ Compose f' g' a') => Rewrapped (Compose f g a) t
+instance Wrapped (Compose f g a) where
+ type Unwrapped (Compose f g a) = f (g a)
+ _Wrapped' = iso getCompose Compose
_Wrapping :: Rewrapping s t => (Unwrapped s -> s) -> Iso s t (Unwrapped s) (Unwrapped t)
_Wrapping _ = _Wrapped
{-# INLINE _Wrapping #-}
-iso :: (s -> a) -> (b -> t) -> Iso s t a b
-iso sa bt = dimap sa (fmap bt)
-{-# INLINE iso #-}
-
_Wrapped :: Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped = withIso _Wrapped' $ \ sa _ -> withIso _Wrapped' $ \ _ bt -> iso sa bt
{-# INLINE _Wrapped #-}
-
-au :: Functor f => AnIso s t a b -> ((b -> t) -> f s) -> f a
-au k = withIso k $ \ sa bt f -> fmap sa (f bt)
-{-# INLINE au #-}
-
-ala :: (Functor f, Rewrapping s t) => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s)
-ala = au . _Wrapping
-{-# INLINE ala #-}
diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T
index 5aaa217..788832d 100644
--- a/testsuite/tests/polykinds/all.T
+++ b/testsuite/tests/polykinds/all.T
@@ -174,6 +174,7 @@ test('T13391', normal, compile_fail, [''])
test('T13391a', normal, compile, [''])
test('T14270', normal, compile, [''])
test('T14450', normal, compile_fail, [''])
+test('T14172', normal, multimod_compile_fail, ['T14172.hs','-v0'])
test('T14174', normal, compile_fail, [''])
test('T14174a', normal, compile, [''])
test('T14520', normal, compile_fail, [''])
More information about the ghc-commits
mailing list