diff options
Diffstat (limited to 'testsuite/tests/rebindable')
-rw-r--r-- | testsuite/tests/rebindable/DoRestrictedM.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/rebindable/RebindableFailA.hs | 19 | ||||
-rw-r--r-- | testsuite/tests/rebindable/RebindableFailA.stderr | 3 | ||||
-rw-r--r-- | testsuite/tests/rebindable/RebindableFailB.hs | 20 | ||||
-rw-r--r-- | testsuite/tests/rebindable/RebindableFailB.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/rebindable/T5908.hs | 5 | ||||
-rw-r--r-- | testsuite/tests/rebindable/all.T | 6 | ||||
-rw-r--r-- | testsuite/tests/rebindable/rebindable1.hs | 3 | ||||
-rw-r--r-- | testsuite/tests/rebindable/rebindable11.hs | 15 | ||||
-rw-r--r-- | testsuite/tests/rebindable/rebindable11.stderr | 0 | ||||
-rw-r--r-- | testsuite/tests/rebindable/rebindable12.hs | 14 | ||||
-rw-r--r-- | testsuite/tests/rebindable/rebindable12.stderr | 4 | ||||
-rw-r--r-- | testsuite/tests/rebindable/rebindable2.hs | 6 |
13 files changed, 53 insertions, 49 deletions
diff --git a/testsuite/tests/rebindable/DoRestrictedM.hs b/testsuite/tests/rebindable/DoRestrictedM.hs index 2e982c1532..de28079769 100644 --- a/testsuite/tests/rebindable/DoRestrictedM.hs +++ b/testsuite/tests/rebindable/DoRestrictedM.hs @@ -30,11 +30,11 @@ m1 >> m2 = m1 >>= (const m2) newtype RegularM m a = RegularM{unRM :: m a} -instance Prelude.Monad m => MN2 (RegularM m) a where +instance Prelude.MonadFail m => MN2 (RegularM m) a where return = RegularM . Prelude.return - fail = RegularM . Prelude.fail + fail = fail -instance Prelude.Monad m => MN3 (RegularM m) a b where +instance Prelude.MonadFail m => MN3 (RegularM m) a b where m >>= f = RegularM ((Prelude.>>=) (unRM m) (unRM . f)) -- We try to inject Maybe (as the regular monad) into Restricted Monad diff --git a/testsuite/tests/rebindable/RebindableFailA.hs b/testsuite/tests/rebindable/RebindableFailA.hs new file mode 100644 index 0000000000..0fc6444190 --- /dev/null +++ b/testsuite/tests/rebindable/RebindableFailA.hs @@ -0,0 +1,19 @@ +-- Test that RebindableSyntax and the new MonadFail interact correctly. +-- +-- This should fail with the message "Failed with error". + +{-# LANGUAGE RebindableSyntax #-} + +import Prelude hiding (fail) + +fail :: String -> a +fail _ = error "Failed with error" + +f :: Maybe Int -> Maybe () +f x = do + 42 <- x + return () +{-# NOINLINE f #-} + +main = print (f (Just 55)) + diff --git a/testsuite/tests/rebindable/RebindableFailA.stderr b/testsuite/tests/rebindable/RebindableFailA.stderr new file mode 100644 index 0000000000..dfc52f42b0 --- /dev/null +++ b/testsuite/tests/rebindable/RebindableFailA.stderr @@ -0,0 +1,3 @@ +RebindableFailA: Failed with error +CallStack (from HasCallStack): + error, called at RebindableFailA.hs:10:10 in main:Main diff --git a/testsuite/tests/rebindable/RebindableFailB.hs b/testsuite/tests/rebindable/RebindableFailB.hs new file mode 100644 index 0000000000..6c25864685 --- /dev/null +++ b/testsuite/tests/rebindable/RebindableFailB.hs @@ -0,0 +1,20 @@ +-- Test that RebindableSyntax and the new MonadFail interact correctly. +-- +-- This should print "Just ()" + +{-# LANGUAGE RebindableSyntax #-} + +import Prelude hiding (fail) + +fail :: String -> a +fail _ = error "Failed with error" + +f :: Maybe Int -> Maybe () +f x = do + 42 <- x + return () +{-# NOINLINE f #-} + +main = print (f (Just 42)) + + diff --git a/testsuite/tests/rebindable/RebindableFailB.stdout b/testsuite/tests/rebindable/RebindableFailB.stdout new file mode 100644 index 0000000000..7c2c1d94b9 --- /dev/null +++ b/testsuite/tests/rebindable/RebindableFailB.stdout @@ -0,0 +1 @@ +Just () diff --git a/testsuite/tests/rebindable/T5908.hs b/testsuite/tests/rebindable/T5908.hs index 2666c3371a..ff5da8949a 100644 --- a/testsuite/tests/rebindable/T5908.hs +++ b/testsuite/tests/rebindable/T5908.hs @@ -25,11 +25,9 @@ class Monad m where (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b return :: a -> m ex ex a - fail :: String -> m e x a {-# INLINE (>>) #-} m >> k = m >>= \ _ -> k - fail = error type Writer w = WriterT w Identity @@ -60,9 +58,6 @@ instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where where (>>=) = (Prelude.>>=) return = Prelude.return - fail msg = WriterT $ fail msg - where - fail = Prelude.fail tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x () tell w = WriterT $ return ((), w) diff --git a/testsuite/tests/rebindable/all.T b/testsuite/tests/rebindable/all.T index 7c8caea438..2caa486d9b 100644 --- a/testsuite/tests/rebindable/all.T +++ b/testsuite/tests/rebindable/all.T @@ -20,10 +20,8 @@ test('rebindable7', normal, compile_and_run, ['']) test('rebindable8', normal, compile, ['']) test('rebindable9', normal, compile, ['']) test('rebindable10', normal, compile_and_run, ['']) - -# Test rebindable clash warnings -test('rebindable11', normal, compile, ['']) -test('rebindable12', normal, compile_fail, ['']) +test('RebindableFailA', exit_code(1), compile_and_run, ['']) +test('RebindableFailB', normal, compile_and_run, ['']) test('T303', normal, compile, ['']) diff --git a/testsuite/tests/rebindable/rebindable1.hs b/testsuite/tests/rebindable/rebindable1.hs index fcbe52fbc1..f966624710 100644 --- a/testsuite/tests/rebindable/rebindable1.hs +++ b/testsuite/tests/rebindable/rebindable1.hs @@ -1,5 +1,4 @@ -{-# OPTIONS_GHC -Wno-missing-monadfail-instances #-} -{-# LANGUAGE RebindableSyntax, NPlusKPatterns, NoMonadFailDesugaring #-} +{-# LANGUAGE RebindableSyntax, NPlusKPatterns #-} module RebindableCase1 where { diff --git a/testsuite/tests/rebindable/rebindable11.hs b/testsuite/tests/rebindable/rebindable11.hs deleted file mode 100644 index 13e1b2dd3d..0000000000 --- a/testsuite/tests/rebindable/rebindable11.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE RebindableSyntax, MonadFailDesugaring #-} -{-# OPTIONS_GHC -Wno-missing-monadfail-instances #-} - --- Test that rebindable clash warnings are not displayed. This program --- should not generate anything on stderr at compile time. - -module Main where - -import Prelude - -catMaybes xs = do - Just x <- xs - return x - -main = return () diff --git a/testsuite/tests/rebindable/rebindable11.stderr b/testsuite/tests/rebindable/rebindable11.stderr deleted file mode 100644 index e69de29bb2..0000000000 --- a/testsuite/tests/rebindable/rebindable11.stderr +++ /dev/null diff --git a/testsuite/tests/rebindable/rebindable12.hs b/testsuite/tests/rebindable/rebindable12.hs deleted file mode 100644 index fd2e1c7bb3..0000000000 --- a/testsuite/tests/rebindable/rebindable12.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE RebindableSyntax, MonadFailDesugaring #-} -{-# OPTIONS_GHC -Wmissing-monadfail-instances #-} - --- Test that rebindable clash warnings are displayed. - -module Main where - -import Prelude - -catMaybes xs = do - Just x <- xs - return x - -main = return () diff --git a/testsuite/tests/rebindable/rebindable12.stderr b/testsuite/tests/rebindable/rebindable12.stderr deleted file mode 100644 index 722a95c293..0000000000 --- a/testsuite/tests/rebindable/rebindable12.stderr +++ /dev/null @@ -1,4 +0,0 @@ -rebindable12.hs:11:5: error: [-Wmissing-monadfail-instances (in -Wcompat), -Werror=missing-monadfail-instances] - The failable pattern ‘Just x’ - is used together with -XRebindableSyntax. If this is intentional, - compile with -Wno-missing-monadfail-instances. diff --git a/testsuite/tests/rebindable/rebindable2.hs b/testsuite/tests/rebindable/rebindable2.hs index 9fe15150f4..3858d2b9f3 100644 --- a/testsuite/tests/rebindable/rebindable2.hs +++ b/testsuite/tests/rebindable/rebindable2.hs @@ -8,7 +8,7 @@ module Main where import Prelude(String,undefined,Maybe(..),IO,putStrLn, Integer,(++),Rational, (==), (>=) ); - import Prelude(Monad(..),Applicative(..),Functor(..)); + import Prelude(Monad(..),Applicative(..),Functor(..),MonadFail(..)); import Control.Monad(ap, liftM); debugFunc :: String -> IO a -> IO a; @@ -35,7 +35,9 @@ module Main where (>>=) ma amb = MkTM (debugFunc ">>=" ((Prelude.>>=) (unTM ma) (\a -> unTM (amb a)))); (>>) ma mb = MkTM (debugFunc ">>" ((Prelude.>>) (unTM ma) (unTM mb))); - + }; + instance (MonadFail TM) where + { fail s = MkTM (debugFunc "fail" (Prelude.return undefined)); }; |