diff options
Diffstat (limited to 'testsuite/tests/deSugar/should_compile')
132 files changed, 1497 insertions, 0 deletions
diff --git a/testsuite/tests/deSugar/should_compile/GadtOverlap.hs b/testsuite/tests/deSugar/should_compile/GadtOverlap.hs new file mode 100644 index 0000000000..89187414a3 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/GadtOverlap.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE GADTs #-}
+
+module Gadt where
+
+data T a where
+ T1 :: T Int
+ T2 :: T a
+ T3 :: T Bool
+
+f :: T Int -> Bool
+f T1 = True
+f T2 = False
+
+g :: T Bool -> Bool
+g T2 = True
+g T3 = False
+
+h :: T a -> Bool
+h T1 = True
+h T2 = False
diff --git a/testsuite/tests/deSugar/should_compile/GadtOverlap.stderr b/testsuite/tests/deSugar/should_compile/GadtOverlap.stderr new file mode 100644 index 0000000000..423d69469f --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/GadtOverlap.stderr @@ -0,0 +1,4 @@ + +GadtOverlap.hs:19:1: + Warning: Pattern match(es) are non-exhaustive + In an equation for `h': Patterns not matched: T3 diff --git a/testsuite/tests/deSugar/should_compile/Makefile b/testsuite/tests/deSugar/should_compile/Makefile new file mode 100644 index 0000000000..a6cbe41da5 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/Makefile @@ -0,0 +1,8 @@ +TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T5252:
+ $(RM) -f T5252*.hi T5252*.o
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T5252a.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T5252.hs
diff --git a/testsuite/tests/deSugar/should_compile/T2395.hs b/testsuite/tests/deSugar/should_compile/T2395.hs new file mode 100644 index 0000000000..8600690279 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T2395.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall #-} + +-- Pattern-match overlap warnings with view patterns +module T2395 where + +foo :: Int -> Int +foo (even -> True) = 4 +foo _ = 5 + +bar :: (a, (Int,Int)) -> Int +bar (snd -> (x,y)) = x+y -- Cannot fail, hence overlap warning should +bar _ = 6 -- for second pattern diff --git a/testsuite/tests/deSugar/should_compile/T2395.stderr b/testsuite/tests/deSugar/should_compile/T2395.stderr new file mode 100644 index 0000000000..4bfd9d6bb8 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T2395.stderr @@ -0,0 +1,4 @@ + +T2395.hs:12:1: + Warning: Pattern match(es) are overlapped + In an equation for `bar': bar _ = ... diff --git a/testsuite/tests/deSugar/should_compile/T2409.hs b/testsuite/tests/deSugar/should_compile/T2409.hs new file mode 100644 index 0000000000..163786bb58 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T2409.hs @@ -0,0 +1,11 @@ +-- Trac #2409 + +module ShouldCompile where + + f :: Int -> Int + f _ | () `seq` False = undefined + | otherwise = error "XXX" + + g :: Int -> Int + g _ | () `seq` False = undefined + | otherwise = error "XXX" diff --git a/testsuite/tests/deSugar/should_compile/T3263-1.hs b/testsuite/tests/deSugar/should_compile/T3263-1.hs new file mode 100644 index 0000000000..74249cd663 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T3263-1.hs @@ -0,0 +1,36 @@ +-- Trac #3263. New kind of warning on ignored monadic bindings + +module T3263 where + +nullM :: IO () +nullM = return () + +nonNullM :: IO Int +nonNullM = return 10 + +-- No warning +t1 = do + nonNullM + +-- No warning +t2 = nonNullM + +-- No warning +t3 = do + nullM + nonNullM + +-- Warning +t4 = do + nonNullM + nullM + +-- No warning +t5 = do + _ <- nonNullM + nullM + +-- Warning +t6 = mdo + nonNullM + nullM
\ No newline at end of file diff --git a/testsuite/tests/deSugar/should_compile/T3263-1.stderr b/testsuite/tests/deSugar/should_compile/T3263-1.stderr new file mode 100644 index 0000000000..ac21515daf --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T3263-1.stderr @@ -0,0 +1,13 @@ + +on the commandline: + Warning: -XRecursiveDo is deprecated: use -XDoRec or pragma {-# LANGUAGE DoRec #-} instead + +T3263-1.hs:25:3: + Warning: A do-notation statement discarded a result of type Int. + Suppress this warning by saying "_ <- nonNullM", + or by using the flag -fno-warn-unused-do-bind + +T3263-1.hs:35:3: + Warning: A do-notation statement discarded a result of type Int. + Suppress this warning by saying "_ <- nonNullM", + or by using the flag -fno-warn-unused-do-bind diff --git a/testsuite/tests/deSugar/should_compile/T3263-2.hs b/testsuite/tests/deSugar/should_compile/T3263-2.hs new file mode 100644 index 0000000000..71288062c5 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T3263-2.hs @@ -0,0 +1,38 @@ +-- Trac #3263. New kind of warning on monadic bindings that discard a monadic result + +module T3263 where + +import Control.Monad.Fix + +-- No warning +t1 :: Monad m => m Int +t1 = do + return 10 + +-- No warning +t2 :: Monad m => m (m Int) +t2 = return (return 10) + +-- No warning +t3 :: Monad m => m (m Int) +t3 = do + return 10 + return (return 10) + +-- Warning +t4 :: forall m. Monad m => m Int +t4 = do + return (return 10 :: m Int) + return 10 + +-- No warning +t5 :: forall m. Monad m => m Int +t5 = do + _ <- return (return 10 :: m Int) + return 10 + +-- Warning +t6 :: forall m. MonadFix m => m Int +t6 = mdo + return (return 10 :: m Int) + return 10
\ No newline at end of file diff --git a/testsuite/tests/deSugar/should_compile/T3263-2.stderr b/testsuite/tests/deSugar/should_compile/T3263-2.stderr new file mode 100644 index 0000000000..3f92403e84 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T3263-2.stderr @@ -0,0 +1,13 @@ + +on the commandline: + Warning: -XRecursiveDo is deprecated: use -XDoRec or pragma {-# LANGUAGE DoRec #-} instead + +T3263-2.hs:25:3: + Warning: A do-notation statement discarded a result of type m Int. + Suppress this warning by saying "_ <- return (return 10 :: m Int)", + or by using the flag -fno-warn-wrong-do-bind + +T3263-2.hs:37:3: + Warning: A do-notation statement discarded a result of type m Int. + Suppress this warning by saying "_ <- return (return 10 :: m Int)", + or by using the flag -fno-warn-wrong-do-bind diff --git a/testsuite/tests/deSugar/should_compile/T4371.hs b/testsuite/tests/deSugar/should_compile/T4371.hs new file mode 100644 index 0000000000..c6542a8540 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T4371.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ViewPatterns,DeriveDataTypeable #-} +module T4371 where + +import Data.Typeable + +data E1 = E1 deriving Typeable +data E2 = E2 deriving Typeable + +f :: Typeable a => a-> () +f x = case x of + (cast -> Just E1) -> () + (cast -> Just E2) -> () diff --git a/testsuite/tests/deSugar/should_compile/T4439.hs b/testsuite/tests/deSugar/should_compile/T4439.hs new file mode 100644 index 0000000000..13b02e65d6 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T4439.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ViewPatterns, ExistentialQuantification #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +-- None of these should give incomplete-pattern warnings + +module T4439 where + +data Moo = Moo (Char -> Int) +spqr (Moo _) = undefined +foo (id -> Moo _) = undefined + + +data Exists = forall a. Exists (a -> Int) +bar (Exists _) = undefined +baz (id -> Exists _) = undefined diff --git a/testsuite/tests/deSugar/should_compile/T4488.hs b/testsuite/tests/deSugar/should_compile/T4488.hs new file mode 100644 index 0000000000..c5bae4e536 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T4488.hs @@ -0,0 +1,29 @@ +{-# OPTIONS -fwarn-identities #-} + +-- Test warnings about identities + +module T4488 where + +-- ok1 :: Int -> Float +ok1 x = fromIntegral x + +warn1 :: Int -> Int +warn1 x = fromIntegral x + +ok4 :: Int -> Integer +ok4 x = toInteger x + +warn4 :: Integer -> Integer +warn4 x = toInteger x + +ok5 :: Float -> Rational +ok5 x = toRational x + +warn5 :: Rational -> Rational +warn5 x = toRational x + +-- ok6 :: Float -> Rational +ok6 x = realToFrac x + +warn6 :: Float -> Float +warn6 x = realToFrac x diff --git a/testsuite/tests/deSugar/should_compile/T4488.stderr b/testsuite/tests/deSugar/should_compile/T4488.stderr new file mode 100644 index 0000000000..f8c20a5de0 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T4488.stderr @@ -0,0 +1,20 @@ + +T4488.hs:11:11: + Warning: Call of fromIntegral :: Int -> Int + can probably be omitted + (Use -fno-warn-identities to suppress this messsage)) + +T4488.hs:17:11: + Warning: Call of toInteger :: Integer -> Integer + can probably be omitted + (Use -fno-warn-identities to suppress this messsage)) + +T4488.hs:23:11: + Warning: Call of toRational :: Rational -> Rational + can probably be omitted + (Use -fno-warn-identities to suppress this messsage)) + +T4488.hs:29:11: + Warning: Call of realToFrac :: Float -> Float + can probably be omitted + (Use -fno-warn-identities to suppress this messsage)) diff --git a/testsuite/tests/deSugar/should_compile/T4870.hs b/testsuite/tests/deSugar/should_compile/T4870.hs new file mode 100644 index 0000000000..fefcdb194b --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T4870.hs @@ -0,0 +1,10 @@ +module T4870 where
+
+import T4870a
+
+data D = D
+
+instance C D where
+ c x = x
+
+{-# SPECIALIZE f :: D #-}
diff --git a/testsuite/tests/deSugar/should_compile/T4870a.hs b/testsuite/tests/deSugar/should_compile/T4870a.hs new file mode 100644 index 0000000000..a4c59a5b66 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T4870a.hs @@ -0,0 +1,8 @@ +module T4870a where
+
+class C a where c :: a -> a
+
+{-# INLINABLE f #-}
+f :: (C a) => a
+f = c f
+
diff --git a/testsuite/tests/deSugar/should_compile/T5117.hs b/testsuite/tests/deSugar/should_compile/T5117.hs new file mode 100644 index 0000000000..15f9c796f0 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T5117.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-}
+module BadWarning where
+
+data MyString = MyString String
+
+f1 (MyString "a") = undefined
+f1 (MyString "bb") = undefined
+f1 _ = undefined
+
+f2 (MyString "aa") = undefined
+f2 (MyString "bb") = undefined
+f2 _ = undefined
+
+-- Genuine overlap here!
+f3(MyString ('a':_)) = undefined
+f3 (MyString "a") = undefined
+f3 _ = undefined
diff --git a/testsuite/tests/deSugar/should_compile/T5117.stderr b/testsuite/tests/deSugar/should_compile/T5117.stderr new file mode 100644 index 0000000000..e9ddba143b --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T5117.stderr @@ -0,0 +1,4 @@ +
+T5117.hs:15:1:
+ Warning: Pattern match(es) are overlapped
+ In an equation for `f3': f3 (MyString "a") = ...
diff --git a/testsuite/tests/deSugar/should_compile/T5252.hs b/testsuite/tests/deSugar/should_compile/T5252.hs new file mode 100644 index 0000000000..e2498c4089 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T5252.hs @@ -0,0 +1,13 @@ +-- Trac #5252
+-- Killed 7.03 when compiled witout -O,
+-- because it could not see that x had a product type
+-- but MkS still unpacked it
+
+module T5252 where
+import T5252a
+
+blah :: S -> T
+blah (MkS x _) = x
+
+
+
diff --git a/testsuite/tests/deSugar/should_compile/T5252a.hs b/testsuite/tests/deSugar/should_compile/T5252a.hs new file mode 100644 index 0000000000..ff1704a566 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T5252a.hs @@ -0,0 +1,5 @@ +module T5252a( S(..), T ) where
+
+data T = MkT Int Int
+
+data S = MkS {-# UNPACK #-}!T Int
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T new file mode 100644 index 0000000000..0db20f9e71 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/all.T @@ -0,0 +1,90 @@ +# Just do the normal way... +def f( opts ): + opts.only_ways = ['normal'] + +setTestOpts(f) + +test('ds-wildcard', normal, compile, ['']) +test('ds001', normal, compile, ['']) +test('ds002', normal, compile, ['']) +test('ds003', normal, compile, ['']) +test('ds004', normal, compile, ['']) +test('ds005', normal, compile, ['']) +test('ds006', normal, compile, ['']) +test('ds007', normal, compile, ['']) +test('ds008', normal, compile, ['']) +test('ds009', normal, compile, ['']) +test('ds010', normal, compile, ['']) +test('ds011', normal, compile, ['']) +test('ds012', normal, compile, ['']) +test('ds013', normal, compile, ['']) +test('ds014', normal, compile, ['']) +test('ds015', normal, compile, ['']) +test('ds016', normal, compile, ['']) +test('ds017', normal, compile, ['']) +test('ds018', normal, compile, ['']) +test('ds019', normal, compile, ['']) +test('ds020', normal, compile, ['']) +test('ds021', normal, compile, ['']) +test('ds022', normal, compile, ['']) +test('ds023', normal, compile, ['']) +test('ds024', normal, compile, ['']) +test('ds025', normal, compile, ['']) +test('ds026', normal, compile, ['']) +test('ds027', normal, compile, ['']) +test('ds028', normal, compile, ['']) +test('ds029', normal, compile, ['']) +test('ds030', normal, compile, ['']) +test('ds031', normal, compile, ['']) +test('ds032', normal, compile, ['']) +test('ds033', normal, compile, ['']) +test('ds034', normal, compile, ['']) +test('ds035', only_compiler_types(['ghc']), compile, ['']) +test('ds036', normal, compile, ['']) +test('ds037', normal, compile, ['']) +test('ds038', normal, compile, ['']) +test('ds039', normal, compile, ['']) +test('ds040', normal, compile, ['']) +test('ds041', normal, compile, ['']) +test('ds042', normal, compile, ['']) +test('ds043', normal, compile, ['']) +test('ds044', normal, compile, ['']) +test('ds045', normal, compile, ['']) +test('ds046', normal, compile, ['-funbox-strict-fields']) +test('ds047', normal, compile, ['']) +test('ds048', normal, compile, ['']) +test('ds050', normal, compile, ['']) +test('ds051', normal, compile, ['']) +test('ds052', normal, compile, ['']) +test('ds053', normal, compile, ['']) +test('ds054', normal, compile, ['']) +test('ds055', only_compiler_types(['ghc']), compile, ['']) +test('ds056', normal, compile, ['-Wall']) +test('ds057', normal, compile, ['']) +test('ds058', normal, compile, ['-W']) +test('ds059', normal, compile, ['-W']) +test('ds060', expect_broken(322), compile, ['']) +test('ds061', expect_broken(851), compile, ['']) +test('ds062', normal, compile, ['']) +test('ds063', normal, compile, ['']) + +test('T2409', normal, compile, ['']) +test('T3263-1', normal, compile, ['-fwarn-unused-do-bind -XRecursiveDo']) +test('T3263-2', normal, compile, ['-fwarn-wrong-do-bind -XScopedTypeVariables -XRecursiveDo']) + +test('GadtOverlap', normal, compile, ['-Wall']) +test('T2395', normal, compile, ['']) +test('T4371', normal, compile, ['']) +test('T4439', normal, compile, ['']) +test('T4488', if_compiler_lt('ghc', '7.1', expect_fail), compile, ['']) +test('T4870', + [only_ways(['optasm']), + only_compiler_types(['ghc']), + extra_clean(['T4870a.hi', 'T4870a.o'])], + multimod_compile, + ['T4870', '-v0']) +test('T5117', normal, compile, ['']) +test('T5252', + extra_clean(['T5252a.hi', 'T5252a.o']), + run_command, + ['$MAKE -s --no-print-directory T5252']) diff --git a/testsuite/tests/deSugar/should_compile/ds-wildcard.hs b/testsuite/tests/deSugar/should_compile/ds-wildcard.hs new file mode 100644 index 0000000000..dae882c32b --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds-wildcard.hs @@ -0,0 +1,3 @@ +module ShouldCompile where + +x@_ = x diff --git a/testsuite/tests/deSugar/should_compile/ds-wildcard.stderr b/testsuite/tests/deSugar/should_compile/ds-wildcard.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds-wildcard.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds001.hs b/testsuite/tests/deSugar/should_compile/ds001.hs new file mode 100644 index 0000000000..d3f0b60f56 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds001.hs @@ -0,0 +1,25 @@ +-- !!! ds001 -- simple function and pattern bindings +-- +-- this tests ultra-simple function and pattern bindings (no patterns) + +module ShouldCompile where + +-- simple function bindings + +f x = x + +g x y z = f z + +j w x y z = g w x z + +h x y = f y + where + f a b = a + +-- simple pattern bindings + +a = b + +b = f + +c = c diff --git a/testsuite/tests/deSugar/should_compile/ds001.stderr b/testsuite/tests/deSugar/should_compile/ds001.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds001.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds002.hs b/testsuite/tests/deSugar/should_compile/ds002.hs new file mode 100644 index 0000000000..280674e1fe --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds002.hs @@ -0,0 +1,16 @@ +-- !!! ds002 -- overlapping equations and guards +-- +-- this tests "overlapping" variables and guards + +module ShouldCompile where + +f x = x +f y = y +f z = z + +g x y z | True = f z + | True = f z + | True = f z +g x y z | True = f z + | True = f z + | True = f z diff --git a/testsuite/tests/deSugar/should_compile/ds002.stderr-ghc b/testsuite/tests/deSugar/should_compile/ds002.stderr-ghc new file mode 100644 index 0000000000..baf7ffde53 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds002.stderr-ghc @@ -0,0 +1,10 @@ + +ds002.hs:7:1: + Warning: Pattern match(es) are overlapped + In an equation for `f': + f y = ... + f z = ... + +ds002.hs:11:1: + Warning: Pattern match(es) are overlapped + In an equation for `g': g x y z = ... diff --git a/testsuite/tests/deSugar/should_compile/ds003.hs b/testsuite/tests/deSugar/should_compile/ds003.hs new file mode 100644 index 0000000000..dafeac94b7 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds003.hs @@ -0,0 +1,8 @@ +-- !!! ds003 -- list, tuple, lazy, as patterns +-- +module ShouldCompile where + +f [] y True = [] +f x a@(y,ys) ~z = [] +f (x:x1:x2:x3) ~(y,ys) z = [] +f x y True = [] diff --git a/testsuite/tests/deSugar/should_compile/ds003.stderr-ghc b/testsuite/tests/deSugar/should_compile/ds003.stderr-ghc new file mode 100644 index 0000000000..5b1bd3949f --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds003.stderr-ghc @@ -0,0 +1,6 @@ + +ds003.hs:5:1: + Warning: Pattern match(es) are overlapped + In an equation for `f': + f (x : x1 : x2 : x3) ~(y, ys) z = ... + f x y True = ... diff --git a/testsuite/tests/deSugar/should_compile/ds004.hs b/testsuite/tests/deSugar/should_compile/ds004.hs new file mode 100644 index 0000000000..ebbe8e06c2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds004.hs @@ -0,0 +1,9 @@ +-- !!! ds004 -- nodups from SLPJ p 79 +-- +module ShouldCompile where + +-- SLPJ, p 79 +nodups [] = [] +nodups [x] = [x] +nodups (y:x:xs) | y == x = nodups (x:xs) + | True = y : nodups (x:xs) diff --git a/testsuite/tests/deSugar/should_compile/ds004.stderr b/testsuite/tests/deSugar/should_compile/ds004.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds004.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds005.hs b/testsuite/tests/deSugar/should_compile/ds005.hs new file mode 100644 index 0000000000..a02e8d9c1d --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds005.hs @@ -0,0 +1,15 @@ +-- !!! ds005 -- mappairs from SLPJ Ch 5' +-- +-- this simply tests a "typical" example + +module ShouldCompile where + +-- from SLPJ, p 78 +mappairs f [] ys = [] +mappairs f (x:xs) [] = [] +mappairs f (x:xs) (y:ys) = f x y : mappairs f xs ys + +-- from p 80 +mappairs' f [] ys = [] +mappairs' f x [] = [] +mappairs' f (x:xs) (y:ys) = f x y : mappairs' f xs ys diff --git a/testsuite/tests/deSugar/should_compile/ds005.stderr b/testsuite/tests/deSugar/should_compile/ds005.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds005.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds006.hs b/testsuite/tests/deSugar/should_compile/ds006.hs new file mode 100644 index 0000000000..d66e7c17e8 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds006.hs @@ -0,0 +1,6 @@ +-- !!! ds006 -- v | True = v+1 | False = v (dead code elim) +-- +module ShouldCompile where + +v | True = v + 1 + | False = v diff --git a/testsuite/tests/deSugar/should_compile/ds006.stderr b/testsuite/tests/deSugar/should_compile/ds006.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds006.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds007.hs b/testsuite/tests/deSugar/should_compile/ds007.hs new file mode 100644 index 0000000000..ae12cf7a8c --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds007.hs @@ -0,0 +1,6 @@ +-- !!! ds007 -- simple local bindings + +module ShouldCompile where + +w = a where a = y + y = [] diff --git a/testsuite/tests/deSugar/should_compile/ds007.stderr b/testsuite/tests/deSugar/should_compile/ds007.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds007.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds008.hs b/testsuite/tests/deSugar/should_compile/ds008.hs new file mode 100644 index 0000000000..73707ed565 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds008.hs @@ -0,0 +1,11 @@ +-- !!! ds008 -- free tyvars on RHSs +-- +-- these tests involve way-cool TyApps + +module ShouldCompile where + +f x = [] + +g x = (f [],[],[],[]) + +h x = g (1::Int) diff --git a/testsuite/tests/deSugar/should_compile/ds008.stderr b/testsuite/tests/deSugar/should_compile/ds008.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds008.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds009.hs b/testsuite/tests/deSugar/should_compile/ds009.hs new file mode 100644 index 0000000000..6ebcc96adf --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds009.hs @@ -0,0 +1,13 @@ +-- !!! ds009 -- simple list comprehensions + +module ShouldCompile where + +f xs = [ x | x <- xs ] + +g xs ys zs = [ (x,y,z) | x <- xs, y <- ys, z <- zs, True ] + +h xs ys = [ [x,y] | x <- xs, y <- ys, False ] + +i xs = [ x | all@(x,y) <- xs, all == ([],[]) ] + +j xs = [ (a,b) | (a,b,c,d) <- xs ] diff --git a/testsuite/tests/deSugar/should_compile/ds009.stderr b/testsuite/tests/deSugar/should_compile/ds009.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds009.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds010.hs b/testsuite/tests/deSugar/should_compile/ds010.hs new file mode 100644 index 0000000000..268610e124 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds010.hs @@ -0,0 +1,15 @@ +-- !!! ds010 -- deeply-nested list comprehensions + +module ShouldCompile where + +z = [ (a,b,c,d,e,f,g,h,i,j) | a <- "12", + b <- "12", + c <- "12", + d <- "12", + e <- "12", + f <- "12", + g <- "12", + h <- "12", + i <- "12", + j <- "12" + ] diff --git a/testsuite/tests/deSugar/should_compile/ds010.stderr b/testsuite/tests/deSugar/should_compile/ds010.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds010.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds011.hs b/testsuite/tests/deSugar/should_compile/ds011.hs new file mode 100644 index 0000000000..dab482ff04 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds011.hs @@ -0,0 +1,11 @@ +-- !!! ds011 -- uses of "error" + +module ShouldCompile where + +f = error [] + +g = error "" + +h = error "\"" + +i = error "foo" diff --git a/testsuite/tests/deSugar/should_compile/ds011.stderr b/testsuite/tests/deSugar/should_compile/ds011.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds011.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds012.hs b/testsuite/tests/deSugar/should_compile/ds012.hs new file mode 100644 index 0000000000..4ef9d8cc1d --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds012.hs @@ -0,0 +1,10 @@ +-- !!! ds012 -- simple Integer arithmetic +-- +module ShouldCompile where + +f x = 1 + 2 - 3 + 4 * 5 + +g x = x + (f x) + +h x = 111111111111111111111111111111111111111111111111111111111111 + + 222222222222222222222222222222222222222222222222222222222222 diff --git a/testsuite/tests/deSugar/should_compile/ds012.stderr b/testsuite/tests/deSugar/should_compile/ds012.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds012.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds013.hs b/testsuite/tests/deSugar/should_compile/ds013.hs new file mode 100644 index 0000000000..3fb55ab47c --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds013.hs @@ -0,0 +1,23 @@ +-- !!! ds013 -- simple Rational arithmetic + +module ShouldCompile where + +f = 1.5 + 2.0 - 3.14159265 + 4.2 * 5.111111111111111111111111111 + +g :: Float +g = 1.5 + 2.0 - 3.14159265 + 4.2 * 5.111111111111111111111111111 + +h :: Double +h = 1.5 + 2.0 - 3.14159265 + 4.2 * 5.111111111111111111111111111 + +{- later +g x = x + (f x) + +h x = 1.0e1000000000 + 1.0e1000000000 + +i x = 1.0e-1000000000 + 1.0e-1000000000 + +j x = 1111111111.222222222222222e333333333333333 + * 4444444444.555555555555555e-66666666666666 +-} + diff --git a/testsuite/tests/deSugar/should_compile/ds013.stderr b/testsuite/tests/deSugar/should_compile/ds013.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds013.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds014.hs b/testsuite/tests/deSugar/should_compile/ds014.hs new file mode 100644 index 0000000000..23b3709854 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds014.hs @@ -0,0 +1,76 @@ +-- !!! ds014 -- character and string literals +-- !!! really should add ALL weird forms... + +module ShouldCompile where + +a = 'a' +b = "b" +c = a:b +d = b ++ b + +b1 = "" -- examples from the Haskell report +b2 = "\&" -- the same thing +b3 = "\SO\&H" ++ "\137\&9" + +a000 = '\NUL' +a001 = '\SOH' +a002 = '\STX' +a003 = '\ETX' +a004 = '\EOT' +a005 = '\ENQ' +a006 = '\ACK' +a007 = '\BEL' +a010 = '\BS' +a011 = '\HT' +a012 = '\LF' +a013 = '\VT' +a014 = '\FF' +a015 = '\CR' +a016 = '\SO' +a017 = '\SI' +a020 = '\DLE' +a021 = '\DC1' +a022 = '\DC2' +a023 = '\DC3' +a024 = '\DC4' +a025 = '\NAK' +a026 = '\SYN' +a027 = '\ETB' +a030 = '\CAN' +a031 = '\EM' +a032 = '\SUB' +a033 = '\ESC' +a034 = '\FS' +a035 = '\GS' +a036 = '\RS' +a037 = '\US' +a040 = '\SP' +a042 = '"' +a047 = '\'' +a134 = '\\' +a177 = '\DEL' + +ascii = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\ + \\BS\HT\LF\VT\FF\CR\SO\SI\ + \\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\ + \\CAN\EM\SUB\ESC\FS\GS\RS\US\ + \\SP!\"#$%&'\ + \()*+,-./\ + \01234567\ + \89:;<=>?\ + \@ABCDEFG\ + \HIJKLMNO\ + \PQRSTUVW\ + \XYZ[\\]^_\ + \`abcdefg\ + \hijklmno\ + \pqrstuvw\ + \xyz{|}~\DEL" + +na200 = '\o200' +na250 = '\o250' +na300 = '\o300' +na350 = '\o350' +na377 = '\o377' + +eightbit = "\o200\o250\o300\o350\o377" diff --git a/testsuite/tests/deSugar/should_compile/ds014.stderr b/testsuite/tests/deSugar/should_compile/ds014.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds014.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds015.hs b/testsuite/tests/deSugar/should_compile/ds015.hs new file mode 100644 index 0000000000..24645778ee --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds015.hs @@ -0,0 +1,9 @@ +-- !!! ds015 -- lambdas +-- +module ShouldCompile where + +f x = ( \ x -> x ) x + +g x y = ( \ x y -> y x ) ( \ x -> x ) x + +h x y = ( \ (x:xs) -> x ) x diff --git a/testsuite/tests/deSugar/should_compile/ds015.stderr b/testsuite/tests/deSugar/should_compile/ds015.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds015.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds016.hs b/testsuite/tests/deSugar/should_compile/ds016.hs new file mode 100644 index 0000000000..41394e7ed9 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds016.hs @@ -0,0 +1,15 @@ +-- !!! ds016 -- case expressions +-- +module ShouldCompile where + +f x y z = + case ( x ++ x ++ x ++ x ++ x ) of + [] -> [] + [a] -> error "2" + [a,b,c] -> + case ( (y,z,y,z) ) of +-- (True, _, False, _) | True == False -> z +-- (True, _, False, _) | True == False -> z + _ -> z + + (a:bs) -> error "4" diff --git a/testsuite/tests/deSugar/should_compile/ds016.stderr b/testsuite/tests/deSugar/should_compile/ds016.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds016.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds017.hs b/testsuite/tests/deSugar/should_compile/ds017.hs new file mode 100644 index 0000000000..e6fd6d02f9 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds017.hs @@ -0,0 +1,12 @@ +-- !!! ds017 -- let expressions +-- +module ShouldCompile where + +f x y z + = let + a = x : [] + b = x : a + c = y (let d = (z, z) in d) + result = (c, b) + in + result diff --git a/testsuite/tests/deSugar/should_compile/ds017.stderr b/testsuite/tests/deSugar/should_compile/ds017.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds017.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds018.hs b/testsuite/tests/deSugar/should_compile/ds018.hs new file mode 100644 index 0000000000..68a9e4ce47 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds018.hs @@ -0,0 +1,57 @@ +-- !!! ds018 -- explicit lists and tuples (with disabled LARGE tuples!) +-- +module ShouldCompile where + +-- exprs + +f x y z = [x,y,z,x,y,z] +f2 x y = [] + +g1 x y = () + +{- Although GHC *should* provide arbitrary tuples, it currently doesn't + and probably won't in the near future, so this test is only a reminder. + +g x y z = (x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z) -- hey, we love big tuples +-} + +-- pats + +fa [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z] = x + +fb [] = [] + +{- See above +ga (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z, + aa,ab,ac,ad,ae,af,ag,ah,ai,aj,ak,al,am, + an,ao,ap,aq,ar,as,at,au,av,aw,ax,ay,az) = x +-} + +gb () x = x +gb2 () = () + +-- need to think of some better ones... diff --git a/testsuite/tests/deSugar/should_compile/ds018.stderr b/testsuite/tests/deSugar/should_compile/ds018.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds018.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds019.hs b/testsuite/tests/deSugar/should_compile/ds019.hs new file mode 100644 index 0000000000..6bcf43f0ce --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds019.hs @@ -0,0 +1,8 @@ +-- !!! ds019 -- mixed var and uni-constructor pats + +module ShouldCompile where + +f (a,b,c) i o = [] +f d (j,k) p = [] +f (e,f,g) l q = [] +f h (m,n) r = [] diff --git a/testsuite/tests/deSugar/should_compile/ds019.stderr-ghc b/testsuite/tests/deSugar/should_compile/ds019.stderr-ghc new file mode 100644 index 0000000000..68816686b1 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds019.stderr-ghc @@ -0,0 +1,7 @@ + +ds019.hs:5:1: + Warning: Pattern match(es) are overlapped + In an equation for `f': + f d (j, k) p = ... + f (e, f, g) l q = ... + f h (m, n) r = ... diff --git a/testsuite/tests/deSugar/should_compile/ds020.hs b/testsuite/tests/deSugar/should_compile/ds020.hs new file mode 100644 index 0000000000..184c857a8f --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds020.hs @@ -0,0 +1,57 @@ +-- !!! ds020 -- lazy patterns (in detail) +-- + +{-# LANGUAGE NPlusKPatterns #-} + +module ShouldCompile where + +a ~([],[],[]) = [] +a ~(~[],~[],~[]) = [] + +b ~(x:xs:ys) = [] +b ~(~x: ~xs: ~ys) = [] + +c ~x ~ _ ~11111 ~3.14159265 = x + +d 11 = 4 +d 12 = 3 +d ~(n+4) = 2 +d ~(n+43) = 1 +d ~(n+999) = 0 + +f ~(x@[]) = [] +f x@(~[]) = [] + +g ~(~(~(~([])))) = [] + +-- pattern bindings (implicitly lazy) + +([],[],[]) = ([],[],[]) +(~[],~[],~[]) = ([],[],[]) + +(x1: xs1: ys1) = [] +(~x: ~xs: ~ys) = [] + +(x2 : xs2: ys2) | eq2 = [] + | eq3 = [x2] + | eq4 = [x2] + | True = [] + where + eq2 = (2::Int) == (4::Int) + eq3 = (3::Int) == (3::Int) + eq4 = (4::Int) == (2::Int) + +(x3,y3) | x3 > 3 = (4, 5) + | x3 <= 3 = (2, 3) +-- above: x & y should both be \bottom. + +(x4,(y4,(z4,a4))) | eq2 = ('a',('a',('a','a'))) + | eq3 = ('b',('b',('b','b'))) + | eq4 = ('c',('c',('c','c'))) + | True = ('d',('d',('d','d'))) + where + eq2 = (2::Int) == (4::Int) + eq3 = (3::Int) == (3::Int) + eq4 = (4::Int) == (2::Int) + + diff --git a/testsuite/tests/deSugar/should_compile/ds020.stderr-ghc b/testsuite/tests/deSugar/should_compile/ds020.stderr-ghc new file mode 100644 index 0000000000..3f9205a729 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds020.stderr-ghc @@ -0,0 +1,18 @@ + +ds020.hs:8:1: + Warning: Pattern match(es) are overlapped + In an equation for `a': a ~(~[], ~[], ~[]) = ... + +ds020.hs:11:1: + Warning: Pattern match(es) are overlapped + In an equation for `b': b ~(~x : ~xs : ~ys) = ... + +ds020.hs:16:1: + Warning: Pattern match(es) are overlapped + In an equation for `d': + d ~(n+43) = ... + d ~(n+999) = ... + +ds020.hs:22:1: + Warning: Pattern match(es) are overlapped + In an equation for `f': f x@(~[]) = ... diff --git a/testsuite/tests/deSugar/should_compile/ds021.hs b/testsuite/tests/deSugar/should_compile/ds021.hs new file mode 100644 index 0000000000..4faaba53fd --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds021.hs @@ -0,0 +1,8 @@ +-- !!! ds021 -- hairier uses of guards + +module ShouldCompile where + +f x y z | x == y = [] + | x /= z = [] + | True = [] + | False = [] diff --git a/testsuite/tests/deSugar/should_compile/ds021.stderr b/testsuite/tests/deSugar/should_compile/ds021.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds021.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds022.hs b/testsuite/tests/deSugar/should_compile/ds022.hs new file mode 100644 index 0000000000..2ac429f95b --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds022.hs @@ -0,0 +1,32 @@ +-- !!! ds022 -- literal patterns (wimp version) +-- +module ShouldCompile where + +f 1 1.1 = [] +f 2 2.2 = [] +f 3 3.3 = [] +f 4 4.4 = [] + +g 11111111111111111111111 1.11111111111111111 = [] +g 22222222222222222222222 2.22222222222222222 = [] +g 33333333333333333333333 3.33333333333333333 = [] +g 44444444444444444444444 4.44444444444444444 = [] + +h 'a' "" = [] +h '\'' "foo" = [] +h '"' ('b':'a':'r':[]) = [] +h '\o250' blob = [] + +i 1 1.1 = [] +i 2 2.2 = [] +i 1 0.011e2 = [] +i 2 2.20000 = [] + +{- +j one@1 oneone@1.1 + | ((fromFloat oneone) - (fromIntegral (fromInt one))) + /= (fromIntegral (fromInt 0)) = [] +j two@2 twotwo@2.2 + | ((fromFloat twotwo) * (fromIntegral (fromInt 2))) + == (fromIntegral (fromInt 4.4)) = [] +-} diff --git a/testsuite/tests/deSugar/should_compile/ds022.stderr-ghc b/testsuite/tests/deSugar/should_compile/ds022.stderr-ghc new file mode 100644 index 0000000000..ce6d4a52c1 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds022.stderr-ghc @@ -0,0 +1,6 @@ + +ds022.hs:20:1: + Warning: Pattern match(es) are overlapped + In an equation for `i': + i 1 0.011e2 = ... + i 2 2.20000 = ... diff --git a/testsuite/tests/deSugar/should_compile/ds023.hs b/testsuite/tests/deSugar/should_compile/ds023.hs new file mode 100644 index 0000000000..736107d979 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds023.hs @@ -0,0 +1,7 @@ +-- !!! ds023 -- overloading eg from section 9.2 +-- +module ShouldCompile where + +f x = g (x == x) x +g b x = abs (f x) +--g b x = (f x) + (f x) diff --git a/testsuite/tests/deSugar/should_compile/ds023.stderr b/testsuite/tests/deSugar/should_compile/ds023.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds023.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds024.hs b/testsuite/tests/deSugar/should_compile/ds024.hs new file mode 100644 index 0000000000..76606a90f7 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds024.hs @@ -0,0 +1,11 @@ +-- !!! ds024 -- correct types on ConPatOuts + +-- do all the right types get stuck on all the +-- Nils and Conses? + +module ShouldCompile where + + +f x = [[], []] + +g x = ([], [], []) diff --git a/testsuite/tests/deSugar/should_compile/ds024.stderr b/testsuite/tests/deSugar/should_compile/ds024.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds024.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds025.hs b/testsuite/tests/deSugar/should_compile/ds025.hs new file mode 100644 index 0000000000..fdbf0ff6ae --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds025.hs @@ -0,0 +1,16 @@ +-- !!! ds025 -- overloaded assoc -- AbsBinds + +module ShouldCompile where + +ehead xs loc | null xs = error ("4"++loc) + | True = head xs + +assoc key lst loc + = if (null res) then error ("1"++loc++"2"++(show key)) + else (ehead res "3") + where res = [ val | (key',val) <- lst, key==key'] + +assocMaybe :: (Eq a) => a -> [(a,b)] -> Maybe b +assocMaybe key lst + = if (null res) then Nothing else (Just (head res)) + where res = [ val | (key',val) <- lst, key==key'] diff --git a/testsuite/tests/deSugar/should_compile/ds025.stderr b/testsuite/tests/deSugar/should_compile/ds025.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds025.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds026.hs b/testsuite/tests/deSugar/should_compile/ds026.hs new file mode 100644 index 0000000000..f21ca0b18b --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds026.hs @@ -0,0 +1,14 @@ +-- !!! ds026 -- classes -- incl. polymorphic method + +module ShouldCompile where + +class Foo a where + op :: a -> a + +class Foo a => Boo a where + op1 :: a -> a + +class Boo a => Noo a where + op2 :: (Eq b) => a -> b -> a + +f x y = op (op2 x y) diff --git a/testsuite/tests/deSugar/should_compile/ds026.stderr b/testsuite/tests/deSugar/should_compile/ds026.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds026.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds027.hs b/testsuite/tests/deSugar/should_compile/ds027.hs new file mode 100644 index 0000000000..436958e531 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds027.hs @@ -0,0 +1,9 @@ +-- !!! ds027 -- simple instances +-- +module ShouldCompile where + +data Foo = Bar | Baz + +instance Eq Foo where + Bar == Baz = True + Bar /= Baz = False diff --git a/testsuite/tests/deSugar/should_compile/ds027.stderr b/testsuite/tests/deSugar/should_compile/ds027.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds027.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds028.hs b/testsuite/tests/deSugar/should_compile/ds028.hs new file mode 100644 index 0000000000..4c7944aa39 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds028.hs @@ -0,0 +1,13 @@ +-- !!! ds028: failable pats in top row + +module ShouldCompile where + + +-- when the first row of pats doesn't have convenient +-- variables to grab... + +mAp f [] = [] +mAp f (x:xs) = f x : mAp f xs + +True |||| _ = True +False |||| x = x diff --git a/testsuite/tests/deSugar/should_compile/ds028.stderr b/testsuite/tests/deSugar/should_compile/ds028.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds028.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds029.hs b/testsuite/tests/deSugar/should_compile/ds029.hs new file mode 100644 index 0000000000..000052365e --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds029.hs @@ -0,0 +1,9 @@ +-- !!! ds029: pattern binding with guards (dubious but valid) +-- + +module ShouldCompile where + +f x = y + where (y,z) | y < z = (0,1) + | y > z = (1,2) + | True = (2,3) diff --git a/testsuite/tests/deSugar/should_compile/ds029.stderr b/testsuite/tests/deSugar/should_compile/ds029.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds029.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds030.hs b/testsuite/tests/deSugar/should_compile/ds030.hs new file mode 100644 index 0000000000..8475b55a0f --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds030.hs @@ -0,0 +1,5 @@ +-- !!! ds030: checks that types substituted into binders +-- +module ShouldCompile where + +f x = case x of [] -> (3::Int) ; _ -> (4::Int) diff --git a/testsuite/tests/deSugar/should_compile/ds030.stderr b/testsuite/tests/deSugar/should_compile/ds030.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds030.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds031.hs b/testsuite/tests/deSugar/should_compile/ds031.hs new file mode 100644 index 0000000000..5f25c15b19 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds031.hs @@ -0,0 +1,7 @@ +module ShouldCompile where + +foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b) +foldPair fg ab [] = ab +foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v) + where (u,v) = foldPair fg ab abs + diff --git a/testsuite/tests/deSugar/should_compile/ds031.stderr b/testsuite/tests/deSugar/should_compile/ds031.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds031.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds032.hs b/testsuite/tests/deSugar/should_compile/ds032.hs new file mode 100644 index 0000000000..09e2de15a7 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds032.hs @@ -0,0 +1,17 @@ +-- !!! recursive funs tangled in an AbsBind + +module ShouldCompile where + + +flatten :: Int -- Indentation + -> Bool -- True => just had a newline + -> Float -- Current seq to flatten + -> [(Int,Float)]-- Work list with indentation + -> String + +flatten n nlp 0.0 seqs = flattenS nlp seqs +flatten n nlp 1.0 seqs = flatten n nlp 1.1 ((n,1.2) : seqs) + +flattenS :: Bool -> [(Int, Float)] -> String +flattenS nlp [] = "" +flattenS nlp ((col,seq):seqs) = flatten col nlp seq seqs diff --git a/testsuite/tests/deSugar/should_compile/ds032.stderr b/testsuite/tests/deSugar/should_compile/ds032.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds032.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds033.hs b/testsuite/tests/deSugar/should_compile/ds033.hs new file mode 100644 index 0000000000..9d89a936c7 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds033.hs @@ -0,0 +1,15 @@ +-- !!! getting top-level dependencies right +-- +module ShouldCompile where + +f1 x = g1 x +g1 y = y + +g2 y = y +f2 x = g2 x + +f3 x = g3 x +g3 y = f3 y + +g4 y = f4 y +f4 x = g4 x diff --git a/testsuite/tests/deSugar/should_compile/ds033.stderr b/testsuite/tests/deSugar/should_compile/ds033.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds033.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds034.hs b/testsuite/tests/deSugar/should_compile/ds034.hs new file mode 100644 index 0000000000..0725a7a97f --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds034.hs @@ -0,0 +1,11 @@ +-- !!! mutually-recursive methods in an instance declaration +-- +module ShouldCompile where + +class Foo a where + op1 :: a -> a + op2 :: a -> a + +instance Foo Int where + op1 x = op2 x + op2 y = op1 y diff --git a/testsuite/tests/deSugar/should_compile/ds034.stderr b/testsuite/tests/deSugar/should_compile/ds034.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds034.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds035.hs b/testsuite/tests/deSugar/should_compile/ds035.hs new file mode 100644 index 0000000000..b3d8568a14 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds035.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE MagicHash, BangPatterns #-} +module ShouldCompile where + +import GHC.Exts + +data CList = CNil | CCons Int# CList + +mk :: Int# -> CList +mk n = case (n ==# 0#) of + False -> CNil + _ -> CCons 1# (mk (n -# 1#)) + +clen :: CList -> Int# +clen CNil = 0# +clen (CCons _ cl) = 1# +# (clen cl) + +main = putStr (case len4_twice of + 8# -> "bingo\n" + _ -> "oops\n") + where + list4 = mk 4# + !len4 = clen list4 + !len4_twice = len4 +# len4 diff --git a/testsuite/tests/deSugar/should_compile/ds035.stderr b/testsuite/tests/deSugar/should_compile/ds035.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds035.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds036.hs b/testsuite/tests/deSugar/should_compile/ds036.hs new file mode 100644 index 0000000000..12b90ed3ab --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds036.hs @@ -0,0 +1,47 @@ +{- +From dmc@minster.york.ac.uk Tue Mar 10 17:15:20 1992 +Via: uk.ac.york.minster; Tue, 10 Mar 92 17:15:14 GMT +Message-Id: <swordfish.700247842@minster.york.ac.uk> +From: dmc@minster.york.ac.uk +To: partain +Date: 10 Mar 1992 17:17:21 GMT + +Will, + +I have just started using Haskell at York and have found a compilation +error in the code below which disappears when the last line is +commented out +-} + +{-# LANGUAGE NPlusKPatterns #-} + +module ShouldCompile where + +--brack :: (Eq a) => a -> a -> [a] -> ([a],[a]) +--brack open close = brack' open close (1 :: Int) + +brack' :: (Eq a) => a -> a -> Int -> [a] -> ([a],[a]) +brack' open close 0 xs = ([],xs) +brack' open close (n+1) [] = ([],[]) +brack' open close (n+1) (h:t) | h == open = ([],[]) + +{- +Is this something I have done wrong or a fault with the compiler? + +Cheers +Dave + + +----------------------------------------------------------------------- +David Cattrall Telephone +44 904 432777 +Department of Computer Science +University of York JANET: dmc@uk.ac.york.minster +YORK Y01 5DD +United Kingdom UUNET: uucp!ukc!minster!dmc +----------------------------------------------------------------------- +-} + +-- and this was Kevin's idea, subsequently... + +kh (n+2) x | x > n = x * 2 +kh (x+1) (m+1) = m diff --git a/testsuite/tests/deSugar/should_compile/ds036.stderr b/testsuite/tests/deSugar/should_compile/ds036.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds036.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds037.hs b/testsuite/tests/deSugar/should_compile/ds037.hs new file mode 100644 index 0000000000..d5fc1300f3 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds037.hs @@ -0,0 +1,6 @@ +-- !!! AbsBinds with tyvars, no dictvars, but some dict binds +-- +module ShouldCompile where + +f x y = (fst (g y x), x+(1::Int)) +g x y = (fst (f x y), y+(1::Int)) diff --git a/testsuite/tests/deSugar/should_compile/ds037.stderr b/testsuite/tests/deSugar/should_compile/ds037.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds037.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds038.hs b/testsuite/tests/deSugar/should_compile/ds038.hs new file mode 100644 index 0000000000..3accf7cf42 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds038.hs @@ -0,0 +1,12 @@ +-- !!! Jon Hill reported a bug in desugaring this in 0.09 +-- !!! (recursive with n+k patts) +-- + +{-# LANGUAGE NPlusKPatterns #-} + +module ShouldCompile where + +takeList :: Int -> [a] -> [a] +takeList 0 _ = [] +takeList (n+1) [] = [] +takeList (n+1) (x:xs) = x : takeList n xs diff --git a/testsuite/tests/deSugar/should_compile/ds038.stderr b/testsuite/tests/deSugar/should_compile/ds038.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds038.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds039.hs b/testsuite/tests/deSugar/should_compile/ds039.hs new file mode 100644 index 0000000000..ad000a5c9f --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds039.hs @@ -0,0 +1,7 @@ +-- !!! make sure correct type applications get put in +-- !!! when (:) is saturated. + +module ShouldCompile where + + +f = (:) diff --git a/testsuite/tests/deSugar/should_compile/ds039.stderr b/testsuite/tests/deSugar/should_compile/ds039.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds039.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds040.hs b/testsuite/tests/deSugar/should_compile/ds040.hs new file mode 100644 index 0000000000..c99f5fab63 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds040.hs @@ -0,0 +1,18 @@ + +{-# LANGUAGE NPlusKPatterns #-} + +module ShouldCompile where + +-- !!! Another bug in overloaded n+k patts +-- + +main = print ((4::Int) ^^^^ (6::Int)) + +(^^^^) :: (Num a, Integral b) => a -> b -> a +x ^^^^ 0 = 1 +x ^^^^ (n+1) = f x n x + where f _ 0 y = y + f x n y = g x n where + g x n | even n = g (x*x) (n `quot` 2) + | otherwise = f x (n-1) (x*y) +_ ^^^^ _ = error "(^^^^){Prelude}: negative exponent" diff --git a/testsuite/tests/deSugar/should_compile/ds040.stderr-ghc b/testsuite/tests/deSugar/should_compile/ds040.stderr-ghc new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds040.stderr-ghc diff --git a/testsuite/tests/deSugar/should_compile/ds041.hs b/testsuite/tests/deSugar/should_compile/ds041.hs new file mode 100644 index 0000000000..90c1c22b4d --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds041.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DatatypeContexts #-} +{- In 2.05 this one crashed with + + Fail: "basicTypes/Id.lhs", line 990: incomplete pattern(s) + to match in function "dataConFieldLabels" + + Reason: dsExpr (RecordCon ...) didn't extract + the constructor properly. +-} + +module ShouldCompile where + +data Eq a => Foo a = Foo { x :: a } + +foo :: Eq a => Foo a +foo = Foo{} + diff --git a/testsuite/tests/deSugar/should_compile/ds041.stderr-ghc b/testsuite/tests/deSugar/should_compile/ds041.stderr-ghc new file mode 100644 index 0000000000..acf3e1ae6f --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds041.stderr-ghc @@ -0,0 +1,8 @@ + +ds041.hs:1:14: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + +ds041.hs:16:7: + Warning: Fields of `Foo' not initialised: x + In the expression: Foo {} + In an equation for `foo': foo = Foo {} diff --git a/testsuite/tests/deSugar/should_compile/ds042.hs b/testsuite/tests/deSugar/should_compile/ds042.hs new file mode 100644 index 0000000000..e3f928d8d9 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds042.hs @@ -0,0 +1,8 @@ +-- !!! Guard on a tuple pattern, broke 4.01 due to the +-- !!! special handling of unboxed tuples in desugarer. +module ShouldCompile where + +f :: Int -> (Int,Int) +f x = + case f x of + (a,b) | a > 0 -> f (x-1) diff --git a/testsuite/tests/deSugar/should_compile/ds043.hs b/testsuite/tests/deSugar/should_compile/ds043.hs new file mode 100644 index 0000000000..5c7d746b8b --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds043.hs @@ -0,0 +1,11 @@ +-- !!! Checking the exhaustiveness of constructor +-- !!! with labelled fields. +module ShouldCompile where + +data E = B { a,b,c,d,e,f :: Bool } + +bug x = + case x of + B _ _ _ _ True False -> undefined + B {e=True, f=False} -> undefined + B {a=a,f=False,e=False} -> undefined diff --git a/testsuite/tests/deSugar/should_compile/ds043.stderr-ghc b/testsuite/tests/deSugar/should_compile/ds043.stderr-ghc new file mode 100644 index 0000000000..8529a8c737 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds043.stderr-ghc @@ -0,0 +1,4 @@ + +ds043.hs:8:2: + Warning: Pattern match(es) are overlapped + In a case alternative: B {e = True, f = False} -> ... diff --git a/testsuite/tests/deSugar/should_compile/ds044.hs b/testsuite/tests/deSugar/should_compile/ds044.hs new file mode 100644 index 0000000000..fddf19499e --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds044.hs @@ -0,0 +1,10 @@ +-- !!! Use of empty record patterns for constructors +-- !!! that don't have any labelled fields. According +-- !!! to the report, this isn't illegal. +module ShouldCompile where + +data F = F Int Int + | G + +isF F{} = True +isF _ = False diff --git a/testsuite/tests/deSugar/should_compile/ds045.hs b/testsuite/tests/deSugar/should_compile/ds045.hs new file mode 100644 index 0000000000..5688a530e1 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds045.hs @@ -0,0 +1,18 @@ + +{-# LANGUAGE NPlusKPatterns #-} + +-- !!! N-plus-K pattern in binding + +-- From: Andreas Marth +-- Sent: Monday, June 07, 1999 5:02 PM +-- To: glasgow-haskell-bugs@majordomo.haskell.org +-- Subject: compiler-bug + +module ShouldCompile where + +erroR :: Int +erroR = n where + (n+1,_) = (5,2) + +-- Produced a -dcore-lint error in the desugarer output +-- (Was a missing case in DsHsSyn.collectTypedPatBinders) diff --git a/testsuite/tests/deSugar/should_compile/ds046.hs b/testsuite/tests/deSugar/should_compile/ds046.hs new file mode 100644 index 0000000000..7096f2bdf0 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds046.hs @@ -0,0 +1,41 @@ +module ShouldCompile where + +-- Strict field unpacking tests: compile with -O -funbox-strict-fields. + +-- test 1: simple unboxed int field +data T = T !Int +t (T i) = i + 1 + +-- test 2: mutual recursion (should back off from unboxing either field) +data R = R !S +data S = S !R + +r (R s) = s + +-- test 3: multi-level unboxing +data A = A Int !B Int +data B = B !Int + +f = A 1 (B 2) 1 +g (A x (B y) z) = A x (B (y+2)) z +h (A x (B y) z) = y + 2 + +-- test 4: flattening nested tuples +data C = C !(Int,Int) +j (C (a,b)) = a + b + +-- test 5: polymorphism, multiple strict fields +data D a b = D Int !(a,b) !(E Int) +data E a = E a +k (D a (b,c) (E d)) = a + b + c + d + +-- test 6: records +data F a b = F { x :: !Int, y :: !(Float,Float), z :: !(a,b) } +l F{x = a} = a +m (F a b c) = a +n F{z = (a,b)} = a + +-- test 7: newtypes +newtype G a b = G (F a b) +data H a b = H !Int !(G a b) !Int +o (H y (G (F{ x=x })) z) = x + z diff --git a/testsuite/tests/deSugar/should_compile/ds047.hs b/testsuite/tests/deSugar/should_compile/ds047.hs new file mode 100644 index 0000000000..f6ee2b5dc7 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds047.hs @@ -0,0 +1,9 @@ +-- !!! Nullary rec-pats for constructors that hasn't got any labelled +-- !!! fields is legal Haskell, and requires extra care in the desugarer. +module ShouldCompile where + +data X = X Int [Int] + +f :: X -> Int +f (X _ []) = 0 +f X{} = 1 diff --git a/testsuite/tests/deSugar/should_compile/ds048.hs b/testsuite/tests/deSugar/should_compile/ds048.hs new file mode 100644 index 0000000000..9274aacbea --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds048.hs @@ -0,0 +1,7 @@ +-- !!! newtypes with a labelled field. +module ShouldCompile where + +newtype Foo = Foo { x :: Int } deriving (Eq) + +f :: Foo -> Foo -> Int +f a b = x a + x b diff --git a/testsuite/tests/deSugar/should_compile/ds050.hs b/testsuite/tests/deSugar/should_compile/ds050.hs new file mode 100644 index 0000000000..be88654d7e --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds050.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Rank2Types #-} + +module ShouldCompile where + +data Q = Q {f :: forall a. a -> a} +g1 = f +g2 x = f x +g3 x y = f x y diff --git a/testsuite/tests/deSugar/should_compile/ds051.hs b/testsuite/tests/deSugar/should_compile/ds051.hs new file mode 100644 index 0000000000..70c51a792f --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds051.hs @@ -0,0 +1,33 @@ +module ShouldCompile where + +-- !!! test the overlapping patterns detection. + +-- f1 overlaps +f1 "ab" = [] +f1 "ab" = [] +f1 _ = [] + +-- f2 overlaps +f2 "ab" = [] +f2 ('a':'b':[]) = [] +f2 _ = [] + +-- f3 overlaps +f3 ('a':'b':[]) = [] +f3 "ab" = [] +f3 _ = [] + +-- f4 doesn't overlap +f4 "ab" = [] +f4 ('a':'b':'c':[]) = [] +f4 _ = [] + +-- f5 doesn't overlap +f5 ('a':'b':'c':[]) = [] +f5 "ab" = [] +f5 _ = [] + +-- f6 doesn't overlap +f6 "ab" = [] +f6 ('a':[]) = [] +f6 _ = [] diff --git a/testsuite/tests/deSugar/should_compile/ds051.stderr-ghc b/testsuite/tests/deSugar/should_compile/ds051.stderr-ghc new file mode 100644 index 0000000000..a098efee33 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds051.stderr-ghc @@ -0,0 +1,12 @@ + +ds051.hs:6:1: + Warning: Pattern match(es) are overlapped + In an equation for `f1': f1 "ab" = ... + +ds051.hs:11:1: + Warning: Pattern match(es) are overlapped + In an equation for `f2': f2 ('a' : 'b' : []) = ... + +ds051.hs:16:1: + Warning: Pattern match(es) are overlapped + In an equation for `f3': f3 "ab" = ... diff --git a/testsuite/tests/deSugar/should_compile/ds052.hs b/testsuite/tests/deSugar/should_compile/ds052.hs new file mode 100644 index 0000000000..08612aec98 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds052.hs @@ -0,0 +1,7 @@ +{-# OPTIONS -fwarn-incomplete-patterns #-} +module ShouldCompile where + +-- should *not* produce a warning about non-exhaustive patterns +lazyZip:: [a] -> [b] -> [(a, b)] +lazyZip [] _ = [] +lazyZip (x:xs) ~(y:ys) = (x, y):lazyZip xs ys diff --git a/testsuite/tests/deSugar/should_compile/ds052.stderr b/testsuite/tests/deSugar/should_compile/ds052.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds052.stderr diff --git a/testsuite/tests/deSugar/should_compile/ds053.hs b/testsuite/tests/deSugar/should_compile/ds053.hs new file mode 100644 index 0000000000..4069c614d5 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds053.hs @@ -0,0 +1,5 @@ +{-# OPTIONS -fwarn-unused-binds #-} +module ShouldCompile() where + +-- should warn about unused f, even though f is used in itself +f = f diff --git a/testsuite/tests/deSugar/should_compile/ds053.stderr-ghc b/testsuite/tests/deSugar/should_compile/ds053.stderr-ghc new file mode 100644 index 0000000000..3bce906869 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds053.stderr-ghc @@ -0,0 +1,2 @@ + +ds053.hs:5:1: Warning: Defined but not used: `f' diff --git a/testsuite/tests/deSugar/should_compile/ds054.hs b/testsuite/tests/deSugar/should_compile/ds054.hs new file mode 100644 index 0000000000..7b05409adf --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds054.hs @@ -0,0 +1,8 @@ +-- fails core-lint in 6.2 +module ShouldCompile where + +newtype Foo = Foo [Foo] +newtype Bar = Bar Foo + +unBar :: Bar -> Foo +unBar (Bar x) = x diff --git a/testsuite/tests/deSugar/should_compile/ds055.hs b/testsuite/tests/deSugar/should_compile/ds055.hs new file mode 100644 index 0000000000..280fe968d2 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds055.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-} +
+-- This module requires quite trick desugaring,
+-- because of the context in the existentials
+-- It broke a pre 6.4 GHC
+
+module Foo where
+
+ import Data.Data
+ import Data.HashTable
+
+ data Item = forall a. (Data a) => Leaf Bool a
+ | forall a. (Data a) => Branch Bool a Int Int
+ deriving (Typeable)
+
+
+ instance Data Item where
+ gfoldl k z (Leaf b v) = z (Leaf b) `k` v
+ gfoldl k z (Branch b v a1 a2) = z (\x -> Branch b x a1 a2) `k` v
+ gunfold _ _ _ = error "urk"
+ toConstr (Leaf _ _) = leafConstr
+ toConstr (Branch _ _ _ _) = branchConstr
+ dataTypeOf _ = itemDataType
+
+ itemDataType = mkDataType "Subliminal.Item" [leafConstr, branchConstr]
+ leafConstr = mkConstr itemDataType "Leaf" [] Prefix
+ branchConstr = mkConstr itemDataType "Branch" [] Prefix
+
+
+
diff --git a/testsuite/tests/deSugar/should_compile/ds056.hs b/testsuite/tests/deSugar/should_compile/ds056.hs new file mode 100644 index 0000000000..77c3860112 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds056.hs @@ -0,0 +1,14 @@ +-- Check overlap in n+k patterns + +{-# LANGUAGE NPlusKPatterns #-} + +module Foo where + +g :: Int -> Int +g (x+1) = x +g y = y +g _ = 0 -- Overlapped + +h :: Int -> Int +h (x+1) = x +h _ = 0 -- Not overlapped diff --git a/testsuite/tests/deSugar/should_compile/ds056.stderr b/testsuite/tests/deSugar/should_compile/ds056.stderr new file mode 100644 index 0000000000..6e0972bef4 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds056.stderr @@ -0,0 +1,4 @@ + +ds056.hs:8:1: + Warning: Pattern match(es) are overlapped + In an equation for `g': g _ = ... diff --git a/testsuite/tests/deSugar/should_compile/ds057.hs b/testsuite/tests/deSugar/should_compile/ds057.hs new file mode 100644 index 0000000000..23bf5d3645 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds057.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MagicHash, BangPatterns, UnboxedTuples #-} +module ShouldCompile where + +import Data.Word +import GHC.Ptr +import GHC.Exts + +f# :: Int# -> (# Char#, Int# #) +f# a# = (# '\0'#, a# #) + +g :: Int -> (Char, Int) +g (I# a#) = ( C# c#, I# b# ) + where !(# c#, b# #) = f# a# diff --git a/testsuite/tests/deSugar/should_compile/ds058.hs b/testsuite/tests/deSugar/should_compile/ds058.hs new file mode 100644 index 0000000000..0b83d0bd32 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds058.hs @@ -0,0 +1,8 @@ +-- Test overlapping pattern warnings + +module ShouldCompile where + +f x = case x of + Just (~1) -> 0 + Just _ -> 1 -- This one cannot match + Nothing -> 2 diff --git a/testsuite/tests/deSugar/should_compile/ds058.stderr b/testsuite/tests/deSugar/should_compile/ds058.stderr new file mode 100644 index 0000000000..fb504cc514 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds058.stderr @@ -0,0 +1,4 @@ + +ds058.hs:5:7: + Warning: Pattern match(es) are overlapped + In a case alternative: Just _ -> ... diff --git a/testsuite/tests/deSugar/should_compile/ds059.hs b/testsuite/tests/deSugar/should_compile/ds059.hs new file mode 100644 index 0000000000..f8385726b7 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds059.hs @@ -0,0 +1,33 @@ +{-# OPTIONS -fwarn-incomplete-patterns #-} + +-- Test for incomplete-pattern warnings +-- None should cause a warning + +module ShouldCompile where + +-- These ones gave bogus warnings in 6.2 + +data D = D1 { f1 :: Int } | D2 + +-- Use pattern matching in the argument +f :: D -> D +f d1@(D1 {f1 = n}) = d1 { f1 = f1 d1 + n } -- Warning here +f d = d + +-- Use case pattern matching +g :: D -> D +g d1 = case d1 of + D1 { f1 = n } -> d1 { f1 = n + 1 } -- Warning here also + D2 -> d1 + +-- These ones were from Neil Mitchell +-- no warning +ex1 x = ss + where (_s:ss) = x + +-- no warning +ex2 x = let (_s:ss) = x in ss + +-- Warning: Pattern match(es) are non-exhaustive +-- In a case alternative: Patterns not matched: [] +ex3 x = case x of ~(_s:ss) -> ss diff --git a/testsuite/tests/deSugar/should_compile/ds060.hs b/testsuite/tests/deSugar/should_compile/ds060.hs new file mode 100644 index 0000000000..b822605742 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds060.hs @@ -0,0 +1,25 @@ + +-- Test for trac #322 + +module ShouldCompile where + +instance (Num a) => Num (Maybe a) where + (Just a) + (Just b) = Just (a + b) + _ + _ = Nothing + (Just a) - (Just b) = Just (a - b) + _ - _ = Nothing + (Just a) * (Just b) = Just (a * b) + _ * _ = Nothing + negate (Just a) = Just (negate a) + negate _ = Nothing + abs (Just a) = Just (abs a) + abs _ = Nothing + signum (Just a) = Just (signum a) + signum _ = Nothing + fromInteger = Just . fromInteger + +f :: Maybe Int -> Int +f 1 = 1 +f Nothing = 2 -- Gives bogus "Warning: Pattern match(es) are overlapped" +f _ = 3 + diff --git a/testsuite/tests/deSugar/should_compile/ds061.hs b/testsuite/tests/deSugar/should_compile/ds061.hs new file mode 100644 index 0000000000..271bbbbc60 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds061.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE NPlusKPatterns #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -Wall #-} + +-- Test for trac #851 +-- Should not give a non-exhaustive pattern warning + +module ShouldCompile where + +import Data.Word + +f :: Word -> Bool +f 0 = True +f (_n + 1) = False + diff --git a/testsuite/tests/deSugar/should_compile/ds062.hs b/testsuite/tests/deSugar/should_compile/ds062.hs new file mode 100644 index 0000000000..18bd5d53e5 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds062.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall #-} + +module ShouldCompile where + +f :: String -> Int +f x | null x = 1 + | otherwise = 2 + +-- Should not give a non-exhaustive-patterns error +-- See Trac #1759 + diff --git a/testsuite/tests/deSugar/should_compile/ds063.hs b/testsuite/tests/deSugar/should_compile/ds063.hs new file mode 100644 index 0000000000..74bde90887 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/ds063.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ViewPatterns #-} + +module ShouldCompile where + +f :: Int -> Int +f ((+1) -> 1) = 5 +f _ = 3 + +-- Should not give an overlapping-patterns or non-exhaustive-patterns error +-- See Trac #2395 |