diff options
Diffstat (limited to 'testsuite/tests/deSugar')
208 files changed, 2351 insertions, 0 deletions
diff --git a/testsuite/tests/deSugar/Makefile b/testsuite/tests/deSugar/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/deSugar/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk 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 diff --git a/testsuite/tests/deSugar/should_run/Makefile b/testsuite/tests/deSugar/should_run/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/deSugar/should_run/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/deSugar/should_run/T246.hs b/testsuite/tests/deSugar/should_run/T246.hs new file mode 100644 index 0000000000..835e618b79 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T246.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- Test Trac #246 + +module Main where + +import Control.Exception + +data T = T { x :: Bool, y :: Bool } + +f (T { y=True, x=True }) = "Odd" +f _ = "OK" + +g (T { x=True, y=True }) = "Odd2" +g _ = "Odd3" + +funny = T { x = undefined, y = False } + +main = do { print (f funny) -- Should work, because we test + -- y first, which fails, and falls + -- through to "OK" + + ; Control.Exception.catch + (print (g funny)) -- Should fail, because we test + (\(_::SomeException) -> print "caught") -- x first, and hit "undefined" + } diff --git a/testsuite/tests/deSugar/should_run/T246.stdout b/testsuite/tests/deSugar/should_run/T246.stdout new file mode 100644 index 0000000000..f266ecc65d --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T246.stdout @@ -0,0 +1,2 @@ +"OK" +"caught" diff --git a/testsuite/tests/deSugar/should_run/T3126.hs b/testsuite/tests/deSugar/should_run/T3126.hs new file mode 100644 index 0000000000..811ddc1fa7 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T3126.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where +import Data.String + +-- {{{ Num literals +newtype N = N Int deriving (Show,Eq) + +instance Num N where + fromInteger 0 = error "0" + fromInteger 1 = N 0 + fromInteger _ = N 1 + +f x = case x of + 1 -> False + 0 -> True + +g x = case x of + 1 -> False + _ -> case x of + 0 -> True + _ -> error "No match" + +testNum = do + print $ g (N 0) + print $ f (N 0) + +-- }}} + +-- {{{ IsString literals +newtype S = S String deriving Eq + +instance IsString S where + fromString [] = error "[]" + fromString (_:_) = S "." + +fs x = case x of + "." -> False + "" -> True + +gs x = case x of + "." -> False + _ -> case x of + "" -> True + _ -> error "No match" + +testIsString = do + print $ gs (S ".") + print $ fs (S ".") + +-- }}} + +main = do { testNum; testIsString } + diff --git a/testsuite/tests/deSugar/should_run/T3126.stdout b/testsuite/tests/deSugar/should_run/T3126.stdout new file mode 100644 index 0000000000..3367978a7b --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T3126.stdout @@ -0,0 +1,4 @@ +False +False +False +False diff --git a/testsuite/tests/deSugar/should_run/T3382.hs b/testsuite/tests/deSugar/should_run/T3382.hs new file mode 100644 index 0000000000..800256a1f0 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T3382.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -XOverloadedStrings #-}
+module Main where
+
+import Data.String
+
+instance IsString Int where
+ fromString x = 1337
+
+f :: Int -> String
+f "hello" = "correct"
+f _ = "false"
+
+main = do print $ f 1337
+ print $ f 1338
diff --git a/testsuite/tests/deSugar/should_run/T3382.stdout b/testsuite/tests/deSugar/should_run/T3382.stdout new file mode 100644 index 0000000000..a92f13b57a --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T3382.stdout @@ -0,0 +1,2 @@ +"correct"
+"false"
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T new file mode 100644 index 0000000000..9c8664d64b --- /dev/null +++ b/testsuite/tests/deSugar/should_run/all.T @@ -0,0 +1,39 @@ +# Args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero + +test('dsrun001', normal, compile_and_run, ['']) +test('dsrun002', normal, compile_and_run, ['']) +test('dsrun003', normal, compile_and_run, ['']) +test('dsrun004', normal, compile_and_run, ['']) +test('dsrun005', exit_code(1), compile_and_run, ['']) +test('dsrun006', normal, compile_and_run, ['']) +test('dsrun007', exit_code(1), compile_and_run, ['']) +test('dsrun008', exit_code(1), compile_and_run, ['']) +test('dsrun009', normal, compile_and_run, ['']) +test('dsrun010', normal, compile_and_run, ['']) +test('dsrun011', skip_if_fast, compile_and_run, ['']) +test('dsrun012', skip_if_fast, compile_and_run, ['']) +test('dsrun013', normal, compile_and_run, ['']) +test('dsrun014', expect_broken_for(1257, ['ghci']), compile_and_run, ['']) +test('dsrun015', normal, compile_and_run, ['']) +test('dsrun016', normal, compile_and_run, ['']) +test('dsrun017', normal, compile_and_run, ['']) +test('dsrun018', normal, compile_and_run, ['']) +test('dsrun019', normal, compile_and_run, ['']) +test('dsrun020', normal, compile_and_run, ['']) +test('dsrun021', normal, compile_and_run, ['']) +test('dsrun022', normal, compile_and_run, ['']) +test('dsrun023', normal, compile_and_run, ['']) +test('T246', normal, compile_and_run, ['']) +test('T3126', normal, compile_and_run, ['']) +test('T3382', normal, compile_and_run, ['']) +test('mc01', normal, compile_and_run, ['']) +test('mc02', normal, compile_and_run, ['']) +test('mc03', normal, compile_and_run, ['']) +test('mc04', normal, compile_and_run, ['']) +test('mc05', normal, compile_and_run, ['']) +test('mc06', normal, compile_and_run, ['']) +test('mc07', normal, compile_and_run, ['']) +test('mc08', normal, compile_and_run, ['']) diff --git a/testsuite/tests/deSugar/should_run/dsrun001.hs b/testsuite/tests/deSugar/should_run/dsrun001.hs new file mode 100644 index 0000000000..e40ea2a11d --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun001.hs @@ -0,0 +1,12 @@ +{- Check that list comprehensions can be written + in do-notation. This actually broke 2.02, with + a pattern match failure in dsListComp! +-} + +module Main where + +main = putStrLn (show theList) +theList = do x <- [1..3] + y <- [1..3] + return (x,y) + diff --git a/testsuite/tests/deSugar/should_run/dsrun001.stdout b/testsuite/tests/deSugar/should_run/dsrun001.stdout new file mode 100644 index 0000000000..a375d0fe24 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun001.stdout @@ -0,0 +1 @@ +[(1,1),(1,2),(1,3),(2,1),(2,2),(2,3),(3,1),(3,2),(3,3)] diff --git a/testsuite/tests/deSugar/should_run/dsrun002.hs b/testsuite/tests/deSugar/should_run/dsrun002.hs new file mode 100644 index 0000000000..acad275f74 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun002.hs @@ -0,0 +1,14 @@ +{- Tests let-expressions in do-statments -} + +module Main( main ) where + +foo = do + putStr "a" + let x = "b" in putStr x + putStr "c" + +main = do + putStr "a" + foo + let x = "b" in putStrLn x + diff --git a/testsuite/tests/deSugar/should_run/dsrun002.stdout b/testsuite/tests/deSugar/should_run/dsrun002.stdout new file mode 100644 index 0000000000..660eacecf5 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun002.stdout @@ -0,0 +1 @@ +aabcb diff --git a/testsuite/tests/deSugar/should_run/dsrun003.hs b/testsuite/tests/deSugar/should_run/dsrun003.hs new file mode 100644 index 0000000000..d100bff718 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun003.hs @@ -0,0 +1,13 @@ +-- Tests match on empty field lists + +module Main where + +data Person = Female {firstName, lastName :: String} + | Male {firstName, lastName :: String} + deriving (Show) + +isFemale (Female{}) = True +isFemale (Male{}) = False + +main = print (isFemale (Female {firstName = "Jane", lastName = "Smith"})) + diff --git a/testsuite/tests/deSugar/should_run/dsrun003.stdout b/testsuite/tests/deSugar/should_run/dsrun003.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun003.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/deSugar/should_run/dsrun004.hs b/testsuite/tests/deSugar/should_run/dsrun004.hs new file mode 100644 index 0000000000..8f54e330e1 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun004.hs @@ -0,0 +1,13 @@ +-- Test n+k patterns + +{-# LANGUAGE NPlusKPatterns #-} + +module Main where + +f (n+1) = n + +g :: Int -> Int +g (n+4) = n + +main = print (f 3) >> + print (g 9) diff --git a/testsuite/tests/deSugar/should_run/dsrun004.stdout b/testsuite/tests/deSugar/should_run/dsrun004.stdout new file mode 100644 index 0000000000..49ae94bb33 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun004.stdout @@ -0,0 +1,2 @@ +2 +5 diff --git a/testsuite/tests/deSugar/should_run/dsrun005.hs b/testsuite/tests/deSugar/should_run/dsrun005.hs new file mode 100644 index 0000000000..238a2c3410 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun005.hs @@ -0,0 +1,46 @@ +{- + +From: Olaf Chitil <chitil@Informatik.RWTH-Aachen.DE> + +It is a problem with 0.29 (which we use for compiling 2.01), it is gone +in 2.01. + + f :: Eq a => a -> [b] -> [b] -> Bool + f a [] [] = (a==a) + main = print (f True "" "Hallo") + + +when run after compilation with 0.29 you get: +Fail: "test.hs", line 6: incomplete pattern(s) to match in function "ds.d5b4" + +while 2.01 gives you as desired +Fail: In pattern-matching: function f{-aYw-}; at test.hs, line 6 + +The problem is the dictionary, because for the program + + f :: a -> [b] -> [b] -> Bool + f a [] [] = True + main = print (f True "" "Hallo") + +0.29 gives the function name "f" as well. + +So it's ok in 2.01, but why did you change the form of the error messages? +"incomplete pattern(s) to match" is more informative then "In pattern-matching"! +I even prefer the order of information in the 0.29 error messages. + +May I finally repeat that in my opinion the compiler should warn about +incomplete patterns during compilation. However, I suppose the +incomplete patterns are just recognised by the desugarer which does +not produce error messages any more. + +-} + + +module Main where + +f :: Eq a => a -> [b] -> [b] -> Bool +f a [] [] = (a==a) + +main = print (f True "" "Hallo") + + diff --git a/testsuite/tests/deSugar/should_run/dsrun005.stderr b/testsuite/tests/deSugar/should_run/dsrun005.stderr new file mode 100644 index 0000000000..73718fc858 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun005.stderr @@ -0,0 +1,2 @@ +dsrun005: dsrun005.hs:42:1-18: Non-exhaustive patterns in function f + diff --git a/testsuite/tests/deSugar/should_run/dsrun005.stderr-hugs b/testsuite/tests/deSugar/should_run/dsrun005.stderr-hugs new file mode 100644 index 0000000000..e9fed4ae3a --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun005.stderr-hugs @@ -0,0 +1 @@ +dsrun005: pattern match failure diff --git a/testsuite/tests/deSugar/should_run/dsrun005.stdout b/testsuite/tests/deSugar/should_run/dsrun005.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun005.stdout diff --git a/testsuite/tests/deSugar/should_run/dsrun006.hs b/testsuite/tests/deSugar/should_run/dsrun006.hs new file mode 100644 index 0000000000..759c9c542d --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun006.hs @@ -0,0 +1,33 @@ +{- +Date: Tue, 20 May 1997 05:10:04 GMT +From: Tomasz Cholewo <tjchol01@mecca.spd.louisville.edu> + +ghc-2.03 cannot compile the following code, which I think is correct +according to the Report + + data X = A {a :: Int} | B {a :: Int} + +The error message is: + + Conflicting definitions for: a + Defined at bug4.lhs:2 + Defined at bug4.lhs:2 + +In addition the following snippet + + data X = A {a :: Int} + y = let A {a} = x + in a + +fails with: + + bug4.lhs:4:5: Not a valid LHS on input: "in" +-} +--module Main(main) where + +data X = A {a :: Int} | B {a :: Int} + +f x = let A {a=a} = x + in a + +main = print (f (A {a = 3})) diff --git a/testsuite/tests/deSugar/should_run/dsrun006.stdout b/testsuite/tests/deSugar/should_run/dsrun006.stdout new file mode 100644 index 0000000000..00750edc07 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun006.stdout @@ -0,0 +1 @@ +3 diff --git a/testsuite/tests/deSugar/should_run/dsrun007.hs b/testsuite/tests/deSugar/should_run/dsrun007.hs new file mode 100644 index 0000000000..19a0c641cb --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun007.hs @@ -0,0 +1,5 @@ +data T = C Int + +unpick (C i) = i + 1 + +main = print (unpick (C{}))
\ No newline at end of file diff --git a/testsuite/tests/deSugar/should_run/dsrun007.stderr b/testsuite/tests/deSugar/should_run/dsrun007.stderr new file mode 100644 index 0000000000..f313633803 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun007.stderr @@ -0,0 +1,2 @@ +dsrun007: dsrun007.hs:5:23-25: Missing field in record construction + diff --git a/testsuite/tests/deSugar/should_run/dsrun007.stderr-hugs b/testsuite/tests/deSugar/should_run/dsrun007.stderr-hugs new file mode 100644 index 0000000000..8941f55132 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun007.stderr-hugs @@ -0,0 +1 @@ +dsrun007: undefined field: C diff --git a/testsuite/tests/deSugar/should_run/dsrun008.hs b/testsuite/tests/deSugar/should_run/dsrun008.hs new file mode 100644 index 0000000000..c055da563c --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun008.hs @@ -0,0 +1,2 @@ +-- !!! Double irrefutable pattern (bug in Hugs98, 29/8/2001) +main = print (case (1,2) of ~(~(2,x)) -> x) diff --git a/testsuite/tests/deSugar/should_run/dsrun008.stderr b/testsuite/tests/deSugar/should_run/dsrun008.stderr new file mode 100644 index 0000000000..ff7de054f2 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun008.stderr @@ -0,0 +1,2 @@ +dsrun008: dsrun008.hs:2:15-42: Irrefutable pattern failed for pattern (2, x) + diff --git a/testsuite/tests/deSugar/should_run/dsrun008.stderr-hugs b/testsuite/tests/deSugar/should_run/dsrun008.stderr-hugs new file mode 100644 index 0000000000..18ee3730c2 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun008.stderr-hugs @@ -0,0 +1 @@ +dsrun008: pattern match failure diff --git a/testsuite/tests/deSugar/should_run/dsrun009.hs b/testsuite/tests/deSugar/should_run/dsrun009.hs new file mode 100644 index 0000000000..104f1af2e3 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun009.hs @@ -0,0 +1,16 @@ +-- !!! Test that 'negate' is used properly to construct negative literals + +main = print (minusTwo,trueOrFalse) + +minusTwo = -2::N + +trueOrFalse = + case minusTwo of + -2 -> True + _ -> False + +data N = Negate N | FromInteger Integer deriving (Eq,Show) + +instance Num N where + negate = Negate + fromInteger = FromInteger diff --git a/testsuite/tests/deSugar/should_run/dsrun009.stdout b/testsuite/tests/deSugar/should_run/dsrun009.stdout new file mode 100644 index 0000000000..1f0a31b942 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun009.stdout @@ -0,0 +1 @@ +(Negate (FromInteger 2),True) diff --git a/testsuite/tests/deSugar/should_run/dsrun010.hs b/testsuite/tests/deSugar/should_run/dsrun010.hs new file mode 100644 index 0000000000..99a9297f8b --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun010.hs @@ -0,0 +1,22 @@ +-- Check that pattern match failure in do-notation +-- is reflected by calling the monadic 'fail', not by a +-- runtime exception + +import Control.Monad +import Data.Maybe + +test :: (MonadPlus m) => [a] -> m Bool +test xs + = do + (_:_) <- return xs + -- Should fail here + return True + `mplus` + -- Failure in LH arg should trigger RH arg + do + return False + +main :: IO () +main + = do let x = fromJust (test []) + putStrLn (show x) diff --git a/testsuite/tests/deSugar/should_run/dsrun010.stdout b/testsuite/tests/deSugar/should_run/dsrun010.stdout new file mode 100644 index 0000000000..bc59c12aa1 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun010.stdout @@ -0,0 +1 @@ +False diff --git a/testsuite/tests/deSugar/should_run/dsrun011.hs b/testsuite/tests/deSugar/should_run/dsrun011.hs new file mode 100644 index 0000000000..b7e518c0bf --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun011.hs @@ -0,0 +1,93 @@ +-- Test desugaring of mutual recursion of many functions +-- which generated a big-tuple link error in GHC 6.0 + +module Main where + + +a1 :: Num a => a -> a + +a1 x | x==0 = x +a1 x = 1 + k8 (x-1) + +a2 x = 1 + a1 x +a3 x = 1 + a2 x +a4 x = 1 + a3 x +a5 x = 1 + a4 x +a6 x = 1 + a5 x +a7 x = 1 + a6 x +a8 x = 1 + a7 x + +b1 x = 1 + a8 x +b2 x = 1 + b1 x +b3 x = 1 + b2 x +b4 x = 1 + b3 x +b5 x = 1 + b4 x +b6 x = 1 + b5 x +b7 x = 1 + b6 x +b8 x = 1 + b7 x + +c1 x = 1 + b8 x +c2 x = 1 + c1 x +c3 x = 1 + c2 x +c4 x = 1 + c3 x +c5 x = 1 + c4 x +c6 x = 1 + c5 x +c7 x = 1 + c6 x +c8 x = 1 + c7 x + +d1 x = 1 + c8 x +d2 x = 1 + d1 x +d3 x = 1 + d2 x +d4 x = 1 + d3 x +d5 x = 1 + d4 x +d6 x = 1 + d5 x +d7 x = 1 + d6 x +d8 x = 1 + d7 x + +e1 x = 1 + d8 x +e2 x = 1 + e1 x +e3 x = 1 + e2 x +e4 x = 1 + e3 x +e5 x = 1 + e4 x +e6 x = 1 + e5 x +e7 x = 1 + e6 x +e8 x = 1 + e7 x + +f1 x = 1 + e8 x +f2 x = 1 + f1 x +f3 x = 1 + f2 x +f4 x = 1 + f3 x +f5 x = 1 + f4 x +f6 x = 1 + f5 x +f7 x = 1 + f6 x +f8 x = 1 + f7 x + +g1 x = 1 + f8 x +g2 x = 1 + g1 x +g3 x = 1 + g2 x +g4 x = 1 + g3 x +g5 x = 1 + g4 x +g6 x = 1 + g5 x +g7 x = 1 + g6 x +g8 x = 1 + g7 x + +h1 x = 1 + g8 x +h2 x = 1 + h1 x +h3 x = 1 + h2 x +h4 x = 1 + h3 x +h5 x = 1 + h4 x +h6 x = 1 + h5 x +h7 x = 1 + h6 x +h8 x = 1 + h7 x + +k1 x = 1 + h8 x +k2 x = 1 + k1 x +k3 x = 1 + k2 x +k4 x = 1 + k3 x +k5 x = 1 + k4 x +k6 x = 1 + k5 x +k7 x = 1 + k6 x +k8 x = 1 + k7 x + + +main = print (a1 3)
\ No newline at end of file diff --git a/testsuite/tests/deSugar/should_run/dsrun011.stdout b/testsuite/tests/deSugar/should_run/dsrun011.stdout new file mode 100644 index 0000000000..a817176f4a --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun011.stdout @@ -0,0 +1 @@ +216 diff --git a/testsuite/tests/deSugar/should_run/dsrun012.hs b/testsuite/tests/deSugar/should_run/dsrun012.hs new file mode 100644 index 0000000000..52ebd160e3 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun012.hs @@ -0,0 +1,12 @@ +-- Desugaring of massive pattern bindings +-- Fails in GHC 6.0 without -O + +module Main where + +[a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15,a16,a17, + a18,a19,a20,a21,a22,a23,a24,a25,a26,a27,a28,a29,a30,a31,a32, + a33,a34,a35,a36,a37,a38,a39,a40,a41,a42,a43,a44,a45,a46,a47, + a48,a49,a50,a51,a52,a53,a54,a55,a56,a57,a58,a59,a60,a61,a62,a63] = + [0..63] + +main = print a62 diff --git a/testsuite/tests/deSugar/should_run/dsrun012.stdout b/testsuite/tests/deSugar/should_run/dsrun012.stdout new file mode 100644 index 0000000000..a8fa06e1be --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun012.stdout @@ -0,0 +1 @@ +62 diff --git a/testsuite/tests/deSugar/should_run/dsrun013.hs b/testsuite/tests/deSugar/should_run/dsrun013.hs new file mode 100644 index 0000000000..c9cc59ead9 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun013.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE UnboxedTuples #-} + +-- This one killed GHC 6.4.1, because the pattern match on the +-- unboxed tuple generates a failure case, which defeated the +-- rather fragile code in the desugarer +-- See DsExpr.lhs, the HsCase case + +module Main where + +foo xs ys = case (# null xs, null ys #) of + (# True, False #) -> "One" + (# False, True #) -> "Two" + +main :: IO () +main = print (foo [] "ok") + diff --git a/testsuite/tests/deSugar/should_run/dsrun013.stdout b/testsuite/tests/deSugar/should_run/dsrun013.stdout new file mode 100644 index 0000000000..2dcddd2593 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun013.stdout @@ -0,0 +1 @@ +"One" diff --git a/testsuite/tests/deSugar/should_run/dsrun014.hs b/testsuite/tests/deSugar/should_run/dsrun014.hs new file mode 100644 index 0000000000..3b08a7ebf0 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun014.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import Debug.Trace + +{-# NOINLINE f #-} +f :: a -> b -> (# a,b #) +f x y = x `seq` y `seq` (# x,y #) + +g :: Int -> Int -> Int +g v w = case f v w of + (# a,b #) -> a+b + +main = print (g (trace "one" 1) (trace "two" 2)) +-- The args should be evaluated in the right order! diff --git a/testsuite/tests/deSugar/should_run/dsrun014.stderr b/testsuite/tests/deSugar/should_run/dsrun014.stderr new file mode 100644 index 0000000000..814f4a4229 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun014.stderr @@ -0,0 +1,2 @@ +one +two diff --git a/testsuite/tests/deSugar/should_run/dsrun014.stdout b/testsuite/tests/deSugar/should_run/dsrun014.stdout new file mode 100644 index 0000000000..00750edc07 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun014.stdout @@ -0,0 +1 @@ +3 diff --git a/testsuite/tests/deSugar/should_run/dsrun015.hs b/testsuite/tests/deSugar/should_run/dsrun015.hs new file mode 100644 index 0000000000..da5e443605 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun015.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -XRecordWildCards -XNamedFieldPuns #-} + +-- This is a very partial test of the record-wildcard extension +-- but better than nothing + +module Main where + +data T = C { x :: Int, y :: Int } + | D { x :: Int, b :: Bool } + +select :: T -> Int +select = x + +f :: (T,T) -> Int +f v = let (C {..}, d) = v in Main.x d + +mkC a = + let x = a + 1 + y = a * 2 + in C{..} + +sumC C{..} = x + y + +foo x b = + let y = x+1 + in (C{..}, let x = 100 in D{..}) + +bar a = + let (C{..}, d) = a + in (x + y + Main.x d, let D{..} = d in b) + +main = do + print $ sumC $ mkC 10 + print $ bar $ foo 5 True diff --git a/testsuite/tests/deSugar/should_run/dsrun015.stdout b/testsuite/tests/deSugar/should_run/dsrun015.stdout new file mode 100644 index 0000000000..b085e1acb0 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun015.stdout @@ -0,0 +1,2 @@ +31 +(111,True) diff --git a/testsuite/tests/deSugar/should_run/dsrun016.hs b/testsuite/tests/deSugar/should_run/dsrun016.hs new file mode 100644 index 0000000000..38747a46e3 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun016.hs @@ -0,0 +1,14 @@ +-- Tests grouping WITH a using clause but WITHOUT a by clause + +{-# OPTIONS_GHC -XTransformListComp #-} + +module Main where + +import Data.List(inits) + +main = putStrLn (show output) + where + output = [ x + | y <- [1..3] + , x <- "hello" + , then group using inits ] diff --git a/testsuite/tests/deSugar/should_run/dsrun016.stdout b/testsuite/tests/deSugar/should_run/dsrun016.stdout new file mode 100644 index 0000000000..60b1b8058e --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun016.stdout @@ -0,0 +1 @@ +["","h","he","hel","hell","hello","helloh","hellohe","hellohel","hellohell","hellohello","hellohelloh","hellohellohe","hellohellohel","hellohellohell","hellohellohello"] diff --git a/testsuite/tests/deSugar/should_run/dsrun017.hs b/testsuite/tests/deSugar/should_run/dsrun017.hs new file mode 100644 index 0000000000..877db7823c --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun017.hs @@ -0,0 +1,13 @@ +-- Tests grouping WITH a by clause but WITHOUT a using clause + +{-# OPTIONS_GHC -XTransformListComp #-} + +module Main where + +import GHC.Exts(the) + +main = putStrLn (show output) + where + output = [ (the dept, sum salary, name) + | (dept, salary, name) <- [("A", 1, "Bob"), ("B", 2, "Fred"), ("A", 5, "Jim"), ("A", 9, "Jim")] + , then group by dept ]
\ No newline at end of file diff --git a/testsuite/tests/deSugar/should_run/dsrun017.stdout b/testsuite/tests/deSugar/should_run/dsrun017.stdout new file mode 100644 index 0000000000..60ddd472ac --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun017.stdout @@ -0,0 +1 @@ +[("A",15,["Bob","Jim","Jim"]),("B",2,["Fred"])] diff --git a/testsuite/tests/deSugar/should_run/dsrun018.hs b/testsuite/tests/deSugar/should_run/dsrun018.hs new file mode 100644 index 0000000000..d89f5b24f3 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun018.hs @@ -0,0 +1,18 @@ +-- Test grouping with both a using and a by clause + +{-# OPTIONS_GHC -XTransformListComp #-} + +module Main where + +import Data.List(groupBy) +import GHC.Exts(the) + +groupRuns :: Eq b => (a -> b) -> [a] -> [[a]] +groupRuns f = groupBy (\x y -> f x == f y) + +main = putStrLn (show output) + where + output = [ (the x, product y) + | x <- ([1, 1, 1, 2, 2, 1, 3]) + , y <- [4..6] + , then group by x using groupRuns ]
\ No newline at end of file diff --git a/testsuite/tests/deSugar/should_run/dsrun018.stdout b/testsuite/tests/deSugar/should_run/dsrun018.stdout new file mode 100644 index 0000000000..7c2936211d --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun018.stdout @@ -0,0 +1 @@ +[(1,1728000),(2,14400),(1,120),(3,120)] diff --git a/testsuite/tests/deSugar/should_run/dsrun019.hs b/testsuite/tests/deSugar/should_run/dsrun019.hs new file mode 100644 index 0000000000..049d264114 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun019.hs @@ -0,0 +1,11 @@ +-- Test transform WITHOUT a by clause + +{-# OPTIONS_GHC -XTransformListComp #-} + +module Main where + +main = putStrLn (show output) + where + output = [ x + | x <- [1..10] + , then take 5 ]
\ No newline at end of file diff --git a/testsuite/tests/deSugar/should_run/dsrun019.stdout b/testsuite/tests/deSugar/should_run/dsrun019.stdout new file mode 100644 index 0000000000..bfedf5b35e --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun019.stdout @@ -0,0 +1 @@ +[1,2,3,4,5] diff --git a/testsuite/tests/deSugar/should_run/dsrun020.hs b/testsuite/tests/deSugar/should_run/dsrun020.hs new file mode 100644 index 0000000000..6d26dc5607 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun020.hs @@ -0,0 +1,14 @@ +-- Tests transform WITH a by clause + +{-# OPTIONS_GHC -XTransformListComp #-} + +module Main where + +import Data.List(takeWhile) + +main = putStrLn (show output) + where + output = [ (x * 10) + y + | x <- [1..4] + , y <- [1..4] + , then takeWhile by (x + y) < 4]
\ No newline at end of file diff --git a/testsuite/tests/deSugar/should_run/dsrun020.stdout b/testsuite/tests/deSugar/should_run/dsrun020.stdout new file mode 100644 index 0000000000..771f5460d8 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun020.stdout @@ -0,0 +1 @@ +[11,12] diff --git a/testsuite/tests/deSugar/should_run/dsrun021.hs b/testsuite/tests/deSugar/should_run/dsrun021.hs new file mode 100644 index 0000000000..7489f77a4a --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun021.hs @@ -0,0 +1,22 @@ +-- Transformation stress test
+
+{-# OPTIONS_GHC -XTransformListComp #-}
+
+module Main where
+
+import Data.List(takeWhile)
+import GHC.Exts(sortWith)
+
+employees = [ ("Simon", "MS", 80)
+ , ("Erik", "MS", 100)
+ , ("Phil", "Ed", 40)
+ , ("Gordon", "Ed", 45)
+ , ("Paul", "Yale", 60)]
+
+main = putStrLn (show output)
+ where
+ output = [ (dept, salary)
+ | (name, dept, salary) <- employees
+ , then sortWith by salary
+ , then filter by salary > 50
+ , then take 1 ]
\ No newline at end of file diff --git a/testsuite/tests/deSugar/should_run/dsrun021.stdout b/testsuite/tests/deSugar/should_run/dsrun021.stdout new file mode 100644 index 0000000000..b7de0302ef --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun021.stdout @@ -0,0 +1 @@ +[("Yale",60)] diff --git a/testsuite/tests/deSugar/should_run/dsrun022.hs b/testsuite/tests/deSugar/should_run/dsrun022.hs new file mode 100644 index 0000000000..dbbd906ce8 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun022.hs @@ -0,0 +1,26 @@ +-- Transformation and grouping stress test + +{-# OPTIONS_GHC -XTransformListComp #-} + +module Main where + +import GHC.Exts(sortWith, the) + +employees = [ ("Simon", "MS", 80) + , ("Erik", "MS", 100) + , ("Phil", "Ed", 40) + , ("Gordon", "Ed", 45) + , ("Paul", "Yale", 60) ] + +main = putStrLn (show can_still_use_group_function) >> putStrLn (show output) + where + output = [ (the dept, map sum salary, (show x) ++ " and " ++ (show y)) + | (name, dept, salary) <- employees + , then group by dept + , x <- [1, 2, 3] + , y <- [4, 5, 6] + , then sortWith by sum salary + , then take 4 + , then group using replicate 2 ] + group = const "my group function called!" + can_still_use_group_function = group "Mississippi"
\ No newline at end of file diff --git a/testsuite/tests/deSugar/should_run/dsrun022.stdout b/testsuite/tests/deSugar/should_run/dsrun022.stdout new file mode 100644 index 0000000000..c426e190ce --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun022.stdout @@ -0,0 +1,2 @@ +"my group function called!" +[(["Yale"],[60,60,60,60],"[1,1,1,2] and [4,5,6,4]"),(["Yale"],[60,60,60,60],"[1,1,1,2] and [4,5,6,4]")] diff --git a/testsuite/tests/deSugar/should_run/dsrun023.hs b/testsuite/tests/deSugar/should_run/dsrun023.hs new file mode 100644 index 0000000000..8189633415 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun023.hs @@ -0,0 +1,41 @@ +-- "Big tuple" stress test for parallel and transform comprehensions + +{-# OPTIONS_GHC -XTransformListComp -XParallelListComp #-} + +module Main where + +main = putStrLn (show output) + where + output = [ x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + + x40 + x41 + x42 + x43 + x44 + x45 + x46 + x47 + x48 + x49 + + x50 + x51 + x52 + x53 + x54 + x55 + x56 + x57 + x58 + x59 + + x60 + x61 + x62 + x63 + x64 + x65 + x66 + x67 + x68 + x69 + + x70 + x71 + x72 + x73 + x74 + x75 + x76 + x77 + x78 + x79 + + x80 + x81 + x82 + x83 + x84 + x85 + x86 + x87 + x88 + x89 + + x90 + x91 + x92 + x93 + x94 + x95 + x96 + x97 + x98 + x99 + + y + | x0 <- [0], x1 <- [1], x2 <- [2], x3 <- [3], x4 <- [4] + , x5 <- [5], x6 <- [6], x7 <- [7], x8 <- [8], x9 <- [9] + , x10 <- [0], x11 <- [1], x12 <- [2], x13 <- [3], x14 <- [4] + , x15 <- [5], x16 <- [6], x17 <- [7], x18 <- [8], x19 <- [9] + , x20 <- [0], x21 <- [1], x22 <- [2], x23 <- [3], x24 <- [4] + , x25 <- [5], x26 <- [6], x27 <- [7], x28 <- [8], x29 <- [9] + , x30 <- [0], x31 <- [1], x32 <- [2], x33 <- [3], x34 <- [4] + , x35 <- [5], x36 <- [6], x37 <- [7], x38 <- [8], x39 <- [9] + , x40 <- [0], x41 <- [1], x42 <- [2], x43 <- [3], x44 <- [4] + , x45 <- [5], x46 <- [6], x47 <- [7], x48 <- [8], x49 <- [9] + , x50 <- [0], x51 <- [1], x52 <- [2], x53 <- [3], x54 <- [4] + , x55 <- [5], x56 <- [6], x57 <- [7], x58 <- [8], x59 <- [9] + , x60 <- [0], x61 <- [1], x62 <- [2], x63 <- [3], x64 <- [4] + , x65 <- [5], x66 <- [6], x67 <- [7], x68 <- [8], x69 <- [9] + , x70 <- [0], x71 <- [1], x72 <- [2], x73 <- [3], x74 <- [4] + , x75 <- [5], x76 <- [6], x77 <- [7], x78 <- [8], x79 <- [9] + , x80 <- [0], x81 <- [1], x82 <- [2], x83 <- [3], x84 <- [4] + , x85 <- [5], x86 <- [6], x87 <- [7], x88 <- [8], x89 <- [9] + , x90 <- [0], x91 <- [1], x92 <- [2], x93 <- [3], x94 <- [4] + , x95 <- [5], x96 <- [6], x97 <- [7], x98 <- [8], x99 <- [9] + , then take 4 + | y <- [10] ]
\ No newline at end of file diff --git a/testsuite/tests/deSugar/should_run/dsrun023.stdout b/testsuite/tests/deSugar/should_run/dsrun023.stdout new file mode 100644 index 0000000000..538ca9d5f0 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/dsrun023.stdout @@ -0,0 +1 @@ +[460] diff --git a/testsuite/tests/deSugar/should_run/mc01.hs b/testsuite/tests/deSugar/should_run/mc01.hs new file mode 100644 index 0000000000..cf5ca1a0e9 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc01.hs @@ -0,0 +1,26 @@ +-- Transformation and grouping stress test + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module Main where + +import GHC.Exts(sortWith, the) + +employees = [ ("Simon", "MS", 80) + , ("Erik", "MS", 100) + , ("Phil", "Ed", 40) + , ("Gordon", "Ed", 45) + , ("Paul", "Yale", 60) ] + +main = putStrLn (show can_still_use_group_function) >> putStrLn (show output) + where + output = [ (the dept, map sum salary, (show x) ++ " and " ++ (show y)) + | (name, dept, salary) <- employees + , then group by dept + , x <- [1, 2, 3] + , y <- [4, 5, 6] + , then sortWith by sum salary + , then take 4 + , then group using replicate 2 ] + group = const "my group function called!" + can_still_use_group_function = group "Mississippi" diff --git a/testsuite/tests/deSugar/should_run/mc01.stdout b/testsuite/tests/deSugar/should_run/mc01.stdout new file mode 100644 index 0000000000..c426e190ce --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc01.stdout @@ -0,0 +1,2 @@ +"my group function called!" +[(["Yale"],[60,60,60,60],"[1,1,1,2] and [4,5,6,4]"),(["Yale"],[60,60,60,60],"[1,1,1,2] and [4,5,6,4]")] diff --git a/testsuite/tests/deSugar/should_run/mc02.hs b/testsuite/tests/deSugar/should_run/mc02.hs new file mode 100644 index 0000000000..77adf26c37 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc02.hs @@ -0,0 +1,22 @@ +-- Transformation stress test + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module Main where + +import Data.List(takeWhile) +import GHC.Exts(sortWith) + +employees = [ ("Simon", "MS", 80) + , ("Erik", "MS", 100) + , ("Phil", "Ed", 40) + , ("Gordon", "Ed", 45) + , ("Paul", "Yale", 60)] + +main = putStrLn (show output) + where + output = [ (dept, salary) + | (name, dept, salary) <- employees + , then sortWith by salary + , then filter by salary > 50 + , then take 1 ] diff --git a/testsuite/tests/deSugar/should_run/mc02.stdout b/testsuite/tests/deSugar/should_run/mc02.stdout new file mode 100644 index 0000000000..b7de0302ef --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc02.stdout @@ -0,0 +1 @@ +[("Yale",60)] diff --git a/testsuite/tests/deSugar/should_run/mc03.hs b/testsuite/tests/deSugar/should_run/mc03.hs new file mode 100644 index 0000000000..1b52c83c46 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc03.hs @@ -0,0 +1,41 @@ +-- "Big tuple" stress test for monad comprehensions + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp -XParallelListComp #-} + +module Main where + +main = putStrLn (show output) + where + output = [ x0 + x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + + x10 + x11 + x12 + x13 + x14 + x15 + x16 + x17 + x18 + x19 + + x20 + x21 + x22 + x23 + x24 + x25 + x26 + x27 + x28 + x29 + + x30 + x31 + x32 + x33 + x34 + x35 + x36 + x37 + x38 + x39 + + x40 + x41 + x42 + x43 + x44 + x45 + x46 + x47 + x48 + x49 + + x50 + x51 + x52 + x53 + x54 + x55 + x56 + x57 + x58 + x59 + + x60 + x61 + x62 + x63 + x64 + x65 + x66 + x67 + x68 + x69 + + x70 + x71 + x72 + x73 + x74 + x75 + x76 + x77 + x78 + x79 + + x80 + x81 + x82 + x83 + x84 + x85 + x86 + x87 + x88 + x89 + + x90 + x91 + x92 + x93 + x94 + x95 + x96 + x97 + x98 + x99 + + y + | x0 <- [0], x1 <- [1], x2 <- [2], x3 <- [3], x4 <- [4] + , x5 <- [5], x6 <- [6], x7 <- [7], x8 <- [8], x9 <- [9] + , x10 <- [0], x11 <- [1], x12 <- [2], x13 <- [3], x14 <- [4] + , x15 <- [5], x16 <- [6], x17 <- [7], x18 <- [8], x19 <- [9] + , x20 <- [0], x21 <- [1], x22 <- [2], x23 <- [3], x24 <- [4] + , x25 <- [5], x26 <- [6], x27 <- [7], x28 <- [8], x29 <- [9] + , x30 <- [0], x31 <- [1], x32 <- [2], x33 <- [3], x34 <- [4] + , x35 <- [5], x36 <- [6], x37 <- [7], x38 <- [8], x39 <- [9] + , x40 <- [0], x41 <- [1], x42 <- [2], x43 <- [3], x44 <- [4] + , x45 <- [5], x46 <- [6], x47 <- [7], x48 <- [8], x49 <- [9] + , x50 <- [0], x51 <- [1], x52 <- [2], x53 <- [3], x54 <- [4] + , x55 <- [5], x56 <- [6], x57 <- [7], x58 <- [8], x59 <- [9] + , x60 <- [0], x61 <- [1], x62 <- [2], x63 <- [3], x64 <- [4] + , x65 <- [5], x66 <- [6], x67 <- [7], x68 <- [8], x69 <- [9] + , x70 <- [0], x71 <- [1], x72 <- [2], x73 <- [3], x74 <- [4] + , x75 <- [5], x76 <- [6], x77 <- [7], x78 <- [8], x79 <- [9] + , x80 <- [0], x81 <- [1], x82 <- [2], x83 <- [3], x84 <- [4] + , x85 <- [5], x86 <- [6], x87 <- [7], x88 <- [8], x89 <- [9] + , x90 <- [0], x91 <- [1], x92 <- [2], x93 <- [3], x94 <- [4] + , x95 <- [5], x96 <- [6], x97 <- [7], x98 <- [8], x99 <- [9] + , then take 4 + | y <- [10] ] diff --git a/testsuite/tests/deSugar/should_run/mc03.stdout b/testsuite/tests/deSugar/should_run/mc03.stdout new file mode 100644 index 0000000000..538ca9d5f0 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc03.stdout @@ -0,0 +1 @@ +[460] diff --git a/testsuite/tests/deSugar/should_run/mc04.hs b/testsuite/tests/deSugar/should_run/mc04.hs new file mode 100644 index 0000000000..38747a46e3 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc04.hs @@ -0,0 +1,14 @@ +-- Tests grouping WITH a using clause but WITHOUT a by clause + +{-# OPTIONS_GHC -XTransformListComp #-} + +module Main where + +import Data.List(inits) + +main = putStrLn (show output) + where + output = [ x + | y <- [1..3] + , x <- "hello" + , then group using inits ] diff --git a/testsuite/tests/deSugar/should_run/mc04.stdout b/testsuite/tests/deSugar/should_run/mc04.stdout new file mode 100644 index 0000000000..60b1b8058e --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc04.stdout @@ -0,0 +1 @@ +["","h","he","hel","hell","hello","helloh","hellohe","hellohel","hellohell","hellohello","hellohelloh","hellohellohe","hellohellohel","hellohellohell","hellohellohello"] diff --git a/testsuite/tests/deSugar/should_run/mc05.hs b/testsuite/tests/deSugar/should_run/mc05.hs new file mode 100644 index 0000000000..c2d7d2d4a5 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc05.hs @@ -0,0 +1,11 @@ +-- Test transform WITHOUT a by clause + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module Main where + +main = putStrLn (show output) + where + output = [ x + | x <- [1..10] + , then take 5 ] diff --git a/testsuite/tests/deSugar/should_run/mc05.stdout b/testsuite/tests/deSugar/should_run/mc05.stdout new file mode 100644 index 0000000000..bfedf5b35e --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc05.stdout @@ -0,0 +1 @@ +[1,2,3,4,5] diff --git a/testsuite/tests/deSugar/should_run/mc06.hs b/testsuite/tests/deSugar/should_run/mc06.hs new file mode 100644 index 0000000000..20fe041283 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc06.hs @@ -0,0 +1,18 @@ +-- Test grouping with both a using and a by clause + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module Main where + +import Data.List(groupBy) +import GHC.Exts(the) + +groupRuns :: Eq b => (a -> b) -> [a] -> [[a]] +groupRuns f = groupBy (\x y -> f x == f y) + +main = putStrLn (show output) + where + output = [ (the x, product y) + | x <- ([1, 1, 1, 2, 2, 1, 3]) + , y <- [4..6] + , then group by x using groupRuns ] diff --git a/testsuite/tests/deSugar/should_run/mc06.stdout b/testsuite/tests/deSugar/should_run/mc06.stdout new file mode 100644 index 0000000000..7c2936211d --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc06.stdout @@ -0,0 +1 @@ +[(1,1728000),(2,14400),(1,120),(3,120)] diff --git a/testsuite/tests/deSugar/should_run/mc07.hs b/testsuite/tests/deSugar/should_run/mc07.hs new file mode 100644 index 0000000000..7726dedb65 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc07.hs @@ -0,0 +1,14 @@ +-- Tests transform WITH a by clause + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module Main where + +import Data.List(takeWhile) + +main = putStrLn (show output) + where + output = [ (x * 10) + y + | x <- [1..4] + , y <- [1..4] + , then takeWhile by (x + y) < 4] diff --git a/testsuite/tests/deSugar/should_run/mc07.stdout b/testsuite/tests/deSugar/should_run/mc07.stdout new file mode 100644 index 0000000000..771f5460d8 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc07.stdout @@ -0,0 +1 @@ +[11,12] diff --git a/testsuite/tests/deSugar/should_run/mc08.hs b/testsuite/tests/deSugar/should_run/mc08.hs new file mode 100644 index 0000000000..24dd3beb4c --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc08.hs @@ -0,0 +1,13 @@ +-- Tests grouping WITH a by clause but WITHOUT a using clause + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module Main where + +import GHC.Exts(the) + +main = putStrLn (show output) + where + output = [ (the dept, sum salary, name) + | (dept, salary, name) <- [("A", 1, "Bob"), ("B", 2, "Fred"), ("A", 5, "Jim"), ("A", 9, "Jim")] + , then group by dept ] diff --git a/testsuite/tests/deSugar/should_run/mc08.stdout b/testsuite/tests/deSugar/should_run/mc08.stdout new file mode 100644 index 0000000000..60ddd472ac --- /dev/null +++ b/testsuite/tests/deSugar/should_run/mc08.stdout @@ -0,0 +1 @@ +[("A",15,["Bob","Jim","Jim"]),("B",2,["Fred"])] |