[commit: testsuite] master: Test Trac #8603 (b34bee3)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/b34bee3a45204ff43fa31e9dee3a23a74aa252db/testsuite

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

commit b34bee3a45204ff43fa31e9dee3a23a74aa252db
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Sat Dec 28 12:45:35 2013 +0000

    Test Trac #8603


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

b34bee3a45204ff43fa31e9dee3a23a74aa252db
 tests/typecheck/should_fail/T8603.hs     |   32 ++++++++++++++++++++++++++++++
 tests/typecheck/should_fail/T8603.stderr |   22 ++++++++++++++++++++
 tests/typecheck/should_fail/all.T        |    1 +
 3 files changed, 55 insertions(+)

diff --git a/tests/typecheck/should_fail/T8603.hs b/tests/typecheck/should_fail/T8603.hs
new file mode 100644
index 0000000..90c1db3
--- /dev/null
+++ b/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/tests/typecheck/should_fail/T8603.stderr b/tests/typecheck/should_fail/T8603.stderr
new file mode 100644
index 0000000..1777dc9
--- /dev/null
+++ b/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/tests/typecheck/should_fail/all.T b/tests/typecheck/should_fail/all.T
index 93eb007..faef063 100644
--- a/tests/typecheck/should_fail/all.T
+++ b/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, [''])