[commit: ghc] master: Add regression test for #12648 (27f6f38)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/27f6f388ef1a3cd694008150fe513e3e7be2e6ad/ghc

>---------------------------------------------------------------

commit 27f6f388ef1a3cd694008150fe513e3e7be2e6ad
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Fri May 26 21:28:28 2017 -0400

    Add regression test for #12648
    
    Commit ce97b7298d54bdfccd9dcf366a69c5617b4eb43f (the fix for #12175) also
    fixed #12648. Let's add a regression test so that it stays fixed.


>---------------------------------------------------------------

27f6f388ef1a3cd694008150fe513e3e7be2e6ad
 testsuite/tests/typecheck/should_fail/T12648.hs    | 76 ++++++++++++++++++++++
 .../tests/typecheck/should_fail/T12648.stderr      | 17 +++++
 testsuite/tests/typecheck/should_fail/all.T        |  1 +
 3 files changed, 94 insertions(+)

diff --git a/testsuite/tests/typecheck/should_fail/T12648.hs b/testsuite/tests/typecheck/should_fail/T12648.hs
new file mode 100644
index 0000000..b36ecce
--- /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 0000000..227bc67
--- /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 cf2c3c8..bf4854f 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, [''])