diff options
| author | David Terei <davidterei@gmail.com> | 2011-07-20 11:09:03 -0700 |
|---|---|---|
| committer | David Terei <davidterei@gmail.com> | 2011-07-20 11:26:35 -0700 |
| commit | 16514f272fb42af6e9c7674a9bd6c9dce369231f (patch) | |
| tree | e4f332b45fe65e2a7a2451be5674f887b42bf199 /testsuite/tests/typecheck/should_compile | |
| parent | ebd422aed41048476aa61dd4c520d43becd78682 (diff) | |
| download | haskell-16514f272fb42af6e9c7674a9bd6c9dce369231f.tar.gz | |
Move tests from tests/ghc-regress/* to just tests/*
Diffstat (limited to 'testsuite/tests/typecheck/should_compile')
336 files changed, 6973 insertions, 0 deletions
diff --git a/testsuite/tests/typecheck/should_compile/FD1.hs b/testsuite/tests/typecheck/should_compile/FD1.hs new file mode 100644 index 0000000000..0c8942ad95 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/FD1.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} + +-- Trac #1781 +-- This one should really succeed, because 'plus' can only +-- be called with a = Int->Int, but the old fundep story +-- certainly made it fail, and so that's what we expect for now +-- We may become more liberal later + +module ShouldCompile where + +class E a b | a -> b, b -> a +instance E a a + +plus :: (E a (Int -> Int)) => Int -> a +plus x y = x + y + diff --git a/testsuite/tests/typecheck/should_compile/FD1.stderr b/testsuite/tests/typecheck/should_compile/FD1.stderr new file mode 100644 index 0000000000..6f98877b84 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/FD1.stderr @@ -0,0 +1,12 @@ + +FD1.hs:16:1: + Could not deduce (a ~ (Int -> Int)) + from the context (E a (Int -> Int)) + bound by the type signature for + plus :: E a (Int -> Int) => Int -> a + at FD1.hs:16:1-16 + `a' is a rigid type variable bound by + the type signature for plus :: E a (Int -> Int) => Int -> a + at FD1.hs:16:1 + The equation(s) for `plus' have two arguments, + but its type `Int -> a' has only one diff --git a/testsuite/tests/typecheck/should_compile/FD2.hs b/testsuite/tests/typecheck/should_compile/FD2.hs new file mode 100644 index 0000000000..b4623a8743 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/FD2.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
+
+-- Trac #1783
+-- Like Trac #1781 you could argue that this one should succeed
+-- but we stick with the old behaviour for now. When we do
+-- fundeps properly it'll probably start to work
+
+module ShouldCompile where
+
+import Prelude hiding (foldr, foldr1)
+
+import Data.Maybe
+
+class Elem a e | a -> e
+
+class Foldable a where
+ foldr :: Elem a e => (e -> b -> b) -> b -> a -> b
+
+-- foldr1 :: forall e. Elem a e => (e -> e -> e) -> a -> e -- WORKS!
+ foldr1 :: Elem a e => (e -> e -> e) -> a -> e
+ foldr1 f xs = fromMaybe (error "foldr1: empty structure")
+ (foldr mf Nothing xs)
+ where mf :: Elem a e => (e -> Maybe e -> Maybe e)
+ mf x Nothing = Just x
+ mf x (Just y) = Just (f x y)
diff --git a/testsuite/tests/typecheck/should_compile/FD2.stderr b/testsuite/tests/typecheck/should_compile/FD2.stderr new file mode 100644 index 0000000000..618c361f49 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/FD2.stderr @@ -0,0 +1,25 @@ + +FD2.hs:26:38: + Could not deduce (e1 ~ e) + from the context (Foldable a) + bound by the class declaration for `Foldable' + at FD2.hs:(17,1)-(26,39) + or from (Elem a e) + bound by the type signature for + foldr1 :: Elem a e => (e -> e -> e) -> a -> e + at FD2.hs:(22,3)-(26,39) + or from (Elem a e1) + bound by the type signature for + mf :: Elem a e1 => e1 -> Maybe e1 -> Maybe e1 + at FD2.hs:(25,12)-(26,39) + `e1' is a rigid type variable bound by + the type signature for + mf :: Elem a e1 => e1 -> Maybe e1 -> Maybe e1 + at FD2.hs:25:12 + `e' is a rigid type variable bound by + the type signature for + foldr1 :: Elem a e => (e -> e -> e) -> a -> e + at FD2.hs:22:3 + In the second argument of `f', namely `y' + In the first argument of `Just', namely `(f x y)' + In the expression: Just (f x y) diff --git a/testsuite/tests/typecheck/should_compile/FD3.hs b/testsuite/tests/typecheck/should_compile/FD3.hs new file mode 100644 index 0000000000..333c0c31dd --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/FD3.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
+
+-- Trac #1795
+
+module ShouldCompile where
+
+data A a = A
+
+class MkA a b | a -> b where
+ mkA :: a -> A b
+
+instance MkA a a where
+
+translate :: (String, a) -> A a
+translate a = mkA a
diff --git a/testsuite/tests/typecheck/should_compile/FD3.stderr b/testsuite/tests/typecheck/should_compile/FD3.stderr new file mode 100644 index 0000000000..5e8a4ee164 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/FD3.stderr @@ -0,0 +1,13 @@ + +FD3.hs:15:15: + Couldn't match type `a' with `(String, a)' + `a' is a rigid type variable bound by + the type signature for translate :: (String, a) -> A a + at FD3.hs:15:1 + When using functional dependencies to combine + MkA a a, + arising from the dependency `a -> b' + in the instance declaration at FD3.hs:12:10 + MkA (String, a) a, arising from a use of `mkA' at FD3.hs:15:15-17 + In the expression: mkA a + In an equation for `translate': translate a = mkA a diff --git a/testsuite/tests/typecheck/should_compile/FD4.hs b/testsuite/tests/typecheck/should_compile/FD4.hs new file mode 100644 index 0000000000..5d5869ca01 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/FD4.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE
+ MultiParamTypeClasses,
+ FunctionalDependencies,
+ UndecidableInstances,
+ OverlappingInstances,
+ FlexibleInstances,
+ EmptyDataDecls #-}
+
+-- Trac #1797
+
+module ShouldCompile where
+
+data True
+
+data False
+
+class TypeEq type1 type2 result | type1 type2 -> result where
+ typeEq :: type1 -> type2 -> result
+
+instance TypeEq soleType soleType True where
+ typeEq _ _ = undefined
+
+instance (TypeCast False result) => TypeEq type1 type2 result where
+ typeEq _ _ = undefined
+
+class TypeCast type1 type2 | type1 -> type2, type2 -> type1
+
+instance TypeCast soleType soleType
diff --git a/testsuite/tests/typecheck/should_compile/GivenOverlapping.hs b/testsuite/tests/typecheck/should_compile/GivenOverlapping.hs new file mode 100644 index 0000000000..35f4b07962 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/GivenOverlapping.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FunctionalDependencies, FlexibleContexts #-}
+
+class C a where
+
+class D a where
+ dop :: a -> a
+
+instance C a => D [a] where
+ dop = undefined
+
+class J a b | a -> b
+ where j :: a -> b -> ()
+
+instance J Bool Int where
+ j = undefined
+
+foo :: D [Int] => ()
+foo = j True (head (dop [undefined]))
+
+main = return ()
+
diff --git a/testsuite/tests/typecheck/should_compile/GivenTypeSynonym.hs b/testsuite/tests/typecheck/should_compile/GivenTypeSynonym.hs new file mode 100644 index 0000000000..918eb788b3 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/GivenTypeSynonym.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeFamilies #-}
+module Main where
+
+data A a
+
+type T a = A a
+
+
+f :: (A a ~ T Int) => a -> Int
+f x = x
+
+
+main :: IO ()
+main = return ()
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_compile/HasKey.hs b/testsuite/tests/typecheck/should_compile/HasKey.hs new file mode 100644 index 0000000000..8da7ee7205 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/HasKey.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- Provided by Christian Maeder; broke +-- a pre-release GHC 7.0 + +module HasKey where + +class Ord key => HasKey x key | x -> key where + toKey :: x -> key + +newtype Keyed x = Keyed { unKey :: x } + +lift :: (HasKey x1 key1,HasKey x2 key2) + => (key1 -> key2 -> a) -> (Keyed x1 -> Keyed x2 -> a) +lift f x1 x2 = f (toKey . unKey $ x1) (toKey . unKey $ x2) + +instance HasKey x key => Eq (Keyed x) where + (==) = lift (==) + +instance HasKey x key => Ord (Keyed x) diff --git a/testsuite/tests/typecheck/should_compile/LoopOfTheDay1.hs b/testsuite/tests/typecheck/should_compile/LoopOfTheDay1.hs new file mode 100644 index 0000000000..e3b656a66e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/LoopOfTheDay1.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} + +-- Compiles fine. +-- Instance selection works fine. +-- try: :t foo (T1b T1a) + +module ShouldCompile where + +-- Notice: T1 is a recursive type. +-- Notice: the classes are recursive, too. +-- Why does this work when almost the same thing doesn't? +-- Say: adding an Int component to T1a makes things loop. +-- See LoopOfTheDay2.hs and LoopOfTheDay3.hs. + +data T1 = T1a | T1b T1 + +class C0 x where foo :: x -> (); foo = undefined +class C1 x y +class C1 x y => C2 x y + +instance C0 T1 => C1 () T1 -- (I1) +instance (C1 x T1) => C2 x T1 -- (I2) +instance C2 () T1 => C0 T1 -- (I3) + +baz = foo (T1b T1a) + +{- Need C0 T1 +-->(I3) C2 () T1 +-->(I2) C1 () T1 +-->(I1) C0 T1 -- STOP because we've seen this before +-} diff --git a/testsuite/tests/typecheck/should_compile/LoopOfTheDay2.hs b/testsuite/tests/typecheck/should_compile/LoopOfTheDay2.hs new file mode 100644 index 0000000000..0996e7c2f2 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/LoopOfTheDay2.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} + +-- Compilation loops in GHC 6.2! +-- While LoopOfTheDay1.hs did compile and work, +-- this one loops during compilation, even though +-- there is only an innocent difference regarding T1, +-- i.e., an additional, non-recursive constructor component. + +module ShouldCompile where + +data T1 = T1a Int | T1b T1 + +class C0 x where foo :: x -> (); foo = undefined +-- foo :: C0 x => x -> () + +class C1 x y +class C1 x y => C2 x y + +instance C0 Int => C1 () Int -- I1 +instance C0 T1 => C1 () T1 -- I2 +instance (C1 x T1, C1 x Int) => C2 x T1 -- I3 +instance C1 x Int => C2 x Int -- I4 +instance C2 () T1 => C0 T1 -- I5 +instance C2 () Int => C0 Int -- I6 + + +baz = foo (T1b (T1a 3)) + +{- Need + C0 T1 +-->(I5) C2 () T1 +-->(I3) C1 () T1, C1 () Int +-->(I1,I2) C0 T1, C0 Int +-->(recusive) C0 Int +-->(I6) C2 () Int +-->(I4) C1 () Int +-->(recursive) {} +-} diff --git a/testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs b/testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs new file mode 100644 index 0000000000..dce1601a70 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, + OverlappingInstances, UndecidableInstances #-} + +-- Instances compile fine but instance selection loops in GHC 6.2. +-- try: :t foo (T1a 1) +-- This is essentially the same as LoopOfTheDay2.hs +-- but with the innocent (?) use of overlapping instances. + +module ShouldCompile where + +data T1 = T1a Int | T1b T1 + +class C0 x where foo :: x -> (); foo = undefined +class C1 x y +class C1 x y => C2 x y + +instance C0 a => C1 () a +instance (C1 x T1, C1 x Int) => C2 x T1 +instance C1 x Int => C2 x Int +instance C2 () a => C0 a + +baz = foo (T1b (T1a 3)) diff --git a/testsuite/tests/typecheck/should_compile/Makefile b/testsuite/tests/typecheck/should_compile/Makefile new file mode 100644 index 0000000000..75691da79c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/Makefile @@ -0,0 +1,26 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +tc170: + $(RM) Tc170_Aux.hi Tc170_Aux.o tc170.hi tc170.o + '$(TEST_HC)' $(TEST_HC_OPTS) -c Tc170_Aux.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c tc170.hs + +tc173: + $(RM) Tc173a.o Tc173a.hi Tc173b.o Tc173b.hi + '$(TEST_HC)' $(TEST_HC_OPTS) -c -XFlexibleInstances -XTypeSynonymInstances -XUndecidableInstances -XOverlappingInstances Tc173a.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c -XUndecidableInstances -XOverlappingInstances Tc173b.hs + +T2412: + $(RM) -f T2412.hi-boot T2412.o-boot T2412A.hi T2412A.o T2412.hi T2412.o + '$(TEST_HC)' $(TEST_HC_OPTS) -c T2412.hs-boot + '$(TEST_HC)' $(TEST_HC_OPTS) -c T2412A.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c T2412.hs + +tc245: + $(RM) -f Tc245_A.hi Tc245_A.o tc245.hi tc245.o + '$(TEST_HC)' $(TEST_HC_OPTS) --make tc245 + $(RM) -f tc245.hi tc245.o + '$(TEST_HC)' $(TEST_HC_OPTS) --make tc245 + diff --git a/testsuite/tests/typecheck/should_compile/PolyRec.hs b/testsuite/tests/typecheck/should_compile/PolyRec.hs new file mode 100644 index 0000000000..ddb911553a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/PolyRec.hs @@ -0,0 +1,29 @@ +-- An example of RelaxedPolyRec in action which came up
+-- on Haskell Cafe June 2010 (Job Vranish)
+
+module Foo where
+
+import Data.Maybe
+
+-- The fixed point datatype
+data Y f = Y (f (Y f))
+
+-- Silly dummy function
+maybeToInt :: Maybe a -> Int
+maybeToInt = length . maybeToList
+
+---------------------------
+-- f and g are mutually recursive
+-- Even though f has a totally monomorphic
+-- signature, g has a very polymorphic one
+
+f :: Y Maybe -> Int
+f (Y x) = g maybeToInt x
+
+-- With RelaxedPolyRec we can infer this type
+-- g :: Functor f => (f Int -> b) -> f (Y Maybe) -> b
+g h x = h $ fmap f x
+
+-- 'test' checks that g's type is polymophic enough
+test :: Functor f => (f Int -> b) -> f (Y Maybe) -> b
+test = g
diff --git a/testsuite/tests/typecheck/should_compile/SilentParametersOverlapping.hs b/testsuite/tests/typecheck/should_compile/SilentParametersOverlapping.hs new file mode 100644 index 0000000000..8169c3f64a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/SilentParametersOverlapping.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} + +module SilentParametersOverlapping where + +class C a where + c :: a -> () + +class C a => B a where + b :: a -> () + +instance C [a] where + c x = () + +instance {- silent: C [(a,b)] => -} B [(a,b)] where + b x = c [(undefined,undefined)] + -- We get wanted: C [(gamma, delta)], + -- and gamma,delta are unconstrained + -- But we can apply the C [a] instance without difficulty + -- (except in the old days when we had silent dfun parameters) diff --git a/testsuite/tests/typecheck/should_compile/T1123.hs b/testsuite/tests/typecheck/should_compile/T1123.hs new file mode 100644 index 0000000000..a9a7d965e3 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T1123.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE RankNTypes #-} + +module Bug where + +data T a = MkT + +out :: forall a. T a -> () +out MkT = () + +inHoisted :: forall r. () -> (forall a. T a -> r) -> r +inHoisted _ foo = foo MkT + +inUnhoisted :: () -> forall r. (forall a. T a -> r) -> r +inUnhoisted _ foo = foo MkT + +testHoisted :: () +testHoisted = inHoisted () out + +testUnhoisted :: () +testUnhoisted = inUnhoisted () out + + +---------------- + +data A s = A { unA :: () } + +runA1 :: (forall s. A s) -> () +runA1 a = unA a + +-- doesn't work :( +runA2 :: (forall s. A s) -> () +runA2 (A a) = a + +runA3 :: (forall s. A s) -> () +runA3 a = case a of A x -> x + +runA4 :: (forall s. A s) -> () +runA4 a = let A x = a in x + +runA5 :: (forall s. A s) -> () +runA5 a = go a + where go (A a) = a diff --git a/testsuite/tests/typecheck/should_compile/T1470.hs b/testsuite/tests/typecheck/should_compile/T1470.hs new file mode 100644 index 0000000000..8419a94627 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T1470.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances #-} + +-- Trac #1470 + +module Foo where + +class Sat a +class Data ctx a +instance Sat (ctx Char) => Data ctx Char +instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] + +class Data FooD a => Foo a + +data FooD a = FooD + +instance Foo t => Sat (FooD t) + +instance Data FooD a => Foo a + + +instance Foo a => Foo [a] +{- + Given: Foo a, + and its superclasses: Data FooD a + + Want superclass: Data FooD [a] + + by instance Data FooD [a] + want: Sat (FooD [a]) + Data FooD a -- We have this + + by instance Sat (FooD t) + want: Foo [a] + +BUT THIS INSTANCE OVERLAPS +-} + +instance Foo [Char] diff --git a/testsuite/tests/typecheck/should_compile/T1495.hs b/testsuite/tests/typecheck/should_compile/T1495.hs new file mode 100644 index 0000000000..0de4e456de --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T1495.hs @@ -0,0 +1,19 @@ +-- Test Trac #1495 + +module CompilerBug where + +newtype Fix a = Fix (a (Fix a)) +data ID a = ID a +newtype I a = I a + +testOk :: Fix ID +testOk = undefined + +-- this definition causes the compiler to fail to terminate +testInfiniteLoop :: Fix I +testInfiniteLoop = undefined + + +newtype T = MkT T +test :: T +test = undefined diff --git a/testsuite/tests/typecheck/should_compile/T1634.hs b/testsuite/tests/typecheck/should_compile/T1634.hs new file mode 100644 index 0000000000..b4c6f2b561 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T1634.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RankNTypes #-} + +module T1634 where + +t1 :: a -> (forall b. b -> (a,b)) +t1 = (,) diff --git a/testsuite/tests/typecheck/should_compile/T2045.hs b/testsuite/tests/typecheck/should_compile/T2045.hs new file mode 100644 index 0000000000..78b924a6ea --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2045.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Trac #2045 +-- ghc -fhpc --make Vhdl.hs -o gencirc -Wall + +module ShouleCompile where + +writeDefinitions :: Generic b + => b -> IO () +writeDefinitions out = + do let define v s = + case s of + Bool True -> port "vcc" [] + Bool False -> port "gnd" [] + Inv x -> port "inv" [x] + + And [] -> define v (Bool True) + And [x] -> port "id" [x] + And [x,y] -> port "and2" [x,y] + And (x:xs) -> define (w 0) (And xs) + >> define v (And [x,w 0]) + + Or [] -> define v (Bool False) + Or [x] -> port "id" [x] + Or [x,y] -> port "or2" [x,y] + Or (x:xs) -> define (w 0) (Or xs) + >> define v (Or [x,w 0]) + + Xor [] -> define v (Bool False) + Xor [x] -> port "id" [x] + Xor [x,y] -> port "xor2" [x,y] + Xor (x:xs) -> define (w 0) (Or xs) + >> define (w 1) (Inv (w 0)) + >> define (w 2) (And [x, w 1]) + + >> define (w 3) (Inv x) + >> define (w 4) (Xor xs) + >> define (w 5) (And [w 3, w 4]) + >> define v (Or [w 2, w 5]) + + Multi a1 a2 a3 a4 -> multi a1 a2 a3 a4 + where + w i = v ++ "_" ++ show i + + multi n "RAMB16_S18" opts args = + do putStr $ + " " + ++ " : " + ++ "RAMB16_S18" + ++ "\ngeneric map (" + ++ opts + ++ mapTo "DOP" [0,1] (get 16 2 outs) + ++ mapTo "ADDR" [0..9] (get 0 10 args) + where + outs = map (\i -> "o" ++ show i ++ "_" ++ v) [1..n] + + get :: Int -> Int -> [a] -> [a] + get n' m xs = take m (drop n' xs) + + mapTo s' (n':ns) (x:xs) = s' ++ "(" ++ show n' ++ ")" + ++ " => " ++ x ++ ",\n" + ++ mapTo s' ns xs + mapTo _ _ _ = "" + + + + multi n "RAMB16_S18_S18" opts args = + do putStr $ + opts + ++ mapTo "DOA" [0..15] (get 0 16 outs) + ++ mapTo "DOB" [0..15] (get 18 16 outs) + ++ mapTo "DOPA" [0,1] (get 16 2 outs) + ++ mapTo "DOPB" [0,1] (get 34 2 outs) + ++ mapTo "ADDRA" [0..9] (get 0 10 args) + ++ mapTo "ADDRB" [0..9] (get 10 10 args) + ++ mapTo "DIA" [0..15] (get 20 16 args) + ++ mapTo "DIB" [0..15] (get 38 16 args) + ++ mapTo "DIPA" [0,1] (get 36 2 args) + ++ mapTo "DIPB" [0,1] (get 54 2 args) + ++ head (get 56 1 args) + ++ head (get 57 1 args) + where + outs = map (\i -> "o" ++ show i ++ "_" ++ v) [1..n] + + get :: Int -> Int -> [a] -> [a] + get _ _ = id + + mapTo s' (n':ns) (x:xs) = s' ++ "(" ++ show n' ++ ")" + ++ " => " ++ x ++ ",\n" + ++ mapTo s' ns xs + mapTo _ _ _ = "" + multi _ _ _ _ = undefined + + port n args | n == "id" = + do putStr $ + " " + ++ v ++ " <= " ++ (head args) ++ ";\n" + + port _ _ = undefined + netlistIO define (struct out) + return () + +netlistIO :: (v -> S v -> IO ()) -> f Symbol -> IO (f v) +netlistIO = undefined + +data Struct a + +class Generic a where + struct :: a -> Struct Symbol + struct = undefined + +instance Generic (Signal a) + +data Signal a + +data Symbol + +data S s + = Bool Bool + | Inv s + | And [s] + | Or [s] + | Xor [s] + | Multi Int String String [s] + diff --git a/testsuite/tests/typecheck/should_compile/T2412.hs b/testsuite/tests/typecheck/should_compile/T2412.hs new file mode 100644 index 0000000000..509546aa5f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2412.hs @@ -0,0 +1,7 @@ + +module T2412 ( Baz ) where + +import T2412A ( Bar ) + +type Spqr = Bar +data Baz = Baz Spqr diff --git a/testsuite/tests/typecheck/should_compile/T2412.hs-boot b/testsuite/tests/typecheck/should_compile/T2412.hs-boot new file mode 100644 index 0000000000..3467929adc --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2412.hs-boot @@ -0,0 +1,4 @@ + +module T2412 where + +data Baz diff --git a/testsuite/tests/typecheck/should_compile/T2412A.hs b/testsuite/tests/typecheck/should_compile/T2412A.hs new file mode 100644 index 0000000000..a3e1c579e5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2412A.hs @@ -0,0 +1,6 @@ + +module T2412A where + +import {-# SOURCE #-} T2412 ( Baz ) + +type Bar = Baz diff --git a/testsuite/tests/typecheck/should_compile/T2433.hs b/testsuite/tests/typecheck/should_compile/T2433.hs new file mode 100644 index 0000000000..345c961029 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2433.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- Test Trac #2433 + +module T2433 where + + import Data.Typeable(Typeable1) + import T2433_Help( T ) + + deriving instance Typeable1 T diff --git a/testsuite/tests/typecheck/should_compile/T2433_Help.hs b/testsuite/tests/typecheck/should_compile/T2433_Help.hs new file mode 100644 index 0000000000..7760242d4b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2433_Help.hs @@ -0,0 +1,3 @@ +module T2433_Help where + +data T a = MkT a diff --git a/testsuite/tests/typecheck/should_compile/T2478.hs b/testsuite/tests/typecheck/should_compile/T2478.hs new file mode 100644 index 0000000000..eec589b444 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2478.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ExistentialQuantification, DatatypeContexts #-} + +module ShouldCompile where + + data Eq t => TrafoE t = forall env2 . TrafoE Int t + + newSRef () = TrafoE diff --git a/testsuite/tests/typecheck/should_compile/T2478.stderr b/testsuite/tests/typecheck/should_compile/T2478.stderr new file mode 100644 index 0000000000..f03324cd15 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2478.stderr @@ -0,0 +1,3 @@ + +T2478.hs:1:41: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. diff --git a/testsuite/tests/typecheck/should_compile/T2494-2.hs b/testsuite/tests/typecheck/should_compile/T2494-2.hs new file mode 100644 index 0000000000..7e3bfc146b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2494-2.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} + +-- Trac #2494, should compile ok + +module Foo where + +foo :: (forall m. Monad m => Maybe (m a) -> Maybe (m a)) -> Maybe a -> Maybe a +foo _ x = x + +{-# RULES + +"foo/foo" + forall (f :: forall m. Monad m => Maybe (m a) -> Maybe (m a)) + (g :: forall m. Monad m => Maybe (m a) -> Maybe (m a)) x. + foo f (foo g x) = foo (f . g) x + #-} diff --git a/testsuite/tests/typecheck/should_compile/T2494.hs b/testsuite/tests/typecheck/should_compile/T2494.hs new file mode 100644 index 0000000000..55d80a23eb --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2494.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} + +-- Trac #2494, should generate an error message + +module Foo where + +foo :: (forall m. Monad m => Maybe (m a) -> Maybe (m a)) -> Maybe a -> Maybe a +foo _ x = x + +{-# RULES + +"foo/foo" + forall (f :: forall m. Monad m => Maybe (m a) -> Maybe (m a)) + (g :: forall m. Monad m => Maybe (m b) -> Maybe (m b)) x. + foo f (foo g x) = foo (f . g) x + #-} diff --git a/testsuite/tests/typecheck/should_compile/T2494.stderr b/testsuite/tests/typecheck/should_compile/T2494.stderr new file mode 100644 index 0000000000..b522833af2 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2494.stderr @@ -0,0 +1,22 @@ + +T2494.hs:15:7: + Couldn't match type `a' with `b' + `a' is a rigid type variable bound by + the RULE "foo/foo" at T2494.hs:13:46 + `b' is a rigid type variable bound by + the RULE "foo/foo" at T2494.hs:14:46 + Expected type: Maybe (m b) -> Maybe (m b) + Actual type: Maybe (m a) -> Maybe (m a) + In the first argument of `foo', namely `f' + In the expression: foo f (foo g x) + +T2494.hs:15:30: + Couldn't match type `b' with `a' + `b' is a rigid type variable bound by + the RULE "foo/foo" at T2494.hs:14:46 + `a' is a rigid type variable bound by + the RULE "foo/foo" at T2494.hs:13:46 + Expected type: Maybe (m b) -> Maybe (m a) + Actual type: Maybe (m b) -> Maybe (m b) + In the second argument of `(.)', namely `g' + In the first argument of `foo', namely `(f . g)' diff --git a/testsuite/tests/typecheck/should_compile/T2497.hs b/testsuite/tests/typecheck/should_compile/T2497.hs new file mode 100644 index 0000000000..0e6ab4e9f7 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2497.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -fwarn-unused-binds #-} + +module ShouldCompile() where + +-- Trac #2497; test should compile without language +-- pragmas to swith on the forall +{-# RULES "id" forall (x :: a). id x = x #-} + + + +-- Trac #2213; eq should not be reported as unused + +eq,beq :: Eq a => a -> a -> Bool +eq = (==) -- Used +beq = (==) -- Unused + +{-# RULES + "rule 1" forall x y. x == y = y `eq` x + #-} diff --git a/testsuite/tests/typecheck/should_compile/T2497.stderr b/testsuite/tests/typecheck/should_compile/T2497.stderr new file mode 100644 index 0000000000..81b8fbcbb1 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2497.stderr @@ -0,0 +1,2 @@ + +T2497.hs:15:1: Warning: Defined but not used: `beq' diff --git a/testsuite/tests/typecheck/should_compile/T2572.hs b/testsuite/tests/typecheck/should_compile/T2572.hs new file mode 100644 index 0000000000..189055914a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2572.hs @@ -0,0 +1,10 @@ + {-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
+
+-- Trac #2572
+
+module Foo where
+
+type GTypeFun = forall a . a -> ()
+
+gmapType :: Int -> GTypeFun
+gmapType _ (_ :: a) = undefined
diff --git a/testsuite/tests/typecheck/should_compile/T2683.hs b/testsuite/tests/typecheck/should_compile/T2683.hs new file mode 100644 index 0000000000..3e8e9e5892 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2683.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses,
+ FunctionalDependencies, Rank2Types #-}
+
+module Q where
+
+class Transformer t a | t -> a where
+ transform :: t -> l a -> (forall l'. l' a -> b) -> b
+
+data EL a = forall l. EL (l a)
+
+unEL :: EL a -> (forall l. l a -> b) -> b
+unEL = undefined
+
+transform' :: (Transformer t a) => t -> EL a -> EL a
+transform' = undefined
+
+data MultiToggleS ts a = MultiToggleS ts
+
+data MultiToggle = MultiToggle
+
+expand :: HList ts a => MultiToggleS ts a -> MultiToggle
+expand (MultiToggleS ts) =
+ resolve ts
+ (\x mt ->
+ let g = transform' x in
+ mt
+ )
+ MultiToggle
+
+class HList c a | c -> a where
+ resolve :: c -> (forall t. (Transformer t a) => t -> b) -> b
diff --git a/testsuite/tests/typecheck/should_compile/T2735.hs b/testsuite/tests/typecheck/should_compile/T2735.hs new file mode 100644 index 0000000000..81deb7dda4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2735.hs @@ -0,0 +1,7 @@ +-- Trac #2735 + +module Bug where + +data S = S { s1 :: (), s2 :: () } + +f s = s { s1 = (), s2 = s1 s } diff --git a/testsuite/tests/typecheck/should_compile/T2799.hs b/testsuite/tests/typecheck/should_compile/T2799.hs new file mode 100644 index 0000000000..38beabdd48 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2799.hs @@ -0,0 +1,16 @@ +{-# OPTIONS -XGADTs #-} + +module RepAux ( + toSpineRl +) where + +data MTup l where + P :: MTup l -> MTup (a,l) + +data Spine a where + S :: Spine (a -> b) -> Spine b + +toSpineRl :: MTup l -> l -> (l -> a) -> Spine a +toSpineRl (P rs) (a, l) into = S (toSpineRl rs l into') + where + into' tl1 x1 = into (x1,tl1) diff --git a/testsuite/tests/typecheck/should_compile/T2846.hs b/testsuite/tests/typecheck/should_compile/T2846.hs new file mode 100644 index 0000000000..43ad7510fc --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2846.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ImpredicativeTypes, FlexibleContexts #-} +module T2846 where + +x = [1,2,3] :: [Num a => a] diff --git a/testsuite/tests/typecheck/should_compile/T2846.stderr b/testsuite/tests/typecheck/should_compile/T2846.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T2846.stderr diff --git a/testsuite/tests/typecheck/should_compile/T3018.hs b/testsuite/tests/typecheck/should_compile/T3018.hs new file mode 100644 index 0000000000..9ef5b56e60 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T3018.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverlappingInstances , UndecidableInstances, EmptyDataDecls #-} +{-# LANGUAGE Rank2Types, KindSignatures, MultiParamTypeClasses, FlexibleInstances #-} + +-- Works with new constraint solver + +module T3018 where + +import Control.Monad + +-- minimal Data/Rep classes +data Rep ctx a + +class Data (ctx :: * -> *) a where rep :: Rep ctx a + +class Sat a where dict :: a + +--------- Version A: failed in 6.12.3 ----------- +-- Substitution class +-- substitute [a -> t] t'. +class Subst_A a t t' where + subst_A :: (Monad m) => a -> t -> t' -> m t' + +data SubstD_A a t t' = SubstD_A {substD_A:: (Monad m) => a -> t -> t' -> m t'} + +-- Allow override dictionary verion with implementation of type class Subst +instance Subst_A a t t' => Sat (SubstD_A a t t') where + dict = SubstD_A {substD_A = subst_A} + +-- Generic instance +instance Data (SubstD_A a t) t' => Subst_A a t t' where + subst_A = undefined + +--------- Version B: passed in 6.12.3 ----------- +-- Substitution class +-- substitute [a -> t] t'. +class Subst_B a t t' where + subst_B :: a -> t -> t' -> t' + +data SubstD_B a t t' = SubstD_B {substD_B :: a -> t -> t' -> t'} + +-- allow override dictionary verion with implementation of type class Subst +instance Subst_B a t t' => Sat (SubstD_B a t t') where + dict = SubstD_B {substD_B = subst_B} + +-- generic instance +instance Data (SubstD_B a t) t' => Subst_B a t t' where + subst_B = undefined + + +{- Commentary from Trac #3018 + +Here are the key lines of code: + + class Subst a t t' where + subst :: (Monad m) => a -> t -> t' -> m t' + + data SubstD a t t' + = SubstD (forall m. Monad m => a -> t -> t' -> m t') + + instance Data (SubstD a t) t' => Subst a t t' -- (1) + + instance Subst a t t' => Sat (SubstD a t t') where -- (2) + dict = SubstD subst + +The call to 'subst' on the last line gives rise to a constraint (Subst +a t t'). But that constraint can be satisfied in two different ways: + + Using the instance declaration for Subst (which matches anything!) + Using the context of the Sat (SubstD ..) instance declaration itself + +If GHC uses (1) it gets into a corner it can't get out of, because now +it needs (Data (SubstD a t) t'), and that it can't get. The error +message is a bit misleading: + +T3018.hs:29:28: + Could not deduce (Data (SubstD a t) t') from the context (Monad m) + arising from a use of `subst' at T3018.hs:29:28-32 + +it should really say + + ...from the context (Subst a t t', Monad m) + +but that's a bit of a separate matter. + +Now, you are hoping that (2) will happen, but I hope you can see that +it's delicate. Adding the (Monad m) context just tips things over the +edge so that GHC doesn't "see" the (Subst a t t') in the context until +too late. But the real problem is that you are asking too much. Here +is a simpler example: + + f :: Eq [a] => a -> blah + f x = let g :: Int -> Int + g = ....([x]==[x])... + in ... + +The use of == requires Eq [a], but GHC will probably use the list +equality instance to simplify this to Eq a; and then it can't deduce +Eq a from Eq [a]. Local constraints that shadow or override global +instance declarations are extremely delicate. + +All this is perhaps soluble if GHC were to be lazier about solving +constraints, and only makes the attempt when it has all the evidence +in hand. I'm thinking quite a bit about constraint solving at the +moment and will bear that in mind. But I can't offer you an immediate +solution. At least I hope I've explained the problem. +-}
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_compile/T3219.hs b/testsuite/tests/typecheck/should_compile/T3219.hs new file mode 100644 index 0000000000..5c23c1727d --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T3219.hs @@ -0,0 +1,11 @@ +-- Trac #3219. Lint error in GHC 6.10 + +module T3219 where + +data T a = A{ m1 :: a } | B{ m1, m2 :: a } | C{ m2 :: a } + +-- bar :: (a -> a) -> T a -> T a +bar f x@(A m) = x{m1 = f m} + +-- foo :: (a -> a) -> T a -> T a +foo f x@(C m) = x{m2 = f m} diff --git a/testsuite/tests/typecheck/should_compile/T3342.hs b/testsuite/tests/typecheck/should_compile/T3342.hs new file mode 100644 index 0000000000..7881aadb4e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T3342.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} + +module T3342 where + +data F = FT String [F] +data G = GX F F | GY + +spec :: F -> G +spec (FT "X" [t1, t2]) = GX t1 t2 +spec _ = GY + +-- walk :: F -> F +walk (spec -> GX _ t2) = walk t2 +walk t@(FT _ _) = t diff --git a/testsuite/tests/typecheck/should_compile/T3346.hs b/testsuite/tests/typecheck/should_compile/T3346.hs new file mode 100644 index 0000000000..bba57a06f9 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T3346.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -XTypeFamilies #-} + +-- Trac #3346 + +module Foo where + +class EP a where + type Result a + from :: a -> Result a + to :: Result a -> a + +{-# RULES "rule1" forall x. to (from x) = x #-} +{-# RULES "rule2" forall x. from (to x) = x #-} + +foo :: EP a => a -> a +-- This is typed in a way rather similarly to RULE rule1 +foo x = to (from x) + +bar x = from (to x) diff --git a/testsuite/tests/typecheck/should_compile/T3391.hs b/testsuite/tests/typecheck/should_compile/T3391.hs new file mode 100644 index 0000000000..eb569366b5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T3391.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell, Generics #-} +{-# OPTIONS_GHC -v0 #-} + +-- We should only generate one set of generic to/from functions +-- for T, despite the multiple chunks caused by the TH splices +-- See Trac #3391 + +module T3391 where + +data T = MkT + +$(return []) + +$(return []) diff --git a/testsuite/tests/typecheck/should_compile/T3409.hs b/testsuite/tests/typecheck/should_compile/T3409.hs new file mode 100644 index 0000000000..b584fe1f1f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T3409.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ExistentialQuantification, TypeFamilies #-} + +-- Tests a nasty case where 'exprType' or 'coreAltsType' can +-- return a type that mentions an out-of-scope type variable +-- because of a type synonym that discards one of its arguments +-- +-- See Note [Existential variables and silly type synonyms] +-- in CoreUtils + +-- In GHC 6.10, both tests below (independently) give Lint errors + +module T3409 where + + +-------------------------- +-- Simpler version not involving type families + +data T = forall a. T a (Funny a) +type Funny a = Bool + +f :: T -> Bool +f (T x n) = n + + +-------------------------- +-- Cut down version of the original report + +newtype Size s = Size Int + +data ArrayS d e = ArrayS d e + +data Array1 e = forall s . Array1 (Size s) (ArrayS (Size s) e) +-- Array1 :: forall e s. Size s -> ArrayS (Size s) e -> Array1 e + +copy :: Int -> Array1 a -> Array1 a +copy _ (Array1 s a) = Array1 s $ (ArrayS s (bang a)) + -- Array1 s :: ArrayS (Size s) a -> Array1 a + + -- s :: Size s + -- a :: ArrayS (Size s) a + -- ArrayS :: Size s -> a -> ArrayS (Size s) a + -- i :: AccessIx (ArrayS (Size s) a) = Ix s + -- bang a :: AccessResult (ArrayS (Size s) a) = a + + -- ArrayS s (bang a) :: ArrayS (Size s) (AccessResult (ArrayS (Size s) a)) + +class Access a where + type AccessResult a + bang :: a -> AccessResult a + +instance Access (ArrayS d a) where + type AccessResult (ArrayS d a) = a + bang = error "urk" diff --git a/testsuite/tests/typecheck/should_compile/T3692.hs b/testsuite/tests/typecheck/should_compile/T3692.hs new file mode 100644 index 0000000000..b10e184d94 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T3692.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE RankNTypes #-}
+
+module T3692 where
+
+type Foo a b = () -> (Bar a => a)
+
+class Bar a where {}
+
+foo :: Foo a b
+foo = id (undefined :: Foo a b)
diff --git a/testsuite/tests/typecheck/should_compile/T3696.hs b/testsuite/tests/typecheck/should_compile/T3696.hs new file mode 100644 index 0000000000..af39ee85b7 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T3696.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -Wall #-} + +module T3696 where + +class C a where c :: a + +instance C Int where c = 37 + +def = c + +use :: Int +use = def diff --git a/testsuite/tests/typecheck/should_compile/T3696.stderr b/testsuite/tests/typecheck/should_compile/T3696.stderr new file mode 100644 index 0000000000..1784e53511 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T3696.stderr @@ -0,0 +1,3 @@ +
+T3696.hs:9:1:
+ Warning: Top-level binding with no type signature: def :: Int
diff --git a/testsuite/tests/typecheck/should_compile/T3955.hs b/testsuite/tests/typecheck/should_compile/T3955.hs new file mode 100644 index 0000000000..921753b80a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T3955.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +-- Test for Trac #3955 + +module T3955 where + +class (Monad m) => MonadReader r m +newtype Reader r a = Reader { runReader :: r -> a } + +instance Monad (Reader r) where + (>>=) = error "urk" + return = error "urk" + +instance MonadReader r (Reader r) + +newtype T a x = T (Reader a x) + deriving (Monad, MonadReader a) + +{- +[1 of 1] Compiling Main ( bug.hs, interpreted ) +mkUsageInfo: internal name? a{tv amy} +Ok, modules loaded: Main. +-} diff --git a/testsuite/tests/typecheck/should_compile/T4284.hs b/testsuite/tests/typecheck/should_compile/T4284.hs new file mode 100644 index 0000000000..2d5164a487 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4284.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE RankNTypes #-} +module Test where + +foo :: () -> forall b. b +foo = undefined + +works = id foo + +fails = (id) foo + +-- works type checks, but fails fails with the following error +-- message: +-- +-- Cannot match a monotype with `() -> forall b. b' +-- Probable cause: `foo' is applied to too few arguments +-- In the first argument of `(id)', namely `foo' +-- In the expression: (id) foo diff --git a/testsuite/tests/typecheck/should_compile/T4355.hs b/testsuite/tests/typecheck/should_compile/T4355.hs new file mode 100644 index 0000000000..8eff366cdc --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4355.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, Rank2Types, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, PatternGuards, DatatypeContexts #-} + +module T4355 where + +import Control.Arrow +import Control.Monad.Trans -- From mtl +import Control.Monad.Reader -- Ditto +import Data.Typeable +import Data.Maybe + +class (Eq t, Typeable t) => Transformer t a | t -> a where + transform :: (LayoutClass l a) => t -> l a -> + (forall l'. (LayoutClass l' a) => l' a -> (l' a -> l a) -> b) -> b + +class HList c a where + find :: (Transformer t a) => c -> t -> Maybe Int + +class Typeable a => Message a + +data (LayoutClass l a) => EL l a = forall l'. (LayoutClass l' a) => EL (l' a) (l' a -> l a) + +unEL :: (LayoutClass l a) => EL l a -> (forall l'. (LayoutClass l' a) => l' a -> b) -> b +unEL (EL x _) k = k x + +transform' :: (Transformer t a, LayoutClass l a) => t -> EL l a -> EL l a +transform' t (EL l det) = transform t l (\l' det' -> EL l' (det . det')) + +data Toggle a = forall t. (Transformer t a) => Toggle t + deriving (Typeable) + +instance (Typeable a) => Message (Toggle a) + +data MultiToggle ts l a = MultiToggle{ + currLayout :: EL l a, + currIndex :: Maybe Int, + transformers :: ts +} + +instance (Show ts, Show (l a), LayoutClass l a) => Show (MultiToggle ts l a) where + +class Show (layout a) => LayoutClass layout a where + handleMessage :: layout a -> SomeMessage -> IO (Maybe (layout a)) + +instance (Typeable a, Show ts, HList ts a, LayoutClass l a) + => LayoutClass (MultiToggle ts l) a where + handleMessage mt m + | Just (Toggle t) <- fromMessage m + , i@(Just _) <- find (transformers mt) t + = case currLayout mt of + EL l det -> do + return . Just $ + mt { + currLayout = (if cur then id else transform' t) (EL (det l) id) + } + where cur = (i == currIndex mt) + +data SomeMessage = forall a. Message a => SomeMessage a + +fromMessage :: Message m => SomeMessage -> Maybe m +fromMessage (SomeMessage m) = cast m diff --git a/testsuite/tests/typecheck/should_compile/T4355.stderr b/testsuite/tests/typecheck/should_compile/T4355.stderr new file mode 100644 index 0000000000..af072e6867 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4355.stderr @@ -0,0 +1,3 @@ + +T4355.hs:1:172: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. diff --git a/testsuite/tests/typecheck/should_compile/T4361.hs b/testsuite/tests/typecheck/should_compile/T4361.hs new file mode 100644 index 0000000000..19727c2e53 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4361.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- This test comes from Sergei Mechveliani's DoCon system + +module Pol3_ (moduloBasisx) where + +class CommutativeRing a +class CommutativeRing a => LinSolvRing a +class LinSolvRing a => EuclideanRing a + +instance EuclideanRing a => LinSolvRing (Pol a) -- XXXX +instance CommutativeRing a => CommutativeRing (Pol a) + +data Pol a = MkPol + +upLinSolvRing :: LinSolvRing a => a -> () +upLinSolvRing = undefined + +moduloBasisx :: (LinSolvRing (Pol a), CommutativeRing a) => Pol a -> () +moduloBasisx p = let x = upLinSolvRing p + in () + + -- This is very delicate! The contraint (LinSolvRing (Pol a)) + -- arises in the RHS of x, and we must be careful *not* to simplify + -- it with the instance declaration "XXXX", else we get the + -- unsatisfiable constraint (EuclideanRing a). In effect, the + -- given constraint in the type sig for moduleBasisx overlaps + -- with the top level declaration. + diff --git a/testsuite/tests/typecheck/should_compile/T4401.hs b/testsuite/tests/typecheck/should_compile/T4401.hs new file mode 100644 index 0000000000..81fcf71a96 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4401.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances, + MultiParamTypeClasses, FunctionalDependencies #-} +module T4401 where + +class Mul x y z | x y -> z +class IsType a +class IsType a => IsSized a s | a -> s + +data Array n a = Array +instance IsSized a s => IsType (Array n a) +instance (IsSized a s, Mul n s ns) => IsSized (Array n a) ns diff --git a/testsuite/tests/typecheck/should_compile/T4404.hs b/testsuite/tests/typecheck/should_compile/T4404.hs new file mode 100644 index 0000000000..894066542a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4404.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE RecordWildCards, DoRec #-} + +module TT where + +data T = T {t1, t2 :: Int} + +f :: T -> Int +f d = x + where T {t1 = x, ..} = d + +g :: T -> Int +g (T {t1 = x, ..}) = x + +-- The fix to this test also affected the dorec checking code, hence this: +h :: Maybe Int +h = do + rec + T {t1 = x, ..} <- Just $ T 1 1 + return x diff --git a/testsuite/tests/typecheck/should_compile/T4418.hs b/testsuite/tests/typecheck/should_compile/T4418.hs new file mode 100644 index 0000000000..9b90fd61a6 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4418.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + +module Ambiguity where + +class C1 a b | b -> a +class (C1 a b) => C2 a b where + foo :: b -> b + +data A = A +data B = B +instance C1 A B +instance C2 A B where foo = error "urk" + +-- this is accepted by both 6.12.3 and 7 +runFoo1 :: C2 a b => b -> b +runFoo1 = foo + +-- this is accepted by 6.12.3, but not by 7 +runFoo2 :: B -> B +runFoo2 = foo diff --git a/testsuite/tests/typecheck/should_compile/T4444.hs b/testsuite/tests/typecheck/should_compile/T4444.hs new file mode 100644 index 0000000000..5f07d5d71d --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4444.hs @@ -0,0 +1,18 @@ + +-- #4444: We shouldn't warn about SPECIALISE INLINE pragmas on +-- non-overloaded functions + +{-# LANGUAGE GADTs, MagicHash #-} +module Q where + +import GHC.Exts + +data Arr e where + ArrInt :: !Int -> ByteArray# -> Arr Int + ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) + +(!:) :: Arr e -> Int -> e +{-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} +{-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} +(ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) +(ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) diff --git a/testsuite/tests/typecheck/should_compile/T4498.hs b/testsuite/tests/typecheck/should_compile/T4498.hs new file mode 100644 index 0000000000..fb8c120601 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4498.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE BangPatterns, NoMonoLocalBinds, NoMonoPatBinds #-} + +module T4498 where + +f x = let !y = (\v -> v) :: a -> a + in (y x, y 'T') + diff --git a/testsuite/tests/typecheck/should_compile/T4524.hs b/testsuite/tests/typecheck/should_compile/T4524.hs new file mode 100644 index 0000000000..c59ad08b0a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4524.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE + GADTs, + TypeOperators, + ScopedTypeVariables, + RankNTypes, + NoMonoLocalBinds + #-} +{-# OPTIONS_GHC -O2 -w #-} +{- + Copyright (C) 2002-2003 David Roundy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; see the file COPYING. If not, write to + the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. +-} + +module T4524 where + +import Data.Maybe ( mapMaybe ) +import Control.Monad ( MonadPlus, mplus, msum, mzero ) +import Unsafe.Coerce (unsafeCoerce) + +newtype FileName = FN FilePath deriving ( Eq, Ord ) + +data FL a x z where + (:>:) :: a x y -> FL a y z -> FL a x z + NilFL :: FL a x x +data RL a x z where + (:<:) :: a y z -> RL a x y -> RL a x z + NilRL :: RL a x x +data (a1 :> a2) x y = forall z. (a1 x z) :> (a2 z y) +infixr 1 :> +data (a1 :< a2) x y = forall z. (a1 z y) :< (a2 x z) +infix 1 :< +infixr 5 :>:, :<: + +data EqCheck a b where + IsEq :: EqCheck a a + NotEq :: EqCheck a b + +class MyEq p => Invert p where + invert :: p x y -> p y x + identity :: p x x + +class MyEq p where + unsafeCompare :: p a b -> p c d -> Bool + unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b) + + (=\/=) :: p a b -> p a c -> EqCheck b c + a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq + | otherwise = NotEq + + (=/\=) :: p a c -> p b c -> EqCheck a b + a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq + | otherwise = NotEq + +infix 4 =\/=, =/\= + +class Commute p where + commute :: (p :> p) x y -> Maybe ((p :> p) x y) + +instance (MyEq p, Commute p) => MyEq (FL p) where +instance (MyEq p, Commute p) => MyEq (RL p) where +instance Commute p => Commute (RL p) where +instance (Commute p, Invert p) => Invert (RL p) where +instance (Invert p, Commute p) => Invert (FL p) where +instance Eq (EqCheck a b) where +instance MyEq FilePatchType where +instance Invert Patch where + +instance MyEq Patch where + unsafeCompare = eqPatches + +eqPatches :: Patch x y -> Patch w z -> Bool +eqPatches (PP p1) (PP p2) = undefined +eqPatches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b) + = eqPatches p1a p2a && + eqPatches p1b p2b +eqPatches (Regrem _ _ p1a p1b) (Regrem _ _ p2a p2b) + = eqPatches p1a p2a && + eqPatches p1b p2b +eqPatches _ _ = False + +data Prim x y where + FP :: !FileName -> !(FilePatchType x y) -> Prim x y + +data FilePatchType x y = FilePatchType + deriving (Eq,Ord) + +data Patch x y where + PP :: Prim x y -> Patch x y + Merger :: FL Patch x y + -> RL Patch x b + -> Patch c b + -> Patch c d + -> Patch x y + Regrem :: FL Patch x y + -> RL Patch x b + -> Patch c b + -> Patch c a + -> Patch y x + +data Sealed a where + Sealed :: a x -> Sealed a +data FlippedSeal a y where + FlippedSeal :: !(a x y) -> FlippedSeal a y + +mapFlipped :: (forall x. a x y -> b x z) -> FlippedSeal a y -> FlippedSeal b z +mapFlipped f (FlippedSeal x) = FlippedSeal (f x) + +headPermutationsRL :: Commute p => RL p x y -> [RL p x y] +headPermutationsRL NilRL = [] +headPermutationsRL (p:<:ps) = + (p:<:ps) : mapMaybe (swapfirstRL.(p:<:)) (headPermutationsRL ps) + where swapfirstRL (p1:<:p2:<:xs) = do p1':>p2' <- commute (p2:>p1) + Just $ p2':<:p1':<:xs + swapfirstRL _ = Nothing + +is_filepatch :: Prim x y -> Maybe FileName +is_filepatch (FP f _) = Just f +is_filepatch _ = Nothing + +toFwdCommute :: (Commute p, Commute q, Monad m) + => ((p :< q) x y -> m ((q :< p) x y)) + -> (q :> p) x y -> m ((p :> q) x y) +toFwdCommute c (x :> y) = do x' :< y' <- c (y :< x) + return (y' :> x') + +unsafeUnseal :: Sealed a -> a x +unsafeUnseal (Sealed a) = unsafeCoerceP1 a + +unsafeUnsealFlipped :: FlippedSeal a y -> a x y +unsafeUnsealFlipped (FlippedSeal a) = unsafeCoerceP a + +unsafeCoerceP :: a x y -> a b c +unsafeCoerceP = unsafeCoerce + +unsafeCoercePStart :: a x1 y -> a x2 y +unsafeCoercePStart = unsafeCoerce + +unsafeCoercePEnd :: a x y1 -> a x y2 +unsafeCoercePEnd = unsafeCoerce + +unsafeCoerceP1 :: a x -> a y +unsafeCoerceP1 = unsafeCoerce + +data Perhaps a = Unknown | Failed | Succeeded a + +instance Monad Perhaps where + (Succeeded x) >>= k = k x + Failed >>= _ = Failed + Unknown >>= _ = Unknown + Failed >> _ = Failed + (Succeeded _) >> k = k + Unknown >> k = k + return = Succeeded + fail _ = Unknown + +instance MonadPlus Perhaps where + mzero = Unknown + Unknown `mplus` ys = ys + Failed `mplus` _ = Failed + (Succeeded x) `mplus` _ = Succeeded x + +toMaybe :: Perhaps a -> Maybe a +toMaybe (Succeeded x) = Just x +toMaybe _ = Nothing + +cleverCommute :: CommuteFunction -> CommuteFunction +cleverCommute c (p1:<p2) = + case c (p1 :< p2) of + Succeeded x -> Succeeded x + Failed -> Failed + +speedyCommute :: CommuteFunction +speedyCommute (p1 :< p2) -- Deal with common case quickly! + | p1_modifies /= Nothing && p2_modifies /= Nothing && + p1_modifies /= p2_modifies = undefined + | otherwise = Unknown + where p1_modifies = isFilepatchMerger p1 + p2_modifies = isFilepatchMerger p2 + +everythingElseCommute :: MaybeCommute -> CommuteFunction +everythingElseCommute _ x = undefined + +unsafeMerger :: String -> Patch x y -> Patch x z -> Patch a b +unsafeMerger x p1 p2 = unsafeCoercePStart $ unsafeUnseal $ merger x p1 p2 + +mergerCommute :: (Patch :< Patch) x y -> Perhaps ((Patch :< Patch) x y) +mergerCommute (Merger _ _ p1 p2 :< pA) + | unsafeCompare pA p1 = Succeeded (unsafeMerger "0.0" p2 p1 :< unsafeCoercePStart p2) + | unsafeCompare pA (invert (unsafeMerger "0.0" p2 p1)) = Failed +mergerCommute (Merger _ _ + (Merger _ _ c b) + (Merger _ _ c' a) :< + Merger _ _ b' c'') + | unsafeCompare b' b && unsafeCompare c c' && unsafeCompare c c'' = undefined +mergerCommute _ = Unknown + +instance Commute Patch where + commute x = toMaybe $ msum + [toFwdCommute speedyCommute x, + toFwdCommute (cleverCommute mergerCommute) x, + toFwdCommute (everythingElseCommute undefined) x + ] + +isFilepatchMerger :: Patch x y -> Maybe FileName +isFilepatchMerger (PP p) = is_filepatch p +isFilepatchMerger (Regrem und unw p1 p2) + = isFilepatchMerger (Merger und unw p1 p2) + +type CommuteFunction = forall x y. (Patch :< Patch) x y -> Perhaps ((Patch :< Patch) x y) +type MaybeCommute = forall x y. (Patch :< Patch) x y -> Maybe ((Patch :< Patch) x y) + +{- unwind, trueUnwind, reconcleUnwindings, and merger are most likely + where the problem lies. Everything above is just brought in to bring + in enough context so that those four will compile. -} +unwind :: Patch x y -> Sealed (RL Patch x) -- Recreates a patch history in reverse. +unwind (Merger _ unwindings _ _) = Sealed unwindings +unwind p = Sealed (p :<: NilRL) + +trueUnwind :: Patch x y -> Sealed (RL Patch x) -- Recreates a patch history in reverse. +trueUnwind p@(Merger _ _ p1 p2) = + case (unwind p1, unwind p2) of + (Sealed (_:<:p1s),Sealed (_:<:p2s)) -> + Sealed (p :<: unsafeCoerceP p1 :<: unsafeUnsealFlipped (reconcileUnwindings p1s (unsafeCoercePEnd p2s))) + +reconcileUnwindings :: RL Patch x z -> RL Patch y z -> FlippedSeal (RL Patch) z +reconcileUnwindings p1s NilRL = FlippedSeal p1s +reconcileUnwindings (p1:<:_) (p2:<:_) = + case [undefined | p1s'@(_:<:_) <- headPermutationsRL (p1:<:undefined)] of + ((_:<:p1s', _:<:p2s'):_) -> + mapFlipped (undefined :<:) $ reconcileUnwindings p1s' (unsafeCoercePEnd p2s') + +merger :: String -> Patch x y -> Patch x z -> Sealed (Patch y) +merger "0.0" p1 p2 = Sealed $ Merger undoit unwindings p1 p2 + where fake_p = Merger identity NilRL p1 p2 + unwindings = unsafeUnseal (trueUnwind fake_p) + p = undefined + undoit = undefined diff --git a/testsuite/tests/typecheck/should_compile/T4912.hs b/testsuite/tests/typecheck/should_compile/T4912.hs new file mode 100644 index 0000000000..539ba078ee --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4912.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fwarn-orphans #-} +module T4912 where + +import T4912a + + +type OurData = TheirData + +instance Foo TheirData where + foo = id + +instance Bar OurData where + bar _ = "Ours" diff --git a/testsuite/tests/typecheck/should_compile/T4912.stderr b/testsuite/tests/typecheck/should_compile/T4912.stderr new file mode 100644 index 0000000000..c944dc1260 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4912.stderr @@ -0,0 +1,4 @@ + +T4912.hs:10:10: Warning: orphan instance: instance Foo TheirData + +T4912.hs:13:10: Warning: orphan instance: instance Bar OurData diff --git a/testsuite/tests/typecheck/should_compile/T4912a.hs b/testsuite/tests/typecheck/should_compile/T4912a.hs new file mode 100644 index 0000000000..4cc1548c05 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4912a.hs @@ -0,0 +1,9 @@ +module T4912a where + +data TheirData = TheirData + +class Foo a where + foo :: a -> a + +class Bar a where + bar :: a -> String diff --git a/testsuite/tests/typecheck/should_compile/T4917.hs b/testsuite/tests/typecheck/should_compile/T4917.hs new file mode 100644 index 0000000000..f6d51d4c27 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4917.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs, ScopedTypeVariables, EmptyDataDecls, RankNTypes #-} + +module T4917 where + +-- only works on ghc6 but not on ghc7 +type Const a b = a + +newtype Fix f n = In { out :: f (Fix f) n } + +mcata :: forall f a b . + (forall x c . (forall d . x d -> Const b d) -> f x c -> Const b c) + -> Fix f a -> Const b a +mcata f x = f {- x=(Fix f), c=a -} mcataf outx + where + outx :: f (Fix f) a + outx = out x + + mcataf :: forall d. Fix f d -> Const b d + mcataf y = mcata {- f=f, a=d, b=b0 -} f (y :: Fix f d) + -- Const b d ~ Const b0 d + -- Expected type of f :: forall x c. (forall d. x d -> Const b0 d) -> f x c -> Const b0 c diff --git a/testsuite/tests/typecheck/should_compile/T4952.hs b/testsuite/tests/typecheck/should_compile/T4952.hs new file mode 100644 index 0000000000..b0d2fba794 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4952.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE UndecidableInstances, + MultiParamTypeClasses, + KindSignatures, + FlexibleInstances, + FunctionalDependencies #-} + +module Storage.Hashed.Monad () where + +class Monad m => TreeRO m where + withDirectory :: (MonadError e m) => Int -> m a -> m a + expandTo :: (MonadError e m) => Int -> m Int + +instance (Monad m, MonadError e m) => TreeRO (M m) where + expandTo = undefined + withDirectory dir _ = do + _ <- expandTo dir + undefined + +data M (m :: * -> *) a + +instance Monad m => Monad (M m) where + (>>=) = undefined + return = undefined + +instance MonadError e m => MonadError e (M m) + +class Monad m => MonadError e m | m -> e diff --git a/testsuite/tests/typecheck/should_compile/T4969.hs b/testsuite/tests/typecheck/should_compile/T4969.hs new file mode 100644 index 0000000000..084420e660 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T4969.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_GHC -w #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleContexts, FlexibleInstances, + OverlappingInstances, UndecidableInstances #-} + +-- Cut down from a larger core-lint error + +module Q where + +import Control.Monad (foldM) + +data NameId = NameId +data Named name a = Named +data Arg e = Arg + +data Range = Range +data Name = Name +data ALetBinding = ALetBinding +data APattern a = APattern +data CExpr = CExpr +data CPattern = CPattern +data NiceDeclaration = QQ +data TypeError = NotAValidLetBinding NiceDeclaration +data TCState = TCSt { stFreshThings :: FreshThings } +data FreshThings = Fresh + +newtype NewName a = NewName a +newtype LetDef = LetDef NiceDeclaration +newtype TCMT m a = TCM () + +localToAbstract :: ToAbstract c a => c -> (a -> TCMT IO b) -> TCMT IO b +localToAbstract = undefined + +typeError :: MonadTCM tcm => TypeError -> tcm a +typeError = undefined + +lhsArgs :: [Arg (Named String CPattern)] +lhsArgs = undefined + +freshNoName :: (MonadState s m, HasFresh NameId s) => Range -> m Name +freshNoName = undefined + +class (Monad m) => MonadState s m | m -> s +class (Monad m) => MonadIO m + +class ToAbstract concrete abstract | concrete -> abstract where + toAbstract :: concrete -> TCMT IO abstract + +class (MonadState TCState tcm) => MonadTCM tcm where + liftTCM :: TCMT IO a -> tcm a + +class HasFresh i a where + nextFresh :: a -> (i,a) + +instance ToAbstract c a => ToAbstract [c] [a] where +instance ToAbstract c a => ToAbstract (Arg c) (Arg a) where +instance ToAbstract c a => ToAbstract (Named name c) (Named name a) where +instance ToAbstract CPattern (APattern CExpr) where + +instance ToAbstract LetDef [ALetBinding] where + toAbstract (LetDef d) = do _ <- letToAbstract + undefined + where letToAbstract = do + localToAbstract lhsArgs $ \args -> + foldM lambda undefined undefined + lambda _ _ = do x <- freshNoName undefined + return undefined + lambda _ _ = typeError $ NotAValidLetBinding d + +instance HasFresh NameId FreshThings where + nextFresh = undefined + +instance HasFresh i FreshThings => HasFresh i TCState where + nextFresh = undefined + +instance Monad m => MonadState TCState (TCMT m) where + +instance Monad m => MonadTCM (TCMT m) where + liftTCM = undefined + +instance Monad (TCMT m) where + return = undefined + (>>=) = undefined + fail = undefined + +instance Monad m => MonadIO (TCMT m) where + diff --git a/testsuite/tests/typecheck/should_compile/T5051.hs b/testsuite/tests/typecheck/should_compile/T5051.hs new file mode 100644 index 0000000000..e98c074c4b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T5051.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleInstances, OverlappingInstances #-} + +-- A very delicate interaction of overlapping instances + +module T5051 where + +data T = T deriving( Eq, Ord ) +instance Eq [T] + +foo :: Ord a => [a] -> Bool +foo x = x >= x + +-- Bizarrely, the defn of 'foo' failed in GHC 7.0.3 with +-- T5051.hs:14:10: +-- Overlapping instances for Eq [a] +-- arising from a use of `>' +-- Matching instances: +-- instance Eq a => Eq [a] -- Defined in GHC.Classes +-- instance [overlap ok] Eq [T] -- Defined at T5051.hs:9:10-15 +-- (The choice depends on the instantiation of `a' +-- To pick the first instance above, use -XIncoherentInstances +-- when compiling the other instance declarations) +-- In the expression: x > x +-- +-- Reason: the dfun for Ord [a] (in the Prelude) had a "silent" +-- superclass parameter, thus +-- $dfOrdList :: forall a. (Eq [a], Ord a) => Ord [a] +-- Using the dfun means we need Eq [a], and that gives rise to the +-- overlap error. +-- +-- This is terribly confusing: the use of (>=) means we need Ord [a], +-- and if we have Ord a (which we do) we should be done. +-- A very good reason for not having silent parameters! diff --git a/testsuite/tests/typecheck/should_compile/T5120.hs b/testsuite/tests/typecheck/should_compile/T5120.hs new file mode 100644 index 0000000000..6fe95c4516 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T5120.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+
+module Test where
+
+class C t where
+ type TF t
+ ttt :: TF t -> t
+
+b :: (C t, ?x :: TF t) => t
+b = ttt ?x
diff --git a/testsuite/tests/typecheck/should_compile/T700.hs b/testsuite/tests/typecheck/should_compile/T700.hs new file mode 100644 index 0000000000..9024033c29 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T700.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE RankNTypes #-} + +module T700 where + +-- These two should behave the same way + +f,g :: (forall a. Maybe a) -> (forall a. a) + +f x = case x of Just y -> y +g (Just y) = y diff --git a/testsuite/tests/typecheck/should_compile/Tc170_Aux.hs b/testsuite/tests/typecheck/should_compile/Tc170_Aux.hs new file mode 100644 index 0000000000..c7cd186f13 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/Tc170_Aux.hs @@ -0,0 +1,24 @@ + +module Tc170_Aux where + +class ReadMode mode + +data Attr m w a = Attr (w -> IO a) (w -> a -> IO ()) + +mapAttr :: ReadMode m => (a -> b) -> (a -> b -> a) -> Attr m w a -> Attr m w b +mapAttr get set (Attr getter setter) + = Attr (\w -> do a <- getter w; return (get a)) + (\w b -> do a <- getter w; setter w (set a b)) + + +data Rect = Rect +data Point = Point +topLeft = undefined +rectMoveTo = undefined + +class Dimensions w where + frame :: ReadMode m => Attr m w Rect + + position :: ReadMode m => Attr m w Point + position = mapAttr (\f -> topLeft f) (\f p -> rectMoveTo p f) frame + diff --git a/testsuite/tests/typecheck/should_compile/Tc173a.hs b/testsuite/tests/typecheck/should_compile/Tc173a.hs new file mode 100644 index 0000000000..c8a589d2b3 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/Tc173a.hs @@ -0,0 +1,17 @@ +module Tc173a where + +class FormValue value where + isFormValue :: value -> () + isFormValue _ = () + +class FormTextField value + +instance FormTextField String + +instance FormTextField value => FormTextFieldIO value + +class FormTextFieldIO value + +instance FormTextFieldIO value => FormValue value + +instance FormTextFieldIO value => FormTextFieldIO (Maybe value) diff --git a/testsuite/tests/typecheck/should_compile/Tc173b.hs b/testsuite/tests/typecheck/should_compile/Tc173b.hs new file mode 100644 index 0000000000..c98c57acd8 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/Tc173b.hs @@ -0,0 +1,6 @@ +module Tc173b where + +import Tc173a + +is :: () +is = isFormValue (Just "")
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_compile/Tc239_Help.hs b/testsuite/tests/typecheck/should_compile/Tc239_Help.hs new file mode 100644 index 0000000000..c72acdfb11 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/Tc239_Help.hs @@ -0,0 +1,13 @@ +module Tc239_Help ( WrapIO, WrapIO2 ) where
+
+newtype WrapIO e a = MkWrapIO { unwrap :: IO a }
+
+type WrapIO2 a = WrapIO String a
+
+instance Monad (WrapIO e) where
+ return x = MkWrapIO (return x)
+
+ m >>= f = MkWrapIO (do x <- unwrap m
+ unwrap (f x) )
+
+ fail str = error str
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_compile/Tc245_A.hs b/testsuite/tests/typecheck/should_compile/Tc245_A.hs new file mode 100644 index 0000000000..6b03118723 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/Tc245_A.hs @@ -0,0 +1,5 @@ + +{-# LANGUAGE TypeFamilies #-} +module Tc245_A where +class Foo a where + data Bar a :: * -> * diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T new file mode 100644 index 0000000000..b8440458c4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -0,0 +1,348 @@ +# Args to vtc are: extra compile flags + +def f( opts ): + opts.extra_hc_opts = '-fno-warn-incomplete-patterns' + +setTestOpts(f) + +test('tc001', normal, compile, ['']) +test('tc002', normal, compile, ['']) +test('tc003', normal, compile, ['']) +test('tc004', normal, compile, ['']) +test('tc005', normal, compile, ['']) +test('tc006', normal, compile, ['']) +test('tc007', normal, compile, ['']) +test('tc008', normal, compile, ['']) +test('tc009', normal, compile, ['']) +test('tc010', normal, compile, ['']) +test('tc011', normal, compile, ['']) +test('tc012', normal, compile, ['']) +test('tc013', normal, compile, ['']) +test('tc014', normal, compile, ['']) +test('tc015', normal, compile, ['']) +test('tc016', normal, compile, ['']) +test('tc017', normal, compile, ['']) +test('tc018', normal, compile, ['']) +test('tc019', normal, compile, ['']) +test('tc020', normal, compile, ['']) +test('tc021', normal, compile, ['']) +test('tc022', normal, compile, ['']) +test('tc023', normal, compile, ['']) +test('tc024', normal, compile, ['']) +test('tc025', normal, compile, ['']) +test('tc026', normal, compile, ['']) +test('tc027', normal, compile, ['']) +test('tc028', normal, compile, ['']) +test('tc029', normal, compile, ['']) +test('tc030', normal, compile, ['']) +test('tc031', normal, compile, ['']) +test('tc032', normal, compile, ['']) +test('tc033', normal, compile, ['']) +test('tc034', normal, compile, ['']) +test('tc035', normal, compile, ['']) +test('tc036', normal, compile, ['']) +test('tc037', normal, compile, ['']) +test('tc038', normal, compile, ['']) +test('tc039', normal, compile, ['']) +test('tc040', normal, compile, ['']) +test('tc041', normal, compile, ['']) +test('tc042', normal, compile, ['']) +test('tc043', normal, compile, ['']) +test('tc044', normal, compile, ['']) +test('tc045', normal, compile, ['']) +test('tc046', normal, compile, ['']) +test('tc047', normal, compile, ['']) +test('tc048', normal, compile, ['']) +test('tc049', normal, compile, ['']) +test('tc050', normal, compile, ['']) +test('tc051', normal, compile, ['']) +test('tc052', normal, compile, ['']) +test('tc053', normal, compile, ['']) +test('tc054', normal, compile, ['']) +test('tc055', normal, compile, ['']) +test('tc056', normal, compile, ['']) +test('tc057', normal, compile, ['']) +test('tc058', normal, compile, ['']) +test('tc059', normal, compile, ['']) +test('tc060', normal, compile, ['']) +test('tc061', normal, compile, ['']) +test('tc062', normal, compile, ['']) +test('tc063', normal, compile, ['']) +test('tc064', normal, compile, ['']) +test('tc065', normal, compile, ['']) +test('tc066', normal, compile, ['']) +test('tc067', normal, compile, ['']) +test('tc068', normal, compile, ['']) +test('tc069', normal, compile, ['']) +test('tc070', normal, compile, ['']) +test('tc073', normal, compile, ['']) +test('tc074', normal, compile, ['']) +test('tc076', normal, compile, ['']) +test('tc077', normal, compile, ['']) +test('tc078', normal, compile, ['']) +test('tc079', normal, compile, ['']) +test('tc080', normal, compile, ['']) +test('tc081', normal, compile, ['']) +test('tc082', normal, compile, ['']) +test('tc084', if_compiler_type('hugs', expect_fail), compile, ['']) +test('tc085', only_compiler_types(['ghc']), compile, ['']) +test('tc086', normal, compile, ['']) +test('tc087', normal, compile, ['']) +test('tc088', normal, compile, ['']) +test('tc089', normal, compile, ['']) +test('tc090', normal, compile, ['']) +test('tc091', normal, compile, ['']) +test('tc092', normal, compile, ['']) +test('tc093', normal, compile, ['']) +test('tc094', normal, compile, ['']) +test('tc095', normal, compile, ['']) +test('tc096', if_compiler_type('hugs', expect_fail), compile, ['']) +test('tc097', normal, compile, ['']) +test('tc098', normal, compile, ['']) +test('tc099', normal, compile, ['']) +test('tc100', normal, compile, ['']) +test('tc101', normal, compile, ['']) +test('tc102', normal, compile, ['']) +# tc103 free +test('tc104', normal, compile, ['']) +test('tc105', normal, compile, ['']) +test('tc106', normal, compile, ['']) +test('tc107', normal, compile, ['']) +test('tc108', normal, compile, ['']) +test('tc109', normal, compile, ['']) +test('tc111', normal, compile, ['']) +test('tc112', normal, compile, ['']) +test('tc113', normal, compile, ['']) +test('tc114', normal, compile, ['']) +test('tc115', normal, compile, ['']) +test('tc116', normal, compile, ['']) +test('tc117', normal, compile, ['']) +test('tc118', normal, compile, ['']) +test('tc119', normal, compile, ['']) +test('tc120', normal, compile, ['']) +test('tc121', normal, compile, ['']) +test('tc122', normal, compile, ['']) +test('tc123', normal, compile, ['']) +test('tc124', normal, compile, ['']) +test('tc125', normal, compile, ['']) +test('tc126', normal, compile, ['']) +test('tc127', normal, compile, ['']) +test('tc128', normal, compile, ['']) +test('tc129', normal, compile, ['']) +test('tc130', normal, compile, ['']) +test('tc131', normal, compile, ['']) +test('tc132', normal, compile, ['']) +test('tc133', normal, compile, ['']) + +# tc134 tested result type signatures, which aren't supported any more +# test('tc134', only_compiler_types(['ghc']), compile_fail, ['']) + +test('tc135', only_compiler_types(['ghc']), compile, ['']) +test('tc136', normal, compile, ['']) +test('tc137', normal, compile, ['']) +test('tc140', normal, compile, ['']) +test('tc141', normal, compile_fail, ['']) +test('tc142', normal, compile, ['']) +test('tc143', normal, compile, ['']) +test('tc144', omit_compiler_types(['hugs']), compile, ['']) # Hugs loops +test('tc145', normal, compile, ['']) +test('tc146', normal, compile, ['']) +test('tc147', normal, compile, ['']) +test('tc148', only_compiler_types(['ghc']), compile, ['']) +test('tc149', only_compiler_types(['ghc']), compile, ['']) +test('tc150', normal, compile, ['']) +test('tc151', normal, compile, ['']) +test('tc152', only_compiler_types(['ghc']), compile, ['']) +test('tc153', normal, compile, ['']) +test('tc154', normal, compile, ['']) +test('tc155', normal, compile, ['']) +test('tc156', only_compiler_types(['ghc']), compile, ['']) +test('tc157', normal, compile, ['']) +test('tc158', only_compiler_types(['ghc']), compile, ['']) +test('tc159', normal, compile_and_run, ['']) +test('tc160', only_compiler_types(['ghc']), compile, ['']) +test('tc161', normal, compile, ['']) +test('tc162', only_compiler_types(['ghc']), compile, ['']) +test('tc163', only_compiler_types(['ghc']), compile, ['']) +test('tc164', normal, compile, ['']) +test('tc165', normal, compile, ['']) +test('tc166', only_compiler_types(['ghc']), compile, ['']) +test('tc167', only_compiler_types(['ghc']), compile, ['']) +test('tc168', only_compiler_types(['ghc']), compile, ['-ddump-types']) +test('tc169', normal, compile, ['']) + +test('tc170', + extra_clean(['Tc170_Aux.hi', 'Tc170_Aux.o']), + run_command, + ['$MAKE -s --no-print-directory tc170']) + +test('tc171', normal, compile, ['']) +test('tc172', normal, compile, ['']) + +# The point about this test is that it compiles Tc173a and Tc173b *separately* +test('tc173', + extra_clean(['Tc173a.hi', 'Tc173a.o', 'Tc173b.hi', 'Tc173b.o']), + run_command, + ['$MAKE -s --no-print-directory tc173']) + +test('tc174', only_compiler_types(['ghc']), compile, ['']) +test('tc175', normal, compile, ['']) +test('tc176', normal, compile, ['']) +test('tc177', normal, compile, ['']) +test('tc178', normal, compile, ['']) +test('tc179', normal, compile, ['']) +test('tc180', normal, compile, ['']) +test('tc181', normal, compile, ['']) +test('tc182', normal, compile, ['']) +test('tc183', reqlib('mtl'), compile, ['']) +test('tc184', normal, compile, ['']) +test('tc185', only_compiler_types(['ghc']), compile, ['']) +test('tc186', normal, compile, ['']) +test('tc187', normal, compile, ['']) +test('tc188', only_compiler_types(['ghc']), compile, ['']) +test('tc189', normal, compile, ['']) +test('tc190', only_compiler_types(['ghc']), compile, ['']) +test('tc191', [only_compiler_types(['ghc']), reqlib('syb')], compile, ['']) +test('tc192', only_compiler_types(['ghc']), compile, ['']) +test('tc193', only_compiler_types(['ghc']), compile, ['']) +test('tc194', normal, compile, ['']) +test('tc195', only_compiler_types(['ghc']), compile, ['']) +test('tc196', normal, compile, ['']) +test('tc197', normal, compile, ['']) +test('tc198', normal, compile, ['']) +test('tc199', normal, compile, ['']) +test('tc200', normal, compile, ['']) +test('tc201', normal, compile, ['']) +test('tc202', normal, compile, ['']) +test('tc203', normal, compile, ['']) +test('tc204', normal, compile, ['']) +test('tc205', normal, compile, ['']) +test('tc206', normal, compile, ['']) +test('tc207', normal, compile, ['']) +test('tc208', normal, compile, ['']) +test('tc209', normal, compile, ['']) +test('tc210', normal, compile, ['']) +test('tc211', normal, compile_fail, ['']) +test('tc212', normal, compile, ['']) +test('tc213', normal, compile, ['']) +test('tc214', normal, compile, ['']) +test('tc215', normal, compile, ['']) + +# This one is very delicate, but I don't think the result really matters +test('tc216', normal, compile, ['']) + +test('tc217', reqlib('mtl'), compile, ['']) +test('tc218', normal, compile, ['']) +test('tc219', normal, compile, ['']) +test('tc220', [reqlib('mtl'), reqlib('syb')], compile, ['']) +test('tc221', normal, compile, ['']) +test('tc222', normal, compile, ['']) +test('tc223', reqlib('mtl'), compile, ['']) +test('tc224', normal, compile, ['']) +test('tc225', normal, compile, ['']) +test('tc226', normal, compile, ['']) +test('tc227', normal, compile, ['']) +test('tc228', normal, compile, ['']) +test('tc229', normal, compile, ['']) +test('tc230', normal, compile, ['']) +test('tc231', normal, compile, ['']) +test('tc232', reqlib('mtl'), compile, ['']) +test('tc233', normal, compile, ['']) +test('tc234', normal, compile, ['']) +test('tc235', normal, compile, ['']) +test('tc236', normal, compile, ['']) +test('tc237', normal, compile, ['']) +test('tc238', normal, compile, ['']) + +test('tc239', extra_clean(['Tc239_Help.hi', 'Tc239_Help.o']), + multimod_compile, ['tc239', '-v0']) + +test('tc240', normal, compile, ['']) +test('tc241', normal, compile, ['']) +test('tc242', normal, compile, ['']) +test('tc243', normal, compile, ['']) +test('tc244', normal, compile, ['']) +test('tc245', + extra_clean(['Tc245_A.hi', 'Tc245_A.o', 'tc245.hi', 'tc245.o']), + run_command, + ['$MAKE -s --no-print-directory tc245']) +test('tc246', normal, compile, ['']) +test('tc247', normal, compile, ['']) +test('tc248', normal, compile, ['']) + +test('FD1', normal, compile_fail, ['']) +test('FD2', normal, compile_fail, ['']) +test('FD3', normal, compile_fail, ['']) +test('FD4', normal, compile, ['']) + +test('faxen', normal, compile, ['']) +test('T1495', normal, compile, ['']) +test('T2045', normal, compile, ['']) # Needs -fhpc +test('T2478', normal, compile, ['']) +test('T2433', extra_clean(['T2433_Help.hi', 'T2433_Help.o']), + multimod_compile, ['T2433', '-v0']) +test('T2494', normal, compile_fail, ['']) +test('T2494-2', normal, compile, ['']) +test('T2497', normal, compile, ['']) + + +# Omitting temporarily +test('syn-perf', normal, compile, ['-fcontext-stack=30']) +test('syn-perf2', normal, compile, ['']) + +test('LoopOfTheDay1', normal, compile, ['']) +test('LoopOfTheDay2', normal, compile, ['']) +test('LoopOfTheDay3', normal, compile, ['']) + +test('T1470', normal, compile, ['']) +test('T2572', normal, compile, ['']) +test('T2735', normal, compile, ['']) +test('T2799', normal, compile, ['']) +test('T3219', normal, compile, ['']) +test('T3342', normal, compile, ['']) +test('T3346', normal, compile, ['']) +test('T3409', normal, compile, ['']) +test('T3955', normal, compile, ['']) +test('PolyRec', normal, compile, ['']) +test('twins', normal, compile, ['']) + +test('T2412', + extra_clean(['T2412.hi-boot', 'T2412.o-boot', + 'T2412A.hi', 'T2412A.o', + 'T2412.hi', 'T2412.o']), + run_command, + ['$MAKE --no-print-directory -s T2412']) + +test('T2846', normal, compile, ['']) +test('T4284', normal, compile, ['']) +test('T2683', normal, compile, ['']) +test('T3696', normal, compile, ['']) +test('T1123', normal, compile, ['']) +test('T3692', normal, compile, ['']) +test('T700', normal, compile, ['']) +test('T4361', normal, compile, ['']) +test('T4355', reqlib('mtl'), compile, ['']) +test('T1634', normal, compile, ['']) +test('T4401', normal, compile, ['']) +test('T4404', normal, compile, ['-Wall']) +test('HasKey', normal, compile, ['']) +test('T4418', normal, compile, ['']) +test('T4444', normal, compile, ['']) +test('T4498', normal, compile, ['']) +test('T4524', normal, compile, ['']) +test('T4917', normal, compile, ['']) + +test('T4912', extra_clean(['T4912a.hi', 'T4912a.o']), + multimod_compile, ['T4912', '-v0']) + +test('T4952', normal, compile, ['']) +test('T4969', normal, compile, ['']) +test('T5120', normal, compile, ['']) +test('mc18', normal, compile, ['']) +test('tc249', normal, compile, ['']) + +test('GivenOverlapping', normal, compile, ['']) +test('SilentParametersOverlapping', normal, compile, ['']) +test('GivenTypeSynonym', normal, compile, ['']) +test('T5051', normal, compile, ['']) +test('T3018', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_compile/faxen.hs b/testsuite/tests/typecheck/should_compile/faxen.hs new file mode 100644 index 0000000000..c7310529c6 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/faxen.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Rank2Types #-} +
+-- A classic test for type inference
+-- Taken from "Haskell and principal types", Section 3
+-- by Faxen, in the Haskell Workshop 2003, pp88-97
+
+module ShouldCompile where
+
+class HasEmpty a where
+ isEmpty :: a -> Bool
+
+instance HasEmpty [a] where
+ isEmpty x = null x
+
+instance HasEmpty (Maybe a) where
+ isEmpty Nothing = True
+ isEmpty (Just x) = False
+
+test1 y
+ = (null y)
+ || (let f :: forall d. d -> Bool
+ f x = isEmpty (y >> return x)
+ in f y)
+
+test2 y
+ = (let f :: forall d. d -> Bool
+ f x = isEmpty (y >> return x)
+ in f y)
+ || (null y)
+
diff --git a/testsuite/tests/typecheck/should_compile/mc18.hs b/testsuite/tests/typecheck/should_compile/mc18.hs new file mode 100644 index 0000000000..82ee05e6f7 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/mc18.hs @@ -0,0 +1,14 @@ +-- Checks that the types of the old binder and the binder implicitly introduced by grouping are linked + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module ShouldCompile where + +import Data.List(inits) + +foo :: [[[Int]]] +foo = [ x + | x <- [1..10] + , then group using inits + , then group using inits + ] diff --git a/testsuite/tests/typecheck/should_compile/syn-perf.hs b/testsuite/tests/typecheck/should_compile/syn-perf.hs new file mode 100644 index 0000000000..c7e2a4a0eb --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/syn-perf.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE TypeOperators, DeriveDataTypeable #-} + +-- This is a performance test. In GHC 6.4, it simply wouldn't compile +-- because the types got exponentially large, due to poor handling of +-- type synonyms + +module ShouldCompile where + +import Data.Word +import Data.Int +import Data.Typeable + +data HNil = HNil deriving (Eq,Show,Read) +data HCons e l = HCons e l deriving (Eq,Show,Read) + +type e :*: l = HCons e l + -- In GHC 6.4 the deeply-nested use of this + -- synonym gave rise to exponential behaviour + +--- list endian16 +newtype Tables = Tables [TableInfo] deriving (Show, Typeable) + +type TableInfo = + AvgPot :*: + NumPlayers :*: + Waiting :*: + PlayersFlop :*: + TableName :*: + TableID :*: + GameType :*: + InfoMaxPlayers :*: + RealMoneyTable :*: + LowBet :*: + HighBet :*: + MinStartMoney :*: + MaxStartMoney :*: + GamesPerHour :*: + TourType :*: + TourID :*: + BetType :*: + CantReturnLess :*: + AffiliateID :*: + NIsResurrecting :*: + MinutesForTimeout :*: + SeatsToResurrect :*: + LangID :*: + HNil + +newtype TourType = TourType TourType_ deriving (Show, Typeable) +newtype AvgPot = AvgPot Word64 deriving (Show, Typeable) +newtype NumPlayers = NumPlayers Word16 deriving (Show, Typeable) +newtype Waiting = Waiting Word16 deriving (Show, Typeable) +newtype PlayersFlop = PlayersFlop Word8 deriving (Show, Typeable) +newtype TableName = TableName String deriving (Show, Typeable) +newtype TableID = TableID Word32 deriving (Show, Typeable) +newtype OldTableID = OldTableID Word32 deriving (Show, Typeable) +newtype GameType = GameType GameType_ deriving (Show, Typeable) +newtype InfoMaxPlayers = InfoMaxPlayers Word16 deriving (Show, Typeable) +newtype RealMoneyTable = RealMoneyTable Bool deriving (Show, Typeable) +newtype LowBet = LowBet RealMoney_ deriving (Show, Typeable) +newtype HighBet = HighBet RealMoney_ deriving (Show, Typeable) +newtype MinStartMoney = MinStartMoney RealMoney_ deriving (Show, Typeable) +newtype MaxStartMoney = MaxStartMoney RealMoney_ deriving (Show, Typeable) +newtype GamesPerHour = GamesPerHour Word16 deriving (Show, Typeable) +newtype TourID = TourID Word32 deriving (Show, Typeable) +newtype BetType = BetType BetType_ deriving (Show, Typeable) +newtype CantReturnLess = CantReturnLess Word32 deriving (Show, Typeable) +newtype AffiliateID = AffiliateID [Word8] deriving (Show, Typeable) +newtype NIsResurrecting = NIsResurrecting Word32 deriving (Show, Typeable) +newtype MinutesForTimeout = MinutesForTimeout Word32 deriving (Show, Typeable) +newtype SeatsToResurrect = SeatsToResurrect Word32 deriving (Show, Typeable) +newtype LangID = LangID Word32 deriving (Show, Typeable) + +data GameType_ + = EmptyGame + | Holdem + | OmahaHoldem + | OmahaHiLo + | SevenCardStud + | SevenCardStudLoHi + | OneToOne + | OneToOneOmaha + | OneToOne7CS + | OneToOneOmahaHL + | OneToOne7CSHL + | TeenPatti + | OneToOneTeenPatti + deriving (Eq, Show, Typeable) + +type RealMoney_ = Word64 + +data TourType_ + = TourNone + | TourSingle + | TourMulti + | TourHeadsUpMulti + deriving (Enum, Eq, Show, Typeable) + +data BetType_ + = BetNone + | BetFixed + | BetPotLimit + | BetNoLimit + | BetBigRiver + | BetTeenPatti + | BetTeenPattiFixed + deriving (Enum, Eq, Show, Typeable) + diff --git a/testsuite/tests/typecheck/should_compile/syn-perf2.hs b/testsuite/tests/typecheck/should_compile/syn-perf2.hs new file mode 100644 index 0000000000..517fdb8a21 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/syn-perf2.hs @@ -0,0 +1,33 @@ +-- Another type-synonym performance test +-- (Trac 323) +-- Fails in GHC up to 6.6 + +module ShouldCompile where + +type S = Maybe +type S2 n = S (S n) +type S4 n = S2 (S2 n) +type S8 n = S4 (S4 n) +type S16 n = S8 (S8 n) +type S32 n = S16 (S16 n) + +type N64 n = S32 (S32 n) + +type N64' = + S ( S ( S ( S ( S ( S ( S ( S ( + S ( S ( S ( S ( S ( S ( S ( S ( + S ( S ( S ( S ( S ( S ( S ( S ( + S ( S ( S ( S ( S ( S ( S ( S ( + S ( S ( S ( S ( S ( S ( S ( S ( + S ( S ( S ( S ( S ( S ( S ( S ( + S ( S ( S ( S ( S ( S ( S ( S ( + S ( S ( S ( S ( S ( S ( S ( S ( + Int + )))))))) + )))))))) + )))))))) + )))))))) + )))))))) + )))))))) + )))))))) + )))))))) diff --git a/testsuite/tests/typecheck/should_compile/tc001.hs b/testsuite/tests/typecheck/should_compile/tc001.hs new file mode 100644 index 0000000000..c3b0a785e2 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc001.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +a x = y+2 where y = x+3 diff --git a/testsuite/tests/typecheck/should_compile/tc002.hs b/testsuite/tests/typecheck/should_compile/tc002.hs new file mode 100644 index 0000000000..85f1a91e1f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc002.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +b = if True then 1 else 2 diff --git a/testsuite/tests/typecheck/should_compile/tc003.hs b/testsuite/tests/typecheck/should_compile/tc003.hs new file mode 100644 index 0000000000..70459c3443 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc003.hs @@ -0,0 +1,12 @@ +module ShouldSucceed where + +-- This is a somewhat surprising program. +-- It shows up the monomorphism restriction, *and* ambiguity resolution! +-- The binding is a pattern binding without a signature, so it is monomorphic. +-- Hence the types of c,d,e are not universally quantified. But then +-- their type variables are ambiguous, so the ambiguity resolution leaps +-- into action, and resolves them to Integer. + +-- That's why we check the interface file in the test suite. + +(c@(d,e)) = if True then (1,2) else (1,3) diff --git a/testsuite/tests/typecheck/should_compile/tc004.hs b/testsuite/tests/typecheck/should_compile/tc004.hs new file mode 100644 index 0000000000..a0627302d4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc004.hs @@ -0,0 +1,5 @@ +module ShouldSucceed where + +f x = case x of + True -> True + False -> x diff --git a/testsuite/tests/typecheck/should_compile/tc005.hs b/testsuite/tests/typecheck/should_compile/tc005.hs new file mode 100644 index 0000000000..9d39da8912 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc005.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +g ((x:z),y) = x +g (x,y) = 2 diff --git a/testsuite/tests/typecheck/should_compile/tc006.hs b/testsuite/tests/typecheck/should_compile/tc006.hs new file mode 100644 index 0000000000..2a22688d19 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc006.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +h = 1:h diff --git a/testsuite/tests/typecheck/should_compile/tc007.hs b/testsuite/tests/typecheck/should_compile/tc007.hs new file mode 100644 index 0000000000..c65458514b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc007.hs @@ -0,0 +1,9 @@ +module ShouldSucceed where + +j = 2 + +k = 1:j:l + +l = 0:k + +m = j+j diff --git a/testsuite/tests/typecheck/should_compile/tc008.hs b/testsuite/tests/typecheck/should_compile/tc008.hs new file mode 100644 index 0000000000..236b575573 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc008.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +n True = 1 +n False = 0 diff --git a/testsuite/tests/typecheck/should_compile/tc009.hs b/testsuite/tests/typecheck/should_compile/tc009.hs new file mode 100644 index 0000000000..b682a94c0d --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc009.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +o (True,x) = x +o (False,y) = y+1 diff --git a/testsuite/tests/typecheck/should_compile/tc010.hs b/testsuite/tests/typecheck/should_compile/tc010.hs new file mode 100644 index 0000000000..8ec9afd3d0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc010.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +p = [(y+2,True) | y <- [1,2]] diff --git a/testsuite/tests/typecheck/should_compile/tc011.hs b/testsuite/tests/typecheck/should_compile/tc011.hs new file mode 100644 index 0000000000..24c5b3b91b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc011.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +x@_ = x diff --git a/testsuite/tests/typecheck/should_compile/tc012.hs b/testsuite/tests/typecheck/should_compile/tc012.hs new file mode 100644 index 0000000000..6f5e954220 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc012.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +q = \ y -> y diff --git a/testsuite/tests/typecheck/should_compile/tc013.hs b/testsuite/tests/typecheck/should_compile/tc013.hs new file mode 100644 index 0000000000..f6a08b5e7b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc013.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +(r,s) = (1,'a') diff --git a/testsuite/tests/typecheck/should_compile/tc014.hs b/testsuite/tests/typecheck/should_compile/tc014.hs new file mode 100644 index 0000000000..97ce375583 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc014.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +t = 1+t diff --git a/testsuite/tests/typecheck/should_compile/tc015.hs b/testsuite/tests/typecheck/should_compile/tc015.hs new file mode 100644 index 0000000000..41c902bfc6 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc015.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +u x = \ (y,z) -> x diff --git a/testsuite/tests/typecheck/should_compile/tc016.hs b/testsuite/tests/typecheck/should_compile/tc016.hs new file mode 100644 index 0000000000..5f3c7e5721 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc016.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +f x@_ y@_ = x diff --git a/testsuite/tests/typecheck/should_compile/tc017.hs b/testsuite/tests/typecheck/should_compile/tc017.hs new file mode 100644 index 0000000000..ec51aeb8d0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc017.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +v | True = v+1 + | False = v diff --git a/testsuite/tests/typecheck/should_compile/tc018.hs b/testsuite/tests/typecheck/should_compile/tc018.hs new file mode 100644 index 0000000000..7fb398c6e6 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc018.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +w = a where a = y + y = 2 diff --git a/testsuite/tests/typecheck/should_compile/tc019.hs b/testsuite/tests/typecheck/should_compile/tc019.hs new file mode 100644 index 0000000000..3cfe5ea626 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc019.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +(al:am) = [y+1 | (y,z) <- [(1,2)]] diff --git a/testsuite/tests/typecheck/should_compile/tc020.hs b/testsuite/tests/typecheck/should_compile/tc020.hs new file mode 100644 index 0000000000..a0ef679c8f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc020.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +f x = a where a = x:a diff --git a/testsuite/tests/typecheck/should_compile/tc021.hs b/testsuite/tests/typecheck/should_compile/tc021.hs new file mode 100644 index 0000000000..418fa38e29 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc021.hs @@ -0,0 +1,7 @@ +module ShouldSucceed where + +f x = a + +a = (x,x) + +x = x diff --git a/testsuite/tests/typecheck/should_compile/tc022.hs b/testsuite/tests/typecheck/should_compile/tc022.hs new file mode 100644 index 0000000000..1a04d7e7a2 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc022.hs @@ -0,0 +1,5 @@ +module ShouldSucceed where + +main = iD iD + +iD x = x diff --git a/testsuite/tests/typecheck/should_compile/tc023.hs b/testsuite/tests/typecheck/should_compile/tc023.hs new file mode 100644 index 0000000000..b996719bb9 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc023.hs @@ -0,0 +1,7 @@ +module ShouldSucceed where + +main = s k k + +s f g x = f x (g x) + +k x y = x diff --git a/testsuite/tests/typecheck/should_compile/tc024.hs b/testsuite/tests/typecheck/should_compile/tc024.hs new file mode 100644 index 0000000000..e28d1acf96 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc024.hs @@ -0,0 +1,7 @@ +module ShouldSucceed where + +main x = s k k x + +s f g x = f x (g x) + +k x y = x diff --git a/testsuite/tests/typecheck/should_compile/tc025.hs b/testsuite/tests/typecheck/should_compile/tc025.hs new file mode 100644 index 0000000000..e9adf9acb5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc025.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +g x = f (f True x) x where f x y = if x then y else (f x y) diff --git a/testsuite/tests/typecheck/should_compile/tc026.hs b/testsuite/tests/typecheck/should_compile/tc026.hs new file mode 100644 index 0000000000..3e718a5053 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc026.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +g x = f (f True x) x +f x y = if x then y else (f x y) diff --git a/testsuite/tests/typecheck/should_compile/tc027.hs b/testsuite/tests/typecheck/should_compile/tc027.hs new file mode 100644 index 0000000000..6edc01b619 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc027.hs @@ -0,0 +1,5 @@ +module ShouldSucceed where + +h x = f (f True x) x +f x y = if x then y else (g y x) +g y x = if x then y else (f x y) diff --git a/testsuite/tests/typecheck/should_compile/tc028.hs b/testsuite/tests/typecheck/should_compile/tc028.hs new file mode 100644 index 0000000000..49a0835ade --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc028.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +type H = (Int,Bool) diff --git a/testsuite/tests/typecheck/should_compile/tc029.hs b/testsuite/tests/typecheck/should_compile/tc029.hs new file mode 100644 index 0000000000..c44b78f79f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc029.hs @@ -0,0 +1,6 @@ +module ShouldSucceed where + +type G = [Int] + +data K = H Bool | M G + diff --git a/testsuite/tests/typecheck/should_compile/tc030.hs b/testsuite/tests/typecheck/should_compile/tc030.hs new file mode 100644 index 0000000000..004bc226d1 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc030.hs @@ -0,0 +1,5 @@ +module ShouldSucceed where + +type H = [Bool] + +type G = (H,Char) diff --git a/testsuite/tests/typecheck/should_compile/tc031.hs b/testsuite/tests/typecheck/should_compile/tc031.hs new file mode 100644 index 0000000000..c55bf11f54 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc031.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +data Rec = Node Int Rec diff --git a/testsuite/tests/typecheck/should_compile/tc032.hs b/testsuite/tests/typecheck/should_compile/tc032.hs new file mode 100644 index 0000000000..9c43bbb010 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc032.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +data AList b = Node b [b] | Other (b,Char) diff --git a/testsuite/tests/typecheck/should_compile/tc033.hs b/testsuite/tests/typecheck/should_compile/tc033.hs new file mode 100644 index 0000000000..7111d75a4e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc033.hs @@ -0,0 +1,7 @@ +module ShouldSucceed where + +data Twine = Twine2 Twist + +data Twist = Twist2 Twine + +type F = Twine diff --git a/testsuite/tests/typecheck/should_compile/tc034.hs b/testsuite/tests/typecheck/should_compile/tc034.hs new file mode 100644 index 0000000000..0e7c4a66ed --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc034.hs @@ -0,0 +1,11 @@ +module ShouldSucceed where + +data AList a = ANull | ANode a (AList a) + +type IntList = AList Int + +g (ANull) = 2 +g (ANode b (ANode c d)) | b = 3 + | True = 4 + + diff --git a/testsuite/tests/typecheck/should_compile/tc035.hs b/testsuite/tests/typecheck/should_compile/tc035.hs new file mode 100644 index 0000000000..b8dd554373 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc035.hs @@ -0,0 +1,9 @@ +module ShouldSucceed where + +type AnnExpr a = (a,Expr a) + +data Expr a = Var [Char] + | App (AnnExpr a) (AnnExpr a) + +g (a,(Var name)) = [name] +g (a,(App e1 e2)) = (g e1) ++ (g e2) diff --git a/testsuite/tests/typecheck/should_compile/tc036.hs b/testsuite/tests/typecheck/should_compile/tc036.hs new file mode 100644 index 0000000000..05b87846ac --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc036.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +class (Eq a) => A a where + op1 :: a -> a diff --git a/testsuite/tests/typecheck/should_compile/tc037.hs b/testsuite/tests/typecheck/should_compile/tc037.hs new file mode 100644 index 0000000000..8621b278d3 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc037.hs @@ -0,0 +1,9 @@ +module ShouldSucceed where + +class Eq' a where + deq :: a -> a -> Bool + +instance (Eq' a) => Eq' [a] where + deq [] [] = True + deq (x:xs) (y:ys) = if (x `deq` y) then (deq xs ys) else False + deq other1 other2 = False diff --git a/testsuite/tests/typecheck/should_compile/tc038.hs b/testsuite/tests/typecheck/should_compile/tc038.hs new file mode 100644 index 0000000000..d404ee6913 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc038.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +f (x:xs) = if (x == (fromInteger 2)) then xs else [] diff --git a/testsuite/tests/typecheck/should_compile/tc039.hs b/testsuite/tests/typecheck/should_compile/tc039.hs new file mode 100644 index 0000000000..05b87846ac --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc039.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +class (Eq a) => A a where + op1 :: a -> a diff --git a/testsuite/tests/typecheck/should_compile/tc040.hs b/testsuite/tests/typecheck/should_compile/tc040.hs new file mode 100644 index 0000000000..4897a2b9b3 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc040.hs @@ -0,0 +1,9 @@ +module ShouldSucceed where + +-- !!! tests the deduction of contexts. + +f :: (Eq a) => a -> [a] + +f x = g x + where + g y = if (y == x) then [] else [y] diff --git a/testsuite/tests/typecheck/should_compile/tc041.hs b/testsuite/tests/typecheck/should_compile/tc041.hs new file mode 100644 index 0000000000..b42374f5e2 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc041.hs @@ -0,0 +1,12 @@ +-- !!! a very simple test of class and instance declarations + +module ShouldSucceed where + +class H a where + op1 :: a -> a -> a + +instance H Bool where + op1 x y = y + +f :: Bool -> Int -> Bool +f x y = op1 x x diff --git a/testsuite/tests/typecheck/should_compile/tc042.hs b/testsuite/tests/typecheck/should_compile/tc042.hs new file mode 100644 index 0000000000..58a120c13b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc042.hs @@ -0,0 +1,73 @@ +-- !!! a file mailed us by Ryzard Kubiak. This provides a good test of the code +-- !!! handling type signatures and recursive data types. + +module ShouldSucceed where + +data Boolean = FF | TT +data Pair a b = Mkpair a b +data List alpha = Nil | Cons alpha (List alpha) +data Nat = Zero | Succ Nat +data Tree t = Leaf t | Node (Tree t) (Tree t) + +idb :: Boolean -> Boolean +idb x = x + + +swap :: Pair a b -> Pair b a +swap t = case t of + Mkpair x y -> Mkpair y x + +neg :: Boolean -> Boolean +neg b = case b of + FF -> TT + TT -> FF + +nUll :: List alpha -> Boolean +nUll l = case l of + Nil -> TT + Cons y ys -> FF + +idl :: List a -> List a +idl xs = case xs of + Nil -> Nil + Cons y ys -> Cons y (idl ys) + +add :: Nat -> Nat -> Nat +add a b = case a of + Zero -> b + Succ c -> Succ (add c b) + +app :: List alpha -> List alpha -> List alpha +app xs zs = case xs of + Nil -> zs + Cons y ys -> Cons y (app ys zs) + +lEngth :: List a -> Nat +lEngth xs = case xs of + Nil -> Zero + Cons y ys -> Succ(lEngth ys) + +before :: List Nat -> List Nat +before xs = case xs of + Nil -> Nil + Cons y ys -> case y of + Zero -> Nil + Succ n -> Cons y (before ys) + +rEverse :: List alpha -> List alpha +rEverse rs = case rs of + Nil -> Nil + Cons y ys -> app (rEverse ys) (Cons y Nil) + + +flatten :: Tree alpha -> List alpha +flatten t = case t of + Leaf x -> Cons x Nil + Node l r -> app (flatten l) (flatten r) + +sUm :: Tree Nat -> Nat +sUm t = case t of + Leaf t -> t + Node l r -> add (sUm l) (sUm r) + + diff --git a/testsuite/tests/typecheck/should_compile/tc043.hs b/testsuite/tests/typecheck/should_compile/tc043.hs new file mode 100644 index 0000000000..2a2e5f050c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc043.hs @@ -0,0 +1,18 @@ +module ShouldSucceed where + +-- !!! another simple test of class and instance code. + +class A a where + op1 :: a + +instance A Int where + op1 = 2 + +f x = op1 + +class B b where + op2 :: b -> Int + +instance (B a) => B [a] where + op2 [] = 0 + op2 (x:xs) = 1 + op2 xs diff --git a/testsuite/tests/typecheck/should_compile/tc044.hs b/testsuite/tests/typecheck/should_compile/tc044.hs new file mode 100644 index 0000000000..84c91d19fd --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc044.hs @@ -0,0 +1,6 @@ +-- once produced a bug, here as regression test + +module ShouldSucceed where + +f _ | otherwise = () + diff --git a/testsuite/tests/typecheck/should_compile/tc045.hs b/testsuite/tests/typecheck/should_compile/tc045.hs new file mode 100644 index 0000000000..4ff3766673 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc045.hs @@ -0,0 +1,19 @@ +module ShouldSucceed where + +class C a where + op1 :: a -> a + +class (C a) => B a where + op2 :: a -> a -> a + +instance (B a) => B [a] where + op2 xs ys = xs + +instance C [a] where + op1 xs = xs + +{- This was passed by the prototype, but failed hard in the new +typechecker with the message + +Fail:No match in theta_class +-} diff --git a/testsuite/tests/typecheck/should_compile/tc046.hs b/testsuite/tests/typecheck/should_compile/tc046.hs new file mode 100644 index 0000000000..c1ae30c96c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc046.hs @@ -0,0 +1,9 @@ +module ShouldSucceed where + +class C a where + op1 :: a -> a + +class (C a) => B a where + op2 :: a -> a -> a + +{- Failed hard in new tc with "No match in theta_class" -} diff --git a/testsuite/tests/typecheck/should_compile/tc047.hs b/testsuite/tests/typecheck/should_compile/tc047.hs new file mode 100644 index 0000000000..b8c197d185 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc047.hs @@ -0,0 +1,23 @@ +module ShouldSucceed where + +type OL a = [a] + +-- produces the interface: +-- data OL a = MkOL [a] deriving () +-- ranOAL :: (OL (a, a)) -> [a] +-- this interface was produced by BOTH hbc and nhc + +-- the following bogus type sig. was accepted by BOTH hbc and nhc +f x = ranOAL where -- ranOAL :: OL (a,v) -> [a] +--ranOAL :: OL (a,v) -> [v], the right sig. + ranOAL ( xs) = mp sd xs + + +mp f [] = [] +mp f (x:xs) = (f x) : mp f xs + +sd (f,s) = s + + + + diff --git a/testsuite/tests/typecheck/should_compile/tc048.hs b/testsuite/tests/typecheck/should_compile/tc048.hs new file mode 100644 index 0000000000..eea6f10e79 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc048.hs @@ -0,0 +1,21 @@ +module ShouldSucceed where + +data OL a = MkOL [a] +data FG a b = MkFG (OL (a,b)) +data AFE n a b = MkAFE (OL (n,(FG a b))) + +--ranOAL :: OL (a,v) -> [a] +ranOAL :: OL (a,v) -> [v] +ranOAL (MkOL xs) = mAp sNd xs + +mAp f [] = [] +mAp f (x:xs) = (f x) : mAp f xs + +sNd (f,s) = s + +ranAFE :: AFE n a b -> [FG a b] -- ? +ranAFE (MkAFE nfs) = ranOAL nfs + + + + diff --git a/testsuite/tests/typecheck/should_compile/tc049.hs b/testsuite/tests/typecheck/should_compile/tc049.hs new file mode 100644 index 0000000000..20be6b768b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc049.hs @@ -0,0 +1,39 @@ +module ShouldSucceed where + +fib n = if n <= 2 then n else fib (n-1) + fib (n-2) + +---------------------------------------- + +mem x [] = False +mem x (y:ys) = (x == y) `oR` mem x ys + +a `oR` b = if a then True else b + +---------------------------------------- + +mem1 x [] = False +mem1 x (y:ys) = (x == y) `oR1` mem2 x ys + +a `oR1` b = if a then True else b + +mem2 x [] = False +mem2 x (y:ys) = (x == y) `oR` mem1 x ys + +--------------------------------------- + +mem3 x [] = False +mem3 x (y:ys) = if [x] == [y] then mem4 x ys else False + +mem4 y (x:xs) = mem3 y xs + +--------------------------------------- + +main1 = [[(1,True)]] == [[(2,False)]] + +--------------------------------------- + +main2 = "Hello" == "Goodbye" + +--------------------------------------- + +main3 = [[1],[2]] == [[3]] diff --git a/testsuite/tests/typecheck/should_compile/tc050.hs b/testsuite/tests/typecheck/should_compile/tc050.hs new file mode 100644 index 0000000000..ef03b282d9 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc050.hs @@ -0,0 +1,23 @@ +module ShouldSucceed where + +class Foo a where + o_and :: a -> a -> a + + +instance Foo Bool where + o_and False x = False + o_and x False = False + o_and True True = True + + +instance Foo Int where + o_and x 0 = 0 + o_and 0 x = 0 + o_and 1 1 = 1 + + +f x y = o_and x False + +g x y = o_and x 1 + + diff --git a/testsuite/tests/typecheck/should_compile/tc051.hs b/testsuite/tests/typecheck/should_compile/tc051.hs new file mode 100644 index 0000000000..7f14282fb8 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc051.hs @@ -0,0 +1,30 @@ +module ShouldSucceed where + +class Eq' a where + doubleeq :: a -> a -> Bool + +class (Eq' a) => Ord' a where + lt :: a -> a -> Bool + +instance Eq' Int where + doubleeq x y = True + +instance (Eq' a) => Eq' [a] where + doubleeq x y = True + +instance Ord' Int where + lt x y = True + +{- +class (Ord a) => Ix a where + range :: (a,a) -> [a] + +instance Ix Int where + range (x,y) = [x,y] +-} + + + + + + diff --git a/testsuite/tests/typecheck/should_compile/tc052.hs b/testsuite/tests/typecheck/should_compile/tc052.hs new file mode 100644 index 0000000000..108ef12046 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc052.hs @@ -0,0 +1,8 @@ +module ShouldSucceed where + +type A a = B a + +type B c = C + +type C = Int + diff --git a/testsuite/tests/typecheck/should_compile/tc053.hs b/testsuite/tests/typecheck/should_compile/tc053.hs new file mode 100644 index 0000000000..865211d917 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc053.hs @@ -0,0 +1,12 @@ +module ShouldSucceed where + +class Eq' a where + deq :: a -> a -> Bool + +instance Eq' Int where + deq x y = True + +instance (Eq' a) => Eq' [a] where + deq (a:as) (b:bs) = if (deq a b) then (deq as bs) else False + +f x = deq x [1] diff --git a/testsuite/tests/typecheck/should_compile/tc054.hs b/testsuite/tests/typecheck/should_compile/tc054.hs new file mode 100644 index 0000000000..df9deb08aa --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc054.hs @@ -0,0 +1,16 @@ +module ShouldSucceed where + +class Eq' a where + doubleeq :: a -> a -> Bool + +class (Eq' a) => Ord' a where + lt :: a -> a -> Bool + +instance Eq' Int where + doubleeq x y = True + +instance Ord' Int where + lt x y = True + +f x y | lt x 1 = True + | otherwise = False diff --git a/testsuite/tests/typecheck/should_compile/tc055.hs b/testsuite/tests/typecheck/should_compile/tc055.hs new file mode 100644 index 0000000000..cdbb8f4b4d --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc055.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +(x,y) = (\p -> p,\q -> q) diff --git a/testsuite/tests/typecheck/should_compile/tc056.hs b/testsuite/tests/typecheck/should_compile/tc056.hs new file mode 100644 index 0000000000..64d7138571 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc056.hs @@ -0,0 +1,19 @@ +-- !!! Duplicate class assertion warning + +-- ghc 6.6 now warns about duplicate class assertions, + +module ShouldSucceed where + +class Eq' a where + doubleeq :: a -> a -> Bool + +class (Eq' a) => Ord' a where + lt :: a -> a -> Bool + +instance Eq' Int where + doubleeq x y = True + +instance (Eq' a, Eq' a) => Eq' [a] where + doubleeq x y = True + +f x y = doubleeq x [1] diff --git a/testsuite/tests/typecheck/should_compile/tc056.stderr b/testsuite/tests/typecheck/should_compile/tc056.stderr new file mode 100644 index 0000000000..c49396721c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc056.stderr @@ -0,0 +1,6 @@ + +tc056.hs:16:10: + Warning: Duplicate constraint(s): Eq' a + In the context: (Eq' a, Eq' a) + While checking the context of an instance declaration + In the instance declaration for `Eq' [a]' diff --git a/testsuite/tests/typecheck/should_compile/tc057.hs b/testsuite/tests/typecheck/should_compile/tc057.hs new file mode 100644 index 0000000000..cc561b95b8 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc057.hs @@ -0,0 +1,18 @@ +module ShouldSucceed where + +-- See also tcfail060.hs + +class Eq' a where + deq :: a -> a -> Bool + +instance Eq' Int where + deq x y = True + +instance (Eq' a) => Eq' [a] where + deq (a:as) (b:bs) = dand (f a b) (f as bs) + +dand True True = True +dand x y = False + +f :: Eq' a => a -> a -> Bool +f p q = dand (deq p q) (deq [1::Int] [2::Int]) diff --git a/testsuite/tests/typecheck/should_compile/tc058.hs b/testsuite/tests/typecheck/should_compile/tc058.hs new file mode 100644 index 0000000000..7df1f3bc6d --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc058.hs @@ -0,0 +1,18 @@ +module ShouldSucceed where + +class Eq2 a where + doubleeq :: a -> a -> Bool + +class (Eq2 a) => Ord2 a where + lt :: a -> a -> Bool + +instance Eq2 Int where + doubleeq x y = True + +instance Ord2 Int where + lt x y = True + +instance (Eq2 a,Ord2 a) => Eq2 [a] where + doubleeq xs ys = True + +f x y = doubleeq x [1] diff --git a/testsuite/tests/typecheck/should_compile/tc059.hs b/testsuite/tests/typecheck/should_compile/tc059.hs new file mode 100644 index 0000000000..f0faac8155 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc059.hs @@ -0,0 +1,15 @@ +module ShouldSucceed where + +class Eq2 a where + deq :: a -> a -> Bool + foo :: a -> a + +instance Eq2 Int where + deq x y = True + foo x = x + +instance (Eq2 a) => Eq2 [a] where + deq (a:as) (b:bs) = if (deq a (foo b)) then (deq as (foo bs)) else False + foo x = x + +f x = deq x [1] diff --git a/testsuite/tests/typecheck/should_compile/tc060.hs b/testsuite/tests/typecheck/should_compile/tc060.hs new file mode 100644 index 0000000000..6ae0ca9228 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc060.hs @@ -0,0 +1,12 @@ +module ShouldSucceed where + +class Eq2 a where + deq :: a -> a -> Bool + +instance (Eq2 a) => Eq2 [a] where + deq (a:as) (b:bs) = if (deq a b) then (deq as bs) else False + + +instance Eq2 Int where + deq x y = True + diff --git a/testsuite/tests/typecheck/should_compile/tc061.hs b/testsuite/tests/typecheck/should_compile/tc061.hs new file mode 100644 index 0000000000..25a8b65f35 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc061.hs @@ -0,0 +1,11 @@ +module ShouldSucceed where + +class Eq1 a where + deq :: a -> a -> Bool + +instance (Eq1 a) => Eq1 [a] where + deq (a:as) (b:bs) = deq a b + +instance Eq1 Int where + deq x y = True + diff --git a/testsuite/tests/typecheck/should_compile/tc062.hs b/testsuite/tests/typecheck/should_compile/tc062.hs new file mode 100644 index 0000000000..fde6c4b1da --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc062.hs @@ -0,0 +1,12 @@ +module ShouldSucceed where + +class Eq1 a where + deq :: a -> a -> Bool + +instance Eq1 Int where + deq x y = True + +instance (Eq1 a) => Eq1 [a] where + deq (a:as) (b:bs) = if (deq a b) then (deq as bs) else False + +f x (y:ys) = deq x ys diff --git a/testsuite/tests/typecheck/should_compile/tc063.hs b/testsuite/tests/typecheck/should_compile/tc063.hs new file mode 100644 index 0000000000..36affbfdce --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc063.hs @@ -0,0 +1,18 @@ +module ShouldSucceed where + +data X a = Tag a + +class Reps r where + f :: r -> r -> r + +instance Reps (X q) where +-- f (Tag x) (Tag y) = Tag y + f x y = y + +instance Reps Bool where + f True True = True + f x y = False + +g x = f x x + + diff --git a/testsuite/tests/typecheck/should_compile/tc064.hs b/testsuite/tests/typecheck/should_compile/tc064.hs new file mode 100644 index 0000000000..18aecb091d --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc064.hs @@ -0,0 +1,7 @@ +module ShouldSucceed where + +data Boolean = FF | TT + +idb :: Boolean -> Boolean +idb x = x + diff --git a/testsuite/tests/typecheck/should_compile/tc065.hs b/testsuite/tests/typecheck/should_compile/tc065.hs new file mode 100644 index 0000000000..1d47cf35c4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc065.hs @@ -0,0 +1,108 @@ +module ShouldSucceed where + +-- import TheUtils +import qualified Data.Set as Set +import Data.Set (Set) +import Data.List (partition ) + +data Digraph vertex = MkDigraph [vertex] + +type Edge vertex = (vertex, vertex) +type Cycle vertex = [vertex] + +mkDigraph = MkDigraph + +stronglyConnComp :: Eq vertex => [Edge vertex] -> [vertex] -> [[vertex]] +stronglyConnComp es vs + = snd (span_tree (new_range reversed_edges) + ([],[]) + ( snd (dfs (new_range es) ([],[]) vs) ) + ) + where + reversed_edges = map swap es + + swap :: Edge v -> Edge v + swap (x,y) = (y, x) + + new_range [] w = [] + new_range ((x,y):xys) w + = if x==w + then (y : (new_range xys w)) + else (new_range xys w) + + span_tree r (vs,ns) [] = (vs,ns) + span_tree r (vs,ns) (x:xs) + | x `elem` vs = span_tree r (vs,ns) xs + | otherwise = span_tree r (vs',(x:ns'):ns) xs + where + (vs',ns') = dfs r (x:vs,[]) (r x) + +dfs r (vs,ns) [] = (vs,ns) +dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs + | otherwise = dfs r (vs',(x:ns')++ns) xs + where + (vs',ns') = dfs r (x:vs,[]) (r x) + + +isCyclic :: Eq vertex => [Edge vertex] -> [vertex] -> Bool +isCyclic edges [v] = (v,v) `elem` edges +isCyclic edges vs = True + + +topSort :: (Eq vertex) => [Edge vertex] -> [vertex] + -> MaybeErr [vertex] [[vertex]] + + +topSort edges vertices + = case cycles of + [] -> Succeeded [v | [v] <- singletons] + _ -> Failed cycles + where + sccs = stronglyConnComp edges vertices + (cycles, singletons) = partition (isCyclic edges) sccs + + +type FlattenedDependencyInfo vertex name code + = [(vertex, Set name, Set name, code)] + +mkVertices :: FlattenedDependencyInfo vertex name code -> [vertex] +mkVertices info = [ vertex | (vertex,_,_,_) <- info] + +mkEdges :: (Eq vertex, Ord name) => + [vertex] + -> FlattenedDependencyInfo vertex name code + -> [Edge vertex] + +mkEdges vertices flat_info + = [ (source_vertex, target_vertex) + | (source_vertex, _, used_names, _) <- flat_info, + target_name <- Set.toList used_names, + target_vertex <- vertices_defining target_name flat_info + ] + where + vertices_defining name flat_info + = [ vertex | (vertex, names_defined, _, _) <- flat_info, + name `Set.member` names_defined + ] + +lookupVertex :: (Eq vertex, Ord name) => + FlattenedDependencyInfo vertex name code + -> vertex + -> code + +lookupVertex flat_info vertex + = head code_list + where + code_list = [ code | (vertex',_,_,code) <- flat_info, vertex == vertex'] + + +isRecursiveCycle :: (Eq vertex) => Cycle vertex -> [Edge vertex] -> Bool +isRecursiveCycle [vertex] edges = (vertex, vertex) `elem` edges +isRecursiveCycle cycle edges = True + + + +-- may go to TheUtils + +data MaybeErr a b = Succeeded a | Failed b + diff --git a/testsuite/tests/typecheck/should_compile/tc066.hs b/testsuite/tests/typecheck/should_compile/tc066.hs new file mode 100644 index 0000000000..7c929516bc --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc066.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +data Pair a b = MkPair a b +f x = [ a | (MkPair c a) <- x ] diff --git a/testsuite/tests/typecheck/should_compile/tc067.hs b/testsuite/tests/typecheck/should_compile/tc067.hs new file mode 100644 index 0000000000..853caf308f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc067.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +f [] = [] +f (x:xs) = x : (f xs) diff --git a/testsuite/tests/typecheck/should_compile/tc068.hs b/testsuite/tests/typecheck/should_compile/tc068.hs new file mode 100644 index 0000000000..f455d41b6e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc068.hs @@ -0,0 +1,18 @@ +module ShouldSucceed where + +data T a = D (B a) | C +data B b = X | Y b + +instance (Eq a) => Eq (T a) where + (D x) == (D y) = x == y + C == C = True + a == b = False + + a /= b = not (a == b) + +instance (Eq b) => Eq (B b) where + X == X = True + (Y a) == (Y b) = a == b + a == b = False + + a /= b = not (a == b) diff --git a/testsuite/tests/typecheck/should_compile/tc069.hs b/testsuite/tests/typecheck/should_compile/tc069.hs new file mode 100644 index 0000000000..539b3046da --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc069.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +x = 'a' +(y:ys) = ['a','b','c'] where p = x diff --git a/testsuite/tests/typecheck/should_compile/tc070.hs b/testsuite/tests/typecheck/should_compile/tc070.hs new file mode 100644 index 0000000000..831195f9f6 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc070.hs @@ -0,0 +1,9 @@ +module ShouldSucceed where + + +data Boolean = FF | TT + + +idb :: Boolean -> Boolean +idb x = x + diff --git a/testsuite/tests/typecheck/should_compile/tc073.hs b/testsuite/tests/typecheck/should_compile/tc073.hs new file mode 100644 index 0000000000..44e4129f6a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc073.hs @@ -0,0 +1,5 @@ + +module ShouldSucceed where + +f [] = [] +f (x:xs) = x : (f xs) diff --git a/testsuite/tests/typecheck/should_compile/tc074.hs b/testsuite/tests/typecheck/should_compile/tc074.hs new file mode 100644 index 0000000000..f455d41b6e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc074.hs @@ -0,0 +1,18 @@ +module ShouldSucceed where + +data T a = D (B a) | C +data B b = X | Y b + +instance (Eq a) => Eq (T a) where + (D x) == (D y) = x == y + C == C = True + a == b = False + + a /= b = not (a == b) + +instance (Eq b) => Eq (B b) where + X == X = True + (Y a) == (Y b) = a == b + a == b = False + + a /= b = not (a == b) diff --git a/testsuite/tests/typecheck/should_compile/tc076.hs b/testsuite/tests/typecheck/should_compile/tc076.hs new file mode 100644 index 0000000000..493e967efa --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc076.hs @@ -0,0 +1,8 @@ +-- !!! scoping in list comprehensions right way 'round? +-- a bug reported by Jon Hill +-- +module ShouldSucceed where + +x = [[True]] +xs :: [Bool] +xs = [x | x <- x, x <- x] diff --git a/testsuite/tests/typecheck/should_compile/tc077.hs b/testsuite/tests/typecheck/should_compile/tc077.hs new file mode 100644 index 0000000000..c4f6c4e986 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc077.hs @@ -0,0 +1,9 @@ +-- !!! make sure context of EQ is minimised in interface file. +-- +module ShouldSucceed where + +data NUM = ONE | TWO +class (Num a) => ORD a + +class (ORD a, Show a) => EQ a where + (===) :: a -> a -> Bool diff --git a/testsuite/tests/typecheck/should_compile/tc078.hs b/testsuite/tests/typecheck/should_compile/tc078.hs new file mode 100644 index 0000000000..de5e748d20 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc078.hs @@ -0,0 +1,8 @@ +-- !!! instance decls with no binds +-- +module ShouldFail where + +data Bar a = MkBar Int a + +instance Eq a => Eq (Bar a) +instance Ord a => Ord (Bar a) diff --git a/testsuite/tests/typecheck/should_compile/tc079.hs b/testsuite/tests/typecheck/should_compile/tc079.hs new file mode 100644 index 0000000000..db07ad1325 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc079.hs @@ -0,0 +1,16 @@ +-- !!! small class decl with local polymorphism; +-- !!! "easy" to check default methods and such... +-- !!! (this is the example given in TcClassDcl) +-- +module ShouldSucceed where + +class Foo a where + op1 :: a -> Bool + op2 :: Ord b => a -> b -> b -> b + + op1 x = True + op2 x y z = if (op1 x) && (y < z) then y else z + +instance Foo Int where {} + +instance Foo a => Foo [a] where {} diff --git a/testsuite/tests/typecheck/should_compile/tc080.hs b/testsuite/tests/typecheck/should_compile/tc080.hs new file mode 100644 index 0000000000..636c5b0313 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc080.hs @@ -0,0 +1,58 @@ +--module Parse(Parse(..),whiteSpace,seperatedBy) where +--import StdLib +module ShouldSucceed where + +import Data.Char + +class Parse a where + parseFile :: String -> [a] + parseLine :: String -> a + parseType :: String -> (a,String) + parse :: String -> (a,String) + forced :: a -> Bool + + parseFile string | all forced x = x + where x = map parseLine (lines' string) + parseLine = pl.parse where pl (a,_) = a + parse = parseType.whiteSpace + forced x = True + +instance Parse Int where + parseType str = pl (span' isDigit str) + where pl (l,r) = (strToInt l,r) + forced n | n>=0 = True + +instance Parse Char where + parseType (ch:str) = (ch,str) + forced n = True + +instance (Parse a) => Parse [a] where + parseType more = (map parseLine (seperatedBy ',' (l++",")),out) + where (l,']':out) = span' (\x->x/=']') (tail more) + forced = all forced + +seperatedBy :: Char -> String -> [String] +seperatedBy ch [] = [] +seperatedBy ch xs = twaddle ch (span' (\x->x/=ch) xs) + where twaddle ch (l,_:r) = l:seperatedBy ch r + +whiteSpace :: String -> String +whiteSpace = dropWhile isSpace + +span' :: (a->Bool) -> [a] -> ([a],[a]) +span' p [] = ([],[]) +span' p (x:xs') | p x = fixLeak x (span' p xs') where fixLeak x (xs,ys) = (x:xs,ys) +span' _ xs = ([],xs) + +lines' :: [Char] -> [[Char]] +lines' "" = [] +lines' s = plumb (span' ((/=) '\n') s) + where plumb (l,s') = l:if null s' then [] else lines' (tail s') + +strToInt :: String -> Int +strToInt x = strToInt' (length x-1) x + where strToInt' _ [] = 0 + strToInt' x (a:l) = (charToInt a)*(10^x) + (strToInt' (x-1) l) + +charToInt :: Char -> Int +charToInt x = (ord x - ord '0') diff --git a/testsuite/tests/typecheck/should_compile/tc081.hs b/testsuite/tests/typecheck/should_compile/tc081.hs new file mode 100644 index 0000000000..03be25659e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc081.hs @@ -0,0 +1,29 @@ +-- !!! an example Simon made up +-- +module ShouldSucceed where + +f x = (x+1, x<3, g True, g 'c') + where + g y = if x>2 then [] else [y] +{- +Here the type-check of g will yield an LIE with an Ord dict +for x. g still has type forall a. a -> [a]. The dictionary is +free, bound by the x. + +It should be ok to add the signature: +-} + +f2 x = (x+1, x<3, g2 True, g2 'c') + where + -- NB: this sig: + g2 :: a -> [a] + g2 y = if x>2 then [] else [y] +{- +or to write: +-} + +f3 x = (x+1, x<3, g3 True, g3 'c') + where + -- NB: this line: + g3 :: a -> [a] + g3 = (\ y -> if x>2 then [] else [y])::(a -> [a]) diff --git a/testsuite/tests/typecheck/should_compile/tc082.hs b/testsuite/tests/typecheck/should_compile/tc082.hs new file mode 100644 index 0000000000..8ef70afd01 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc082.hs @@ -0,0 +1,12 @@ +-- !!! tc082: an instance for functions +-- +module ShouldSucceed where + +class Normal a + where + normal :: a -> Bool + +instance Normal ( a -> b ) where + normal _ = True + +f x = normal id diff --git a/testsuite/tests/typecheck/should_compile/tc084.hs b/testsuite/tests/typecheck/should_compile/tc084.hs new file mode 100644 index 0000000000..597a296f90 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc084.hs @@ -0,0 +1,23 @@ +{- This program shows up a bug in the handling of + the monomorphism restriction in an earlier version of + ghc. With ghc 0.18 and before, f gets a type with + an unbound type variable, which shows up in the + interface file. Reason: it was being monomorphised. + + Simon PJ +-} + +module ShouldSucceed where + + +g :: Num a => Bool -> a -> b -> a +g b x y = if b then x+x else x-x + +-- Everything is ok if this signature is put in +-- but the program should be perfectly legal without it. +-- f :: Num a => a -> b -> a +f = g True + +h y x = f (x::Int) y + -- This use of f binds the overloaded monomorphic + -- type to Int diff --git a/testsuite/tests/typecheck/should_compile/tc085.hs b/testsuite/tests/typecheck/should_compile/tc085.hs new file mode 100644 index 0000000000..6074250a45 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc085.hs @@ -0,0 +1,9 @@ + +-- !!! From a bug report from Satnam. +-- !!! To do with re-exporting importees from PreludeGla* modules. +module ShouldSucceed ( module GHC.Prim ) where + +import GHC.Prim + +type FooType = Int +data FooData = FooData diff --git a/testsuite/tests/typecheck/should_compile/tc086.hs b/testsuite/tests/typecheck/should_compile/tc086.hs new file mode 100644 index 0000000000..2db3b7094c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc086.hs @@ -0,0 +1,60 @@ +{- + From: Marc van Dongen <dongen@cs.ucc.ie> + Date: Sat, 31 May 1997 19:57:46 +0100 (BST) + + panic! (the `impossible' happened): + tcLookupTyVar:a_r6F + + Please report it as a compiler bug to glasgow-haskell-bugs@dcs.gla.ac.uk. + + +If the instance definition for (*) at the end of this toy module +is replaced by the definition that is commented, this all compiles +fine. Strange, because the two implementations are equivalent modulo +the theory {(*) = multiply}. + +Remove the `multiply :: a -> a -> a' part, and it compiles without +problems. + + +SPJ note: the type signature on "multiply" should be + multiply :: Group a => a -> a -> a + +-} + +module ShouldSucceed( Group, Ring ) where + +import qualified Prelude( Ord(..), Eq(..), Num(..) ) +import Prelude hiding( Ord(..), Eq(..), Num(..) ) + +class Group a where + compare :: a -> a -> Prelude.Ordering + fromInteger :: Integer -> a + (+) :: a -> a -> a + (-) :: a -> a -> a + zero :: a + one :: a + zero = fromInteger 0 + one = fromInteger 1 + +-- class (Group a) => Ring a where +-- (*) :: a -> a -> a +-- (*) a b = +-- case (compare a zero) of +-- EQ -> zero +-- LT -> zero - ((*) (zero - a) b) +-- GT -> case compare a one of +-- EQ -> b +-- _ -> b + ((*) (a - one) b) + +class (Group a) => Ring a where + (*) :: a -> a -> a + (*) a b = multiply a b + where multiply :: Group b => b -> b -> b + multiply a b + = case (compare a zero) of + EQ -> zero + LT -> zero - (multiply (zero - a) b) + GT -> case compare a one of + EQ -> b + _ -> b + (multiply (a - one) b) diff --git a/testsuite/tests/typecheck/should_compile/tc087.hs b/testsuite/tests/typecheck/should_compile/tc087.hs new file mode 100644 index 0000000000..88317bad35 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc087.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE Rank2Types #-} + +module ShouldSucceed where + +data SeqView t a = Null + | Cons a (t a) + +class PriorityQueue q where + empty :: (Ord a) => q a + single :: (Ord a) => a -> q a + insert :: (Ord a) => a -> q a -> q a + meld :: (Ord a) => q a -> q a -> q a + splitMin :: (Ord a) => q a -> SeqView q a + insert a q = single a `meld` q + +toOrderedList q = case splitMin q of + Null -> [] + Cons a q -> a : toOrderedList q + +insertMany x q = foldr insert q x +pqSort q x = toOrderedList (insertMany x q) + +check :: forall q. (PriorityQueue q) => (forall a. Ord a => q a) -> IO () +check empty = do + putStr "*** sorting\n" + out (pqSort empty [1 .. 99]) + out (pqSort empty [1.0, 1.1 ..99.9]) + +out :: (Num a) => [a] -> IO () +out x | sum x == 0 = putStr "ok\n" + | otherwise = putStr "ok\n" + diff --git a/testsuite/tests/typecheck/should_compile/tc088.hs b/testsuite/tests/typecheck/should_compile/tc088.hs new file mode 100644 index 0000000000..05faeae482 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc088.hs @@ -0,0 +1,19 @@ +-- Check that "->" is an instance of Eval + +module ShouldSucceed where + +instance Show (a->b) + +instance (Eq b) => Eq (a -> b) where + (==) f g = error "attempt to compare functions" + + -- Since Eval is a superclass of Num this fails + -- unless -> is an instance of Eval +instance (Num b) => Num (a -> b) where + f + g = \a -> f a + g a + f - g = \a -> f a - g a + f * g = \a -> f a * g a + negate f = \a -> negate (f a) + abs f = \a -> abs (f a) + signum f = \a -> signum (f a) + fromInteger n = \a -> fromInteger n diff --git a/testsuite/tests/typecheck/should_compile/tc089.hs b/testsuite/tests/typecheck/should_compile/tc089.hs new file mode 100644 index 0000000000..b2516df0ad --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc089.hs @@ -0,0 +1,77 @@ +-- !!! Stress test for type checker + +module ShouldSucceed where + +import Prelude hiding (head) + +one :: a +one = one + +head (x:xs) = x + +bottom xs = head xs + +absIf a b c = a + +absAnd a b = head [a,b] + +fac_rec fac0 n a + = (absIf (absAnd (s_3_0 n) one) + (s_2_0 a) + (fac0 (absAnd (s_3_2 n) one) (absAnd (s_3_1 n) (s_2_1 a)))) + +f_rec f0 a + = (f0 (s_1_0 a)) + +g_rec g0 g1 x y z p + = (absIf (absAnd (s_3_0 p) one) + (absAnd (s_1_0 x) (s_3_0 z)) + (absAnd + (g0 (s_1_0 y) one one (absAnd (s_3_1 p) one)) + (g1 (s_3_2 z) (s_3_1 z) one (absAnd (s_3_2 p) one)))) + +s_2_0 (v0,v1) = v0 +s_2_1 (v0,v1) = v1 +s_1_0 v0 = v0 +s_3_0 (v0,v1,v2) = v0 +s_3_1 (v0,v1,v2) = v1 +s_3_2 (v0,v1,v2) = v2 + +fac n a = fac_rec fac_rec4 n a + +fac_rec4 n a = (fac_rec fac_rec3 n a) +fac_rec3 n a = (fac_rec fac_rec2 n a) +fac_rec2 n a = (fac_rec fac_rec1 n a) +fac_rec1 n a = (fac_rec fac_rec0 n a) +fac_rec0 n a = (bottom [n,a]) + +f a = (f_rec f_rec2 a) + +f_rec2 a = (f_rec f_rec1 a) +f_rec1 a = (f_rec f_rec0 a) +f_rec0 a = (bottom [a]) + +g x y z p = (g_rec g_rec8 g_rec8 x y z p) + +{- +g x y z p = (g_rec g_rec16 g_rec16 x y z p) + +g_rec16 x y z p = (g_rec g_rec15 g_rec15 x y z p) +g_rec15 x y z p = (g_rec g_rec14 g_rec14 x y z p) +g_rec14 x y z p = (g_rec g_rec13 g_rec13 x y z p) +g_rec13 x y z p = (g_rec g_rec12 g_rec12 x y z p) +g_rec12 x y z p = (g_rec g_rec11 g_rec11 x y z p) +g_rec11 x y z p = (g_rec g_rec10 g_rec10 x y z p) +g_rec10 x y z p = (g_rec g_rec9 g_rec9 x y z p) +g_rec9 x y z p = (g_rec g_rec8 g_rec8 x y z p) +-} + +g_rec8 x y z p = (g_rec g_rec7 g_rec7 x y z p) +g_rec7 x y z p = (g_rec g_rec6 g_rec6 x y z p) +g_rec6 x y z p = (g_rec g_rec5 g_rec5 x y z p) +g_rec5 x y z p = (g_rec g_rec4 g_rec4 x y z p) +g_rec4 x y z p = (g_rec g_rec3 g_rec3 x y z p) +g_rec3 x y z p = (g_rec g_rec2 g_rec2 x y z p) +g_rec2 x y z p = (g_rec g_rec1 g_rec1 x y z p) +g_rec1 x y z p = (g_rec g_rec0 g_rec0 x y z p) +g_rec0 x y z p = (bottom [x,y,z,p]) diff --git a/testsuite/tests/typecheck/should_compile/tc090.hs b/testsuite/tests/typecheck/should_compile/tc090.hs new file mode 100644 index 0000000000..f568c390a5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc090.hs @@ -0,0 +1,22 @@ +{- This module tests that we can ge polymorphic recursion + of overloaded functions. GHC 2.02 produced the following + bogus error: + + tmp.lhs:1: A group of type signatures have mismatched contexts + Abf.a :: (PrelBase.Ord f{-aX6-}) => ... + Abf.b :: (PrelBase.Ord f{-aX2-}) => ... + + This was due to having more than one type signature for one + group of recursive functions. +-} + + +module ShouldSucceed where + +a :: (Ord f) => f +a = b + +b :: (Ord f) => f +b = a + + diff --git a/testsuite/tests/typecheck/should_compile/tc091.hs b/testsuite/tests/typecheck/should_compile/tc091.hs new file mode 100644 index 0000000000..628b571c61 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc091.hs @@ -0,0 +1,67 @@ +-- !!! Test polymorphic recursion + + +-- With polymorphic recursion this one becomes legal +-- SLPJ June 97. + +{- +To: Lennart Augustsson <augustss@cs.chalmers.se> +Cc: partain@dcs.gla.ac.uk, John Peterson (Yale) <peterson-john@cs.yale.edu>, + simonpj@dcs.gla.ac.uk +Subject: Type checking matter +Date: Fri, 23 Oct 92 15:28:38 +0100 +From: Simon L Peyton Jones <simonpj@dcs.gla.ac.uk> + + +I've looked at the enclosed again. It seems to me that +since "s" includes a recursive call to "sort", inside the body +of "sort", then "sort" is monomorphic, and hence so is "s"; +hence the type signature (which claims full polymorphism) is +wrong. + +[Lennart says he can't see any free variables inside "s", but there +is one, namely "sort"!] + +Will: one for the should-fail suite? + +Simon + + +------- Forwarded Message + + +From: Lennart Augustsson <augustss@cs.chalmers.se> +To: partain +Subject: Re: just to show you I'm a nice guy... +Date: Tue, 26 May 92 17:30:12 +0200 + +> Here's a fairly simple module from our compiler, which includes what +> we claim is an illegal type signature (grep ILLEGAL ...). +> Last time I checked, hbc accepted this module. + +Not that I don't believe you, but why is this illegal? +As far as I can see there are no free variables in the function s, +which makes me believe that it can typechecked like a top level +definition. And for a top level defn the signature should be +all right. + + -- Lennart +- ------- End of forwarded message ------- +-} +module ShouldSucceed where + +sort :: Ord a => [a] -> [a] +sort xs = s xs (length xs) + where + s :: Ord b => [b] -> Int -> [b] -- This signature is WRONG + s xs k = if k <= 1 then xs + else merge (sort ys) (sort zs) + where (ys,zs) = init_last xs (k `div` (2::Int)) + +-- Defns of merge and init_last are just dummies with the correct types +merge :: Ord a => [a] -> [a] -> [a] +merge xs ys = xs + +init_last :: [a] -> Int -> ([a],[a]) +init_last a b = (a,a) + diff --git a/testsuite/tests/typecheck/should_compile/tc092.hs b/testsuite/tests/typecheck/should_compile/tc092.hs new file mode 100644 index 0000000000..2f129026a7 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc092.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Rank2Types #-} + +module ShouldSucceed where + +data Empty q = Empty (Ord a => q a) +q :: (Ord a) => [a] +q = [] +e0, e1, e2 :: Empty [] +e0 = Empty [] +e1 = Empty ([] :: (Ord a) => [a]) +e2 = Empty q diff --git a/testsuite/tests/typecheck/should_compile/tc093.hs b/testsuite/tests/typecheck/should_compile/tc093.hs new file mode 100644 index 0000000000..c834428b20 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc093.hs @@ -0,0 +1,25 @@ +module ShouldSucceed where + +data State c a = State (c -> (a,c)) + +unState :: State c a -> (c -> (a,c)) +unState (State x) = x + +unitState :: a -> State c a +unitState a = State (\s0 -> (a,s0)) + +bindState :: State c a -> (a -> State c b) -> State c b +bindState m k = State (\s0 -> let (a,s1) = (unState m) s0 + (b,s2) = (unState (k a)) s1 + in (b,s2)) + +instance Eq c => Monad (State c) where + return = unitState + (>>=) = bindState + +data TS = TS { vs::Int } deriving (Show,Eq) + +type St a = State TS a + +foo :: Int -> St Int -- it works if this line is not given +foo x = return x diff --git a/testsuite/tests/typecheck/should_compile/tc094.hs b/testsuite/tests/typecheck/should_compile/tc094.hs new file mode 100644 index 0000000000..334c34cf18 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc094.hs @@ -0,0 +1,7 @@ +module ShouldSucceed where + +-- From a bug report by Sven Panne. + +foo = bar + where bar = \_ -> (truncate boing, truncate boing) + boing = 0 diff --git a/testsuite/tests/typecheck/should_compile/tc095.hs b/testsuite/tests/typecheck/should_compile/tc095.hs new file mode 100644 index 0000000000..5e0a34d912 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc095.hs @@ -0,0 +1,237 @@ +{- +Bug report from Jon Mountjoy: + +While playing with Happy I managed to generate a Haskell program +which compiles fine under ghc but not under Hugs. I don't know which +one is the culprit.... + +In Hugs(January 1998), one gets + + ERROR "hugs.hs" (line 32): Unresolved top-level overloading + *** Binding : happyReduce_1 + *** Outstanding context : Functor b + +where line 32 is the one marked -- ## + +It compiles in ghc-3.00. Changing very small things, like the +line marked ---**** to + action_0 (6) = happyShift action_0 ---**** + +then makes ghc produce a similar message: + + hugs.hs:37: + Cannot resolve the ambiguous context (Functor a1Ab) + `Functor a1Ab' arising from use of `reduction', at hugs.hs:37 +-} + +module ShouldSucceed where + +data HappyAbsSyn t1 t2 t3 + = HappyTerminal Token + | HappyErrorToken Int + | HappyAbsSyn1 t1 + | HappyAbsSyn2 t2 + | HappyAbsSyn3 t3 + +action_0 (6) = happyShift action_3 --- ***** +action_0 (1) = happyGoto action_1 +action_0 (2) = happyGoto action_2 +action_0 _ = happyFail + +action_1 (7) = happyAccept +action_1 _ = happyFail + +action_2 _ = happyReduce_1 + +action_3 (5) = happyShift action_4 +action_3 _ = happyFail + +action_4 (4) = happyShift action_6 +action_4 (3) = happyGoto action_5 +action_4 _ = happyFail + +action_5 _ = happyReduce_2 + +action_6 _ = happyReduce_3 + +happyReduce_1 = happySpecReduce_1 1 reduction where { -- ## + reduction + (HappyAbsSyn2 happy_var_1) + = HappyAbsSyn1 + (\p -> let q = map (\(x,y) -> (x,y p)) happy_var_1 in (10.1)) +; + reduction _ = notHappyAtAll } + +happyReduce_2 = happySpecReduce_3 2 reduction where { + reduction + (HappyAbsSyn3 happy_var_3) + _ + (HappyTerminal (TokenVar happy_var_1)) + = HappyAbsSyn2 + ([(happy_var_1,happy_var_3)]); + reduction _ _ _ = notHappyAtAll } + +happyReduce_3 = happySpecReduce_1 3 reduction where { + reduction + (HappyTerminal (TokenInt happy_var_1)) + = HappyAbsSyn3 + (\p -> happy_var_1); + reduction _ = notHappyAtAll } + +happyNewToken action sts stk [] = + action 7 7 (error "reading EOF!") (HappyState action) sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = action i i tk (HappyState action) sts stk tks in + case tk of { + TokenInt happy_dollar_dollar -> cont 4; + TokenEq -> cont 5; + TokenVar happy_dollar_dollar -> cont 6; + } + +happyThen = \m k -> k m +happyReturn = \a tks -> a +myparser = happyParse + + + +happyError ::[Token] -> a +happyError _ = error "Parse error\n" + +--Here are our tokens +data Token = + TokenInt Int + | TokenVar String + | TokenEq + deriving Show + +main = print (myparser [] []) +-- $Id: tc095.hs,v 1.4 2005/05/24 11:33:11 simonpj Exp $ + +{- + The stack is in the following order throughout the parse: + + i current token number + j another copy of this to avoid messing with the stack + tk current token semantic value + st current state + sts state stack + stk semantic stack +-} + +----------------------------------------------------------------------------- + +happyParse = happyNewToken action_0 [] [] + +-- All this HappyState stuff is simply because we can't have recursive +-- types in Haskell without an intervening data structure. + +newtype HappyState b c = HappyState + (Int -> -- token number + Int -> -- token number (yes, again) + b -> -- token semantic value + HappyState b c -> -- current state + [HappyState b c] -> -- state stack + c) + +----------------------------------------------------------------------------- +-- Accepting the parse + +happyAccept j tk st sts [ HappyAbsSyn1 ans ] = happyReturn ans +happyAccept j tk st sts _ = notHappyAtAll + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state (-1) tk st sts stk@(HappyErrorToken i : _) = +-- _trace "shifting the error token" $ + new_state i i tk (HappyState new_state) (st:sts) stk + +happyShift new_state i tk st sts stk = + happyNewToken new_state (st:sts) (HappyTerminal tk:stk) + +----------------------------------------------------------------------------- +-- Reducing + +-- happyReduce is specialised for the common cases. + +-- don't allow reductions when we're in error recovery, because this can +-- lead to an infinite loop. + +happySpecReduce_0 i fn (-1) tk _ sts stk + = case sts of + st@(HappyState action):sts -> action (-1) (-1) tk st sts stk + _ -> happyError +happySpecReduce_0 i fn j tk st@(HappyState action) sts stk + = action i j tk st (st:sts) (fn : stk) + +happySpecReduce_1 i fn (-1) tk _ (st@(HappyState action):sts) stk + = action (-1) (-1) tk st sts stk +happySpecReduce_1 i fn j tk _ sts@(st@(HappyState action):_) (v1:stk') + = action i j tk st sts (fn v1 : stk') +happySpecReduce_1 _ _ _ _ _ _ _ + = notHappyAtAll + +happySpecReduce_2 i fn (-1) tk _ (st@(HappyState action):sts) stk + = action (-1) (-1) tk st sts stk +happySpecReduce_2 i fn j tk _ (_:sts@(st@(HappyState action):_)) (v1:v2:stk') + = action i j tk st sts (fn v1 v2 : stk') +happySpecReduce_2 _ _ _ _ _ _ _ + = notHappyAtAll + +happySpecReduce_3 i fn (-1) tk _ (st@(HappyState action):sts) stk + = action (-1) (-1) tk st sts stk +happySpecReduce_3 i fn j tk _ (_:_:sts@(st@(HappyState action):_)) + (v1:v2:v3:stk') + = action i j tk st sts (fn v1 v2 v3 : stk') +happySpecReduce_3 _ _ _ _ _ _ _ + = notHappyAtAll + +happyReduce k i fn (-1) tk _ (st@(HappyState action):sts) stk + = action (-1) (-1) tk st sts stk +happyReduce k i fn j tk st sts stk = action i j tk st' sts' (fn stk) + where sts'@(st'@(HappyState action):_) = drop (k::Int) (st:sts) + +happyMonadReduce k i c fn (-1) tk _ sts stk + = case sts of + (st@(HappyState action):sts) -> action (-1) (-1) tk st sts stk + [] -> happyError +happyMonadReduce k i c fn j tk st sts stk = + happyThen (fn stk) (\r -> action i j tk st' sts' (c r : stk')) + where sts'@(st'@(HappyState action):_) = drop (k::Int) (st:sts) + stk' = drop (k::Int) stk + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + +happyGoto action j tk st = action j j tk (HappyState action) + +----------------------------------------------------------------------------- +-- Error recovery (-1 is the error token) + +-- fail if we are in recovery and no more states to discard +{-# NOINLINE happyFail #-} +-- NOINLINE else GHC diverges with the contravariant data type bug +-- See test simplCore/should_compile/simpl012 +happyFail (-1) tk st' [] stk = happyError + +-- discard a state +happyFail (-1) tk st' (st@(HappyState action):sts) stk = +-- _trace "discarding state" $ + action (-1) (-1) tk st sts stk + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. + +-- we push the error token on the stack in anticipation of a shift, +-- and also because this is a convenient place to store the saved token. + +happyFail i tk st@(HappyState action) sts stk = +-- _trace "entering error recovery" $ + action (-1) (-1) tk st sts (HappyErrorToken i : stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +-- end of Happy Template. diff --git a/testsuite/tests/typecheck/should_compile/tc096.hs b/testsuite/tests/typecheck/should_compile/tc096.hs new file mode 100644 index 0000000000..165c5bd636 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc096.hs @@ -0,0 +1,36 @@ +module ShouldSucceed where + +-- !!! monomorphism restriction and defaulting + +x = 3 + +main = print $ 6 / x + +{- +Hugs 1.4 complains: ERROR "Strange.hs" (line 3): Int is not an +instance of class "Fractional". GHC however compiles the program. +Substitute for x and Hugs is happy. What's going on? + +I haven't studied the numeric classes much so perhaps I'm missing +something obvious here. (I see that the bugs page alludes to some 1.4 +features not in Hugs leading to type errors. If this is it, maybe you +should give it as an example?) + + Bjarte + +------- Message 2 + +Date: Wed, 25 Feb 98 14:01:35 -0500 +From: "John C. Peterson" <peterson-john@CS.YALE.EDU> +To: bjartem@idi.ntnu.no +cc: hugs-bugs@CS.YALE.EDU +Subject: Re: Fractional and Int? + +This is a known hugs bug. x should be monomorphic, allowing the usage +in main to constrain it to Fractional. Instead, it is generalized and +then defaulted to Int without being influenced by main. So ghc is +right and hugs is wrong on this one. I expect this will be fixed +eventually. + + John +-} diff --git a/testsuite/tests/typecheck/should_compile/tc097.hs b/testsuite/tests/typecheck/should_compile/tc097.hs new file mode 100644 index 0000000000..a65d529dd3 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc097.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Rank2Types #-} +-- !!! Local universal quantification. +module ShouldSucceed where + +data Monad2 m = MkMonad2 (forall a. a -> m a) + (forall a b. m a -> (a -> m b) -> m b) + +halfListMonad :: (forall a b. [a] -> (a -> [b]) -> [b]) -> Monad2 [] +halfListMonad b = MkMonad2 (\x -> [x]) b diff --git a/testsuite/tests/typecheck/should_compile/tc098.hs b/testsuite/tests/typecheck/should_compile/tc098.hs new file mode 100644 index 0000000000..f870caa0e7 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc098.hs @@ -0,0 +1,31 @@ +-- !!! Ambiguity in local declarations + +module ShouldSucceed where + +type Cp a = a -> a -> Ordering + +m :: Eq a => Cp a -> [a] -> a +m _ [x,y,z] = if x==y then x else z + +cpPairs :: Cp [j] -> (a,[j]) -> (a,[j]) -> Ordering +cpPairs cp (_,p) (_,q) = cp p q + +mp :: (Eq i,Eq j) => Cp [j] -> [(i,[j])] -> (i,[j]) +mp cp dD = + let minInRow = m (cpPairs cp) + in minInRow dD + +{- GHC 3.02 reported + + T.hs:24: + Ambiguous type variable(s) + `j' in the constraint `Eq (aYD, [j])' + arising from use of `m' at T.hs:24 + In an equation for function `mp': + mp cp dD = let minInRow = m (cpPairs cp) in minInRow dD + +This was because the ambiguity test in tcSimplify didn't +take account of the type variables free in the environment. + +It should compile fine. +-} diff --git a/testsuite/tests/typecheck/should_compile/tc099.hs b/testsuite/tests/typecheck/should_compile/tc099.hs new file mode 100644 index 0000000000..367789a4c7 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc099.hs @@ -0,0 +1,8 @@ +-- !! check if tc type substitutions really do +-- !! clone (or if not, work around it by cloning +-- !! all binders in first pass of the simplifier). +module ShouldCompile where + +f,g :: Eq a => (a,b) +f = g +g = f diff --git a/testsuite/tests/typecheck/should_compile/tc100.hs b/testsuite/tests/typecheck/should_compile/tc100.hs new file mode 100644 index 0000000000..06f34750e1 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc100.hs @@ -0,0 +1,7 @@ +-- !!! Caused ghc-3.03 and 4.01 tc to enter a +-- !!! a blackhole (as reported by P. Callaghan.) +module ShouldCompile where + +type C a = D a -> a +newtype D a = DD (D_ a) +type D_ a = C (Maybe a) diff --git a/testsuite/tests/typecheck/should_compile/tc101.hs b/testsuite/tests/typecheck/should_compile/tc101.hs new file mode 100644 index 0000000000..7ae95d53f5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc101.hs @@ -0,0 +1,15 @@ +-- !!! Caused ghc-4.04proto to loop! +-- !!! (as reported by Sigbjorn) + +module ShouldCompile where + +-- This made the compiler (4.04 proto) loop (stack overflow) +-- The bug was in TcUnify.uUnboundVar and is documented there. + +type A a = () + +f :: (A a -> a -> ()) -> () +f = \ _ -> () + +x :: () +x = f (\ x p -> p x) diff --git a/testsuite/tests/typecheck/should_compile/tc102.hs b/testsuite/tests/typecheck/should_compile/tc102.hs new file mode 100644 index 0000000000..c71b2d0ec0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc102.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} + +-- !!! Caused ghc-4.04proto to report a bogus type error +-- !!! (as reported by Keith) + +-- The type error arose from a mistake in tcMatches.tc_match + +-- Involves pattern type signatures + +module ShouldCompile where + +p :: forall a. a -> a +p = let y = p in \ (x::a) -> x diff --git a/testsuite/tests/typecheck/should_compile/tc104.hs b/testsuite/tests/typecheck/should_compile/tc104.hs new file mode 100644 index 0000000000..25f354c42a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc104.hs @@ -0,0 +1,4 @@ +-- !!! Checking that Main.main's type can now be of the form (IO a) +module Main(main) where + +main = putStrLn "Hello" >> return (id) diff --git a/testsuite/tests/typecheck/should_compile/tc105.hs b/testsuite/tests/typecheck/should_compile/tc105.hs new file mode 100644 index 0000000000..6f35fff7fb --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc105.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} + +module ShouldCompile where + +import Control.Monad.ST +import Data.STRef + +-- (Modified now that we don't have result type signatures) + +f:: forall s. ST s Int +f = do v <- newSTRef 5 + let g :: ST s Int + -- ^ should be in scope + g = readSTRef v + g diff --git a/testsuite/tests/typecheck/should_compile/tc106.hs b/testsuite/tests/typecheck/should_compile/tc106.hs new file mode 100644 index 0000000000..565bbad9b4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc106.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} + +-- !!! Mutually recursive kind inference +-- Exposes a bug in 4.08 (fixed in 4.08 pl1) + +module ShouldCompile where + +-- This pair will tickle the bug +class Lookup c k a where + lookupAll :: Sequence seq a => c -> k -> seq a + +class Lookup (s a) Int a => Sequence s a where + foo :: s a + + +-- This decl will tickle it all by itself +class Matrix a e where + amap2 :: (Matrix a d) => + (e -> d -> e) -> a ix e -> a ix d -> a ix e + diff --git a/testsuite/tests/typecheck/should_compile/tc107.hs b/testsuite/tests/typecheck/should_compile/tc107.hs new file mode 100644 index 0000000000..75211bc584 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc107.hs @@ -0,0 +1,8 @@ +-- !!! Kind checking in a recursive situation +-- Exposes a bug in proto-4.09 (black hole) + +module ShouldCompile where + +data ChItem = ChItemX Stream +type Stream = ChItem + diff --git a/testsuite/tests/typecheck/should_compile/tc108.hs b/testsuite/tests/typecheck/should_compile/tc108.hs new file mode 100644 index 0000000000..71f5f5c07f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc108.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} +-- !!! Scopes in kind checking + +-- Exposes a bizarre bug in 4.08.1 +-- TestSh.hs:6: +-- `Shape' is not in scope +-- When checking kinds in `HasConfigValue Shape nodeTypeParms' +-- In the class declaration for `HasShape' + +module ShouldCompile where + +data Shape value = Box | Circle + +class HasConfigValue Shape nodeTypeParms => HasShape nodeTypeParms where {} + +class HasConfigValue option configuration where + ($$$) :: option value -> configuration value -> configuration value + + diff --git a/testsuite/tests/typecheck/should_compile/tc109.hs b/testsuite/tests/typecheck/should_compile/tc109.hs new file mode 100644 index 0000000000..0d9fdc051c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc109.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + UndecidableInstances #-} +-- UndecidableInstances because 'b' appears in the context but not the head + +module ShouldCompile where + +-- This accepted by Hugs, but not by GHC 4.08.1 +-- Reported by Thomas Hallgren Nov 00 + +class P a +class R a b | b->a + +instance (P a,R a b) => P [b] + +{- GHC 4.08.1 doesn't seem to allow variables in the context that +don't appear after the =>, but which are still ok since they are +determined by the functional dependenices. -} + + diff --git a/testsuite/tests/typecheck/should_compile/tc111.hs b/testsuite/tests/typecheck/should_compile/tc111.hs new file mode 100644 index 0000000000..26eb942970 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc111.hs @@ -0,0 +1,19 @@ + +-- !!! Test monomorphism + RULES + +module ShouldCompile where + +-- This example crashed GHC 4.08.1. +-- The reason was that foobar is monomorphic, so the RULE +-- should not generalise over it. + +foo 1 = 2 +bar 0 = 1 + +foobar = 2 + +{-# RULES + "foo/bar" foo bar = foobar + #-} + + diff --git a/testsuite/tests/typecheck/should_compile/tc112.hs b/testsuite/tests/typecheck/should_compile/tc112.hs new file mode 100644 index 0000000000..d588d0e698 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc112.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + +-- !!! Functional dependencies +-- This broke an early impl of functional dependencies +-- (complaint about ambiguity) + +module ShouldCompile where + +class C a b | a -> b where f :: a -> b + +g :: (C a b, Eq b) => a -> Bool +g x = f x == f x diff --git a/testsuite/tests/typecheck/should_compile/tc113.hs b/testsuite/tests/typecheck/should_compile/tc113.hs new file mode 100644 index 0000000000..38e79743e4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc113.hs @@ -0,0 +1,13 @@ +-- !!! Monomorphism restriction + +module ShouldCompile where + +foo :: Eq a => a -> b -> b +foo x y = y + +-- Expect test2 :: forall b. b->b +-- despite the monomorphism restriction +poly = foo (3::Int) + +-- Check that test2 is polymorphic +test = (poly True, poly 'c') diff --git a/testsuite/tests/typecheck/should_compile/tc114.hs b/testsuite/tests/typecheck/should_compile/tc114.hs new file mode 100644 index 0000000000..e8c339bdf6 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc114.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances #-} + +-- !!! Functional dependencies +-- This broke an early impl of functional dependencies + +module ShouldCompile where + +class Foo r a | r -> a where + foo :: a -> r + +instance Foo (Maybe e) e where + foo = Just + +bad:: Num e => Maybe e +bad = foo 0 diff --git a/testsuite/tests/typecheck/should_compile/tc115.hs b/testsuite/tests/typecheck/should_compile/tc115.hs new file mode 100644 index 0000000000..139b3a5323 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc115.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances #-} +-- !!! Functional dependencies +-- This broke an early impl of functional dependencies +-- (complaining about ambiguity) + +module ShouldCompile where + +class Foo r a | r -> a where + foo :: r -> a + +instance Foo [m a] (m a) + +bad:: Monad m => m a +bad = foo bar + +bar:: Monad m => [m a] +bar = [] diff --git a/testsuite/tests/typecheck/should_compile/tc115.stderr-ghc b/testsuite/tests/typecheck/should_compile/tc115.stderr-ghc new file mode 100644 index 0000000000..b4b8dd81b1 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc115.stderr-ghc @@ -0,0 +1,4 @@ + +tc115.hs:12:10: + Warning: No explicit method nor default method for `foo' + In the instance declaration for `Foo [m a] (m a)' diff --git a/testsuite/tests/typecheck/should_compile/tc116.hs b/testsuite/tests/typecheck/should_compile/tc116.hs new file mode 100644 index 0000000000..eb93410bed --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc116.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances #-} +-- !!! Functional dependencies +-- This broke an early impl of functional dependencies +-- (caused a panic) + +module ShouldCompile where + +class Foo r a | r -> a where + foo :: r -> a + +instance Foo [m a] (m a) + +bad:: Monad m => m a +bad = foo bar + +bar:: [m a] +bar = [] diff --git a/testsuite/tests/typecheck/should_compile/tc116.stderr-ghc b/testsuite/tests/typecheck/should_compile/tc116.stderr-ghc new file mode 100644 index 0000000000..7aa90036d0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc116.stderr-ghc @@ -0,0 +1,4 @@ + +tc116.hs:12:10: + Warning: No explicit method nor default method for `foo' + In the instance declaration for `Foo [m a] (m a)' diff --git a/testsuite/tests/typecheck/should_compile/tc117.hs b/testsuite/tests/typecheck/should_compile/tc117.hs new file mode 100644 index 0000000000..d27c2b0076 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc117.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, UndecidableInstances #-} +-- UndecidableInstances now needed because the Coverage Condition fails + +-- !!! Functional dependencies +-- This one gave another fail in tcReadMutVar + +module M1 where + +class HasFoo a foo | a -> foo where + foo :: a -> foo +instance HasFoo Int Int where + foo = id + +instance HasFoo a b => HasFoo [a] b where + foo = foo . head + +test:: [[Int]] -> Int +test = foo diff --git a/testsuite/tests/typecheck/should_compile/tc118.hs b/testsuite/tests/typecheck/should_compile/tc118.hs new file mode 100644 index 0000000000..5828a1287c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc118.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + UndecidableInstances #-} + +-- !!! An instance decl with a context containing a free type variable +-- The interest here is that there's a "b" in the instance decl +-- context that isn't mentioned in the instance head. +-- Hence UndecidableInstances + +module ShouldCompile where + +class HasConverter a b | a -> b where + convert :: a -> b + +data Foo a = MkFoo a + +instance (HasConverter a b,Show b) => Show (Foo a) where + show (MkFoo value) = show (convert value) + diff --git a/testsuite/tests/typecheck/should_compile/tc119.hs b/testsuite/tests/typecheck/should_compile/tc119.hs new file mode 100644 index 0000000000..e29cb6a72f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc119.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + ExistentialQuantification #-} + +-- !!! Functional dependencies and existentials + +-- Hugs (February 2000) doesn't like it. It says +-- Variable "e" in constraint is not locally bound + +module ShouldCompile where + +class Collection c e | c -> e where + empty :: c + put :: c -> e -> c + +data SomeCollection e = forall c . Collection c e => MakeSomeCollection c diff --git a/testsuite/tests/typecheck/should_compile/tc120.hs b/testsuite/tests/typecheck/should_compile/tc120.hs new file mode 100644 index 0000000000..11c64d868d --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc120.hs @@ -0,0 +1,8 @@ +-- !!! Check that we can have a type for main that is more general than IO a + +-- main :: forall a.a certainly also has type IO a, so it should be fine. + +module Main(main) where + +main :: a +main = error "not much luck" diff --git a/testsuite/tests/typecheck/should_compile/tc121.hs b/testsuite/tests/typecheck/should_compile/tc121.hs new file mode 100644 index 0000000000..9f25183e7a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc121.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ImplicitParams #-} + +-- !!! Implicit Parameters + +-- If the implicit param isn't recognized as a PredType, x and y +-- will be inferred to have two params instead of one. + +module ShouldCompile where + +x () = ?wibble + +y () = x () + +same :: a -> a -> b +same x y = undefined + +a () = same x id +b () = same y id diff --git a/testsuite/tests/typecheck/should_compile/tc122.hs b/testsuite/tests/typecheck/should_compile/tc122.hs new file mode 100644 index 0000000000..71315f20c8 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc122.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ImplicitParams #-} + +-- !!! Implicit Parameters + +-- GHC 5.00 doesn't handle this: + +-- Could not deduce `?wibble :: t' from the context () +-- Probable fix: +-- Add `?wibble :: t' to the banding(s) for {y} +-- Or add an instance declaration for `?wibble :: t' +-- arising from use of implicit parameter `?wibble' at tc122.hs:18 +-- in the definition of function `y': wibble + + +module ShouldCompile where + +x () = y + where y = ?wibble diff --git a/testsuite/tests/typecheck/should_compile/tc123.hs b/testsuite/tests/typecheck/should_compile/tc123.hs new file mode 100644 index 0000000000..fb49c91a4b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc123.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ImplicitParams #-} + +-- !!! Monotypes w/ Implicit Parameters + +-- GHC 5.00 doesn't handle this: + +-- Couldn't match `{?wibble :: Int}' against `()' +-- Expected type: {?wibble :: Int} +-- Inferred type: () +-- In the first argument of `x', namely `()' +-- in the definition of function `y': x () + +module ShouldCompile where + +x () = (?wibble :: Int) + +y () = x () diff --git a/testsuite/tests/typecheck/should_compile/tc124.hs b/testsuite/tests/typecheck/should_compile/tc124.hs new file mode 100644 index 0000000000..cd2362be4f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc124.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Rank2Types #-} +
+-- !!! Rank 2 polymorphism
+-- Both f and g are rejected by Hugs [April 2001]
+
+module Foo where
+
+data T = T { t1 :: forall a. a -> a , t2 :: forall a b. a->b->b }
+
+-- Test pattern bindings for polymorphic fields
+f :: T -> (Int,Char)
+f t = let T { t1 = my_t1 } = t
+ in
+ (my_t1 3, my_t1 'c')
+
+-- Test record update with polymorphic fields
+g :: T -> T
+g t = t { t2 = \x y -> y }
diff --git a/testsuite/tests/typecheck/should_compile/tc125.hs b/testsuite/tests/typecheck/should_compile/tc125.hs new file mode 100644 index 0000000000..8d820ba209 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc125.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, UndecidableInstances #-} +-- UndecidableInstances now needed because the Coverage Condition fails + +-- !!! Functional dependency test. Hugs [Apr 2001] fails to typecheck this +-- We should infer this type for foo +-- foo :: Q (S (S Z)) (S Z) + +module ShouldCompile where + +data Z = Z +data S a = S a + +class Add a b c | a b -> c where add :: a -> b -> c + +instance Add Z a a +instance Add a b c => Add (S a) b (S c) + +class Mul a b c | a b -> c where mul :: a -> b -> c + +instance Mul Z a Z +instance (Mul a b c, Add b c d) => Mul (S a) b d + +data Q a b = Q a b + +-- Problem here. This is the addition of rational +-- numbers: (a/b) + (c/d) = (ad+bc)/bd + +instance (Mul a d ad, + Mul b c bc, + Mul b d bd, + Add ad bc ad_bc) => Add (Q a b) (Q c d) (Q ad_bc bd) + +z = Z +sz = S Z +ssz = S (S Z) + +foo = add (Q sz sz) (Q sz sz) diff --git a/testsuite/tests/typecheck/should_compile/tc125.stderr-ghc b/testsuite/tests/typecheck/should_compile/tc125.stderr-ghc new file mode 100644 index 0000000000..628c5e59db --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc125.stderr-ghc @@ -0,0 +1,20 @@ + +tc125.hs:16:10: + Warning: No explicit method nor default method for `add' + In the instance declaration for `Add Z a a' + +tc125.hs:17:10: + Warning: No explicit method nor default method for `add' + In the instance declaration for `Add (S a) b (S c)' + +tc125.hs:21:10: + Warning: No explicit method nor default method for `mul' + In the instance declaration for `Mul Z a Z' + +tc125.hs:22:10: + Warning: No explicit method nor default method for `mul' + In the instance declaration for `Mul (S a) b d' + +tc125.hs:29:10: + Warning: No explicit method nor default method for `add' + In the instance declaration for `Add (Q a b) (Q c d) (Q ad_bc bd)' diff --git a/testsuite/tests/typecheck/should_compile/tc126.hs b/testsuite/tests/typecheck/should_compile/tc126.hs new file mode 100644 index 0000000000..2680ea6290 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc126.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, FlexibleContexts, UndecidableInstances #-} +-- UndecidableInstances now needed because the Coverage Condition fails + +-- !!! Functional dependency test. Hugs [Apr 2001] fails to typecheck this +-- Rather bizarre example submitted by Jonathon Bell + +module ShouldCompile where + +-- module Foo where + +class Bug f a r | f a -> r where + bug::f->a->r + +instance Bug (Int->r) Int r +instance (Bug f a r) => Bug f (c a) (c r) + +f:: Bug(Int->Int) a r => a->r +f = bug (id::Int->Int) + +g1 = f (f [0::Int]) +-- Inner f gives result type +-- f [0::Int] :: Bug (Int->Int) [Int] r => r +-- Which matches the second instance declaration, giving r = [r'] +-- f [0::Int] :: Bug (Int->Int) Int r' => r' +-- Wwich matches the first instance decl giving r' = Int +-- f [0::Int] :: Int +-- The outer f now has constraint +-- Bug (Int->Int) Int r +-- which makes r=Int +-- So g1::Int + +g2 = f (f (f [0::Int])) +-- The outer f repeats the exercise, so g2::Int +-- This is the definition that Hugs rejects + diff --git a/testsuite/tests/typecheck/should_compile/tc126.stderr-ghc b/testsuite/tests/typecheck/should_compile/tc126.stderr-ghc new file mode 100644 index 0000000000..a414a0e35a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc126.stderr-ghc @@ -0,0 +1,8 @@ + +tc126.hs:15:25: + Warning: No explicit method nor default method for `bug' + In the instance declaration for `Bug (Int -> r) Int r' + +tc126.hs:16:10: + Warning: No explicit method nor default method for `bug' + In the instance declaration for `Bug f (c a) (c r)' diff --git a/testsuite/tests/typecheck/should_compile/tc127.hs b/testsuite/tests/typecheck/should_compile/tc127.hs new file mode 100644 index 0000000000..58ccca7a5e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc127.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ImplicitParams #-} + +-- !!! Another implicit parameter test, from Alastair Reid + +module ShouldCompile where + +import Data.Maybe + +type Env = ([(String,Int)],Int) + +ident1 :: (?env :: Env) => String -> Int +ident1 x = y + where + env = ?env + y = fromJust (lookup x (fst env)) + +ident2 :: (?env :: Env) => String -> Int +ident2 x = y + where + y = fromJust (lookup x (fst ?env)) + + +-- Two more tests from Jeff Lewis +x () = y where y = ?wibble + +f () = ?wibble :: Int +g () = f () diff --git a/testsuite/tests/typecheck/should_compile/tc128.hs b/testsuite/tests/typecheck/should_compile/tc128.hs new file mode 100644 index 0000000000..139e8e5a14 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc128.hs @@ -0,0 +1,10 @@ +-- !!! Test type checking of mutually recursive groups +-- GHC 5.00 was falling into a black hole when type checking a recursive +-- group of type declarations including a *chain* of type synonyms. + +module ShouldCompile where + + type PhraseFun = PMap -> Float + type PMap = () -> Player + data Player = MkT PhraseFun + diff --git a/testsuite/tests/typecheck/should_compile/tc129.hs b/testsuite/tests/typecheck/should_compile/tc129.hs new file mode 100644 index 0000000000..56163ffe31 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc129.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ImplicitParams #-} + +-- !!! Test inheritance of implicit parameters. +-- GHC 5.00.2 fails this test + +-- The thing is to do with whether an implicit parameter +-- constraint can be "inherited". See notes in TcSimplify.lhs + +module ShouldCompile where + +data R = R {f :: Int} + +foo :: (?x :: Int) => R -> R +foo r = r {f = ?x} + +baz :: (?x :: Int) => Int +baz = (?x +1) :: Int + diff --git a/testsuite/tests/typecheck/should_compile/tc130.hs b/testsuite/tests/typecheck/should_compile/tc130.hs new file mode 100644 index 0000000000..da91273ff0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc130.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE ImplicitParams #-} + +-- !!! Desugaring of record updates +-- Showed up a bug in the newtype-squashing machinery + + +module ShouldCompile where + +data R = R {field :: Int} + +test:: (?param :: R) => a -> Int +test x = field (?param {field = 42}) + -- The type of the record to be updated is + -- {?param :: R} as well as plain R + -- which confused the compiler + diff --git a/testsuite/tests/typecheck/should_compile/tc131.hs b/testsuite/tests/typecheck/should_compile/tc131.hs new file mode 100644 index 0000000000..14813edb4e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc131.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + +-- !!! Typechecking of functional dependencies +-- Showed up (another) bug in the newtype-squashing machinery + + +module ShouldCompile where + +class Split2 a b | a -> b, b -> a where + combine2 :: (b,b) -> a + +class Split4 a b | a -> b, b -> a where + combine4 :: (b,b) -> a + +newtype Word16 = Word16 Int +newtype Word32 = Word32 Int +newtype Word64 = Word64 Int + +instance Split2 Word32 Word16 where + combine2 = undefined + +instance Split2 Word64 Word32 where + combine2 a = undefined + +instance Split4 Word64 Word16 where + combine4 (a, b) = + combine2 ( (combine2 (a, b)), combine2 (a, b)) + + + diff --git a/testsuite/tests/typecheck/should_compile/tc132.hs b/testsuite/tests/typecheck/should_compile/tc132.hs new file mode 100644 index 0000000000..f32e6dc6bc --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc132.hs @@ -0,0 +1,13 @@ +-- !!! Monomorphism restriction +-- This one should work fine, despite the monomorphism restriction +-- Fails with GHC 5.00.1 + +module Test where +import Control.Monad.ST +import Data.STRef + +-- Should get +-- apa :: forall s. ST s () +apa = newSTRef () >> return () + +foo1 = runST apa diff --git a/testsuite/tests/typecheck/should_compile/tc133.hs b/testsuite/tests/typecheck/should_compile/tc133.hs new file mode 100644 index 0000000000..8b378a4f00 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc133.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-} + +-- !!! Existentials + +-- This one killed GHC 5.00.1: +-- Inferred type is less polymorphic than expected +-- Quantified type variable `a' is unified with another quantified type variable `a' +-- When checking a pattern that binds f :: a -> Int +-- In the definition of `f': f (T (x :: a) f) = T (undefined :: a) f + +module Test where + +data T = forall a. T a (a->Int) + +f :: T -> T +f (T (x::a) f) = T (undefined::a) f diff --git a/testsuite/tests/typecheck/should_compile/tc134.hs b/testsuite/tests/typecheck/should_compile/tc134.hs new file mode 100644 index 0000000000..84eb75c82f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc134.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- !!! Scoped type variables: result sig + +module Test where + +f :: Int -> Int +f x :: Int = x + +g :: Int -> Int +g x :: a = x :: a -- Here, a is a name for Int diff --git a/testsuite/tests/typecheck/should_compile/tc134.stderr b/testsuite/tests/typecheck/should_compile/tc134.stderr new file mode 100644 index 0000000000..1bf70204eb --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc134.stderr @@ -0,0 +1,5 @@ + +tc134.hs:11:2: + The scoped type variable `a' is bound to the type `Int' + You can only bind scoped type variables to type variables + In the definition of `g': g x :: a = x :: a diff --git a/testsuite/tests/typecheck/should_compile/tc135.hs b/testsuite/tests/typecheck/should_compile/tc135.hs new file mode 100644 index 0000000000..6ede73f573 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc135.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification #-} + +-- !!! scoped type variables w/ existential types +-- this test failed in GHC 5.00 + +module ShouldCompile where + +data T = forall a. MkT [a] + +f :: T -> T +f (MkT [t::a]) = MkT t3 + where t3::[a] = [t,t,t] diff --git a/testsuite/tests/typecheck/should_compile/tc136.hs b/testsuite/tests/typecheck/should_compile/tc136.hs new file mode 100644 index 0000000000..044f0a75f7 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc136.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- !!! scoped type variables +-- this test failed in pre-release GHC 5.02 + +module ShouldCompile where + +f :: forall x. x -> x -> x +f (x::x) (y::x) = x +-- Two points: (a) we are using x as a term variable and as a type variable +-- (b) the type variable appears twice, but that is OK diff --git a/testsuite/tests/typecheck/should_compile/tc137.hs b/testsuite/tests/typecheck/should_compile/tc137.hs new file mode 100644 index 0000000000..dce781d39b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc137.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances #-} +{-# OPTIONS -dcore-lint #-} + +{- This one killed GHC 5.02 + +The problem is that in rather obscure cases (involving functional +dependencies) it is possible to get an AbsBinds [] [] (no tyvars, no +dicts) which nevertheless has some "dictionary bindings". These come +out of the typechecker in non-dependency order, so we need to Rec them +just in case. Otherwise we get a CoreLint out-of-scope error. + +Reported by Armin Groesslinger + +-} + +module ShouldCompile +where + +data X a = X a + +class Y a b | a -> b where + y :: a -> X b + +instance Y [[a]] a where + y ((x:_):_) = X x + +g :: Num a => [X a] -> [X a] +g xs = h xs + where + h ys = ys ++ map (k (y [[0]])) xs + +k :: X a -> X a -> X a +k _ _ = y ([] ++ [[]] ++ []) diff --git a/testsuite/tests/typecheck/should_compile/tc140.hs b/testsuite/tests/typecheck/should_compile/tc140.hs new file mode 100644 index 0000000000..6536e3d47d --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc140.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Rank2Types #-} + +-- Make sure for-alls can occur in data types + +module Foo where + +newtype CPS1 a = CPS1 { unCPS1 :: forall ans . (a -> ans) -> ans } + +newtype CPS2 a = CPS2 (forall ans . (a -> ans) -> ans) + -- This one also has an interesting record selector; + -- caused an applyTypeArgs crash in 5.02.1 + +data CPS3 a = CPS3 { unCPS3 :: forall ans . (a -> ans) -> ans } +data CPS4 a = CPS4 (forall ans . (a -> ans) -> ans) diff --git a/testsuite/tests/typecheck/should_compile/tc141.hs b/testsuite/tests/typecheck/should_compile/tc141.hs new file mode 100644 index 0000000000..c5f675000d --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc141.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- Scoped type variables on pattern bindings +-- This should *fail* on GHC 5.02 and lower, +-- It's a post-5.02 enhancements to allow them. + +-- It's an error again in GHC 6.6! + +module ShouldCompile where + +f x = let (p::a,q::a) = x in (q::a,p) + +g a b = let y::a = a in + let v :: a + v = b + in v +
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_compile/tc141.stderr b/testsuite/tests/typecheck/should_compile/tc141.stderr new file mode 100644 index 0000000000..2fdf1fa99c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc141.stderr @@ -0,0 +1,6 @@ + +tc141.hs:11:15: Not in scope: type variable `a' + +tc141.hs:11:20: Not in scope: type variable `a' + +tc141.hs:13:16: Not in scope: type variable `a' diff --git a/testsuite/tests/typecheck/should_compile/tc142.hs b/testsuite/tests/typecheck/should_compile/tc142.hs new file mode 100644 index 0000000000..8621710038 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc142.hs @@ -0,0 +1,11 @@ +-- !!! Legitimate re-use of prelude class-method name (==) +-- Used not to be legal, but a late H98 change made it legal +-- +module ShouldFail where + +data NUM = ONE | TWO +class EQ a where + (==) :: a -> a -> Bool + +instance EQ NUM where + a == b = True diff --git a/testsuite/tests/typecheck/should_compile/tc143.hs b/testsuite/tests/typecheck/should_compile/tc143.hs new file mode 100644 index 0000000000..316f47aade --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc143.hs @@ -0,0 +1,7 @@ +-- These two declarations get their derived instances +-- in two different ways + +module ShouldCompile where + +newtype Bar = Bar Int deriving Eq +data Baz = Baz Bar deriving Eq diff --git a/testsuite/tests/typecheck/should_compile/tc144.hs b/testsuite/tests/typecheck/should_compile/tc144.hs new file mode 100644 index 0000000000..29185c8bc4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc144.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ImplicitParams, Rank2Types #-} + +-- Rank-2 types with implicit parameters. +-- GHC 5.02 erroneously rejected this + +module ShouldCompile where + + f :: ((?param :: a) => b) -> a -> b + f foo a = let ?param = a in foo + + g :: (?param :: a) => a + g = ?param + + h :: a -> a + h = f g diff --git a/testsuite/tests/typecheck/should_compile/tc145.hs b/testsuite/tests/typecheck/should_compile/tc145.hs new file mode 100644 index 0000000000..a11c5b93e5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc145.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ImplicitParams, UnboxedTuples #-} + +-- Test two slightly exotic things about type signatures + +module ShouldCompile where + + -- The for-all hoisting should hoist the + -- implicit parameter to give + -- r :: (?param::a) => a + r :: Int -> ((?param :: a) => a) + r = error "urk" + + -- The unboxed tuple is OK because it is + -- used on the right hand end of an arrow + type T = (# Int, Int #) + + f :: Int -> T + f = error "urk" diff --git a/testsuite/tests/typecheck/should_compile/tc146.hs b/testsuite/tests/typecheck/should_compile/tc146.hs new file mode 100644 index 0000000000..4f44e908cf --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc146.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Rank2Types #-} + +-- The interesting thign about this one is that +-- there's an unbound type variable of kind *->* +-- that the typechecker should default to some +-- arbitrary type. +-- +-- GHC 5.02 could only really deal with such things +-- of kind *, but 5.03 extended that to *->..->* +-- Still not complete, but a lot better. + +module ShouldCompile where + +f :: (forall a b . a b -> int) -> (forall c . c int) -> int +f x y = x y diff --git a/testsuite/tests/typecheck/should_compile/tc147.hs b/testsuite/tests/typecheck/should_compile/tc147.hs new file mode 100644 index 0000000000..1125fe7051 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc147.hs @@ -0,0 +1,8 @@ +-- This one sent 5.03 into an infinite loop, because it +-- gazed too deeply into the functional type of PP + +module ShouldCompile where + +newtype PP = PP (Int -> PP) + +foo = PP undefined diff --git a/testsuite/tests/typecheck/should_compile/tc148.hs b/testsuite/tests/typecheck/should_compile/tc148.hs new file mode 100644 index 0000000000..c66f723550 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc148.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Rank2Types #-} + +-- This program tickled a bug in 5.02.2's forall-lifting + +module ShouldCompile where + +class Class x where + combinator' :: (forall y. Class y => y -> y) -> x -> x + +combinator :: (forall y. Class y => y -> y) + -> (forall x. Class x => x -> x) +combinator f = combinator' f diff --git a/testsuite/tests/typecheck/should_compile/tc149.hs b/testsuite/tests/typecheck/should_compile/tc149.hs new file mode 100644 index 0000000000..5813604bc3 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc149.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE RankNTypes #-} + +module ShouldCompile where + +type Generic i o = forall x. i x -> o x +type Id x = x + +foo :: Generic Id Id +foo = error "urk" + +-- The point here is that we instantiate "i" and "o" +-- with a partially applied type synonym. This is +-- OK in GHC because we check type validity only *after* +-- expanding type synonyms. +-- +-- However, a bug in GHC 5.03-Feb02 made this break a +-- type invariant (see Type.mkAppTy) + diff --git a/testsuite/tests/typecheck/should_compile/tc150.hs b/testsuite/tests/typecheck/should_compile/tc150.hs new file mode 100644 index 0000000000..2e3b9187f0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc150.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} + +module ShouldCompile where + +f v = (\ (x :: forall a. a->a) -> True) id -- 'c' diff --git a/testsuite/tests/typecheck/should_compile/tc151.hs b/testsuite/tests/typecheck/should_compile/tc151.hs new file mode 100644 index 0000000000..b28900de75 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc151.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE RankNTypes #-} + +-- A test for rank-3 types + +module ShouldCompile where + +data Fork a = ForkC a a + +mapFork :: forall a1 a2 . (a1 -> a2) -> (Fork a1 -> Fork a2) +mapFork mapA (ForkC a1 a2) = ForkC (mapA a1) (mapA a2) + +data SequF s a = EmptyF | ZeroF (s (Fork a)) | OneF a (s (Fork a)) +newtype HFix h a = HIn (h (HFix h) a) + +type Sequ = HFix SequF + +mapSequF :: forall s1 s2 . (forall b1 b2 . (b1 -> b2) -> (s1 b1 -> s2 b2)) + -> (forall a1 a2 . (a1 -> a2) -> (SequF s1 a1 -> SequF s2 a2)) +mapSequF mapS mapA EmptyF = EmptyF +mapSequF mapS mapA (ZeroF as) = ZeroF (mapS (mapFork mapA) as) +mapSequF mapS mapA (OneF a as)= OneF (mapA a) (mapS (mapFork mapA) as) + +mapHFix :: forall h1 h2 . (forall f1 f2 . (forall c1 c2 . (c1 -> c2) -> (f1 c1 -> f2 c2)) + -> (forall b1 b2 . (b1 -> b2) -> (h1 f1 b1 -> h2 f2 b2))) + -> (forall a1 a2 . (a1 -> a2) -> (HFix h1 a1 -> HFix h2 a2)) +mapHFix mapH mapA (HIn v) = HIn (mapH (mapHFix mapH) mapA v) + +mapSequ :: forall a1 a2 . (a1 -> a2) -> (Sequ a1 -> Sequ a2) +mapSequ = mapHFix mapSequF + diff --git a/testsuite/tests/typecheck/should_compile/tc152.hs b/testsuite/tests/typecheck/should_compile/tc152.hs new file mode 100644 index 0000000000..43f107365d --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc152.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + UndecidableInstances #-} +-- -XUndecidableInstances now needed because the Coverage Condition fails + +-- This one blew up Hugs (Apr 02) + +module ShouldCompile where + +-- Context reduction can introduce opportunities for context improvement, +-- so add an additional `improve' step afterwards. The bug is demonstrated by +-- the following code: + + class C a b c | a b -> c where + m :: a -> b -> c + + instance C Integer Integer Integer where + m = error "urk" + + newtype T a = T a + + instance C a b c => C (T a) (T b) (T c) where + m = error "urk" + + i :: T Integer + i = undefined + + x = m (m i i) i -- This line blows up w/ unresolved top-level overloading + diff --git a/testsuite/tests/typecheck/should_compile/tc153.hs b/testsuite/tests/typecheck/should_compile/tc153.hs new file mode 100644 index 0000000000..14ded3531a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc153.hs @@ -0,0 +1,12 @@ +-- No ScopedTypeVariables, so (v::a) means (v:: forall a.a) + +module ShouldCompile where + +data T a = T a + +instance Eq (T a) where + (==) x y = let v :: a + v = undefined + in + v + diff --git a/testsuite/tests/typecheck/should_compile/tc154.hs b/testsuite/tests/typecheck/should_compile/tc154.hs new file mode 100644 index 0000000000..d83e7a34c8 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc154.hs @@ -0,0 +1,9 @@ +-- The type sig mentions a type variable that doesn't appear in +-- the type. This one killed GHC 5.03, in a trivial way. + +module ShouldCompile where + +type T a = () -> () + +f :: T a +f () = () diff --git a/testsuite/tests/typecheck/should_compile/tc155.hs b/testsuite/tests/typecheck/should_compile/tc155.hs new file mode 100644 index 0000000000..598afc94da --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc155.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE LiberalTypeSynonyms #-} + +-- The type sig for 'test' is illegal in H98 because of the +-- partial application of the type sig. +-- But with LiberalTypeSynonyms it should be OK because when +-- you expand the type synonyms it's just Int->Int +-- c.f should_fail/tcfail107.hs + +module ShouldCompile where + +type Thing m = m () + +type Const a b = a + +test :: Thing (Const Int) -> Thing (Const Int) +test = test + diff --git a/testsuite/tests/typecheck/should_compile/tc156.hs b/testsuite/tests/typecheck/should_compile/tc156.hs new file mode 100644 index 0000000000..aad75019a9 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc156.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeOperators #-} + +-- Test infix type constructors + +module ShouldCompile where + +infixl 4 :*: +infixl 3 :+: + +data a :*: b = a :*: b +data a :+: b = a :+: b + +data T a b = T (a `b` Int) + +type Foo a b = a `T` b + +f :: Int :*: Bool :+: Char +f = (3 :*: True) :+: 'c' diff --git a/testsuite/tests/typecheck/should_compile/tc157.hs b/testsuite/tests/typecheck/should_compile/tc157.hs new file mode 100644 index 0000000000..5e4b711393 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc157.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Rank2Types #-} + +-- Test silly type synonyms + +module ShouldCompile where + +type C u a = u -- Note 'a' unused + +foo :: (forall a. C u a -> C u a) -> u +foo x = undefined x + +bar :: Num u => u +bar = foo (\t -> t + t) +-- The (Num u) should not get trapped inside the +-- /\a-abstraction which the compiler constructs for +-- the arg to foo. But it might because it's Num (C u a)! + +-- This test tickles a bizarre corner case documented +-- as [Silly Type Synonym] in TcMType.lhs diff --git a/testsuite/tests/typecheck/should_compile/tc158.hs b/testsuite/tests/typecheck/should_compile/tc158.hs new file mode 100644 index 0000000000..4414fc9c21 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc158.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Rank2Types #-} + +-- Types should be checked for well-formedness only after +-- expanding type synonyms. GHC 5.03 fails this + +module ShouldCompile where + +type All u = forall x. x->u +type All' u = u -> All u + +all1 :: All u -> (u -> All u) -> All u +all1 = undefined diff --git a/testsuite/tests/typecheck/should_compile/tc159.hs b/testsuite/tests/typecheck/should_compile/tc159.hs new file mode 100644 index 0000000000..dbdfdc7f55 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc159.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- Don't do the cunning new newtype-deriving thing +-- when the type constructor is recursive + +module Main where + + +newtype A = A [A] deriving (Eq) + +-- The derived instance would be: +-- instance Eq A where +-- (A xs) == (A ys) = xs==ys +-- $df :: Eq [A] => Eq A +-- $df d = d |> Eq (sym co) + +x :: A +x = A [A [], A [A []]] + +main = print (x == x) + diff --git a/testsuite/tests/typecheck/should_compile/tc159.stdout b/testsuite/tests/typecheck/should_compile/tc159.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc159.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/typecheck/should_compile/tc160.hs b/testsuite/tests/typecheck/should_compile/tc160.hs new file mode 100644 index 0000000000..bf88fc3159 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc160.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Rank2Types #-} + +--Tests alpha-renaming in with extended type-synonyms + +module ShouldCompile where + +type Foo x = forall a. a -> x + +foo :: Foo (Foo ()) +-- foo :: forall a b. a -> b -> () +-- NOT forall a. a -> a -> () +foo = undefined + +baz = foo 'c' True diff --git a/testsuite/tests/typecheck/should_compile/tc161.hs b/testsuite/tests/typecheck/should_compile/tc161.hs new file mode 100644 index 0000000000..44f41a57b4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc161.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Rank2Types #-} +-- Blew up GHC 5.04, with: +-- Ambiguous type variable(s) `q' in the constraint `Foo q' +-- arising from a function with an overloaded argument type at Foo.hs:7 +-- Expected type: Int -> (forall q1. (Foo q1) => q1 -> a) -> a +-- Inferred type: Int -> (q -> a) -> a +-- In the application `GHC.Err.noMethodBindingError "Foo.hs:7|Foo.foo"#' +-- +-- Fix is to give wild-card args to the default methods +-- See TcClassDcl.mkDefMethRhs + +module ShouldCompile where + +class Foo a where + op :: Eq c => c -> (forall b. Eq b => b->b) -> a -> a + +instance Foo Int diff --git a/testsuite/tests/typecheck/should_compile/tc161.stderr-ghc b/testsuite/tests/typecheck/should_compile/tc161.stderr-ghc new file mode 100644 index 0000000000..81c636e698 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc161.stderr-ghc @@ -0,0 +1,4 @@ + +tc161.hs:17:10: + Warning: No explicit method nor default method for `op' + In the instance declaration for `Foo Int' diff --git a/testsuite/tests/typecheck/should_compile/tc162.hs b/testsuite/tests/typecheck/should_compile/tc162.hs new file mode 100644 index 0000000000..91a3272a92 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc162.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Rank2Types #-} + +-- These ones failed with 5.04. They need a coercion +-- in the pattern matching compiler, so they are a bit +-- tricky. + +-- GHC 6.3: these are back to failures, because we no longer do +-- type subsumption in pattern-matching + +-- GHC 7.0: back to success + +module ShouldCompile where + +newtype Bug s a = Bug a + +runBug :: (forall s. Bug s a) -> a +runBug (Bug _) = undefined + +newtype BugN s a = BugN a + +runBugN :: (forall s. BugN s a) -> a +runBugN (BugN _) = undefined + +data Foo a b = Foo { foo :: a -> b } + +baz :: String -> (forall a b . Foo a b) -> IO () +baz s (Foo { foo = foo }) = putStrLn s diff --git a/testsuite/tests/typecheck/should_compile/tc162.stderr b/testsuite/tests/typecheck/should_compile/tc162.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc162.stderr diff --git a/testsuite/tests/typecheck/should_compile/tc163.hs b/testsuite/tests/typecheck/should_compile/tc163.hs new file mode 100644 index 0000000000..21d8a72949 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc163.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE RankNTypes #-} + +-- This one killed GHC 5.05 and earlier +-- The problem was in a newtype with a record selector, with +-- a polymorphic argument type. MkId generated a bogus selector +-- function + +module ShouldCompile where + +type M3 a = forall r. (forall b. M3' b -> (b -> M3' a) -> r) -> r + +newtype M3' a = M3' { mkM3' :: M3 a } + +flop :: forall a b. M3' b -> (b -> M3' a) -> Int +flop = \m' k -> mkM3' m' (\bm k1 -> error "urk") + +-- Suppose mkM3' has the straightforward type: +-- mkM3' :: forall a. M3' a -> M3 a +-- Then (mkM3' m') :: forall r. (forall b. ...) -> r +-- If we simply do a subsumption check of this against +-- alpha -> Int +-- where alpha is the type inferred for (\bm k1 ...) +-- this won't work. + +-- But if we give mkM3' the type +-- forall a r. M3' a -> (forall b. ...) -> r +-- everthing works fine. Very very delicate. + +---------------- A more complex case ------------- +bind :: M3 a -> (a -> M3 b) -> M3 b +bind m k b = b (M3' m) (\a -> M3' (k a)) + +observe :: M3 a -> a +observe m + = m (\m' k -> mkM3' m' + (\bm k1 -> observe (bind (mkM3' bm) + (\a -> bind (mkM3' (k1 a)) (\a -> mkM3' (k a))))) + ) + diff --git a/testsuite/tests/typecheck/should_compile/tc164.hs b/testsuite/tests/typecheck/should_compile/tc164.hs new file mode 100644 index 0000000000..ed6fa429aa --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc164.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ImplicitParams #-} + +module ShouldCompile where + +data UniqueSupply = US Integer + +newUnique :: (?uniqueSupply :: UniqueSupply) => Integer +newUnique = r + where US r = ?uniqueSupply + -- The lazy pattern match in the where clause killed GHC 5.04 + -- because the type {?uniqueSupply::UniqueSupply} of the RHS + -- of the 'where' didn't look like a UniqueSupply diff --git a/testsuite/tests/typecheck/should_compile/tc165.hs b/testsuite/tests/typecheck/should_compile/tc165.hs new file mode 100644 index 0000000000..ea2fa08ec1 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc165.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -dcore-lint #-} + +-- Fails GHC 5.04.2 with -dcore-lint +-- The issue ariseswhen you have a method that +-- constrains a class variable + +module Test where + +class C a where + f :: (Eq a) => a + +instance C () where + f = f + diff --git a/testsuite/tests/typecheck/should_compile/tc166.hs b/testsuite/tests/typecheck/should_compile/tc166.hs new file mode 100644 index 0000000000..2e69c3ad56 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc166.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + ExistentialQuantification, Rank2Types, + FlexibleInstances #-} + +-- Arguably, the type signature for f1 should be enough to make +-- this program compile, but in 5.04 it wasn't; the +-- extra sig in f2 was needed. +-- +-- This is a pretty borderline case. + +module ShouldCompile where + + class C t a b | t a -> b + instance C Char a Bool + + data P t a = forall b. (C t a b) => MkP b + + data Q t = MkQ (forall a. P t a) + + f1 :: Q Char + f1 = MkQ (MkP True) + + f2 :: Q Char + f2 = MkQ (MkP True :: forall a. P Char a) + diff --git a/testsuite/tests/typecheck/should_compile/tc167.hs b/testsuite/tests/typecheck/should_compile/tc167.hs new file mode 100644 index 0000000000..7a9f410d64 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc167.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE MagicHash #-} + +-- Type checking with unboxed kinds fails when (->) is used in a prefix way + +module ShouldSucceed where +import GHC.Base + +f :: (->) Int# Int# +f x = x + + +-- Here's the comment from TypeRep: +-- +-- funTyCon = mkFunTyCon funTyConName +-- (mkArrowKinds [liftedTypeKind, liftedTypeKind] +-- liftedTypeKind) +-- You might think that (->) should have type (? -> ? -> *), and you'd be right +-- But if we do that we get kind errors when saying +-- instance Control.Arrow (->) +-- becuase the expected kind is (*->*->*). The trouble is that the +-- expected/actual stuff in the unifier does not go contra-variant, whereas +-- the kind sub-typing does. Sigh. It really only matters if you use (->) in +-- a prefix way, thus: (->) Int# Int#. And this is unusual. diff --git a/testsuite/tests/typecheck/should_compile/tc168.hs b/testsuite/tests/typecheck/should_compile/tc168.hs new file mode 100644 index 0000000000..10b7fb9fb8 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc168.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- We want to get the type +-- g :: forall a b c. C a (b,c) => a -> b +--but GHC 6.0 bogusly gets +-- g :: forall a b. C a (b,()) => a -> b + +module ShouldCompile where + +class C a b where { op :: a -> b } + +f x = fst (op x) diff --git a/testsuite/tests/typecheck/should_compile/tc168.stderr b/testsuite/tests/typecheck/should_compile/tc168.stderr new file mode 100644 index 0000000000..3241e13415 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc168.stderr @@ -0,0 +1,7 @@ +TYPE SIGNATURES + f :: forall a b a1. C a1 (a, b) => a1 -> a +TYPE CONSTRUCTORS +COERCION AXIOMS + axiom ShouldCompile.NTCo:T:C [] :: ShouldCompile.T:C ~ (->) +Dependent modules: [] +Dependent packages: [base, ghc-prim, integer-gmp] diff --git a/testsuite/tests/typecheck/should_compile/tc169.hs b/testsuite/tests/typecheck/should_compile/tc169.hs new file mode 100644 index 0000000000..7cb9e001f5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc169.hs @@ -0,0 +1,27 @@ +-- This one briefly killed the new GHC 6.4 + +module Foo where + +newtype Foo x = Foo x +-- data Foo x = Foo x -- this works + +class X a where + x :: a -> IO () + +class X a => Y a where + y :: [a] -> IO () + +class Z z where + z :: Y c => z c -> IO () + +instance X Char where + x = putChar +instance X a => X (Foo a) where + x (Foo foo) = x foo + +instance Y Char where + y cs = mapM_ x cs + +instance Z Foo where + z = x + diff --git a/testsuite/tests/typecheck/should_compile/tc170.hs b/testsuite/tests/typecheck/should_compile/tc170.hs new file mode 100644 index 0000000000..9e649b307b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc170.hs @@ -0,0 +1,16 @@ +-- This test killed GHC 6.0.2 when it read the interface file for +-- Tc170_Aux, because there was a +-- forall a. (# ... #) +-- in the default method for 'position' +-- +-- NB: only fails when compiled in batch mode. In --make mode, GHC +-- doesn't read the interface file, so all is well. + +module ShouldCompile where + +import Tc170_Aux + +data Bitmap = Bitmap + +instance Dimensions Bitmap where + frame = error "urk"
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_compile/tc171.hs b/testsuite/tests/typecheck/should_compile/tc171.hs new file mode 100644 index 0000000000..a77b6f7fc5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc171.hs @@ -0,0 +1,12 @@ + +-- Data types with no constructors + +module ShouldCompile where + +data S +data T a + +f :: [T a] -> Int +f xs = length xs + + diff --git a/testsuite/tests/typecheck/should_compile/tc172.hs b/testsuite/tests/typecheck/should_compile/tc172.hs new file mode 100644 index 0000000000..f744fe43d5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc172.hs @@ -0,0 +1,11 @@ +module Test where + +class C s where + foo :: (Int -> Int) -> s -> s + +instance C Int where + foo = undefined --prevent warning + +bar _ = baz where + baz :: C s => s -> s + baz = foo baz diff --git a/testsuite/tests/typecheck/should_compile/tc174.hs b/testsuite/tests/typecheck/should_compile/tc174.hs new file mode 100644 index 0000000000..49f8d6aab5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc174.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE UnboxedTuples #-} + +module ShouldCompile where + +f x = (# x, x #) :: (# Int, Int #) diff --git a/testsuite/tests/typecheck/should_compile/tc175.hs b/testsuite/tests/typecheck/should_compile/tc175.hs new file mode 100644 index 0000000000..1631864d5c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc175.hs @@ -0,0 +1,15 @@ +-- See trac bug 179 + +-- Gives a bogus type error +-- No instance for (Show (t -> Bool)) +-- arising from use of `show' at tc175.hs:11:8-11 +-- In the definition of `foo': foo x = show (\ _ -> True) +-- because the instance decl has type variables with +-- kind *, whereas the constraint (Show (x -> Bool)) has x::?? +-- Kind of stupid, really, but awkward to fix. + +module ShouldCompile where + +instance Show (a->b) + +foo x = show (\ _ -> True) diff --git a/testsuite/tests/typecheck/should_compile/tc176.hs b/testsuite/tests/typecheck/should_compile/tc176.hs new file mode 100644 index 0000000000..d05ccdbe29 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc176.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleInstances, OverlappingInstances #-} + +{- With "hugs -98 +o test.hs" gives me: + ERROR "test.hs":8 - Cannot justify constraints in instance member binding + *** Expression : fromStr + *** Type : FromStr [a] => String -> [a] + *** Given context : FromStr [a] + *** Constraints : FromStr [a] + + Adding the constraint "FromStr a" to the declaration of fromStr fixes + the problem, but that seems like it should be redundant. Removing the + second instance (lines 10-11) also fixes the problem, interestingly enough. + + /Bjorn Bringert -} + +-- August 08: on reflection I think a complaint about overlapping +-- instances for line 8 is absolutely right, so I've changed this to +-- expected-failure + +-- Sept 08: on further reflection (!) I'm changing it back +-- See Note [Subtle interaction of recursion and overlap] +-- in TcInstDcls + +module ShouldCompile where + +class FromStr a where + fromStr :: String -> a + +typeError :: FromStr a => a -> a +typeError t = error "type error" + +instance FromStr [a] where + fromStr _ = typeError undefined -- line 8 + +instance FromStr [(String,a)] where -- line 10 + fromStr _ = typeError undefined -- line 11 diff --git a/testsuite/tests/typecheck/should_compile/tc177.hs b/testsuite/tests/typecheck/should_compile/tc177.hs new file mode 100644 index 0000000000..613528fef3 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc177.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances, + MultiParamTypeClasses, FunctionalDependencies #-} + +-- This is a rather complicated program that uses functional +-- dependencies to do Peano arithmetic. +-- +-- GHC 6.2 dies because tcSimplifyRestricted was trying to +-- be too clever. See 'Plan B' in tcSimplifyRestricted + +module ShouldCompile where + + + +-- This is the offending definition. It falls under +-- the monomorphism restriction, so tcSimplifyRestricted applies +bug = ins b (ins b Nil) + + +------------------------------------ +data LAB l r = LAB l r deriving Show + +data OR a b = OR a b deriving Show + + +data Cons x y = Cons x y deriving Show + +data Nil = Nil deriving Show + +data T = T + +data F = F + +data A = A deriving Show + +data B = B deriving Show + +data Zero = Zero + +data Succ n = Succ n + +b = ((LAB B []),[]) + +-- insertion function +-- insert label pairs in the a list of list, each list contains a collection of +-- label pair that sharing the common label. + + +class Ins r l l' | r l -> l' where + ins :: r -> l -> l' + + +instance Ins ((LAB l1 r1),r1') Nil (Cons (Cons ((LAB l1 r1),r1') Nil) Nil) where + ins l Nil = (Cons (Cons l Nil) Nil) + + +instance ( L2N l1 n1 + , L2N l2 n2 + , EqR n1 n2 b + , Ins1 ((LAB l1 r1),r1') (Cons (Cons ((LAB l2 r2),r2') rs) rs') b l + ) => Ins ((LAB l1 r1),r1') (Cons (Cons ((LAB l2 r2),r2') rs) rs') l + where + ins ((LAB l1 r1),r1') (Cons (Cons ((LAB l2 r2),r2') rs) rs') + = ins1 ((LAB l1 r1),r1') (Cons (Cons ((LAB l2 r2),r2') rs) rs') + (eqR (l2n l1) (l2n l2)) +-- Note that n1 and n2 are functionally defined by l1 and l2, respectively, +-- and b is functionally defined by n1 and n2. + + +class Ins1 r l b l' | r l b -> l' where + ins1 :: r -> l -> b -> l' + +instance Ins1 ((LAB l1 r1),r1') (Cons r rs) T + (Cons (Cons ((LAB l1 r1),r1') r) rs) where + ins1 l (Cons r rs) _ = (Cons (Cons l r) rs) + +instance ( Ins ((LAB l1 r1),r1') rs rs') + => Ins1 ((LAB l1 r1),r1') (Cons r rs) F (Cons r rs') where + ins1 l (Cons r rs) _ = (Cons r (ins l rs)) + +-- class for mapping label to number + +class L2N l n | l -> n where + l2n :: l -> n + +instance L2N A Zero where + l2n A = Zero + +instance L2N B (Succ Zero) where + l2n B = Succ Zero + + +-- class for comparing number type + +class EqR n1 n2 b | n1 n2 -> b where + eqR :: n1 -> n2 -> b + +instance EqR Zero Zero T where + eqR _ _ = T + +instance EqR Zero (Succ n) F where + eqR _ _ = F + +instance EqR (Succ n) Zero F where + eqR _ _ = F + +instance (EqR n1 n2 b) => EqR (Succ n1) (Succ n2) b where + eqR (Succ n1) (Succ n2) = eqR n1 n2 + diff --git a/testsuite/tests/typecheck/should_compile/tc178.hs b/testsuite/tests/typecheck/should_compile/tc178.hs new file mode 100644 index 0000000000..2a181208d4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc178.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleInstances #-} + +-- This one tickled the kind-check in TcType.matchTys, +-- which should use sub-kinding + +module ShouldCompile where + +type TypeRep = () + +class Typeable2 t where + typeOf2 :: t a b -> TypeRep + +class Typeable1 t where + typeOf1 :: t a -> TypeRep + +class Typeable0 a where + typeOf0 :: a -> TypeRep + +instance Typeable2 (->) where + typeOf2 = undefined + +instance (Typeable2 t, Typeable0 a) => Typeable1 (t a) where + typeOf1 = undefined + +instance (Typeable1 t, Typeable0 a) => Typeable0 (t a) where + typeOf0 = undefined + +class Typeable0 a => Data0 a where + dataTypeOf0 :: a -> Bool + +instance (Data0 a, Data0 b) => Data0 (a -> b) where + dataTypeOf0 = undefined + +foo :: (Typeable0 a, Typeable0 b) => (a -> b) -> TypeRep +foo f = typeOf0 f diff --git a/testsuite/tests/typecheck/should_compile/tc179.hs b/testsuite/tests/typecheck/should_compile/tc179.hs new file mode 100644 index 0000000000..110950587d --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc179.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ExistentialQuantification, FlexibleInstances, + OverlappingInstances, UndecidableInstances #-} + +-- Tests context reduction for existentials + +module TestWrappedNode where + +class Foo a where { op :: a -> Int } + +instance Foo a => Foo [a] where -- NB overlap + op (x:xs) = op x +instance Foo [Int] where -- NB overlap + op x = 1 + +data T = forall a. Foo a => MkT a + +f :: T -> Int +f (MkT x) = op [x,x] + -- The op [x,x] means we need (Foo [a]). We used to + -- complain, saying that the choice of instance depended on + -- the instantiation of 'a'; but of course it isn't *going* + -- to be instantiated. + diff --git a/testsuite/tests/typecheck/should_compile/tc180.hs b/testsuite/tests/typecheck/should_compile/tc180.hs new file mode 100644 index 0000000000..1a404ad5de --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc180.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, UndecidableInstances #-} + +-- This tests an aspect of functional dependencies, revealing a bug in GHC 6.0.1 +-- discovered by Martin Sulzmann + + +module ShouldCompile where + +data PHI = PHI +data EMPT = EMPT +data LAB l a = LAB l a +data Phi = Phi + +data A = A +data A_H = A_H [Char] + + +class LNFyV r1 r2 h1 h2 | r1 -> r2, r1 r2 -> h1 h2 where + lnfyv :: r1->r2->h1->h2 + +instance ( REtoHT (LAB l c) h) + => LNFyV (LAB l c) ((LAB l c),EMPT) h (h,[Phi]) where -- (L2) + lnfyv = error "urk" + +class REtoHT s t | s->t +instance REtoHT (LAB A [Char]) A_H -- (R4) + +foo = lnfyv (LAB A "") ((LAB A ""),EMPT) (A_H "1") + + +{- +ghci 6.0.1 + +*Test> :t (lnfyv (LAB A "") ((LAB A ""),EMPT) (A_H "1") ) + +No instance for (LNFyV (LAB A [Char]) + (LAB A [Char], EMPT) + A_H + (h, [Phi])) + arising from use of `lnfyv' at <No locn> + + +hugs November 2002 + +Test> :t (lnfyv (LAB A "") ((LAB A ""),EMPT) (A_H "1")) +lnfyv (LAB A "") (LAB A "",EMPT) (A_H "1") :: (A_H,[Phi]) + + +hugs is right, here's why + + +(lnfyv (LAB A "") ((LAB A ""),EMPT) (A_H "1")) yields + + + LNFyV (LAB A Char) ((LAB A Char),EMPT) (A_H) c + +improve by (L2) LNFyV (LAB A Char) ((LAB A Char),EMPT) (A_H) (A_H,[Phi]), c=(A_H,[Phi]) +reduce by (L2) REtoHT (LAB A Char) A_H, c=(A_H,[Phi]) +reduce by (R4) c=(A_H,[Phi]) + + +-} diff --git a/testsuite/tests/typecheck/should_compile/tc181.hs b/testsuite/tests/typecheck/should_compile/tc181.hs new file mode 100644 index 0000000000..6ccf6b90de --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc181.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, FlexibleContexts, UndecidableInstances #-} + +-- Example of improvement, due to George Russel + +module Folders where + +data Folder = Folder + +newtype SB x = SB x +newtype SS x = SS x + +data NodeArcsHidden = NodeArcsHidden + +class HasSS hasS x | hasS -> x where + toSS :: hasS -> SS x + +instance HasSS (SB x) x where + toSS (SB x) = (SS x) + +class HMV option graph node where + modd :: option -> graph -> node value -> IO () + +instance HMV NodeArcsHidden graph node + => HMV (Maybe NodeArcsHidden) graph node + where + modd = error "burk" + +gn :: HMV NodeArcsHidden graph node + => graph + -> SS (graph -> node Int -> IO ()) +gn graph = fmapSS (\ arcsHidden -> (\ graph node -> modd arcsHidden graph node)) + (toSS (error "C" :: SB (Maybe NodeArcsHidden))) + +-- The call to modd gives rise to +-- HMV option graph node +-- The call to toSS gives rise to +-- HasSS (SB (Maybe NodeArcsHidden)) x +-- where (toSS (error ...)) :: SS x +-- and hence arcsHidden :: x +-- +-- Then improvement should give x = Maybe NodeArcsHidden +-- and hence option=Maybe NodeArcsHidden + +fmapSS :: (a->b) -> SS a -> SS b +fmapSS = error "urk" diff --git a/testsuite/tests/typecheck/should_compile/tc182.hs b/testsuite/tests/typecheck/should_compile/tc182.hs new file mode 100644 index 0000000000..f6e9164f47 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc182.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DatatypeContexts, ExistentialQuantification #-} + +-- Tests the "stupid theta" in pattern-matching +-- when there's an existential as well + +module ShouldCompile where + +data (Show a) => Obs a = forall b. LiftObs a b + +f :: Show a => Obs a -> String +f (LiftObs _ _) = "yes" + + diff --git a/testsuite/tests/typecheck/should_compile/tc182.stderr b/testsuite/tests/typecheck/should_compile/tc182.stderr new file mode 100644 index 0000000000..bd8397708b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc182.stderr @@ -0,0 +1,3 @@ + +tc182.hs:1:14: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. diff --git a/testsuite/tests/typecheck/should_compile/tc183.hs b/testsuite/tests/typecheck/should_compile/tc183.hs new file mode 100644 index 0000000000..5015af3c91 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc183.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ExistentialQuantification, Rank2Types #-} + +-- An interesting interaction of universals and existentials, prompted by +-- http://www.haskell.org/pipermail/haskell-cafe/2004-October/007160.html +-- +-- Note the non-nested pattern-match in runProg; tcfail126 checks the +-- nested pattern match + +module Foo where + +import Control.Monad.Trans + +data Bar m + = forall t. (MonadTrans t, Monad (t m)) + => Bar (t m () -> m ()) (t m Int) + +data Foo = Foo (forall m. Monad m => Bar m) + +runProg :: Foo -> IO () +runProg (Foo b) = case b of + Bar run op -> run (prog op) + -- You can't say runProg (Foo (Bar run op)); + -- see tcfail126 + +prog :: (MonadTrans t, Monad (t IO)) => a -> t IO () +prog x = error "urk" diff --git a/testsuite/tests/typecheck/should_compile/tc184.hs b/testsuite/tests/typecheck/should_compile/tc184.hs new file mode 100644 index 0000000000..2ab4b42cdd --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc184.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE ImplicitParams, ExistentialQuantification #-} + +-- Both these two fail in 6.2.2 + +module ShouldCompile where + + +-- A record with an 'existential' context that binds no +-- type vars, so record selectors should be OK +data Test1 = (?val::Bool) => Test1 { name :: String } + +instance Show Test1 where + show p = name p + + +-- Same, but no record selector; GHC 6.2.2 failed because it tried +-- to derive generic to/from +data Test2 = (?val::Bool) => Test2 String +f (Test2 s) | ?val = s diff --git a/testsuite/tests/typecheck/should_compile/tc185.hs b/testsuite/tests/typecheck/should_compile/tc185.hs new file mode 100644 index 0000000000..e06550f63b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc185.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MagicHash, BangPatterns #-} + +-- Killed GHC 6.3 HEAD + +module Bug where +import GHC.Base + +foo v = let !(I# x#) = 7 * 7 in "Forty-Two"
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_compile/tc186.hs b/testsuite/tests/typecheck/should_compile/tc186.hs new file mode 100644 index 0000000000..79bd42e861 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc186.hs @@ -0,0 +1,16 @@ + +-- Killed 6.2.2 +-- The trouble was that 1 was instantiated to a type (t::?) +-- and the constraint (Foo (t::? -> s::*)) didn't match Foo (a::* -> b::*). +-- Solution is to zap the expected type in TcEpxr.tc_expr(HsOverLit). + +module ShoudlCompile where + +class Foo a where + foo :: a + +instance Foo (a -> b) where + foo = error "urk" + +test :: () +test = foo 1 diff --git a/testsuite/tests/typecheck/should_compile/tc187.hs b/testsuite/tests/typecheck/should_compile/tc187.hs new file mode 100644 index 0000000000..15946f8a50 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc187.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE UndecidableInstances, FlexibleInstances, + MultiParamTypeClasses, FunctionalDependencies #-} +-- UndecidableInstances now needed because the Coverage Condition fails + +-- Hugs failed this functional-dependency test +-- Reported by Iavor Diatchki Feb 05 + +module ShouldCompile where + +data N0 +newtype Succ n = Succ n + +class Plus a b c | a b -> c +instance Plus N0 n n +instance Plus a b c => Plus (Succ a) b (Succ c) + +( # ) :: Plus x y z => x -> y -> z +( # ) = undefined + +class BitRep t n | t -> n where + toBits :: t -> n + +instance BitRep Bool (Succ N0) where + toBits = error "urk" + +instance BitRep (Bool,Bool,Bool) (Succ (Succ (Succ N0))) where + toBits (x,y,z) = toBits x # toBits y # toBits z + +-- Hugs complains that it cannot solve the constraint: +-- Plus (Succ N0) (Succ N0) (Succ (Succ N0)) + diff --git a/testsuite/tests/typecheck/should_compile/tc188.hs b/testsuite/tests/typecheck/should_compile/tc188.hs new file mode 100644 index 0000000000..eaf3690ef1 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc188.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses, LiberalTypeSynonyms #-} + +-- Test infix type constructors for type synonyms + +module ShouldCompile where + +infix 9 :-+-: +type (f :-+-: g) t o1 o2 = Either (f t o1 o2) (g t o1 o2) + +data Foo a b c = Foo (a,b,c) + +type App f = f Int Bool Int + +f :: (Foo :-+-: Foo) Bool Int Bool +f = error "urk" + +g :: App (Foo :-+-: Foo) +g = error "urk" + +-------- classes -------- + +class (Eq a, Eq b) => a :&: b where + op :: a -> b + +h :: (a :&: b) => a -> b +h x = op x diff --git a/testsuite/tests/typecheck/should_compile/tc189.hs b/testsuite/tests/typecheck/should_compile/tc189.hs new file mode 100644 index 0000000000..3f9a2879b0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc189.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE NoMonoPatBinds #-} + -- Disable experimetal monomorphic pattern bindings + +-- Nasty test for type signatures +-- In both groups of declarations below, the type variables 'a' and 'b' +-- end up being unified together. + +module ShouldCompile where + +------------- + x :: a + x = z `asTypeOf` y + + y :: b + y = z + + z = x +------------- + p :: [a] + q :: b + (p,q,r) = ([q,r], r, head p) + +------------- + t :: a + u :: b + (t,u,v) = (v,v,t) diff --git a/testsuite/tests/typecheck/should_compile/tc190.hs b/testsuite/tests/typecheck/should_compile/tc190.hs new file mode 100644 index 0000000000..97413c7177 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc190.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP, KindSignatures #-} +
+-- The record update triggered a kind error in GHC 6.2
+
+module Foo where
+
+data HT (ref :: * -> *)
+ = HT { kcount :: Int }
+
+set_kcount :: Int -> HT s -> HT s
+set_kcount kc ht = ht{kcount=kc}
diff --git a/testsuite/tests/typecheck/should_compile/tc191.hs b/testsuite/tests/typecheck/should_compile/tc191.hs new file mode 100644 index 0000000000..cf77c0505a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc191.hs @@ -0,0 +1,29 @@ + + +-- This only typechecks if forall-hoisting works ok when +-- importing from an interface file. The type of Twins.gzipWithQ +-- is this: +-- type GenericQ r = forall a. Data a => a -> r +-- gzipWithQ :: GenericQ (GenericQ r) -> GenericQ (GenericQ [r]) +-- It's kept this way in the interface file for brevity and documentation, +-- but when the type synonym is expanded, the foralls need expanding + +module Foo where + +import Data.Generics.Basics +import Data.Generics.Aliases +import Data.Generics.Twins(gzipWithQ) + +-- | Generic equality: an alternative to \deriving Eq\ +geq :: Data a => a -> a -> Bool +geq x y = geq' x y + where +-- This type signature no longer works, because it is +-- insufficiently polymoprhic. +-- geq' :: forall a b. (Data a, Data b) => a -> b -> Bool + geq' :: GenericQ (GenericQ Bool) + geq' x y = (toConstr x == toConstr y) + && and (gzipWithQ geq' x y) + + + diff --git a/testsuite/tests/typecheck/should_compile/tc192.hs b/testsuite/tests/typecheck/should_compile/tc192.hs new file mode 100644 index 0000000000..3337954ade --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc192.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE Arrows, CPP, TypeOperators #-} + +-- Test infix type notation and arrow notation + +module Test where + +import Prelude hiding (id,(.)) +import Control.Category +import Control.Arrow + +-- For readability, I use infix notation for arrow types. I'd prefer the +-- following, but GHC doesn't allow operators like "-=>" as type +-- variables. +-- +-- comp1 :: Arrow (-=>) => b-=>c -> c-=>d -> b-=>d + + +comp1 :: Arrow (~>) => b~>c -> c~>d -> b~>d +comp1 f g = proc x -> do + b <- f -< x + g -< b + +-- arrowp produces +-- comp1 f g = (f >>> g) + +comp :: Arrow (~>) => (b~>c, c~>d)~>(b~>d) +comp = arr (uncurry (>>>)) + +-- app :: Arrow (~>) => (b c, b)~>c + +type R = Float +type I = Int + +z1,z2 :: Arrow (~>) => I~>(R~>R) +z1 = undefined +z2 = z1 + +z3 :: Arrow (~>) => (I,I)~>(R~>R,R~>R) +z3 = z1 *** z2 + +z4 :: Arrow (~>) => (I,I)~>(R~>R) +z4 = z3 >>> comp + +comp4,comp5 :: Arrow (~>) => + b~>(c~>d) -> e~>(d~>f) -> (b,e)~>(c~>f) + +comp4 g f = proc (b,e) -> do + g' <- g -< b + f' <- f -< e + returnA -< (g' >>> f') + +comp5 g f = (g *** f) >>> comp + +lam,lam2 :: Arrow (~>) => (e,b)~>c -> e~>(b~>c) + +lam f = arr $ \ e -> arr (pair e) >>> f + +pair a b = (a,b) + +-- I got the definition lam above by starting with + +lam2 f = proc e -> + returnA -< (proc b -> do + c <- f -< (e,b) + returnA -< c) + +-- I desugared with the arrows preprocessor, removed extra parens and +-- renamed "arr" (~>) "pure", (~>) get +-- +-- lam f = pure (\ e -> pure (\ b -> (e, b)) >>> f) + +-- Note that lam is arrow curry + +-- curry :: ((e,b) -> c) -> (e -> b -> c) + +-- All equivalent: + +curry1 f e b = f (e,b) + +curry2 f = \ e -> \ b -> f (e,b) + +curry3 f = \ e -> f . (\ b -> (e,b)) + +curry4 f = \ e -> f . (pair e) + + + +comp6 :: Arrow (~>) => b~>(c~>d) -> e~>(d~>f) + -> b~>(e~>(c~>f)) +comp6 g f = lam $ comp5 g f + +-- What about uncurrying? + +-- uncurryA :: Arrow (~>) => b~>(c~>d) +-- -> (b,c)~>d +-- uncurryA f = proc (b,c) -> do +-- f' <- f -< b +-- returnA -< f' c + +-- Why "lam" instead of "curryA" (good name also): so I can use Arrows +-- lambda notation, similar (~>) + +compF g f = \ b e -> g b . f e + +-- But I haven't figured out how (~>). + +-- comp7 :: Arrow (~>) => b~>(c~>d) -> e~>(d~>f) +-- -> b~>(e~>(c~>f)) +-- comp7 g f = proc b -> proc e -> do +-- g' <- g -< b +-- f' <- f -< e +-- returnA -< (g' >>> f') + +-- Try "(| lam \ b -> ... |)" in the FOP arrows chapter +-- cmd ::= form exp cmd1 ... cmdn. Parens if nec + +-- (| lam (\ b -> undefined) |) + +-- Oh! The arrow syntax allows bindings with *infix* operators. And I +-- don't know how (~>) finish comp7. + +-- Uncurried forms: + +comp8 :: Arrow (~>) => (b,c)~>d -> (e,d)~>k -> (b,c,e)~>k +comp8 g f = proc (b,c,e) -> do + d <- g -< (b,c) + f -< (e,d) + +-- This looks like straightforward~>translation. With insertions of +-- curry & uncurry operators, it'd probably be easy (~>) handle curried +-- definitions as well. + +-- Simpler example, for experimentation + +comp9 :: Arrow (~>) => (c,d)~>e -> b~>d -> (b,c)~>e +comp9 g f = proc (b,c) -> do + d <- f -< b + g -< (c,d) + +-- Desugared: + +comp9' :: Arrow (~>) => (c,d)~>e -> b~>d -> (b,c)~>e +comp9' g f = first f >>> arr (\ (d,c) -> (c,d)) >>> g + + diff --git a/testsuite/tests/typecheck/should_compile/tc193.hs b/testsuite/tests/typecheck/should_compile/tc193.hs new file mode 100644 index 0000000000..54d970ebeb --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc193.hs @@ -0,0 +1,16 @@ + +-- A newtype representation problem crashed GHC 6.4 + +module ShouldCompile where + + +newtype Signal a = Signal Symbol + +newtype Symbol = Symbol (S Symbol) + +data S s = Bool Bool + +liftl :: Signal a -> Symbol +liftl (Signal a) = a + + diff --git a/testsuite/tests/typecheck/should_compile/tc194.hs b/testsuite/tests/typecheck/should_compile/tc194.hs new file mode 100644 index 0000000000..07b0ed4f02 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc194.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} + +-- Tests the special case of +-- non-recursive, function binding, +-- with no type signature + +module ShouldCompile where + +f = \ (x :: forall a. a->a) -> (x True, x 'c') + diff --git a/testsuite/tests/typecheck/should_compile/tc195.hs b/testsuite/tests/typecheck/should_compile/tc195.hs new file mode 100644 index 0000000000..8eacf024ca --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc195.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, TypeSynonymInstances #-} + +-- This one made GHC 6.4 loop becuause Unify.unify +-- didn't deal correctly with unifying +-- a :=: Foo a +-- where +-- type Foo a = a + +module ShouldSucceed where + +newtype PRef a = PRef a +type Drop1 a = a +class Ref a r | a -> r where readRef :: a -> r +instance Ref (PRef a) (Drop1 a) where readRef (PRef v) = v + + + diff --git a/testsuite/tests/typecheck/should_compile/tc196.hs b/testsuite/tests/typecheck/should_compile/tc196.hs new file mode 100644 index 0000000000..c34d5e7e9c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc196.hs @@ -0,0 +1,18 @@ + +-- Test the refined dependency analysis of bindings +-- with -fglagow-exts + +module ShouldCompile where + + f1 :: Eq a => a -> Bool + f1 x = (x == x) || g1 True + + g1 :: Ord a => a -> Bool + g1 y = (y <= y) || f1 True + +--------- + + f2 :: Eq a => a -> Bool + f2 x = (x == x) || g2 True || g2 "Yes" + + g2 y = (y <= y) || f2 True diff --git a/testsuite/tests/typecheck/should_compile/tc197.hs b/testsuite/tests/typecheck/should_compile/tc197.hs new file mode 100644 index 0000000000..40b9aeca7e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc197.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, FlexibleContexts #-} + +-- Another dependency analysis test +-- Notice that 'a' and 'b' are mutually recursive, +-- but have different contexts. +-- +-- This is the program submitted by Robert van Herk [rherk@cs.uu.nl] +-- to motivate the refined dependency analysis. + +module ShouldCompile where +import Data.IORef + +class MyReader r v | r -> v where + myRead :: r -> IO v + +data R v = R (IORef v) +instance MyReader (R v) v where + myRead (R v) = + do v <- readIORef v + return v + + +a :: IO () +a = + do r <- createReader + b r + +b :: MyReader r Int => r -> IO () +b r = + do i <- myRead r + if i > 10 + then a + else putStrLn (show i) + +createReader :: IO (R Int) +createReader = + do ref <- newIORef 0 + return (R ref) + diff --git a/testsuite/tests/typecheck/should_compile/tc198.hs b/testsuite/tests/typecheck/should_compile/tc198.hs new file mode 100644 index 0000000000..e931ac5cb8 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc198.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} + +-- This should work, because the type sig and the type +-- in the pattern match exactly + +module Foo where + +foo :: (forall a. a -> b) -> b +foo (f :: forall a. a -> b) = f undefined :: b diff --git a/testsuite/tests/typecheck/should_compile/tc199.hs b/testsuite/tests/typecheck/should_compile/tc199.hs new file mode 100644 index 0000000000..d530cfd6d0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc199.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- This code defines a default method with a highly dubious type, +-- because 'v' is not mentioned, and there are no fundeps +-- +-- However, arguably the instance declaration should be accepted, +-- beause it's equivalent to +-- instance Baz Int Int where { foo x = x } +-- which *does* typecheck + +-- GHC does not actually macro-expand the instance decl. Instead, it +-- defines a default method function, thus +-- +-- $dmfoo :: Baz v x => x -> x +-- $dmfoo y = y +-- +-- Notice that this is an ambiguous type: you can't call $dmfoo +-- without triggering an error. And when you write an instance decl, +-- it calls the default method: +-- +-- instance Baz Int Int where foo = $dmfoo +-- +-- I'd never thought of that. You might think that we should just +-- *infer* the type of the default method (here forall a. a->a), but +-- in the presence of higher rank types etc we can't necessarily do +-- that. + +module Foo1 where + +class Baz v x where + foo :: x -> x + foo y = y + +instance Baz Int Int diff --git a/testsuite/tests/typecheck/should_compile/tc200.hs b/testsuite/tests/typecheck/should_compile/tc200.hs new file mode 100644 index 0000000000..bb6a00e1ae --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc200.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -w #-} + +-- A nasty case that crashed GHC 6.4 with a Lint error; +-- see Note [Multiple instantiation] in TcExpr + +module ShouldCompile where + +class C a where + foo :: Eq b => b -> a -> Int + baz :: Eq a => Int -> a -> Int + +instance C Int where + baz = foo diff --git a/testsuite/tests/typecheck/should_compile/tc201.hs b/testsuite/tests/typecheck/should_compile/tc201.hs new file mode 100644 index 0000000000..c60aa85406 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc201.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + ExistentialQuantification, FlexibleContexts #-} + +{- Email 30 Jan 2006 + +> the attached program compiles under GHC, but not with Hugs. as far as +> i see, Hugs don't use dependencies in class headers to figure out that +> there is only one "vMkIOError" that can be called in the last +> definition + +OK, I think it's a bug (though the example is bizarre). Sadly Hugs's +support for FDs is rough around the edges (and unlikely to improve +soon). + +-} + +module ShoudlCompile where + + class (Monad m) => Stream m h | h->m where + vMkIOError :: h -> Int + + data BinHandle = forall h . Stream IO h => BinH h + + instance Stream IO BinHandle where + vMkIOError (BinH h) = vMkIOError h diff --git a/testsuite/tests/typecheck/should_compile/tc202.hs b/testsuite/tests/typecheck/should_compile/tc202.hs new file mode 100644 index 0000000000..7280606388 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc202.hs @@ -0,0 +1,8 @@ + +-- Tests that subFunTys works when the arugment is a type of form (a ty1 ty2) + +module ShouldCompile where + +newtype StreamArrow a b c = Str (a [b] [c]) + +foo = Str $ (\x -> x) diff --git a/testsuite/tests/typecheck/should_compile/tc203.hs b/testsuite/tests/typecheck/should_compile/tc203.hs new file mode 100644 index 0000000000..2579896458 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc203.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Rank2Types #-} + +-- Check that we can have a forall after a forall + +module Foo4 where + +type AnyE a = forall err. Either err a + +foo :: Monad m => AnyE (m t) +foo = undefined diff --git a/testsuite/tests/typecheck/should_compile/tc204.hs b/testsuite/tests/typecheck/should_compile/tc204.hs new file mode 100644 index 0000000000..d95fe86480 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc204.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE ImplicitParams #-} +{-# OPTIONS -dcore-lint #-}
+
+-- The dict-bindings attached to an IPBinds
+-- need not be in recursive order. This is
+-- a long-standing bug, which lasted up to
+-- and including GHC 6.4.2
+
+module Bug795(foo) where
+
+data Arg = E Integer | T Bool deriving (Eq, Show)
+
+foo :: Integer -> [Arg] -> IO String
+foo 1 as = do { let ?err = "my custom error"
+ ; let ws = (show (firstE as))
+ ; return (show (firstE as)) }
+
+firstE :: (?err :: String) => [Arg] -> Integer
+firstE = error "urk"
diff --git a/testsuite/tests/typecheck/should_compile/tc205.hs b/testsuite/tests/typecheck/should_compile/tc205.hs new file mode 100644 index 0000000000..621061a3de --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc205.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeOperators, GADTs, KindSignatures #-} + +-- Tests infix type constructors in GADT declarations + +module ShouldCompile where + +infix 1 `DArrowX` -- (->) has precedence 0 + +data DArrowX :: * -> * -> * where + First :: a `DArrowX` a' -> (a,b) `DArrowX` (a',b) diff --git a/testsuite/tests/typecheck/should_compile/tc206.hs b/testsuite/tests/typecheck/should_compile/tc206.hs new file mode 100644 index 0000000000..c54618950a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc206.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Rank2Types #-} + +-- This one showed up a bug in pre-subsumption + +module ShouldCompile where + +class Data a where {} + +type GenericQ r = forall a. Data a => a -> r + +everything :: (r -> r -> r) -> GenericQ r +everything k f = error "urk" + + +-- | Get a list of all entities that meet a predicate +listify :: (r -> Bool) -> GenericQ [r] +listify p = everything (++) diff --git a/testsuite/tests/typecheck/should_compile/tc207.hs b/testsuite/tests/typecheck/should_compile/tc207.hs new file mode 100644 index 0000000000..a5b952176b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc207.hs @@ -0,0 +1,16 @@ + +-- Tests enhanced polymorphism + +module ShouldCompile where + +foo xs = let + f :: Eq a => [a] -> [a] + f [] = [] + f xs | null (g [True]) = [] + | otherwise = tail (g xs) + + g :: Eq b => [b] -> [b] + g [] = [] + g xs | null (f "hello") = [] + | otherwise = tail (f xs) + in f xs diff --git a/testsuite/tests/typecheck/should_compile/tc208.hs b/testsuite/tests/typecheck/should_compile/tc208.hs new file mode 100644 index 0000000000..0bfb1d4e81 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc208.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ImplicitParams, Rank2Types #-} + +-- This program failed to typecheck in an early version of +-- GHC with impredicative polymorphism, but it was fixed by +-- doing pre-subsumption in the subsumption check. +-- Trac bug #821 + +module ShouldCompile where + +type PPDoc = (?env :: Int) => Char + +f :: Char -> PPDoc +f = succ diff --git a/testsuite/tests/typecheck/should_compile/tc209.hs b/testsuite/tests/typecheck/should_compile/tc209.hs new file mode 100644 index 0000000000..b2073a5993 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc209.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE UnboxedTuples #-} + +-- Unboxed tuples; cf tcfail115, tcfail120 + +module ShouldFail where + +type T a = Int -> (# Int, Int #) + +-- Should be ok +h t = \x -> case t x of (# r, s #) -> r + diff --git a/testsuite/tests/typecheck/should_compile/tc210.hs b/testsuite/tests/typecheck/should_compile/tc210.hs new file mode 100644 index 0000000000..a2cc717122 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc210.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Rank2Types #-} + +module ShouldCompile where + +f :: forall a. a -> forall b. b -> Int +f = error "urk" + +-- Both these should be ok, but an early GHC 6.6 failed + +g1 = [ (+) :: Int -> Int -> Int, f ] +g2 = [ f, (+) :: Int -> Int -> Int ] + diff --git a/testsuite/tests/typecheck/should_compile/tc211.hs b/testsuite/tests/typecheck/should_compile/tc211.hs new file mode 100644 index 0000000000..5bd5c34821 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc211.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags -XScopedTypeVariables -XGADTs #-} + +-- Here are a bunch of tests for impredicative polymorphism +-- mainly written by Dimitrios + +module ShouldCompile where + +xs :: [forall a. a->a] +xs = [\x -> x] + +foo = id xs + +-- Annotation resolves impredicative instantiation +bar = ((:)::(forall a.a ->a) -> [forall a. a->a] -> [forall a. a ->a]) + (head foo) foo + +-- result type resolves everything! really neat +barr :: [forall a. a -> a] +barr = (head foo):(tail foo) + +zoo = tail xs +zooo = head xs + +-- This is the only unsatisfactory case...annotating +-- one of the arguments does not do the job...but maybe +-- this is reasonable to expect ... +-- bar3 = ((head foo) :: forall a. a ->a) : foo + +data Pair a b where + P :: a -> b -> Pair a b + +data List a where + Nil :: List a + Cons :: a -> List a -> List a +-- FromMono :: (a->a) -> List (forall a. a->a) +-- This constructor looks utterly bogus, so +-- I'm commenting it out; SLPJ 7 Jan 08 + +f :: Int -> Pair Int Int +f x = P x x + +h0 :: (forall a. a -> a) -> Int +h0 g = let y = P (g 3) (g (P 3 4)) + in 3 + + +h1 (g::(forall a. a ->a)) + = let y = P (g 3) (g (P 3 4)) + in 3 + +h2 :: (forall a. a -> a) -> Int +h2 (g::(forall a. a ->a)) = let y = P (g 3) (g (P 3 4)) + in 3 + +xs1 :: List (forall a. a ->a) +xs1 = let cons = Cons :: (forall a. a ->a) + -> List (forall a. a->a) + -> List (forall a. a ->a) + in cons (\x -> x) Nil + +xs2 :: List (forall a. a -> a) +xs2 = (Cons :: ((forall a. a->a) + -> List (forall a. a->a) + -> List (forall a. a->a))) + (\x ->x) Nil + +foo2 :: forall a. List a -> a -> a +foo2 x y = y + +bar4 = (foo2 :: List (forall a. a->a) -> (forall a. a->a) -> (forall a.a->a)) + xs1 (\x -> x) + + diff --git a/testsuite/tests/typecheck/should_compile/tc211.stderr b/testsuite/tests/typecheck/should_compile/tc211.stderr new file mode 100644 index 0000000000..30d986c456 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc211.stderr @@ -0,0 +1,30 @@ + +tc211.hs:15:22: + Couldn't match expected type `a -> a' + with actual type `forall a1. a1 -> a1' + Expected type: [a -> a] + Actual type: [forall a1. a1 -> a1] + In the first argument of `head', namely `foo' + In the first argument of `(:) :: + (forall a. a -> a) + -> [forall a. a -> a] -> [forall a. a -> a]', namely + `(head foo)' + +tc211.hs:70:9: + Couldn't match expected type `a -> a' + with actual type `forall a1. a1 -> a1' + Expected type: List (forall a1. a1 -> a1) + -> (forall a1. a1 -> a1) + -> a + -> a + Actual type: List (forall a1. a1 -> a1) + -> (forall a1. a1 -> a1) + -> forall a1. a1 -> a1 + In the expression: + foo2 :: + List (forall a. a -> a) -> (forall a. a -> a) -> (forall a. a -> a) + In the expression: + (foo2 :: + List (forall a. a -> a) + -> (forall a. a -> a) -> (forall a. a -> a)) + xs1 (\ x -> x) diff --git a/testsuite/tests/typecheck/should_compile/tc212.hs b/testsuite/tests/typecheck/should_compile/tc212.hs new file mode 100644 index 0000000000..ad408fbdaf --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc212.hs @@ -0,0 +1,8 @@ + +-- This one crashed the 6.6 release candidate + +module ShouldCompile where + +-- A specialise pragma with no type signature +fac n = fac (n + 1) +{-# SPECIALISE fac :: Int -> Int #-} diff --git a/testsuite/tests/typecheck/should_compile/tc213.hs b/testsuite/tests/typecheck/should_compile/tc213.hs new file mode 100644 index 0000000000..e9e3069e7b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc213.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE Rank2Types, ScopedTypeVariables, FlexibleInstances, + MultiParamTypeClasses, FunctionalDependencies #-} + +-- This tests scoped type variables, used in an expression +-- type signature in t1 and t2 + +module Foo7 where +import Control.Monad +import Control.Monad.ST +import Data.Array.MArray +import Data.Array.ST +import Data.STRef +import Data.Set hiding (map,filter) + +-- a store that allows to mark keys +class Mark m store key | store -> key m where + new :: (key,key) -> m store + mark :: store -> key -> m () + markQ :: store -> key -> m Bool + seen :: store -> m [ key ] + +-- implementation 1 +instance Ord key => Mark (ST s) (STRef s (Set key)) key where + new _ = newSTRef empty + mark s k = modifySTRef s (insert k) + markQ s k = liftM (member k) (readSTRef s) + seen s = liftM elems (readSTRef s) + +-- implementation 2 +instance Ix key => Mark (ST s) (STUArray s key Bool) key where + new bnd = newArray bnd False + mark s k = writeArray s k True + markQ = readArray + seen s = liftM (map fst . filter snd) (getAssocs s) + +-- traversing the hull suc^*(start) with loop detection +trav suc start i = new i >>= \ c -> mapM_ (compo c) start >> return c + where compo c x = markQ c x >>= flip unless (visit c x) + visit c x = mark c x >> mapM_ (compo c) (suc x) + +-- sample graph +f 1 = 1 : [] +f n = n : f (if even n then div n 2 else 3*n+1) + +t1 = runST ( (trav f [1..10] (1,52) >>= \ (s::STRef s (Set Int)) -> seen s) + :: forall s. ST s [Int] ) + +t2 = runST ( (trav f [1..10] (1,52) >>= \ (s::STUArray s Int Bool) -> seen s) + :: forall s. ST s [Int] ) diff --git a/testsuite/tests/typecheck/should_compile/tc214.hs b/testsuite/tests/typecheck/should_compile/tc214.hs new file mode 100644 index 0000000000..e631854a1e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc214.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags -XGADTs #-} + +-- This program sent GHC 6.6 into a loop, because the fixpointing +-- of the substitution in type refinement got its in-scope-set +-- from the answer! + +module ShouldCompile where + +------------------ +data Foo a b where F :: a -> Foo () a + +bar :: Foo () (forall a.a) -> () +bar (F _) = () + +------------------ +data Foo2 a where F2 :: a -> Foo2 [a] + +bar2 :: Foo2 [forall a.a] -> () +bar2 (F2 _) = () diff --git a/testsuite/tests/typecheck/should_compile/tc215.hs b/testsuite/tests/typecheck/should_compile/tc215.hs new file mode 100644 index 0000000000..bb128b7f0c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc215.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +-- Test for trac #366 +-- The C2 case is impossible due to the types + +module ShouldCompile where + +data T a where + C1 :: T Char + C2 :: T Float + +exhaustive :: T Char -> Char +exhaustive C1 = ' ' + diff --git a/testsuite/tests/typecheck/should_compile/tc216.hs b/testsuite/tests/typecheck/should_compile/tc216.hs new file mode 100644 index 0000000000..4a23f3df7f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc216.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE UndecidableInstances, FlexibleInstances, + MultiParamTypeClasses, FunctionalDependencies #-} + +-- Test for trac #816 +-- GHC's typechecker loops when trying to type this, resulting in a +-- context stack overflow. + +{- Maybe this should typecheck: + + Given: Foo x y, Bar y z + Wanted: Foo x beta, Bar beta z + +If we happened to process (Foo x beta) first we +might generate the extra equality beta~y, and we are good + +If we process (Bar beta z) first, we end up in an infinite +loop, using the (Bar x z) instance repeatedly. + +If instead we'd had + class (F x ~ y) => Foo x y where + type F x + foo :: x -> y + +Then after canonicalising we get + Given: Foo x y, Bar y z, F x ~ y + Wanted: Foo x beta, Bar beta z +-} + +module ShouldCompile where + +class Foo x y | x -> y where + foo :: x -> y + +class Bar x z where + bar :: x -> z -> Int + +instance (Foo x y, Bar y z) => Bar x z where + bar x z = bar (foo x) z + diff --git a/testsuite/tests/typecheck/should_compile/tc216.stderr b/testsuite/tests/typecheck/should_compile/tc216.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc216.stderr diff --git a/testsuite/tests/typecheck/should_compile/tc217.hs b/testsuite/tests/typecheck/should_compile/tc217.hs new file mode 100644 index 0000000000..c42c1eb33b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc217.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -w #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module ShouldCompile where + + +import Control.Monad.Reader + +instance Eq (a -> b) where + _ == _ = error "whoops" + +instance Show (a -> b) where + show = const "<fun>" + +-- This is the example from Trac #179 +foo x = show (\_ -> True) + +-- This is the example from Trac #963 +instance (Num a, Monad m, Eq (m a), Show (m a)) => Num (m a) where +test = 1 True diff --git a/testsuite/tests/typecheck/should_compile/tc218.hs b/testsuite/tests/typecheck/should_compile/tc218.hs new file mode 100644 index 0000000000..ea77525dfc --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc218.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ImplicitParams #-} + +module ShouldCompile where + +bar :: (Show a, ?c::a) => String +-- This type should not be reported as ambiguous +-- See the call in +bar = show ?c + +foo = let { ?c = 'x' } in bar + + diff --git a/testsuite/tests/typecheck/should_compile/tc219.hs b/testsuite/tests/typecheck/should_compile/tc219.hs new file mode 100644 index 0000000000..638f1b6e1e --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc219.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ImplicitParams, NoMonomorphismRestriction #-} + +module ShouldCompile where + +-- c.f. tc218.hs, only no type signature here +-- Instead, the NoMonomorphismRestriction language +bar = show ?c + +foo = let { ?c = 'x' } in bar diff --git a/testsuite/tests/typecheck/should_compile/tc220.hs b/testsuite/tests/typecheck/should_compile/tc220.hs new file mode 100644 index 0000000000..f9f5443bc0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc220.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- See Trac #1033 + +module Pointful' where + +import Data.Generics +import Control.Monad.State + +data HsExp = HsWildCard deriving( Typeable, Data ) +data HsName = HsName deriving( Typeable, Data ) + +-- rename :: () -> HsExp -> State (HsName, [HsName]) HsExp +-- Type sig commented out +rename1 = \_ -> everywhereM (mkM (\e -> case e of HsWildCard -> return e)) + +rename2 _ = everywhereM (mkM (\e -> case e of HsWildCard -> return e)) + +uncomb1 :: State (HsName, [HsName]) HsExp +uncomb1 = rename1 () undefined + +uncomb2 :: State (HsName, [HsName]) HsExp +uncomb2 = rename2 () undefined + + + diff --git a/testsuite/tests/typecheck/should_compile/tc221.hs b/testsuite/tests/typecheck/should_compile/tc221.hs new file mode 100644 index 0000000000..903b2bc3ac --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc221.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE GADTs #-} + +-- A program very like this triggered a kind error with GHC 6.6 + +module Foo where + +data PatchSeq p a b where + Nil :: PatchSeq p a b + U :: p a b -> PatchSeq p a b + (:-) :: PatchSeq p a b -> PatchSeq p b c -> PatchSeq p a c + +-- is_normal :: PatchSeq p a b -> Bool +is_normal Nil = True +is_normal (U _) = True +is_normal (U _ :- _) = True +is_normal _ = False diff --git a/testsuite/tests/typecheck/should_compile/tc222.hs b/testsuite/tests/typecheck/should_compile/tc222.hs new file mode 100644 index 0000000000..4c418ca232 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc222.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ImplicitParams, Rank2Types #-} + +-- Tests impredivative polymorphism with left-to-right +-- flow information; see the uses of "$" + +module TestIP where + +import Control.Monad.ST +import Data.STRef + +-- Here's a use of runST with ($) +foo = runST $ (do { v <- newSTRef 0; readSTRef v }) + +-- Here's a use of implicit parameters with ($) + +type PPDoc = (?env :: Int) => Char -> Char + +f :: PPDoc -> PPDoc +f c = g $ c + +-- Fully annotated version of f, as compiled by GHC 6.4.2 +-- +-- f ?env c = $ (C->C) (C->C) +-- (\(x:C->C). g ?env (\?env. x)) +-- (c ?env) +-- +-- The subsumption test needed from the call to $ is this: +-- ?env => (?env => C -> C) -> C -> C <= a->b +-- (?env => C -> C) -> C -> C <= a->b +-- (a) C->C <= b +-- (b) a <= (?env => C -> C) +-- And perhaps surprisingly (b) succeeds! + +g :: PPDoc -> PPDoc +g d = d + + + diff --git a/testsuite/tests/typecheck/should_compile/tc223.hs b/testsuite/tests/typecheck/should_compile/tc223.hs new file mode 100644 index 0000000000..bf04ba3910 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc223.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +module Foo where + +-- This example suggested by Yitzchak Gale + +import Control.Monad.State +import Control.Monad.Error + +class Error e => Game b mv e | b -> mv e where + newBoard :: MonadState b m => m () + -- This method is unambiguous, because + -- m determines b (via a fundep in MonadState) + + diff --git a/testsuite/tests/typecheck/should_compile/tc224.hs b/testsuite/tests/typecheck/should_compile/tc224.hs new file mode 100644 index 0000000000..34df398e2b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc224.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -XOverloadedStrings #-} +module T where + +import Data.String + +newtype MyString = MyString String deriving (Eq, Show) +instance IsString MyString where + fromString = MyString + +greet1 :: MyString -> MyString +greet1 "hello" = "world" +greet1 other = other + +greet2 :: String -> String +greet2 "hello" = "world" +greet2 other = other + +greet3 :: (Eq s, IsString s) => s -> s +greet3 "hello" = "world" +greet3 other = other + +test = do + print $ greet1 "hello" + print $ greet2 "fool" + print $ greet3 ("foo" :: String) + print $ greet3 ("bar" :: MyString) diff --git a/testsuite/tests/typecheck/should_compile/tc225.hs b/testsuite/tests/typecheck/should_compile/tc225.hs new file mode 100644 index 0000000000..7c4875668b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc225.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTs #-} + +-- Newtype in GADT syntax + +module ShouldCompile where + +newtype Bug a where Bug :: a -> Bug a diff --git a/testsuite/tests/typecheck/should_compile/tc226.hs b/testsuite/tests/typecheck/should_compile/tc226.hs new file mode 100644 index 0000000000..1e5e28ac5b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc226.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} + +-- The combination of unboxing and a recursive newtype crashed GHC 6.6.1 +-- Trac #1255 + +module Foo where + +newtype Bar = Bar Bar -- Recursive + +data Gah = Gah { baaz :: !Bar } + + diff --git a/testsuite/tests/typecheck/should_compile/tc227.hs b/testsuite/tests/typecheck/should_compile/tc227.hs new file mode 100644 index 0000000000..5a4736eccc --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc227.hs @@ -0,0 +1,6 @@ +-- Ensure that tuple instances are brought into scope +-- See Trac #1385 + +module ShouldCompile where + +foo = (1,True) == (2,False) diff --git a/testsuite/tests/typecheck/should_compile/tc228.hs b/testsuite/tests/typecheck/should_compile/tc228.hs new file mode 100644 index 0000000000..a3d1c2f464 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc228.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- Without a type sig this is slightly tricky. +-- See Trac #1430 + +-- Reason: we get an implication constraint (forall a. Typeable a => Typeable b), +-- when generalising unExTypeable. We want to infer a context for the +-- whole thing of (Typeable b). +-- See Note [Inference and implication constraints] in TcSimplify + + +module Foo where + +import Data.Typeable + +data ExTypeable = forall a. Typeable a => ExTypeable a + +-- unExTypeable :: Typeable h => ExTypeable -> Maybe h +unExTypeable (ExTypeable a) = cast a + diff --git a/testsuite/tests/typecheck/should_compile/tc229.hs b/testsuite/tests/typecheck/should_compile/tc229.hs new file mode 100644 index 0000000000..bf48342ee9 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc229.hs @@ -0,0 +1,35 @@ + +-- trac #1406: Constraint doesn't reduce in the presence of quantified +-- type variables + +{-# LANGUAGE FlexibleInstances, UndecidableInstances, Rank2Types, + MultiParamTypeClasses, FunctionalDependencies #-} + +module Problem where + +data Z +data S a + +class HPrefix l +instance (NSub (S Z) ndiff, HDrop ndiff l l) => HPrefix l + +class NSub n1 n3 | n1 -> n3 +instance NSub Z Z +instance NSub n1 n3 => NSub (S n1) n3 + +class HDrop n l1 l2 | n l1 -> l2 +instance HDrop Z l l + +t_hPrefix :: HPrefix l => l -> () +t_hPrefix = undefined + +-- In ghc 6.6.1 this works... +thr' :: (forall r. l -> a) -> a +thr' f = f undefined +thP4' = thr' t_hPrefix + +-- ... but this doesn't work...? +thr :: (forall r. r -> a) -> a +thr f = f undefined +thP4 = thr t_hPrefix + diff --git a/testsuite/tests/typecheck/should_compile/tc230.hs b/testsuite/tests/typecheck/should_compile/tc230.hs new file mode 100644 index 0000000000..11877d487f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc230.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ImplicitParams #-} + +-- Trac #1445 + +module Bug where + +f :: () -> (?p :: ()) => () -> () +f _ _ = () + +g :: (?p :: ()) => () +g = f () () diff --git a/testsuite/tests/typecheck/should_compile/tc231.hs b/testsuite/tests/typecheck/should_compile/tc231.hs new file mode 100644 index 0000000000..304748994b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc231.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -ddump-types #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + +-- See Trac #1456 + +-- The key thing here is that foo should get the type +-- foo :: forall b s t1. (Zork s (Z [Char]) b) +-- => Q s (Z [Char]) t1 -> ST s () + +-- Note the quantification over 'b', which was previously +-- omitted; see Note [Important subtlety in oclose] in FunDeps + + +module ShouldCompile where + +import GHC.ST + +data Q s a chain = Node s a chain + +data Z a = Z a + +s :: Q t (Z [Char]) t1 -> Q t (Z [Char]) t1 +s = undefined + +class Zork s a b | a -> b where + huh :: Q s a chain -> ST s () + +foo b = huh (s b) + diff --git a/testsuite/tests/typecheck/should_compile/tc231.stderr b/testsuite/tests/typecheck/should_compile/tc231.stderr new file mode 100644 index 0000000000..0d4ea6d0c3 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc231.stderr @@ -0,0 +1,22 @@ +TYPE SIGNATURES + foo :: forall s b chain. + Zork s (Z [Char]) b => + Q s (Z [Char]) chain -> ST s () + s :: forall t t1. Q t (Z [Char]) t1 -> Q t (Z [Char]) t1 +TYPE CONSTRUCTORS + data Q s a chain + RecFlag NonRecursive + = Node :: forall s a chain. s -> a -> chain -> Q s a chain + Stricts: _ _ _ + FamilyInstance: none + data Z a + RecFlag NonRecursive + = Z :: forall a. a -> Z a Stricts: _ + FamilyInstance: none +COERCION AXIOMS + axiom ShouldCompile.NTCo:T:Zork [s, a, b] + :: ShouldCompile.T:Zork s a b + ~ + (forall chain. Q s a chain -> ST s ()) +Dependent modules: [] +Dependent packages: [base, ghc-prim, integer-gmp] diff --git a/testsuite/tests/typecheck/should_compile/tc232.hs b/testsuite/tests/typecheck/should_compile/tc232.hs new file mode 100644 index 0000000000..c9f23d45d5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc232.hs @@ -0,0 +1,19 @@ + +-- This one foxed the constraint solver (Lint error) +-- See Trac #1494 + +module ShouldCompile where + +import Control.Monad.State + +newtype L m r = L (StateT Int m r) + +instance Monad m => Monad (L m) where + (>>=) = undefined + return = undefined + +zork :: (Monad m) => a -> L m () +zork = undefined + +mumble e = do { modify id; zork e } + diff --git a/testsuite/tests/typecheck/should_compile/tc233.hs b/testsuite/tests/typecheck/should_compile/tc233.hs new file mode 100644 index 0000000000..6421ae7a82 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc233.hs @@ -0,0 +1,7 @@ + +{-# OPTIONS_GHC -XPolymorphicComponents #-} + +module ShouldCompile where + +newtype Swizzle = MkSwizzle (forall a. Ord a => [a] -> [a]) + diff --git a/testsuite/tests/typecheck/should_compile/tc234.hs b/testsuite/tests/typecheck/should_compile/tc234.hs new file mode 100644 index 0000000000..0ed46becfe --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc234.hs @@ -0,0 +1,11 @@ + +{-# OPTIONS_GHC -XLiberalTypeSynonyms #-} + +module ShouldCompile where + +type T a b = a +type S m = m () + +f :: S (T Int) +f = undefined + diff --git a/testsuite/tests/typecheck/should_compile/tc235.hs b/testsuite/tests/typecheck/should_compile/tc235.hs new file mode 100644 index 0000000000..feeca6a998 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc235.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances, + MultiParamTypeClasses, FunctionalDependencies #-} + +-- Trac #1564 + +module Foo where + +import Text.PrettyPrint +import Prelude hiding(head,tail) + +class FooBar m k l | m -> k l where + a :: m graphtype + +instance FooBar [] Bool Bool where + a = error "urk" + +instance FooBar Maybe Int Int where + a = error "urk" + +class (Monad m)=>Gr g ep m | g -> ep where + x:: m Int + v:: m Int + +instance (Monad m, FooBar m x z) => Gr g ep m where + x = error "urk" + v = error "urk" + +-- Old GHC claims for y: y :: (Monad m, FooBar m GHC.Prim.Any GHC.Prim.Any) +-- => m Int (which is wrong) +-- The uses in foo and bar show if that happens +y () = x + +foo :: [Int] +foo = y () + +bar :: Maybe Int +bar = y () + + diff --git a/testsuite/tests/typecheck/should_compile/tc236.hs b/testsuite/tests/typecheck/should_compile/tc236.hs new file mode 100644 index 0000000000..c555cec38a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc236.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Rank2Types #-} + +module ShouldCompile where + +-- Check that we can have a forall to the right of a double-arrow + +f :: forall a. (Num a) => forall b. (Ord b) => a -> b -> b -> a +f x y z = if y>z then x+1 else x + +g :: (Num a) => (Ord b) => a -> b -> b -> a +g x y z = if y>z then x+1 else x diff --git a/testsuite/tests/typecheck/should_compile/tc237.hs b/testsuite/tests/typecheck/should_compile/tc237.hs new file mode 100644 index 0000000000..0eacf2e854 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc237.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FunctionalDependencies #-} + +-- This one caught a bug in the implementation of functional +-- dependencies, where improvement must happen when +-- checking the call in 'test4' + +module ShouldCompile where + +newtype M s a = M a + +class Modular s a | s -> a + +wim :: forall a w. Integral a + => a -> (forall s. Modular s a => M s w) -> w +wim i k = error "urk" + +test4' :: (Modular s a, Integral a) => M s a +test4' = error "urk" + +test4 = wim 4 test4' diff --git a/testsuite/tests/typecheck/should_compile/tc238.hs b/testsuite/tests/typecheck/should_compile/tc238.hs new file mode 100644 index 0000000000..92cbf23986 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc238.hs @@ -0,0 +1,20 @@ +-- This innocuous module made GHC 6.6 have exponential behaviour +-- when doing validity checking on the synonym declarations +-- +-- This lot is enough to make the test time out, I hope + +module ShouldCompile where + +data TIACons1 i r c = K (c i) (r c) + +type TIACons2 t x = TIACons1 t (TIACons1 t x) +type TIACons3 t x = TIACons2 t (TIACons1 t x) +type TIACons4 t x = TIACons2 t (TIACons2 t x) +type TIACons7 t x = TIACons4 t (TIACons3 t x) +type TIACons8 t x = TIACons4 t (TIACons4 t x) +type TIACons15 t x = TIACons8 t (TIACons7 t x) +type TIACons16 t x = TIACons8 t (TIACons8 t x) +type TIACons31 t x = TIACons16 t (TIACons15 t x) +type TIACons32 t x = TIACons16 t (TIACons16 t x) +type TIACons47 t x = TIACons32 t (TIACons15 t x) +type TIACons48 t x = TIACons32 t (TIACons16 t x) diff --git a/testsuite/tests/typecheck/should_compile/tc239.hs b/testsuite/tests/typecheck/should_compile/tc239.hs new file mode 100644 index 0000000000..81c39b790a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc239.hs @@ -0,0 +1,11 @@ +-- Trac #1072
+
+module ShouldCompile where
+
+import Tc239_Help
+
+f1 :: Show a => WrapIO e a
+f1 = return undefined
+
+f2 :: Show a => WrapIO2 a
+f2 = f1
diff --git a/testsuite/tests/typecheck/should_compile/tc240.hs b/testsuite/tests/typecheck/should_compile/tc240.hs new file mode 100644 index 0000000000..4d43092a44 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc240.hs @@ -0,0 +1,14 @@ +-- Checks that the types of the old binder and the binder implicitly introduced by grouping are linked
+
+{-# OPTIONS_GHC -XTransformListComp #-}
+
+module ShouldCompile where
+
+import Data.List(inits)
+
+foo :: [[[Int]]]
+foo = [ x
+ | x <- [1..10]
+ , then group using inits
+ , then group using inits
+ ]
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_compile/tc241.hs b/testsuite/tests/typecheck/should_compile/tc241.hs new file mode 100644 index 0000000000..8dca34314a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc241.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -XGADTs -XRankNTypes -O1 #-} +-- Trac #2018 + +module Bug1 where + + data A a where + MkA :: A () + + class C w where + f :: forall a . w a -> Maybe a + + instance C A where + f MkA = Just () diff --git a/testsuite/tests/typecheck/should_compile/tc242.hs b/testsuite/tests/typecheck/should_compile/tc242.hs new file mode 100644 index 0000000000..eda338bc8a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc242.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Bug where + +f1 :: forall a. [a] -> [a] +f1 (x:xs) = xs ++ [ x :: a ] -- OK + +f2 :: forall a. [a] -> [a] +f2 = \(x:xs) -> xs ++ [ x :: a ] -- OK + +-- This pair is a cut-down version of Trac #2030 +isSafe alts = isSafeAlts alts + +isSafeAlts :: forall m . Int -> m Int +isSafeAlts x = error "urk" + where + isSafeAlt :: Int -> m Int + isSafeAlt alt = isSafe `seq` error "urk" + diff --git a/testsuite/tests/typecheck/should_compile/tc243.hs b/testsuite/tests/typecheck/should_compile/tc243.hs new file mode 100644 index 0000000000..10bf4d1b52 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc243.hs @@ -0,0 +1,11 @@ + +{-# OPTIONS_GHC -Wall #-} + +module Bug where + +-- When we warn about this, we give a warning saying +-- Inferred type: (.+.) :: forall a. a +-- but we used to not print the parentheses. + +(.+.) = undefined + diff --git a/testsuite/tests/typecheck/should_compile/tc243.stderr b/testsuite/tests/typecheck/should_compile/tc243.stderr new file mode 100644 index 0000000000..10fcab9a71 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc243.stderr @@ -0,0 +1,4 @@ +
+tc243.hs:10:1:
+ Warning: Top-level binding with no type signature:
+ (.+.) :: forall a. a
diff --git a/testsuite/tests/typecheck/should_compile/tc244.hs b/testsuite/tests/typecheck/should_compile/tc244.hs new file mode 100644 index 0000000000..4c5468809a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc244.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeFamilies, GADTs #-}
+
+-- Tests record update in the presence of
+-- existentials, GADTs, type families
+
+module Rec where
+
+----------------- Existential
+data S a where
+ S1 :: { fs1 :: a, fs2 :: b } -> S a
+ S2 :: { fs1 :: a } -> S a
+
+updS s x = s { fs1=x }
+
+------------------ GADT
+data T a b where
+ T1 :: { ft1 :: a, ft2 :: c, ft3 :: d } -> T a Int
+ T2 :: { ft1 :: a, ft3 :: c } -> T a Int
+ T3 :: T Int b
+
+f :: T a1 b -> a2 -> T a2 b
+f x v = x { ft1 = v }
+
+------------------ Type family
+data family R a
+data instance R (a,b) where
+ R1 :: { fr1 :: a, fr2 :: b, fr3 :: c } -> R (a,b)
+ R2 :: { fr1 :: a, fr3 :: c } -> R (a,b)
+
+updR r x = r { fr1=x }
diff --git a/testsuite/tests/typecheck/should_compile/tc245.hs b/testsuite/tests/typecheck/should_compile/tc245.hs new file mode 100644 index 0000000000..abe45d9537 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc245.hs @@ -0,0 +1,11 @@ +-- Test for trac #2937 + +{-# LANGUAGE GADTs, TypeFamilies #-} + +module Tc245 where + +import Tc245_A + +instance Foo Int where + data Bar Int x where + Baz :: Bar Int String diff --git a/testsuite/tests/typecheck/should_compile/tc245.stdout b/testsuite/tests/typecheck/should_compile/tc245.stdout new file mode 100644 index 0000000000..00beb40f5f --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc245.stdout @@ -0,0 +1,3 @@ +[1 of 2] Compiling Tc245_A ( Tc245_A.hs, Tc245_A.o ) +[2 of 2] Compiling Tc245 ( tc245.hs, tc245.o ) +[2 of 2] Compiling Tc245 ( tc245.hs, tc245.o ) diff --git a/testsuite/tests/typecheck/should_compile/tc246.hs b/testsuite/tests/typecheck/should_compile/tc246.hs new file mode 100644 index 0000000000..2b9429b36b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc246.hs @@ -0,0 +1,7 @@ +-- Test for trac #3066 +-- GHC with optimisation off would go into an infinite loop + +module Tc246 () where + +newtype Foo = Foo Foo + diff --git a/testsuite/tests/typecheck/should_compile/tc247.hs b/testsuite/tests/typecheck/should_compile/tc247.hs new file mode 100644 index 0000000000..55c23f92bd --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc247.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE EmptyDataDecls, KindSignatures #-}
+
+module ShouldCompile where
+
+-- Various forms of empty data type declarations
+
+data T1
+
+data T2 where
+
+data T3 :: * -> *
+
+data T4 a :: * -> *
+
+data T5 a :: * -> * where
+
+
diff --git a/testsuite/tests/typecheck/should_compile/tc248.hs b/testsuite/tests/typecheck/should_compile/tc248.hs new file mode 100644 index 0000000000..1fde336bb0 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc248.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ExplicitForAll #-} + +module ShouldCompile where + +identity :: forall a. a -> a +identity x = x diff --git a/testsuite/tests/typecheck/should_compile/tc249.hs b/testsuite/tests/typecheck/should_compile/tc249.hs new file mode 100644 index 0000000000..c16c11e118 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/tc249.hs @@ -0,0 +1,5 @@ +module Ctx where + +f :: (Monad m, Eq (m a)) => a -> m a -> Bool +f x y = (return x == y) + diff --git a/testsuite/tests/typecheck/should_compile/twins.hs b/testsuite/tests/typecheck/should_compile/twins.hs new file mode 100644 index 0000000000..6e46f860db --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/twins.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RankNTypes, LiberalTypeSynonyms #-} + +-- This test checks that deep skolemisation and deep +-- instanatiation work right. A buggy prototype +-- of GHC 7.0, where the type checker generated wrong +-- code, sent applyTypeToArgs into a loop. + +module Twins where + +import Data.Data + +type GenericQ r = forall a. Data a => a -> r +type GenericM m = forall a. Data a => a -> m a + +gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe) +gzip f x y + = f x y + `orElse` + if toConstr x == toConstr y + then gzipWithM (gzip f) x y + else Nothing + +gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) +gzipWithM = error "urk" + +orElse :: Maybe a -> Maybe a -> Maybe a +orElse = error "urk"
\ No newline at end of file |