diff options
Diffstat (limited to 'testsuite')
13 files changed, 180 insertions, 17 deletions
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 6b75ee2997..a841a73218 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -41,6 +41,7 @@ expectedGhcOnlyExtensions = , "AlternativeLayoutRule" , "AlternativeLayoutRuleTransitional" , "OverloadedRecordUpdate" + , "DeepSubsumption" ] expectedCabalOnlyExtensions :: [String] diff --git a/testsuite/tests/indexed-types/should_compile/Simple14.hs b/testsuite/tests/indexed-types/should_compile/Simple14.hs index bedf5bb3e7..a1b2e5eaca 100644 --- a/testsuite/tests/indexed-types/should_compile/Simple14.hs +++ b/testsuite/tests/indexed-types/should_compile/Simple14.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Haskell2010 #-} {-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Simple14 where @@ -7,6 +8,7 @@ data EQ_ x y = EQ_ -- Nov 2014: actually eqE has an ambiguous type -- Apr 2020: now it doesn't again +-- Jun 2022: now it does again -- because of DeepSubsumption eqE :: EQ_ x y -> (x~y => EQ_ z z) -> p eqE x y = error "eqE" diff --git a/testsuite/tests/indexed-types/should_compile/Simple14.stderr b/testsuite/tests/indexed-types/should_compile/Simple14.stderr index 7489ffce5a..c9c83b6434 100644 --- a/testsuite/tests/indexed-types/should_compile/Simple14.stderr +++ b/testsuite/tests/indexed-types/should_compile/Simple14.stderr @@ -1,21 +1,21 @@ -Simple14.hs:20:27: error: +Simple14.hs:22:27: error: • Couldn't match type ‘z0’ with ‘n’ Expected: EQ_ z0 z0 Actual: EQ_ m n - ‘z0’ is untouchable - inside the constraints: Maybe m ~ Maybe n - bound by a type expected by the context: - (Maybe m ~ Maybe n) => EQ_ z0 z0 - at Simple14.hs:20:26-41 + • ‘z0’ is untouchable + inside the constraints: Maybe m ~ Maybe n + bound by a type expected by the context: + (Maybe m ~ Maybe n) => EQ_ z0 z0 + at Simple14.hs:22:26-41 ‘n’ is a rigid type variable bound by the type signature for: foo :: forall m n. EQ_ (Maybe m) (Maybe n) - at Simple14.hs:19:1-42 + at Simple14.hs:21:1-42 • In the second argument of ‘eqE’, namely ‘(eqI :: EQ_ m n)’ In the expression: x `eqE` (eqI :: EQ_ m n) In the first argument of ‘ntI’, namely ‘(\ x -> x `eqE` (eqI :: EQ_ m n))’ • Relevant bindings include - x :: EQ_ (Maybe m) (Maybe n) (bound at Simple14.hs:20:13) - foo :: EQ_ (Maybe m) (Maybe n) (bound at Simple14.hs:20:1) + x :: EQ_ (Maybe m) (Maybe n) (bound at Simple14.hs:22:13) + foo :: EQ_ (Maybe m) (Maybe n) (bound at Simple14.hs:22:1) diff --git a/testsuite/tests/showIface/LanguageExts.stdout b/testsuite/tests/showIface/LanguageExts.stdout index c155327230..1e0a2a89be 100644 --- a/testsuite/tests/showIface/LanguageExts.stdout +++ b/testsuite/tests/showIface/LanguageExts.stdout @@ -12,6 +12,7 @@ docs: Just Haskell98 language extensions: MonomorphismRestriction + DeepSubsumption ImplicitPrelude NPlusKPatterns PatternGuards diff --git a/testsuite/tests/simplCore/should_compile/rule2.stderr b/testsuite/tests/simplCore/should_compile/rule2.stderr index 7a27514454..3c108d8e71 100644 --- a/testsuite/tests/simplCore/should_compile/rule2.stderr +++ b/testsuite/tests/simplCore/should_compile/rule2.stderr @@ -10,19 +10,22 @@ ==================== Grand total simplifier statistics ==================== -Total ticks: 10 +Total ticks: 12 -1 PreInlineUnconditionally 1 f +2 PreInlineUnconditionally + 1 f + 1 ds 1 UnfoldingDone 1 Roman.bar 1 RuleFired 1 foo/bar 1 LetFloatFromLet 1 -6 BetaReduction +7 BetaReduction 1 f 1 a 1 m 1 m 1 b 1 m + 1 ds 8 SimplifierDone 8 diff --git a/testsuite/tests/typecheck/should_compile/DeepSubsumption01.hs b/testsuite/tests/typecheck/should_compile/DeepSubsumption01.hs new file mode 100644 index 0000000000..d07525b7eb --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/DeepSubsumption01.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeepSubsumption #-} +module Repro where + +import GHC.Generics +import Data.Binary + +data FFIType + = FFIVoid + deriving (Show, Generic, Binary) diff --git a/testsuite/tests/typecheck/should_compile/DeepSubsumption02.hs b/testsuite/tests/typecheck/should_compile/DeepSubsumption02.hs new file mode 100644 index 0000000000..fe8be78f38 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/DeepSubsumption02.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE BangPatterns, Rank2Types, FlexibleContexts, LambdaCase, DeepSubsumption #-} +module DeepSubsumption02 where + +import Data.Semigroup + +-- | Finite source +type Source r s = Tap r (Maybe s) + +newtype Sink t m a = Sink + { unSink :: forall r. t m -> (a -> t m -> m r) -> m r } + +-- | Mono in/out +type Converter p q r s m = Source r s (Sink (Source p q) m) + +type Pipe a b m = forall r. (Monoid r, Semigroup r) => Converter r a r b m + +newtype Tap r s m = Tap { unTap :: r -> m (s, Tap r s m) } + +type Distiller tap r s m = Tap r s (Sink tap m) + +filter :: Monad m => (a -> Bool) -> Pipe a a m +--filter f = filtering $ maybe True f +filter = filtering . maybe True +{-# INLINE filter #-} + +mapAccum :: Monad m => (s -> a -> (s, b)) -> s -> Pipe a b m +--mapAccum f x = go x where +mapAccum f = go where + go s = reservingTap $ \case + Just a -> let (s', b) = f s a in return (Just b, go s') + Nothing -> return (Nothing, go s) +{-# INLINE mapAccum #-} + +traverse :: (Monad m) => (a -> m b) -> Pipe a b m +-- traverse f = traversing $ Prelude.traverse f +traverse = traversing . Prelude.traverse +{-# INLINE traverse #-} + +-- | Get one element preserving a request +reservingTap :: Monad m => (a -> Sink (Tap r a) m (b, Distiller (Tap r a) r b m)) -> Distiller (Tap r a) r b m +reservingTap k = Tap $ \r -> Sink $ \t cont -> do + (a, t') <- unTap t r + unSink (k a) t' cont +{-# INLINE reservingTap #-} + +traversing :: (Monad m) => (a -> m b) -> Distiller (Tap r a) r b m +traversing f = go where + go = reservingTap $ \a -> do + b <- undefined $ f a + return (b, go) +{-# INLINE traversing #-} + +filtering :: (Monoid r, Monad m) => (a -> Bool) -> Distiller (Tap r a) r a m +filtering f = go where + go = reservingTap $ \a -> if f a + then return (a, go) + else unTap go mempty +{-# INLINE filtering #-} + +instance Functor (Sink s m) where + fmap f m = Sink $ \s k -> unSink m s (k . f) + +instance Applicative (Sink s m) where + pure a = Sink $ \s k -> k a s + Sink mf <*> Sink mx = Sink + $ \s k -> mf s $ \f s' -> mx s' $ k . f + m *> k = m >>= \_ -> k + +instance Monad (Sink s m) where + return = pure + {-# INLINE return #-} + m >>= k = Sink $ \s cont -> unSink m s $ \a s' -> unSink (k a) s' cont + diff --git a/testsuite/tests/typecheck/should_compile/DeepSubsumption03.hs b/testsuite/tests/typecheck/should_compile/DeepSubsumption03.hs new file mode 100644 index 0000000000..8f8c465047 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/DeepSubsumption03.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeepSubsumption #-} +{-# LANGUAGE NoPolyKinds #-} +module DeepSubsumption03 where + +class Profunctor p where + dimap :: (s -> a) -> (b -> t) -> p i a b -> p i s t + +type Iso s t a b = forall p i . Profunctor p => p i a b -> p i s t + +iso :: (s -> a) -> (b -> t) -> Iso s t a b +-- iso f g = dimap f g +iso = dimap diff --git a/testsuite/tests/typecheck/should_compile/DeepSubsumption04.hs b/testsuite/tests/typecheck/should_compile/DeepSubsumption04.hs new file mode 100644 index 0000000000..abaf8d569b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/DeepSubsumption04.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeepSubsumption #-} +{-# LANGUAGE KindSignatures #-} +module DeepSubsumption04 where + +import Data.Kind + +data TermOutput = TermOutput + +type TermAction = () -> TermOutput + +type ActionT = WriterT TermAction + +class MonadReader r m where + ask :: m r + +data WriterT w (m :: Type -> Type) a = WriterT + +type ActionM a = forall m . (MonadReader () m) => ActionT m a + +output :: TermAction -> ActionM () +output t = undefined + +termText :: String -> TermOutput +termText = undefined + +outputText :: String -> ActionM () +outputText = output . const . termText +--outputText x = output . const . termText $ x + diff --git a/testsuite/tests/typecheck/should_compile/DeepSubsumption05.hs b/testsuite/tests/typecheck/should_compile/DeepSubsumption05.hs new file mode 100644 index 0000000000..a6d9db3cb9 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/DeepSubsumption05.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeepSubsumption #-} +module DeepSubsumption06 where + +type Traversal' s a = forall f . Applicative f => (a -> a) -> f s -> f s +type LensLike f m a = (a -> a) -> f m -> f m + +class Ixed m where + ix :: () -> Traversal' m () + + default ix :: (Applicative f) => () -> LensLike f m () + ix = undefined diff --git a/testsuite/tests/typecheck/should_compile/T21548a.hs b/testsuite/tests/typecheck/should_compile/T21548a.hs new file mode 100644 index 0000000000..399f3e5386 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T21548a.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE RankNTypes, DeepSubsumption #-} + +module T21548a where + +f1 :: (forall a. a -> forall b. b -> b) -> Int +f1 = f1 + +g1 :: forall p q. p -> q -> q +g1 = g1 + +foo1 = f1 g1 + diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 62edaf99e6..3410ad68bb 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -843,3 +843,9 @@ test('T18802', normal, compile, ['']) test('T18802b', normal, compile, ['']) test('T21289', normal, compile, ['']) test('HardRecordUpdate', normal, compile, ['']) +test('T21548a', normal, compile, ['']) +test('DeepSubsumption01', normal, compile, ['']) +test('DeepSubsumption02', normal, compile, ['']) +test('DeepSubsumption03', normal, compile, ['']) +test('DeepSubsumption04', normal, compile, ['']) +test('DeepSubsumption05', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/T14618.stderr b/testsuite/tests/typecheck/should_fail/T14618.stderr index 05a763048e..6cf768bbce 100644 --- a/testsuite/tests/typecheck/should_fail/T14618.stderr +++ b/testsuite/tests/typecheck/should_fail/T14618.stderr @@ -1,10 +1,10 @@ T14618.hs:7:14: error: - • Couldn't match type ‘b’ with ‘forall c. a’ - Expected: a -> b - Actual: a -> forall c. a - Cannot equate type variable ‘b’ - with a type involving polytypes: forall c. a + • Couldn't match expected type ‘b’ with actual type ‘a’ + ‘a’ is a rigid type variable bound by + the type signature for: + safeCoerce :: forall a b. a -> b + at T14618.hs:6:1-20 ‘b’ is a rigid type variable bound by the type signature for: safeCoerce :: forall a b. a -> b |