Test Trac #8603

3 files changed, 55 insertions, 0 deletions

diff --git a/testsuite/tests/typecheck/should_fail/T8603.hs b/testsuite/tests/typecheck/should_fail/T8603.hs
new file mode 100644
index 0000000000..90c1db3ad6
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T8603.hs
@@ -0,0 +1,32 @@
+module T8603 where
+
+import Control.Monad
+import Data.Functor
+import Control.Monad.Trans.Class( lift )
+import Control.Monad.Trans.State( StateT )
+
+newtype RV a = RV { getPDF :: [(Rational,a)] } deriving (Show, Eq)
+
+instance Functor RV where
+  fmap f = RV . map (\(x,y) -> (x, f y)) . getPDF
+
+instance Monad RV where
+  return x = RV [(1,x)]
+  rv >>= f = RV $
+    do (p,a) <- getPDF rv
+       guard (p > 0)
+       (q,b) <- getPDF $ f a
+       guard (q > 0)
+       return (p*q, b)
+
+type RVState s a = StateT s RV a
+
+uniform :: [a] -> RV a
+uniform x = RV [(1/fromIntegral (length x), y) | y <- x]
+
+testRVState1 :: RVState s Bool
+testRVState1
+  = do prize <- lift uniform [1,2,3]
+       return False
+
+-- lift :: (MonadTrans t, Monad m) => m a -> t m a
\ No newline at end of file
diff --git a/testsuite/tests/typecheck/should_fail/T8603.stderr b/testsuite/tests/typecheck/should_fail/T8603.stderr
new file mode 100644
index 0000000000..1777dc9535
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T8603.stderr
@@ -0,0 +1,22 @@
+

+T8603.hs:29:17:

+    Couldn't match type ‛(->) [a0]’ with ‛[t1]’

+    Expected type: [t1] -> StateT s RV t0

+      Actual type: t2 ((->) [a0]) (StateT s RV t0)

+    The function ‛lift’ is applied to two arguments,

+    but its type ‛([a0] -> StateT s RV t0)

+                  -> t2 ((->) [a0]) (StateT s RV t0)’

+    has only one

+    In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3]

+    In the expression:

+      do { prize <- lift uniform [1, 2, ....];

+           return False }

+

+T8603.hs:29:22:

+    Couldn't match type ‛StateT s RV t0’ with ‛RV a0’

+    Expected type: [a0] -> StateT s RV t0

+      Actual type: [a0] -> RV a0

+    Relevant bindings include

+      testRVState1 :: RVState s Bool (bound at T8603.hs:28:1)

+    In the first argument of ‛lift’, namely ‛uniform’

+    In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3]

diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 93eb007af3..faef06382d 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -329,3 +329,4 @@ test('ContextStack1', normal, compile_fail, ['-fcontext-stack=10'])
 test('ContextStack2', normal, compile_fail, ['-ftype-function-depth=10'])
 test('T8570', extra_clean(['T85570a.o', 'T8570a.hi','T85570b.o', 'T8570b.hi']),
      multimod_compile_fail, ['T8570', '-v0'])
+test('T8603', normal, compile_fail, [''])