diff options
Diffstat (limited to 'testsuite/tests/typecheck')
-rw-r--r-- | testsuite/tests/typecheck/should_fail/T12648.hs | 76 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_fail/T12648.stderr | 17 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_fail/all.T | 1 |
3 files changed, 94 insertions, 0 deletions
diff --git a/testsuite/tests/typecheck/should_fail/T12648.hs b/testsuite/tests/typecheck/should_fail/T12648.hs new file mode 100644 index 0000000000..b36ecce3bc --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T12648.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +module T12648 where + +import GHC.Exts (Constraint) +import Unsafe.Coerce (unsafeCoerce) + +type family Skolem (p :: k -> Constraint) :: k +type family Forall (p :: k -> Constraint) :: Constraint +type instance Forall p = Forall_ p +class p (Skolem p) => Forall_ (p :: k -> Constraint) +instance p (Skolem p) => Forall_ (p :: k -> Constraint) + +inst :: forall p a. Forall p :- p a +inst = unsafeCoerce (Sub Dict :: Forall p :- p (Skolem p)) + +data Dict :: Constraint -> * where + Dict :: a => Dict a + +newtype a :- b = Sub (a => Dict b) + +infixl 1 \\ -- required comment + +(\\) :: a => (b => r) -> (a :- b) -> r +r \\ Sub Dict = r + +class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m | m -> b + +instance MonadBase IO IO -- where liftBase = id + +class MonadBase b m => MonadBaseControl b m | m -> b where + type StM m a :: * + liftBaseWith :: (RunInBase m b -> b a) -> m a + +type RunInBase m b = forall a. m a -> b (StM m a) + +instance MonadBaseControl IO IO where + type StM IO a = a + liftBaseWith f = f id + {-# INLINABLE liftBaseWith #-} + +class (StM m a ~ a) => IdenticalBase m a +instance (StM m a ~ a) => IdenticalBase m a + +newtype UnliftBase b m = UnliftBase { unliftBase :: forall a. m a -> b a } + +mkUnliftBase :: forall m a b. (Forall (IdenticalBase m), Monad b) + => (forall c. m c -> b (StM m c)) -> m a -> b a +mkUnliftBase r act = r act \\ (inst :: Forall (IdenticalBase m) :- IdenticalBase m a) + +class (MonadBaseControl b m, Forall (IdenticalBase m)) => MonadBaseUnlift b m | m -> b +instance (MonadBaseControl b m, Forall (IdenticalBase m)) => MonadBaseUnlift b m + +askUnliftBase :: forall b m. (MonadBaseUnlift b m) => m (UnliftBase b m) +askUnliftBase = liftBaseWith unlifter + where + unlifter :: (forall c. m c -> b (StM m c)) -> b (UnliftBase b m) + unlifter r = return $ UnliftBase (mkUnliftBase r) + +f :: (MonadBaseUnlift m IO) => m a +f = do + + _ <- askUnliftBase + + return () diff --git a/testsuite/tests/typecheck/should_fail/T12648.stderr b/testsuite/tests/typecheck/should_fail/T12648.stderr new file mode 100644 index 0000000000..227bc6773e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T12648.stderr @@ -0,0 +1,17 @@ + +T12648.hs:76:2: error: + • Couldn't match type ‘a’ with ‘()’ + ‘a’ is a rigid type variable bound by + the type signature for: + f :: forall (m :: * -> *) a. MonadBaseUnlift m IO => m a + at T12648.hs:71:1-34 + Expected type: m a + Actual type: m () + • In a stmt of a 'do' block: return () + In the expression: + do _ <- askUnliftBase + return () + In an equation for ‘f’: + f = do _ <- askUnliftBase + return () + • Relevant bindings include f :: m a (bound at T12648.hs:72:1) diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index cf2c3c859d..bf4854fcd6 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -415,6 +415,7 @@ test('T12170a', normal, compile_fail, ['']) test('T12124', normal, compile_fail, ['']) test('T12589', normal, compile_fail, ['']) test('T12529', normal, compile_fail, ['']) +test('T12648', normal, compile_fail, ['']) test('T12729', normal, compile_fail, ['']) test('T12785b', normal, compile_fail, ['']) test('T12803', normal, compile_fail, ['']) |