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 | |
| parent | ebd422aed41048476aa61dd4c520d43becd78682 (diff) | |
| download | haskell-16514f272fb42af6e9c7674a9bd6c9dce369231f.tar.gz | |
Move tests from tests/ghc-regress/* to just tests/*
Diffstat (limited to 'testsuite/tests/typecheck')
1064 files changed, 16495 insertions, 0 deletions
diff --git a/testsuite/tests/typecheck/Makefile b/testsuite/tests/typecheck/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/typecheck/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/typecheck/bug1465/B1.hs b/testsuite/tests/typecheck/bug1465/B1.hs new file mode 100644 index 0000000000..146f5b0529 --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/B1.hs @@ -0,0 +1,6 @@ +module B1 where + +import A + +f :: T +f = T diff --git a/testsuite/tests/typecheck/bug1465/B2.hs b/testsuite/tests/typecheck/bug1465/B2.hs new file mode 100644 index 0000000000..669f9cbd2c --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/B2.hs @@ -0,0 +1,6 @@ +module B2 where + +import A + +f :: T +f = T diff --git a/testsuite/tests/typecheck/bug1465/C.hs b/testsuite/tests/typecheck/bug1465/C.hs new file mode 100644 index 0000000000..6275ecdaaf --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/C.hs @@ -0,0 +1,6 @@ +module C where + +import qualified B1 +import qualified B2 + +x = [B1.f,B2.f] diff --git a/testsuite/tests/typecheck/bug1465/Makefile b/testsuite/tests/typecheck/bug1465/Makefile new file mode 100644 index 0000000000..965b21e99a --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/Makefile @@ -0,0 +1,33 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +LOCAL_PKGCONF=local.package.conf + +PKG=bug1465 + +clean: + rm -f v1/setup v1/Setup.o v1/Setup.hi + rm -f v2/setup v2/Setup.o v2/Setup.hi + rm -rf v1/dist v2/dist + rm -f *.o *.hi + rm -f $(LOCAL_PKGCONF) + +bug1465: + $(MAKE) clean + $(MAKE) prep + '$(TEST_HC)' $(TEST_HC_OPTS) -package-conf $(LOCAL_PKGCONF) -c C.hs || exit 0 + $(MAKE) clean + +prep: + echo "[]" >$(LOCAL_PKGCONF) + $(MAKE) prep.v1 + $(MAKE) prep.v2 + '$(TEST_HC)' $(TEST_HC_OPTS) -package-conf $(LOCAL_PKGCONF) -c -package $(PKG)-1.0 B1.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -package-conf $(LOCAL_PKGCONF) -c -package $(PKG)-2.0 B2.hs + +prep.%: + cd $* && '$(TEST_HC)' -v0 --make -o setup Setup.hs + cd $* && ./setup configure -v0 --with-compiler='$(TEST_HC)' --with-ghc-pkg='$(GHC_PKG)' --package-db ../$(LOCAL_PKGCONF) + cd $* && ./setup build -v0 + cd $* && ./setup register -v0 --inplace diff --git a/testsuite/tests/typecheck/bug1465/all.T b/testsuite/tests/typecheck/bug1465/all.T new file mode 100644 index 0000000000..3847d684d8 --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/all.T @@ -0,0 +1,4 @@ +test('bug1465', + clean_cmd('$MAKE -s clean'), + run_command, + ['$MAKE -s --no-print-directory bug1465']) diff --git a/testsuite/tests/typecheck/bug1465/bug1465.stderr b/testsuite/tests/typecheck/bug1465/bug1465.stderr new file mode 100644 index 0000000000..47a4d0c616 --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/bug1465.stderr @@ -0,0 +1,7 @@ + +C.hs:6:11: + Couldn't match expected type `bug1465-1.0:A.T' + with actual type `A.T' + In the expression: B2.f + In the expression: [B1.f, B2.f] + In an equation for `x': x = [B1.f, B2.f] diff --git a/testsuite/tests/typecheck/bug1465/v1/A.hs b/testsuite/tests/typecheck/bug1465/v1/A.hs new file mode 100644 index 0000000000..6656b4bdfc --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/v1/A.hs @@ -0,0 +1,2 @@ +module A where +data T = T diff --git a/testsuite/tests/typecheck/bug1465/v1/Setup.hs b/testsuite/tests/typecheck/bug1465/v1/Setup.hs new file mode 100644 index 0000000000..6fa548caf7 --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/v1/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/testsuite/tests/typecheck/bug1465/v1/bug1465.cabal b/testsuite/tests/typecheck/bug1465/v1/bug1465.cabal new file mode 100644 index 0000000000..542e7a67d0 --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/v1/bug1465.cabal @@ -0,0 +1,4 @@ +name: bug1465 +version: 1.0 +exposed-modules: A +build-depends: base diff --git a/testsuite/tests/typecheck/bug1465/v2/A.hs b/testsuite/tests/typecheck/bug1465/v2/A.hs new file mode 100644 index 0000000000..6656b4bdfc --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/v2/A.hs @@ -0,0 +1,2 @@ +module A where +data T = T diff --git a/testsuite/tests/typecheck/bug1465/v2/Setup.hs b/testsuite/tests/typecheck/bug1465/v2/Setup.hs new file mode 100644 index 0000000000..6fa548caf7 --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/v2/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/testsuite/tests/typecheck/bug1465/v2/bug1465.cabal b/testsuite/tests/typecheck/bug1465/v2/bug1465.cabal new file mode 100644 index 0000000000..a9ccededfe --- /dev/null +++ b/testsuite/tests/typecheck/bug1465/v2/bug1465.cabal @@ -0,0 +1,4 @@ +name: bug1465 +version: 2.0 +exposed-modules: A +build-depends: base diff --git a/testsuite/tests/typecheck/prog001/A.hs b/testsuite/tests/typecheck/prog001/A.hs new file mode 100644 index 0000000000..4cef40ee75 --- /dev/null +++ b/testsuite/tests/typecheck/prog001/A.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +module A where + +class Matrix a fa | a -> fa where + row :: [a] -> fa diff --git a/testsuite/tests/typecheck/prog001/B.hs b/testsuite/tests/typecheck/prog001/B.hs new file mode 100644 index 0000000000..322a04cde7 --- /dev/null +++ b/testsuite/tests/typecheck/prog001/B.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +module B where +import A + +newtype Val = Val [Int] + +instance Matrix Bool Val diff --git a/testsuite/tests/typecheck/prog001/C.hs b/testsuite/tests/typecheck/prog001/C.hs new file mode 100644 index 0000000000..6c33aaa175 --- /dev/null +++ b/testsuite/tests/typecheck/prog001/C.hs @@ -0,0 +1,9 @@ +module C where + +-- !!! a test for missing instances w/ functional dependencies +-- (failed in GHC 5.00.2) + +import A +import B + +ct0a = row [True,False,True,False] diff --git a/testsuite/tests/typecheck/prog001/Makefile b/testsuite/tests/typecheck/prog001/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/typecheck/prog001/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/typecheck/prog001/test.T b/testsuite/tests/typecheck/prog001/test.T new file mode 100644 index 0000000000..09bb3f0f30 --- /dev/null +++ b/testsuite/tests/typecheck/prog001/test.T @@ -0,0 +1,6 @@ + +test('typecheck.prog001', + [skip_if_fast, + extra_clean(['A.hi', 'A.o', 'B.hi', 'B.o', 'C.hi', 'C.o'])], + multimod_compile, + ['C', '-v0']) diff --git a/testsuite/tests/typecheck/prog001/typecheck.prog001.stderr-ghc b/testsuite/tests/typecheck/prog001/typecheck.prog001.stderr-ghc new file mode 100644 index 0000000000..ea4c0e88f6 --- /dev/null +++ b/testsuite/tests/typecheck/prog001/typecheck.prog001.stderr-ghc @@ -0,0 +1,4 @@ + +B.hs:7:10: + Warning: No explicit method nor default method for `row' + In the instance declaration for `Matrix Bool Val' diff --git a/testsuite/tests/typecheck/prog002/A.hs b/testsuite/tests/typecheck/prog002/A.hs new file mode 100644 index 0000000000..e44f619bf8 --- /dev/null +++ b/testsuite/tests/typecheck/prog002/A.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeOperators #-} + +module A where + +type a :+ b = (a,b) +infixr 1 :+ + + diff --git a/testsuite/tests/typecheck/prog002/B.hs b/testsuite/tests/typecheck/prog002/B.hs new file mode 100644 index 0000000000..9ce85b4b7f --- /dev/null +++ b/testsuite/tests/typecheck/prog002/B.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeOperators #-} + +module B where +import A + +a :: Int :+ Float :+ Double +a = undefined + +b :: Int +b = case a of (p,q) -> p + diff --git a/testsuite/tests/typecheck/prog002/Makefile b/testsuite/tests/typecheck/prog002/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/typecheck/prog002/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/typecheck/prog002/test.T b/testsuite/tests/typecheck/prog002/test.T new file mode 100644 index 0000000000..24625bad04 --- /dev/null +++ b/testsuite/tests/typecheck/prog002/test.T @@ -0,0 +1,7 @@ +setTestOpts(only_compiler_types(['ghc'])) + +test('typecheck.prog002', + [skip_if_fast, + extra_clean(['A.hi', 'A.o', 'B.hi', 'B.o'])], + multimod_compile, + ['B', '-v0']) 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 diff --git a/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.hs b/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.hs new file mode 100644 index 0000000000..505eddcad1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE FlexibleContexts #-}
+
+module FailDueToGivenOverlapping where
+
+class C a where
+
+class D a where
+ dop :: a -> ()
+
+
+instance C a => D [a]
+
+-- should succeed since we can't learn anything more for 'a'
+foo :: (C a, D [Int]) => a -> ()
+foo x = dop [x]
+
+
+class E a where
+ eop :: a -> ()
+
+instance E [a] where
+ eop = undefined
+
+-- should fail since we can never be sure that we learnt
+-- everything about the free unification variable.
+bar :: E [Int] => () -> ()
+bar _ = eop [undefined]
diff --git a/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr b/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr new file mode 100644 index 0000000000..10db900878 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr @@ -0,0 +1,13 @@ +
+FailDueToGivenOverlapping.hs:27:9:
+ Overlapping instances for E [t0]
+ arising from a use of `eop'
+ Matching instances:
+ instance E [a] -- Defined at FailDueToGivenOverlapping.hs:21:10-14
+ Matching givens (or their superclasses):
+ (E [Int])
+ bound by the type signature for bar :: E [Int] => () -> ()
+ at FailDueToGivenOverlapping.hs:27:1-23
+ (The choice depends on the instantiation of `t0')
+ In the expression: eop [undefined]
+ In an equation for `bar': bar _ = eop [undefined]
diff --git a/testsuite/tests/typecheck/should_fail/FrozenErrorTests.hs b/testsuite/tests/typecheck/should_fail/FrozenErrorTests.hs new file mode 100644 index 0000000000..bea5495518 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/FrozenErrorTests.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE RankNTypes, GADTs, TypeFamilies #-}
+module Test where
+
+
+data T a where
+ MkT :: a -> T a
+ MkT2 :: forall a b. (b ~ T b) => b -> T a
+ MkT3 :: forall a. (a ~ Bool) => T a
+-- Occurs checks in givens
+foo :: forall a. (a ~ T a) => a -> a
+foo x = x
+
+blah x = case x of
+ MkT2 y -> ()
+
+-- Mismatches in givens
+bloh :: T Int -> ()
+bloh x = case x of
+ MkT3 -> ()
+
+type family F a b
+type family G a b
+type instance F a Bool = a
+type instance G a Char = a
+
+goo1 :: forall a b. (F a b ~ [a]) => b -> a -> a
+goo1 = undefined
+
+goo2 :: forall a. G a Char ~ [Int] => a -> a
+goo2 = undefined
+
+-- Just an occurs check
+test1 = goo1 False undefined
+
+-- A frozen occurs check, now transformed to decomposition error
+test2 = goo2 (goo1 False undefined)
+test3 = goo1 False (goo2 undefined)
+
+
+-- A frozen occurs check, now transformed to both a decomposition and occurs check
+data M a where
+ M :: M a
+data T2 a b where
+ T2 :: T2 a b
+
+goo3 :: forall a b. F a b ~ T2 (M a) a => b -> a -> a
+goo3 = undefined
+
+goo4 :: forall a c. G a Char ~ T2 (T2 c c) c => a -> a
+goo4 = undefined
+
+test4 = goo4 (goo3 False undefined)
+test5 = goo3 False (goo4 undefined)
+
+
+
diff --git a/testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr b/testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr new file mode 100644 index 0000000000..de552764d1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr @@ -0,0 +1,73 @@ + +FrozenErrorTests.hs:11:1: + Couldn't match type `a' with `T a' + `a' is a rigid type variable bound by + the type signature for foo :: a ~ T a => a -> a + at FrozenErrorTests.hs:11:1 + Inaccessible code in + the type signature for foo :: a ~ T a => a -> a + +FrozenErrorTests.hs:14:12: + Couldn't match type `b' with `T b' + `b' is a rigid type variable bound by + a pattern with constructor + MkT2 :: forall a b. b ~ T b => b -> T a, + in a case alternative + at FrozenErrorTests.hs:14:12 + Inaccessible code in + a pattern with constructor + MkT2 :: forall a b. b ~ T b => b -> T a, + in a case alternative + In the pattern: MkT2 y + In a case alternative: MkT2 y -> () + In the expression: case x of { MkT2 y -> () } + +FrozenErrorTests.hs:19:12: + Couldn't match type `Int' with `Bool' + Inaccessible code in + a pattern with constructor + MkT3 :: forall a. a ~ Bool => T a, + in a case alternative + In the pattern: MkT3 + In a case alternative: MkT3 -> () + In the expression: case x of { MkT3 -> () } + +FrozenErrorTests.hs:33:9: + Occurs check: cannot construct the infinite type: a0 = [a0] + In the expression: goo1 False undefined + In an equation for `test1': test1 = goo1 False undefined + +FrozenErrorTests.hs:36:15: + Couldn't match type `[Int]' with `[[Int]]' + In the first argument of `goo2', namely `(goo1 False undefined)' + In the expression: goo2 (goo1 False undefined) + In an equation for `test2': test2 = goo2 (goo1 False undefined) + +FrozenErrorTests.hs:37:9: + Couldn't match type `Int' with `[Int]' + In the expression: goo1 False (goo2 undefined) + In an equation for `test3': test3 = goo1 False (goo2 undefined) + +FrozenErrorTests.hs:52:15: + Couldn't match type `T2 (T2 c0 c0) c0' + with `T2 (M (T2 (T2 c0 c0) c0)) (T2 (T2 c0 c0) c0)' + In the first argument of `goo4', namely `(goo3 False undefined)' + In the expression: goo4 (goo3 False undefined) + In an equation for `test4': test4 = goo4 (goo3 False undefined) + +FrozenErrorTests.hs:53:9: + Occurs check: cannot construct the infinite type: + c0 = T2 (T2 c0 c0) c0 + In the expression: goo3 False (goo4 undefined) + In an equation for `test5': test5 = goo3 False (goo4 undefined) + +FrozenErrorTests.hs:53:9: + Occurs check: cannot construct the infinite type: + c0 = T2 (T2 c0 c0) c0 + In the expression: goo3 False (goo4 undefined) + In an equation for `test5': test5 = goo3 False (goo4 undefined) + +FrozenErrorTests.hs:53:9: + Couldn't match type `T2 c0' with `M' + In the expression: goo3 False (goo4 undefined) + In an equation for `test5': test5 = goo3 False (goo4 undefined) diff --git a/testsuite/tests/typecheck/should_fail/IPFail.hs b/testsuite/tests/typecheck/should_fail/IPFail.hs new file mode 100644 index 0000000000..1c897eb8cb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/IPFail.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ImplicitParams #-} + +module IPFail where + +f0 :: (?x :: Int) => () -> Bool +f0 () = let ?x = 5 in ?x diff --git a/testsuite/tests/typecheck/should_fail/IPFail.stderr b/testsuite/tests/typecheck/should_fail/IPFail.stderr new file mode 100644 index 0000000000..7d0d8980af --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/IPFail.stderr @@ -0,0 +1,13 @@ + +IPFail.hs:6:18: + Could not deduce (Num Bool) arising from the literal `5' + from the context (?x::Int) + bound by the type signature for f0 :: (?x::Int) => () -> Bool + at IPFail.hs:6:1-24 + Possible fix: + add (Num Bool) to the context of + the type signature for f0 :: (?x::Int) => () -> Bool + or add an instance declaration for (Num Bool) + In the expression: 5 + In the expression: let ?x = 5 in ?x + In an equation for `f0': f0 () = let ?x = 5 in ?x diff --git a/testsuite/tests/typecheck/should_fail/LongWayOverlapping.hs b/testsuite/tests/typecheck/should_fail/LongWayOverlapping.hs new file mode 100644 index 0000000000..4a79e69ed6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/LongWayOverlapping.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses
+ , FlexibleContexts, FlexibleInstances, UndecidableInstances
+ , TypeSynonymInstances, GeneralizedNewtypeDeriving
+ , OverlappingInstances
+ #-}
+
+module LongWayOverlapping where
+
+
+class M a where
+
+class M a => XMLG a
+
+instance M [a]
+
+instance XMLG [m] where -- Generates an implication wanted: forall m. M [m]
+
+class M a => EmbAsChild a b where
+ emb :: b -> [a]
+
+
+instance EmbAsChild [Char] Bool where
+ emb _ = emb 'c'
+
+
+ -- This one generates an unsolvable EmbAsChild [Char] Char
+
+-- Original problem is:
+-- [w] EmbAsChild [Char] Char
+-- [w] forall m. M [m]
+-- Now, by converting the wanted to given and pushing it inside the implication
+-- we have the following:
+-- [g] EmbAsChild [Char] Char
+-- [g] M [Char] <~~ The superclass of the first given!
+-- [w] M [m]
+-- And now OOPS we can't solve M [m] because we are supposed to delay our choice
+-- as much as possible!
+
+-- DV:
+-- One possible solution is to STOP PUSHING wanteds as givens inside an implication
+-- in a checking context. I think it's the best thing to do and I've implemented it.
+
+-- In inference mode that's ok and the error message is very comprehensible, see
+-- test case PushedInFlatsOverlap.hs
diff --git a/testsuite/tests/typecheck/should_fail/LongWayOverlapping.stderr b/testsuite/tests/typecheck/should_fail/LongWayOverlapping.stderr new file mode 100644 index 0000000000..7cc45560c9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/LongWayOverlapping.stderr @@ -0,0 +1,9 @@ +
+LongWayOverlapping.hs:23:11:
+ No instance for (EmbAsChild [Char] Char)
+ arising from a use of `emb'
+ Possible fix:
+ add an instance declaration for (EmbAsChild [Char] Char)
+ In the expression: emb 'c'
+ In an equation for `emb': emb _ = emb 'c'
+ In the instance declaration for `EmbAsChild [Char] Bool'
diff --git a/testsuite/tests/typecheck/should_fail/Makefile b/testsuite/tests/typecheck/should_fail/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/typecheck/should_fail/SCLoop.hs b/testsuite/tests/typecheck/should_fail/SCLoop.hs new file mode 100644 index 0000000000..f3f6a20bc4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/SCLoop.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
+
+-- This is a superclass loop test
+-- It should fail with a type error, but
+-- it's all too easy to succeed with a bogus recursive dictionary
+
+module SCLoop where
+
+class SC a where
+ f :: a -> ()
+
+class SC a => A a b where
+ op :: a -> b -> ()
+ op x _ = f x
+
+instance A a b => A a [b]
+-- dfun1 :: \d::(A a b) -> DA (sc d)
+
+instance SC a => A a (Maybe b)
+-- dfun2 :: \d::SC a -> DA d
+
+foo = op () ([Just True])
+
+{- Here is the explanation:
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+[Wanted] d1 : (A () [Maybe Bool])
+~~~> d1 := dfun1 d2
+[Wanted] d2 : (A () (Maybe Bool))
+~~~> d2 := dfun2 d3
+[Wanted] d3 : SC ()
+[Derived] d4 : SC () d4 := sc d1
+~~~>
+ d3 := sc d1
+ isGoodRecEv will check:
+ d3 == sc d1
+ == sc (dfun1 d2)
+ == sc (dfun1 (dfun2 d3) ==> PASSES! (gravity = 1)
+ This is BAD BAD BAD, because we get a loop
+
+ If we had inlined the definitions:
+ d3 == sc d1
+ == sc (DA (sc d2))
+ == sc (DA (sc (DA d3))) ==> DOES NOT! (gravity = 0)
+
+We should get "No instance for SC ()"
+-}
+
+
+
+
+
+
+
+
diff --git a/testsuite/tests/typecheck/should_fail/SCLoop.stderr b/testsuite/tests/typecheck/should_fail/SCLoop.stderr new file mode 100644 index 0000000000..277b84a7b9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/SCLoop.stderr @@ -0,0 +1,7 @@ + +SCLoop.hs:22:7: + No instance for (SC ()) + arising from a use of `op' + Possible fix: add an instance declaration for (SC ()) + In the expression: op () ([Just True]) + In an equation for `foo': foo = op () ([Just True]) diff --git a/testsuite/tests/typecheck/should_fail/T1595.hs b/testsuite/tests/typecheck/should_fail/T1595.hs new file mode 100644 index 0000000000..fae0192c1e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T1595.hs @@ -0,0 +1,13 @@ +-- +-- Check that we produce only one error message for each type +-- signature. See ticket #1595. +-- + +module T1595 where + +foo1, bar1 :: DoesNotExist +foo1 = undefined +bar1 = undefined + +class Test a where + foo2, bar2 :: a -> DoesNotExist diff --git a/testsuite/tests/typecheck/should_fail/T1595.stderr b/testsuite/tests/typecheck/should_fail/T1595.stderr new file mode 100644 index 0000000000..d3f665c15a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T1595.stderr @@ -0,0 +1,6 @@ + +T1595.hs:8:15: + Not in scope: type constructor or class `DoesNotExist' + +T1595.hs:13:22: + Not in scope: type constructor or class `DoesNotExist' diff --git a/testsuite/tests/typecheck/should_fail/T1633.hs b/testsuite/tests/typecheck/should_fail/T1633.hs new file mode 100644 index 0000000000..3fff8f2540 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T1633.hs @@ -0,0 +1,6 @@ +-- This just tests what the kind error message looks like +-- Trac #1633 + +module T1633 where + +instance Functor Bool diff --git a/testsuite/tests/typecheck/should_fail/T1633.stderr b/testsuite/tests/typecheck/should_fail/T1633.stderr new file mode 100644 index 0000000000..8b3e8fd8a2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T1633.stderr @@ -0,0 +1,6 @@ + +T1633.hs:6:18: + Kind mis-match + The first argument of `Functor' should have kind `* -> *', + but `Bool' has kind `*' + In the instance declaration for `Functor Bool' diff --git a/testsuite/tests/typecheck/should_fail/T1899.hs b/testsuite/tests/typecheck/should_fail/T1899.hs new file mode 100644 index 0000000000..a49b647be7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T1899.hs @@ -0,0 +1,16 @@ +-- Test for Trac #1899 + +module T1899 where + + data Constraint a = Formula [[Proposition a]] + data Proposition a = Prop a + | Auxiliary [Proposition a] + + transRHS :: [a] -> Int -> Constraint a + transRHS varSet b = + if b < 0 + then Formula [[Prop (Auxiliary undefined)]] + else Formula $ + [[Prop (Auxiliary varSet), + Prop (Auxiliary varSet)] + ] diff --git a/testsuite/tests/typecheck/should_fail/T1899.stderr b/testsuite/tests/typecheck/should_fail/T1899.stderr new file mode 100644 index 0000000000..4769b2d96c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T1899.stderr @@ -0,0 +1,15 @@ + +T1899.hs:13:13: + Couldn't match type `a' with `Proposition a0' + `a' is a rigid type variable bound by + the type signature for transRHS :: [a] -> Int -> Constraint a + at T1899.hs:10:2 + Expected type: Constraint a + Actual type: Constraint (Proposition a0) + In the expression: + Formula $ [[Prop (Auxiliary varSet), Prop (Auxiliary varSet)]] + In the expression: + if b < 0 then + Formula [[Prop (Auxiliary undefined)]] + else Formula + $ [[Prop (Auxiliary varSet), Prop (Auxiliary varSet)]] diff --git a/testsuite/tests/typecheck/should_fail/T2126.hs b/testsuite/tests/typecheck/should_fail/T2126.hs new file mode 100644 index 0000000000..4ef3037512 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2126.hs @@ -0,0 +1,5 @@ +-- Trac #2126
+
+module Foo where
+
+newtype X
diff --git a/testsuite/tests/typecheck/should_fail/T2126.stderr b/testsuite/tests/typecheck/should_fail/T2126.stderr new file mode 100644 index 0000000000..2facb189a9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2126.stderr @@ -0,0 +1,4 @@ + +T2126.hs:5:1: + A newtype must have exactly one constructor, but `X' has none + In the newtype declaration for `X' diff --git a/testsuite/tests/typecheck/should_fail/T2307.hs b/testsuite/tests/typecheck/should_fail/T2307.hs new file mode 100644 index 0000000000..321c2d5641 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2307.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + OverlappingInstances, UndecidableInstances, + IncoherentInstances, + FlexibleInstances #-} + +-- Trac #2307 + +module ShouldFail where + + class C a b c | a -> b, a -> c + instance C Int (Maybe String) Float + instance C Int (Maybe Bool) Double diff --git a/testsuite/tests/typecheck/should_fail/T2307.stderr b/testsuite/tests/typecheck/should_fail/T2307.stderr new file mode 100644 index 0000000000..0ca572dbd1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2307.stderr @@ -0,0 +1,7 @@ + +T2307.hs:11:11: + Functional dependencies conflict between instance declarations: + instance [incoherent] C Int (Maybe String) Float + -- Defined at T2307.hs:11:11-36 + instance [incoherent] C Int (Maybe Bool) Double + -- Defined at T2307.hs:12:11-37 diff --git a/testsuite/tests/typecheck/should_fail/T2414.hs b/testsuite/tests/typecheck/should_fail/T2414.hs new file mode 100644 index 0000000000..fba628db27 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2414.hs @@ -0,0 +1,9 @@ +-- Test for Trac #2414 +-- Should provoke an occurs-check error + +module ShouldFail where + +unfoldr :: (b -> Maybe (Bool, b)) -> Bool +unfoldr = unfoldr + +f = unfoldr Just diff --git a/testsuite/tests/typecheck/should_fail/T2414.stderr b/testsuite/tests/typecheck/should_fail/T2414.stderr new file mode 100644 index 0000000000..030bf6e52a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2414.stderr @@ -0,0 +1,7 @@ + +T2414.hs:9:13: + Occurs check: cannot construct the infinite type: b0 = (Bool, b0) + Expected type: b0 -> Maybe (Bool, b0) + Actual type: b0 -> Maybe b0 + In the first argument of `unfoldr', namely `Just' + In the expression: unfoldr Just diff --git a/testsuite/tests/typecheck/should_fail/T2538.hs b/testsuite/tests/typecheck/should_fail/T2538.hs new file mode 100644 index 0000000000..11d9c479b5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2538.hs @@ -0,0 +1,13 @@ + +-- Trac #2538 +module ShouldFail where +import Data.Ix + +f :: (Eq a => a -> a) -> Int +f = error "urk" + +g :: [Eq a => a -> a] -> Int +g = error "urk" + +h :: Ix (Eq a => a -> a) => Int +h = error "urk" diff --git a/testsuite/tests/typecheck/should_fail/T2538.stderr b/testsuite/tests/typecheck/should_fail/T2538.stderr new file mode 100644 index 0000000000..e4e9a7551a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2538.stderr @@ -0,0 +1,14 @@ +
+T2538.hs:6:1:
+ Illegal polymorphic or qualified type: Eq a => a -> a
+ Perhaps you intended to use -XRankNTypes or -XRank2Types
+ In the type signature for `f': f :: (Eq a => a -> a) -> Int
+
+T2538.hs:9:1:
+ Illegal polymorphic or qualified type: Eq a => a -> a
+ Perhaps you intended to use -XImpredicativeTypes
+ In the type signature for `g': g :: [Eq a => a -> a] -> Int
+
+T2538.hs:12:1:
+ Illegal polymorphic or qualified type: Eq a => a -> a
+ In the type signature for `h': h :: Ix (Eq a => a -> a) => Int
diff --git a/testsuite/tests/typecheck/should_fail/T2688.hs b/testsuite/tests/typecheck/should_fail/T2688.hs new file mode 100644 index 0000000000..6897e07b76 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2688.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -XFunctionalDependencies -XMultiParamTypeClasses #-} + +module T2688 where + +class VectorSpace v s | v -> s where + (*^) :: s -> v -> v + (^/) :: v -> s -> v + v ^/ s = v *^ (1/s) diff --git a/testsuite/tests/typecheck/should_fail/T2688.stderr b/testsuite/tests/typecheck/should_fail/T2688.stderr new file mode 100644 index 0000000000..de91620078 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2688.stderr @@ -0,0 +1,13 @@ + +T2688.hs:8:22: + Could not deduce (s ~ v) + from the context (VectorSpace v s) + bound by the class declaration for `VectorSpace' + at T2688.hs:(5,1)-(8,23) + `s' is a rigid type variable bound by + the class declaration for `VectorSpace' at T2688.hs:5:21 + `v' is a rigid type variable bound by + the class declaration for `VectorSpace' at T2688.hs:5:19 + In the second argument of `(/)', namely `s' + In the second argument of `(*^)', namely `(1 / s)' + In the expression: v *^ (1 / s) diff --git a/testsuite/tests/typecheck/should_fail/T2714.hs b/testsuite/tests/typecheck/should_fail/T2714.hs new file mode 100644 index 0000000000..80f838c37c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2714.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ScopedTypeVariables #-}
+
+-- Trac #2714
+
+module T2714 where
+
+f :: ((a -> b) -> b) -> (forall c. c -> a)
+f = ffmap
+
+ffmap :: Functor f => (p->q) -> f p -> f q
+ffmap = error "urk"
+
+{-
+ a ~ f q
+ c ~ f p
+ (p->q) ~ (a->b) -> b
+
+ =>
+ a ~ f q
+ c ~ f p
+ p ~ a->b
+ q ~ b
+ =>
+ a ~ f b
+ c ~ f (a->b)
+-}
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/T2714.stderr b/testsuite/tests/typecheck/should_fail/T2714.stderr new file mode 100644 index 0000000000..da355fc738 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2714.stderr @@ -0,0 +1,22 @@ + +T2714.hs:8:5: + Couldn't match type `a' with `f0 b' + `a' is a rigid type variable bound by + the type signature for f :: ((a -> b) -> b) -> forall c. c -> a + at T2714.hs:8:1 + Expected type: ((a -> b) -> b) -> c -> a + Actual type: ((a -> b) -> b) -> f0 (a -> b) -> f0 b + In the expression: ffmap + In an equation for `f': f = ffmap + +T2714.hs:8:5: + Couldn't match type `c' with `f0 (f0 b -> b)' + `c' is a rigid type variable bound by + the type signature for f :: ((a -> b) -> b) -> c -> a + at T2714.hs:8:1 + Expected type: c + Actual type: f0 (a -> b) + Expected type: ((a -> b) -> b) -> c -> a + Actual type: ((a -> b) -> b) -> f0 (a -> b) -> f0 b + In the expression: ffmap + In an equation for `f': f = ffmap diff --git a/testsuite/tests/typecheck/should_fail/T2806.hs b/testsuite/tests/typecheck/should_fail/T2806.hs new file mode 100644 index 0000000000..a130d49528 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2806.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -Werror #-} + +-- Trac #2806 + +module Foo where + +import GHC.Base + +foo :: Int +foo = 3 + where (I# _x) = 4 + diff --git a/testsuite/tests/typecheck/should_fail/T2806.stderr b/testsuite/tests/typecheck/should_fail/T2806.stderr new file mode 100644 index 0000000000..ebbffb29eb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2806.stderr @@ -0,0 +1,12 @@ + +T2806.hs:13:11: + Warning: Pattern bindings containing unlifted types should use an outermost bang pattern: + (I# _x) = 4 + In an equation for `foo': + foo + = 3 + where + (I# _x) = 4 + +<no location info>: +Failing due to -Werror. diff --git a/testsuite/tests/typecheck/should_fail/T2846b.hs b/testsuite/tests/typecheck/should_fail/T2846b.hs new file mode 100644 index 0000000000..87468df87e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2846b.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ImpredicativeTypes, FlexibleContexts #-} +module T2846 where + +f :: String +f = show ([1,2,3] :: [Num a => a]) + diff --git a/testsuite/tests/typecheck/should_fail/T2846b.stderr b/testsuite/tests/typecheck/should_fail/T2846b.stderr new file mode 100644 index 0000000000..79527c15b7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2846b.stderr @@ -0,0 +1,7 @@ + +T2846b.hs:5:5: + No instance for (Show (Num a0 => a0)) + arising from a use of `show' + Possible fix: add an instance declaration for (Show (Num a0 => a0)) + In the expression: show ([1, 2, 3] :: [Num a => a]) + In an equation for `f': f = show ([1, 2, 3] :: [Num a => a]) diff --git a/testsuite/tests/typecheck/should_fail/T2994.hs b/testsuite/tests/typecheck/should_fail/T2994.hs new file mode 100644 index 0000000000..cd09745aba --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2994.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- Trac #2994 + +module T2994 where + +class MonadReader a b + +newtype Reader' r a = Reader' (r -> a) + +instance MonadReader Int + +instance MonadReader (Reader' r) + +instance MonadReader r r (Reader' r) diff --git a/testsuite/tests/typecheck/should_fail/T2994.stderr b/testsuite/tests/typecheck/should_fail/T2994.stderr new file mode 100644 index 0000000000..7eab543ad4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T2994.stderr @@ -0,0 +1,15 @@ + +T2994.hs:11:10: + `MonadReader Int' is not applied to enough type arguments + Expected kind `*', but `MonadReader Int' has kind `* -> *' + In the instance declaration for `MonadReader Int' + +T2994.hs:13:23: + `Reader' r' is not applied to enough type arguments + The first argument of `MonadReader' should have kind `*', + but `Reader' r' has kind `* -> *' + In the instance declaration for `MonadReader (Reader' r)' + +T2994.hs:15:10: + `MonadReader' is applied to too many type arguments + In the instance declaration for `MonadReader r r (Reader' r)' diff --git a/testsuite/tests/typecheck/should_fail/T3102.hs b/testsuite/tests/typecheck/should_fail/T3102.hs new file mode 100644 index 0000000000..dd5abb25e1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3102.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -XImplicitParams -XRankNTypes #-} + module Bug where + +t :: forall a. ((?p :: Int) => a) -> String +t _ = "Hello" + +f :: (forall a. a -> String) -> Int +f _ = 3 + +result :: Int +result = f t + diff --git a/testsuite/tests/typecheck/should_fail/T3102.stderr b/testsuite/tests/typecheck/should_fail/T3102.stderr new file mode 100644 index 0000000000..cf3483870d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3102.stderr @@ -0,0 +1,9 @@ + +T3102.hs:11:12: + Couldn't match type `a' with `(?p::Int) => a0' + `a' is a rigid type variable bound by + a type expected by the context: a -> String at T3102.hs:11:10 + Expected type: a -> String + Actual type: ((?p::Int) => a0) -> String + In the first argument of `f', namely `t' + In the expression: f t diff --git a/testsuite/tests/typecheck/should_fail/T3155.hs b/testsuite/tests/typecheck/should_fail/T3155.hs new file mode 100644 index 0000000000..3a4c0d2f77 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3155.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs, TypeOperators #-} +module T3155 where + +-- Test Trac #3155 +-- Gave bad error message in GHC 6.10 + +data Any s where + Any :: s ix -> ix -> Any s + +data AnyR s r where + AnyR :: s ix -> r ix -> AnyR s r + +unR :: (forall ix. r ix -> ix) -> AnyR s r -> Any s +unR f (AnyR ix rix) = Any ix (f rix) diff --git a/testsuite/tests/typecheck/should_fail/T3155.stderr b/testsuite/tests/typecheck/should_fail/T3155.stderr new file mode 100644 index 0000000000..d26bb6dd08 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3155.stderr @@ -0,0 +1,5 @@ + +T3155.hs:13:18: + Illegal symbol '.' in type + Perhaps you intended -XRankNTypes or similar flag + to enable explicit-forall syntax: forall <tvs>. <type> diff --git a/testsuite/tests/typecheck/should_fail/T3176.hs b/testsuite/tests/typecheck/should_fail/T3176.hs new file mode 100644 index 0000000000..0235ad712f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3176.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- Trac #3176 + +module Foo where + +data ES = forall a. Show a => ES {unES:: a} + +smallPrintES f t = show $ unES $ f t diff --git a/testsuite/tests/typecheck/should_fail/T3176.stderr b/testsuite/tests/typecheck/should_fail/T3176.stderr new file mode 100644 index 0000000000..393880367d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3176.stderr @@ -0,0 +1,7 @@ + +T3176.hs:9:27: + Cannot use record selector `unES' as a function due to escaped type variables + Probable fix: use pattern-matching syntax instead + In the expression: unES + In the second argument of `($)', namely `unES $ f t' + In the expression: show $ unES $ f t diff --git a/testsuite/tests/typecheck/should_fail/T3323.hs b/testsuite/tests/typecheck/should_fail/T3323.hs new file mode 100644 index 0000000000..22ed520806 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3323.hs @@ -0,0 +1,18 @@ +-- Trac #3323 +module T3323 where + +import GHC.IO.Handle.Types +import GHC.IO.Handle.Internals + +-- The point here is that Handle__ is an existential type, +-- so the haDevice field can't be updated. +-- +-- The bug was that, haDevice is a "naughty" selector, we +-- couldn't find its type constructor. +-- +-- This only happened when you go via an interface file, which is why +-- this test imports an existential. To make the test more +-- standalone, you'd need to make it a two-module test + +f :: Handle__ -> Handle__ +f h = h {haDevice=undefined} diff --git a/testsuite/tests/typecheck/should_fail/T3323.stderr b/testsuite/tests/typecheck/should_fail/T3323.stderr new file mode 100644 index 0000000000..d7c4c26681 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3323.stderr @@ -0,0 +1,5 @@ + +T3323.hs:18:7: + Record update for insufficiently polymorphic field: haDevice :: dev + In the expression: h {haDevice = undefined} + In an equation for `f': f h = h {haDevice = undefined} diff --git a/testsuite/tests/typecheck/should_fail/T3406.hs b/testsuite/tests/typecheck/should_fail/T3406.hs new file mode 100644 index 0000000000..3337f3b135 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3406.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-}
+
+-- Trac #3406
+-- A pattern signature that discards the bound variables
+
+module T3406 where
+
+type ItemColID a b = Int -- Discards a,b
+
+get :: ItemColID a b -> a -> ItemColID a b
+get (x :: ItemColID a b) = x :: ItemColID a b
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/T3406.stderr b/testsuite/tests/typecheck/should_fail/T3406.stderr new file mode 100644 index 0000000000..ceba706f87 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3406.stderr @@ -0,0 +1,10 @@ + +T3406.hs:11:6: + The type variables `a, b' + should be bound by the pattern signature `ItemColID a b' + but are actually discarded by a type synonym + To fix this, expand the type synonym + [Note: I hope to lift this restriction in due course] + In the pattern: x :: ItemColID a b + In an equation for `get': + get (x :: ItemColID a b) = x :: ItemColID a b diff --git a/testsuite/tests/typecheck/should_fail/T3468.hs b/testsuite/tests/typecheck/should_fail/T3468.hs new file mode 100644 index 0000000000..ac9aef557a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3468.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module T3468 where + +import {-# SOURCE #-} T3468 + +data Tool d = forall a r . F a + diff --git a/testsuite/tests/typecheck/should_fail/T3468.hs-boot b/testsuite/tests/typecheck/should_fail/T3468.hs-boot new file mode 100644 index 0000000000..5c7704fab5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3468.hs-boot @@ -0,0 +1,4 @@ +module T3468 where + +data Tool + diff --git a/testsuite/tests/typecheck/should_fail/T3468.stderr b/testsuite/tests/typecheck/should_fail/T3468.stderr new file mode 100644 index 0000000000..020d10457a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3468.stderr @@ -0,0 +1,11 @@ + +T3468.hs-boot:3:6: + Type constructor `Tool' has conflicting definitions in the module and its hs-boot file + Main module: data Tool d + RecFlag Recursive + = F :: forall d a r. a -> Tool d Stricts: _ + FamilyInstance: none + Boot file: data Tool + RecFlag NonRecursive + {- abstract -} + FamilyInstance: none diff --git a/testsuite/tests/typecheck/should_fail/T3540.hs b/testsuite/tests/typecheck/should_fail/T3540.hs new file mode 100644 index 0000000000..364193ceb5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3540.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ImplicitParams, TypeFamilies #-} +module T3540 where + +thing :: (a~Int) +thing = undefined + +thing1 :: Int -> (a~Int) +thing1 = undefined + +thing2 :: (a~Int) -> Int +thing2 = undefined + +thing3 :: (?dude :: Int) -> Int +thing3 = undefined + +thing4:: (Eq a) -> Int +thing4 = undefined
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/T3540.stderr b/testsuite/tests/typecheck/should_fail/T3540.stderr new file mode 100644 index 0000000000..8708dffa5d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3540.stderr @@ -0,0 +1,25 @@ + +T3540.hs:4:12: + Predicate used as a type: a ~ Int + In the type signature for `thing': + thing :: a ~ Int + +T3540.hs:7:20: + Predicate used as a type: a ~ Int + In the type signature for `thing1': + thing1 :: Int -> (a ~ Int) + +T3540.hs:10:13: + Predicate used as a type: a ~ Int + In the type signature for `thing2': + thing2 :: (a ~ Int) -> Int + +T3540.hs:13:12: + Predicate used as a type: ?dude :: Int + In the type signature for `thing3': + thing3 :: (?dude :: Int) -> Int + +T3540.hs:16:11: + Class `Eq' used as a type + In the type signature for `thing4': + thing4 :: (Eq a) -> Int diff --git a/testsuite/tests/typecheck/should_fail/T3613.hs b/testsuite/tests/typecheck/should_fail/T3613.hs new file mode 100644 index 0000000000..9969d63707 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3613.hs @@ -0,0 +1,19 @@ +-- c.f Trac #3613
+
+module T3613 where
+
+import Control.Monad
+
+foo :: Maybe ()
+foo = return ()
+
+bar :: IO ()
+bar = return ()
+
+fun1 = let fooThen m = foo>> m
+ in fooThen (bar>> undefined)
+
+fun2 = let fooThen m = foo>> m
+ in fooThen (do {bar; undefined})
+
+
diff --git a/testsuite/tests/typecheck/should_fail/T3613.stderr b/testsuite/tests/typecheck/should_fail/T3613.stderr new file mode 100644 index 0000000000..feb46416df --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3613.stderr @@ -0,0 +1,17 @@ + +T3613.hs:14:20: + Couldn't match expected type `Maybe a0' with actual type `IO ()' + In the first argument of `(>>)', namely `bar' + In the first argument of `fooThen', namely `(bar >> undefined)' + In the expression: fooThen (bar >> undefined) + +T3613.hs:17:24: + Couldn't match expected type `Maybe a0' with actual type `IO ()' + In a stmt of a 'do' block: bar + In the first argument of `fooThen', namely + `(do { bar; + undefined })' + In the expression: + fooThen + (do { bar; + undefined }) diff --git a/testsuite/tests/typecheck/should_fail/T3950.hs b/testsuite/tests/typecheck/should_fail/T3950.hs new file mode 100644 index 0000000000..127a82b04b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3950.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE GADTs #-}
+
+module T3950 where
+
+-- Id :: (* -> * -> *) -> * -> * -> *
+data Id p x y = Id (p x y)
+
+-- Sealed :: (* -> *) -> *
+data Sealed p where
+ Sealed :: p x -> Sealed p
+
+-- w :: (* -> * -> *) -> *
+-- Id p :: * -> * -> *
+rp :: Bool -> Maybe (w (Id p))
+rp _ = Just rp'
+ where rp' :: Sealed (Id p x)
+ rp' = undefined
diff --git a/testsuite/tests/typecheck/should_fail/T3950.stderr b/testsuite/tests/typecheck/should_fail/T3950.stderr new file mode 100644 index 0000000000..1c326ad43e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3950.stderr @@ -0,0 +1,7 @@ + +T3950.hs:15:13: + Couldn't match expected type `Id p' with actual type `Id p x0' + Expected type: w (Id p) + Actual type: Sealed (Id p x0) + In the first argument of `Just', namely `rp'' + In the expression: Just rp' diff --git a/testsuite/tests/typecheck/should_fail/T3966.hs b/testsuite/tests/typecheck/should_fail/T3966.hs new file mode 100644 index 0000000000..7b1184c710 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3966.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Werror -O #-} +-- Add -O so the UNPACK has some effect + +module T3966 where + +data Foo a b = Foo {-# UNPACK #-} !(a -> b) diff --git a/testsuite/tests/typecheck/should_fail/T3966.stderr b/testsuite/tests/typecheck/should_fail/T3966.stderr new file mode 100644 index 0000000000..b24087ff8b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T3966.stderr @@ -0,0 +1,9 @@ + +T3966.hs:6:16: + Warning: Ignoring unusable UNPACK pragma on the + first argument of `Foo' + In the definition of data constructor `Foo' + In the data type declaration for `Foo' + +<no location info>: +Failing due to -Werror. diff --git a/testsuite/tests/typecheck/should_fail/T4875.hs b/testsuite/tests/typecheck/should_fail/T4875.hs new file mode 100644 index 0000000000..832bb1c8f5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T4875.hs @@ -0,0 +1,28 @@ + {-# OPTIONS -XMultiParamTypeClasses -XFunctionalDependencies -XFlexibleInstances #-}
+module HaskellBug where
+
+data Relation c -- The basic Relation
+ = Rel { relnm :: String -- The name of the relation
+ , relsrc :: c -- Source concept
+ , reltrg :: c -- ^Target concept
+ }
+ deriving Eq
+
+-- This declaration is ok; should not get an error here
+class (Eq concept)=> Association rel concept | rel -> concept where
+ source, target :: rel -> concept
+ -- e.g. Declaration Concept -> Concept
+ sign :: rel -> (concept,concept)
+ sign x = (source x,target x)
+ homogeneous :: rel -> Bool
+ homogeneous s = source s == target s
+
+instance (Eq c)=>Association (Relation c) c where
+ source = relsrc
+ target = reltrg
+
+-- This declaration has a kind error
+-- The error should be reported here
+class (Eq c, Association r c) => Morphic r c where
+ multiplicities :: r c -> [c]
+ multiplicities _ = []
diff --git a/testsuite/tests/typecheck/should_fail/T4875.stderr b/testsuite/tests/typecheck/should_fail/T4875.stderr new file mode 100644 index 0000000000..24c570e73b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T4875.stderr @@ -0,0 +1,5 @@ +
+T4875.hs:27:24:
+ `r' is applied to too many type arguments
+ In the type `r c -> [c]'
+ In the class declaration for `Morphic'
diff --git a/testsuite/tests/typecheck/should_fail/T5084.hs b/testsuite/tests/typecheck/should_fail/T5084.hs new file mode 100644 index 0000000000..0ae39fd71c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T5084.hs @@ -0,0 +1,12 @@ +module T5084 where + +-- Superclass method pragma test (fail) +class Foo a where + bar :: a -> a + {-# INLINE bar #-} + +-- Instance test (ok) +instance Foo Int where + bar = (+1) + {-# INLINE bar #-} + diff --git a/testsuite/tests/typecheck/should_fail/T5084.stderr b/testsuite/tests/typecheck/should_fail/T5084.stderr new file mode 100644 index 0000000000..eba9426342 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T5084.stderr @@ -0,0 +1,3 @@ + +T5084.hs:6:5: + The INLINE pragma for default method `bar' lacks an accompanying binding diff --git a/testsuite/tests/typecheck/should_fail/T5236.hs b/testsuite/tests/typecheck/should_fail/T5236.hs new file mode 100644 index 0000000000..07b31c3218 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T5236.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-} + +module Main where + +data A +data B + +class Id a b | a -> b, b -> a + +instance Id A A +instance Id B B + +loop :: Id A B => Bool +loop = True + +f :: Bool +f = loop + + +main :: IO () +main = return ()
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/T5236.stderr b/testsuite/tests/typecheck/should_fail/T5236.stderr new file mode 100644 index 0000000000..8ec3544f6a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T5236.stderr @@ -0,0 +1,20 @@ +
+T5236.hs:17:5:
+ Couldn't match type `B' with `A'
+ When using functional dependencies to combine
+ Id B B,
+ arising from the dependency `b -> a'
+ in the instance declaration at T5236.hs:11:10
+ Id A B, arising from a use of `loop' at T5236.hs:17:5-8
+ In the expression: loop
+ In an equation for `f': f = loop
+
+T5236.hs:17:5:
+ Couldn't match type `A' with `B'
+ When using functional dependencies to combine
+ Id A A,
+ arising from the dependency `a -> b'
+ in the instance declaration at T5236.hs:10:10
+ Id A B, arising from a use of `loop' at T5236.hs:17:5-8
+ In the expression: loop
+ In an equation for `f': f = loop
diff --git a/testsuite/tests/typecheck/should_fail/T5246.hs b/testsuite/tests/typecheck/should_fail/T5246.hs new file mode 100644 index 0000000000..c7b41c0492 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T5246.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ImplicitParams #-}
+
+-- Produced a duplicated error message in 7.0
+
+module T5246 where
+
+foo :: (?x :: Int) => a
+foo = undefined
+
+bar = let ?x = "hello"
+ in foo
diff --git a/testsuite/tests/typecheck/should_fail/T5246.stderr b/testsuite/tests/typecheck/should_fail/T5246.stderr new file mode 100644 index 0000000000..3886cdef07 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T5246.stderr @@ -0,0 +1,6 @@ +
+T5246.hs:11:10:
+ Couldn't match type `Int' with `[Char]'
+ In the expression: foo
+ In the expression: let ?x = "hello" in foo
+ In an equation for `bar': bar = let ?x = "hello" in foo
diff --git a/testsuite/tests/typecheck/should_fail/T5300.hs b/testsuite/tests/typecheck/should_fail/T5300.hs new file mode 100644 index 0000000000..d052d84659 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T5300.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-} +module T5300 where + +import Control.Monad.State (StateT) + +class C1 a b c | a -> b +class C2 a b c + +data T b = T + +f1 :: (Monad m, C1 a b c) => a -> StateT (T b) m a +f1 f = undefined + +f2 :: (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) => a1 -> StateT (T b2) m a2 +f2 fm = f1 fm >>= return . undefined diff --git a/testsuite/tests/typecheck/should_fail/T5300.stderr b/testsuite/tests/typecheck/should_fail/T5300.stderr new file mode 100644 index 0000000000..bc3bc066b5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T5300.stderr @@ -0,0 +1,8 @@ + +T5300.hs:15:9: + Ambiguous type variable `c0' in the constraint: + (C1 a1 b2 c0) arising from a use of `f1' + Probable fix: add a type signature that fixes these type variable(s) + In the first argument of `(>>=)', namely `f1 fm' + In the expression: f1 fm >>= return . undefined + In an equation for `f2': f2 fm = f1 fm >>= return . undefined diff --git a/testsuite/tests/typecheck/should_fail/Tcfail186_Help.hs b/testsuite/tests/typecheck/should_fail/Tcfail186_Help.hs new file mode 100644 index 0000000000..bdf67f4747 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/Tcfail186_Help.hs @@ -0,0 +1,5 @@ +module Tcfail186_Help where + +type PhantomSyn a = Int + +f = (\_ -> 2) :: PhantomSyn a -> Int diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T new file mode 100644 index 0000000000..5ea05ef478 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -0,0 +1,245 @@ + +test('tcfail001', normal, compile_fail, ['']) +test('tcfail002', normal, compile_fail, ['']) +test('tcfail003', normal, compile_fail, ['']) +test('tcfail004', normal, compile_fail, ['']) +test('tcfail005', normal, compile_fail, ['']) +test('tcfail006', normal, compile_fail, ['']) +test('tcfail007', normal, compile_fail, ['']) +test('tcfail008', normal, compile_fail, ['']) +test('tcfail009', normal, compile_fail, ['']) +test('tcfail010', normal, compile_fail, ['']) +test('tcfail011', normal, compile_fail, ['']) +test('tcfail012', normal, compile_fail, ['']) +test('tcfail013', normal, compile_fail, ['']) +test('tcfail014', normal, compile_fail, ['']) +test('tcfail015', normal, compile_fail, ['']) +test('tcfail016', normal, compile_fail, ['']) +test('tcfail017', normal, compile_fail, ['']) +test('tcfail018', normal, compile_fail, ['']) +test('tcfail019', normal, compile_fail, ['']) +test('tcfail020', normal, compile_fail, ['']) +test('tcfail021', normal, compile_fail, ['']) +test('tcfail023', normal, compile_fail, ['']) +test('tcfail027', normal, compile_fail, ['']) +test('tcfail028', normal, compile_fail, ['']) +test('tcfail029', normal, compile_fail, ['']) +test('tcfail030', if_compiler_type('hugs', expect_fail), compile_fail, ['']) +test('tcfail031', normal, compile_fail, ['']) +test('tcfail032', normal, compile_fail, ['']) +test('tcfail033', normal, compile_fail, ['']) +test('tcfail034', normal, compile_fail, ['']) +test('tcfail035', normal, compile_fail, ['']) +test('tcfail036', normal, compile_fail, ['']) +test('tcfail037', normal, compile_fail, ['']) +test('tcfail038', normal, compile_fail, ['']) +test('tcfail040', normal, compile_fail, ['']) +test('tcfail042', normal, compile_fail, ['']) +test('tcfail043', normal, compile_fail, ['']) +test('tcfail044', normal, compile_fail, ['']) +test('tcfail046', normal, compile_fail, ['']) +test('tcfail047', normal, compile_fail, ['']) +test('tcfail048', normal, compile_fail, ['']) +test('tcfail049', normal, compile_fail, ['']) +test('tcfail050', normal, compile_fail, ['']) +test('tcfail051', normal, compile_fail, ['']) +test('tcfail052', normal, compile_fail, ['']) +test('tcfail053', normal, compile_fail, ['']) +test('tcfail054', normal, compile_fail, ['']) +test('tcfail055', normal, compile_fail, ['']) +test('tcfail056', normal, compile_fail, ['']) +test('tcfail057', normal, compile_fail, ['']) +test('tcfail058', normal, compile_fail, ['']) +test('tcfail061', normal, compile_fail, ['']) +test('tcfail062', normal, compile_fail, ['']) +test('tcfail063', normal, compile_fail, ['']) +test('tcfail065', normal, compile_fail, ['']) +test('tcfail067', normal, compile_fail, ['']) +test('tcfail068', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail069', normal, compile_fail, ['']) +test('tcfail070', normal, compile_fail, ['']) +test('tcfail071', normal, compile, ['']) +test('tcfail072', normal, compile_fail, ['']) +test('tcfail073', normal, compile_fail, ['']) +test('tcfail075', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail076', normal, compile_fail, ['']) +test('tcfail077', normal, compile_fail, ['']) +test('tcfail078', normal, compile_fail, ['']) +test('tcfail079', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail080', if_compiler_type('ghc', expect_fail), compile_fail, ['']) +test('tcfail082', normal, compile_fail, ['']) +test('tcfail083', normal, compile_fail, ['']) +test('tcfail084', normal, compile_fail, ['']) +test('tcfail085', normal, compile_fail, ['']) +test('tcfail086', normal, compile_fail, ['']) +test('tcfail087', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail088', normal, compile_fail, ['']) +test('tcfail089', normal, compile_fail, ['']) +test('tcfail090', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail091', normal, compile_fail, ['']) +test('tcfail092', normal, compile_fail, ['']) +test('tcfail093', normal, compile, ['']) +test('tcfail094', normal, compile_fail, ['']) +test('tcfail095', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail096', normal, compile_fail, ['']) +test('tcfail097', normal, compile_fail, ['']) +test('tcfail098', normal, compile_fail, ['']) +test('tcfail099', normal, compile_fail, ['']) +test('tcfail100', normal, compile_fail, ['']) +test('tcfail101', normal, compile_fail, ['']) +test('tcfail102', normal, compile_fail, ['']) +test('tcfail103', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail104', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail105', normal, compile, ['']) +test('tcfail106', normal, compile_fail, ['']) +test('tcfail107', normal, compile_fail, ['']) +test('tcfail108', normal, compile_fail, ['']) +test('tcfail109', normal, compile_fail, ['']) +test('tcfail110', normal, compile_fail, ['']) +test('tcfail112', normal, compile_fail, ['']) +test('tcfail113', normal, compile_fail, ['']) +test('tcfail114', normal, compile_fail, ['']) +test('tcfail115', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail116', normal, compile_fail, ['']) +test('tcfail117', normal, compile_fail, ['']) +test('tcfail118', normal, compile_fail, ['']) +test('tcfail119', normal, compile_fail, ['']) +test('tcfail120', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail121', normal, compile_fail, ['']) +test('tcfail122', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail123', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail124', only_compiler_types(['ghc']), compile, ['']) +test('tcfail125', normal, compile_fail, ['']) +test('tcfail126', reqlib('mtl'), compile, ['']) +test('tcfail127', normal, compile_fail, ['']) +test('tcfail128', normal, compile_fail, ['']) +test('tcfail129', normal, compile_fail, ['']) +test('tcfail130', normal, compile_fail, ['']) +test('tcfail131', normal, compile_fail, ['']) +test('tcfail132', normal, compile_fail, ['']) +test('tcfail133', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail134', normal, compile_fail, ['']) +test('tcfail135', normal, compile_fail, ['']) +test('tcfail136', normal, compile_fail, ['']) +test('tcfail137', normal, compile_fail, ['']) + +test('tcfail138', normal, compile, ['']) +# Now fails; see notes in file + +test('tcfail139', normal, compile_fail, ['']) +test('tcfail140', normal, compile_fail, ['']) +test('tcfail141', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcfail142', normal, compile_fail, ['']) +test('tcfail143', normal, compile_fail, ['']) +test('tcfail144', normal, compile, ['']) +test('tcfail145', normal, compile, ['']) +test('tcfail146', normal, compile_fail, ['']) +test('tcfail147', normal, compile_fail, ['']) +test('tcfail148', normal, compile_fail, ['']) +test('tcfail149', normal, compile_and_run, ['']) +test('tcfail150', normal, compile, ['']) +test('tcfail151', normal, compile_fail, ['']) +test('tcfail152', normal, compile_fail, ['']) +test('tcfail153', normal, compile_fail, ['']) +test('tcfail154', normal, compile_fail, ['']) +test('tcfail155', normal, compile_fail, ['']) +test('tcfail156', normal, compile_fail, ['']) +test('tcfail157', normal, compile_fail, ['']) +test('tcfail158', normal, compile_fail, ['']) +test('tcfail159', normal, compile_fail, ['']) +test('tcfail160', normal, compile_fail, ['']) +test('tcfail161', normal, compile_fail, ['']) +test('tcfail162', normal, compile_fail, ['']) +test('tcfail164', normal, compile_fail, ['']) +test('tcfail165', normal, compile_fail, ['']) +test('tcfail166', normal, compile_fail, ['']) +test('tcfail167', normal, compile_fail, ['']) +test('tcfail168', normal, compile_fail, ['']) +test('tcfail169', normal, compile_fail, ['']) +test('tcfail170', normal, compile_fail, ['']) +test('tcfail171', normal, compile_fail, ['']) +test('tcfail172', normal, compile, ['']) +test('tcfail173', normal, compile_fail, ['']) +test('tcfail174', normal, compile_fail, ['']) +test('tcfail175', normal, compile_fail, ['']) +test('tcfail176', normal, compile_fail, ['']) +test('tcfail177', normal, compile_fail, ['']) +test('tcfail178', normal, compile_fail, ['']) +test('tcfail179', normal, compile_fail, ['']) +test('tcfail180', normal, compile_fail, ['']) +test('tcfail181', normal, compile_fail, ['']) +test('tcfail182', normal, compile_fail, ['']) +test('tcfail183', normal, compile_fail, ['']) +test('tcfail184', normal, compile_fail, ['']) +test('tcfail185', normal, compile_fail, ['']) +test('tcfail186', + extra_clean(['Tcfail186_Help.hi', 'Tcfail186_Help.o']), + multimod_compile_fail, ['tcfail186', '-v0']) +test('tcfail187', normal, compile_fail, ['']) + +test('tcfail188', normal, compile, ['']) + +test('tcfail189', normal, compile_fail, ['']) +test('tcfail190', normal, compile_fail, ['']) +test('tcfail191', normal, compile_fail, ['']) +test('tcfail192', normal, compile_fail, ['']) +test('tcfail193', normal, compile_fail, ['']) +test('tcfail194', normal, compile_fail, ['']) +test('tcfail195', normal, compile_fail, ['']) +test('tcfail196', normal, compile_fail, ['']) +test('tcfail197', normal, compile_fail, ['']) +test('tcfail198', normal, compile_fail, ['']) +test('tcfail199', normal, compile_fail, ['']) +test('tcfail200', normal, compile_fail, ['']) +test('tcfail201', normal, compile_fail, ['']) +test('tcfail202', normal, compile_fail, ['']) +test('tcfail203', normal, compile, ['']) +test('tcfail203a', normal, compile_fail, ['']) +test('tcfail204', normal, compile_fail, ['']) +test('tcfail206', normal, compile_fail, ['']) + +test('T1595', normal, compile_fail, ['']) +test('T1899', normal, compile_fail, ['']) +test('T2126', normal, compile_fail, ['']) +test('T2307', normal, compile_fail, ['']) +test('T2414', normal, compile_fail, ['']) +test('T2538', normal, compile_fail, ['']) +test('T2688', normal, compile_fail, ['']) +test('T2714', normal, compile_fail, ['']) +test('T2994', normal, compile_fail, ['']) +test('T3155', normal, compile_fail, ['']) +test('T3176', normal, compile_fail, ['']) +test('T1633', normal, compile_fail, ['']) +test('T2806', normal, compile_fail, ['']) +test('T3323', normal, compile_fail, ['']) +test('T3406', normal, compile_fail, ['']) +test('T3540', normal, compile_fail, ['']) +test('T3102', normal, compile_fail, ['']) +test('T3613', normal, compile_fail, ['']) +test('fd-loop', normal, compile_fail, ['']) +test('T3950', normal, compile_fail, ['']) +test('T3966', normal, compile_fail, ['']) +test('IPFail', normal, compile_fail, ['']) + +test('T3468', extra_clean(['T3468.hi-boot']), + multimod_compile_fail, ['T3468', '-v0']) +test('T2846b', normal, compile_fail, ['']) +test('FrozenErrorTests', normal, compile_fail, ['']) +test('SCLoop', normal, compile_fail, ['']) +test('T4875', normal, compile_fail, ['']) +test('mc19', normal, compile_fail, ['']) +test('mc20', normal, compile_fail, ['']) +test('mc21', normal, compile_fail, ['']) +test('mc22', normal, compile_fail, ['']) +test('mc23', normal, compile_fail, ['']) +test('mc24', normal, compile_fail, ['']) +test('mc25', normal, compile_fail, ['']) +test('tcfail207', normal, compile_fail, ['']) +test('T5084', normal, compile_fail, ['']) +test('tcfail208', normal, compile_fail, ['']) + +test('FailDueToGivenOverlapping', normal, compile_fail, ['']) +test('LongWayOverlapping', normal, compile_fail, ['']) +test('T5236',normal,compile_fail,['']) +test('T5246',normal,compile_fail,['']) +test('T5300',normal,compile_fail,['']) diff --git a/testsuite/tests/typecheck/should_fail/fd-loop.hs b/testsuite/tests/typecheck/should_fail/fd-loop.hs new file mode 100644 index 0000000000..8b9a22926e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/fd-loop.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
+
+-- Here's a nice example of a fundep loop, correctly
+-- rejected by the undecidable-instance check.
+-- See comments below.
+
+module FDLoop where
+
+class C a b | a -> b where f :: a -> b
+newtype T a = T a
+
+instance (C a b, Eq b) => Eq (T a) where (==) = undefined
+
+g x = (undefined :: d -> d -> d -> ()) (T x) (f x) (undefined :: Eq e => e)
+
+{- Analysis
+
+ f :: C a b => a -> b
+ x :: a
+ b ~ T a
+ need: C a b
+ b ~ e
+ need: Eq e
+
+Hence need (C a (T a), Eq (T a))
+Apply instance for Eq
+ = (C a (T a), C a g, Eq g)
+Apply functional dependency: g ~ T a
+ = (C a (T a), C a (T a), Eq (T a))
+And now we are back where we started
+-}
+
diff --git a/testsuite/tests/typecheck/should_fail/fd-loop.stderr b/testsuite/tests/typecheck/should_fail/fd-loop.stderr new file mode 100644 index 0000000000..9f93b6d9bc --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/fd-loop.stderr @@ -0,0 +1,12 @@ + +fd-loop.hs:12:10: + Variable occurs more often in a constraint than in the instance head + in the constraint: C a b + (Use -XUndecidableInstances to permit this) + In the instance declaration for `Eq (T a)' + +fd-loop.hs:12:10: + Variable occurs more often in a constraint than in the instance head + in the constraint: Eq b + (Use -XUndecidableInstances to permit this) + In the instance declaration for `Eq (T a)' diff --git a/testsuite/tests/typecheck/should_fail/mc19.hs b/testsuite/tests/typecheck/should_fail/mc19.hs new file mode 100644 index 0000000000..f5cc693b9a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc19.hs @@ -0,0 +1,11 @@ +-- Checks that the correct type is used checking the using clause of the transform + +{-# LANGUAGE MonadComprehensions, TransformListComp #-} + +module ShouldFail where + +import Data.List(inits) + +z :: [Int] +z = [x | x <- [3, 2, 1], then inits] + diff --git a/testsuite/tests/typecheck/should_fail/mc19.stderr b/testsuite/tests/typecheck/should_fail/mc19.stderr new file mode 100644 index 0000000000..c7bca0afd4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc19.stderr @@ -0,0 +1,9 @@ + +mc19.hs:10:31: + Couldn't match type `a' with `[a]' + `a' is a rigid type variable bound by + a type expected by the context: [a] -> [a] at mc19.hs:10:26 + Expected type: [a] -> [a] + Actual type: [a] -> [[a]] + In the expression: inits + In a stmt of a monad comprehension: then inits diff --git a/testsuite/tests/typecheck/should_fail/mc20.hs b/testsuite/tests/typecheck/should_fail/mc20.hs new file mode 100644 index 0000000000..4dd0fe2fe5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc20.hs @@ -0,0 +1,13 @@ + +-- Checks that the ordering constraint on the implicit groupWith is respected + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module ShouldFail where + +data Unorderable = Gnorf | Pinky | Brain + +foo = [ () + | x <- [Gnorf, Brain] + , then group by x + ] diff --git a/testsuite/tests/typecheck/should_fail/mc20.stderr b/testsuite/tests/typecheck/should_fail/mc20.stderr new file mode 100644 index 0000000000..1214b6ac17 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc20.stderr @@ -0,0 +1,8 @@ + +mc20.hs:12:9: + No instance for (Ord Unorderable) + arising from a use of `Control.Monad.Group.mgroupWith' + Possible fix: add an instance declaration for (Ord Unorderable) + In the expression: Control.Monad.Group.mgroupWith + In a stmt of a monad comprehension: then group by x + In the expression: [() | x <- [Gnorf, Brain], then group by x] diff --git a/testsuite/tests/typecheck/should_fail/mc21.hs b/testsuite/tests/typecheck/should_fail/mc21.hs new file mode 100644 index 0000000000..601403a6bd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc21.hs @@ -0,0 +1,13 @@ +-- Checks that the correct type is used checking the using clause of the group + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module ShouldFail where +import GHC.Exts( the ) + +data Unorderable = Gnorf | Pinky | Brain + +foo = [ length x + | x <- [Gnorf, Brain] + , then group using take 5 + ] diff --git a/testsuite/tests/typecheck/should_fail/mc21.stderr b/testsuite/tests/typecheck/should_fail/mc21.stderr new file mode 100644 index 0000000000..95c077cb25 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc21.stderr @@ -0,0 +1,9 @@ + +mc21.hs:12:26: + Couldn't match type `a' with `[a]' + `a' is a rigid type variable bound by + a type expected by the context: [a] -> [[a]] at mc21.hs:12:9 + Expected type: [a] -> [[a]] + Actual type: [a] -> [a] + In the return type of a call of `take' + In the expression: take 5 diff --git a/testsuite/tests/typecheck/should_fail/mc22.hs b/testsuite/tests/typecheck/should_fail/mc22.hs new file mode 100644 index 0000000000..dd8d44e6b7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc22.hs @@ -0,0 +1,11 @@ +-- Checks that the types of the old binder and the binder +-- implicitly introduced by grouping are linked + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module ShouldFail where + +foo = [ x + 1 + | x <- ["Hello", "World"] + , then group using take 5 + ] diff --git a/testsuite/tests/typecheck/should_fail/mc22.stderr b/testsuite/tests/typecheck/should_fail/mc22.stderr new file mode 100644 index 0000000000..96294ae693 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc22.stderr @@ -0,0 +1,9 @@ + +mc22.hs:10:26: + Couldn't match type `a' with `t0 a' + `a' is a rigid type variable bound by + a type expected by the context: [a] -> [t0 a] at mc22.hs:10:9 + Expected type: [a] -> [t0 a] + Actual type: [a] -> [a] + In the return type of a call of `take' + In the expression: take 5 diff --git a/testsuite/tests/typecheck/should_fail/mc23.hs b/testsuite/tests/typecheck/should_fail/mc23.hs new file mode 100644 index 0000000000..ab6f3468a4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc23.hs @@ -0,0 +1,10 @@ +-- Checks that using the "by" clause in a transform requires a function parameter + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module ShouldFail where + +import Data.List(take) + +z = [x | x <- [1..10], then take 5 by x ] + diff --git a/testsuite/tests/typecheck/should_fail/mc23.stderr b/testsuite/tests/typecheck/should_fail/mc23.stderr new file mode 100644 index 0000000000..ec632f8bdb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc23.stderr @@ -0,0 +1,8 @@ + +mc23.hs:9:29: + Couldn't match expected type `a -> t0' with actual type `[a0]' + Expected type: (a -> t0) -> [a] -> t1 a + Actual type: [a0] -> [a0] + In the return type of a call of `take' + Probable cause: `take' is applied to too many arguments + In the expression: take 5 diff --git a/testsuite/tests/typecheck/should_fail/mc24.hs b/testsuite/tests/typecheck/should_fail/mc24.hs new file mode 100644 index 0000000000..9186721229 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc24.hs @@ -0,0 +1,11 @@ +-- Checks that the correct type is used checking the using clause of +-- the group when a by clause is present + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module ShouldFail where + +foo = [ length x + | x <- [1..10] + , then group by x using take 2 + ] diff --git a/testsuite/tests/typecheck/should_fail/mc24.stderr b/testsuite/tests/typecheck/should_fail/mc24.stderr new file mode 100644 index 0000000000..bee1592659 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc24.stderr @@ -0,0 +1,8 @@ + +mc24.hs:10:31: + Couldn't match expected type `a -> t0' with actual type `[a0]' + Expected type: (a -> t0) -> [a] -> t1 (t2 a) + Actual type: [a0] -> [a0] + In the return type of a call of `take' + Probable cause: `take' is applied to too many arguments + In the expression: take 2 diff --git a/testsuite/tests/typecheck/should_fail/mc25.hs b/testsuite/tests/typecheck/should_fail/mc25.hs new file mode 100644 index 0000000000..ecbcfde798 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc25.hs @@ -0,0 +1,10 @@ +-- Checks that using the "by" clause in a transform requires a function parameter + +{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-} + +module ShouldFail where + +import Data.List(take) + +z = [x | x <- [1..10], then group by x using take ] + diff --git a/testsuite/tests/typecheck/should_fail/mc25.stderr b/testsuite/tests/typecheck/should_fail/mc25.stderr new file mode 100644 index 0000000000..7016fad147 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/mc25.stderr @@ -0,0 +1,7 @@ + +mc25.hs:9:46: + Couldn't match expected type `a -> t0' with actual type `Int' + Expected type: (a -> t0) -> [a] -> t1 (t2 a) + Actual type: Int -> [a0] -> [a0] + In the expression: take + In a stmt of a monad comprehension: then group by x using take diff --git a/testsuite/tests/typecheck/should_fail/tcfail001.hs b/testsuite/tests/typecheck/should_fail/tcfail001.hs new file mode 100644 index 0000000000..4e3e13072f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail001.hs @@ -0,0 +1,9 @@ +-- !!! This should fail with a type error: the instance method +-- !!! has a function type when it should have the type [a]. +module ShouldFail where + +class A a where + op :: a + +instance (A a, A a) => A [a] where + op [] = [] diff --git a/testsuite/tests/typecheck/should_fail/tcfail001.stderr b/testsuite/tests/typecheck/should_fail/tcfail001.stderr new file mode 100644 index 0000000000..5fadcf6271 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail001.stderr @@ -0,0 +1,5 @@ + +tcfail001.hs:9:2: + The equation(s) for `op' have one argument, + but its type `[a]' has none + In the instance declaration for `A [a]' diff --git a/testsuite/tests/typecheck/should_fail/tcfail001.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail001.stderr-hugs new file mode 100644 index 0000000000..7b82227ee6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail001.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail001.hs":9 - Type error in instance member binding +*** Term : op +*** Type : [b] -> [c] +*** Does not match : [a] diff --git a/testsuite/tests/typecheck/should_fail/tcfail002.hs b/testsuite/tests/typecheck/should_fail/tcfail002.hs new file mode 100644 index 0000000000..b1fdd165b4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail002.hs @@ -0,0 +1,4 @@ +module ShouldFail where + +c (x:y) = x +c z = z diff --git a/testsuite/tests/typecheck/should_fail/tcfail002.stderr b/testsuite/tests/typecheck/should_fail/tcfail002.stderr new file mode 100644 index 0000000000..12a77d0cc8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail002.stderr @@ -0,0 +1,5 @@ + +tcfail002.hs:4:7: + Occurs check: cannot construct the infinite type: t0 = [t0] + In the expression: z + In an equation for `c': c z = z diff --git a/testsuite/tests/typecheck/should_fail/tcfail002.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail002.stderr-hugs new file mode 100644 index 0000000000..52a41cd2e3 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail002.stderr-hugs @@ -0,0 +1,5 @@ +ERROR "tcfail002.hs":4 - Type error in function binding +*** Term : c +*** Type : a -> a +*** Does not match : [a] -> a +*** Because : unification would give infinite type diff --git a/testsuite/tests/typecheck/should_fail/tcfail003.hs b/testsuite/tests/typecheck/should_fail/tcfail003.hs new file mode 100644 index 0000000000..8458014c1b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail003.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +(d:e) = [1,'a'] diff --git a/testsuite/tests/typecheck/should_fail/tcfail003.stderr b/testsuite/tests/typecheck/should_fail/tcfail003.stderr new file mode 100644 index 0000000000..62fb6a9812 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail003.stderr @@ -0,0 +1,8 @@ + +tcfail003.hs:3:10: + No instance for (Num Char) + arising from the literal `1' + Possible fix: add an instance declaration for (Num Char) + In the expression: 1 + In the expression: [1, 'a'] + In a pattern binding: (d : e) = [1, 'a'] diff --git a/testsuite/tests/typecheck/should_fail/tcfail003.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail003.stderr-hugs new file mode 100644 index 0000000000..3655bd61a7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail003.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail003.hs":3 - Unresolved top-level overloading +*** Binding : d +*** Outstanding context : Num Char diff --git a/testsuite/tests/typecheck/should_fail/tcfail004.hs b/testsuite/tests/typecheck/should_fail/tcfail004.hs new file mode 100644 index 0000000000..513680bd12 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail004.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +(f,g) = (1,2,3) diff --git a/testsuite/tests/typecheck/should_fail/tcfail004.stderr b/testsuite/tests/typecheck/should_fail/tcfail004.stderr new file mode 100644 index 0000000000..5f0408880c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail004.stderr @@ -0,0 +1,6 @@ + +tcfail004.hs:3:9: + Couldn't match expected type `(t0, t1)' + with actual type `(t2, t3, t4)' + In the expression: (1, 2, 3) + In a pattern binding: (f, g) = (1, 2, 3) diff --git a/testsuite/tests/typecheck/should_fail/tcfail004.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail004.stderr-hugs new file mode 100644 index 0000000000..90f8a8105e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail004.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail004.hs":3 - Type error in right hand side +*** Term : (1,2,3) +*** Type : (c,d,e) +*** Does not match : (a,b) diff --git a/testsuite/tests/typecheck/should_fail/tcfail005.hs b/testsuite/tests/typecheck/should_fail/tcfail005.hs new file mode 100644 index 0000000000..ca211e1216 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail005.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +(h:i) = (1,'a') diff --git a/testsuite/tests/typecheck/should_fail/tcfail005.stderr b/testsuite/tests/typecheck/should_fail/tcfail005.stderr new file mode 100644 index 0000000000..8a158f5c8d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail005.stderr @@ -0,0 +1,5 @@ + +tcfail005.hs:3:9: + Couldn't match expected type `[t0]' with actual type `(t1, t2)' + In the expression: (1, 'a') + In a pattern binding: (h : i) = (1, 'a') diff --git a/testsuite/tests/typecheck/should_fail/tcfail005.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail005.stderr-hugs new file mode 100644 index 0000000000..e52ab03426 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail005.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail005.hs":3 - Type error in right hand side +*** Term : (1,'a') +*** Type : (b,Char) +*** Does not match : [a] diff --git a/testsuite/tests/typecheck/should_fail/tcfail006.hs b/testsuite/tests/typecheck/should_fail/tcfail006.hs new file mode 100644 index 0000000000..37fd1f9c35 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail006.hs @@ -0,0 +1,5 @@ +module ShouldFail where + +(j,k) = case (if True then True else False) of + True -> (True,1) + False -> (1,True) diff --git a/testsuite/tests/typecheck/should_fail/tcfail006.stderr b/testsuite/tests/typecheck/should_fail/tcfail006.stderr new file mode 100644 index 0000000000..b2a3f5b04a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail006.stderr @@ -0,0 +1,8 @@ + +tcfail006.hs:5:20: + No instance for (Num Bool) + arising from the literal `1' + Possible fix: add an instance declaration for (Num Bool) + In the expression: 1 + In the expression: (1, True) + In a case alternative: False -> (1, True) diff --git a/testsuite/tests/typecheck/should_fail/tcfail006.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail006.stderr-hugs new file mode 100644 index 0000000000..617112e3f2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail006.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail006.hs":3 - Unresolved top-level overloading +*** Binding : j +*** Outstanding context : Num Bool diff --git a/testsuite/tests/typecheck/should_fail/tcfail007.hs b/testsuite/tests/typecheck/should_fail/tcfail007.hs new file mode 100644 index 0000000000..ee24983aff --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail007.hs @@ -0,0 +1,4 @@ +module ShouldFail where + +n x | True = x+1 + | False = True diff --git a/testsuite/tests/typecheck/should_fail/tcfail007.stderr b/testsuite/tests/typecheck/should_fail/tcfail007.stderr new file mode 100644 index 0000000000..3545f8644f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail007.stderr @@ -0,0 +1,11 @@ + +tcfail007.hs:3:16: + No instance for (Num Bool) + arising from the literal `1' + Possible fix: add an instance declaration for (Num Bool) + In the second argument of `(+)', namely `1' + In the expression: x + 1 + In an equation for `n': + n x + | True = x + 1 + | False = True diff --git a/testsuite/tests/typecheck/should_fail/tcfail007.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail007.stderr-hugs new file mode 100644 index 0000000000..cd78c91def --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail007.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail007.hs":3 - Instance of Num Bool required for definition of n diff --git a/testsuite/tests/typecheck/should_fail/tcfail008.hs b/testsuite/tests/typecheck/should_fail/tcfail008.hs new file mode 100644 index 0000000000..dbc9d0c911 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail008.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +o = 1:2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail008.stderr b/testsuite/tests/typecheck/should_fail/tcfail008.stderr new file mode 100644 index 0000000000..2d31ee6034 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail008.stderr @@ -0,0 +1,8 @@ + +tcfail008.hs:3:7: + No instance for (Num [a0]) + arising from the literal `2' + Possible fix: add an instance declaration for (Num [a0]) + In the second argument of `(:)', namely `2' + In the expression: 1 : 2 + In an equation for `o': o = 1 : 2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail008.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail008.stderr-hugs new file mode 100644 index 0000000000..820654317f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail008.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail008.hs":3 - Unresolved top-level overloading +*** Binding : o +*** Outstanding context : (Num [b], Num b) diff --git a/testsuite/tests/typecheck/should_fail/tcfail009.hs b/testsuite/tests/typecheck/should_fail/tcfail009.hs new file mode 100644 index 0000000000..e8afa0fbf7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail009.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +p = [(1::Int)..(2::Integer)] diff --git a/testsuite/tests/typecheck/should_fail/tcfail009.stderr b/testsuite/tests/typecheck/should_fail/tcfail009.stderr new file mode 100644 index 0000000000..8226c1fbdc --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail009.stderr @@ -0,0 +1,6 @@ + +tcfail009.hs:3:17: + Couldn't match expected type `Int' with actual type `Integer' + In the expression: (2 :: Integer) + In the expression: [(1 :: Int) .. (2 :: Integer)] + In an equation for `p': p = [(1 :: Int) .. (2 :: Integer)] diff --git a/testsuite/tests/typecheck/should_fail/tcfail009.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail009.stderr-hugs new file mode 100644 index 0000000000..9b02c99702 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail009.stderr-hugs @@ -0,0 +1,5 @@ +ERROR "tcfail009.hs":3 - Type error in application +*** Expression : enumFromTo 1 2 +*** Term : 1 +*** Type : Int +*** Does not match : Integer diff --git a/testsuite/tests/typecheck/should_fail/tcfail010.hs b/testsuite/tests/typecheck/should_fail/tcfail010.hs new file mode 100644 index 0000000000..8b793355da --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail010.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +q = \ (y:z) -> z+2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail010.stderr b/testsuite/tests/typecheck/should_fail/tcfail010.stderr new file mode 100644 index 0000000000..34a52ed1d2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail010.stderr @@ -0,0 +1,8 @@ + +tcfail010.hs:3:18: + No instance for (Num [t0]) + arising from the literal `2' + Possible fix: add an instance declaration for (Num [t0]) + In the second argument of `(+)', namely `2' + In the expression: z + 2 + In the expression: \ (y : z) -> z + 2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail010.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail010.stderr-hugs new file mode 100644 index 0000000000..3cc7f66919 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail010.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail010.hs":3 - Unresolved top-level overloading +*** Binding : q +*** Outstanding context : Num [b] diff --git a/testsuite/tests/typecheck/should_fail/tcfail011.hs b/testsuite/tests/typecheck/should_fail/tcfail011.hs new file mode 100644 index 0000000000..89f5c4bcd1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail011.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +z = \y -> x x where x = y diff --git a/testsuite/tests/typecheck/should_fail/tcfail011.stderr b/testsuite/tests/typecheck/should_fail/tcfail011.stderr new file mode 100644 index 0000000000..f41e3a67ce --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail011.stderr @@ -0,0 +1,2 @@ + +tcfail011.hs:3:25: Not in scope: `y' diff --git a/testsuite/tests/typecheck/should_fail/tcfail011.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail011.stderr-hugs new file mode 100644 index 0000000000..d4605dd854 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail011.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail011.hs":3 - Undefined variable "y" diff --git a/testsuite/tests/typecheck/should_fail/tcfail012.hs b/testsuite/tests/typecheck/should_fail/tcfail012.hs new file mode 100644 index 0000000000..67e5fa0256 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail012.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +True = [] diff --git a/testsuite/tests/typecheck/should_fail/tcfail012.stderr b/testsuite/tests/typecheck/should_fail/tcfail012.stderr new file mode 100644 index 0000000000..7fe9b18d47 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail012.stderr @@ -0,0 +1,5 @@ + +tcfail012.hs:3:8: + Couldn't match expected type `Bool' with actual type `[a0]' + In the expression: [] + In a pattern binding: True = [] diff --git a/testsuite/tests/typecheck/should_fail/tcfail012.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail012.stderr-hugs new file mode 100644 index 0000000000..87c9b53fd0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail012.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail012.hs":3 - Type error in right hand side +*** Term : [] +*** Type : [a] +*** Does not match : Bool diff --git a/testsuite/tests/typecheck/should_fail/tcfail013.hs b/testsuite/tests/typecheck/should_fail/tcfail013.hs new file mode 100644 index 0000000000..c9ccc52a64 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail013.hs @@ -0,0 +1,4 @@ +module ShouldFail where + +f [] = 1 +f True = 2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail013.stderr b/testsuite/tests/typecheck/should_fail/tcfail013.stderr new file mode 100644 index 0000000000..439a663c5c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail013.stderr @@ -0,0 +1,5 @@ + +tcfail013.hs:4:3: + Couldn't match expected type `[t0]' with actual type `Bool' + In the pattern: True + In an equation for `f': f True = 2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail013.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail013.stderr-hugs new file mode 100644 index 0000000000..ed08baca77 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail013.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail013.hs":4 - Type error in function binding +*** Term : f +*** Type : Bool -> b +*** Does not match : [a] -> b diff --git a/testsuite/tests/typecheck/should_fail/tcfail014.hs b/testsuite/tests/typecheck/should_fail/tcfail014.hs new file mode 100644 index 0000000000..7d9169936d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail014.hs @@ -0,0 +1,5 @@ +module ShouldFail where + +f x = g+1 + where g y = h+2 + where h z = z z diff --git a/testsuite/tests/typecheck/should_fail/tcfail014.stderr b/testsuite/tests/typecheck/should_fail/tcfail014.stderr new file mode 100644 index 0000000000..d46bf92db3 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail014.stderr @@ -0,0 +1,6 @@ + +tcfail014.hs:5:33: + Occurs check: cannot construct the infinite type: t1 = t1 -> t0 + In the first argument of `z', namely `z' + In the expression: z z + In an equation for `h': h z = z z diff --git a/testsuite/tests/typecheck/should_fail/tcfail014.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail014.stderr-hugs new file mode 100644 index 0000000000..773b9ec586 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail014.stderr-hugs @@ -0,0 +1,6 @@ +ERROR "tcfail014.hs":5 - Type error in application +*** Expression : z z +*** Term : z +*** Type : a -> b +*** Does not match : a +*** Because : unification would give infinite type diff --git a/testsuite/tests/typecheck/should_fail/tcfail015.hs b/testsuite/tests/typecheck/should_fail/tcfail015.hs new file mode 100644 index 0000000000..ae929e3973 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail015.hs @@ -0,0 +1,9 @@ +module ShouldFail where + +data AList a = ANull | ANode a (AList a) + +type IntList = AList Int + +g (ANull) = 2 +g (ANode b (ANode c d)) | b = c+1 + | otherwise = 4 diff --git a/testsuite/tests/typecheck/should_fail/tcfail015.stderr b/testsuite/tests/typecheck/should_fail/tcfail015.stderr new file mode 100644 index 0000000000..52dc7956cd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail015.stderr @@ -0,0 +1,10 @@ + +tcfail015.hs:9:39: + No instance for (Num Bool) + arising from the literal `4' + Possible fix: add an instance declaration for (Num Bool) + In the expression: 4 + In an equation for `g': + g (ANode b (ANode c d)) + | b = c + 1 + | otherwise = 4 diff --git a/testsuite/tests/typecheck/should_fail/tcfail015.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail015.stderr-hugs new file mode 100644 index 0000000000..6884840cdb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail015.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail015.hs":7 - Instance of Num Bool required for definition of g diff --git a/testsuite/tests/typecheck/should_fail/tcfail016.hs b/testsuite/tests/typecheck/should_fail/tcfail016.hs new file mode 100644 index 0000000000..2dfd4a50e0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail016.hs @@ -0,0 +1,9 @@ +module ShouldFail where + +type AnnExpr a = (a,Expr a) + +data Expr a = Var [Char] + | App (AnnExpr a) (AnnExpr a) + +g (Var name) = [name] +g (App e1 e2) = (g e1)++(g e2) diff --git a/testsuite/tests/typecheck/should_fail/tcfail016.stderr b/testsuite/tests/typecheck/should_fail/tcfail016.stderr new file mode 100644 index 0000000000..6420918b37 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail016.stderr @@ -0,0 +1,7 @@ + +tcfail016.hs:9:20: + Couldn't match expected type `Expr t0' + with actual type `AnnExpr t0' + In the first argument of `g', namely `e1' + In the first argument of `(++)', namely `(g e1)' + In the expression: (g e1) ++ (g e2) diff --git a/testsuite/tests/typecheck/should_fail/tcfail016.stderr-ghc-7.0 b/testsuite/tests/typecheck/should_fail/tcfail016.stderr-ghc-7.0 new file mode 100644 index 0000000000..8d2b960eef --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail016.stderr-ghc-7.0 @@ -0,0 +1,8 @@ + +tcfail016.hs:9:20: + Couldn't match expected type `Expr t0' + with actual type `(t0, Expr t0)' + Expected type: Expr t0 + Actual type: AnnExpr t0 + In the first argument of `g', namely `e1' + In the first argument of `(++)', namely `(g e1)' diff --git a/testsuite/tests/typecheck/should_fail/tcfail016.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail016.stderr-hugs new file mode 100644 index 0000000000..cfde47e2fb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail016.stderr-hugs @@ -0,0 +1,5 @@ +ERROR "tcfail016.hs":9 - Type error in application +*** Expression : g e2 +*** Term : e2 +*** Type : (b,Expr b) +*** Does not match : Expr a diff --git a/testsuite/tests/typecheck/should_fail/tcfail017.hs b/testsuite/tests/typecheck/should_fail/tcfail017.hs new file mode 100644 index 0000000000..db3215dc19 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail017.hs @@ -0,0 +1,13 @@ + +module ShouldFail 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 + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail017.stderr b/testsuite/tests/typecheck/should_fail/tcfail017.stderr new file mode 100644 index 0000000000..4f09814afa --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail017.stderr @@ -0,0 +1,10 @@ + +tcfail017.hs:10:10: + Could not deduce (C [a]) + arising from the superclasses of an instance declaration + from the context (B a) + bound by the instance declaration at tcfail017.hs:10:10-23 + Possible fix: + add (C [a]) to the context of the instance declaration + or add an instance declaration for (C [a]) + In the instance declaration for `B [a]' diff --git a/testsuite/tests/typecheck/should_fail/tcfail017.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail017.stderr-hugs new file mode 100644 index 0000000000..a52b3c9715 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail017.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail017.hs":10 - Cannot build superclass instance +*** Instance : B [a] +*** Context supplied : B a +*** Required superclass : C [a] diff --git a/testsuite/tests/typecheck/should_fail/tcfail018.hs b/testsuite/tests/typecheck/should_fail/tcfail018.hs new file mode 100644 index 0000000000..9d811dcda2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail018.hs @@ -0,0 +1,5 @@ + + +module ShouldFail where + +(a:[]) = 1 diff --git a/testsuite/tests/typecheck/should_fail/tcfail018.stderr b/testsuite/tests/typecheck/should_fail/tcfail018.stderr new file mode 100644 index 0000000000..67ee509537 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail018.stderr @@ -0,0 +1,7 @@ + +tcfail018.hs:5:10: + No instance for (Num [t0]) + arising from the literal `1' + Possible fix: add an instance declaration for (Num [t0]) + In the expression: 1 + In a pattern binding: (a : []) = 1 diff --git a/testsuite/tests/typecheck/should_fail/tcfail018.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail018.stderr-hugs new file mode 100644 index 0000000000..4df764f201 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail018.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail018.hs":5 - Unresolved top-level overloading +*** Binding : a +*** Outstanding context : Num [b] diff --git a/testsuite/tests/typecheck/should_fail/tcfail019.hs b/testsuite/tests/typecheck/should_fail/tcfail019.hs new file mode 100644 index 0000000000..af46532f44 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail019.hs @@ -0,0 +1,20 @@ +module ShouldFail where + +class A a where + p1 :: a -> a + p2 :: a -> a -> a + +class (A b) => B b where + p3 :: b + p4 :: b -> b + +class (A c) => C c where + p5 :: c -> c + p6 :: c -> Int + +class (B d,C d) => D d where + p7 :: d -> d + +instance D [a] where + p7 l = [] + diff --git a/testsuite/tests/typecheck/should_fail/tcfail019.stderr b/testsuite/tests/typecheck/should_fail/tcfail019.stderr new file mode 100644 index 0000000000..0f24d012f6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail019.stderr @@ -0,0 +1,12 @@ + +tcfail019.hs:18:10: + No instance for (B [a]) + arising from the superclasses of an instance declaration + Possible fix: add an instance declaration for (B [a]) + In the instance declaration for `D [a]' + +tcfail019.hs:18:10: + No instance for (C [a]) + arising from the superclasses of an instance declaration + Possible fix: add an instance declaration for (C [a]) + In the instance declaration for `D [a]' diff --git a/testsuite/tests/typecheck/should_fail/tcfail019.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail019.stderr-hugs new file mode 100644 index 0000000000..879bea35de --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail019.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail019.hs":18 - Cannot build superclass instance +*** Instance : D [a] +*** Context supplied : () +*** Required superclass : B [a] diff --git a/testsuite/tests/typecheck/should_fail/tcfail020.hs b/testsuite/tests/typecheck/should_fail/tcfail020.hs new file mode 100644 index 0000000000..0d3dc2594a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail020.hs @@ -0,0 +1,16 @@ +module ShouldFail where + +class A a where + p1 :: a -> a + p2 :: a -> a -> a + +class (A b) => B b where + p3 :: b + +instance (A a) => B [a] where + p3 = [] + +data X = XC --, causes stack dump + +--instance B Bool where +-- p3 = True diff --git a/testsuite/tests/typecheck/should_fail/tcfail020.stderr b/testsuite/tests/typecheck/should_fail/tcfail020.stderr new file mode 100644 index 0000000000..3e0df9e42b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail020.stderr @@ -0,0 +1,10 @@ + +tcfail020.hs:10:10: + Could not deduce (A [a]) + arising from the superclasses of an instance declaration + from the context (A a) + bound by the instance declaration at tcfail020.hs:10:10-23 + Possible fix: + add (A [a]) to the context of the instance declaration + or add an instance declaration for (A [a]) + In the instance declaration for `B [a]' diff --git a/testsuite/tests/typecheck/should_fail/tcfail020.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail020.stderr-hugs new file mode 100644 index 0000000000..08d4e497b1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail020.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail020.hs":10 - Cannot build superclass instance +*** Instance : B [a] +*** Context supplied : A a +*** Required superclass : A [a] diff --git a/testsuite/tests/typecheck/should_fail/tcfail021.hs b/testsuite/tests/typecheck/should_fail/tcfail021.hs new file mode 100644 index 0000000000..af11b56df9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail021.hs @@ -0,0 +1,8 @@ +-- !!! Illegally giving methods in a pattern binding (for no v good reason...) + +module ShouldFail where + +data Foo = MkFoo Int + +instance Eq Foo where + ((==), (/=)) = (\x -> \y -> True, \x -> \y -> False) diff --git a/testsuite/tests/typecheck/should_fail/tcfail021.stderr b/testsuite/tests/typecheck/should_fail/tcfail021.stderr new file mode 100644 index 0000000000..5a4e8055bc --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail021.stderr @@ -0,0 +1,4 @@ + +tcfail021.hs:8:5: + Pattern bindings (except simple variables) not allowed in instance declarations + (==, /=) = (\ x -> \ y -> True, \ x -> \ y -> False) diff --git a/testsuite/tests/typecheck/should_fail/tcfail021.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail021.stderr-hugs new file mode 100644 index 0000000000..948d2e7d6d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail021.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail021.hs":8 - Pattern binding illegal in instance declaration diff --git a/testsuite/tests/typecheck/should_fail/tcfail023.hs b/testsuite/tests/typecheck/should_fail/tcfail023.hs new file mode 100644 index 0000000000..74bcaf3a4b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail023.hs @@ -0,0 +1,16 @@ +module ShouldFail where + +-- !!! Duplicate instances + +data B = C + +class A a where + op :: a -> Bool + +instance A B where + op C = True + +instance A B where + op C = True + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail023.stderr b/testsuite/tests/typecheck/should_fail/tcfail023.stderr new file mode 100644 index 0000000000..96cdb4ebc0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail023.stderr @@ -0,0 +1,5 @@ + +tcfail023.hs:10:10: + Duplicate instance declarations: + instance A B -- Defined at tcfail023.hs:10:10-12 + instance A B -- Defined at tcfail023.hs:13:10-12 diff --git a/testsuite/tests/typecheck/should_fail/tcfail023.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail023.stderr-hugs new file mode 100644 index 0000000000..84b92be57c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail023.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail023.hs":13 - Overlapping instances for class "A" +*** This instance : A B +*** Overlaps with : A B +*** Common instance : A B diff --git a/testsuite/tests/typecheck/should_fail/tcfail025.stderr b/testsuite/tests/typecheck/should_fail/tcfail025.stderr new file mode 100644 index 0000000000..6a0f830cc4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail025.stderr @@ -0,0 +1,8 @@ + +tcfail025.hs:2: + Conflicting exports for local name: A + module Main + module Main + + +Compilation had errors diff --git a/testsuite/tests/typecheck/should_fail/tcfail026.stderr b/testsuite/tests/typecheck/should_fail/tcfail026.stderr new file mode 100644 index 0000000000..23e90f7ae4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail026.stderr @@ -0,0 +1,13 @@ + +tcfail026.hs:2: + Conflicting exports for local name: A + module Main + module Main + +tcfail026.hs:6: + Class type variable ``a'' does not appear in method signature: + op2 :: + `b' -> `b' + + +Compilation had errors diff --git a/testsuite/tests/typecheck/should_fail/tcfail027.hs b/testsuite/tests/typecheck/should_fail/tcfail027.hs new file mode 100644 index 0000000000..e01f6961bd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail027.hs @@ -0,0 +1,8 @@ +-- !!! tests for CycleErr in classes +module TcFail where + +class (B a) => A a where + op1 :: a -> a + +class (A a) => B a where + op2 :: a -> a -> a diff --git a/testsuite/tests/typecheck/should_fail/tcfail027.stderr b/testsuite/tests/typecheck/should_fail/tcfail027.stderr new file mode 100644 index 0000000000..d51c253617 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail027.stderr @@ -0,0 +1,5 @@ +
+tcfail027.hs:4:1:
+ Cycle in class declarations (via superclasses):
+ tcfail027.hs:(4,1)-(5,14): class B a => A a
+ tcfail027.hs:(7,1)-(8,19): class A a => B a
diff --git a/testsuite/tests/typecheck/should_fail/tcfail027.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail027.stderr-hugs new file mode 100644 index 0000000000..fd1b771772 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail027.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail027.hs":7 - Superclass relation for "B" is cyclic diff --git a/testsuite/tests/typecheck/should_fail/tcfail028.hs b/testsuite/tests/typecheck/should_fail/tcfail028.hs new file mode 100644 index 0000000000..5f9b32c07f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail028.hs @@ -0,0 +1,4 @@ +-- !!! tests for ArityErr +module TcFail where + +data A a b = B (A a) diff --git a/testsuite/tests/typecheck/should_fail/tcfail028.stderr b/testsuite/tests/typecheck/should_fail/tcfail028.stderr new file mode 100644 index 0000000000..7ad9ecbb23 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail028.stderr @@ -0,0 +1,7 @@ + +tcfail028.hs:4:17: + `A a' is not applied to enough type arguments + Expected kind `?', but `A a' has kind `k0 -> *' + In the type `A a' + In the definition of data constructor `B' + In the data type declaration for `A' diff --git a/testsuite/tests/typecheck/should_fail/tcfail028.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail028.stderr-hugs new file mode 100644 index 0000000000..a64425da98 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail028.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail028.hs":4 - Illegal type "A a -> A a b" in constructor application diff --git a/testsuite/tests/typecheck/should_fail/tcfail029.hs b/testsuite/tests/typecheck/should_fail/tcfail029.hs new file mode 100644 index 0000000000..14dd2d7e6b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail029.hs @@ -0,0 +1,6 @@ +-- !!! tests for InstOpErr +module ShouldFail where + +data Foo = Bar | Baz + +f x = x > Bar diff --git a/testsuite/tests/typecheck/should_fail/tcfail029.stderr b/testsuite/tests/typecheck/should_fail/tcfail029.stderr new file mode 100644 index 0000000000..cf83c561b9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail029.stderr @@ -0,0 +1,7 @@ + +tcfail029.hs:6:9: + No instance for (Ord Foo) + arising from a use of `>' + Possible fix: add an instance declaration for (Ord Foo) + In the expression: x > Bar + In an equation for `f': f x = x > Bar diff --git a/testsuite/tests/typecheck/should_fail/tcfail029.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail029.stderr-hugs new file mode 100644 index 0000000000..e9a48fd076 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail029.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail029.hs":6 - Instance of Ord Foo required for definition of f diff --git a/testsuite/tests/typecheck/should_fail/tcfail030.hs b/testsuite/tests/typecheck/should_fail/tcfail030.hs new file mode 100644 index 0000000000..163c727518 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail030.hs @@ -0,0 +1,2 @@ +-- !!! empty file + diff --git a/testsuite/tests/typecheck/should_fail/tcfail030.stderr b/testsuite/tests/typecheck/should_fail/tcfail030.stderr new file mode 100644 index 0000000000..cb9d80959d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail030.stderr @@ -0,0 +1,3 @@ + +tcfail030.hs:1:1: + The function `main' is not defined in module `Main' diff --git a/testsuite/tests/typecheck/should_fail/tcfail031.hs b/testsuite/tests/typecheck/should_fail/tcfail031.hs new file mode 100644 index 0000000000..6b9a0de12b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail031.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +f x = if 'a' then 1 else 2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail031.stderr b/testsuite/tests/typecheck/should_fail/tcfail031.stderr new file mode 100644 index 0000000000..f7fc14bb1f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail031.stderr @@ -0,0 +1,6 @@ + +tcfail031.hs:3:10: + Couldn't match expected type `Bool' with actual type `Char' + In the expression: 'a' + In the expression: if 'a' then 1 else 2 + In an equation for `f': f x = if 'a' then 1 else 2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail031.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail031.stderr-hugs new file mode 100644 index 0000000000..a955d833cb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail031.stderr-hugs @@ -0,0 +1,5 @@ +ERROR "tcfail031.hs":3 - Type error in conditional +*** Expression : if 'a' then 1 else 2 +*** Term : 'a' +*** Type : Char +*** Does not match : Bool diff --git a/testsuite/tests/typecheck/should_fail/tcfail032.hs b/testsuite/tests/typecheck/should_fail/tcfail032.hs new file mode 100644 index 0000000000..5950064655 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail032.hs @@ -0,0 +1,16 @@ +{- This test gives the following not-very-wonderful error message. + + "tc_sig.hs", line 3: Type signature does not match the inferred type: + Signature: t76 -> Int + Inferred type: t75 + +It *is* an error, because x does not have the polytype + forall a. Eq a => a -> Int +becuase it is monomorphic, but the error message isn't very illuminating. +-} + +module ShouldFail where + +f x = (x :: (Eq a) => a -> Int) + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail032.stderr b/testsuite/tests/typecheck/should_fail/tcfail032.stderr new file mode 100644 index 0000000000..8cb4c1b99a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail032.stderr @@ -0,0 +1,14 @@ + +tcfail032.hs:14:8: + Could not deduce (t ~ (a1 -> Int)) + from the context (Eq a) + bound by the inferred type of f :: Eq a => t -> a -> Int + at tcfail032.hs:14:1-31 + or from (Eq a1) + bound by an expression type signature: Eq a1 => a1 -> Int + at tcfail032.hs:14:8-30 + `t' is a rigid type variable bound by + the inferred type of f :: Eq a => t -> a -> Int + at tcfail032.hs:14:1 + In the expression: (x :: Eq a => a -> Int) + In an equation for `f': f x = (x :: Eq a => a -> Int) diff --git a/testsuite/tests/typecheck/should_fail/tcfail032.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail032.stderr-hugs new file mode 100644 index 0000000000..39879dc120 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail032.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail032.hs":14 - Inferred type is not general enough +*** Expression : x +*** Expected type : Eq a => a -> Int +*** Inferred type : Eq _5 => _5 -> Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail033.hs b/testsuite/tests/typecheck/should_fail/tcfail033.hs new file mode 100644 index 0000000000..fdc0aff8ed --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail033.hs @@ -0,0 +1,4 @@ +-- from Jon Hill +module ShouldFail where + +buglet = [ x | (x,y) <- buglet ] diff --git a/testsuite/tests/typecheck/should_fail/tcfail033.stderr b/testsuite/tests/typecheck/should_fail/tcfail033.stderr new file mode 100644 index 0000000000..826ad4626d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail033.stderr @@ -0,0 +1,6 @@ + +tcfail033.hs:4:12: + Occurs check: cannot construct the infinite type: t0 = (t0, t1) + In the expression: x + In the expression: [x | (x, y) <- buglet] + In an equation for `buglet': buglet = [x | (x, y) <- buglet] diff --git a/testsuite/tests/typecheck/should_fail/tcfail033.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail033.stderr-hugs new file mode 100644 index 0000000000..aed2ee660e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail033.stderr-hugs @@ -0,0 +1,5 @@ +ERROR "tcfail033.hs":4 - Type error in function binding +*** Term : buglet +*** Type : [a] +*** Does not match : [(a,b)] +*** Because : unification would give infinite type diff --git a/testsuite/tests/typecheck/should_fail/tcfail034.hs b/testsuite/tests/typecheck/should_fail/tcfail034.hs new file mode 100644 index 0000000000..0bbb75fab8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail034.hs @@ -0,0 +1,39 @@ +{- +From: Jon Hill <hilly@dcs.qmw.ac.uk@jess.gla.ac.uk@pp.dcs.glasgow.ac.uk> +To: glasgow-haskell-bugs +Subject: Unfriendly error message +Date: Thu, 25 Jun 1992 09:22:55 +0100 + +Hello again, + +I came across a rather nasty error message when I gave a function an +incorrect type signature (the context is wrong). I can remember reading +in the source about this problem - I just thought I'd let you know anyway :-) +-} +module ShouldFail where + + +test::(Num a, Eq a) => a -> Bool +test x = (x `mod` 3) == 0 + +{- +granite> ndph bug002.ldh +Data Parallel Haskell Compiler, version 0.01 (Glasgow 0.07) + + +"<unknown>", line <unknown>: Cannot express dicts in terms of dictionaries available: +dicts_encl: + "<built-in>", line : dict.87 :: <Num a> + "<built-in>", line : dict.88 :: <Eq a> +dicts_encl': + "<built-in>", line : dict.87 :: <Num a> + "<built-in>", line : dict.88 :: <Eq a> +dicts: + "<built-in>", line : dict.87 :: <Num a> + "<built-in>", line : dict.88 :: <Eq a> +super_class_dict: "<built-in>", line : dict.80 :: <Integral a> +Fail: Compilation errors found + +dph: execution of the Haskell compiler had trouble + +-} diff --git a/testsuite/tests/typecheck/should_fail/tcfail034.stderr b/testsuite/tests/typecheck/should_fail/tcfail034.stderr new file mode 100644 index 0000000000..db8e148eb9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail034.stderr @@ -0,0 +1,12 @@ + +tcfail034.hs:17:13: + Could not deduce (Integral a) arising from a use of `mod' + from the context (Num a, Eq a) + bound by the type signature for test :: (Num a, Eq a) => a -> Bool + at tcfail034.hs:17:1-25 + Possible fix: + add (Integral a) to the context of + the type signature for test :: (Num a, Eq a) => a -> Bool + In the first argument of `(==)', namely `(x `mod` 3)' + In the expression: (x `mod` 3) == 0 + In an equation for `test': test x = (x `mod` 3) == 0 diff --git a/testsuite/tests/typecheck/should_fail/tcfail035.hs b/testsuite/tests/typecheck/should_fail/tcfail035.hs new file mode 100644 index 0000000000..8de67867dd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail035.hs @@ -0,0 +1,9 @@ +-- !!! instances with empty where parts: duplicate +-- +module ShouldFail where + +data NUM = ONE | TWO +instance Num NUM +instance Num NUM +instance Eq NUM +instance Show NUM diff --git a/testsuite/tests/typecheck/should_fail/tcfail035.stderr b/testsuite/tests/typecheck/should_fail/tcfail035.stderr new file mode 100644 index 0000000000..ed9efb53b0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail035.stderr @@ -0,0 +1,5 @@ + +tcfail035.hs:6:10: + Duplicate instance declarations: + instance Num NUM -- Defined at tcfail035.hs:6:10-16 + instance Num NUM -- Defined at tcfail035.hs:7:10-16 diff --git a/testsuite/tests/typecheck/should_fail/tcfail035.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail035.stderr-hugs new file mode 100644 index 0000000000..4d459748ac --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail035.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail035.hs":7 - Overlapping instances for class "Num" +*** This instance : Num NUM +*** Overlaps with : Num NUM +*** Common instance : Num NUM diff --git a/testsuite/tests/typecheck/should_fail/tcfail036.hs b/testsuite/tests/typecheck/should_fail/tcfail036.hs new file mode 100644 index 0000000000..ade1720ccc --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail036.hs @@ -0,0 +1,10 @@ +-- !!! prelude class name in an instance-tycon position +-- +module ShouldFail where + +data NUM = ONE | TWO +instance Num NUM + where ONE + ONE = TWO +instance Num NUM +instance Eq Num +--instance Text Num diff --git a/testsuite/tests/typecheck/should_fail/tcfail036.stderr b/testsuite/tests/typecheck/should_fail/tcfail036.stderr new file mode 100644 index 0000000000..9ce51d2dd0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail036.stderr @@ -0,0 +1,9 @@ + +tcfail036.hs:6:10: + Duplicate instance declarations: + instance Num NUM -- Defined at tcfail036.hs:6:10-16 + instance Num NUM -- Defined at tcfail036.hs:8:10-16 + +tcfail036.hs:9:13: + Class `Num' used as a type + In the instance declaration for `Eq Num' diff --git a/testsuite/tests/typecheck/should_fail/tcfail036.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail036.stderr-hugs new file mode 100644 index 0000000000..7c418cc655 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail036.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail036.hs":8 - Overlapping instances for class "Num" +*** This instance : Num NUM +*** Overlaps with : Num NUM +*** Common instance : Num NUM diff --git a/testsuite/tests/typecheck/should_fail/tcfail037.hs b/testsuite/tests/typecheck/should_fail/tcfail037.hs new file mode 100644 index 0000000000..d2110c755a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail037.hs @@ -0,0 +1,11 @@ +-- !!! PreludeCore entities cannot be redefined at the top-level +-- +module ShouldFail where + +data NUM = ONE | TWO + +f a b = a + b +f :: NUM -> NUM -> NUM + +ONE + ONE = TWO + diff --git a/testsuite/tests/typecheck/should_fail/tcfail037.stderr b/testsuite/tests/typecheck/should_fail/tcfail037.stderr new file mode 100644 index 0000000000..a6a2a5e412 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail037.stderr @@ -0,0 +1,5 @@ + +tcfail037.hs:7:11: + Ambiguous occurrence `+' + It could refer to either `ShouldFail.+', defined at tcfail037.hs:10:5 + or `Prelude.+', imported from Prelude diff --git a/testsuite/tests/typecheck/should_fail/tcfail037.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail037.stderr-hugs new file mode 100644 index 0000000000..cfd3f42a89 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail037.stderr-hugs @@ -0,0 +1,2 @@ +ERROR "tcfail037.hs":7 - Ambiguous variable occurrence "+" +*** Could refer to: ShouldFail.+ Hugs.Prelude.+ diff --git a/testsuite/tests/typecheck/should_fail/tcfail038.hs b/testsuite/tests/typecheck/should_fail/tcfail038.hs new file mode 100644 index 0000000000..1770bde61c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail038.hs @@ -0,0 +1,11 @@ +-- !!! duplicate class-method declarations + +module ShouldFail where + +data NUM = ONE | TWO +instance Eq NUM where + a == b = True + a /= b = False + a == b = False + a /= b = True + diff --git a/testsuite/tests/typecheck/should_fail/tcfail038.stderr b/testsuite/tests/typecheck/should_fail/tcfail038.stderr new file mode 100644 index 0000000000..70e13f3c72 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail038.stderr @@ -0,0 +1,10 @@ + +tcfail038.hs:7:11: + Conflicting definitions for `==' + Bound at: tcfail038.hs:7:11-12 + tcfail038.hs:9:11-12 + +tcfail038.hs:8:11: + Conflicting definitions for `/=' + Bound at: tcfail038.hs:8:11-12 + tcfail038.hs:10:11-12 diff --git a/testsuite/tests/typecheck/should_fail/tcfail038.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail038.stderr-hugs new file mode 100644 index 0000000000..7e2f61b981 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail038.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail038.hs":8 - "/=" multiply defined diff --git a/testsuite/tests/typecheck/should_fail/tcfail040.hs b/testsuite/tests/typecheck/should_fail/tcfail040.hs new file mode 100644 index 0000000000..8ac06b363c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail040.hs @@ -0,0 +1,29 @@ +-- !!! instances of functions +-- +module ShouldFail where + +data NUM = ONE | TWO + +class EQ a where + (===) :: a -> a -> Bool + +class ORD a where + (<<) :: a -> a -> Bool + a << b = True + +instance EQ (a -> b) where + f === g = True + +instance ORD (a -> b) + +f = (<<) === (<<) +--f :: (EQ a,Num a) => a -> a -> Bool + + +{- +instance EQ NUM where +-- a /= b = False + a === b = True +-- a /= b = False + +-} diff --git a/testsuite/tests/typecheck/should_fail/tcfail040.stderr b/testsuite/tests/typecheck/should_fail/tcfail040.stderr new file mode 100644 index 0000000000..8d30ec57a2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail040.stderr @@ -0,0 +1,8 @@ + +tcfail040.hs:19:14: + Ambiguous type variable `a0' in the constraint: + (ORD a0) arising from a use of `<<' + Probable fix: add a type signature that fixes these type variable(s) + In the second argument of `(===)', namely `(<<)' + In the expression: (<<) === (<<) + In an equation for `f': f = (<<) === (<<) diff --git a/testsuite/tests/typecheck/should_fail/tcfail040.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail040.stderr-hugs new file mode 100644 index 0000000000..2a12f6a15b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail040.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail040.hs":19 - Unresolved top-level overloading +*** Binding : f +*** Outstanding context : ORD b diff --git a/testsuite/tests/typecheck/should_fail/tcfail042.hs b/testsuite/tests/typecheck/should_fail/tcfail042.hs new file mode 100644 index 0000000000..5fdf6c61b6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail042.hs @@ -0,0 +1,30 @@ +module ShouldFail where + +-- !!! weird class/instance examples off the haskell list +-- + +class Foo a where foo :: a -> a +class Foo a => Bar a where bar :: a -> a + + +instance Num a => Foo [a] where + foo [] = [] + foo (x:xs) = map (x+) xs + + +instance (Eq a, Show a) => Bar [a] where + bar [] = [] + bar (x:xs) = foo xs where u = x==x + v = show x + +------------------------------------------ + +{- +class Foo a => Bar2 a where bar2 :: a -> a + +instance (Eq a, Show a) => Foo [a] + +instance Num a => Bar2 [a] + +data X a = X a +-} diff --git a/testsuite/tests/typecheck/should_fail/tcfail042.stderr b/testsuite/tests/typecheck/should_fail/tcfail042.stderr new file mode 100644 index 0000000000..ba2b83fd96 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail042.stderr @@ -0,0 +1,24 @@ + +tcfail042.hs:15:10: + Could not deduce (Num a) + arising from the superclasses of an instance declaration + from the context (Eq a, Show a) + bound by the instance declaration at tcfail042.hs:15:10-34 + Possible fix: + add (Num a) to the context of the instance declaration + In the instance declaration for `Bar [a]' + +tcfail042.hs:17:18: + Could not deduce (Num a) arising from a use of `foo' + from the context (Eq a, Show a) + bound by the instance declaration at tcfail042.hs:15:10-34 + Possible fix: + add (Num a) to the context of the instance declaration + In the expression: foo xs + In an equation for `bar': + bar (x : xs) + = foo xs + where + u = x == x + v = show x + In the instance declaration for `Bar [a]' diff --git a/testsuite/tests/typecheck/should_fail/tcfail042.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail042.stderr-hugs new file mode 100644 index 0000000000..87c290d829 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail042.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail042.hs":15 - Cannot build superclass instance +*** Instance : Bar [a] +*** Context supplied : (Eq a, Show a) +*** Required superclass : Foo [a] diff --git a/testsuite/tests/typecheck/should_fail/tcfail043.hs b/testsuite/tests/typecheck/should_fail/tcfail043.hs new file mode 100644 index 0000000000..184a4e23bf --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail043.hs @@ -0,0 +1,219 @@ +-- The translation of this program should assign only one dictionary to +-- the function search (an Ord dictionary). Instead, it assigns two. +-- The output produced currently displays this. + +-- 10/12/92: This program is actually erroneous. The pattern-binding for +-- search falls under the monomorphism restriction, and there is no +-- call to search which might fix its type. So there should be a complaint. +-- But the actual error message is horrible: +-- +-- "bug001.hs", line 26: Ambiguous overloading: +-- class "Ord_", type "a" (at a use of an overloaded identifier: gt) +-- class "Eq_", type "a" (at a use of an overloaded identifier: eq) + + +module TcFail where + +class Eq_ a where + eq :: a -> a -> Bool + +instance Eq_ Int where + eq = eqIntEq + +instance (Eq_ a) => Eq_ [a] where + eq = \ xs ys -> + if (null xs) + then (null ys) + else if (null ys) + then False + else (&&) (eq (hd xs) (hd ys)) (eq (tl xs) (tl ys)) + +class (Eq_ a) => Ord_ a where + gt :: a -> a -> Bool + +instance Ord_ Int where + gt = ordIntGt + +search + = \ a bs -> if gt (hd bs) a + then False + else if eq a (hd bs) then True else search a (tl bs) + + +hd :: [a] -> a +hd (a:as) = a + +tl :: [a] -> [a] +tl (a:as) = as + +ordIntGt :: Int -> Int -> Bool +ordIntGt 2 3 = True + +eqIntEq :: Int -> Int -> Bool +eqIntEq 2 3 = True + + + + +{- + +=============================================== +Main.Eq__INST_PreludeBuiltin.Int = + let + AbsBinds [] [] [(eq, eq)] + {- nonrec -} + {-# LINE 2 "test3.hs" -} + + eq :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool + eq = Main.eqIntEq + in ({-dict-} [] [eq]) + +Main.Eq__INST_PreludeBuiltin.List = + /\ t135 -> + \{-dict-} _dict138 -> + let + {- nonrec -} + _dict136 = {-singleDict-} _dict138 + {- nonrec -} + _dict129 = {-singleDict-} _dict136 + AbsBinds [] [] [(eq, eq)] + {- nonrec -} + + _dict133 = + Main.Eq__INST_PreludeBuiltin.List + [t135] [{-singleDict-} _dict136] + {- nonrec -} + {-# LINE 5 "test3.hs" -} + + eq :: [t135] -> [t135] -> PreludeCore.Bool + eq = \ xs ys -> + +if (Main.null t135) xs then + (Main.null t135) ys + else + + if (Main.null t135) ys then + PreludeCore.False + else + + Main.and + + + ((Main.Eq_.eq t135 _dict129) + + + ((Main.hd t135) xs) + ((Main.hd t135) ys)) + + + + + + +(Main.Eq_.eq [t135] _dict133) + + + + ((Main.tl t135) xs) + ((Main.tl t135) ys)) + in ({-dict-} [] [eq]) +Main.Ord__INST_PreludeBuiltin.Int = + let + {- nonrec -} + _dict142 = Main.Eq__INST_PreludeBuiltin.Int [] [] + AbsBinds [] [] [(gt, gt)] + {- nonrec -} + {-# LINE 16 "test3.hs" -} + + gt :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool + gt = Main.ordIntGt + in ({-dict-} [_dict142] [gt]) + +Main.Eq_.eq = /\ a -> \{-classdict-} [] [eq] -> eq + +Main.Ord_.gt = /\ a -> \{-classdict-} [_dict56] [gt] -> gt + +Main.Ord__TO_Main.Eq_ = /\ a -> \{-classdict-} [_dict58] [gt] -> ???_dict58??? + +AbsBinds [t60] [] [(hd, Main.hd)] + {- nonrec -} + + + + hd :: [t60] -> t60 + hd (a PreludeBuiltin.: as) + = a + +AbsBinds [t68] [] [(tl, Main.tl)] + {- nonrec -} + + + + + tl :: [t68] -> [t68] + tl (a PreludeBuiltin.: as) + = as + + +AbsBinds [t91] [_dict85, _dict88] [(search, Main.search)] + {- rec -} + {-# LINE 19 "test3.hs" -} + + + search :: t91 -> [t91] -> PreludeCore.Bool + search + = \ a bs -> + + +if (Main.Ord_.gt t91 _dict85) ((Main.hd t91) bs) a then + PreludeCore.False + else + + if (Main.Eq_.eq t91 _dict88) a ((Main.hd t91) bs) then + PreludeCore.True + else + + search a ((Main.tl t91) bs) +AbsBinds [] [] [(and, Main.and)] + {- nonrec -} + and :: PreludeCore.Bool -> PreludeCore.Bool -> PreludeCore.Bool + and PreludeCore.True PreludeCore.True + = PreludeCore.True +AbsBinds [] [] [(ordIntGt, Main.ordIntGt)] + {- nonrec -} + _dict97 = PreludeCore.Num_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict98 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict100 = PreludeCore.Num_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict101 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + + + + ordIntGt :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool + ordIntGt + 2 3 = PreludeCore.True +AbsBinds [] [] [(eqIntEq, Main.eqIntEq)] + {- nonrec -} + _dict105 = PreludeCore.Num_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict106 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict108 = PreludeCore.Num_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict109 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + + eqIntEq :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool + eqIntEq + 2 3 = PreludeCore.True + + +AbsBinds [t112] [] [(null, Main.null)] + {- nonrec -} + + null :: [t112] -> PreludeCore.Bool + null [] = PreludeCore.True +-} diff --git a/testsuite/tests/typecheck/should_fail/tcfail043.stderr b/testsuite/tests/typecheck/should_fail/tcfail043.stderr new file mode 100644 index 0000000000..7cd3faf53e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail043.stderr @@ -0,0 +1,21 @@ + +tcfail043.hs:38:17: + Ambiguous type variable `a0' in the constraints: + (Ord_ a0) arising from a use of `gt' at tcfail043.hs:38:17-18 + (Eq_ a0) arising from a use of `eq' at tcfail043.hs:40:25-26 + Possible cause: the monomorphism restriction applied to the following: + search :: a0 -> [a0] -> Bool (bound at tcfail043.hs:37:1) + Probable fix: give these definition(s) an explicit type signature + or use -XNoMonomorphismRestriction + In the expression: gt (hd bs) a + In the expression: + if gt (hd bs) a then + False + else + if eq a (hd bs) then True else search a (tl bs) + In the expression: + \ a bs + -> if gt (hd bs) a then + False + else + if eq a (hd bs) then True else search a (tl bs) diff --git a/testsuite/tests/typecheck/should_fail/tcfail043.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail043.stderr-hugs new file mode 100644 index 0000000000..2153721a6d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail043.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail043.hs":38 - Unresolved top-level overloading +*** Binding : search +*** Outstanding context : Ord_ b diff --git a/testsuite/tests/typecheck/should_fail/tcfail044.hs b/testsuite/tests/typecheck/should_fail/tcfail044.hs new file mode 100644 index 0000000000..b271d0f977 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail044.hs @@ -0,0 +1,22 @@ +-- !!! tcfail044: duplicated type variable in instance decls +-- +module ShouldFail where + +instance (Eq a) => Eq (a->a) +instance Show (a->b) + +instance (Num a) => Num (a->a) where + f + g = \x -> f x + g x + negate f = \x -> - (f x) + f * g = \x -> f x * g x + fromInteger n = \x -> fromInteger n + +ss :: Float -> Float +cc :: Float -> Float +tt :: Float -> Float + +ss = sin * sin +cc = cos * cos +tt = ss + cc + +--main = putStr ((show (tt 0.4))++ " "++(show (tt 1.652))) diff --git a/testsuite/tests/typecheck/should_fail/tcfail044.stderr b/testsuite/tests/typecheck/should_fail/tcfail044.stderr new file mode 100644 index 0000000000..03ad2fb705 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail044.stderr @@ -0,0 +1,16 @@ + +tcfail044.hs:5:20: + Illegal instance declaration for `Eq (a -> a)' + (All instance types must be of the form (T a1 ... an) + where a1 ... an are *distinct type variables*, + and each type variable appears at most once in the instance head. + Use -XFlexibleInstances if you want to disable this.) + In the instance declaration for `Eq (a -> a)' + +tcfail044.hs:8:21: + Illegal instance declaration for `Num (a -> a)' + (All instance types must be of the form (T a1 ... an) + where a1 ... an are *distinct type variables*, + and each type variable appears at most once in the instance head. + Use -XFlexibleInstances if you want to disable this.) + In the instance declaration for `Num (a -> a)' diff --git a/testsuite/tests/typecheck/should_fail/tcfail044.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail044.stderr-hugs new file mode 100644 index 0000000000..6fe05624cd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail044.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail044.hs":5 - Repeated type variable "a" in instance head diff --git a/testsuite/tests/typecheck/should_fail/tcfail046.hs b/testsuite/tests/typecheck/should_fail/tcfail046.hs new file mode 100644 index 0000000000..67225acde0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail046.hs @@ -0,0 +1,27 @@ +-- !! function types in deriving Eq things +-- From a bug report by Dave Harrison <D.A.Harrison@newcastle.ac.uk> + +module ShouldFail where + + +type Process a = Pid -> Time -> Message a -> ( MessList a, + Continuation a) + +data Continuation a = Do (Process a) deriving Eq + + +type ProcList a = [ (Pid, Status, Process a) ] +data Status = Active | Passive | Busy Integer | Terminated + deriving Eq + + +data Message a = Create (Process a) | Created Pid | Activate Pid | + Passivate Pid | Terminate Pid | Wait Pid Time | + Query Pid a | Data Pid a | Event | + Output Pid String + deriving Eq + +type MessList a = [ Message a ] + +type Pid = Integer +type Time = Integer diff --git a/testsuite/tests/typecheck/should_fail/tcfail046.stderr b/testsuite/tests/typecheck/should_fail/tcfail046.stderr new file mode 100644 index 0000000000..1b668d07a6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail046.stderr @@ -0,0 +1,18 @@ + +tcfail046.hs:10:50: + No instance for (Eq (Process a)) + arising from the 'deriving' clause of a data type declaration + Possible fix: + add an instance declaration for (Eq (Process a)) + or use a standalone 'deriving instance' declaration, + so you can specify the instance context yourself + When deriving the instance for (Eq (Continuation a)) + +tcfail046.hs:22:25: + No instance for (Eq (Process a)) + arising from the 'deriving' clause of a data type declaration + Possible fix: + add an instance declaration for (Eq (Process a)) + or use a standalone 'deriving instance' declaration, + so you can specify the instance context yourself + When deriving the instance for (Eq (Message a)) diff --git a/testsuite/tests/typecheck/should_fail/tcfail046.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail046.stderr-hugs new file mode 100644 index 0000000000..583bd7ffd8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail046.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail046.hs":9 - An instance of Eq (Process a) is required to derive Eq (Continuation a) diff --git a/testsuite/tests/typecheck/should_fail/tcfail047.hs b/testsuite/tests/typecheck/should_fail/tcfail047.hs new file mode 100644 index 0000000000..f3cdb19741 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail047.hs @@ -0,0 +1,7 @@ +module ShouldFail where + +class A a where + op1 :: a -> a + +instance A (a,(b,c)) where + op1 a = a diff --git a/testsuite/tests/typecheck/should_fail/tcfail047.stderr b/testsuite/tests/typecheck/should_fail/tcfail047.stderr new file mode 100644 index 0000000000..e99d9df755 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail047.stderr @@ -0,0 +1,8 @@ + +tcfail047.hs:6:10: + Illegal instance declaration for `A (a, (b, c))' + (All instance types must be of the form (T a1 ... an) + where a1 ... an are *distinct type variables*, + and each type variable appears at most once in the instance head. + Use -XFlexibleInstances if you want to disable this.) + In the instance declaration for `A (a, (b, c))' diff --git a/testsuite/tests/typecheck/should_fail/tcfail047.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail047.stderr-hugs new file mode 100644 index 0000000000..8b2a529fe8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail047.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail047.hs":6 - Syntax error in instance head (variable expected) diff --git a/testsuite/tests/typecheck/should_fail/tcfail048.hs b/testsuite/tests/typecheck/should_fail/tcfail048.hs new file mode 100644 index 0000000000..f4400e2fa0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail048.hs @@ -0,0 +1,4 @@ +module ShouldFail where + +class (B a) => C a where + op1 :: a -> a diff --git a/testsuite/tests/typecheck/should_fail/tcfail048.stderr b/testsuite/tests/typecheck/should_fail/tcfail048.stderr new file mode 100644 index 0000000000..569b85f915 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail048.stderr @@ -0,0 +1,2 @@ + +tcfail048.hs:3:7: Not in scope: type constructor or class `B' diff --git a/testsuite/tests/typecheck/should_fail/tcfail048.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail048.stderr-hugs new file mode 100644 index 0000000000..8ae3da6dea --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail048.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail048.hs":3 - Undefined class "B" diff --git a/testsuite/tests/typecheck/should_fail/tcfail049.hs b/testsuite/tests/typecheck/should_fail/tcfail049.hs new file mode 100644 index 0000000000..64dee54a5c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail049.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +f x = g x diff --git a/testsuite/tests/typecheck/should_fail/tcfail049.stderr b/testsuite/tests/typecheck/should_fail/tcfail049.stderr new file mode 100644 index 0000000000..750a65bc3c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail049.stderr @@ -0,0 +1,2 @@ + +tcfail049.hs:3:7: Not in scope: `g' diff --git a/testsuite/tests/typecheck/should_fail/tcfail049.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail049.stderr-hugs new file mode 100644 index 0000000000..95c25d66e3 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail049.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail049.hs":3 - Undefined variable "g" diff --git a/testsuite/tests/typecheck/should_fail/tcfail050.hs b/testsuite/tests/typecheck/should_fail/tcfail050.hs new file mode 100644 index 0000000000..c0cee979f7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail050.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +f x = B x diff --git a/testsuite/tests/typecheck/should_fail/tcfail050.stderr b/testsuite/tests/typecheck/should_fail/tcfail050.stderr new file mode 100644 index 0000000000..9115af93fb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail050.stderr @@ -0,0 +1,2 @@ + +tcfail050.hs:3:7: Not in scope: data constructor `B' diff --git a/testsuite/tests/typecheck/should_fail/tcfail050.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail050.stderr-hugs new file mode 100644 index 0000000000..d3153a8875 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail050.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail050.hs":3 - Undefined data constructor "B" diff --git a/testsuite/tests/typecheck/should_fail/tcfail051.hs b/testsuite/tests/typecheck/should_fail/tcfail051.hs new file mode 100644 index 0000000000..1b8e251c40 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail051.hs @@ -0,0 +1,4 @@ +module ShouldFail where + +instance B Bool where + op1 a = a diff --git a/testsuite/tests/typecheck/should_fail/tcfail051.stderr b/testsuite/tests/typecheck/should_fail/tcfail051.stderr new file mode 100644 index 0000000000..97d4b13a1e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail051.stderr @@ -0,0 +1,4 @@ + +tcfail051.hs:3:10: Not in scope: type constructor or class `B' + +tcfail051.hs:4:2: `op1' is not a (visible) method of class `B' diff --git a/testsuite/tests/typecheck/should_fail/tcfail051.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail051.stderr-hugs new file mode 100644 index 0000000000..6f6d9689cd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail051.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail051.hs":3 - Undefined class "B" diff --git a/testsuite/tests/typecheck/should_fail/tcfail052.hs b/testsuite/tests/typecheck/should_fail/tcfail052.hs new file mode 100644 index 0000000000..e9be21e6f2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail052.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +data C a = B a c diff --git a/testsuite/tests/typecheck/should_fail/tcfail052.stderr b/testsuite/tests/typecheck/should_fail/tcfail052.stderr new file mode 100644 index 0000000000..9ffa31c227 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail052.stderr @@ -0,0 +1,2 @@ + +tcfail052.hs:3:16: Not in scope: type variable `c' diff --git a/testsuite/tests/typecheck/should_fail/tcfail052.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail052.stderr-hugs new file mode 100644 index 0000000000..57866de750 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail052.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail052.hs":3 - Undefined type variable "c" diff --git a/testsuite/tests/typecheck/should_fail/tcfail053.hs b/testsuite/tests/typecheck/should_fail/tcfail053.hs new file mode 100644 index 0000000000..d13e606434 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail053.hs @@ -0,0 +1,3 @@ +module TcFail where + +data B = C A diff --git a/testsuite/tests/typecheck/should_fail/tcfail053.stderr b/testsuite/tests/typecheck/should_fail/tcfail053.stderr new file mode 100644 index 0000000000..9889c3f0f6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail053.stderr @@ -0,0 +1,2 @@ + +tcfail053.hs:3:12: Not in scope: type constructor or class `A' diff --git a/testsuite/tests/typecheck/should_fail/tcfail053.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail053.stderr-hugs new file mode 100644 index 0000000000..85bd6abcc6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail053.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail053.hs":3 - Undefined type constructor "A" diff --git a/testsuite/tests/typecheck/should_fail/tcfail054.hs b/testsuite/tests/typecheck/should_fail/tcfail054.hs new file mode 100644 index 0000000000..a4e724cf18 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail054.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +f (B a) = True diff --git a/testsuite/tests/typecheck/should_fail/tcfail054.stderr b/testsuite/tests/typecheck/should_fail/tcfail054.stderr new file mode 100644 index 0000000000..1a5cfca053 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail054.stderr @@ -0,0 +1,2 @@ + +tcfail054.hs:3:4: Not in scope: data constructor `B' diff --git a/testsuite/tests/typecheck/should_fail/tcfail054.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail054.stderr-hugs new file mode 100644 index 0000000000..2a20bb69d2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail054.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail054.hs":3 - Undefined data constructor "B" diff --git a/testsuite/tests/typecheck/should_fail/tcfail055.hs b/testsuite/tests/typecheck/should_fail/tcfail055.hs new file mode 100644 index 0000000000..f61c5a81be --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail055.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +f x = (x + 1 :: Int) :: Float diff --git a/testsuite/tests/typecheck/should_fail/tcfail055.stderr b/testsuite/tests/typecheck/should_fail/tcfail055.stderr new file mode 100644 index 0000000000..ac012da98e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail055.stderr @@ -0,0 +1,5 @@ + +tcfail055.hs:3:8: + Couldn't match expected type `Float' with actual type `Int' + In the expression: (x + 1 :: Int) :: Float + In an equation for `f': f x = (x + 1 :: Int) :: Float diff --git a/testsuite/tests/typecheck/should_fail/tcfail055.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail055.stderr-hugs new file mode 100644 index 0000000000..c9d13c2991 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail055.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail055.hs":3 - Type error in type annotation +*** Term : x + 1 +*** Type : Int +*** Does not match : Float diff --git a/testsuite/tests/typecheck/should_fail/tcfail056.hs b/testsuite/tests/typecheck/should_fail/tcfail056.hs new file mode 100644 index 0000000000..a8a1315be7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail056.hs @@ -0,0 +1,11 @@ +module ShouldFail where + +data Foo = MkFoo Bool + +instance Eq Foo where + (MkFoo x) == (MkFoo y) = x == y + +instance Eq Foo where + -- forgot to type "Ord" above + (MkFoo x) <= (MkFoo y) = x <= y + diff --git a/testsuite/tests/typecheck/should_fail/tcfail056.stderr b/testsuite/tests/typecheck/should_fail/tcfail056.stderr new file mode 100644 index 0000000000..09505ed945 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail056.stderr @@ -0,0 +1,2 @@ + +tcfail056.hs:10:15: `<=' is not a (visible) method of class `Eq' diff --git a/testsuite/tests/typecheck/should_fail/tcfail056.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail056.stderr-hugs new file mode 100644 index 0000000000..d1521e1a78 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail056.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail056.hs":8 - Overlapping instances for class "Eq" +*** This instance : Eq Foo +*** Overlaps with : Eq Foo +*** Common instance : Eq Foo diff --git a/testsuite/tests/typecheck/should_fail/tcfail057.hs b/testsuite/tests/typecheck/should_fail/tcfail057.hs new file mode 100644 index 0000000000..9659cf0801 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail057.hs @@ -0,0 +1,6 @@ +module ShouldFail where + +-- !!! inadvertently using -> instead of => + +f :: (RealFrac a) -> a -> a +f x = x diff --git a/testsuite/tests/typecheck/should_fail/tcfail057.stderr b/testsuite/tests/typecheck/should_fail/tcfail057.stderr new file mode 100644 index 0000000000..d67b969f37 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail057.stderr @@ -0,0 +1,5 @@ + +tcfail057.hs:5:7: + Class `RealFrac' used as a type + In the type signature for `f': + f :: (RealFrac a) -> a -> a diff --git a/testsuite/tests/typecheck/should_fail/tcfail057.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail057.stderr-hugs new file mode 100644 index 0000000000..c18a43df4a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail057.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail057.hs":5 - Undefined type constructor "RealFrac" diff --git a/testsuite/tests/typecheck/should_fail/tcfail058.hs b/testsuite/tests/typecheck/should_fail/tcfail058.hs new file mode 100644 index 0000000000..2763e97bc7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail058.hs @@ -0,0 +1,7 @@ +module ShouldFail where +import Data.Array + +-- !!! inadvertently using => instead of -> + +f :: (Array a) => a -> b +f x = x diff --git a/testsuite/tests/typecheck/should_fail/tcfail058.stderr b/testsuite/tests/typecheck/should_fail/tcfail058.stderr new file mode 100644 index 0000000000..4c017c8681 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail058.stderr @@ -0,0 +1,4 @@ +
+tcfail058.hs:6:6:
+ Type constructor `Array' used as a class
+ In the type signature for `f': f :: Array a => a -> b
diff --git a/testsuite/tests/typecheck/should_fail/tcfail058.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail058.stderr-hugs new file mode 100644 index 0000000000..dee94737b2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail058.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail058.hs":6 - Undefined class "Array" diff --git a/testsuite/tests/typecheck/should_fail/tcfail061.hs b/testsuite/tests/typecheck/should_fail/tcfail061.hs new file mode 100644 index 0000000000..35e502c64e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail061.hs @@ -0,0 +1,11 @@ +-- !! signature bugs exposed by Sigbjorn Finne +-- +module ShouldFail where + +type Flarp a = (b,b) + +--More fun can be had if we change the signature slightly + +type Bob a = a + +type Flarp2 a = Bob (b,b) diff --git a/testsuite/tests/typecheck/should_fail/tcfail061.stderr b/testsuite/tests/typecheck/should_fail/tcfail061.stderr new file mode 100644 index 0000000000..a047863e9b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail061.stderr @@ -0,0 +1,8 @@ + +tcfail061.hs:5:17: Not in scope: type variable `b' + +tcfail061.hs:5:19: Not in scope: type variable `b' + +tcfail061.hs:11:22: Not in scope: type variable `b' + +tcfail061.hs:11:24: Not in scope: type variable `b' diff --git a/testsuite/tests/typecheck/should_fail/tcfail061.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail061.stderr-hugs new file mode 100644 index 0000000000..47faffae38 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail061.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail061.hs":11 - Undefined type variable "b" diff --git a/testsuite/tests/typecheck/should_fail/tcfail062.hs b/testsuite/tests/typecheck/should_fail/tcfail062.hs new file mode 100644 index 0000000000..f37dc1e556 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail062.hs @@ -0,0 +1,37 @@ +-- !!! bug report from Satnam +-- +module ShouldFail +where + +type Module = (String,[Declaration]) + +data Declaration + = Architecture String StructuralExpression | + Behaviour String Parameter Parameter BehaviouralExpression + deriving (Eq, Show) + +data Parameter = ParameterVariable String | ParameterList [Parameter] + deriving (Eq, Show) + +nameOfModule :: Module -> String +nameOfModule (name, _) = name + +data StructuralExpression + = Variable String | + Serial StructuralExpression StructuralExpression | + Par [StructuralExpression] + deriving (Eq, Show) + +data BehaviouralExpression + = BehaviouralVariable String + | AndExpr BehaviouralExpression BehaviouralExpression + | OrExpr BehaviouralExpression BehaviouralExpression + | NotExpr BehaviouralExpression + deriving (Eq, Show) + + +type BehaviouralRelation + = (behaviouralExpression, behaviouralExpression) +---- ^ typo ----------------^ typo (but so what?) + +type BehaviouralRelationList = [BehaviouralRelation] diff --git a/testsuite/tests/typecheck/should_fail/tcfail062.stderr b/testsuite/tests/typecheck/should_fail/tcfail062.stderr new file mode 100644 index 0000000000..9ee1bb75a9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail062.stderr @@ -0,0 +1,6 @@ + +tcfail062.hs:34:6: + Not in scope: type variable `behaviouralExpression' + +tcfail062.hs:34:29: + Not in scope: type variable `behaviouralExpression' diff --git a/testsuite/tests/typecheck/should_fail/tcfail062.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail062.stderr-hugs new file mode 100644 index 0000000000..261199229e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail062.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail062.hs":34 - Undefined type variable "behaviouralExpression" diff --git a/testsuite/tests/typecheck/should_fail/tcfail063.hs b/testsuite/tests/typecheck/should_fail/tcfail063.hs new file mode 100644 index 0000000000..6e012dbb24 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail063.hs @@ -0,0 +1,7 @@ +-- !!! no type variable on a context +-- !!! reported by Sigbjorn Finne + +module ShouldFail where + +moby :: Num => Int -> a -> Int +moby x y = x+y diff --git a/testsuite/tests/typecheck/should_fail/tcfail063.stderr b/testsuite/tests/typecheck/should_fail/tcfail063.stderr new file mode 100644 index 0000000000..1a1ee507f5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail063.stderr @@ -0,0 +1,5 @@ + +tcfail063.hs:6:9: + `Num' is not applied to enough type arguments + Expected kind `?', but `Num' has kind `* -> *' + In the type signature for `moby': moby :: Num => Int -> a -> Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail063.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail063.stderr-hugs new file mode 100644 index 0000000000..3ddc482a66 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail063.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail063.hs":6 - Haskell 98 does not support tag classes diff --git a/testsuite/tests/typecheck/should_fail/tcfail065.hs b/testsuite/tests/typecheck/should_fail/tcfail065.hs new file mode 100644 index 0000000000..3029b1978c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail065.hs @@ -0,0 +1,37 @@ +{- + +------- Forwarded Message + +Date: Wed, 30 Nov 1994 16:34:18 +0100 +From: John Hughes <rjmh@cs.chalmers.se> +To: augustss@cs.chalmers.se, simonpj@dcs.gla.ac.uk +Subject: Nice little program + + +Lennart, Simon, + +You might like to look at the fun little program below. + +THUMBS DOWN to hbc for compiling it (it prints [72, 101, 108, 108, 111]) +THUMBS UP to ghc for rejecting it --- but what an error message! +nhc and gofer both reject it with the right error message. +I haven't tried Yale Haskell. + +Enjoy! +- ---------------------------- +-} + +class HasX a where + setX :: x->a->a + +data X x = X x +instance HasX (X x) where + setX x (X _) = X x + +changetype x = case setX x (X (error "change type!")) of X y->y + +main = print (changetype "Hello" :: [Int]) + +{- +------- End of Forwarded Message +-} diff --git a/testsuite/tests/typecheck/should_fail/tcfail065.stderr b/testsuite/tests/typecheck/should_fail/tcfail065.stderr new file mode 100644 index 0000000000..9d94b920ff --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail065.stderr @@ -0,0 +1,11 @@ + +tcfail065.hs:29:20: + Couldn't match type `x1' with `x' + `x1' is a rigid type variable bound by + the type signature for setX :: x1 -> X x -> X x + at tcfail065.hs:29:3 + `x' is a rigid type variable bound by + the instance declaration at tcfail065.hs:28:18 + In the first argument of `X', namely `x' + In the expression: X x + In an equation for `setX': setX x (X _) = X x diff --git a/testsuite/tests/typecheck/should_fail/tcfail065.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail065.stderr-hugs new file mode 100644 index 0000000000..ef6178e6f2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail065.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail065.hs":29 - Inferred type is not general enough +*** Expression : setX +*** Expected type : HasX (X a) => b -> X a -> X a +*** Inferred type : HasX (X a) => a -> X a -> X a diff --git a/testsuite/tests/typecheck/should_fail/tcfail067.hs b/testsuite/tests/typecheck/should_fail/tcfail067.hs new file mode 100644 index 0000000000..bcdb0c75ed --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail067.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DatatypeContexts #-} +module ShouldFail where + +infixr 1 `rangeOf` + +data Ord a => SubRange a = SubRange (a, a) a + +type IntSubRange = SubRange Int + + +subRangeValue :: SubRange a -> a +subRangeValue (SubRange (lower, upper) value) = value + +subRange :: SubRange a -> (a, a) +subRange (SubRange r value) = r + +newRange :: (Ord a, Show a) => (a, a) -> a -> SubRange a +newRange r value = checkRange (SubRange r value) + + +checkRange :: (Ord a, Show a) => SubRange a -> SubRange a +checkRange (SubRange (lower, upper) value) + = if (value < lower) || (value > upper) then + error ("### sub range error. range = " ++ show lower ++ + ".." ++ show upper ++ " value = " ++ show value ++ "\n") + else + SubRange (lower, upper) value + + +instance Eq a => Eq (SubRange a) where + (==) a b = subRangeValue a == subRangeValue b + +instance (Ord a) => Ord (SubRange a) where + (<) = relOp (<) + (<=) = relOp (<=) + (>=) = relOp (>=) + (>) = relOp (>) + +relOp :: Ord a => (a->a->Bool) -> SubRange a -> SubRange a -> Bool +relOp op a b = (subRangeValue a) `op` (subRangeValue b) + +rangeOf :: (Ord a, Show a) => SubRange a -> SubRange a -> SubRange a +rangeOf a b = checkRange (SubRange (subRange b) (subRangeValue a)) + +showRange :: Show a => SubRange a -> String +showRange (SubRange (lower, upper) value) + = show value ++ " :" ++ show lower ++ ".." ++ show upper + +showRangePair :: (Show a, Show b) => (SubRange a, SubRange b) -> String +showRangePair (a, b) + = "(" ++ showRange a ++ ", " ++ showRange b ++ ")" + +showRangeTriple :: (Show a, Show b, Show c) => + (SubRange a, SubRange b, SubRange c) -> String +showRangeTriple (a, b, c) + = "(" ++ showRange a ++ ", " ++ showRange b ++ ", " ++ showRange c ++ ")" + + + +instance Num a => Num (SubRange a) where + negate = numSubRangeNegate + (+) = numSubRangeAdd + (-) = numSubRangeSubtract + (*) = numSubRangeMultiply + fromInteger a = SubRange (fromInteger a, fromInteger a) (fromInteger a) + +numSubRangeNegate :: (Ord a, Num a) => SubRange a -> SubRange a +numSubRangeNegate (SubRange (lower, upper) value) + = checkRange (SubRange (lower, upper) (-value)) + +numSubRangeBinOp :: Num a => (a -> a -> a) -> + SubRange a -> SubRange a -> SubRange a +numSubRangeBinOp op a b + = SubRange (result, result) result + where + result = (subRangeValue a) `op` (subRangeValue b) + +-- partain: +numSubRangeAdd, numSubRangeSubtract, numSubRangeMultiply :: Num a => SubRange a -> SubRange a -> SubRange a + +numSubRangeAdd = numSubRangeBinOp (+) +numSubRangeSubtract = numSubRangeBinOp (-) +numSubRangeMultiply = numSubRangeBinOp (*) + +unsignedBits :: Int -> (Int, Int) +unsignedBits n = (0, 2^n-1) + +signedBits :: Int -> (Int, Int) +signedBits n = (-2^(n-1), 2^(n-1)-1) + + +si_n :: Int -> Int -> IntSubRange +si_n bits value = SubRange (signedBits bits) value + +si8, si10, si16 :: Int -> IntSubRange +si8 = si_n 8 +si10 = si_n 10 +si16 = si_n 16 diff --git a/testsuite/tests/typecheck/should_fail/tcfail067.stderr b/testsuite/tests/typecheck/should_fail/tcfail067.stderr new file mode 100644 index 0000000000..4c69c67391 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail067.stderr @@ -0,0 +1,82 @@ + +tcfail067.hs:1:14: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + +tcfail067.hs:12:16: + No instance for (Ord a) + arising from a use of `SubRange' + In the pattern: SubRange (lower, upper) value + In an equation for `subRangeValue': + subRangeValue (SubRange (lower, upper) value) = value + +tcfail067.hs:15:11: + No instance for (Ord a) + arising from a use of `SubRange' + In the pattern: SubRange r value + In an equation for `subRange': subRange (SubRange r value) = r + +tcfail067.hs:46:12: + Could not deduce (Ord a) arising from a use of `SubRange' + from the context (Show a) + bound by the type signature for + showRange :: Show a => SubRange a -> String + at tcfail067.hs:(46,1)-(47,58) + Possible fix: + add (Ord a) to the context of + the type signature for showRange :: Show a => SubRange a -> String + In the pattern: SubRange (lower, upper) value + In an equation for `showRange': + showRange (SubRange (lower, upper) value) + = show value ++ " :" ++ show lower ++ ".." ++ show upper + +tcfail067.hs:60:10: + Could not deduce (Show (SubRange a)) + arising from the superclasses of an instance declaration + from the context (Num a) + bound by the instance declaration at tcfail067.hs:60:10-34 + Possible fix: + add (Show (SubRange a)) to the context of the instance declaration + or add an instance declaration for (Show (SubRange a)) + In the instance declaration for `Num (SubRange a)' + +tcfail067.hs:61:12: + Could not deduce (Ord a) arising from a use of `numSubRangeNegate' + from the context (Num a) + bound by the instance declaration at tcfail067.hs:60:10-34 + Possible fix: + add (Ord a) to the context of the instance declaration + In the expression: numSubRangeNegate + In an equation for `negate': negate = numSubRangeNegate + In the instance declaration for `Num (SubRange a)' + +tcfail067.hs:65:19: + Could not deduce (Ord a) arising from a use of `SubRange' + from the context (Num a) + bound by the instance declaration at tcfail067.hs:60:10-34 + Possible fix: + add (Ord a) to the context of the instance declaration + In the expression: + SubRange (fromInteger a, fromInteger a) (fromInteger a) + In an equation for `fromInteger': + fromInteger a + = SubRange (fromInteger a, fromInteger a) (fromInteger a) + In the instance declaration for `Num (SubRange a)' + +tcfail067.hs:74:5: + Could not deduce (Ord a) arising from a use of `SubRange' + from the context (Num a) + bound by the type signature for + numSubRangeBinOp :: Num a => + (a -> a -> a) -> SubRange a -> SubRange a -> SubRange a + at tcfail067.hs:(73,1)-(76,53) + Possible fix: + add (Ord a) to the context of + the type signature for + numSubRangeBinOp :: Num a => + (a -> a -> a) -> SubRange a -> SubRange a -> SubRange a + In the expression: SubRange (result, result) result + In an equation for `numSubRangeBinOp': + numSubRangeBinOp op a b + = SubRange (result, result) result + where + result = (subRangeValue a) `op` (subRangeValue b) diff --git a/testsuite/tests/typecheck/should_fail/tcfail067.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail067.stderr-hugs new file mode 100644 index 0000000000..ac6853972f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail067.stderr-hugs @@ -0,0 +1,5 @@ +ERROR "tcfail067.hs":12 - Cannot justify constraints in explicitly typed binding +*** Expression : subRangeValue +*** Type : SubRange a -> a +*** Given context : () +*** Constraints : Ord a diff --git a/testsuite/tests/typecheck/should_fail/tcfail068.hs b/testsuite/tests/typecheck/should_fail/tcfail068.hs new file mode 100644 index 0000000000..beae0f8359 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail068.hs @@ -0,0 +1,90 @@ +-- !! Make sure that state threads don't escape +-- !! (example from Neil Ashton at York) +-- +module ShouldFail where + +import GHC.Arr +import Control.Monad.ST ( runST ) + +type IndTree s t = STArray s (Int,Int) t + +itgen :: Constructed a => (Int,Int) -> a -> IndTree s a +itgen n x = + runST ( + newSTArray ((1,1),n) x) + +itiap :: Constructed a => (Int,Int) -> (a->a) -> IndTree s a -> IndTree s a +itiap i f arr = + runST ( + readSTArray arr i >>= \val -> + writeSTArray arr i (f val) >> + return arr) + +itrap :: Constructed a => ((Int,Int),(Int,Int)) -> (a->a) -> IndTree s a -> IndTree s a +itrap ((i,k),(j,l)) f arr = runST(itrap' i k) + where + itrap' i k = if k > l then return arr + else (itrapsnd i k >> + itrap' i (k+1)) + itrapsnd i k = if i > j then return arr + else (readSTArray arr (i,k) >>= \val -> + writeSTArray arr (i,k) (f val) >> + itrapsnd (i+1) k) + +itrapstate :: Constructed b => ((Int,Int),(Int,Int)) -> (a->b->(a,b)) -> ((Int,Int)->c->a) -> + (a->c) -> c -> IndTree s b -> (c, IndTree s b) +itrapstate ((i,k),(j,l)) f c d s arr = runST(itrapstate' i k s) + where + itrapstate' i k s = if k > l then return (s,arr) + else (itrapstatesnd i k s >>= \(s,arr) -> + itrapstate' i (k+1) s) + itrapstatesnd i k s = if i > j then return (s,arr) + else (readSTArray arr (i,k) >>= \val -> + let (newstate, newval) = f (c (i,k) s) val + in writeSTArray arr (i,k) newval >> + itrapstatesnd (i+1) k (d newstate)) + +-- stuff from Auxiliary: copied here (partain) + +sap :: (a->b) -> (c,a) -> (c,b) +sap f (x,y) = (x, f y) + +fap :: (a->b) -> (a,c) -> (b,c) +fap f (x,y) = (f x, y) + +nonempty :: [a] -> Bool +nonempty [] = False +nonempty (_:_) = True + +-- const :: a -> b -> a +-- const k x = k + +-- id :: a -> a +-- id x = x + +compose :: [a->a] -> a -> a +compose = foldr (.) id + +class Constructed a where + normal :: a -> Bool + +instance Constructed Bool where + normal True = True + normal False = True + +instance Constructed Int where + normal 0 = True + normal n = True + +instance (Constructed a, Constructed b) => Constructed (a,b) where + normal (x,y) = normal x && normal y + +-- pair :: (Constructed a, Constructed b) => a -> b -> (a,b) +-- pair x y | normal x && normal y = (x,y) + +instance Constructed (Maybe a) where + normal Nothing = True + normal (Just _) = True + +just :: Constructed a => a -> Maybe a +just x | normal x = Just x diff --git a/testsuite/tests/typecheck/should_fail/tcfail068.stderr b/testsuite/tests/typecheck/should_fail/tcfail068.stderr new file mode 100644 index 0000000000..afc671a8bf --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail068.stderr @@ -0,0 +1,92 @@ + +tcfail068.hs:14:9: + Could not deduce (s1 ~ s) + from the context (Constructed a) + bound by the type signature for + itgen :: Constructed a => (Int, Int) -> a -> IndTree s a + at tcfail068.hs:(12,1)-(14,31) + `s1' is a rigid type variable bound by + a type expected by the context: GHC.ST.ST s1 (IndTree s a) + at tcfail068.hs:13:9 + `s' is a rigid type variable bound by + the type signature for + itgen :: Constructed a => (Int, Int) -> a -> IndTree s a + at tcfail068.hs:12:1 + Expected type: GHC.ST.ST s (IndTree s1 a) + Actual type: GHC.ST.ST s (STArray s (Int, Int) a) + In the return type of a call of `newSTArray' + In the first argument of `runST', namely + `(newSTArray ((1, 1), n) x)' + +tcfail068.hs:20:22: + Could not deduce (s ~ s1) + from the context (Constructed a) + bound by the type signature for + itiap :: Constructed a => + (Int, Int) -> (a -> a) -> IndTree s a -> IndTree s a + at tcfail068.hs:(17,1)-(21,19) + `s' is a rigid type variable bound by + the type signature for + itiap :: Constructed a => + (Int, Int) -> (a -> a) -> IndTree s a -> IndTree s a + at tcfail068.hs:17:1 + `s1' is a rigid type variable bound by + a type expected by the context: GHC.ST.ST s1 (IndTree s a) + at tcfail068.hs:18:9 + Expected type: STArray s1 (Int, Int) a + Actual type: IndTree s a + In the first argument of `writeSTArray', namely `arr' + In the first argument of `(>>)', namely + `writeSTArray arr i (f val)' + +tcfail068.hs:24:35: + Could not deduce (s ~ s1) + from the context (Constructed a) + bound by the type signature for + itrap :: Constructed a => + ((Int, Int), (Int, Int)) -> (a -> a) -> IndTree s a -> IndTree s a + at tcfail068.hs:(24,1)-(32,41) + `s' is a rigid type variable bound by + the type signature for + itrap :: Constructed a => + ((Int, Int), (Int, Int)) -> (a -> a) -> IndTree s a -> IndTree s a + at tcfail068.hs:24:1 + `s1' is a rigid type variable bound by + a type expected by the context: GHC.ST.ST s1 (IndTree s a) + at tcfail068.hs:24:29 + Expected type: GHC.ST.ST s1 (IndTree s a) + Actual type: GHC.ST.ST s (IndTree s a) + In the return type of a call of `itrap'' + In the first argument of `runST', namely `(itrap' i k)' + +tcfail068.hs:36:46: + Could not deduce (s ~ s1) + from the context (Constructed b) + bound by the type signature for + itrapstate :: Constructed b => + ((Int, Int), (Int, Int)) + -> (a -> b -> (a, b)) + -> ((Int, Int) -> c -> a) + -> (a -> c) + -> c + -> IndTree s b + -> (c, IndTree s b) + at tcfail068.hs:(36,1)-(45,66) + `s' is a rigid type variable bound by + the type signature for + itrapstate :: Constructed b => + ((Int, Int), (Int, Int)) + -> (a -> b -> (a, b)) + -> ((Int, Int) -> c -> a) + -> (a -> c) + -> c + -> IndTree s b + -> (c, IndTree s b) + at tcfail068.hs:36:1 + `s1' is a rigid type variable bound by + a type expected by the context: GHC.ST.ST s1 (c, IndTree s b) + at tcfail068.hs:36:40 + Expected type: GHC.ST.ST s1 (c, IndTree s b) + Actual type: GHC.ST.ST s (c, IndTree s b) + In the return type of a call of `itrapstate'' + In the first argument of `runST', namely `(itrapstate' i k s)' diff --git a/testsuite/tests/typecheck/should_fail/tcfail069.hs b/testsuite/tests/typecheck/should_fail/tcfail069.hs new file mode 100644 index 0000000000..63684fa9db --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail069.hs @@ -0,0 +1,48 @@ +{- +From: Marc van Dongen <dongen@cs.ucc.ie> +Date: Wed, 9 Apr 1997 14:06:39 +0100 (BST) + +I just wanted to report that the erroneous and tiny +program added below can not be compiled within 6MB of +heap (Admitted it can be compiled with a bigger heap). +It was part of a bigger program that could not be +compiled within 20MB of heap. + +[GHC 2.03 and earlier.] Turned out to be a bug in the +error recovery mechanism. + +-} + +module ShouldFail where + +too_much :: [Int] -> [(Int,Int)] -> [(Int,[Int])] -> Bool +too_much ds ((k,m):q1) s0 + = case (list1,list2) of + [] -> error "foo" -- too_much ds q2m s2m + where list1 = ds + list2 = ds + {- + list1 = [k' | k' <- ds, k == k'] + list2 = [k' | k' <- ds, m == k'] + s1 = aas s0 k + raM = [] + raKM = listUnion (\a b -> a) [] [] + s1k = s1 + q1k = raM + s2k = s1 + q2k = raM + s2m = s1 + q2m = raM + s2km = foldr (flip aas) s1 raKM + q2km = raKM + -} + +listUnion :: (v -> v -> Bool) -> [v] -> [v] -> [v] +listUnion _ _ _ + = [] + +aas :: (a,b) -> a -> (a,b) +aas s _ + = s + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail069.stderr b/testsuite/tests/typecheck/should_fail/tcfail069.stderr new file mode 100644 index 0000000000..4c40526b5b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail069.stderr @@ -0,0 +1,7 @@ + +tcfail069.hs:21:7: + Couldn't match expected type `([Int], [Int])' + with actual type `[t0]' + In the pattern: [] + In a case alternative: [] -> error "foo" + In the expression: case (list1, list2) of { [] -> error "foo" } diff --git a/testsuite/tests/typecheck/should_fail/tcfail069.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail069.stderr-hugs new file mode 100644 index 0000000000..4566c1d7a5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail069.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail069.hs":20 - Type error in case pattern +*** Term : [] +*** Type : [a] +*** Does not match : ([Int],[Int]) diff --git a/testsuite/tests/typecheck/should_fail/tcfail070.hs b/testsuite/tests/typecheck/should_fail/tcfail070.hs new file mode 100644 index 0000000000..6cd2a28404 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail070.hs @@ -0,0 +1,16 @@ +{- +From: Wolfgang Drotschmann <drotschm@athene.informatik.uni-bonn.de> +Resent-Date: Thu, 15 May 1997 17:23:09 +0100 + +I'm still using the old ghc-2.01. In one program I ran into a problem +I couldn't fix. But I played around with it, I found a small little +script which reproduces it very well: + +panic! (the `impossible' happened): + tlist +-} + +module TcFail where + +type State = ([Int] Bool) + diff --git a/testsuite/tests/typecheck/should_fail/tcfail070.stderr b/testsuite/tests/typecheck/should_fail/tcfail070.stderr new file mode 100644 index 0000000000..31dd66e77f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail070.stderr @@ -0,0 +1,5 @@ + +tcfail070.hs:15:15: + `[Int]' is applied to too many type arguments + In the type `[Int] Bool' + In the type synonym declaration for `State' diff --git a/testsuite/tests/typecheck/should_fail/tcfail070.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail070.stderr-hugs new file mode 100644 index 0000000000..e96e9fcf6a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail070.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail070.hs":15 - Illegal type "[] Int Bool" in constructor application diff --git a/testsuite/tests/typecheck/should_fail/tcfail071.hs b/testsuite/tests/typecheck/should_fail/tcfail071.hs new file mode 100644 index 0000000000..cbbd25070f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail071.hs @@ -0,0 +1,14 @@ +-- !!! Mis-matched contexts in a mutually recursive group + +{- # LANGUAGE NoRelaxedPolyRec #-} +-- With the new type checker you can't turn off RelaxedPolyRec +-- so this test always succeeds + +module ShouldFail where + +f :: (Ord d) => d -> d +f c = g c + +g :: e -> e +g c = c + where p = f (1 :: Int) diff --git a/testsuite/tests/typecheck/should_fail/tcfail071.stderr b/testsuite/tests/typecheck/should_fail/tcfail071.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail071.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail072.hs b/testsuite/tests/typecheck/should_fail/tcfail072.hs new file mode 100644 index 0000000000..501976e5be --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail072.hs @@ -0,0 +1,24 @@ +{- This program crashed GHC 2.03 + + From: Marc van Dongen <dongen@cs.ucc.ie> + Date: Sat, 31 May 1997 14:35:40 +0100 (BST) + + zonkIdOcc: g_aoQ + + panic! (the `impossible' happened): + lookupBindC:no info! + for: g_aoQ + (probably: data dependencies broken by an optimisation pass) + static binds for: + Tmp.$d1{-rmM,x-} + local binds for: +-} + +module ShouldFail where + +data AB p q = A + | B p q + +g :: (Ord p,Ord q) => (AB p q) -> Bool +g (B _ _) = g A + diff --git a/testsuite/tests/typecheck/should_fail/tcfail072.stderr b/testsuite/tests/typecheck/should_fail/tcfail072.stderr new file mode 100644 index 0000000000..469e75849a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail072.stderr @@ -0,0 +1,14 @@ + +tcfail072.hs:23:13: + Ambiguous type variable `p0' in the constraint: + (Ord p0) arising from a use of `g' + Probable fix: add a type signature that fixes these type variable(s) + In the expression: g A + In an equation for `g': g (B _ _) = g A + +tcfail072.hs:23:13: + Ambiguous type variable `q0' in the constraint: + (Ord q0) arising from a use of `g' + Probable fix: add a type signature that fixes these type variable(s) + In the expression: g A + In an equation for `g': g (B _ _) = g A diff --git a/testsuite/tests/typecheck/should_fail/tcfail072.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail072.stderr-hugs new file mode 100644 index 0000000000..57ea305406 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail072.stderr-hugs @@ -0,0 +1,5 @@ +ERROR "tcfail072.hs":23 - Cannot justify constraints in explicitly typed binding +*** Expression : g +*** Type : (Ord a, Ord b) => AB a b -> Bool +*** Given context : (Ord a, Ord b) +*** Constraints : (Ord c, Ord d) diff --git a/testsuite/tests/typecheck/should_fail/tcfail073.hs b/testsuite/tests/typecheck/should_fail/tcfail073.hs new file mode 100644 index 0000000000..c52d39ae08 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail073.hs @@ -0,0 +1,10 @@ +-- what error do you get if you redefined Prelude instances? + +module ShouldFail where + +f :: (Eq a) => (a,a) -> (a,a) -> Bool +f x y = x == y + +instance Eq a => Eq (a,b) where + (m,n) == (o,p) = m == o + diff --git a/testsuite/tests/typecheck/should_fail/tcfail073.stderr b/testsuite/tests/typecheck/should_fail/tcfail073.stderr new file mode 100644 index 0000000000..4d3bef99ac --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail073.stderr @@ -0,0 +1,5 @@ +
+tcfail073.hs:8:10:
+ Duplicate instance declarations:
+ instance Eq a => Eq (a, b) -- Defined at tcfail073.hs:8:10-25
+ instance (Eq a, Eq b) => Eq (a, b) -- Defined in GHC.Classes
diff --git a/testsuite/tests/typecheck/should_fail/tcfail073.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail073.stderr-hugs new file mode 100644 index 0000000000..8148b896ae --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail073.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail073.hs":8 - Overlapping instances for class "Eq" +*** This instance : Eq (a,b) +*** Overlaps with : Eq (a,b) +*** Common instance : Eq (a,b) diff --git a/testsuite/tests/typecheck/should_fail/tcfail075.hs b/testsuite/tests/typecheck/should_fail/tcfail075.hs new file mode 100644 index 0000000000..c14f276b2d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail075.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE MagicHash #-} + +-- !!! Test top-level unboxed types + +module ShouldFail where + +import GHC.Base +import GHC.Prim + +x = 1# + +y :: Int# +y = x +# 1# + +main = let + z = x -# y + in + if z ># 3# then putStrLn "Yes" + else putStrLn "No" + diff --git a/testsuite/tests/typecheck/should_fail/tcfail075.stderr b/testsuite/tests/typecheck/should_fail/tcfail075.stderr new file mode 100644 index 0000000000..2c251a7a84 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail075.stderr @@ -0,0 +1,6 @@ + +tcfail075.hs:10:1: + Top-level bindings for unlifted types aren't allowed: x = 1# + +tcfail075.hs:13:1: + Top-level bindings for unlifted types aren't allowed: y = x +# 1# diff --git a/testsuite/tests/typecheck/should_fail/tcfail076.hs b/testsuite/tests/typecheck/should_fail/tcfail076.hs new file mode 100644 index 0000000000..abe96c5640 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail076.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Rank2Types #-} + +{- + From: Ralf Hinze <ralf@uran.informatik.uni-bonn.de> + Date: Fri, 15 Aug 1997 15:20:51 +0200 (MET DST) + +I *suppose* that there is a bug in GHC's type checker. The following +program, which I think is ill-typed, passes silently the type checker. +Needless to say that it uses some of GHC's arcane type extensions. +-} + +module ShouldFail where + +data ContT m a = KContT (forall res. (a -> m res) -> m res) +unKContT (KContT x) = x + +callcc :: ((a -> ContT m b) -> ContT m a) -> ContT m a +callcc f = KContT (\cont -> unKContT (f (\a -> KContT (\cont' -> cont a))) cont) + +{- +`ContT' is a continuation monad transformer. Note that we locally +qualify over the result type `res' (sometimes called answer or +output). IMHO this make it impossible to define control constructs +like `callcc'. Let's have a closer look: the code of `callcc' contains +the subexpression `KContT (\cont' -> cont a)'. To be well-typed the +argument of `KContT' must have the type `(All res) => (a -> m res) -> m +res'. Quantification is not possible, however, since the type variable +in `cont's type cannot be forall'd, since it also appears at an outer +level. Right? Or wrong? +-} diff --git a/testsuite/tests/typecheck/should_fail/tcfail076.stderr b/testsuite/tests/typecheck/should_fail/tcfail076.stderr new file mode 100644 index 0000000000..9c380de958 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail076.stderr @@ -0,0 +1,13 @@ + +tcfail076.hs:18:82: + Couldn't match type `res' with `res1' + `res' is a rigid type variable bound by + a type expected by the context: (a -> m res) -> m res + at tcfail076.hs:18:28 + `res1' is a rigid type variable bound by + a type expected by the context: (b -> m res1) -> m res1 + at tcfail076.hs:18:64 + Expected type: m res1 + Actual type: m res + In the return type of a call of `cont' + In the expression: cont a diff --git a/testsuite/tests/typecheck/should_fail/tcfail076.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail076.stderr-hugs new file mode 100644 index 0000000000..a4a05f09ba --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail076.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail076.hs":18 - Inferred type is not general enough +*** Expression : \cont' -> cont a +*** Expected type : (_29 -> _28 a) -> _28 a +*** Inferred type : (_29 -> _28 _30) -> _28 _30 diff --git a/testsuite/tests/typecheck/should_fail/tcfail077.hs b/testsuite/tests/typecheck/should_fail/tcfail077.hs new file mode 100644 index 0000000000..54735b98cd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail077.hs @@ -0,0 +1,8 @@ +module ShouldFail where + +-- !!! declaring a default method in a class that doesn't have that method. + +class Foo a where + op :: a -> a + + op2 x = x -- Bogus declaration diff --git a/testsuite/tests/typecheck/should_fail/tcfail077.stderr b/testsuite/tests/typecheck/should_fail/tcfail077.stderr new file mode 100644 index 0000000000..105604f66c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail077.stderr @@ -0,0 +1,2 @@ + +tcfail077.hs:8:3: `op2' is not a (visible) method of class `Foo' diff --git a/testsuite/tests/typecheck/should_fail/tcfail077.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail077.stderr-hugs new file mode 100644 index 0000000000..eb9afb0826 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail077.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail077.hs":8 - No member "op2" in class "Foo" diff --git a/testsuite/tests/typecheck/should_fail/tcfail078.hs b/testsuite/tests/typecheck/should_fail/tcfail078.hs new file mode 100644 index 0000000000..1054f6d3d6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail078.hs @@ -0,0 +1,6 @@ +module ShouldFail where + +-- !!! Using a type constructor as a class name + +f :: Integer i => i +f = 0 diff --git a/testsuite/tests/typecheck/should_fail/tcfail078.stderr b/testsuite/tests/typecheck/should_fail/tcfail078.stderr new file mode 100644 index 0000000000..60636c94bf --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail078.stderr @@ -0,0 +1,4 @@ +
+tcfail078.hs:5:6:
+ Type constructor `Integer' used as a class
+ In the type signature for `f': f :: Integer i => i
diff --git a/testsuite/tests/typecheck/should_fail/tcfail078.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail078.stderr-hugs new file mode 100644 index 0000000000..22a992258a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail078.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail078.hs":5 - Undefined class "Integer" diff --git a/testsuite/tests/typecheck/should_fail/tcfail079.hs b/testsuite/tests/typecheck/should_fail/tcfail079.hs new file mode 100644 index 0000000000..ec42260d69 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail079.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MagicHash #-} + +module ShouldFail where + +-- !!! unboxed field in newtype declaration + +import GHC.Exts ( Int# ) + +newtype Unboxed = Unboxed Int# + +f = [ Unboxed 1#, Unboxed 2# ] -- shouldn't be allowed! diff --git a/testsuite/tests/typecheck/should_fail/tcfail079.stderr b/testsuite/tests/typecheck/should_fail/tcfail079.stderr new file mode 100644 index 0000000000..149f9b2171 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail079.stderr @@ -0,0 +1,7 @@ + +tcfail079.hs:9:27: + Expecting a lifted type, but `Int#' is unlifted + Expected kind `*', but `Int#' has kind `#' + In the type `Int#' + In the definition of data constructor `Unboxed' + In the newtype declaration for `Unboxed' diff --git a/testsuite/tests/typecheck/should_fail/tcfail080.hs b/testsuite/tests/typecheck/should_fail/tcfail080.hs new file mode 100644 index 0000000000..b2a62cea54 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail080.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- !!! Multi-param type classes test: ambiguity bug + +-- GHC actually accepts this program because +-- q :: Collection c a => a -> Bool +-- and there is no a priori reason to suppose that +-- q would be ambiguous in every context. For example, +-- it could be fine if we had +-- instance c Int where ... +-- Of course, it'd be hard to fill in the "..." in this particular +-- case, but that relies on observations about the form of the types +-- of the class methods, surely beyond what a compiler should do. +-- That's why GHC accepts it + +module ShouldFail where + +class Collection c a where + empty :: c a + add :: a -> c a -> c a + isempty :: c a -> Bool + +singleton x = add x empty + +q x = isempty (singleton x) + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail080.stderr b/testsuite/tests/typecheck/should_fail/tcfail080.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail080.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail080.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail080.stderr-hugs new file mode 100644 index 0000000000..790c9b97fa --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail080.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail080.hs":25 - Ambiguous type signature in inferred type +*** ambiguous type : Collection a b => b -> Bool +*** assigned to : q diff --git a/testsuite/tests/typecheck/should_fail/tcfail082.hs b/testsuite/tests/typecheck/should_fail/tcfail082.hs new file mode 100644 index 0000000000..2d4307acb1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail082.hs @@ -0,0 +1,9 @@ +module Main(main) where +import Data82 +import Inst82_1 +import Inst82_2 + +data Baz = Baz deriving Read + +main = print ((read "FooData")::FooData) + diff --git a/testsuite/tests/typecheck/should_fail/tcfail082.stderr b/testsuite/tests/typecheck/should_fail/tcfail082.stderr new file mode 100644 index 0000000000..4fd34e6022 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail082.stderr @@ -0,0 +1,4 @@ + +tcfail082.hs:2:1: + Failed to load interface for `Data82' + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/typecheck/should_fail/tcfail082.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail082.stderr-hugs new file mode 100644 index 0000000000..028512324c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail082.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail082.hs" - Can't find imported module "Inst82_2" diff --git a/testsuite/tests/typecheck/should_fail/tcfail083.hs b/testsuite/tests/typecheck/should_fail/tcfail083.hs new file mode 100644 index 0000000000..a79be4e7ac --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail083.hs @@ -0,0 +1,16 @@ +module ShouldFail where + +data Bar = Bar { flag :: Bool } deriving( Show ) + +data State = State { bar :: Bar, baz :: Float } + +display :: State -> IO () +display (State{ bar = Bar { flag = f, baz = b }}) = print (f,b) + +-- Typo! The line above should better be: +-- display (State{ bar = Bar { flag = f }, baz = b }) = print (f,b) + +-- GHC 4.04 (as released) crashed with +-- panic! (the `impossible' happened): tcLookupValue: b{-r4n-} +-- Bug reported by Sven Panne + diff --git a/testsuite/tests/typecheck/should_fail/tcfail083.stderr b/testsuite/tests/typecheck/should_fail/tcfail083.stderr new file mode 100644 index 0000000000..77794ffaa6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail083.stderr @@ -0,0 +1,7 @@ + +tcfail083.hs:8:39: + Constructor `Bar' does not have field `baz' + In the pattern: Bar {flag = f, baz = b} + In the pattern: State {bar = Bar {flag = f, baz = b}} + In an equation for `display': + display (State {bar = Bar {flag = f, baz = b}}) = print (f, b) diff --git a/testsuite/tests/typecheck/should_fail/tcfail083.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail083.stderr-hugs new file mode 100644 index 0000000000..5535438428 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail083.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail083.hs":8 - No constructor has all of the fields specified in Bar {flag = f, baz = b} diff --git a/testsuite/tests/typecheck/should_fail/tcfail084.hs b/testsuite/tests/typecheck/should_fail/tcfail084.hs new file mode 100644 index 0000000000..22b5456b1e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail084.hs @@ -0,0 +1,11 @@ +-- !!! Check that using a label belonging to another constructor +-- !!! is flagged as being incorrect. +module ShouldFail where + +data F + = F { x :: Int } + | G { y :: Int } + +z :: F +z = F { y = 2 } + diff --git a/testsuite/tests/typecheck/should_fail/tcfail084.stderr b/testsuite/tests/typecheck/should_fail/tcfail084.stderr new file mode 100644 index 0000000000..1a7e8c3e28 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail084.stderr @@ -0,0 +1,5 @@ + +tcfail084.hs:10:5: + Constructor `F' does not have field `y' + In the expression: F {y = 2} + In an equation for `z': z = F {y = 2} diff --git a/testsuite/tests/typecheck/should_fail/tcfail084.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail084.stderr-hugs new file mode 100644 index 0000000000..2a9e60de1c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail084.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail084.hs":10 - Constructor "F" does not have selected fields in F {y = 2} diff --git a/testsuite/tests/typecheck/should_fail/tcfail085.hs b/testsuite/tests/typecheck/should_fail/tcfail085.hs new file mode 100644 index 0000000000..81036b9dfc --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail085.hs @@ -0,0 +1,10 @@ +-- !!! Check that not supplying bindings for strict fields +-- !!! is flagged as being incorrect. +module ShouldFail where + +data F + = F { x :: Int, y :: !Int } + +z :: F +z = F { x = 2 } + diff --git a/testsuite/tests/typecheck/should_fail/tcfail085.stderr b/testsuite/tests/typecheck/should_fail/tcfail085.stderr new file mode 100644 index 0000000000..c500e7a180 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail085.stderr @@ -0,0 +1,5 @@ + +tcfail085.hs:9:5: + Constructor `F' does not have the required strict field(s): y + In the expression: F {x = 2} + In an equation for `z': z = F {x = 2} diff --git a/testsuite/tests/typecheck/should_fail/tcfail085.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail085.stderr-hugs new file mode 100644 index 0000000000..9f1bc068ca --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail085.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail085.hs":9 - Construction does not define strict field +Expression : F {x = 2} +Field : y diff --git a/testsuite/tests/typecheck/should_fail/tcfail086.hs b/testsuite/tests/typecheck/should_fail/tcfail086.hs new file mode 100644 index 0000000000..46d330daa6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail086.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- !!! Check that we can't derive instances of existential types +module ShouldFail where + +data Ex = forall a. Ex [a] deriving( Eq ) + diff --git a/testsuite/tests/typecheck/should_fail/tcfail086.stderr b/testsuite/tests/typecheck/should_fail/tcfail086.stderr new file mode 100644 index 0000000000..4b221839ea --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail086.stderr @@ -0,0 +1,6 @@ + +tcfail086.hs:6:38: + Can't make a derived instance of `Eq Ex': + Constructor `Ex' must have a Haskell-98 type + Possible fix: use a standalone deriving declaration instead + In the data type declaration for `Ex' diff --git a/testsuite/tests/typecheck/should_fail/tcfail086.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail086.stderr-hugs new file mode 100644 index 0000000000..4c3902b5b6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail086.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail086.hs":6 - Cannot derive instances for types with existentially typed components diff --git a/testsuite/tests/typecheck/should_fail/tcfail087.hs b/testsuite/tests/typecheck/should_fail/tcfail087.hs new file mode 100644 index 0000000000..6055a13d21 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail087.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE UnboxedTuples #-} + +-- !!! Check that unboxed tuples can't be function arguments +module ShouldFail where + +data Ex = Ex (# Int,Int #) + +f :: (# Int,Int #) -> Int +f x = error "urk" + +g (# x,y #) = x + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail087.stderr b/testsuite/tests/typecheck/should_fail/tcfail087.stderr new file mode 100644 index 0000000000..17d9f48537 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail087.stderr @@ -0,0 +1,5 @@ + +tcfail087.hs:6:11: + Illegal unboxed tuple type as function argument: (# Int, Int #) + In the definition of data constructor `Ex' + In the data type declaration for `Ex' diff --git a/testsuite/tests/typecheck/should_fail/tcfail088.hs b/testsuite/tests/typecheck/should_fail/tcfail088.hs new file mode 100644 index 0000000000..6b9f50751e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail088.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Rank2Types, FlexibleInstances #-} + +-- !!! Check that forall types can't be arguments +module ShouldFail where + + +data T s a = MkT s a + +instance Ord a => Ord (forall s. T s a) +-- A for-all should not appear as an argument to Ord + + + +g :: T s (forall b.b) +g = error "urk" diff --git a/testsuite/tests/typecheck/should_fail/tcfail088.stderr b/testsuite/tests/typecheck/should_fail/tcfail088.stderr new file mode 100644 index 0000000000..1bf22ffaa8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail088.stderr @@ -0,0 +1,4 @@ + +tcfail088.hs:9:19: + Illegal polymorphic or qualified type: forall s. T s a + In the instance declaration for `Ord (forall s. T s a)' diff --git a/testsuite/tests/typecheck/should_fail/tcfail088.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail088.stderr-hugs new file mode 100644 index 0000000000..e1b586a2e3 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail088.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail088.hs":9 - Syntax error in type expression (unexpected keyword "forall") diff --git a/testsuite/tests/typecheck/should_fail/tcfail089.hs b/testsuite/tests/typecheck/should_fail/tcfail089.hs new file mode 100644 index 0000000000..142460b0f5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail089.hs @@ -0,0 +1,10 @@ + + +-- !!! Check non-constructors in patterns fail tidily +-- !!! The -O made ghc 4.08 go into a loop! +-- Unfortunately the -O has to go in the Makefile + +module ShouldFail where + +compute :: String -> String +compute ("hd" ++ _) = "_" diff --git a/testsuite/tests/typecheck/should_fail/tcfail089.stderr b/testsuite/tests/typecheck/should_fail/tcfail089.stderr new file mode 100644 index 0000000000..19dd837c13 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail089.stderr @@ -0,0 +1,2 @@ + +tcfail089.hs:10:10: Parse error in pattern: "hd" ++ _ diff --git a/testsuite/tests/typecheck/should_fail/tcfail089.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail089.stderr-hugs new file mode 100644 index 0000000000..c1152bc807 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail089.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail089.hs":10 - Syntax error in declaration (unexpected symbol "++") diff --git a/testsuite/tests/typecheck/should_fail/tcfail090.hs b/testsuite/tests/typecheck/should_fail/tcfail090.hs new file mode 100644 index 0000000000..93a9e9e925 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail090.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MagicHash #-} + +module ShouldFail where + +import GHC.Base + +die :: Int -> ByteArray# +die _ = undefined diff --git a/testsuite/tests/typecheck/should_fail/tcfail090.stderr b/testsuite/tests/typecheck/should_fail/tcfail090.stderr new file mode 100644 index 0000000000..c63ced52c3 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail090.stderr @@ -0,0 +1,7 @@ + +tcfail090.hs:8:9: + Kind incompatibility when matching types: + a0 :: * + ByteArray# :: # + In the expression: undefined + In an equation for `die': die _ = undefined diff --git a/testsuite/tests/typecheck/should_fail/tcfail091.hs b/testsuite/tests/typecheck/should_fail/tcfail091.hs new file mode 100644 index 0000000000..e64d1f512c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail091.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ImplicitParams #-} + +-- !!! Illegal superclass constraint +-- These examples actually crashed GHC 4.08.2 + +module ShouldFail where + +class (?imp :: Int) => C t where + diff --git a/testsuite/tests/typecheck/should_fail/tcfail091.stderr b/testsuite/tests/typecheck/should_fail/tcfail091.stderr new file mode 100644 index 0000000000..74ca90b463 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail091.stderr @@ -0,0 +1,6 @@ + +tcfail091.hs:8:1: + Illegal constraint ?imp::Int + In the context: (?imp::Int) + While checking the super-classes of class `C' + In the class declaration for `C' diff --git a/testsuite/tests/typecheck/should_fail/tcfail091.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail091.stderr-hugs new file mode 100644 index 0000000000..f0a977936d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail091.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail091.hs":8 - Implicit parameters not permitted in class context diff --git a/testsuite/tests/typecheck/should_fail/tcfail092.hs b/testsuite/tests/typecheck/should_fail/tcfail092.hs new file mode 100644 index 0000000000..747f0ca3c7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail092.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ParallelListComp #-} + +-- !!! Illegal conflicting parallel bindings + +module ShouldFail where + +xys = [ () | let a = 13 | let a = 17 ] diff --git a/testsuite/tests/typecheck/should_fail/tcfail092.stderr b/testsuite/tests/typecheck/should_fail/tcfail092.stderr new file mode 100644 index 0000000000..2ba048bb26 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail092.stderr @@ -0,0 +1,3 @@ + +tcfail092.hs:7:27: + Duplicate binding in parallel list comprehension for: `a' diff --git a/testsuite/tests/typecheck/should_fail/tcfail093.hs b/testsuite/tests/typecheck/should_fail/tcfail093.hs new file mode 100644 index 0000000000..9c2d8ea80a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail093.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, UndecidableInstances #-} +-- UndecidableInstances now needed because the Coverage Condition fails + +module ShouldFail where + +-- A stripped down functional-dependency +-- example that causes GHC 4.08.1 to crash with: +-- "basicTypes/Var.lhs:194: Non-exhaustive patterns in function readMutTyVar" +-- Reported by Thomas Hallgren Nov 00 + +-- July 07: I'm changing this from "should fail" to "should succeed" +-- See Note [Important subtlety in oclose] in FunDeps + + +primDup :: Int -> IO Int +primDup = undefined + +dup () = call primDup + +-- call :: Call c h => c -> h +-- +-- call primDup :: {Call (Int -> IO Int) h} => h with +-- Using the instance decl gives +-- call primDup :: {Call (IO Int) h'} => Int -> h' +-- The functional dependency means that h must be constant +-- Hence program is rejected because it can't find an instance +-- for {Call (IO Int) h'} + +class Call c h | c -> h where + call :: c -> h + +instance Call c h => Call (Int->c) (Int->h) where + call f = call . f + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail094.hs b/testsuite/tests/typecheck/should_fail/tcfail094.hs new file mode 100644 index 0000000000..225ceb2d97 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail094.hs @@ -0,0 +1,10 @@ + + +module ShouldFail where + +-- This nonsense tickled a missing-kind-check error in ghc5.00.2 + +type A = Int 1 + + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail094.stderr b/testsuite/tests/typecheck/should_fail/tcfail094.stderr new file mode 100644 index 0000000000..8cd67b632b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail094.stderr @@ -0,0 +1,2 @@ + +tcfail094.hs:7:14: parse error on input `1' diff --git a/testsuite/tests/typecheck/should_fail/tcfail094.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail094.stderr-hugs new file mode 100644 index 0000000000..0d2e0206b2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail094.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail094.hs":7 - Syntax error in input (unexpected numeric literal) diff --git a/testsuite/tests/typecheck/should_fail/tcfail095.hs b/testsuite/tests/typecheck/should_fail/tcfail095.hs new file mode 100644 index 0000000000..b7cae9dbe5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail095.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash #-} + +-- !!! Test top-level unboxed types + +module ShouldFail where + +import GHC.Base + +x = 1# diff --git a/testsuite/tests/typecheck/should_fail/tcfail095.stderr b/testsuite/tests/typecheck/should_fail/tcfail095.stderr new file mode 100644 index 0000000000..55f5b2954d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail095.stderr @@ -0,0 +1,3 @@ + +tcfail095.hs:9:1: + Top-level bindings for unlifted types aren't allowed: x = 1# diff --git a/testsuite/tests/typecheck/should_fail/tcfail096.hs b/testsuite/tests/typecheck/should_fail/tcfail096.hs new file mode 100644 index 0000000000..8a4edfbc6c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail096.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances #-} +module ShouldFail where + +class Foo f a r | f a -> r where + foo::f->a->r + +-- These instances are incompatible because we can unify +-- the first two paramters, though it's rather obscure: +-- p -> (a,b) +-- t -> (,) (a,a) +-- c -> (,) a +-- r -> s +-- +-- So a constraint which would sow this up is +-- Foo ((Int,Int)->Int) +-- ((Int,Int), (Int,Int)) +-- t +-- This matches both. Not easy to spot, and the error +-- message would be improved by giving the unifier, or +-- a witness. + +instance Foo (p->s) (t p) (t s) +instance Foo ((a,b)->r) (c a,c b)(c r) + diff --git a/testsuite/tests/typecheck/should_fail/tcfail096.stderr b/testsuite/tests/typecheck/should_fail/tcfail096.stderr new file mode 100644 index 0000000000..c0ac91f6bf --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail096.stderr @@ -0,0 +1,7 @@ + +tcfail096.hs:23:10: + Functional dependencies conflict between instance declarations: + instance Foo (p -> s) (t p) (t s) + -- Defined at tcfail096.hs:23:10-38 + instance Foo ((a, b) -> r) (c a, c b) (c r) + -- Defined at tcfail096.hs:24:10-38 diff --git a/testsuite/tests/typecheck/should_fail/tcfail096.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail096.stderr-hugs new file mode 100644 index 0000000000..7c3345bb51 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail096.stderr-hugs @@ -0,0 +1,5 @@ +ERROR "tcfail096.hs":24 - Instances are not consistent with dependencies +*** This instance : Foo ((a,b) -> c) (d a,d b) (d c) +*** Conflicts with : Foo (a -> b) (c a) (c b) +*** For class : Foo a b c +*** Under dependency : a b -> c diff --git a/testsuite/tests/typecheck/should_fail/tcfail097.hs b/testsuite/tests/typecheck/should_fail/tcfail097.hs new file mode 100644 index 0000000000..4bcc798b98 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail097.hs @@ -0,0 +1,6 @@ +module ShouldFail where + +-- !!! Ambiguous constraint in type signature + +f :: Eq a => Int -> Int +f x = x diff --git a/testsuite/tests/typecheck/should_fail/tcfail097.stderr b/testsuite/tests/typecheck/should_fail/tcfail097.stderr new file mode 100644 index 0000000000..967b172bb9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail097.stderr @@ -0,0 +1,6 @@ +
+tcfail097.hs:5:1:
+ Ambiguous constraint `Eq a'
+ At least one of the forall'd type variables mentioned by the constraint
+ must be reachable from the type after the '=>'
+ In the type signature for `f': f :: Eq a => Int -> Int
diff --git a/testsuite/tests/typecheck/should_fail/tcfail097.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail097.stderr-hugs new file mode 100644 index 0000000000..9051289079 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail097.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail097.hs":5 - Ambiguous type signature in type declaration +*** ambiguous type : Eq a => Int -> Int +*** assigned to : f diff --git a/testsuite/tests/typecheck/should_fail/tcfail098.hs b/testsuite/tests/typecheck/should_fail/tcfail098.hs new file mode 100644 index 0000000000..2eab9e8f3b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail098.hs @@ -0,0 +1,9 @@ + +{-# LANGUAGE UndecidableInstances #-} + +module ShouldFail where + +-- !!! ambiguous constraint in the context of an instance declaration +class Bar a +instance Bar a => Bar Bool + diff --git a/testsuite/tests/typecheck/should_fail/tcfail098.stderr b/testsuite/tests/typecheck/should_fail/tcfail098.stderr new file mode 100644 index 0000000000..bf2ccabc30 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail098.stderr @@ -0,0 +1,6 @@ + +tcfail098.hs:8:10: + Ambiguous constraint `Bar a' + At least one of the forall'd type variables mentioned by the constraint + must be reachable from the type after the '=>' + In the instance declaration for `Bar Bool' diff --git a/testsuite/tests/typecheck/should_fail/tcfail098.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail098.stderr-hugs new file mode 100644 index 0000000000..9107dbbf06 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail098.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail098.hs":5 - Ambiguous type variable "a" diff --git a/testsuite/tests/typecheck/should_fail/tcfail099.hs b/testsuite/tests/typecheck/should_fail/tcfail099.hs new file mode 100644 index 0000000000..4cfa22c0f0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail099.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- This bogus program slipped past GHC 5.02! + +module ShouldFail where + +data DS = forall a. C (a -> Int) + +call (C f) arg = f arg diff --git a/testsuite/tests/typecheck/should_fail/tcfail099.stderr b/testsuite/tests/typecheck/should_fail/tcfail099.stderr new file mode 100644 index 0000000000..f97c5a1161 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail099.stderr @@ -0,0 +1,13 @@ + +tcfail099.hs:9:20: + Couldn't match type `t' with `a' + `t' is a rigid type variable bound by + the inferred type of call :: DS -> t -> Int at tcfail099.hs:9:1 + `a' is a rigid type variable bound by + a pattern with constructor + C :: forall a. (a -> Int) -> DS, + in an equation for `call' + at tcfail099.hs:9:7 + In the first argument of `f', namely `arg' + In the expression: f arg + In an equation for `call': call (C f) arg = f arg diff --git a/testsuite/tests/typecheck/should_fail/tcfail099.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail099.stderr-hugs new file mode 100644 index 0000000000..b36a4c519e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail099.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail099.hs":9 - Existentially quantified variable in inferred type +*** Variable : _6 +*** From pattern : C f +*** Result type : DS -> _6 -> Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail100.hs b/testsuite/tests/typecheck/should_fail/tcfail100.hs new file mode 100644 index 0000000000..1f125f3fda --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail100.hs @@ -0,0 +1,7 @@ +-- This one broke GHC 5.02, because of the unsaturated +-- uses of type synonyms, which are nevertheless kind-correct. + +module ShouldCompile where + +type A i = i +type B = A diff --git a/testsuite/tests/typecheck/should_fail/tcfail100.stderr b/testsuite/tests/typecheck/should_fail/tcfail100.stderr new file mode 100644 index 0000000000..36ee6f8218 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail100.stderr @@ -0,0 +1,4 @@ + +tcfail100.hs:7:1: + Type synonym `A' should have 1 argument, but has been given none + In the type synonym declaration for `B' diff --git a/testsuite/tests/typecheck/should_fail/tcfail100.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail100.stderr-hugs new file mode 100644 index 0000000000..b4aa433ae9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail100.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail100.hs":7 - Not enough arguments for type synonym "A" diff --git a/testsuite/tests/typecheck/should_fail/tcfail101.hs b/testsuite/tests/typecheck/should_fail/tcfail101.hs new file mode 100644 index 0000000000..8bd88749c3 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail101.hs @@ -0,0 +1,10 @@ +-- This one broke GHC 5.02, because of the unsaturated +-- uses of type synonyms, which are nevertheless kind-correct. + +module ShouldCompile where + +type A i = i +data T k = MkT (k Int) + +f :: T A -- BAD! +f = error "foo" diff --git a/testsuite/tests/typecheck/should_fail/tcfail101.stderr b/testsuite/tests/typecheck/should_fail/tcfail101.stderr new file mode 100644 index 0000000000..0d82b50750 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail101.stderr @@ -0,0 +1,4 @@ + +tcfail101.hs:9:1: + Type synonym `A' should have 1 argument, but has been given none + In the type signature for `f': f :: T A diff --git a/testsuite/tests/typecheck/should_fail/tcfail101.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail101.stderr-hugs new file mode 100644 index 0000000000..626664525d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail101.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail101.hs":9 - Not enough arguments for type synonym "A" diff --git a/testsuite/tests/typecheck/should_fail/tcfail102.hs b/testsuite/tests/typecheck/should_fail/tcfail102.hs new file mode 100644 index 0000000000..f4941789ff --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail102.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DatatypeContexts #-} +module ShouldFail where + +import Data.Ratio + +data Integral a => P a = P { p :: a } + +f :: Integral a => P (Ratio a) -> P (Ratio a) +f x = x { p = p x } diff --git a/testsuite/tests/typecheck/should_fail/tcfail102.stderr b/testsuite/tests/typecheck/should_fail/tcfail102.stderr new file mode 100644 index 0000000000..af047e5dce --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail102.stderr @@ -0,0 +1,17 @@ + +tcfail102.hs:1:14: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + +tcfail102.hs:9:7: + Could not deduce (Integral (Ratio a)) arising from a record update + from the context (Integral a) + bound by the type signature for + f :: Integral a => P (Ratio a) -> P (Ratio a) + at tcfail102.hs:9:1-19 + Possible fix: + add (Integral (Ratio a)) to the context of + the type signature for + f :: Integral a => P (Ratio a) -> P (Ratio a) + or add an instance declaration for (Integral (Ratio a)) + In the expression: x {p = p x} + In an equation for `f': f x = x {p = p x} diff --git a/testsuite/tests/typecheck/should_fail/tcfail102.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail102.stderr-hugs new file mode 100644 index 0000000000..7584fda32e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail102.stderr-hugs @@ -0,0 +1,5 @@ +ERROR "tcfail102.hs":8 - Cannot justify constraints in explicitly typed binding +*** Expression : f +*** Type : Integral a => P (Ratio a) -> P (Ratio a) +*** Given context : Integral a +*** Constraints : Integral (Ratio a) diff --git a/testsuite/tests/typecheck/should_fail/tcfail103.hs b/testsuite/tests/typecheck/should_fail/tcfail103.hs new file mode 100644 index 0000000000..2ed6df2485 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail103.hs @@ -0,0 +1,16 @@ + + +module ShouldCompile where +import GHC.ST +import GHC.STRef +import GHC.Arr + +-- Another 'escape' example + +f:: ST t Int +f = do + v <- newSTRef 5 + let g :: ST s Int + -- Implicitly forall s. ST s Int + g = readSTRef v + g diff --git a/testsuite/tests/typecheck/should_fail/tcfail103.stderr b/testsuite/tests/typecheck/should_fail/tcfail103.stderr new file mode 100644 index 0000000000..636ab29ae7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail103.stderr @@ -0,0 +1,11 @@ + +tcfail103.hs:15:23: + Couldn't match type `t' with `s' + `t' is a rigid type variable bound by + the type signature for f :: ST t Int at tcfail103.hs:11:1 + `s' is a rigid type variable bound by + the type signature for g :: ST s Int at tcfail103.hs:15:9 + Expected type: STRef s Int + Actual type: STRef t Int + In the first argument of `readSTRef', namely `v' + In the expression: readSTRef v diff --git a/testsuite/tests/typecheck/should_fail/tcfail104.hs b/testsuite/tests/typecheck/should_fail/tcfail104.hs new file mode 100644 index 0000000000..292780541c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail104.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} + +-- Test the handling of conditionals in rank-n stuff +-- Should fail, regardless of branch ordering + +module ShouldFail where + +-- These two are ok +f1 = (\ (x :: forall a. a->a) -> x) +f2 = (\ (x :: forall a. a->a) -> x) id 'c' + +-- These fail +f3 v = (if v then + (\ (x :: forall a. a->a) -> x) + else + (\ x -> x) + ) id 'c' + +f4 v = (if v then + (\ x -> x) + else + (\ (x :: forall a. a->a) -> x) + ) id 'c' diff --git a/testsuite/tests/typecheck/should_fail/tcfail104.stderr b/testsuite/tests/typecheck/should_fail/tcfail104.stderr new file mode 100644 index 0000000000..8bd4608bde --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail104.stderr @@ -0,0 +1,16 @@ + +tcfail104.hs:16:19: + Couldn't match expected type `a0 -> a0' + with actual type `forall a. a -> a' + In the expression: x + In the expression: (\ x -> x) + In the expression: + if v then (\ (x :: forall a. a -> a) -> x) else (\ x -> x) + +tcfail104.hs:22:39: + Couldn't match expected type `forall a. a -> a' + with actual type `a0 -> a0' + In the expression: x + In the expression: (\ (x :: forall a. a -> a) -> x) + In the expression: + if v then (\ x -> x) else (\ (x :: forall a. a -> a) -> x) diff --git a/testsuite/tests/typecheck/should_fail/tcfail105.hs b/testsuite/tests/typecheck/should_fail/tcfail105.hs new file mode 100644 index 0000000000..331e38322b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail105.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- Existential context should quantify over some new type variables +-- +-- Jan07: this is now fine, because we've lifted the restrction +-- that the context on a constructor should mention +-- existential type variables + +module ShouldFail where + +data S m t a = Ok a | Cont (M m t a) +data M m t a = Monad m => M { unM::(m (S m t a))} + diff --git a/testsuite/tests/typecheck/should_fail/tcfail105.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail105.stderr-hugs new file mode 100644 index 0000000000..16bedfe8b9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail105.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail105.hs":8 - Syntax error in input (unexpected `=>') diff --git a/testsuite/tests/typecheck/should_fail/tcfail106.hs b/testsuite/tests/typecheck/should_fail/tcfail106.hs new file mode 100644 index 0000000000..22c732e4ce --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail106.hs @@ -0,0 +1,15 @@ +-- This one risked building a recursive dictionary rather than +-- failing, in GHC before 5.03. Actually, 5.02 managed it ok, +-- but I think more by luck than good judgement. + +module ShouldFail where + +class S a +class S a => C a where { opc :: a -> a } +class S b => D b where { opd :: b -> b } + +instance C Int where + opc = opd + +instance D Int where + opd = opc diff --git a/testsuite/tests/typecheck/should_fail/tcfail106.stderr b/testsuite/tests/typecheck/should_fail/tcfail106.stderr new file mode 100644 index 0000000000..e9de772233 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail106.stderr @@ -0,0 +1,12 @@ + +tcfail106.hs:11:10: + No instance for (S Int) + arising from the superclasses of an instance declaration + Possible fix: add an instance declaration for (S Int) + In the instance declaration for `C Int' + +tcfail106.hs:14:10: + No instance for (S Int) + arising from the superclasses of an instance declaration + Possible fix: add an instance declaration for (S Int) + In the instance declaration for `D Int' diff --git a/testsuite/tests/typecheck/should_fail/tcfail106.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail106.stderr-hugs new file mode 100644 index 0000000000..6574cc7864 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail106.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail106.hs":11 - Cannot build superclass instance +*** Instance : C Int +*** Context supplied : () +*** Required superclass : S Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail107.hs b/testsuite/tests/typecheck/should_fail/tcfail107.hs new file mode 100644 index 0000000000..e612e65093 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail107.hs @@ -0,0 +1,14 @@ +-- The type sig for 'test' is illegal in H98 because of the +-- partial application of the type sig. +-- But with the LiberalTypeSynonyms extension enabled it +-- should be OK because when you expand the type synonyms +-- it's just Int->Int +-- c.f should_compile/tc155.hs +module ShouldFail 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_fail/tcfail107.stderr b/testsuite/tests/typecheck/should_fail/tcfail107.stderr new file mode 100644 index 0000000000..eae3610c1d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail107.stderr @@ -0,0 +1,5 @@ + +tcfail107.hs:13:1: + Type synonym `Const' should have 2 arguments, but has been given 1 + In the type signature for `test': + test :: Thing (Const Int) -> Thing (Const Int) diff --git a/testsuite/tests/typecheck/should_fail/tcfail107.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail107.stderr-hugs new file mode 100644 index 0000000000..6c08b363b5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail107.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail107.hs":13 - Not enough arguments for type synonym "Const" diff --git a/testsuite/tests/typecheck/should_fail/tcfail108.hs b/testsuite/tests/typecheck/should_fail/tcfail108.hs new file mode 100644 index 0000000000..5ccebde83e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail108.hs @@ -0,0 +1,9 @@ +-- The instance decl is illegal without UndecidableInstances + +module ShouldFail where + +data Rec f = In (f (Rec f)) + +instance Eq (f (Rec f)) => Eq (Rec f) where + (In x) == (In y) = x == y + diff --git a/testsuite/tests/typecheck/should_fail/tcfail108.stderr b/testsuite/tests/typecheck/should_fail/tcfail108.stderr new file mode 100644 index 0000000000..5d406cd5a6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail108.stderr @@ -0,0 +1,7 @@ + +tcfail108.hs:7:10: + Non type-variable argument in the constraint: Eq (f (Rec f)) + (Use -XFlexibleContexts to permit this) + In the context: (Eq (f (Rec f))) + While checking the context of an instance declaration + In the instance declaration for `Eq (Rec f)' diff --git a/testsuite/tests/typecheck/should_fail/tcfail108.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail108.stderr-hugs new file mode 100644 index 0000000000..f5011fddc7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail108.stderr-hugs @@ -0,0 +1,2 @@ +ERROR "tcfail108.hs":7 - Illegal Haskell 98 class constraint in instance declaration +*** Constraint : Eq (a (Rec a)) diff --git a/testsuite/tests/typecheck/should_fail/tcfail109.hs b/testsuite/tests/typecheck/should_fail/tcfail109.hs new file mode 100644 index 0000000000..861183a399 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail109.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + +-- Strangely, this program does not elicit an error message +-- in GHC 5.03. I don't know why. It fails correctly in +-- 5.04 + + +module ShouldFail where + +class Eq ce => Collects e ce | ce -> e where + empty :: ce + empty = error("empty") + +data Stupid = Stupid -- without equality + +instance Collects Bool Stupid where diff --git a/testsuite/tests/typecheck/should_fail/tcfail109.stderr b/testsuite/tests/typecheck/should_fail/tcfail109.stderr new file mode 100644 index 0000000000..a72c6238d9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail109.stderr @@ -0,0 +1,6 @@ + +tcfail109.hs:16:10: + No instance for (Eq Stupid) + arising from the superclasses of an instance declaration + Possible fix: add an instance declaration for (Eq Stupid) + In the instance declaration for `Collects Bool Stupid' diff --git a/testsuite/tests/typecheck/should_fail/tcfail109.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail109.stderr-hugs new file mode 100644 index 0000000000..3a7abb8842 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail109.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail109.hs":16 - Cannot build superclass instance +*** Instance : Collects Bool Stupid +*** Context supplied : () +*** Required superclass : Eq Stupid diff --git a/testsuite/tests/typecheck/should_fail/tcfail110.hs b/testsuite/tests/typecheck/should_fail/tcfail110.hs new file mode 100644 index 0000000000..92aeb56c06 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail110.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Rank2Types #-} + +module ShouldCompile where + +data Foo a b = Foo { foo :: a -> b } + +-- kind error in here +bar :: String -> (forall a . Foo a) -> IO () +bar s _ = putStrLn s diff --git a/testsuite/tests/typecheck/should_fail/tcfail110.stderr b/testsuite/tests/typecheck/should_fail/tcfail110.stderr new file mode 100644 index 0000000000..e663999edb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail110.stderr @@ -0,0 +1,6 @@ + +tcfail110.hs:8:30: + `Foo a' is not applied to enough type arguments + Expected kind `*', but `Foo a' has kind `* -> *' + In the type signature for `bar': + bar :: String -> (forall a. Foo a) -> IO () diff --git a/testsuite/tests/typecheck/should_fail/tcfail110.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail110.stderr-hugs new file mode 100644 index 0000000000..4cc90e0a43 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail110.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail110.hs":8 - Illegal type in polymorphic type diff --git a/testsuite/tests/typecheck/should_fail/tcfail111.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail111.stderr-hugs new file mode 100644 index 0000000000..46e9b8d08e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail111.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail111.hs":7 - Ambiguous type variable "a" diff --git a/testsuite/tests/typecheck/should_fail/tcfail112.hs b/testsuite/tests/typecheck/should_fail/tcfail112.hs new file mode 100644 index 0000000000..01dd578ab7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail112.hs @@ -0,0 +1,15 @@ +-- Record construction should fail statically +-- if there are any strict fields, +-- including in the non-record case. + +module ShouldFail where + +data S = S { x::Int, y:: ! Int } +data T = T Int !Int +data U = U Int Int + +s1 = S {} -- Bad +s2 = S { x=3 } -- Bad +s3 = S { y=3 } -- Ok +t = T {} -- Bad +u = U {} -- Ok diff --git a/testsuite/tests/typecheck/should_fail/tcfail112.stderr b/testsuite/tests/typecheck/should_fail/tcfail112.stderr new file mode 100644 index 0000000000..602c1e4b69 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail112.stderr @@ -0,0 +1,15 @@ + +tcfail112.hs:11:6: + Constructor `S' does not have the required strict field(s): y + In the expression: S {} + In an equation for `s1': s1 = S {} + +tcfail112.hs:12:6: + Constructor `S' does not have the required strict field(s): y + In the expression: S {x = 3} + In an equation for `s2': s2 = S {x = 3} + +tcfail112.hs:14:6: + Constructor `T' does not have the required strict field(s) + In the expression: T {} + In an equation for `t': t = T {} diff --git a/testsuite/tests/typecheck/should_fail/tcfail112.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail112.stderr-hugs new file mode 100644 index 0000000000..3b64822662 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail112.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail112.hs":11 - Construction does not define strict field +Expression : S {} +Field : y diff --git a/testsuite/tests/typecheck/should_fail/tcfail113.hs b/testsuite/tests/typecheck/should_fail/tcfail113.hs new file mode 100644 index 0000000000..1628cd7c41 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail113.hs @@ -0,0 +1,19 @@ +-- Tests kind error messages + +-- GHC 6.6 stops on the first kind error it encounters, +-- so we only get one error report here. I'll leave +-- the other tests in here, though, in case matters improve +-- again + +module ShouldFail where + +data T k = T (k Int) + +f :: [Maybe] +f x = x + +g :: T Int +g x = x + +h :: Int Int +h x = x diff --git a/testsuite/tests/typecheck/should_fail/tcfail113.stderr b/testsuite/tests/typecheck/should_fail/tcfail113.stderr new file mode 100644 index 0000000000..d4c9208243 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail113.stderr @@ -0,0 +1,18 @@ + +tcfail113.hs:12:7: + `Maybe' is not applied to enough type arguments + Expected kind `*', but `Maybe' has kind `* -> *' + In the type signature for `f': + f :: [Maybe] + +tcfail113.hs:15:8: + Kind mis-match + The first argument of `T' should have kind `* -> *', + but `Int' has kind `*' + In the type signature for `g': + g :: T Int + +tcfail113.hs:18:6: + `Int' is applied to too many type arguments + In the type signature for `h': + h :: Int Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail113.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail113.stderr-hugs new file mode 100644 index 0000000000..014006a69a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail113.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail113.hs":7 - Illegal type "[Maybe]" in constructor application diff --git a/testsuite/tests/typecheck/should_fail/tcfail114.hs b/testsuite/tests/typecheck/should_fail/tcfail114.hs new file mode 100644 index 0000000000..2d0fc19f4b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail114.hs @@ -0,0 +1,13 @@ +-- Killed GHC 5.04.2 + +module ShouldFail where + +class Foo a where + foo :: a -> () + +data Bar = Bar { bar :: () } + +test :: Bar +test = undefined { foo = () } + -- The point is that foo is a class method, + -- but not a record selector diff --git a/testsuite/tests/typecheck/should_fail/tcfail114.stderr b/testsuite/tests/typecheck/should_fail/tcfail114.stderr new file mode 100644 index 0000000000..601feff85b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail114.stderr @@ -0,0 +1,5 @@ + +tcfail114.hs:11:20: + `foo' is not a record selector + In the expression: undefined {foo = ()} + In an equation for `test': test = undefined {foo = ()} diff --git a/testsuite/tests/typecheck/should_fail/tcfail114.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail114.stderr-hugs new file mode 100644 index 0000000000..3a7663b166 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail114.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail114.hs":11 - "foo" is not a selector function/field name diff --git a/testsuite/tests/typecheck/should_fail/tcfail115.hs b/testsuite/tests/typecheck/should_fail/tcfail115.hs new file mode 100644 index 0000000000..971f625a9a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail115.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE UnboxedTuples #-} + +-- Unboxed tuples; c.f. tcfail120, tc209 + +module ShouldFail where + +type T a = Int -> (# Int, Int #) + +g t = case t of r -> (r :: (# Int, Int #)) + +f :: T a -> T a +f t = \x -> case t x of r -> r + diff --git a/testsuite/tests/typecheck/should_fail/tcfail115.stderr b/testsuite/tests/typecheck/should_fail/tcfail115.stderr new file mode 100644 index 0000000000..fd1a02c02d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail115.stderr @@ -0,0 +1,14 @@ + +tcfail115.hs:9:24: + Kind incompatibility when matching types: + t0 :: ?? + (# Int, Int #) :: (#) + In the expression: (r :: (# Int, Int #)) + In a case alternative: r -> (r :: (# Int, Int #)) + In the expression: case t of { r -> (r :: (# Int, Int #)) } + +tcfail115.hs:12:25: + The variable `r' cannot have an unboxed tuple type: (# Int, Int #) + In a case alternative: r -> r + In the expression: case t x of { r -> r } + In the expression: \ x -> case t x of { r -> r } diff --git a/testsuite/tests/typecheck/should_fail/tcfail116.hs b/testsuite/tests/typecheck/should_fail/tcfail116.hs new file mode 100644 index 0000000000..1c32c956d3 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail116.hs @@ -0,0 +1,6 @@ +module ShouldFail where + +-- in Haskell 98, methods must mention the class variable +-- (SourceForge bug #756454). +class Foo a where + bug :: () diff --git a/testsuite/tests/typecheck/should_fail/tcfail116.stderr b/testsuite/tests/typecheck/should_fail/tcfail116.stderr new file mode 100644 index 0000000000..8e7372413a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail116.stderr @@ -0,0 +1,6 @@ + +tcfail116.hs:5:1: + The class method `bug' + mentions none of the type variables of the class Foo a + When checking the class method: bug :: () + In the class declaration for `Foo' diff --git a/testsuite/tests/typecheck/should_fail/tcfail116.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail116.stderr-hugs new file mode 100644 index 0000000000..fba5f2db38 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail116.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail116.hs":6 - Ambiguous type signature in class declaration +*** ambiguous type : Foo a => () +*** assigned to : bug diff --git a/testsuite/tests/typecheck/should_fail/tcfail117.hs b/testsuite/tests/typecheck/should_fail/tcfail117.hs new file mode 100644 index 0000000000..2a5ae99172 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail117.hs @@ -0,0 +1,6 @@ +module ShouldFail where + +-- Without any extensions enabled both of these should fail + +newtype N1 = N1 Int deriving ( Enum ) +data N2 = N2 Int deriving ( Enum ) diff --git a/testsuite/tests/typecheck/should_fail/tcfail117.stderr b/testsuite/tests/typecheck/should_fail/tcfail117.stderr new file mode 100644 index 0000000000..2bc3d7fd63 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail117.stderr @@ -0,0 +1,13 @@ + +tcfail117.hs:5:32: + Can't make a derived instance of `Enum N1': + `N1' must be an enumeration type + (an enumeration consists of one or more nullary, non-GADT constructors) + Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension + In the newtype declaration for `N1' + +tcfail117.hs:6:32: + Can't make a derived instance of `Enum N2': + `N2' must be an enumeration type + (an enumeration consists of one or more nullary, non-GADT constructors) + In the data type declaration for `N2' diff --git a/testsuite/tests/typecheck/should_fail/tcfail117.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail117.stderr-hugs new file mode 100644 index 0000000000..b6db2d800a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail117.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail117.hs":5 - Can only derive instances of Enum for enumeration types diff --git a/testsuite/tests/typecheck/should_fail/tcfail118.hs b/testsuite/tests/typecheck/should_fail/tcfail118.hs new file mode 100644 index 0000000000..1b81c7e01a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail118.hs @@ -0,0 +1,15 @@ +-- Gave a bad error message in a version of 6.3, as a +-- result of 6.3's new duplicate-instance reporting structure +-- +-- Foo.hs:4:5: +-- No instance for `Eq Foo' +-- When deriving the `Eq' instance for type `Bar' + +module ShouldFail where + +data Bar = Bar Foo deriving Eq +data Foo = Foo deriving Eq + +instance Eq Foo where + Foo == Foo = True + diff --git a/testsuite/tests/typecheck/should_fail/tcfail118.stderr b/testsuite/tests/typecheck/should_fail/tcfail118.stderr new file mode 100644 index 0000000000..206bec47be --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail118.stderr @@ -0,0 +1,8 @@ + +tcfail118.hs:10:29: + Overlapping instances for Eq Foo + arising from the 'deriving' clause of a data type declaration + Matching instances: + instance Eq Foo -- Defined at tcfail118.hs:11:25-26 + instance Eq Foo -- Defined at tcfail118.hs:13:10-15 + When deriving the instance for (Eq Bar) diff --git a/testsuite/tests/typecheck/should_fail/tcfail118.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail118.stderr-hugs new file mode 100644 index 0000000000..691a20ee0a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail118.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail118.hs":11 - Overlapping instances for class "Eq" +*** This instance : Eq Foo +*** Overlaps with : Eq Foo +*** Common instance : Eq Foo diff --git a/testsuite/tests/typecheck/should_fail/tcfail119.hs b/testsuite/tests/typecheck/should_fail/tcfail119.hs new file mode 100644 index 0000000000..52b9c8a5eb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail119.hs @@ -0,0 +1,14 @@ +-- Gave a nasty +-- tcLookupGlobal: `FunnyError.$dmb' is not in scope +-- failure in GHC 6.2, because the type-checking of +-- the default method didn't recover. + +module ShouldFail where + +class A x where + a :: x -> () + b :: x -> Bool -> () + b x "Foo" = () -- deliberate type error + +instance A Int where + a _ = () diff --git a/testsuite/tests/typecheck/should_fail/tcfail119.stderr b/testsuite/tests/typecheck/should_fail/tcfail119.stderr new file mode 100644 index 0000000000..1984617b2b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail119.stderr @@ -0,0 +1,5 @@ + +tcfail119.hs:11:8: + Couldn't match expected type `Bool' with actual type `[Char]' + In the pattern: "Foo" + In an equation for `b': b x "Foo" = () diff --git a/testsuite/tests/typecheck/should_fail/tcfail119.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail119.stderr-hugs new file mode 100644 index 0000000000..443f073bcd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail119.stderr-hugs @@ -0,0 +1,4 @@ +ERROR "tcfail119.hs":11 - Type error in default member binding +*** Term : "Foo" +*** Type : String +*** Does not match : Bool diff --git a/testsuite/tests/typecheck/should_fail/tcfail120.hs b/testsuite/tests/typecheck/should_fail/tcfail120.hs new file mode 100644 index 0000000000..04b7cd60ab --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail120.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE UnboxedTuples #-} + +-- Could be ok, because nothing is bound to the unboxed tuple +-- but actually rejected, because a wild card is rather like +-- an unused variable. Could fix this, but it's really a corner case + +module ShouldFail where + +type T a = Int -> (# Int, Int #) + +f2 :: T a -> T a +f2 t = \x -> case t x of _ -> (# 3,4 #) + diff --git a/testsuite/tests/typecheck/should_fail/tcfail120.stderr b/testsuite/tests/typecheck/should_fail/tcfail120.stderr new file mode 100644 index 0000000000..7693b0c7c5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail120.stderr @@ -0,0 +1,7 @@ + +tcfail120.hs:13:26: + A wild-card pattern cannot have an unboxed tuple type: + (# Int, Int #) + In the pattern: _ + In a case alternative: _ -> (# 3, 4 #) + In the expression: case t x of { _ -> (# 3, 4 #) } diff --git a/testsuite/tests/typecheck/should_fail/tcfail121.hs b/testsuite/tests/typecheck/should_fail/tcfail121.hs new file mode 100644 index 0000000000..86c2a92c5c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail121.hs @@ -0,0 +1,14 @@ + +{-# LANGUAGE OverlappingInstances, FlexibleInstances #-} + +module ShouldFail where + +class Foo a where + op :: a -> a + +instance Foo a => Foo [a] +instance Foo [Int] + +foo :: Foo a => [a] -> [a] +foo x = op x +-- Correct instance depends on instantiation of 'a' diff --git a/testsuite/tests/typecheck/should_fail/tcfail121.stderr b/testsuite/tests/typecheck/should_fail/tcfail121.stderr new file mode 100644 index 0000000000..783331fdfc --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail121.stderr @@ -0,0 +1,13 @@ + +tcfail121.hs:13:9: + Overlapping instances for Foo [a] + arising from a use of `op' + Matching instances: + instance [overlap ok] Foo a => Foo [a] + -- Defined at tcfail121.hs:9:10-25 + instance [overlap ok] Foo [Int] -- Defined at tcfail121.hs:10:10-18 + (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: op x + In an equation for `foo': foo x = op x diff --git a/testsuite/tests/typecheck/should_fail/tcfail122.hs b/testsuite/tests/typecheck/should_fail/tcfail122.hs new file mode 100644 index 0000000000..ae2bef8bea --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail122.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Rank2Types, KindSignatures #-} + +module ShouldFail where + +-- There should be a kind error, when unifying (a b) against (c d) + +foo = [ undefined :: forall a b. a b, + undefined :: forall (c:: (* -> *) -> *) (d :: * -> *). c d ] diff --git a/testsuite/tests/typecheck/should_fail/tcfail122.stderr b/testsuite/tests/typecheck/should_fail/tcfail122.stderr new file mode 100644 index 0000000000..3f6c035a55 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail122.stderr @@ -0,0 +1,26 @@ + +tcfail122.hs:8:9: + Kind incompatibility when matching types: + d0 :: * -> * + b0 :: * + Expected type: a0 b0 + Actual type: c0 d0 + In the expression: + undefined :: forall c :: ((* -> *) -> *) d :: (* -> *). c d + In the expression: + [undefined :: forall a b. a b, + undefined :: forall c :: ((* -> *) -> *) d :: (* -> *). c d] + +tcfail122.hs:8:9: + Kind incompatibility when matching types: + c0 :: (* -> *) -> * + a0 :: * -> * + In the expression: + undefined :: forall c :: ((* -> *) -> *) d :: (* -> *). c d + In the expression: + [undefined :: forall a b. a b, + undefined :: forall c :: ((* -> *) -> *) d :: (* -> *). c d] + In an equation for `foo': + foo + = [undefined :: forall a b. a b, + undefined :: forall c :: ((* -> *) -> *) d :: (* -> *). c d] diff --git a/testsuite/tests/typecheck/should_fail/tcfail123.hs b/testsuite/tests/typecheck/should_fail/tcfail123.hs new file mode 100644 index 0000000000..8e91bbe885 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail123.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MagicHash #-} + +module ShouldFail where + +-- The danger here is getting a type like +-- f :: forall (a::??). a -> Bool +-- and hence allowing the bogus calls that follow + +f x = True + +h v = (f 3#, f 4.3#, f True) diff --git a/testsuite/tests/typecheck/should_fail/tcfail123.stderr b/testsuite/tests/typecheck/should_fail/tcfail123.stderr new file mode 100644 index 0000000000..560c8d9048 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail123.stderr @@ -0,0 +1,16 @@ + +tcfail123.hs:11:10: + Kind incompatibility when matching types: + t0 :: * + GHC.Prim.Int# :: # + In the first argument of `f', namely `3#' + In the expression: f 3# + In the expression: (f 3#, f 4.3#, f True) + +tcfail123.hs:11:16: + Kind incompatibility when matching types: + t1 :: * + GHC.Prim.Float# :: # + In the first argument of `f', namely `4.3#' + In the expression: f 4.3# + In the expression: (f 3#, f 4.3#, f True) diff --git a/testsuite/tests/typecheck/should_fail/tcfail124.hs b/testsuite/tests/typecheck/should_fail/tcfail124.hs new file mode 100644 index 0000000000..729d14b601 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail124.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE RankNTypes #-} + +module ShouldFail where + +-- With the new typechecker (GHC 7.1), these now all pass + +f1 :: (forall a. Eq a => [a]) -> Bool +f1 xs@(x:_) = x + +f2 :: (forall a. Eq a => [a]) -> Bool +f2 [x] = x + +f3 :: (forall a. Eq a => [a]) -> Bool +f3 (x:[]) = x diff --git a/testsuite/tests/typecheck/should_fail/tcfail124.stderr b/testsuite/tests/typecheck/should_fail/tcfail124.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail124.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail125.hs b/testsuite/tests/typecheck/should_fail/tcfail125.hs new file mode 100644 index 0000000000..664354d840 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail125.hs @@ -0,0 +1,11 @@ +{-# 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 :: Obs a -> String -- Needs a (Show a) context +f (LiftObs _ _) = "yes" diff --git a/testsuite/tests/typecheck/should_fail/tcfail125.stderr b/testsuite/tests/typecheck/should_fail/tcfail125.stderr new file mode 100644 index 0000000000..988540dad5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail125.stderr @@ -0,0 +1,9 @@ + +tcfail125.hs:1:14: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + +tcfail125.hs:11:4: + No instance for (Show a) + arising from a use of `LiftObs' + In the pattern: LiftObs _ _ + In an equation for `f': f (LiftObs _ _) = "yes" diff --git a/testsuite/tests/typecheck/should_fail/tcfail125.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail125.stderr-hugs new file mode 100644 index 0000000000..7fc582ba2d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail125.stderr-hugs @@ -0,0 +1,5 @@ +ERROR "tcfail125.hs":11 - Cannot justify constraints in explicitly typed binding +*** Expression : f +*** Type : Obs a -> String +*** Given context : () +*** Constraints : Show a diff --git a/testsuite/tests/typecheck/should_fail/tcfail126.hs b/testsuite/tests/typecheck/should_fail/tcfail126.hs new file mode 100644 index 0000000000..1ef2b4820e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail126.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE RankNTypes, ExistentialQuantification #-} + +-- An interesting interaction of universals and existentials, prompted by +-- http://www.haskell.org/pipermail/haskell-cafe/2004-October/007160.html +-- +-- Note the nested pattern-match in runProg; tc183 checks the +-- non-nested version + +-- 3 Sept 2010: with the new typechecker, this one succeeds + +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 (Bar run op)) = run (prog op) +-- This nested match "ought" to work; because +-- runProg (Foo b) = case b of +-- Bar run op -> run (prog op) +-- does work. But the interactions with GADTs and +-- desugaring defeated me, and I removed (in GHC 6.4) the ability +-- to instantiate functions on the left + +prog :: (MonadTrans t, Monad (t IO)) => a -> t IO () +prog x = error "urk" diff --git a/testsuite/tests/typecheck/should_fail/tcfail126.stderr b/testsuite/tests/typecheck/should_fail/tcfail126.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail126.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail127.hs b/testsuite/tests/typecheck/should_fail/tcfail127.hs new file mode 100644 index 0000000000..32b9e37de5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail127.hs @@ -0,0 +1,7 @@ +module ShouldFail where + +foo :: IO (Num a => a -> a) +foo = error "urk" + +-- baz :: (Num a => a -> a) -> Int +-- baz = error "urk" diff --git a/testsuite/tests/typecheck/should_fail/tcfail127.stderr b/testsuite/tests/typecheck/should_fail/tcfail127.stderr new file mode 100644 index 0000000000..8fa64fb204 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail127.stderr @@ -0,0 +1,5 @@ +
+tcfail127.hs:3:1:
+ Illegal polymorphic or qualified type: Num a => a -> a
+ Perhaps you intended to use -XImpredicativeTypes
+ In the type signature for `foo': foo :: IO (Num a => a -> a)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail128.hs b/testsuite/tests/typecheck/should_fail/tcfail128.hs new file mode 100644 index 0000000000..08971837a2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail128.hs @@ -0,0 +1,29 @@ + + +-- Ambiguity error reporting + +module Main where + +import Data.Array.MArray (thaw,freeze) +import Data.Array.Unboxed as UA (UArray,listArray) +import Data.Array.IArray as IA (Array,listArray) + +main :: IO () +main = do let sL = [1,4,6,3,2,5] + dim = length sL + help :: [FlatVector] + help = [listFlatVector (1,s) [0|i<-[1..s]]|s<-sL] + tmp :: Vector FlatVector + tmp = listVector (1,dim) help + v <- thaw tmp + return () + +type FlatVector = UArray Int Double + +listFlatVector :: (Int,Int) -> [Double] -> FlatVector +listFlatVector = UA.listArray + +type Vector a = Array Int a + +listVector :: (Int,Int) -> [a] -> Vector a +listVector = IA.listArray diff --git a/testsuite/tests/typecheck/should_fail/tcfail128.stderr b/testsuite/tests/typecheck/should_fail/tcfail128.stderr new file mode 100644 index 0000000000..a3c99a9548 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail128.stderr @@ -0,0 +1,20 @@ + +tcfail128.hs:18:16: + No instance for (Data.Array.Base.MArray b0 FlatVector IO) + arising from a use of `thaw' + Possible fix: + add an instance declaration for + (Data.Array.Base.MArray b0 FlatVector IO) + In a stmt of a 'do' block: v <- thaw tmp + In the expression: + do { let sL = ... + dim = length sL + ....; + v <- thaw tmp; + return () } + In an equation for `main': + main + = do { let sL = ... + ....; + v <- thaw tmp; + return () } diff --git a/testsuite/tests/typecheck/should_fail/tcfail128.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail128.stderr-hugs new file mode 100644 index 0000000000..fa3977e1e9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail128.stderr-hugs @@ -0,0 +1,5 @@ +ERROR "tcfail128.hs":12 - Cannot justify constraints in explicitly typed binding +*** Expression : main +*** Type : IO () +*** Given context : () +*** Constraints : MArray a (UArray Int Double) IO diff --git a/testsuite/tests/typecheck/should_fail/tcfail129.hs b/testsuite/tests/typecheck/should_fail/tcfail129.hs new file mode 100644 index 0000000000..1a74749f56 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail129.hs @@ -0,0 +1,19 @@ +-- Both blocks are illegal Haskell 98, because of the un-saturated +-- type synonym, but (rather obscurely) at one point (GHC 6.3), we +-- acceped 'blah', but rejected 'blah1' + +module ShouldFail where + +data T = T + +-- This was erroneously accepted +type Foo a = String -> Maybe a +type Bar m = m Int +blah = undefined :: Bar Foo + + +type Foo1 a = Maybe a +type Bar1 m = m Int +blah1 = undefined :: Bar1 Foo1 + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail129.stderr b/testsuite/tests/typecheck/should_fail/tcfail129.stderr new file mode 100644 index 0000000000..f9ee8a567d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail129.stderr @@ -0,0 +1,12 @@ + +tcfail129.hs:12:8: + Type synonym `Foo' should have 1 argument, but has been given none + In an expression type signature: Bar Foo + In the expression: undefined :: Bar Foo + In an equation for `blah': blah = undefined :: Bar Foo + +tcfail129.hs:17:9: + Type synonym `Foo1' should have 1 argument, but has been given none + In an expression type signature: Bar1 Foo1 + In the expression: undefined :: Bar1 Foo1 + In an equation for `blah1': blah1 = undefined :: Bar1 Foo1 diff --git a/testsuite/tests/typecheck/should_fail/tcfail129.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail129.stderr-hugs new file mode 100644 index 0000000000..ff4f0a79c6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail129.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail129.hs":12 - Not enough arguments for type synonym "Foo" diff --git a/testsuite/tests/typecheck/should_fail/tcfail130.hs b/testsuite/tests/typecheck/should_fail/tcfail130.hs new file mode 100644 index 0000000000..96101b534a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail130.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE ImplicitParams #-} + +-- The defn of foo should be rejected; it's monomorphic, but +-- the implicit paramter escapes + +module Foo where + +baz = let ?x = 5 in print foo + +foo = woggle 3 + +woggle :: (?x :: Int) => Int -> Int +woggle y = ?x + y + + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail130.stderr b/testsuite/tests/typecheck/should_fail/tcfail130.stderr new file mode 100644 index 0000000000..3534dba679 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail130.stderr @@ -0,0 +1,6 @@ + +tcfail130.hs:10:7: + Unbound implicit parameter (?x::Int) + arising from a use of `woggle' + In the expression: woggle 3 + In an equation for `foo': foo = woggle 3 diff --git a/testsuite/tests/typecheck/should_fail/tcfail130.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail130.stderr-hugs new file mode 100644 index 0000000000..d4e366eb19 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail130.stderr-hugs @@ -0,0 +1,3 @@ +ERROR "tcfail130.hs":10 - Unresolved top-level overloading +*** Binding : foo +*** Outstanding context : (?x :: Int) diff --git a/testsuite/tests/typecheck/should_fail/tcfail131.hs b/testsuite/tests/typecheck/should_fail/tcfail131.hs new file mode 100644 index 0000000000..98b0a29c80 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail131.hs @@ -0,0 +1,7 @@ +-- Error message in monomorphic case + +module ShouldFail where + + f = (*) -- Monomorphic + g :: Num b => b -> b + g x = f x x diff --git a/testsuite/tests/typecheck/should_fail/tcfail131.stderr b/testsuite/tests/typecheck/should_fail/tcfail131.stderr new file mode 100644 index 0000000000..134b76ffb3 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail131.stderr @@ -0,0 +1,11 @@ + +tcfail131.hs:7:13: + Could not deduce (b ~ Integer) + from the context (Num b) + bound by the type signature for g :: Num b => b -> b + at tcfail131.hs:7:3-13 + `b' is a rigid type variable bound by + the type signature for g :: Num b => b -> b at tcfail131.hs:7:3 + In the second argument of `f', namely `x' + In the expression: f x x + In an equation for `g': g x = f x x diff --git a/testsuite/tests/typecheck/should_fail/tcfail132.hs b/testsuite/tests/typecheck/should_fail/tcfail132.hs new file mode 100644 index 0000000000..cc933dc6ee --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail132.hs @@ -0,0 +1,19 @@ +-- Fails with a kind error. +-- The current error message was rather horrible (trac bug #312): +-- +-- Kind error: Expecting kind `k_a1JA -> k_a1JE -> k_a1JI -> *', +-- but `DUnit t' has kind `k_a1JA -> k_a1JE -> *' +-- +-- as we couldn't tidy kinds, becuase they didn't have OccNames. +-- This test recalls the bad error message. + +module ShouldFail where + +newtype Object f' f t o1 o2 = Object (f' t o1 -> f t o2) +type DUnit t o1 o2 = () + +type T f g t o1 o2 = Either (f t o1 o2) (g t o1 o2) + +type LiftObject t f' f = T (Object f' f t) (DUnit t) + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail132.stderr b/testsuite/tests/typecheck/should_fail/tcfail132.stderr new file mode 100644 index 0000000000..b25f21a809 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail132.stderr @@ -0,0 +1,7 @@ + +tcfail132.hs:17:37: + Kind mis-match + The first argument of `T' should have kind `k0 -> k1 -> k2 -> *', + but `Object f' f t' has kind `k0 -> k1 -> *' + In the type `T (Object f' f t) (DUnit t)' + In the type synonym declaration for `LiftObject' diff --git a/testsuite/tests/typecheck/should_fail/tcfail132.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail132.stderr-hugs new file mode 100644 index 0000000000..3b5f68fc7e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail132.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail132.hs":21 - Not enough arguments for type synonym "T" diff --git a/testsuite/tests/typecheck/should_fail/tcfail133.hs b/testsuite/tests/typecheck/should_fail/tcfail133.hs new file mode 100644 index 0000000000..af45be93cd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail133.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE UndecidableInstances, FlexibleInstances, TypeOperators, + MultiParamTypeClasses, FunctionalDependencies, DatatypeContexts #-} + +-- This one crashed GHC 6.3 due to an error in TcSimplify.add_ors + +module Foo where + +data Zero = Zero deriving Show +data One = One deriving Show +infixl 9 :@ +data (Number a, Digit b) => a :@ b = a :@ b deriving Show + +class Digit a +instance Digit Zero +instance Digit One + +class Number a +instance Number Zero +instance Number One +instance (Number a, Digit b) => Number (a :@ b) + +--- Pretty printing of numbers --- +class PrettyNum a where + prettyNum :: a -> String + +instance PrettyNum Zero where + prettyNum _ = "0" + +instance PrettyNum One where + prettyNum _ = "1" + +instance (Number a, Digit b, PrettyNum a, PrettyNum b) + => PrettyNum (a :@ b) where + prettyNum ~(a:@b) + = prettyNum a ++ prettyNum b + +--- Digit addition --- +class (Number a, Digit b, Number c) + => AddDigit a b c | a b -> c where + addDigit :: a -> b -> c + addDigit = undefined + +instance Number a => AddDigit a Zero a +instance AddDigit Zero One One +instance AddDigit One One (One:@Zero) +instance Number a => AddDigit (a:@Zero) One (a:@One) +instance AddDigit a One a' + => AddDigit (a:@One) One (a':@Zero) + +--- Addition --- +class (Number a, Number b, Number c) + => Add a b c | a b -> c where + add :: a -> b -> c + add = undefined + +instance Number n => Add n Zero n +instance Add Zero One One +instance Add One One (One:@One) +instance Number n + => Add (n:@Zero) One (n:@One) +instance AddDigit n One r' + => Add (n:@One) One (r':@Zero) +instance (Number n1, Digit d1, Number n2, Digit n2 + ,Add n1 n2 nr', AddDigit (d1:@nr') d2 r) + => Add (n1:@d1) (n2:@d2) r + + +foo = show $ add (One:@Zero) (One:@One) + + +-- Add (One:@Zero) (One:@One) c, Show c +-- ==> Number One, Digit Zero, Number One, Digit One +-- Add One One nr', AddDigit (Zero:@nr') One c, Show c +-- +-- ==> Add One One nr', AddDigit (Zero:@nr') One c, Show c +-- +-- ==> Add One One (One:@One), AddDigit (Zero:@(One:@One)) One c, Show c +-- +-- ==> AddDigit (Zero:@(One:@One)) One c, Show c diff --git a/testsuite/tests/typecheck/should_fail/tcfail133.stderr b/testsuite/tests/typecheck/should_fail/tcfail133.stderr new file mode 100644 index 0000000000..2808159950 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail133.stderr @@ -0,0 +1,15 @@ + +tcfail133.hs:2:61: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + +tcfail133.hs:68:14: + No instance for (AddDigit (Zero :@ (One :@ One)) One a0) + arising from a use of `add' + Possible fix: + add an instance declaration for + (AddDigit (Zero :@ (One :@ One)) One a0) + In the second argument of `($)', namely + `add (One :@ Zero) (One :@ One)' + In the expression: show $ add (One :@ Zero) (One :@ One) + In an equation for `foo': + foo = show $ add (One :@ Zero) (One :@ One) diff --git a/testsuite/tests/typecheck/should_fail/tcfail134.hs b/testsuite/tests/typecheck/should_fail/tcfail134.hs new file mode 100644 index 0000000000..467bffdad0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail134.hs @@ -0,0 +1,5 @@ +-- Class used as a type, recursively + +module ShouldFail where + +class XML a where toXML :: a -> XML
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/tcfail134.stderr b/testsuite/tests/typecheck/should_fail/tcfail134.stderr new file mode 100644 index 0000000000..ea302f058a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail134.stderr @@ -0,0 +1,6 @@ + +tcfail134.hs:5:33: + `XML' is not applied to enough type arguments + Expected kind `?', but `XML' has kind `* -> *' + In the type `a -> XML' + In the class declaration for `XML' diff --git a/testsuite/tests/typecheck/should_fail/tcfail134.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail134.stderr-hugs new file mode 100644 index 0000000000..3726341ee9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail134.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail134.hs":5 - Undefined type constructor "XML" diff --git a/testsuite/tests/typecheck/should_fail/tcfail135.hs b/testsuite/tests/typecheck/should_fail/tcfail135.hs new file mode 100644 index 0000000000..5cfc926085 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail135.hs @@ -0,0 +1,9 @@ +-- A missing kind check made GHC 6.4 crash on this one + +module ShoudlFail where + +class Foo f where + baa :: f a -> f + +instance Foo Maybe where + baa z = z diff --git a/testsuite/tests/typecheck/should_fail/tcfail135.stderr b/testsuite/tests/typecheck/should_fail/tcfail135.stderr new file mode 100644 index 0000000000..37274283ed --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail135.stderr @@ -0,0 +1,6 @@ + +tcfail135.hs:6:23: + `f' is not applied to enough type arguments + Expected kind `?', but `f' has kind `k0 -> *' + In the type `f a -> f' + In the class declaration for `Foo' diff --git a/testsuite/tests/typecheck/should_fail/tcfail135.stderr-hugs b/testsuite/tests/typecheck/should_fail/tcfail135.stderr-hugs new file mode 100644 index 0000000000..c4c792a7ab --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail135.stderr-hugs @@ -0,0 +1 @@ +ERROR "tcfail135.hs":6 - Illegal type "a b" in constructor application diff --git a/testsuite/tests/typecheck/should_fail/tcfail136.hs b/testsuite/tests/typecheck/should_fail/tcfail136.hs new file mode 100644 index 0000000000..19989d4a61 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail136.hs @@ -0,0 +1,9 @@ +-- Kind error message test
+
+module ShouldFail where
+
+type IntMap a = [a]
+
+data SymDict a = SymDict {idcounter:: Int, itot::IntMap a}
+
+data SymTable = SymTable { dict::SymDict }
diff --git a/testsuite/tests/typecheck/should_fail/tcfail136.stderr b/testsuite/tests/typecheck/should_fail/tcfail136.stderr new file mode 100644 index 0000000000..cdeff3c8a5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail136.stderr @@ -0,0 +1,7 @@ + +tcfail136.hs:9:35: + `SymDict' is not applied to enough type arguments + Expected kind `?', but `SymDict' has kind `* -> *' + In the type `SymDict' + In the definition of data constructor `SymTable' + In the data type declaration for `SymTable' diff --git a/testsuite/tests/typecheck/should_fail/tcfail137.hs b/testsuite/tests/typecheck/should_fail/tcfail137.hs new file mode 100644 index 0000000000..3d3b4e0369 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail137.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DatatypeContexts #-} +-- Test the stupid context on newtypes +-- (GHC 6.4 dropped it on the floor by mistake) +module ShouldFail where + +newtype Floating a => Test a = Test [a] + +x = Test [False, True] diff --git a/testsuite/tests/typecheck/should_fail/tcfail137.stderr b/testsuite/tests/typecheck/should_fail/tcfail137.stderr new file mode 100644 index 0000000000..9cbe69b98d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail137.stderr @@ -0,0 +1,10 @@ + +tcfail137.hs:1:14: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + +tcfail137.hs:8:5: + No instance for (Floating Bool) + arising from a use of `Test' + Possible fix: add an instance declaration for (Floating Bool) + In the expression: Test [False, True] + In an equation for `x': x = Test [False, True] diff --git a/testsuite/tests/typecheck/should_fail/tcfail138.hs b/testsuite/tests/typecheck/should_fail/tcfail138.hs new file mode 100644 index 0000000000..cf91a023f4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail138.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, UndecidableInstances #-} +-- UndecidableInstances because (L a b) is no smaller than (C a b) + +-- This one shows up another rather subtle functional-dependecy +-- case. The error is: +-- +-- Could not deduce (C a b') from the context (C a b) +-- arising from the superclasses of an instance declaration at Foo.hs:8:0 +-- Probable fix: add (C a b') to the instance declaration superclass context +-- In the instance declaration for `C (Maybe a) a' +-- +-- Since L is a superclass of the (sought) constraint (C a b'), you might +-- think that we'd generate the superclasses (L a b') and (L a b), and now +-- the fundep will force b=b'. But GHC is very cautious about generating +-- superclasses when doing context reduction for instance declarations, +-- becasue of the danger of superclass loops. +-- +-- So, today, this program fails. It's trivial to fix by adding a fundep for C +-- class (G a, L a b) => C a b | a -> b + +-- Note: Sept 08: when fixing Trac #1470, tc138 started working! +-- This test is a very strange one (fundeps, undecidable instances), +-- so I'm just marking it as "should-succeed". It's not very clear to +-- me what the "right" answer should be; when we have the type equality +-- story more worked out we might want to think about that. + +module ShouldFail where + +class G a +class L a b | a -> b +class (G a, L a b) => C a b + +instance C a b' => G (Maybe a) +instance C a b => C (Maybe a) a +instance L (Maybe a) a diff --git a/testsuite/tests/typecheck/should_fail/tcfail138.stderr b/testsuite/tests/typecheck/should_fail/tcfail138.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail138.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail139.hs b/testsuite/tests/typecheck/should_fail/tcfail139.hs new file mode 100644 index 0000000000..af21c8afba --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail139.hs @@ -0,0 +1,6 @@ +-- Should be rejected by Haskell 98 + +module Foo where + +type Foo = Double +instance Bounded Foo diff --git a/testsuite/tests/typecheck/should_fail/tcfail139.stderr b/testsuite/tests/typecheck/should_fail/tcfail139.stderr new file mode 100644 index 0000000000..91559a9f68 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail139.stderr @@ -0,0 +1,7 @@ + +tcfail139.hs:6:10: + Illegal instance declaration for `Bounded Foo' + (All instance types must be of the form (T t1 ... tn) + where T is not a synonym. + Use -XTypeSynonymInstances if you want to disable this.) + In the instance declaration for `Bounded Foo' diff --git a/testsuite/tests/typecheck/should_fail/tcfail140.hs b/testsuite/tests/typecheck/should_fail/tcfail140.hs new file mode 100644 index 0000000000..791dd19cf8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail140.hs @@ -0,0 +1,22 @@ +-- GHC 6.4 gave pretty horrible error messages
+-- for some of these examples
+-- c.f. SourceForge [ ghc-Bugs-1231273 ] confusing error
+
+module ShouldFail where
+
+f :: Int -> Int
+f x = x
+
+bar = f 3 9
+
+rot xs = 3 `f` 4
+
+bot xs = map (3 `f`) xs
+
+t = ((\Just x -> x) :: Maybe a -> a) (Just 1)
+
+g :: Int -> Int
+g x y = True
+
+
+
diff --git a/testsuite/tests/typecheck/should_fail/tcfail140.stderr b/testsuite/tests/typecheck/should_fail/tcfail140.stderr new file mode 100644 index 0000000000..bc888d2309 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail140.stderr @@ -0,0 +1,29 @@ + +tcfail140.hs:10:7: + The function `f' is applied to two arguments, + but its type `Int -> Int' has only one + In the expression: f 3 9 + In an equation for `bar': bar = f 3 9 + +tcfail140.hs:12:10: + The operator `f' takes two arguments, + but its type `Int -> Int' has only one + In the expression: 3 `f` 4 + In an equation for `rot': rot xs = 3 `f` 4 + +tcfail140.hs:14:15: + The operator `f' takes two arguments, + but its type `Int -> Int' has only one + In the first argument of `map', namely `(3 `f`)' + In the expression: map (3 `f`) xs + In an equation for `bot': bot xs = map (3 `f`) xs + +tcfail140.hs:16:8: + Constructor `Just' should have 1 argument, but has been given none + In the pattern: Just + In the expression: (\ Just x -> x) :: Maybe a -> a + In the expression: ((\ Just x -> x) :: Maybe a -> a) (Just 1) + +tcfail140.hs:19:1: + The equation(s) for `g' have two arguments, + but its type `Int -> Int' has only one diff --git a/testsuite/tests/typecheck/should_fail/tcfail141.hs b/testsuite/tests/typecheck/should_fail/tcfail141.hs new file mode 100644 index 0000000000..12504d04f3 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail141.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +-- Should fail, because f :: (# Int#, ByteArray# #) + +module ShouldFail where + +import GHC.Prim (Int#, ByteArray#) + +main :: IO () +main = let f = int2Integer# 0# in putStrLn "" + + +int2Integer# :: Int# -> (# Int#, ByteArray# #) +int2Integer# = undefined +-- This function doesn't have to work! +-- We just need it for its type. + diff --git a/testsuite/tests/typecheck/should_fail/tcfail141.stderr b/testsuite/tests/typecheck/should_fail/tcfail141.stderr new file mode 100644 index 0000000000..27c7ede212 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail141.stderr @@ -0,0 +1,7 @@ + +tcfail141.hs:10:12: + The variable `f' cannot have an unboxed tuple type: + (# Int#, ByteArray# #) + In the expression: let f = int2Integer# 0# in putStrLn "" + In an equation for `main': + main = let f = int2Integer# 0# in putStrLn "" diff --git a/testsuite/tests/typecheck/should_fail/tcfail142.hs b/testsuite/tests/typecheck/should_fail/tcfail142.hs new file mode 100644 index 0000000000..add92e43ab --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail142.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- Tests top-level ambiguity resolution +-- This made a post-6.4 GHC fall over in TcSimplify + +module ShouldFail where + +class Foo a +instance Foo (a -> b) + +foo :: Foo a => a -> () +foo = undefined + +class Bar a r +-- The same happens if we use fundeps: +-- class Bar a r | r -> a + +bar :: Bar a r => r -> () +bar = undefined + +test = foo bar diff --git a/testsuite/tests/typecheck/should_fail/tcfail142.stderr b/testsuite/tests/typecheck/should_fail/tcfail142.stderr new file mode 100644 index 0000000000..cd0161658f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail142.stderr @@ -0,0 +1,8 @@ + +tcfail142.hs:21:12: + Ambiguous type variables `a0', `r0' in the constraint: + (Bar a0 r0) arising from a use of `bar' + Probable fix: add a type signature that fixes these type variable(s) + In the first argument of `foo', namely `bar' + In the expression: foo bar + In an equation for `test': test = foo bar diff --git a/testsuite/tests/typecheck/should_fail/tcfail143.hs b/testsuite/tests/typecheck/should_fail/tcfail143.hs new file mode 100644 index 0000000000..67eb62bafb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail143.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE UndecidableInstances, FlexibleInstances, + MultiParamTypeClasses, FunctionalDependencies #-} + +module Foo where + +data Z = Z +data S a = S a + +class MinMax a b c d | a b -> c d, a c d -> b, b c d -> a +instance MinMax Z Z Z Z -- (a) +instance MinMax a Z Z a -- (b) -- L1: wrongly flagged as error src. +instance MinMax Z b Z b -- (c) +instance MinMax a b c d => MinMax (S a) (S b) (S c) (S d) + -- (d) + +class Extend a b where extend :: a -> b -> b +instance Extend Z b where Z `extend` b = b +instance MinMax a b _c b => Extend a b where + _a `extend` b = b + +t :: MinMax a b _c d => a -> b -> d +t _ _ = (undefined :: d) + +n0 = Z +n1 = S n0 + +t1 = n1 `t` n0 -- L2 + +t2 = n1 `extend` n0 -- L3: uncommenting just this line produces + -- an error message pointing at L1 and L2 + -- with no mention of the real culprit, L3. + +-- t1 :: S Z -- L4: uncommenting this and L3 produces an + -- error message rightly pointing at L2 and L3. + + +{- n0 :: Z; n1 :: S Z + +Call of extend gives wanted: Extend (S Z) Z +Use instance => MinMax (S Z) Z gamma Z +FD on (b) => gamma ~ Z, Z ~ S Z + => MinMax (S Z) Z Z Z +FD on (a), 3rd fundep => Z ~ S Z + (b) again (sadly) Z ~ S Z + +-} +{- + +Here's what is happening. + +Lacking the type signature t1 :: S Z, we get + + n0 :: Z + n1 :: S v1 + t1 :: d1 with constraint ([L2] MinMax (S v1) Z c1 d1) + t2 :: Z with constraint ([L3] Extend (S v1) Z) + + [L2] MinMax (S v1) Z c1 d1, [L3] Extend (S v1) Z +---> <by instance for Extend a b> + [L2] MinMax (S v1) Z c1 d1, [L3] MinMax (S v1) Z c2 Z} +---> <combining these two constraints using (a b -> c d) + [L2] MinMax (S v1) Z c1 Z, [L3] MinMax (S v1) Z c1 Z} + +Now there are the two constraints are indistinguishable, +and both give rise to the same error: + +---> <combining first with [L1] instance MinMax a Z Z a> + c1=Z, Z=S v1 ERROR + +In either case, the error points to L1. + + +A different sequence leads to a different error: + + [L2] MinMax (S v1) Z c1 d1, [L3] Extend (S v1) Z +---> <by instance for Extend a b> + [L2] MinMax (S v1) Z c1 d1, [L3] MinMax (S v1) Z c2 Z} +---> <combining first with [L1] instance MinMax a Z Z a> + [L2] MinMax (S v1) Z Z (S2 v1), [L3] MinMax (S v1) Z c2 Z} + +Now combining the two constraints gives rise to the error, but +this time pointing to L2,L3. + +I can't explain exactly why adding the type signature for t1 +changes the order. + + +Hmm. Perhaps a good improvement strategy would be: + - first do improvement against the instance declartions + - and only then do pairwise improvement between constraints + +I've implemented that, and indeed it improves the result. +Instead of: + + Foo.hs:1:0: + Couldn't match `S Z' against `Z' + Expected type: S Z + Inferred type: Z + When using functional dependencies to combine + MinMax a Z Z a, arising from the instance declaration at Foo.hs:10:0 + MinMax (S Z) Z _c d, arising from use of `t' at Foo.hs:25:8-10 + +we get + + Foo.hs:1:0: + Couldn't match `S Z' against `Z' + Expected type: S Z + Inferred type: Z + When using functional dependencies to combine + MinMax a Z Z a, arising from the instance declaration at Foo.hs:10:0 + MinMax (S Z) Z _c Z, arising from use of `extend' at Foo.hs:27:8-15 + + +And this error in t2 is perfectly correct. You get it even if you comment +out the entire definition of t1. +-}
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/tcfail143.stderr b/testsuite/tests/typecheck/should_fail/tcfail143.stderr new file mode 100644 index 0000000000..846f8c0252 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail143.stderr @@ -0,0 +1,11 @@ + +tcfail143.hs:29:9: + Couldn't match type `S Z' with `Z' + When using functional dependencies to combine + MinMax a Z Z a, + arising from the dependency `a b -> c d' + in the instance declaration at tcfail143.hs:11:10 + MinMax (S Z) Z Z Z, + arising from a use of `extend' at tcfail143.hs:29:9-16 + In the expression: n1 `extend` n0 + In an equation for `t2': t2 = n1 `extend` n0 diff --git a/testsuite/tests/typecheck/should_fail/tcfail144.hs b/testsuite/tests/typecheck/should_fail/tcfail144.hs new file mode 100644 index 0000000000..bdeb6f6a91 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail144.hs @@ -0,0 +1,18 @@ +-- Both sets should fail in Haskell98 + +{-# LANGUAGE Haskell98 #-} + +module ShouldCompile where + + f1 :: Eq a => a -> Bool + f1 x = (x == x) || g1 True || g1 "Yes" + + 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_fail/tcfail144.stderr b/testsuite/tests/typecheck/should_fail/tcfail144.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail144.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail145.hs b/testsuite/tests/typecheck/should_fail/tcfail145.hs new file mode 100644 index 0000000000..d33dc1892f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail145.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} + +-- This fails, because the type in the pattern doesn't exactly match +-- the context type. We don't do subsumption in patterns any more. + +-- GHC 7.0: now we do again + +module Foo where + +foo :: (forall c. c -> c) -> [Char] +foo (f :: forall a. [a] -> [a]) = f undefined + diff --git a/testsuite/tests/typecheck/should_fail/tcfail145.stderr b/testsuite/tests/typecheck/should_fail/tcfail145.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail145.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail146.hs b/testsuite/tests/typecheck/should_fail/tcfail146.hs new file mode 100644 index 0000000000..f5ab46f4c5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail146.hs @@ -0,0 +1,7 @@ +module Foo1 where
+
+-- Variant: class used as data
+class SClass a where
+ sFun :: a -> SData a
+
+data SData a = SCon (SClass a)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail146.stderr b/testsuite/tests/typecheck/should_fail/tcfail146.stderr new file mode 100644 index 0000000000..25031ae618 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail146.stderr @@ -0,0 +1,5 @@ + +tcfail146.hs:7:16: + Class `SClass' used as a type + In the definition of data constructor `SCon' + In the data type declaration for `SData' diff --git a/testsuite/tests/typecheck/should_fail/tcfail147.hs b/testsuite/tests/typecheck/should_fail/tcfail147.hs new file mode 100644 index 0000000000..1ca703a403 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail147.hs @@ -0,0 +1,7 @@ +module Foo1 where
+
+-- Variant: ill-kinded.
+class XClass a where
+ xFun :: a -> XData
+
+data XData = XCon XClass
diff --git a/testsuite/tests/typecheck/should_fail/tcfail147.stderr b/testsuite/tests/typecheck/should_fail/tcfail147.stderr new file mode 100644 index 0000000000..81e77fe648 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail147.stderr @@ -0,0 +1,7 @@ + +tcfail147.hs:7:19: + `XClass' is not applied to enough type arguments + Expected kind `?', but `XClass' has kind `k0 -> *' + In the type `XClass' + In the definition of data constructor `XCon' + In the data type declaration for `XData' diff --git a/testsuite/tests/typecheck/should_fail/tcfail148.hs b/testsuite/tests/typecheck/should_fail/tcfail148.hs new file mode 100644 index 0000000000..d80db2ccf5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail148.hs @@ -0,0 +1,8 @@ +-- This one caused a panic in GHC 6.4 + +module Foo1 where + +data List elem = Cons elem List | Nil + +t1 :: List +t1 = Cons 1 Nil diff --git a/testsuite/tests/typecheck/should_fail/tcfail148.stderr b/testsuite/tests/typecheck/should_fail/tcfail148.stderr new file mode 100644 index 0000000000..13d4293807 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail148.stderr @@ -0,0 +1,7 @@ + +tcfail148.hs:5:28: + `List' is not applied to enough type arguments + Expected kind `?', but `List' has kind `* -> *' + In the type `List' + In the definition of data constructor `Cons' + In the data type declaration for `List' diff --git a/testsuite/tests/typecheck/should_fail/tcfail149.hs b/testsuite/tests/typecheck/should_fail/tcfail149.hs new file mode 100644 index 0000000000..2479ed75c8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail149.hs @@ -0,0 +1,14 @@ +module Main where + +class C a where + op :: (Show a, Show b) => a -> b -> String + -- This class op adds a constraint on 'a' + + -- In GHC 7.0 this is fine, and it's a royal + -- pain to reject it when in H98 mode, so + -- I'm just allowing it + +instance C Int where + op x y = show x ++ " " ++ show y + +main = print (op (1::Int) 2) diff --git a/testsuite/tests/typecheck/should_fail/tcfail149.stderr b/testsuite/tests/typecheck/should_fail/tcfail149.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail149.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail149.stdout b/testsuite/tests/typecheck/should_fail/tcfail149.stdout new file mode 100644 index 0000000000..c1fcb5d3f7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail149.stdout @@ -0,0 +1 @@ +"1 2" diff --git a/testsuite/tests/typecheck/should_fail/tcfail150.hs b/testsuite/tests/typecheck/should_fail/tcfail150.hs new file mode 100644 index 0000000000..cc2ca034ef --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail150.hs @@ -0,0 +1,6 @@ +module ShouldFail where + +-- !!! constraining the type variable in a class head is illegal +-- Simpler version of tcfail149 +class Foo a where + op :: Eq a => a -> a diff --git a/testsuite/tests/typecheck/should_fail/tcfail150.stderr b/testsuite/tests/typecheck/should_fail/tcfail150.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail150.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail151.hs b/testsuite/tests/typecheck/should_fail/tcfail151.hs new file mode 100644 index 0000000000..112973b71e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail151.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DatatypeContexts #-} +module ShouldFail where + +class (Show a, Eq a, Monad m) => Name m a where + hashName :: a -> Int + newName :: m a + +data Name a => Exp a = MkExp a +-- The kind error should be reported here +-- GHC 6.4 reported an error with the class decl + diff --git a/testsuite/tests/typecheck/should_fail/tcfail151.stderr b/testsuite/tests/typecheck/should_fail/tcfail151.stderr new file mode 100644 index 0000000000..bf549602e7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail151.stderr @@ -0,0 +1,8 @@ + +tcfail151.hs:1:14: + Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + +tcfail151.hs:8:6: + `Name a' is not applied to enough type arguments + Expected kind `?', but `Name a' has kind `* -> *' + In the data type declaration for `Exp' diff --git a/testsuite/tests/typecheck/should_fail/tcfail152.hs b/testsuite/tests/typecheck/should_fail/tcfail152.hs new file mode 100644 index 0000000000..3ebb6fe0f6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail152.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ExistentialQuantification #-} +
+-- This test made Hugs fail (Oct 05) because the constraint
+-- from the 'toInteger' call escaped from the pattern match
+
+module ShouldFail where
+
+data T = forall a. C a
+
+test (C x) = toInteger x
diff --git a/testsuite/tests/typecheck/should_fail/tcfail152.stderr b/testsuite/tests/typecheck/should_fail/tcfail152.stderr new file mode 100644 index 0000000000..5ae2f52f00 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail152.stderr @@ -0,0 +1,6 @@ + +tcfail152.hs:10:14: + No instance for (Integral a) + arising from a use of `toInteger' + In the expression: toInteger x + In an equation for `test': test (C x) = toInteger x diff --git a/testsuite/tests/typecheck/should_fail/tcfail153.hs b/testsuite/tests/typecheck/should_fail/tcfail153.hs new file mode 100644 index 0000000000..add0479980 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail153.hs @@ -0,0 +1,8 @@ +-- Killed a test compiler, so I thought it was worth including + +module ShouldFail where + +f :: a -> [a] +f x = g x + where + g y = if y then [] else [y] diff --git a/testsuite/tests/typecheck/should_fail/tcfail153.stderr b/testsuite/tests/typecheck/should_fail/tcfail153.stderr new file mode 100644 index 0000000000..0b40df47d1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail153.stderr @@ -0,0 +1,12 @@ + +tcfail153.hs:6:9: + Couldn't match type `a' with `Bool' + `a' is a rigid type variable bound by + the type signature for f :: a -> [a] at tcfail153.hs:6:1 + In the first argument of `g', namely `x' + In the expression: g x + In an equation for `f': + f x + = g x + where + g y = if y then [] else [...] diff --git a/testsuite/tests/typecheck/should_fail/tcfail154.hs b/testsuite/tests/typecheck/should_fail/tcfail154.hs new file mode 100644 index 0000000000..6e3161bd46 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail154.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module ShouldFail where + +data T a = MkT + +class C a b where + op :: T a -> T b -> Bool + +-- Repeated type variable in an instance constraint +-- should require UndecidableInstances +instance C a a => Eq (T a) where + (==) = op diff --git a/testsuite/tests/typecheck/should_fail/tcfail154.stderr b/testsuite/tests/typecheck/should_fail/tcfail154.stderr new file mode 100644 index 0000000000..f8f3d69a4c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail154.stderr @@ -0,0 +1,6 @@ + +tcfail154.hs:12:10: + Variable occurs more often in a constraint than in the instance head + in the constraint: C a a + (Use -XUndecidableInstances to permit this) + In the instance declaration for `Eq (T a)' diff --git a/testsuite/tests/typecheck/should_fail/tcfail155.hs b/testsuite/tests/typecheck/should_fail/tcfail155.hs new file mode 100644 index 0000000000..265d9d83a9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail155.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTs #-} + +-- Data type returns the wrong type + +module ShouldFail where + +data T a where + P :: L1 -> L2 + +data L1 = L1 +data L2 = L2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail155.stderr b/testsuite/tests/typecheck/should_fail/tcfail155.stderr new file mode 100644 index 0000000000..fcc1133d4d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail155.stderr @@ -0,0 +1,6 @@ + +tcfail155.hs:8:6: + Data constructor `P' returns type `L2' + instead of an instance of its parent type `T a' + In the definition of data constructor `P' + In the data type declaration for `T' diff --git a/testsuite/tests/typecheck/should_fail/tcfail156.hs b/testsuite/tests/typecheck/should_fail/tcfail156.hs new file mode 100644 index 0000000000..7956c5b76a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail156.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- Illegal existential context on a newtype + +module ShouldFail where + +newtype Foo = forall a . Foo a + diff --git a/testsuite/tests/typecheck/should_fail/tcfail156.stderr b/testsuite/tests/typecheck/should_fail/tcfail156.stderr new file mode 100644 index 0000000000..d93549e136 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail156.stderr @@ -0,0 +1,6 @@ + +tcfail156.hs:7:26: + A newtype constructor cannot have an existential context, + but `Foo' does + In the definition of data constructor `Foo' + In the newtype declaration for `Foo' diff --git a/testsuite/tests/typecheck/should_fail/tcfail157.hs b/testsuite/tests/typecheck/should_fail/tcfail157.hs new file mode 100644 index 0000000000..74f02ed1e5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail157.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances #-} +-- NB: *no* UndecidableInstances + +-- This one (due to Oleg) made 6.4.1 go into a loop in the typechecker, +-- despite the lack of UndecidableInstances +-- +-- The example corresponds to a type function (realized as a class E +-- with functional dependencies) in the context of an instance. +-- The function in question is +-- +-- class E m a b | m a -> b +-- instance E m (() -> ()) (m ()) +-- +-- We see that the result of the function, "m ()" is smaller (in the +-- number of constructors) that the functions' arguments, "m" and +-- "() -> ()" together. Plus any type variable free in the result is also +-- free in at least one of the arguments. And yet it loops. +module ShouldFail where + +class Foo m a where + foo :: m b -> a -> Bool + +instance Foo m () where + foo _ _ = True + +instance (E m a b, Foo m b) => Foo m (a->()) where + foo m f = undefined + +class E m a b | m a -> b where + tr :: m c -> a -> b + +-- There is only one instance of the class with functional dependencies +instance E m (() -> ()) (m ()) where + tr x = undefined + +-- GHC(i) loops + +test = foo (\f -> (f ()) :: ()) (\f -> (f ()) :: ()) diff --git a/testsuite/tests/typecheck/should_fail/tcfail157.stderr b/testsuite/tests/typecheck/should_fail/tcfail157.stderr new file mode 100644 index 0000000000..c68f957652 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail157.stderr @@ -0,0 +1,12 @@ + +tcfail157.hs:27:10: + Variable occurs more often in a constraint than in the instance head + in the constraint: E m a b + (Use -XUndecidableInstances to permit this) + In the instance declaration for `Foo m (a -> ())' + +tcfail157.hs:27:10: + Variable occurs more often in a constraint than in the instance head + in the constraint: Foo m b + (Use -XUndecidableInstances to permit this) + In the instance declaration for `Foo m (a -> ())' diff --git a/testsuite/tests/typecheck/should_fail/tcfail158.hs b/testsuite/tests/typecheck/should_fail/tcfail158.hs new file mode 100644 index 0000000000..95af345b36 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail158.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ExplicitForAll #-} + +-- This one actually crashed in 6.4.1 +-- There's a kind error in the signature for bar, +-- and we were recovering, and then crashing when we found +-- a scoped type variable not in scope + + data Val v sm = Val + foo :: forall v sm. Val v sm + foo = undefined + where foo1 :: Val v sm + foo1 = bar + -- Correct type signature: bar :: forall v sm. Val v sm + bar :: forall v. Val v + bar = undefined foo diff --git a/testsuite/tests/typecheck/should_fail/tcfail158.stderr b/testsuite/tests/typecheck/should_fail/tcfail158.stderr new file mode 100644 index 0000000000..b9c3a7dbca --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail158.stderr @@ -0,0 +1,6 @@ + +tcfail158.hs:14:19: + `Val v' is not applied to enough type arguments + Expected kind `*', but `Val v' has kind `* -> *' + In the type signature for `bar': + bar :: forall v. Val v diff --git a/testsuite/tests/typecheck/should_fail/tcfail159.hs b/testsuite/tests/typecheck/should_fail/tcfail159.hs new file mode 100644 index 0000000000..c0c2eb1902 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail159.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE UnboxedTuples #-} + +module ShouldFail where + +h :: Int -> (# Int, Int #) +h x = (# x,x #) + +foo x = case h x of + ~(# p, q #) -> p diff --git a/testsuite/tests/typecheck/should_fail/tcfail159.stderr b/testsuite/tests/typecheck/should_fail/tcfail159.stderr new file mode 100644 index 0000000000..b389ef1e96 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail159.stderr @@ -0,0 +1,8 @@ + +tcfail159.hs:9:11: + Kind incompatibility when matching types: + t0 :: * + (# Int, Int #) :: (#) + In the pattern: ~(# p, q #) + In a case alternative: ~(# p, q #) -> p + In the expression: case h x of { ~(# p, q #) -> p } diff --git a/testsuite/tests/typecheck/should_fail/tcfail160.hs b/testsuite/tests/typecheck/should_fail/tcfail160.hs new file mode 100644 index 0000000000..79b75df305 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail160.hs @@ -0,0 +1,8 @@ +-- Kind error message + +module ShouldFail where + +data T k = T (k Int) + +g :: T Int +g x = x diff --git a/testsuite/tests/typecheck/should_fail/tcfail160.stderr b/testsuite/tests/typecheck/should_fail/tcfail160.stderr new file mode 100644 index 0000000000..33cbbbb8f1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail160.stderr @@ -0,0 +1,7 @@ + +tcfail160.hs:7:8: + Kind mis-match + The first argument of `T' should have kind `* -> *', + but `Int' has kind `*' + In the type signature for `g': + g :: T Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail161.hs b/testsuite/tests/typecheck/should_fail/tcfail161.hs new file mode 100644 index 0000000000..6ebdfddc85 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail161.hs @@ -0,0 +1,7 @@ +-- Kind error message + +module ShouldFail where + +f :: [Maybe] +f x = x + diff --git a/testsuite/tests/typecheck/should_fail/tcfail161.stderr b/testsuite/tests/typecheck/should_fail/tcfail161.stderr new file mode 100644 index 0000000000..0b04d8ef02 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail161.stderr @@ -0,0 +1,6 @@ + +tcfail161.hs:5:7: + `Maybe' is not applied to enough type arguments + Expected kind `*', but `Maybe' has kind `* -> *' + In the type signature for `f': + f :: [Maybe] diff --git a/testsuite/tests/typecheck/should_fail/tcfail162.hs b/testsuite/tests/typecheck/should_fail/tcfail162.hs new file mode 100644 index 0000000000..b13ccaa33e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail162.hs @@ -0,0 +1,12 @@ + + + +-- Kind error messsage should not contain bangs + +module ShouldFail where + +import Foreign.ForeignPtr + +data Foo = Foo {-# UNPACK #-} !(ForeignPtr) + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail162.stderr b/testsuite/tests/typecheck/should_fail/tcfail162.stderr new file mode 100644 index 0000000000..ae7b1c5d27 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail162.stderr @@ -0,0 +1,7 @@ + +tcfail162.hs:10:16: + `ForeignPtr' is not applied to enough type arguments + Expected kind `?', but `ForeignPtr' has kind `* -> *' + In the type `{-# UNPACK #-} !ForeignPtr' + In the definition of data constructor `Foo' + In the data type declaration for `Foo' diff --git a/testsuite/tests/typecheck/should_fail/tcfail164.hs b/testsuite/tests/typecheck/should_fail/tcfail164.hs new file mode 100644 index 0000000000..97ff3caf4e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail164.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE MagicHash #-} + +-- Tests tagToEnum# hacks + +module ShouldFail where + +import GHC.Base + +-- Test 1: Polymorphic +f :: a +f = tagToEnum# 0# + +-- Test 2: Int value (not an Enumeration TyCon) +class Unboxable value where + readUnboxable :: Int -> value +instance Unboxable Int where + readUnboxable (I# value#) = tagToEnum# value# + diff --git a/testsuite/tests/typecheck/should_fail/tcfail164.stderr b/testsuite/tests/typecheck/should_fail/tcfail164.stderr new file mode 100644 index 0000000000..65f9c9f9ac --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail164.stderr @@ -0,0 +1,15 @@ + +tcfail164.hs:11:5: + Bad call to tagToEnum# at type a + Specify the type by giving a type signature + e.g. (tagToEnum# x) :: Bool + In the expression: tagToEnum# 0# + In an equation for `f': f = tagToEnum# 0# + +tcfail164.hs:17:34: + Bad call to tagToEnum# at type Int + Result type must be an enumeration type + In the expression: tagToEnum# value# + In an equation for `readUnboxable': + readUnboxable (I# value#) = tagToEnum# value# + In the instance declaration for `Unboxable Int' diff --git a/testsuite/tests/typecheck/should_fail/tcfail165.hs b/testsuite/tests/typecheck/should_fail/tcfail165.hs new file mode 100644 index 0000000000..c23a7f39b4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail165.hs @@ -0,0 +1,16 @@ +{-# OPTIONS -XImpredicativeTypes -fno-warn-deprecated-flags #-} + +module ShouldFail where + +import Control.Concurrent + +-- Attempt to put a polymorphic value in an MVar +-- Fails, but the error message is worth keeping an eye on +-- +-- Actually (Dec 06) it succeeds now +-- +-- In GHC 7.0 it fails again! (and rightly so) + +foo = do var <- newEmptyMVar :: IO (MVar (forall a. Show a => a -> String)) + putMVar var (show :: forall b. Show b => b -> String) + diff --git a/testsuite/tests/typecheck/should_fail/tcfail165.stderr b/testsuite/tests/typecheck/should_fail/tcfail165.stderr new file mode 100644 index 0000000000..878a707120 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail165.stderr @@ -0,0 +1,12 @@ + +tcfail165.hs:15:23: + Couldn't match expected type `forall a. Show a => a -> String' + with actual type `b0 -> String' + In the second argument of `putMVar', namely + `(show :: forall b. Show b => b -> String)' + In a stmt of a 'do' block: + putMVar var (show :: forall b. Show b => b -> String) + In the expression: + do { var <- newEmptyMVar :: + IO (MVar (forall a. Show a => a -> String)); + putMVar var (show :: forall b. Show b => b -> String) } diff --git a/testsuite/tests/typecheck/should_fail/tcfail166.hs b/testsuite/tests/typecheck/should_fail/tcfail166.hs new file mode 100644 index 0000000000..5a2d4b8df7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail166.hs @@ -0,0 +1,6 @@ +-- Without -XScopedTypeVariables, this should fail + +module ShouldFail where + +destroy :: (forall a. (a -> Maybe (b,a)) -> a -> c) -> [b] -> c +destroy = error "urk" diff --git a/testsuite/tests/typecheck/should_fail/tcfail166.stderr b/testsuite/tests/typecheck/should_fail/tcfail166.stderr new file mode 100644 index 0000000000..3907418e10 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail166.stderr @@ -0,0 +1,5 @@ + +tcfail166.hs:5:21: + Illegal symbol '.' in type + Perhaps you intended -XRankNTypes or similar flag + to enable explicit-forall syntax: forall <tvs>. <type> diff --git a/testsuite/tests/typecheck/should_fail/tcfail167.hs b/testsuite/tests/typecheck/should_fail/tcfail167.hs new file mode 100644 index 0000000000..b4d404a74d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail167.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +-- Test inspired by trac #366 +-- The C2 case is impossible due to the types + +module ShouldCompile where + +data T a where + C1 :: T Char + C2 :: T Float + +inaccessible :: T Char -> Char +inaccessible C1 = ' ' +inaccessible C2 = ' ' + diff --git a/testsuite/tests/typecheck/should_fail/tcfail167.stderr b/testsuite/tests/typecheck/should_fail/tcfail167.stderr new file mode 100644 index 0000000000..f62f524ebd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail167.stderr @@ -0,0 +1,9 @@ + +tcfail167.hs:14:14: + Couldn't match type `Char' with `Float' + Inaccessible code in + a pattern with constructor + C2 :: T Float, + in an equation for `inaccessible' + In the pattern: C2 + In an equation for `inaccessible': inaccessible C2 = ' ' diff --git a/testsuite/tests/typecheck/should_fail/tcfail168.hs b/testsuite/tests/typecheck/should_fail/tcfail168.hs new file mode 100644 index 0000000000..94a78a93b0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail168.hs @@ -0,0 +1,66 @@ + +-- Test trac #719 (shouldn't give the entire do block in the error message) + +module ShouldFail where + +foo = do + putChar + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + putChar 'a' + diff --git a/testsuite/tests/typecheck/should_fail/tcfail168.stderr b/testsuite/tests/typecheck/should_fail/tcfail168.stderr new file mode 100644 index 0000000000..f16f65bdb1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail168.stderr @@ -0,0 +1,12 @@ + +tcfail168.hs:8:11: + Couldn't match expected type `Char -> a0' with actual type `IO ()' + In the return type of a call of `putChar' + Probable cause: `putChar' is applied to too many arguments + In a stmt of a 'do' block: putChar 'a' + In the expression: + do { putChar; + putChar 'a'; + putChar 'a'; + putChar 'a'; + .... } diff --git a/testsuite/tests/typecheck/should_fail/tcfail169.hs b/testsuite/tests/typecheck/should_fail/tcfail169.hs new file mode 100644 index 0000000000..e0d6e4f838 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail169.hs @@ -0,0 +1,8 @@ + +-- Trac #958 + +module ShoulFail where + +data Succ a = S a -- NB: deriving Show omitted +data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show + diff --git a/testsuite/tests/typecheck/should_fail/tcfail169.stderr b/testsuite/tests/typecheck/should_fail/tcfail169.stderr new file mode 100644 index 0000000000..cfe63c06ee --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail169.stderr @@ -0,0 +1,9 @@ + +tcfail169.hs:7:51: + No instance for (Show (Succ a)) + arising from the 'deriving' clause of a data type declaration + Possible fix: + add an instance declaration for (Show (Succ a)) + or use a standalone 'deriving instance' declaration, + so you can specify the instance context yourself + When deriving the instance for (Show (Seq a)) diff --git a/testsuite/tests/typecheck/should_fail/tcfail170.hs b/testsuite/tests/typecheck/should_fail/tcfail170.hs new file mode 100644 index 0000000000..1e7838cb43 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail170.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + +module ShouldFail where + +class C a b | a -> b + +instance C [p] [q] + -- Coverage condition fails diff --git a/testsuite/tests/typecheck/should_fail/tcfail170.stderr b/testsuite/tests/typecheck/should_fail/tcfail170.stderr new file mode 100644 index 0000000000..914ab0cde0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail170.stderr @@ -0,0 +1,6 @@ + +tcfail170.hs:7:10: + Illegal instance declaration for `C [p] [q]' + (the Coverage Condition fails for one of the functional dependencies; + Use -XUndecidableInstances to permit this) + In the instance declaration for `C [p] [q]' diff --git a/testsuite/tests/typecheck/should_fail/tcfail171.hs b/testsuite/tests/typecheck/should_fail/tcfail171.hs new file mode 100644 index 0000000000..fb8e4b652c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail171.hs @@ -0,0 +1,9 @@ +module ShouldFail where + +-- This one made GHC fall over on implication constraints +-- Silly, but one more test does no harm + +import Text.Printf + +phex :: a -> b +phex x = printf "0x%x" x diff --git a/testsuite/tests/typecheck/should_fail/tcfail171.stderr b/testsuite/tests/typecheck/should_fail/tcfail171.stderr new file mode 100644 index 0000000000..b4efd33e32 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail171.stderr @@ -0,0 +1,6 @@ + +tcfail171.hs:9:10: + No instances for (PrintfType b, PrintfArg a) + arising from a use of `printf' + In the expression: printf "0x%x" x + In an equation for `phex': phex x = printf "0x%x" x diff --git a/testsuite/tests/typecheck/should_fail/tcfail172.hs b/testsuite/tests/typecheck/should_fail/tcfail172.hs new file mode 100644 index 0000000000..bb31501cec --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail172.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE GADTs #-} + +-- This one made GHC 6.6 give the very unhelpful error +-- Foo8.hs:11:10: +-- Couldn't match kind `?' against `* -> * -> *' +-- When matching the kinds of `t :: ?' and `t1 :: * -> * -> *' +-- Expected type: t1 +-- Inferred type: t +-- In the pattern: Nil + +module ShouldFail where + +data PatchSeq p a b where + Nil :: PatchSeq p a a + 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_fail/tcfail172.stderr b/testsuite/tests/typecheck/should_fail/tcfail172.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail172.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail173.hs b/testsuite/tests/typecheck/should_fail/tcfail173.hs new file mode 100644 index 0000000000..bad14bd539 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail173.hs @@ -0,0 +1,5 @@ + + +module ShouldFail where + +newtype (f <.> g) a = Compose (f (g a)) diff --git a/testsuite/tests/typecheck/should_fail/tcfail173.stderr b/testsuite/tests/typecheck/should_fail/tcfail173.stderr new file mode 100644 index 0000000000..ee8f59b525 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail173.stderr @@ -0,0 +1,3 @@ + +tcfail173.hs:5:10: + Malformed head of type or class declaration: (f <.> g) a diff --git a/testsuite/tests/typecheck/should_fail/tcfail174.hs b/testsuite/tests/typecheck/should_fail/tcfail174.hs new file mode 100644 index 0000000000..47c63d7248 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail174.hs @@ -0,0 +1,17 @@ +{-# OPTIONS -XImpredicativeTypes #-} + +module Foo where + +data Capture a = Base a + | Capture (Capture (forall x . x -> a)) + +g :: Capture (forall a . a -> a) +g = Base id -- Fails; need a rigid signature on 'id' + +-- This function should definitely be rejected, with or without type signature + +h1 = Capture g + +h2 :: Capture b +h2 = Capture g + diff --git a/testsuite/tests/typecheck/should_fail/tcfail174.stderr b/testsuite/tests/typecheck/should_fail/tcfail174.stderr new file mode 100644 index 0000000000..84c0868db4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail174.stderr @@ -0,0 +1,23 @@ + +tcfail174.hs:9:10: + Couldn't match expected type `forall a. a -> a' + with actual type `a0 -> a0' + In the first argument of `Base', namely `id' + In the expression: Base id + In an equation for `g': g = Base id + +tcfail174.hs:13:14: + Couldn't match expected type `forall x. x -> a0' + with actual type `forall a. a -> a' + Expected type: Capture (forall x. x -> a0) + Actual type: Capture (forall a. a -> a) + In the first argument of `Capture', namely `g' + In the expression: Capture g + +tcfail174.hs:16:14: + Couldn't match expected type `forall x. x -> b' + with actual type `forall a. a -> a' + Expected type: Capture (forall x. x -> b) + Actual type: Capture (forall a. a -> a) + In the first argument of `Capture', namely `g' + In the expression: Capture g diff --git a/testsuite/tests/typecheck/should_fail/tcfail175.hs b/testsuite/tests/typecheck/should_fail/tcfail175.hs new file mode 100644 index 0000000000..5eacd24291 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail175.hs @@ -0,0 +1,12 @@ + +-- Crashed GHC 6.6! +-- Trac #1153 + +module ShouldFail where + +eval :: Int -> String -> String -> String +eval 0 root actual = evalRHS 0 root actual + +evalRHS :: Int -> a +evalRHS 0 root actual = eval 0 root actual + diff --git a/testsuite/tests/typecheck/should_fail/tcfail175.stderr b/testsuite/tests/typecheck/should_fail/tcfail175.stderr new file mode 100644 index 0000000000..f181c00bcd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail175.stderr @@ -0,0 +1,7 @@ + +tcfail175.hs:11:1: + Couldn't match type `a' with `String -> String -> String' + `a' is a rigid type variable bound by + the type signature for evalRHS :: Int -> a at tcfail175.hs:11:1 + The equation(s) for `evalRHS' have three arguments, + but its type `Int -> a' has only one diff --git a/testsuite/tests/typecheck/should_fail/tcfail176.hs b/testsuite/tests/typecheck/should_fail/tcfail176.hs new file mode 100644 index 0000000000..39f3818ede --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail176.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTs #-} + +-- Newtype in GADT syntax + +module ShouldFail where + +newtype Bug a where Bug :: a -> Maybe a diff --git a/testsuite/tests/typecheck/should_fail/tcfail176.stderr b/testsuite/tests/typecheck/should_fail/tcfail176.stderr new file mode 100644 index 0000000000..f804b000cf --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail176.stderr @@ -0,0 +1,6 @@ + +tcfail176.hs:7:21: + Data constructor `Bug' returns type `Maybe a' + instead of an instance of its parent type `Bug a' + In the definition of data constructor `Bug' + In the newtype declaration for `Bug' diff --git a/testsuite/tests/typecheck/should_fail/tcfail177.hs b/testsuite/tests/typecheck/should_fail/tcfail177.hs new file mode 100644 index 0000000000..d9e60e96fc --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail177.hs @@ -0,0 +1,34 @@ +module ShouldFail where + +-- See Trac #1176 +-- This is really a pretty-printer test, not a typechecker test +-- The more infix ops we have, the worse fsep works + +-- Currently the error message looks ok, however + +allTests :: Bool +allTests = foo + [a ~?= b + ,"Three" ~?= "3" + ,"Four" ~?= "4" + ,"Five" ~?= "5" + ,"Five" ~?= "5" + ,"Five" ~?= "5" + ,"Five" ~?= "5" + ,"Five" ~?= "5" + ,"Five" ~?= "5" + ,"Two", "Two", "Two" + ,"Two", "Two", "Two" + ,"Two", "Two", "Two" + ,"Two", "Two", "Two" + ,"Two", "Two", "Two" + ,"Two", "Two", "Two"] + +a="" +b="" + +(~?=) :: a -> a -> Bool +(~?=) = error "urk" + +foo :: a -> Int +foo x = 0 diff --git a/testsuite/tests/typecheck/should_fail/tcfail177.stderr b/testsuite/tests/typecheck/should_fail/tcfail177.stderr new file mode 100644 index 0000000000..3107d1e668 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail177.stderr @@ -0,0 +1,9 @@ + +tcfail177.hs:10:12: + Couldn't match expected type `Bool' with actual type `Int' + In the return type of a call of `foo' + In the expression: + foo + [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", "Five" ~?= "5", ....] + In an equation for `allTests': + allTests = foo [a ~?= b, "Three" ~?= "3", "Four" ~?= "4", ....] diff --git a/testsuite/tests/typecheck/should_fail/tcfail178.hs b/testsuite/tests/typecheck/should_fail/tcfail178.hs new file mode 100644 index 0000000000..8071def02e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail178.hs @@ -0,0 +1,19 @@ +-- See Trac #1221 + +module ShouldFail where + +a :: Num a => (Bool -> [a]) -> [a] +a x = x True ++ [1] + +y :: b -> () +y = const () + +-- Typechecks ok +b = a (const [2]) + +-- This one had an uninformative error message +c = a y + +-- More informative +d = a () + diff --git a/testsuite/tests/typecheck/should_fail/tcfail178.stderr b/testsuite/tests/typecheck/should_fail/tcfail178.stderr new file mode 100644 index 0000000000..63119af75e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail178.stderr @@ -0,0 +1,13 @@ + +tcfail178.hs:15:7: + Couldn't match expected type `[a0]' with actual type `()' + Expected type: Bool -> [a0] + Actual type: Bool -> () + In the first argument of `a', namely `y' + In the expression: a y + +tcfail178.hs:18:7: + Couldn't match expected type `Bool -> [a0]' with actual type `()' + In the first argument of `a', namely `()' + In the expression: a () + In an equation for `d': d = a () diff --git a/testsuite/tests/typecheck/should_fail/tcfail179.hs b/testsuite/tests/typecheck/should_fail/tcfail179.hs new file mode 100644 index 0000000000..a270cbffb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail179.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- Exmaples from Doaitse Swierestra and Brandon Moore +-- GHC users mailing list, April 07, title "Release plans" + +-- This one should fail, but Hugs passes it + +module ShouldFail where + +data T s = forall x. T (s -> (x -> s) -> (x, s, Int)) + +run :: T s -> Int +run ts = case ts of + T g -> let (x,_, b) = g x id + in b + diff --git a/testsuite/tests/typecheck/should_fail/tcfail179.stderr b/testsuite/tests/typecheck/should_fail/tcfail179.stderr new file mode 100644 index 0000000000..ba995b65ea --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail179.stderr @@ -0,0 +1,14 @@ + +tcfail179.hs:14:41: + Couldn't match type `x' with `s' + `x' is a rigid type variable bound by + a pattern with constructor + T :: forall s x. (s -> (x -> s) -> (x, s, Int)) -> T s, + in a case alternative + at tcfail179.hs:14:14 + `s' is a rigid type variable bound by + the type signature for run :: T s -> Int at tcfail179.hs:13:1 + Expected type: x -> s + Actual type: x -> x + In the second argument of `g', namely `id' + In the expression: g x id diff --git a/testsuite/tests/typecheck/should_fail/tcfail180.hs b/testsuite/tests/typecheck/should_fail/tcfail180.hs new file mode 100644 index 0000000000..4c228eedda --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail180.hs @@ -0,0 +1,10 @@ + +-- Showed up a bug in bodySplitTyConApp + +module ShouldFail where + +p :: f b +p = error "urk" + +g x = case p of + True -> () diff --git a/testsuite/tests/typecheck/should_fail/tcfail180.stderr b/testsuite/tests/typecheck/should_fail/tcfail180.stderr new file mode 100644 index 0000000000..96d76100ea --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail180.stderr @@ -0,0 +1,6 @@ + +tcfail180.hs:10:9: + Couldn't match expected type `f0 b0' with actual type `Bool' + In the pattern: True + In a case alternative: True -> () + In the expression: case p of { True -> () } diff --git a/testsuite/tests/typecheck/should_fail/tcfail181.hs b/testsuite/tests/typecheck/should_fail/tcfail181.hs new file mode 100644 index 0000000000..01d06599ef --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail181.hs @@ -0,0 +1,18 @@ +-- GHC 6.7 at one point said wog's type was: +-- +-- wog :: forall t e (m :: * -> *). +-- (Monad GHC.Prim.Any1, Monad m) => +-- t -> Something (m Bool) e +-- +-- The stupid 'GHC.Prim.Any1' arose becuase of type ambiguity +-- which should be reported, and wasn't. + +module ShouldFail where + +data Something d e = Something{ bar:: d, initializer::e } + +foo :: (Monad m) => Something (m Bool) n +foo = undefined + +wog x = foo{bar = return True} + diff --git a/testsuite/tests/typecheck/should_fail/tcfail181.stderr b/testsuite/tests/typecheck/should_fail/tcfail181.stderr new file mode 100644 index 0000000000..59fe8b83af --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail181.stderr @@ -0,0 +1,8 @@ + +tcfail181.hs:17:9: + Ambiguous type variable `m0' in the constraint: + (Monad m0) arising from a use of `foo' + Probable fix: add a type signature that fixes these type variable(s) + In the expression: foo + In the expression: foo {bar = return True} + In an equation for `wog': wog x = foo {bar = return True} diff --git a/testsuite/tests/typecheck/should_fail/tcfail182.hs b/testsuite/tests/typecheck/should_fail/tcfail182.hs new file mode 100644 index 0000000000..7b04df489f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail182.hs @@ -0,0 +1,9 @@ +module Foo where + +import qualified Prelude +import Prelude hiding( Maybe ) + +data Maybe a = Foo + +f :: Prelude.Maybe a -> Int +f Foo = 3 diff --git a/testsuite/tests/typecheck/should_fail/tcfail182.stderr b/testsuite/tests/typecheck/should_fail/tcfail182.stderr new file mode 100644 index 0000000000..d6b97af250 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail182.stderr @@ -0,0 +1,6 @@ + +tcfail182.hs:9:3: + Couldn't match expected type `Prelude.Maybe a' + with actual type `Maybe t0' + In the pattern: Foo + In an equation for `f': f Foo = 3 diff --git a/testsuite/tests/typecheck/should_fail/tcfail183.hs b/testsuite/tests/typecheck/should_fail/tcfail183.hs new file mode 100644 index 0000000000..d46d87ad7c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail183.hs @@ -0,0 +1,4 @@ + +module ShouldCompile where + +newtype Swizzle = MkSwizzle (forall a. Ord a => [a] -> [a]) diff --git a/testsuite/tests/typecheck/should_fail/tcfail183.stderr b/testsuite/tests/typecheck/should_fail/tcfail183.stderr new file mode 100644 index 0000000000..fad1ccf736 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail183.stderr @@ -0,0 +1,5 @@ + +tcfail183.hs:4:38: + Illegal symbol '.' in type + Perhaps you intended -XRankNTypes or similar flag + to enable explicit-forall syntax: forall <tvs>. <type> diff --git a/testsuite/tests/typecheck/should_fail/tcfail184.hs b/testsuite/tests/typecheck/should_fail/tcfail184.hs new file mode 100644 index 0000000000..210a9c7c9b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail184.hs @@ -0,0 +1,8 @@ + +{-# OPTIONS_GHC -XScopedTypeVariables #-} +-- We don't actually want scoped type variables, but this flag makes the +-- forall be recognised by the parser + +module ShouldCompile where + +newtype Swizzle = MkSwizzle (forall a. Ord a => [a] -> [a]) diff --git a/testsuite/tests/typecheck/should_fail/tcfail184.stderr b/testsuite/tests/typecheck/should_fail/tcfail184.stderr new file mode 100644 index 0000000000..20920d822b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail184.stderr @@ -0,0 +1,7 @@ +
+tcfail184.hs:8:19:
+ Illegal polymorphic or qualified type:
+ forall a. Ord a => [a] -> [a]
+ Perhaps you intended to use -XRankNTypes or -XRank2Types
+ In the definition of data constructor `MkSwizzle'
+ In the newtype declaration for `Swizzle'
diff --git a/testsuite/tests/typecheck/should_fail/tcfail185.hs b/testsuite/tests/typecheck/should_fail/tcfail185.hs new file mode 100644 index 0000000000..59af50f738 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail185.hs @@ -0,0 +1,13 @@ +-- See Trac #1606 + +module ShouldFail where + +f :: Int -> Int -> Bool -> Bool -> Int -> Int +f a b = \ x y -> let { y1 = y; y2 = y1; y3 = y2; y4 = y3; y5 = y4; + y6 = y5; y7 = y6 } in x + + + + + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail185.stderr b/testsuite/tests/typecheck/should_fail/tcfail185.stderr new file mode 100644 index 0000000000..1e4c8d718f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail185.stderr @@ -0,0 +1,17 @@ + +tcfail185.hs:7:46: + Couldn't match expected type `Int -> Int' with actual type `Bool' + In the expression: x + In the expression: + let + y1 = y + y2 = y1 + y3 = y2 + .... + in x + In the expression: + \ x y + -> let + y1 = ... + .... + in x diff --git a/testsuite/tests/typecheck/should_fail/tcfail186.hs b/testsuite/tests/typecheck/should_fail/tcfail186.hs new file mode 100644 index 0000000000..6148517a6d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail186.hs @@ -0,0 +1,7 @@ +-- Trac #1814 + +module ShouldFail where + +import Tcfail186_Help + +foo = f "hoo"
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/tcfail186.stderr b/testsuite/tests/typecheck/should_fail/tcfail186.stderr new file mode 100644 index 0000000000..3f4504b810 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail186.stderr @@ -0,0 +1,7 @@ + +tcfail186.hs:7:9: + Couldn't match expected type `PhantomSyn a0' + with actual type `[Char]' + In the first argument of `f', namely `"hoo"' + In the expression: f "hoo" + In an equation for `foo': foo = f "hoo" diff --git a/testsuite/tests/typecheck/should_fail/tcfail186.stderr-ghc-7.0 b/testsuite/tests/typecheck/should_fail/tcfail186.stderr-ghc-7.0 new file mode 100644 index 0000000000..737a0663ea --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail186.stderr-ghc-7.0 @@ -0,0 +1,7 @@ + +tcfail186.hs:7:9: + Couldn't match expected type `Int' with actual type `[Char]' + Expected type: PhantomSyn a0 + Actual type: [Char] + In the first argument of `f', namely `"hoo"' + In the expression: f "hoo" diff --git a/testsuite/tests/typecheck/should_fail/tcfail187.hs b/testsuite/tests/typecheck/should_fail/tcfail187.hs new file mode 100644 index 0000000000..eb508066ec --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail187.hs @@ -0,0 +1,7 @@ +-- Trac #1806 + +module ShouldFail where + +data Foo = (:::) + +foo (x ::: y) = () diff --git a/testsuite/tests/typecheck/should_fail/tcfail187.stderr b/testsuite/tests/typecheck/should_fail/tcfail187.stderr new file mode 100644 index 0000000000..07a741d025 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail187.stderr @@ -0,0 +1,5 @@ + +tcfail187.hs:7:6: + Constructor `:::' should have no arguments, but has been given 2 + In the pattern: x ::: y + In an equation for `foo': foo (x ::: y) = () diff --git a/testsuite/tests/typecheck/should_fail/tcfail188.hs b/testsuite/tests/typecheck/should_fail/tcfail188.hs new file mode 100644 index 0000000000..a79087d90d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail188.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Rank2Types, KindSignatures #-} +{-# OPTIONS_GHC -Werror #-} + +-- Trac #959 + +module ShouldFail where + +data D (f :: (* -> *) -> * -> *) (af :: * -> *) (ax :: *) = + D (af (f af ax)) + +data CList (f :: (* -> *) -> * -> *) (a :: *) = + RCons a (CList (D f) a) + +type CycleList a = forall f. CList f a + +chead :: CycleList a -> a +chead ys = case ys of (RCons x xs) -> x diff --git a/testsuite/tests/typecheck/should_fail/tcfail188.stderr b/testsuite/tests/typecheck/should_fail/tcfail188.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail188.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail189.hs b/testsuite/tests/typecheck/should_fail/tcfail189.hs new file mode 100644 index 0000000000..3de16070c3 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail189.hs @@ -0,0 +1,11 @@ +-- Checks that the correct type is used checking the using clause of
+-- the group when a by clause is present
+
+{-# OPTIONS_GHC -XTransformListComp #-}
+
+module ShouldFail where
+
+foo = [ length x
+ | x <- [1..10]
+ , then group by x using take 2
+ ]
diff --git a/testsuite/tests/typecheck/should_fail/tcfail189.stderr b/testsuite/tests/typecheck/should_fail/tcfail189.stderr new file mode 100644 index 0000000000..b3a6cb4b96 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail189.stderr @@ -0,0 +1,8 @@ + +tcfail189.hs:10:31: + Couldn't match expected type `a -> t0' with actual type `[a0]' + Expected type: (a -> t0) -> [a] -> [[a]] + Actual type: [a0] -> [a0] + In the return type of a call of `take' + Probable cause: `take' is applied to too many arguments + In the expression: take 2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail190.hs b/testsuite/tests/typecheck/should_fail/tcfail190.hs new file mode 100644 index 0000000000..7cc768af65 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail190.hs @@ -0,0 +1,13 @@ + +-- Checks that the ordering constraint on the implicit groupWith is respected + +{-# OPTIONS_GHC -XTransformListComp #-} + +module ShouldFail where + +data Unorderable = Gnorf | Pinky | Brain + +foo = [ () + | x <- [Gnorf, Brain] + , then group by x + ] diff --git a/testsuite/tests/typecheck/should_fail/tcfail190.stderr b/testsuite/tests/typecheck/should_fail/tcfail190.stderr new file mode 100644 index 0000000000..a2e1034162 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail190.stderr @@ -0,0 +1,8 @@ + +tcfail190.hs:12:9: + No instance for (Ord Unorderable) + arising from a use of `Control.Monad.Group.mgroupWith' + Possible fix: add an instance declaration for (Ord Unorderable) + In the expression: Control.Monad.Group.mgroupWith + In a stmt of a list comprehension: then group by x + In the expression: [() | x <- [Gnorf, Brain], then group by x] diff --git a/testsuite/tests/typecheck/should_fail/tcfail191.hs b/testsuite/tests/typecheck/should_fail/tcfail191.hs new file mode 100644 index 0000000000..e6553d07e2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail191.hs @@ -0,0 +1,12 @@ +-- Checks that the correct type is used checking the using clause of the group + +{-# OPTIONS_GHC -XTransformListComp #-} + +module ShouldFail where + +data Unorderable = Gnorf | Pinky | Brain + +foo = [ () + | x <- [Gnorf, Brain] + , then group using take 5 + ] diff --git a/testsuite/tests/typecheck/should_fail/tcfail191.stderr b/testsuite/tests/typecheck/should_fail/tcfail191.stderr new file mode 100644 index 0000000000..6fd626afd4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail191.stderr @@ -0,0 +1,9 @@ + +tcfail191.hs:11:26: + Couldn't match type `a' with `[a]' + `a' is a rigid type variable bound by + a type expected by the context: [a] -> [[a]] at tcfail191.hs:11:9 + Expected type: [a] -> [[a]] + Actual type: [a] -> [a] + In the return type of a call of `take' + In the expression: take 5 diff --git a/testsuite/tests/typecheck/should_fail/tcfail192.hs b/testsuite/tests/typecheck/should_fail/tcfail192.hs new file mode 100644 index 0000000000..15de576d91 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail192.hs @@ -0,0 +1,11 @@ +-- Checks that the types of the old binder and the binder
+-- implicitly introduced by grouping are linked
+
+{-# OPTIONS_GHC -XTransformListComp #-}
+
+module ShouldFail where
+
+foo = [ x + 1
+ | x <- ["Hello", "World"]
+ , then group using take 5
+ ]
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/tcfail192.stderr b/testsuite/tests/typecheck/should_fail/tcfail192.stderr new file mode 100644 index 0000000000..d72c821fd6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail192.stderr @@ -0,0 +1,18 @@ + +tcfail192.hs:8:13: + No instance for (Num [[Char]]) + arising from the literal `1' + Possible fix: add an instance declaration for (Num [[Char]]) + In the second argument of `(+)', namely `1' + In the expression: x + 1 + In the expression: + [x + 1 | x <- ["Hello", "World"], then group using take 5] + +tcfail192.hs:10:26: + Couldn't match type `a' with `[a]' + `a' is a rigid type variable bound by + a type expected by the context: [a] -> [[a]] at tcfail192.hs:10:9 + Expected type: [a] -> [[a]] + Actual type: [a] -> [a] + In the return type of a call of `take' + In the expression: take 5 diff --git a/testsuite/tests/typecheck/should_fail/tcfail193.hs b/testsuite/tests/typecheck/should_fail/tcfail193.hs new file mode 100644 index 0000000000..f8bfd8f681 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail193.hs @@ -0,0 +1,11 @@ +-- Checks that the correct type is used checking the using clause of the transform
+
+{-# OPTIONS_GHC -XTransformListComp #-}
+
+module ShouldFail where
+
+import Data.List(inits)
+
+z :: [Int]
+z = [x | x <- [3, 2, 1], then inits]
+
diff --git a/testsuite/tests/typecheck/should_fail/tcfail193.stderr b/testsuite/tests/typecheck/should_fail/tcfail193.stderr new file mode 100644 index 0000000000..6fd99ae61b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail193.stderr @@ -0,0 +1,9 @@ + +tcfail193.hs:10:31: + Couldn't match type `a' with `[a]' + `a' is a rigid type variable bound by + a type expected by the context: [a] -> [a] at tcfail193.hs:10:26 + Expected type: [a] -> [a] + Actual type: [a] -> [[a]] + In the expression: inits + In a stmt of a list comprehension: then inits diff --git a/testsuite/tests/typecheck/should_fail/tcfail194.hs b/testsuite/tests/typecheck/should_fail/tcfail194.hs new file mode 100644 index 0000000000..9166b18b4a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail194.hs @@ -0,0 +1,10 @@ +-- Checks that using the "by" clause in a transform requires a function parameter + +{-# OPTIONS_GHC -XTransformListComp #-} + +module ShouldFail where + +import Data.List(take) + +z = [x | x <- [1..10], then take 5 by x] + diff --git a/testsuite/tests/typecheck/should_fail/tcfail194.stderr b/testsuite/tests/typecheck/should_fail/tcfail194.stderr new file mode 100644 index 0000000000..be6e37ec6b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail194.stderr @@ -0,0 +1,8 @@ + +tcfail194.hs:9:29: + Couldn't match expected type `a -> t0' with actual type `[a0]' + Expected type: (a -> t0) -> [a] -> [a] + Actual type: [a0] -> [a0] + In the return type of a call of `take' + Probable cause: `take' is applied to too many arguments + In the expression: take 5 diff --git a/testsuite/tests/typecheck/should_fail/tcfail195.hs b/testsuite/tests/typecheck/should_fail/tcfail195.hs new file mode 100644 index 0000000000..4c2408e8ba --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail195.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RankNTypes, GADTs #-} + +module ShouldFail where + +data Foo a where + Foo :: Int -> Foo (forall a. a) diff --git a/testsuite/tests/typecheck/should_fail/tcfail195.stderr b/testsuite/tests/typecheck/should_fail/tcfail195.stderr new file mode 100644 index 0000000000..5816773f48 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail195.stderr @@ -0,0 +1,5 @@ + +tcfail195.hs:6:3: + Illegal polymorphic or qualified type: forall a. a + In the definition of data constructor `Foo' + In the data type declaration for `Foo' diff --git a/testsuite/tests/typecheck/should_fail/tcfail196.hs b/testsuite/tests/typecheck/should_fail/tcfail196.hs new file mode 100644 index 0000000000..a88f3c7f44 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail196.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes #-} + +module ShouldFail where + +bar :: Num (forall a. a) => Int -> Int +bar = error "urk" + diff --git a/testsuite/tests/typecheck/should_fail/tcfail196.stderr b/testsuite/tests/typecheck/should_fail/tcfail196.stderr new file mode 100644 index 0000000000..79cc7266eb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail196.stderr @@ -0,0 +1,5 @@ +
+tcfail196.hs:5:1:
+ Illegal polymorphic or qualified type: forall a. a
+ In the type signature for `bar':
+ bar :: Num (forall a. a) => Int -> Int
diff --git a/testsuite/tests/typecheck/should_fail/tcfail197.hs b/testsuite/tests/typecheck/should_fail/tcfail197.hs new file mode 100644 index 0000000000..1aaffcd389 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail197.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes #-} + +module ShouldFail where + +foo :: [forall a. a] -> Int +foo = error "urk" + diff --git a/testsuite/tests/typecheck/should_fail/tcfail197.stderr b/testsuite/tests/typecheck/should_fail/tcfail197.stderr new file mode 100644 index 0000000000..3abe57be7b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail197.stderr @@ -0,0 +1,6 @@ + +tcfail197.hs:5:1: + Illegal polymorphic or qualified type: forall a. a + Perhaps you intended to use -XImpredicativeTypes + In the type signature for `foo': + foo :: [forall a. a] -> Int diff --git a/testsuite/tests/typecheck/should_fail/tcfail198.hs b/testsuite/tests/typecheck/should_fail/tcfail198.hs new file mode 100644 index 0000000000..658545e9b2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail198.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module ShouldFail where + +f3 :: forall a. [a] -> [a] +Just f3 = Just (\(x:xs) -> xs ++ [ x :: a ]) -- Not OK! + -- The type variable does not scope in a pattern binding diff --git a/testsuite/tests/typecheck/should_fail/tcfail198.stderr b/testsuite/tests/typecheck/should_fail/tcfail198.stderr new file mode 100644 index 0000000000..cc3ca54b14 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail198.stderr @@ -0,0 +1,9 @@ + +tcfail198.hs:6:17: + Couldn't match expected type `t0 -> t1' + with actual type `forall a. [a] -> [a]' + The lambda expression `\ (x : xs) -> xs ++ ...' has one argument, + but its type `forall a. [a] -> [a]' has none + In the first argument of `Just', namely + `(\ (x : xs) -> xs ++ [x :: a])' + In the expression: Just (\ (x : xs) -> xs ++ [x :: a]) diff --git a/testsuite/tests/typecheck/should_fail/tcfail199.hs b/testsuite/tests/typecheck/should_fail/tcfail199.hs new file mode 100644 index 0000000000..bf4dd6503d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail199.hs @@ -0,0 +1,5 @@ +-- trac #2179 + +module Main where + +main = "hi" diff --git a/testsuite/tests/typecheck/should_fail/tcfail199.stderr b/testsuite/tests/typecheck/should_fail/tcfail199.stderr new file mode 100644 index 0000000000..6866a26452 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail199.stderr @@ -0,0 +1,5 @@ + +tcfail199.hs:5:1: + Couldn't match expected type `IO t0' with actual type `[Char]' + In the expression: main + When checking the type of the function `main' diff --git a/testsuite/tests/typecheck/should_fail/tcfail200.hs b/testsuite/tests/typecheck/should_fail/tcfail200.hs new file mode 100644 index 0000000000..18d626207b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail200.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE MagicHash #-} + +module ShouldFail where + +f = let x = ( 1#, 'c' ) in x diff --git a/testsuite/tests/typecheck/should_fail/tcfail200.stderr b/testsuite/tests/typecheck/should_fail/tcfail200.stderr new file mode 100644 index 0000000000..90f590d8e2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail200.stderr @@ -0,0 +1,8 @@ + +tcfail200.hs:5:15: + Kind incompatibility when matching types: + t0 :: * + GHC.Prim.Int# :: # + In the expression: 1# + In the expression: (1#, 'c') + In an equation for `x': x = (1#, 'c') diff --git a/testsuite/tests/typecheck/should_fail/tcfail201.hs b/testsuite/tests/typecheck/should_fail/tcfail201.hs new file mode 100644 index 0000000000..276efd05ae --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail201.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Rank2Types #-} + + +-- Claus reported by email that +-- GHCi, version 6.9.20080217 loops on this program +-- http://www.haskell.org/pipermail/cvs-ghc/2008-June/043173.html +-- So I'm adding it to the test suite so that we'll see it if it happens again + +module Foo where + +data HsDoc id + = DocEmpty + | DocParagraph (HsDoc id) + +gfoldl' :: (forall a b . c (a -> b) -> a -> c b) -> (forall g . g -> c g) -> a -> c a +gfoldl' k z hsDoc = case hsDoc of + DocEmpty -> z DocEmpty + (DocParagraph hsDoc) -> z DocParagraph `k` hsDoc + + + + + diff --git a/testsuite/tests/typecheck/should_fail/tcfail201.stderr b/testsuite/tests/typecheck/should_fail/tcfail201.stderr new file mode 100644 index 0000000000..653e503edc --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail201.stderr @@ -0,0 +1,14 @@ + +tcfail201.hs:18:58: + Couldn't match type `a' with `HsDoc t0' + `a' is a rigid type variable bound by + the type signature for + gfoldl' :: (forall a1 b. c (a1 -> b) -> a1 -> c b) + -> (forall g. g -> c g) + -> a + -> c a + at tcfail201.hs:16:1 + Expected type: HsDoc t0 -> a + Actual type: HsDoc t0 -> HsDoc t0 + In the first argument of `z', namely `DocParagraph' + In the first argument of `k', namely `z DocParagraph' diff --git a/testsuite/tests/typecheck/should_fail/tcfail202.hs b/testsuite/tests/typecheck/should_fail/tcfail202.hs new file mode 100644 index 0000000000..7565755218 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail202.hs @@ -0,0 +1,13 @@ +-- trac #2307 +-- This was accepted due to a bug in GHC + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + OverlappingInstances, UndecidableInstances, IncoherentInstances, + FlexibleInstances #-} + +module Foo where + +class C a b c | b -> c +instance C Bool Int Float +instance C Char Int Double + diff --git a/testsuite/tests/typecheck/should_fail/tcfail202.stderr b/testsuite/tests/typecheck/should_fail/tcfail202.stderr new file mode 100644 index 0000000000..a43f726580 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail202.stderr @@ -0,0 +1,7 @@ + +tcfail202.hs:11:10: + Functional dependencies conflict between instance declarations: + instance [incoherent] C Bool Int Float + -- Defined at tcfail202.hs:11:10-25 + instance [incoherent] C Char Int Double + -- Defined at tcfail202.hs:12:10-26 diff --git a/testsuite/tests/typecheck/should_fail/tcfail203.hs b/testsuite/tests/typecheck/should_fail/tcfail203.hs new file mode 100644 index 0000000000..7f51dae3b5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail203.hs @@ -0,0 +1,54 @@ +-- trac #2806 + +{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-} + +module Foo where + +import GHC.Base + +pass1 = 'a' + where !x = 5# + +pass2 = 'a' + where !(I# x) = 5 + +pass3 = 'a' + where !(b, I# x) = (True, 5) + +pass4 = 'a' + where !(# b, I# x #) = (# True, 5 #) + +pass5 = 'a' + where !(# b, x #) = (# True, 5# #) + +fail1 = 'a' + where x = 5# + +fail2 = 'a' + where (I# x) = 5 + +fail3 = 'a' + where (b, I# x) = (True, 5) + +fail4 = 'a' + where (# b, I# x #) = (# True, 5 #) + +fail5 = 'a' + where (# b, x #) = (# True, 5# #) + +fail6 = 'a' + where (I# !x) = 5 + +fail7 = 'a' + where (b, !(I# x)) = (True, 5) + +fail8 = 'a' + where (# b, !(I# x) #) = (# True, 5 #) + +fail9 = 'a' + where (# b, !x #) = (# True, 5# #) +{- +-- Now in tcfail203a.hs, because it's an error +fail10 = 'a' + where !(b, ~(c, (I# x))) = (True, (False, 5)) +-} diff --git a/testsuite/tests/typecheck/should_fail/tcfail203.stderr b/testsuite/tests/typecheck/should_fail/tcfail203.stderr new file mode 100644 index 0000000000..29cf84095b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail203.stderr @@ -0,0 +1,36 @@ + +tcfail203.hs:28:11: + Warning: Pattern bindings containing unlifted types should use an outermost bang pattern: + (I# x) = 5 + In an equation for `fail2': + fail2 + = 'a' + where + (I# x) = 5 + +tcfail203.hs:31:11: + Warning: Pattern bindings containing unlifted types should use an outermost bang pattern: + (b, I# x) = (True, 5) + In an equation for `fail3': + fail3 + = 'a' + where + (b, I# x) = (True, 5) + +tcfail203.hs:40:11: + Warning: Pattern bindings containing unlifted types should use an outermost bang pattern: + (I# !x) = 5 + In an equation for `fail6': + fail6 + = 'a' + where + (I# !x) = 5 + +tcfail203.hs:43:11: + Warning: Pattern bindings containing unlifted types should use an outermost bang pattern: + (b, !(I# x)) = (True, 5) + In an equation for `fail7': + fail7 + = 'a' + where + (b, !(I# x)) = (True, 5) diff --git a/testsuite/tests/typecheck/should_fail/tcfail203a.hs b/testsuite/tests/typecheck/should_fail/tcfail203a.hs new file mode 100644 index 0000000000..fd5ccaefbb --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail203a.hs @@ -0,0 +1,10 @@ +-- trac #2806 + +{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-} + +module Foo where + +import GHC.Base + +fail10 = 'a' + where !(b, ~(c, (I# x))) = (True, (False, 5)) diff --git a/testsuite/tests/typecheck/should_fail/tcfail203a.stderr b/testsuite/tests/typecheck/should_fail/tcfail203a.stderr new file mode 100644 index 0000000000..272ff4254e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail203a.stderr @@ -0,0 +1,6 @@ + +tcfail203a.hs:10:16: + A lazy (~) pattern cannot contain unlifted types: ~(c, (I# x)) + In the pattern: ~(c, (I# x)) + In the pattern: (b, ~(c, (I# x))) + In the pattern: !(b, ~(c, (I# x))) diff --git a/testsuite/tests/typecheck/should_fail/tcfail204.hs b/testsuite/tests/typecheck/should_fail/tcfail204.hs new file mode 100644 index 0000000000..ed561c3290 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail204.hs @@ -0,0 +1,11 @@ + +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Werror #-} + +-- Trac #3261 + +module Foo where + +foo :: Int +foo = ceiling 6.3 + diff --git a/testsuite/tests/typecheck/should_fail/tcfail204.stderr b/testsuite/tests/typecheck/should_fail/tcfail204.stderr new file mode 100644 index 0000000000..e9d9bb739d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail204.stderr @@ -0,0 +1,13 @@ + +tcfail204.hs:10:15: + Warning: Defaulting the following constraint(s) to type `Double' + (Fractional a0) arising from the literal `6.3' + at tcfail204.hs:10:15-17 + (RealFrac a0) arising from a use of `ceiling' + at tcfail204.hs:10:7-13 + In the first argument of `ceiling', namely `6.3' + In the expression: ceiling 6.3 + In an equation for `foo': foo = ceiling 6.3 + +<no location info>: +Failing due to -Werror. diff --git a/testsuite/tests/typecheck/should_fail/tcfail205.hs b/testsuite/tests/typecheck/should_fail/tcfail205.hs new file mode 100644 index 0000000000..6b676fbb78 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail205.hs @@ -0,0 +1,3 @@ +module Fail where + +f x = foldl (+) [1 .. x] 'a' diff --git a/testsuite/tests/typecheck/should_fail/tcfail205.stderr b/testsuite/tests/typecheck/should_fail/tcfail205.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail205.stderr diff --git a/testsuite/tests/typecheck/should_fail/tcfail206.hs b/testsuite/tests/typecheck/should_fail/tcfail206.hs new file mode 100644 index 0000000000..a256bc3e34 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail206.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TupleSections, UnboxedTuples #-} +module Main where + +a :: Bool -> (Int, Bool) +a = ( , True) + +b :: Int -> Bool -> (Int, Bool) +b = (1, ) + +c :: a -> (a, Bool) +c = (True || False, ) + +d :: Bool -> (#Int, Bool#) +d = (# , True#) + +e :: Int -> Bool -> (#Int, Bool#) +e = (#1, #) + +f :: a -> (#a, Bool#) +f = (#True || False, #) + +main = return ()
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/tcfail206.stderr b/testsuite/tests/typecheck/should_fail/tcfail206.stderr new file mode 100644 index 0000000000..46419c4522 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail206.stderr @@ -0,0 +1,46 @@ + +tcfail206.hs:5:5: + Couldn't match expected type `Int' with actual type `Bool' + Expected type: Bool -> (Int, Bool) + Actual type: Bool -> (Bool, t0) + In the expression: (, True) + In an equation for `a': a = (, True) + +tcfail206.hs:8:5: + Couldn't match expected type `Bool -> (Int, Bool)' + with actual type `(t0, Int)' + Expected type: Int -> Bool -> (Int, Bool) + Actual type: Int -> (t0, Int) + In the expression: (1,) + In an equation for `b': b = (1,) + +tcfail206.hs:11:6: + Couldn't match type `a' with `Bool' + `a' is a rigid type variable bound by + the type signature for c :: a -> (a, Bool) at tcfail206.hs:11:1 + In the expression: True || False + In the expression: (True || False,) + In an equation for `c': c = (True || False,) + +tcfail206.hs:14:5: + Couldn't match expected type `Int' with actual type `Bool' + Expected type: Bool -> (# Int, Bool #) + Actual type: Bool -> (# Bool, t0 #) + In the expression: (# , True #) + In an equation for `d': d = (# , True #) + +tcfail206.hs:17:5: + Couldn't match expected type `Bool -> (# Int, Bool #)' + with actual type `(# t0, Int #)' + Expected type: Int -> Bool -> (# Int, Bool #) + Actual type: Int -> (# t0, Int #) + In the expression: (# 1, #) + In an equation for `e': e = (# 1, #) + +tcfail206.hs:20:7: + Couldn't match type `a' with `Bool' + `a' is a rigid type variable bound by + the type signature for f :: a -> (# a, Bool #) at tcfail206.hs:20:1 + In the expression: True || False + In the expression: (# True || False, #) + In an equation for `f': f = (# True || False, #) diff --git a/testsuite/tests/typecheck/should_fail/tcfail207.hs b/testsuite/tests/typecheck/should_fail/tcfail207.hs new file mode 100644 index 0000000000..cd57f4892f --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail207.hs @@ -0,0 +1,9 @@ +module Foo where + +f :: Int -> [Int] -> [Int] +-- Want an error message that says 'take' is applied to too many args +f x = take x [] + +g :: [Int] +-- Want an error message that says 'take' is applied to too few args +g = take 3 diff --git a/testsuite/tests/typecheck/should_fail/tcfail207.stderr b/testsuite/tests/typecheck/should_fail/tcfail207.stderr new file mode 100644 index 0000000000..307b4044d5 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail207.stderr @@ -0,0 +1,16 @@ + +tcfail207.hs:5:7: + Couldn't match expected type `[Int] -> [Int]' + with actual type `[a0]' + In the return type of a call of `take' + Probable cause: `take' is applied to too many arguments + In the expression: take x [] + In an equation for `f': f x = take x [] + +tcfail207.hs:9:5: + Couldn't match expected type `[Int]' + with actual type `[a0] -> [a0]' + In the return type of a call of `take' + Probable cause: `take' is applied to too few arguments + In the expression: take 3 + In an equation for `g': g = take 3 diff --git a/testsuite/tests/typecheck/should_fail/tcfail208.hs b/testsuite/tests/typecheck/should_fail/tcfail208.hs new file mode 100644 index 0000000000..71c0f3c19b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail208.hs @@ -0,0 +1,5 @@ +module Ctx where + +f :: (Monad m, Eq a) => a -> m a -> Bool +f x y = (return x == y) + diff --git a/testsuite/tests/typecheck/should_fail/tcfail208.stderr b/testsuite/tests/typecheck/should_fail/tcfail208.stderr new file mode 100644 index 0000000000..64200a696d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/tcfail208.stderr @@ -0,0 +1,13 @@ + +tcfail208.hs:4:19: + Could not deduce (Eq (m a)) arising from a use of `==' + from the context (Monad m, Eq a) + bound by the type signature for + f :: (Monad m, Eq a) => a -> m a -> Bool + at tcfail208.hs:4:1-23 + Possible fix: + add (Eq (m a)) to the context of + the type signature for f :: (Monad m, Eq a) => a -> m a -> Bool + or add an instance declaration for (Eq (m a)) + In the expression: (return x == y) + In an equation for `f': f x y = (return x == y) diff --git a/testsuite/tests/typecheck/should_run/IPRun.hs b/testsuite/tests/typecheck/should_run/IPRun.hs new file mode 100644 index 0000000000..66abe6dcbe --- /dev/null +++ b/testsuite/tests/typecheck/should_run/IPRun.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ImplicitParams #-} + +module Main where + +f0 :: (?x :: Int) => () -> Int +f0 () = let ?x = 5 in ?x + -- Should always return 5 + +f1 :: (?x :: Int) => () -> Int +f1 = let ?x = 5 in \() -> ?x + -- Should always return 5 + +f2 () = let ?x = 5 in \() -> ?x + -- Inferred type: (Num a, ?x::a) => () -> () -> a + -- should always return 5 + +f3 :: () -> ((?x :: Int) => Int) +-- Deep skolemisation means that the local x=5 still wins +f3 = let ?x = 5 in \() -> ?x + +main = let ?x = 0 in + do { print (f0 ()) + ; print (f1 ()) + ; print (f2 () ()) + ; print (f3 ()) } + diff --git a/testsuite/tests/typecheck/should_run/IPRun.stdout b/testsuite/tests/typecheck/should_run/IPRun.stdout new file mode 100644 index 0000000000..e558e3cc3a --- /dev/null +++ b/testsuite/tests/typecheck/should_run/IPRun.stdout @@ -0,0 +1,4 @@ +5 +5 +5 +5 diff --git a/testsuite/tests/typecheck/should_run/Makefile b/testsuite/tests/typecheck/should_run/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/typecheck/should_run/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/typecheck/should_run/T1624.hs b/testsuite/tests/typecheck/should_run/T1624.hs new file mode 100644 index 0000000000..e92e2664d3 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T1624.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} + +module Main where + +class Foo a b | a -> b where + foo :: a -> Maybe b + foo x = Nothing + + bar :: a -> b + +instance Foo (Maybe a) a where + bar (Just x) = x + + +main = do { print (foo (Just 'x')) + ; print (bar (Just 'y')) } diff --git a/testsuite/tests/typecheck/should_run/T1624.stdout b/testsuite/tests/typecheck/should_run/T1624.stdout new file mode 100644 index 0000000000..4cd37620ea --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T1624.stdout @@ -0,0 +1,2 @@ +Nothing +'y' diff --git a/testsuite/tests/typecheck/should_run/T1735.hs b/testsuite/tests/typecheck/should_run/T1735.hs new file mode 100644 index 0000000000..a8d453c39f --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T1735.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,
+ ScopedTypeVariables, GADTs, RankNTypes, FlexibleContexts,
+ MultiParamTypeClasses, GeneralizedNewtypeDeriving,
+ DeriveDataTypeable,
+ OverlappingInstances, UndecidableInstances, CPP #-}
+
+module Main (main) where
+
+import T1735_Help.Basics
+import T1735_Help.Xml
+
+data YesNo = Yes | No
+ deriving (Eq, Show, Typeable)
+instance Sat (ctx YesNo) => Data ctx YesNo where
+ toConstr _ Yes = yesConstr
+ toConstr _ No = noConstr
+ gunfold _ _ z c = case constrIndex c of
+ 1 -> z Yes
+ 2 -> z No
+ _ -> error "Foo"
+ dataTypeOf _ _ = yesNoDataType
+yesConstr :: Constr
+yesConstr = mkConstr yesNoDataType "Yes" [] Prefix
+noConstr :: Constr
+noConstr = mkConstr yesNoDataType "No" [] Prefix
+yesNoDataType :: DataType
+yesNoDataType = mkDataType "YesNo" [yesConstr, noConstr]
+
+newtype MyList a = MkMyList { unMyList :: [a] }
+ deriving (Show, Eq, Typeable)
+instance (Sat (ctx (MyList a)), Sat (ctx [a]), Data ctx a)
+ => Data ctx (MyList a) where
+ gfoldl _ f z x = z MkMyList `f` unMyList x
+ toConstr _ (MkMyList _) = mkMyListConstr
+ gunfold _ k z c = case constrIndex c of
+ 1 -> k (z MkMyList)
+ _ -> error "Foo"
+ dataTypeOf _ _ = myListDataType
+mkMyListConstr :: Constr
+mkMyListConstr = mkConstr myListDataType "MkMyList" [] Prefix
+myListDataType :: DataType
+myListDataType = mkDataType "MyList" [mkMyListConstr]
+
+#ifdef FOO
+rigidTests :: Maybe (Maybe [YesNo])
+rigidTests =
+ mkTest [Elem "No" []] (Just [No])
+#endif
+
+rigidManualTests :: Maybe (Maybe (MyList YesNo))
+rigidManualTests =
+ mkTest [Elem "MkMyList" [Elem "Yes" []]] (Just (MkMyList [Yes]))
+
+mkTest :: (Eq a, Xml a) => [Element] -> Maybe a -> Maybe (Maybe a)
+mkTest es v = case fromXml es of
+ v' | v == v' -> Nothing
+ | otherwise -> Just v'
+
+main :: IO ()
+main = print rigidManualTests
+
diff --git a/testsuite/tests/typecheck/should_run/T1735.stdout b/testsuite/tests/typecheck/should_run/T1735.stdout new file mode 100644 index 0000000000..4df191aac2 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T1735.stdout @@ -0,0 +1 @@ +Nothing
diff --git a/testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs b/testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs new file mode 100644 index 0000000000..c7fad91395 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE UndecidableInstances, OverlappingInstances, Rank2Types,
+ KindSignatures, EmptyDataDecls, MultiParamTypeClasses, CPP #-}
+
+{-
+
+(C) 2004--2005 Ralf Laemmel, Simon D. Foster
+
+This module approximates Data.Generics.Basics.
+
+-}
+
+
+module T1735_Help.Basics (
+
+ module Data.Typeable,
+ module T1735_Help.Context,
+ module T1735_Help.Basics
+
+) where
+
+import Data.Typeable
+import T1735_Help.Context
+
+#ifdef __HADDOCK__
+data Proxy
+#else
+data Proxy (a :: * -> *)
+#endif
+
+------------------------------------------------------------------------------
+-- The ingenious Data class
+
+class (Typeable a, Sat (ctx a)) => Data ctx a
+
+ where
+
+ gfoldl :: Proxy ctx
+ -> (forall b c. Data ctx b => w (b -> c) -> b -> w c)
+ -> (forall g. g -> w g)
+ -> a -> w a
+
+ -- Default definition for gfoldl
+ -- which copes immediately with basic datatypes
+ --
+ gfoldl _ _ z = z
+
+ gunfold :: Proxy ctx
+ -> (forall b r. Data ctx b => c (b -> r) -> c r)
+ -> (forall r. r -> c r)
+ -> Constr
+ -> c a
+
+ toConstr :: Proxy ctx -> a -> Constr
+
+ dataTypeOf :: Proxy ctx -> a -> DataType
+
+ -- incomplete implementation
+
+ gunfold _ _ _ _ = undefined
+
+ dataTypeOf _ _ = undefined
+
+ -- | Mediate types and unary type constructors
+ dataCast1 :: Typeable1 t
+ => Proxy ctx
+ -> (forall b. Data ctx b => w (t b))
+ -> Maybe (w a)
+ dataCast1 _ _ = Nothing
+
+ -- | Mediate types and binary type constructors
+ dataCast2 :: Typeable2 t
+ => Proxy ctx
+ -> (forall b c. (Data ctx b, Data ctx c) => w (t b c))
+ -> Maybe (w a)
+ dataCast2 _ _ = Nothing
+
+
+
+------------------------------------------------------------------------------
+
+-- Generic transformations
+
+type GenericT ctx = forall a. Data ctx a => a -> a
+
+
+-- Generic map for transformations
+
+gmapT :: Proxy ctx -> GenericT ctx -> GenericT ctx
+
+gmapT ctx f x = unID (gfoldl ctx k ID x)
+ where
+ k (ID g) y = ID (g (f y))
+
+
+-- The identity type constructor
+
+newtype ID x = ID { unID :: x }
+
+
+------------------------------------------------------------------------------
+
+-- Generic monadic transformations
+
+type GenericM m ctx = forall a. Data ctx a => a -> m a
+
+-- Generic map for monadic transformations
+
+gmapM :: Monad m => Proxy ctx -> GenericM m ctx -> GenericM m ctx
+gmapM ctx f = gfoldl ctx k return
+ where k c x = do c' <- c
+ x' <- f x
+ return (c' x')
+
+
+------------------------------------------------------------------------------
+
+-- Generic queries
+
+type GenericQ ctx r = forall a. Data ctx a => a -> r
+
+
+-- Map for queries
+
+gmapQ :: Proxy ctx -> GenericQ ctx r -> GenericQ ctx [r]
+gmapQ ctx f = gmapQr ctx (:) [] f
+
+gmapQr :: Data ctx a
+ => Proxy ctx
+ -> (r' -> r -> r)
+ -> r
+ -> GenericQ ctx r'
+ -> a
+ -> r
+gmapQr ctx o r f x = unQr (gfoldl ctx k (const (Qr id)) x) r
+ where
+ k (Qr g) y = Qr (\s -> g (f y `o` s))
+
+-- The type constructor used in definition of gmapQr
+newtype Qr r a = Qr { unQr :: r -> r }
+
+
+
+------------------------------------------------------------------------------
+--
+-- Generic unfolding
+--
+------------------------------------------------------------------------------
+
+
+
+-- | Build a term skeleton
+fromConstr :: Data ctx a => Proxy ctx -> Constr -> a
+fromConstr ctx = fromConstrB ctx undefined
+
+-- | Build a term and use a generic function for subterms
+fromConstrB :: Data ctx a
+ => Proxy ctx
+ -> (forall b. Data ctx b => b)
+ -> Constr
+ -> a
+fromConstrB ctx f = unID . gunfold ctx k z
+ where
+ k c = ID (unID c f)
+ z = ID
+
+
+
+-- | Monadic variation on \"fromConstrB\"
+fromConstrM :: (Monad m, Data ctx a)
+ => Proxy ctx
+ -> (forall b. Data ctx b => m b)
+ -> Constr
+ -> m a
+fromConstrM ctx f = gunfold ctx k z
+ where
+ k c = do { c' <- c; b <- f; return (c' b) }
+ z = return
+
+
+
+------------------------------------------------------------------------------
+--
+-- Datatype and constructor representations
+--
+------------------------------------------------------------------------------
+
+
+--
+-- | Representation of datatypes.
+-- | A package of constructor representations with names of type and module.
+-- | The list of constructors could be an array, a balanced tree, or others.
+--
+data DataType = DataType
+ { tycon :: String
+ , datarep :: DataRep
+ }
+
+ deriving Show
+
+
+-- | Representation of constructors
+data Constr = Constr
+ { conrep :: ConstrRep
+ , constring :: String
+ , confields :: [String] -- for AlgRep only
+ , confixity :: Fixity -- for AlgRep only
+ , datatype :: DataType
+ }
+
+instance Show Constr where
+ show = constring
+
+
+-- | Equality of constructors
+instance Eq Constr where
+ c == c' = constrRep c == constrRep c'
+
+
+-- | Public representation of datatypes
+data DataRep = AlgRep [Constr]
+ | IntRep
+ | FloatRep
+ | StringRep
+ | NoRep
+
+ deriving (Eq,Show)
+
+
+-- | Public representation of constructors
+data ConstrRep = AlgConstr ConIndex
+ | IntConstr Integer
+ | FloatConstr Double
+ | StringConstr String
+
+ deriving (Eq,Show)
+
+
+--
+-- | Unique index for datatype constructors.
+-- | Textual order is respected. Starts at 1.
+--
+type ConIndex = Int
+
+
+-- | Fixity of constructors
+data Fixity = Prefix
+ | Infix -- Later: add associativity and precedence
+
+ deriving (Eq,Show)
+
+
+------------------------------------------------------------------------------
+--
+-- Observers for datatype representations
+--
+------------------------------------------------------------------------------
+
+
+-- | Gets the type constructor including the module
+dataTypeName :: DataType -> String
+dataTypeName = tycon
+
+
+
+-- | Gets the public presentation of datatypes
+dataTypeRep :: DataType -> DataRep
+dataTypeRep = datarep
+
+
+-- | Gets the datatype of a constructor
+constrType :: Constr -> DataType
+constrType = datatype
+
+
+-- | Gets the public presentation of constructors
+constrRep :: Constr -> ConstrRep
+constrRep = conrep
+
+
+-- | Look up a constructor by its representation
+repConstr :: DataType -> ConstrRep -> Constr
+repConstr dt cr =
+ case (dataTypeRep dt, cr) of
+ (AlgRep cs, AlgConstr i) -> cs !! (i-1)
+ (IntRep, IntConstr i) -> mkIntConstr dt i
+ (FloatRep, FloatConstr f) -> mkFloatConstr dt f
+ (StringRep, StringConstr str) -> mkStringConstr dt str
+ _ -> error "repConstr"
+
+
+
+------------------------------------------------------------------------------
+--
+-- Representations of algebraic data types
+--
+------------------------------------------------------------------------------
+
+
+-- | Constructs an algebraic datatype
+mkDataType :: String -> [Constr] -> DataType
+mkDataType str cs = DataType
+ { tycon = str
+ , datarep = AlgRep cs
+ }
+
+
+-- | Constructs a constructor
+mkConstr :: DataType -> String -> [String] -> Fixity -> Constr
+mkConstr dt str fields fix =
+ Constr
+ { conrep = AlgConstr idx
+ , constring = str
+ , confields = fields
+ , confixity = fix
+ , datatype = dt
+ }
+ where
+ idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],
+ showConstr c == str ]
+
+
+-- | Gets the constructors
+dataTypeConstrs :: DataType -> [Constr]
+dataTypeConstrs dt = case datarep dt of
+ (AlgRep cons) -> cons
+ _ -> error "dataTypeConstrs"
+
+
+-- | Gets the field labels of a constructor
+constrFields :: Constr -> [String]
+constrFields = confields
+
+
+-- | Gets the fixity of a constructor
+constrFixity :: Constr -> Fixity
+constrFixity = confixity
+
+
+
+------------------------------------------------------------------------------
+--
+-- From strings to constr's and vice versa: all data types
+--
+------------------------------------------------------------------------------
+
+
+-- | Gets the string for a constructor
+showConstr :: Constr -> String
+showConstr = constring
+
+
+-- | Lookup a constructor via a string
+readConstr :: DataType -> String -> Maybe Constr
+readConstr dt str =
+ case dataTypeRep dt of
+ AlgRep cons -> idx cons
+ IntRep -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i)))
+ FloatRep -> mkReadCon (\f -> (mkPrimCon dt str (FloatConstr f)))
+ StringRep -> Just (mkStringConstr dt str)
+ NoRep -> Nothing
+ where
+
+ -- Read a value and build a constructor
+ mkReadCon :: Read t => (t -> Constr) -> Maybe Constr
+ mkReadCon f = case (reads str) of
+ [(t,"")] -> Just (f t)
+ _ -> Nothing
+
+ -- Traverse list of algebraic datatype constructors
+ idx :: [Constr] -> Maybe Constr
+ idx cons = let fit = filter ((==) str . showConstr) cons
+ in if fit == []
+ then Nothing
+ else Just (head fit)
+
+
+------------------------------------------------------------------------------
+--
+-- Convenience funtions: algebraic data types
+--
+------------------------------------------------------------------------------
+
+
+-- | Test for an algebraic type
+isAlgType :: DataType -> Bool
+isAlgType dt = case datarep dt of
+ (AlgRep _) -> True
+ _ -> False
+
+
+-- | Gets the constructor for an index
+indexConstr :: DataType -> ConIndex -> Constr
+indexConstr dt idx = case datarep dt of
+ (AlgRep cs) -> cs !! (idx-1)
+ _ -> error "indexConstr"
+
+
+-- | Gets the index of a constructor
+constrIndex :: Constr -> ConIndex
+constrIndex con = case constrRep con of
+ (AlgConstr idx) -> idx
+ _ -> error "constrIndex"
+
+
+-- | Gets the maximum constructor index
+maxConstrIndex :: DataType -> ConIndex
+maxConstrIndex dt = case dataTypeRep dt of
+ AlgRep cs -> length cs
+ _ -> error "maxConstrIndex"
+
+
+
+------------------------------------------------------------------------------
+--
+-- Representation of primitive types
+--
+------------------------------------------------------------------------------
+
+
+-- | Constructs the Int type
+mkIntType :: String -> DataType
+mkIntType = mkPrimType IntRep
+
+
+-- | Constructs the Float type
+mkFloatType :: String -> DataType
+mkFloatType = mkPrimType FloatRep
+
+
+-- | Constructs the String type
+mkStringType :: String -> DataType
+mkStringType = mkPrimType StringRep
+
+
+-- | Helper for mkIntType, mkFloatType, mkStringType
+mkPrimType :: DataRep -> String -> DataType
+mkPrimType dr str = DataType
+ { tycon = str
+ , datarep = dr
+ }
+
+
+-- Makes a constructor for primitive types
+mkPrimCon :: DataType -> String -> ConstrRep -> Constr
+mkPrimCon dt str cr = Constr
+ { datatype = dt
+ , conrep = cr
+ , constring = str
+ , confields = error $ concat ["constrFields : ", (tycon dt), " is primative"]
+ , confixity = error "constrFixity"
+ }
+
+
+mkIntConstr :: DataType -> Integer -> Constr
+mkIntConstr dt i = case datarep dt of
+ IntRep -> mkPrimCon dt (show i) (IntConstr i)
+ _ -> error "mkIntConstr"
+
+
+mkFloatConstr :: DataType -> Double -> Constr
+mkFloatConstr dt f = case datarep dt of
+ FloatRep -> mkPrimCon dt (show f) (FloatConstr f)
+ _ -> error "mkFloatConstr"
+
+
+mkStringConstr :: DataType -> String -> Constr
+mkStringConstr dt str = case datarep dt of
+ StringRep -> mkPrimCon dt str (StringConstr str)
+ _ -> error "mkStringConstr"
+
+
+------------------------------------------------------------------------------
+--
+-- Non-representations for non-presentable types
+--
+------------------------------------------------------------------------------
+
+
+-- | Constructs a non-representation
+mkNorepType :: String -> DataType
+mkNorepType str = DataType
+ { tycon = str
+ , datarep = NoRep
+ }
+
+
+-- | Test for a non-representable type
+isNorepType :: DataType -> Bool
+isNorepType dt = case datarep dt of
+ NoRep -> True
+ _ -> False
+
diff --git a/testsuite/tests/typecheck/should_run/T1735_Help/Context.hs b/testsuite/tests/typecheck/should_run/T1735_Help/Context.hs new file mode 100644 index 0000000000..25b9df94a8 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T1735_Help/Context.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE UndecidableInstances, OverlappingInstances, EmptyDataDecls #-}
+
+{-
+
+(C) 2004 Ralf Laemmel
+
+Context parameterisation and context passing.
+
+-}
+
+
+module T1735_Help.Context
+
+where
+
+------------------------------------------------------------------------------
+
+--
+-- The Sat class from John Hughes' "Restricted Data Types in Haskell"
+--
+
+class Sat a
+ where
+ dict :: a
+
+
+------------------------------------------------------------------------------
+
+-- No context
+
+data NoCtx a
+
+noCtx :: NoCtx ()
+noCtx = undefined
+
+instance Sat (NoCtx a) where dict = undefined
+
+
+------------------------------------------------------------------------------
+
+-- Pair context
+
+data PairCtx l r a
+ = PairCtx { leftCtx :: l a
+ , rightCtx :: r a }
+
+pairCtx :: l () -> r () -> PairCtx l r ()
+pairCtx _ _ = undefined
+
+instance (Sat (l a), Sat (r a))
+ => Sat (PairCtx l r a)
+ where
+ dict = PairCtx { leftCtx = dict
+ , rightCtx = dict }
+
+
+------------------------------------------------------------------------------
diff --git a/testsuite/tests/typecheck/should_run/T1735_Help/Instances.hs b/testsuite/tests/typecheck/should_run/T1735_Help/Instances.hs new file mode 100644 index 0000000000..6a626138ea --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T1735_Help/Instances.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses,
+ UndecidableInstances, OverlappingInstances, CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- This is a module full of orphans, so don't warn about them
+
+module T1735_Help.Instances () where
+
+import T1735_Help.Basics
+import Data.Typeable
+
+charType :: DataType
+charType = mkStringType "Prelude.Char"
+
+instance Sat (ctx Char) =>
+ Data ctx Char where
+ toConstr _ x = mkStringConstr charType [x]
+ gunfold _ _ z c = case constrRep c of
+ (StringConstr [x]) -> z x
+ _ -> error "gunfold Char"
+ dataTypeOf _ _ = charType
+
+nilConstr :: Constr
+nilConstr = mkConstr listDataType "[]" [] Prefix
+consConstr :: Constr
+consConstr = mkConstr listDataType "(:)" [] Infix
+listDataType :: DataType
+listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr]
+
+instance (Sat (ctx [a]), Data ctx a) =>
+ Data ctx [a] where
+ gfoldl _ _ z [] = z []
+ gfoldl _ f z (x:xs) = z (:) `f` x `f` xs
+ toConstr _ [] = nilConstr
+ toConstr _ (_:_) = consConstr
+ gunfold _ k z c = case constrIndex c of
+ 1 -> z []
+ 2 -> k (k (z (:)))
+ _ -> error "gunfold List"
+ dataTypeOf _ _ = listDataType
+ dataCast1 _ f = gcast1 f
+
diff --git a/testsuite/tests/typecheck/should_run/T1735_Help/Main.hs b/testsuite/tests/typecheck/should_run/T1735_Help/Main.hs new file mode 100644 index 0000000000..0a6e1c59f4 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T1735_Help/Main.hs @@ -0,0 +1,62 @@ +
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,
+ PatternSignatures, GADTs, RankNTypes, FlexibleContexts,
+ MultiParamTypeClasses, GeneralizedNewtypeDeriving,
+ DeriveDataTypeable,
+ OverlappingInstances, UndecidableInstances, CPP #-}
+
+module Main (main) where
+
+import SYBWC.Basics
+import Xml
+
+data YesNo = Yes | No
+ deriving (Eq, Show, Typeable)
+instance Sat (ctx YesNo) => Data ctx YesNo where
+ toConstr _ Yes = yesConstr
+ toConstr _ No = noConstr
+ gunfold _ _ z c = case constrIndex c of
+ 1 -> z Yes
+ 2 -> z No
+ _ -> error "Foo"
+ dataTypeOf _ _ = yesNoDataType
+yesConstr :: Constr
+yesConstr = mkConstr yesNoDataType "Yes" [] Prefix
+noConstr :: Constr
+noConstr = mkConstr yesNoDataType "No" [] Prefix
+yesNoDataType :: DataType
+yesNoDataType = mkDataType "YesNo" [yesConstr, noConstr]
+
+newtype MyList a = MkMyList { unMyList :: [a] }
+ deriving (Show, Eq, Typeable)
+instance (Sat (ctx (MyList a)), Sat (ctx [a]), Data ctx a)
+ => Data ctx (MyList a) where
+ gfoldl _ f z x = z MkMyList `f` unMyList x
+ toConstr _ (MkMyList _) = mkMyListConstr
+ gunfold _ k z c = case constrIndex c of
+ 1 -> k (z MkMyList)
+ _ -> error "Foo"
+ dataTypeOf _ _ = myListDataType
+mkMyListConstr :: Constr
+mkMyListConstr = mkConstr myListDataType "MkMyList" [] Prefix
+myListDataType :: DataType
+myListDataType = mkDataType "MyList" [mkMyListConstr]
+
+#ifdef FOO
+rigidTests :: Maybe (Maybe [YesNo])
+rigidTests =
+ mkTest [Elem "No" []] (Just [No])
+#endif
+
+rigidManualTests :: Maybe (Maybe (MyList YesNo))
+rigidManualTests =
+ mkTest [Elem "MkMyList" [Elem "Yes" []]] (Just (MkMyList [Yes]))
+
+mkTest :: (Eq a, Xml a) => [Element] -> Maybe a -> Maybe (Maybe a)
+mkTest es v = case fromXml es of
+ v' | v == v' -> Nothing
+ | otherwise -> Just v'
+
+main :: IO ()
+main = print rigidManualTests
+
diff --git a/testsuite/tests/typecheck/should_run/T1735_Help/State.hs b/testsuite/tests/typecheck/should_run/T1735_Help/State.hs new file mode 100644 index 0000000000..7b048eb2df --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T1735_Help/State.hs @@ -0,0 +1,18 @@ +
+module T1735_Help.State where
+
+newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
+
+instance Monad m => Monad (StateT s m) where
+ return a = StateT $ \s -> return (a, s)
+ m >>= k = StateT $ \s -> do
+ ~(a, s') <- runStateT m s
+ runStateT (k a) s'
+ fail str = StateT $ \_ -> fail str
+
+get :: Monad m => StateT s m s
+get = StateT $ \s -> return (s, s)
+
+put :: Monad m => s -> StateT s m ()
+put s = StateT $ \_ -> return ((), s)
+
diff --git a/testsuite/tests/typecheck/should_run/T1735_Help/Xml.hs b/testsuite/tests/typecheck/should_run/T1735_Help/Xml.hs new file mode 100644 index 0000000000..b641c6a82c --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T1735_Help/Xml.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,
+ GADTs, RankNTypes, FlexibleContexts, TypeSynonymInstances,
+ MultiParamTypeClasses, DeriveDataTypeable, PatternGuards,
+ OverlappingInstances, UndecidableInstances, CPP #-}
+
+module T1735_Help.Xml (Element(..), Xml, fromXml) where
+
+import T1735_Help.Basics
+import T1735_Help.Instances ()
+import T1735_Help.State
+
+data Element = Elem String [Element]
+ | CData String
+ | Attr String String
+
+fromXml :: Xml a => [Element] -> Maybe a
+fromXml xs = case readXml xs of
+ Just (_, v) -> return v
+ Nothing -> error "XXX"
+
+class (Data XmlD a) => Xml a where
+ toXml :: a -> [Element]
+ toXml = defaultToXml
+
+ readXml :: [Element] -> Maybe ([Element], a)
+ readXml = defaultReadXml
+
+ readXml' :: [Element] -> Maybe ([Element], a)
+ readXml' = defaultReadXml'
+
+instance (Data XmlD t, Show t) => Xml t
+
+data XmlD a = XmlD { toXmlD :: a -> [Element], readMXmlD :: ReadM Maybe a }
+
+xmlProxy :: Proxy XmlD
+xmlProxy = error "xmlProxy"
+
+instance Xml t => Sat (XmlD t) where
+ dict = XmlD { toXmlD = toXml, readMXmlD = readMXml }
+
+defaultToXml :: Xml t => t -> [Element]
+defaultToXml x = [Elem (constring $ toConstr xmlProxy x) (transparentToXml x)]
+
+transparentToXml :: Xml t => t -> [Element]
+transparentToXml x = concat $ gmapQ xmlProxy (toXmlD dict) x
+
+-- Don't do any defaulting here, as these functions can be implemented
+-- differently by the user. We do the defaulting elsewhere instead.
+-- The t' type is thus not used.
+
+defaultReadXml :: Xml t => [Element] -> Maybe ([Element], t)
+defaultReadXml es = readXml' es
+
+defaultReadXml' :: Xml t => [Element] -> Maybe ([Element], t)
+defaultReadXml' = readXmlWith readVersionedElement
+
+readXmlWith :: Xml t
+ => (Element -> Maybe t)
+ -> [Element]
+ -> Maybe ([Element], t)
+readXmlWith f es = case es of
+ e : es' ->
+ case f e of
+ Just v -> Just (es', v)
+ Nothing -> Nothing
+ [] ->
+ Nothing
+
+readVersionedElement :: forall t . Xml t => Element -> Maybe t
+readVersionedElement e = readElement e
+
+readElement :: forall t . Xml t => Element -> Maybe t
+readElement (Elem n es) = res
+ where resType :: t
+ resType = typeNotValue resType
+ resDataType = dataTypeOf xmlProxy resType
+ con = readConstr resDataType n
+ res = case con of
+ Just c -> f c
+ Nothing -> Nothing
+ f c = let m :: Maybe ([Element], t)
+ m = constrFromElements c es
+ in case m of
+ Just ([], x) -> Just x
+ _ -> Nothing
+readElement _ = Nothing
+
+constrFromElements :: forall t . Xml t
+ => Constr -> [Element] -> Maybe ([Element], t)
+constrFromElements c es
+ = do let st = ReadState { xmls = es }
+ m :: ReadM Maybe t
+ m = fromConstrM xmlProxy (readMXmlD dict) c
+ -- XXX Should we flip the result order?
+ (x, st') <- runStateT m st
+ return (xmls st', x)
+
+type ReadM m = StateT ReadState m
+
+data ReadState = ReadState {
+ xmls :: [Element]
+ }
+
+getXmls :: Monad m => ReadM m [Element]
+getXmls = do st <- get
+ return $ xmls st
+
+putXmls :: Monad m => [Element] -> ReadM m ()
+putXmls xs = do st <- get
+ put $ st { xmls = xs }
+
+readMXml :: Xml a => ReadM Maybe a
+readMXml
+ = do xs <- getXmls
+ case readXml xs of
+ Nothing -> fail "Cannot read value"
+ Just (xs', v) ->
+ do putXmls xs'
+ return v
+
+typeNotValue :: Xml a => a -> a
+typeNotValue t = error ("Type used as value: " ++ typeName)
+ where typeName = dataTypeName (dataTypeOf xmlProxy t)
+
+-- The Xml [a] context is a bit scary, but if we don't have it then
+-- GHC complains about overlapping instances
+
+instance (Xml a {-, Xml [a] -}) => Xml [a] where
+ toXml = concatMap toXml
+ readXml = f [] []
+ where f acc_xs acc_vs [] = Just (reverse acc_xs, reverse acc_vs)
+ f acc_xs acc_vs (x:xs) = case readXml [x] of
+ Just ([], v) ->
+ f acc_xs (v:acc_vs) xs
+ _ ->
+ f (x:acc_xs) acc_vs xs
+
+instance Xml String where
+ toXml x = [CData x]
+ readXml = readXmlWith f
+ where f (CData x) = Just x
+ f _ = Nothing
+
diff --git a/testsuite/tests/typecheck/should_run/T2722.hs b/testsuite/tests/typecheck/should_run/T2722.hs new file mode 100644 index 0000000000..3912c840e7 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T2722.hs @@ -0,0 +1,34 @@ +module Main (main, arid1, arid2) where + +import Prelude hiding (id, (.)) +import qualified Prelude +import Control.Category +import Control.Arrow +import System.IO +import Debug.Trace + + +main = do { xs <- runXIOState arid1 -- Works with arid2 + ; print xs } + +runXIOState :: IOSLA () c -> IO [c] +runXIOState f = runIOSLA f () + +newtype IOSLA a b = IOSLA { runIOSLA :: a -> IO [b] } + +instance Arrow IOSLA where + arr f = IOSLA $ \ x -> return [f x] + +instance Category IOSLA where + id = arr id + +-- arr :: Arrow m => (b->c) -> m b c +-- id :: Category m => m b b +-- (arr id) :: Arrow m => m a a + +arid1 :: Arrow m => m a a +arid1 = arr id + +arid2 :: Arrow m => m a a +arid2 = arr Prelude.id + diff --git a/testsuite/tests/typecheck/should_run/T2722.stdout b/testsuite/tests/typecheck/should_run/T2722.stdout new file mode 100644 index 0000000000..daad811123 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T2722.stdout @@ -0,0 +1 @@ +[()] diff --git a/testsuite/tests/typecheck/should_run/T3500a.hs b/testsuite/tests/typecheck/should_run/T3500a.hs new file mode 100644 index 0000000000..c3adeb0c61 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T3500a.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module Main where + +type family F a :: * +type instance F Int = (Int, ()) + +class C a +instance C () +instance (C (F a), C b) => C (a, b) + +f :: C (F a) => a -> Int +f _ = 2 + +main :: IO () +main = print (f (3 :: Int)) + diff --git a/testsuite/tests/typecheck/should_run/T3500a.stdout b/testsuite/tests/typecheck/should_run/T3500a.stdout new file mode 100644 index 0000000000..78c6baefdd --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T3500a.stdout @@ -0,0 +1 @@ +2
diff --git a/testsuite/tests/typecheck/should_run/T3500b.hs b/testsuite/tests/typecheck/should_run/T3500b.hs new file mode 100644 index 0000000000..59a2c47983 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T3500b.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances #-} + +module Main where + +newtype Mu f = Mu (f (Mu f)) + +type family Id m +type instance Id m = m + +instance Show (Id (f (Mu f))) => Show (Mu f) where + show (Mu f) = show f + + +showMu :: Mu (Either ()) -> String +showMu = show + +item :: Mu (Either ()) +item = Mu (Right (Mu (Left ()))) + +main = print (showMu item) diff --git a/testsuite/tests/typecheck/should_run/T3500b.stdout b/testsuite/tests/typecheck/should_run/T3500b.stdout new file mode 100644 index 0000000000..7acb74ffa3 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T3500b.stdout @@ -0,0 +1 @@ +"Right Left ()"
diff --git a/testsuite/tests/typecheck/should_run/T3731-short.hs b/testsuite/tests/typecheck/should_run/T3731-short.hs new file mode 100644 index 0000000000..8f09d5ff52 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T3731-short.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveDataTypeable, + FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses, + OverlappingInstances, UndecidableInstances, + Rank2Types, KindSignatures, EmptyDataDecls #-} + +{-# OPTIONS_GHC -Wall #-} + +module Main (main) where + +class Sat a where + dict :: a -- Holds a default value + +class Sat a => Data a where + gunfold :: (forall b r. Data b => (b -> r) -> r) -> a + +instance (Sat [a], Data a) => Data [a] where + gunfold _ = [] + +class Data a => Default a where + defaultValue :: a + defaultValue = gunfold (\c -> c dict) + +instance Default t => Sat t where + dict = defaultValue + +instance Default a => Default [a] where + defaultValue = [] + +data Proposition = Prop Expression +data Expression = Conj [Expression] + +instance Data Expression => Data Proposition where + gunfold k = k Prop + +instance (Data [Expression],Sat Expression) => Data Expression where +-- DV: Notice what happens when we remove the Sat Expression above! +-- Everything starts working! + gunfold k = k Conj + +instance Default Expression +instance Default Proposition + +main :: IO () + +main = case (defaultValue :: Proposition) of + Prop exp -> case exp of + Conj _ -> putStrLn "Hurray2!" + +{- Need Default Proposition + for which we have an instance + +Instance + Default Proposition +needs superclass + Data Proposition +via instance dfun, needs + Data Expression +via instance dfun, needs + Sat Expression +via instance dfun, needs + Default Expression +for which we have an instance + +Instance + d1: Default Expression +needs superclass [d1 = MkD d2 ..] + d2: Data Expression {superclass Sat Expression} +via instance dfun, [d2 = dfun d3 d4] needs + d3 : Sat Expression (and d4 : Data [Expression]) +via instance dfun, [d3 = dfun d5] needs + d5 Default Expression +for which we have an instance [d5 = d1] + + d1 = MkD d2 .. + d2 = dfun d3 d4 + d3 = dfun d1 + +Instance + d1: Default Expression +needs superclass [d1 = MkD d2 ..] + d2: Data Expression {superclass Sat Expression d2' = sc d2 } +via instance dfun, [d2 = dfun d3 d4] needs + d3 : Sat Expression (and d4 : Data [Expression]) +and we can solve: d3 = d2'... no: recursion checker will reject + +-} + diff --git a/testsuite/tests/typecheck/should_run/T3731-short.stdout b/testsuite/tests/typecheck/should_run/T3731-short.stdout new file mode 100644 index 0000000000..9bc983e8f0 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T3731-short.stdout @@ -0,0 +1 @@ +Hurray2! diff --git a/testsuite/tests/typecheck/should_run/T3731.hs b/testsuite/tests/typecheck/should_run/T3731.hs new file mode 100644 index 0000000000..af858e570a --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T3731.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DeriveDataTypeable, + FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses, + OverlappingInstances, UndecidableInstances, + Rank2Types, KindSignatures, EmptyDataDecls #-} + +{-# OPTIONS_GHC -Wall #-} + +module Main (main) where + +import Data.Typeable + +class Sat a where + dict :: a + +data Proxy (a :: * -> *) + +class ( Sat (ctx a)) => Data ctx a where + gunfold :: Proxy ctx + -> (forall b r. Data ctx b => c (b -> r) -> c r) + -> (forall r. r -> c r) + -> Constr + -> c a + dataTypeOf :: Proxy ctx -> a -> DataType + +newtype ID x = ID { unID :: x } + +fromConstrB :: Data ctx a + => Proxy ctx + -> (forall b. Data ctx b => b) + -> Constr + -> a +fromConstrB ctx f = unID . gunfold ctx k z + where + k c = ID (unID c f) + z = ID + +data DataType = DataType + { tycon :: String + , datarep :: DataRep + } + +data Constr = Constr { conrep :: ConstrRep + , constring :: String + , confields :: [String] + , confixity :: Fixity + , datatype :: DataType + } + +data DataRep = AlgRep [Constr] +data ConstrRep = AlgConstr ConIndex + +type ConIndex = Int + +data Fixity = Prefix + | Infix + +constrRep :: Constr -> ConstrRep +constrRep = conrep + +-- | Constructs an algebraic datatype +mkDataType :: String -> [Constr] -> DataType +mkDataType str cs = DataType + { tycon = str + , datarep = AlgRep cs + } + + +-- | Constructs a constructor +mkConstr :: DataType -> String -> [String] -> Fixity -> Constr +mkConstr dt str fields fix = + Constr + { conrep = AlgConstr idx + , constring = str + , confields = fields + , confixity = fix + , datatype = dt + } + where + idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..], + showConstr c == str ] + + +-- | Gets the constructors +dataTypeConstrs :: DataType -> [Constr] +dataTypeConstrs dt = case datarep dt of + AlgRep cons -> cons + +-- | Gets the string for a constructor +showConstr :: Constr -> String +showConstr = constring + +-- | Gets the index of a constructor +constrIndex :: Constr -> ConIndex +constrIndex con = case constrRep con of + AlgConstr idx -> idx + +nilConstr :: Constr +nilConstr = mkConstr listDataType "[]" [] Prefix +consConstr :: Constr +consConstr = mkConstr listDataType "(:)" [] Infix +listDataType :: DataType +listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr] + +instance (Sat (ctx [a]), Data ctx a) => + Data ctx [a] where + gunfold _ k z c = case constrIndex c of + 1 -> z [] + 2 -> k (k (z (:))) + _ -> error "gunfold List" + dataTypeOf _ _ = listDataType + +class (Data DefaultD a) => Default a where + defaultValue :: a + defaultValue = defaultDefaultValue + +defaultDefaultValue :: Data DefaultD a => a +{-# NOINLINE defaultDefaultValue #-} +defaultDefaultValue = res + where res = case datarep $ dataTypeOf defaultProxy res of + AlgRep (c:_) -> + fromConstrB defaultProxy (defaultValueD dict) c + AlgRep [] -> + error "defaultDefaultValue: Bad DataRep" + +data DefaultD a = DefaultD { defaultValueD :: a } + +defaultProxy :: Proxy DefaultD +defaultProxy = error "defaultProxy" + +-- dfun3 +instance Default t => Sat (DefaultD t) where + dict = DefaultD { defaultValueD = defaultValue } + +-- dfun5 +instance Default a => Default [a] where + defaultValue = [] +data Proposition = Proposition Expression deriving (Show, Typeable) +data Expression = Conjunction [Expression] deriving (Show, Typeable) + +constr_Proposition :: Constr +constr_Proposition = mkConstr dataType_Proposition "Proposition" [] Prefix +dataType_Proposition :: DataType +dataType_Proposition = mkDataType "Proposition" [constr_Proposition] + +-- dfun1 +instance Data DefaultD Proposition + where gunfold _ k z c = case constrIndex c of + 1 -> k (z Proposition) + _ -> error "gunfold: fallthrough" + dataTypeOf _ _ = dataType_Proposition + +constr_Conjunction :: Constr +constr_Conjunction = mkConstr dataType_Expression "Conjunction" [] Prefix +dataType_Expression :: DataType +dataType_Expression = mkDataType "Expression" [constr_Conjunction] + +-- dfun2 +instance (Sat (ctx [Expression]), Sat (ctx Expression)) + => Data ctx Expression + where gunfold _ k z c = case constrIndex c of + 1 -> k (z Conjunction) + _ -> error "gunfold: fallthrough" + dataTypeOf _ _ = dataType_Expression + +-- dfun0 +instance Default Proposition where + defaultValue = defaultDefaultValue + +-- dfun4 +instance Default Expression where + defaultValue = defaultDefaultValue + +main :: IO () +main = putStrLn (show (defaultValue :: Proposition)) + +{- The trouble comes from "instance Default Expression" + +Define: dfun4 : Default Expression = MkDefault d_aCl (..) + +Simplify the superclass: + Wanted: d_aCl : Data DefaultD Expression + Derived: d_aCn : Sat DefaultD Expression d_aCn = $p1 d_aCl {irrelevant} + + by dfun2 d_aCl = dfun2 d_aCo d_aCp + Wanted: d_aCo : Sat (DefaultD [Expression]) + d_aCp : Sat (DefaultD Expression) + + by dfun3 d_aCo = dfun3 d_aCq + Wanted: d_aCq : Default [Expression] + Derived: d_aCr : Data DefaultD [Expression] d_aCr = $p1 d_aCq {irrelevant} + + by dfun5 d_aCq = dfun5 aCu + Wanted: d_aCu : Default Expression + Derived: d_aCw : Data DefaultD Expression d_aCw = $p1 d_aCu + Derived: d_aCx : Sat (DefaultD Expression) d_aCx = $p1 d_aCw + -- These two deriveds are unnecessary, + -- and dangerous, because we later satisfy + -- d_aCu from dfun4 which does not visibly + -- depend on d_aCl + +Now we satisfy d_aCu = dfun4 + d_aCp = d_aCx +Result = disaster: + d_aCp = d_aCx + = $p1 d_aCw + = $p1 ($p1 d_aCu) + = $p1 ($p1 dfun4) + = $p1 ($p1 (MkDefault d_aCl ...)) + = $p1 d_aCl + = $p1 (dfun2 d_aCo d_aCp) + = d_aCp +-} diff --git a/testsuite/tests/typecheck/should_run/T3731.stdout b/testsuite/tests/typecheck/should_run/T3731.stdout new file mode 100644 index 0000000000..688ef59dd4 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T3731.stdout @@ -0,0 +1 @@ +Proposition (Conjunction []) diff --git a/testsuite/tests/typecheck/should_run/T4809.hs b/testsuite/tests/typecheck/should_run/T4809.hs new file mode 100644 index 0000000000..0c0b50826c --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T4809.hs @@ -0,0 +1,18 @@ +{- # LANGUAGE MonoLocalBinds # -} +module Main where + +import T4809_IdentityT (IdentityT(..), XML, runIdentityT) +import T4809_XMLGenerator (XMLGenT(..), XMLGen(genElement), Child, EmbedAsChild(..), unXMLGenT) +import System.IO (BufferMode(..), hSetBuffering, stdout) + +page :: XMLGenT (IdentityT IO) XML +page = genElement (Nothing, "ul") [] [ asChild (asChild "foo")] +-- where +-- item :: XMLGenT (IdentityT IO) [Child (IdentityT IO)] +-- item = (asChild $ asChild (return "bar" :: XMLGenT (IdentityT IO) String)) + +main :: IO () +main = + do hSetBuffering stdout LineBuffering + r <- runIdentityT (unXMLGenT page) + print r diff --git a/testsuite/tests/typecheck/should_run/T4809.stdout b/testsuite/tests/typecheck/should_run/T4809.stdout new file mode 100644 index 0000000000..ad220dd0bd --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T4809.stdout @@ -0,0 +1,5 @@ +EmbedAsChild m (XMLGenT n c) +EmbedAsChild (IdentityT m) String +EmbedAsChild m [c] +EmbedAsChild m (Child m) +Element (Nothing,"ul") [] [CDATA True "foo"] diff --git a/testsuite/tests/typecheck/should_run/T4809_IdentityT.hs b/testsuite/tests/typecheck/should_run/T4809_IdentityT.hs new file mode 100644 index 0000000000..f030fc5b8d --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T4809_IdentityT.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module T4809_IdentityT + ( evalIdentityT + , IdentityT(..) + , XML(..) + ) where + +import Control.Monad (MonadPlus) +import Control.Monad.Trans (MonadTrans(lift), MonadIO(liftIO)) +import T4809_XMLGenerator (XMLGenT(..), EmbedAsChild(..), Name) +import qualified T4809_XMLGenerator as HSX + +data XML + = Element Name [Int] [XML] | CDATA Bool String + deriving Show + +-- * IdentityT Monad Transformer + +newtype IdentityT m a = IdentityT { runIdentityT :: m a } + deriving (Functor, Monad, MonadIO, MonadPlus) + +instance MonadTrans IdentityT where + lift = IdentityT + +evalIdentityT :: (Functor m, Monad m) => XMLGenT (IdentityT m) XML -> m XML +evalIdentityT = runIdentityT . HSX.unXMLGenT + +-- * HSX.XMLGenerator for IdentityT + +instance (Functor m, Monad m) => HSX.XMLGen (IdentityT m) where + type HSX.XML (IdentityT m) = XML + newtype HSX.Child (IdentityT m) = IChild { unIChild :: XML } + genElement n _attrs children = HSX.XMLGenT $ + do children' <- HSX.unXMLGenT (fmap (map unIChild . concat) (sequence children)) + return (Element n [] children') + +instance (Monad m, MonadIO m, Functor m) => EmbedAsChild (IdentityT m) String where + asChild s = + do liftIO $ putStrLn "EmbedAsChild (IdentityT m) String" + XMLGenT . return . (:[]) . IChild . CDATA True $ s diff --git a/testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs b/testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs new file mode 100644 index 0000000000..9ee37e8c6d --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies,
+ FlexibleContexts, FlexibleInstances, UndecidableInstances, OverlappingInstances,
+ TypeSynonymInstances, GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : HSX.XMLGenerator
+-- Copyright : (c) Niklas Broberg 2008
+-- License : BSD-style (see the file LICENSE.txt)
+--
+-- Maintainer : Niklas Broberg, niklas.broberg@chalmers.se
+-- Stability : experimental
+-- Portability : requires newtype deriving and MPTCs with fundeps
+--
+-- The class and monad transformer that forms the basis of the literal XML
+-- syntax translation. Literal tags will be translated into functions of
+-- the GenerateXML class, and any instantiating monads with associated XML
+-- types can benefit from that syntax.
+-----------------------------------------------------------------------------
+module T4809_XMLGenerator where
+
+import Control.Monad.Trans
+import Control.Monad.Cont (MonadCont)
+import Control.Monad.Error (MonadError)
+import Control.Monad.Reader(MonadReader)
+import Control.Monad.Writer(MonadWriter)
+import Control.Monad.State (MonadState)
+import Control.Monad.RWS (MonadRWS)
+import Control.Monad (MonadPlus(..),liftM)
+
+----------------------------------------------
+-- General XML Generation
+
+-- | The monad transformer that allows a monad to generate XML values.
+newtype XMLGenT m a = XMLGenT (m a)
+ deriving (Monad, Functor, MonadIO, MonadPlus, MonadWriter w, MonadReader r,
+ MonadState s, MonadRWS r w s, MonadCont, MonadError e)
+
+-- | un-lift.
+unXMLGenT :: XMLGenT m a -> m a
+unXMLGenT (XMLGenT ma) = ma
+
+instance MonadTrans XMLGenT where
+ lift = XMLGenT
+
+type Name = (Maybe String, String)
+
+-- | Generate XML values in some XMLGenerator monad.
+class Monad m => XMLGen m where
+ type XML m
+ data Child m
+ genElement :: Name -> [XMLGenT m [Int]] -> [XMLGenT m [Child m]] -> XMLGenT m (XML m)
+ genEElement :: Name -> [XMLGenT m [Int]] -> XMLGenT m (XML m)
+ genEElement n ats = genElement n ats []
+
+-- | Embed values as child nodes of an XML element. The parent type will be clear
+-- from the context so it is not mentioned.
+class XMLGen m => EmbedAsChild m c where
+ asChild :: c -> XMLGenT m [Child m]
+
+instance (MonadIO m, EmbedAsChild m c, m ~ n) => EmbedAsChild m (XMLGenT n c) where
+ asChild m = do
+ liftIO $ putStrLn "EmbedAsChild m (XMLGenT n c)"
+ a <- m
+ asChild a
+
+instance (MonadIO m, EmbedAsChild m c) => EmbedAsChild m [c] where
+ asChild cs =
+ do liftIO $ putStrLn "EmbedAsChild m [c]"
+ liftM concat . mapM asChild $ cs
+
+instance (MonadIO m, XMLGen m) => EmbedAsChild m (Child m) where
+ asChild c =
+ do liftIO $ putStrLn "EmbedAsChild m (Child m)"
+ return . return $ c
diff --git a/testsuite/tests/typecheck/should_run/TcRun025_B.hs b/testsuite/tests/typecheck/should_run/TcRun025_B.hs new file mode 100644 index 0000000000..a6d752c1a7 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/TcRun025_B.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ImplicitParams, TypeSynonymInstances, FlexibleInstances #-} + +-- Similar to tc024, but cross module + +module TcRun025_B where + + import Data.List( sort ) + + -- This class has no tyvars in its class op context + -- One uses a newtype, the other a data type + class C1 a where + fc1 :: (?p :: String) => a; + class C2 a where + fc2 :: (?p :: String) => a; + opc :: a + + instance C1 String where + fc1 = ?p; + instance C2 String where + fc2 = ?p; + opc = "x" + + -- This class constrains no new type variables in + -- its class op context + class D1 a where + fd1 :: (Ord a) => [a] -> [a] + class D2 a where + fd2 :: (Ord a) => [a] -> [a] + opd :: a + + instance D1 (Maybe a) where + fd1 xs = sort xs + instance D2 (Maybe a) where + fd2 xs = sort xs + opd = Nothing + + + diff --git a/testsuite/tests/typecheck/should_run/TcRun038_B.hs b/testsuite/tests/typecheck/should_run/TcRun038_B.hs new file mode 100644 index 0000000000..994348ba42 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/TcRun038_B.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} +
+module TcRun038_B where
+
+class Foo a where
+ op :: a -> Int
+
+-- Note the (Foo Int) constraint here; and the fact
+-- that there is no (Foo Int) instance in this module
+-- It's in the importing module!
+
+bar :: Foo Int => Int -> Int
+bar x = op x + 7
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T new file mode 100644 index 0000000000..a66586f0d8 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/all.T @@ -0,0 +1,83 @@ +# args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero + +# ----------------------------------------------------------------------------- +# Pick an arbitrary few to run when 'fast' is on + +test('tcrun001', normal, compile_and_run, ['']) +test('tcrun002', only_compiler_types(['ghc']), compile_and_run, ['']) +test('tcrun003', normal, compile_and_run, ['']) +test('tcrun004', normal, compile_and_run, ['']) +test('tcrun005', normal, compile_and_run, ['']) + +# ----------------------------------------------------------------------------- +# Skip everything else if fast is on + +def f(opts): + if config.fast: + opts.skip = 1 +setTestOpts(f) + +test('tcrun006', normal, compile_and_run, ['']) +test('tcrun008', normal, compile_and_run, ['']) +test('tcrun009', normal, compile_and_run, ['']) +test('tcrun010', normal, compile_and_run, ['']) +test('tcrun011', normal, compile_and_run, ['']) +test('tcrun012', normal, compile_and_run, ['']) +test('tcrun013', normal, compile_and_run, ['']) +test('tcrun014', normal, compile_and_run, ['']) +test('tcrun015', normal, compile_and_run, ['-O']) +test('tcrun016', normal, compile_and_run, ['']) +test('tcrun017', normal, compile_and_run, ['']) +test('tcrun018', normal, compile_and_run, ['']) +test('tcrun019', normal, compile_and_run, ['']) +test('tcrun020', normal, compile_and_run, ['']) +# Doesn't work with External Core due to datatype with no constructors +test('tcrun021', expect_fail_for(['extcore','optextcore']), + compile_and_run, ['-package containers']) +test('tcrun022', compose(omit_ways(['ghci']),only_compiler_types(['ghc'])), compile_and_run, ['-O']) +test('tcrun023', normal, compile_and_run, ['-O']) +test('tcrun024', normal, compile_and_run, ['-O']) +test('tcrun025', extra_clean(['TcRun025_B.hi', 'TcRun025_B.o']), + multimod_compile_and_run, ['tcrun025','']) +test('tcrun026', normal, compile_and_run, ['']) +test('tcrun027', normal, compile_and_run, ['']) +# Doesn't work with External Core due to datatype with no constructors +test('tcrun028', expect_fail_for(['extcore','optextcore']), compile_and_run, ['']) +test('tcrun029', normal, compile_and_run, ['']) +test('tcrun030', normal, compile_and_run, ['']) +test('tcrun031', only_compiler_types(['ghc']), compile_and_run, ['']) +test('tcrun032', only_compiler_types(['ghc']), compile_and_run, ['']) +test('tcrun033', only_compiler_types(['ghc']), compile_and_run, ['']) +test('tcrun034', only_compiler_types(['ghc']), compile_and_run, ['']) +test('tcrun035', only_compiler_types(['ghc']), compile_fail, ['']) +test('tcrun036', only_compiler_types(['ghc']), compile_and_run, ['']) +test('tcrun037', only_compiler_types(['ghc']), compile_and_run, ['']) + +test('tcrun038', + extra_clean(['TcRun038_B.hi', 'TcRun038_B.o']), + multimod_compile_and_run, + ['tcrun038','']) + +test('tcrun039', only_compiler_types(['ghc']), compile_and_run, ['']) +test('tcrun040', normal, compile_and_run, ['']) +test('tcrun041', omit_ways(['ghci']), compile_and_run, ['']) +test('tcrun042', normal, compile_and_run, ['']) + +test('church', normal, compile_and_run, ['']) +test('testeq2', normal, compile_and_run, ['']) +test('T1624', normal, compile_and_run, ['']) +test('IPRun', normal, compile_and_run, ['']) + +# Support files for T1735 are in directory T1735_Help/ +test('T1735', normal, multimod_compile_and_run, ['T1735','']) + +test('T3731', normal, compile_and_run, ['']) +test('T3731-short', normal, compile_and_run, ['']) +test('T3500a', normal, compile_and_run, ['']) +test('T3500b', normal, compile_and_run, ['']) +test('T4809', reqlib('mtl'), compile_and_run, ['']) +test('T2722', normal, compile_and_run, ['']) +test('mc17', normal, compile_and_run, ['']) diff --git a/testsuite/tests/typecheck/should_run/church.hs b/testsuite/tests/typecheck/should_run/church.hs new file mode 100644 index 0000000000..2b7ee92b8b --- /dev/null +++ b/testsuite/tests/typecheck/should_run/church.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE Rank2Types #-} + +module Main where +import Prelude hiding( succ, pred ) + +newtype Ch = Ch (forall a. (a -> a) -> a -> a) + +apply :: Ch -> (a->a) -> a -> a +apply (Ch f) = f + +instance Eq Ch where + a == b = isZero (a - b) + +instance Show Ch where + show a = show (fromCh a) + +instance Num Ch where + fromInteger n = toCh n + m + n = apply n succ m + m - n = apply n pred m + m * n = apply m (n +) zero + +zero :: Ch +zero = Ch (\f z -> z) + +succ :: Ch -> Ch +succ n = Ch (\f z -> f (apply n f z)) + +isZero :: Ch -> Bool +isZero n = apply n (const False) True + +toCh :: Integer -> Ch +toCh 0 = zero +toCh n = succ (toCh (n-1)) + +fromCh :: Ch -> Int +fromCh n = apply n (+1) 0 + +pred :: Ch -> Ch +pred n = snd (apply n g (zero, zero)) + where g (m,_) = (succ m, m) + + +main = print ((3+4)*12 - 10::Ch) diff --git a/testsuite/tests/typecheck/should_run/church.stdout b/testsuite/tests/typecheck/should_run/church.stdout new file mode 100644 index 0000000000..fff0a2476a --- /dev/null +++ b/testsuite/tests/typecheck/should_run/church.stdout @@ -0,0 +1 @@ +74 diff --git a/testsuite/tests/typecheck/should_run/mc17.hs b/testsuite/tests/typecheck/should_run/mc17.hs new file mode 100644 index 0000000000..abd3b7b579 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/mc17.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MonadComprehensions, ParallelListComp #-} + +-- !!! Parallel list comprehensions + +module Main where + +f xs = [ (x,y) | x <- xs, x>3 | y <- xs ] + +main = print (f [0..10]) + diff --git a/testsuite/tests/typecheck/should_run/mc17.stdout b/testsuite/tests/typecheck/should_run/mc17.stdout new file mode 100644 index 0000000000..bb1e684d68 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/mc17.stdout @@ -0,0 +1 @@ +[(4,0),(5,1),(6,2),(7,3),(8,4),(9,5),(10,6)] diff --git a/testsuite/tests/typecheck/should_run/tcrun001.hs b/testsuite/tests/typecheck/should_run/tcrun001.hs new file mode 100644 index 0000000000..209ca3fe00 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun001.hs @@ -0,0 +1,16 @@ +-- !! Test for (->) instances + +module Main where + +class Flob k where + twice :: k a a -> k a a + +instance Flob (->) where + twice f = f . f + +inc :: Int -> Int +inc x = x+1 + +main = print (twice inc 2) + + diff --git a/testsuite/tests/typecheck/should_run/tcrun001.stdout b/testsuite/tests/typecheck/should_run/tcrun001.stdout new file mode 100644 index 0000000000..b8626c4cff --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun001.stdout @@ -0,0 +1 @@ +4 diff --git a/testsuite/tests/typecheck/should_run/tcrun002.hs b/testsuite/tests/typecheck/should_run/tcrun002.hs new file mode 100644 index 0000000000..45fe19fdc9 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun002.hs @@ -0,0 +1,16 @@ +-- !!! space leak from overloading !!! +module Main where + +-- This program develops a space leak if sfoldl isn't compiled with some +-- care. See comment about polymorphic recursion in TcMonoBinds.lhs + +import System.Environment (getArgs) +import GHC.IOBase + +sfoldl :: (a -> Int -> a) -> a -> [Int] -> a +sfoldl f z [] = z +sfoldl f z (x:xs) = _scc_ "sfoldl1" (sfoldl f fzx (fzx `seq` xs)) + where fzx = _scc_ "fzx" (f z x) + + +main = IO (\s -> case print (sfoldl (+) (0::Int) [1..200000]) of { IO a -> a s }) diff --git a/testsuite/tests/typecheck/should_run/tcrun002.stdout b/testsuite/tests/typecheck/should_run/tcrun002.stdout new file mode 100644 index 0000000000..928909f816 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun002.stdout @@ -0,0 +1 @@ +-1474736480 diff --git a/testsuite/tests/typecheck/should_run/tcrun002.stdout-alpha-dec-osf3 b/testsuite/tests/typecheck/should_run/tcrun002.stdout-alpha-dec-osf3 new file mode 100644 index 0000000000..31e0b55e93 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun002.stdout-alpha-dec-osf3 @@ -0,0 +1 @@ +20000100000 diff --git a/testsuite/tests/typecheck/should_run/tcrun002.stdout-mips-sgi-irix b/testsuite/tests/typecheck/should_run/tcrun002.stdout-mips-sgi-irix new file mode 100644 index 0000000000..31e0b55e93 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun002.stdout-mips-sgi-irix @@ -0,0 +1 @@ +20000100000 diff --git a/testsuite/tests/typecheck/should_run/tcrun002.stdout-ws-64 b/testsuite/tests/typecheck/should_run/tcrun002.stdout-ws-64 new file mode 100644 index 0000000000..31e0b55e93 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun002.stdout-ws-64 @@ -0,0 +1 @@ +20000100000 diff --git a/testsuite/tests/typecheck/should_run/tcrun002.stdout-x86_64-unknown-openbsd b/testsuite/tests/typecheck/should_run/tcrun002.stdout-x86_64-unknown-openbsd new file mode 100644 index 0000000000..31e0b55e93 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun002.stdout-x86_64-unknown-openbsd @@ -0,0 +1 @@ +20000100000 diff --git a/testsuite/tests/typecheck/should_run/tcrun003.hs b/testsuite/tests/typecheck/should_run/tcrun003.hs new file mode 100644 index 0000000000..67b9771d5f --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun003.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +-- !!! One method class from Sergey Mechveliani +-- showed up problematic newtype dict rep. +module Main where +import Data.Ratio + +class MBConvertible a b where cm :: a -> b -> Maybe b + +c :: MBConvertible a b => a -> b -> b +c a b = case cm a b + of + Just b' -> b' + _ -> error "c a b failed" + + +instance MBConvertible Int Int where cm a _ = Just a + +instance (MBConvertible a b,Integral b) => MBConvertible a (Ratio b) + where + cm a f = case cm a (numerator f) of Just a' -> Just (a'%1) + _ -> Nothing + +main = let f = 1%1 :: Ratio Int + n2 = 2::Int + g = (c n2 f) + f + in + putStr (shows g "\n") diff --git a/testsuite/tests/typecheck/should_run/tcrun003.stdout b/testsuite/tests/typecheck/should_run/tcrun003.stdout new file mode 100644 index 0000000000..14896f2f71 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun003.stdout @@ -0,0 +1 @@ +3 % 1 diff --git a/testsuite/tests/typecheck/should_run/tcrun003.stdout-ghc b/testsuite/tests/typecheck/should_run/tcrun003.stdout-ghc new file mode 100644 index 0000000000..14896f2f71 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun003.stdout-ghc @@ -0,0 +1 @@ +3 % 1 diff --git a/testsuite/tests/typecheck/should_run/tcrun004.hs b/testsuite/tests/typecheck/should_run/tcrun004.hs new file mode 100644 index 0000000000..2319fc3bec --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun004.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ExistentialQuantification #-} +-- !!! Tests existential data types +-- Originally from Kevin Glynn +module Main(main) where + +data Coordinate3D = Coord3D {cx, cy, cz::Double} + deriving (Eq, Show) + +-- We Represent a line by two coordinates which it passes through. +data Line = MkLine Coordinate3D Coordinate3D + + +class PictureObject pot where + + -- Returns ordered (rel to 0 0 0) of points where the object + -- intersects the given line. + intersectLineObject :: pot -> Line -> [Coordinate3D] + + getPictureName :: pot -> String + +data Sphere = + Sphere Coordinate3D -- Centre + Double -- Radius + Double -- ambient coeff + Double -- diffuse coeff + Double -- specular coeff + Double -- phong specular exponent + +intersectLineSphere :: Sphere -> Line -> [Coordinate3D] +intersectLineSphere sp line = [] + +instance PictureObject Sphere where + intersectLineObject = intersectLineSphere + getPictureName _ = "Sphere" + +data Cube = + Cube Coordinate3D -- Origin corner + Coordinate3D -- Opposite corner + Double -- ambient coeff + Double -- diffuse coeff + Double -- specular coeff + Double -- phong specular exponent + deriving (Eq, Show) + +intersectLineCube :: Cube -> Line -> [Coordinate3D] +intersectLineCube cube line = [] + +instance PictureObject Cube where + intersectLineObject = intersectLineCube + getPictureName _ = "Cube" + + +data GenPic = forall pot. (PictureObject pot) => MkGenPic pot + +sphere :: Sphere +sphere = Sphere (Coord3D 1 1 1) 1 1 1 1 1 + +cube :: Cube +cube = Cube (Coord3D 1 1 1) (Coord3D 2 2 2) 1 1 1 1 + +obj_list:: [GenPic] +obj_list = [MkGenPic sphere, MkGenPic cube] + +putName :: PictureObject pot => pot -> IO () +putName x = putStr $ getPictureName x + + +main :: IO () +main = do { sequence_ $ map put_it obj_list } + where + put_it (MkGenPic s) = putStrLn (getPictureName s) + diff --git a/testsuite/tests/typecheck/should_run/tcrun004.stdout b/testsuite/tests/typecheck/should_run/tcrun004.stdout new file mode 100644 index 0000000000..f0842b68d7 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun004.stdout @@ -0,0 +1,2 @@ +Sphere +Cube diff --git a/testsuite/tests/typecheck/should_run/tcrun005.hs b/testsuite/tests/typecheck/should_run/tcrun005.hs new file mode 100644 index 0000000000..2c315725ef --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun005.hs @@ -0,0 +1,25 @@ +-- !!! Dfun naming bug + +module Main where + + + data TT = TT + data TTT = TTT + + class CC a where + op_cc :: a -> a + + class CCT a where + op_cct :: a -> a + + -- These two instances should get different dfun names! + -- In GHC 4.04 they both got $fCCTTT + + instance CC TTT where + op_cc = id + + instance CCT TT where + op_cct = id + + main = case op_cc TTT of + TTT -> print "ok" diff --git a/testsuite/tests/typecheck/should_run/tcrun005.stdout b/testsuite/tests/typecheck/should_run/tcrun005.stdout new file mode 100644 index 0000000000..52c33a57c7 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun005.stdout @@ -0,0 +1 @@ +"ok" diff --git a/testsuite/tests/typecheck/should_run/tcrun006.hs b/testsuite/tests/typecheck/should_run/tcrun006.hs new file mode 100644 index 0000000000..f3d0e13cef --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun006.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DatatypeContexts #-} +-- !!! Selectors for data and newtypes with contexts + +-- This program, reported in Aug'00 by Jose Emilio Labra Gayo +-- gave rise to a Lint error because the selector 'newout' below +-- was given the type +-- Eq f => NewT f -> f +-- but lacked a dictionary argument in its body. + +module Main where + +newtype (Eq f) => NewT f = NewIn { newout :: f } +data (Eq f) => DataT f = DataIn { dataout :: f } + +main = print (newout (NewIn "ok new") ++ dataout (DataIn " ok data")) + diff --git a/testsuite/tests/typecheck/should_run/tcrun006.stdout b/testsuite/tests/typecheck/should_run/tcrun006.stdout new file mode 100644 index 0000000000..e96d077c6e --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun006.stdout @@ -0,0 +1 @@ +"ok new ok data" diff --git a/testsuite/tests/typecheck/should_run/tcrun008.hs b/testsuite/tests/typecheck/should_run/tcrun008.hs new file mode 100644 index 0000000000..80097a8f24 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun008.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE Rank2Types #-} + +-- !!! Check that record selectors for polymorphic fields work right + +module Main where + +class Foo a where + bar :: a -> [a] + +instance Foo Int where + bar x = replicate x x + +instance Foo Bool where + bar x = [x, not x] + +data Record = R { + blub :: Foo a => a -> [a] + } + +main = do { let r = R {blub = bar} + ; print (blub r (3::Int)) + ; print (blub r True) + } + + + diff --git a/testsuite/tests/typecheck/should_run/tcrun008.stdout b/testsuite/tests/typecheck/should_run/tcrun008.stdout new file mode 100644 index 0000000000..f494982ffa --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun008.stdout @@ -0,0 +1,2 @@ +[3,3,3] +[True,False] diff --git a/testsuite/tests/typecheck/should_run/tcrun009.hs b/testsuite/tests/typecheck/should_run/tcrun009.hs new file mode 100644 index 0000000000..1adc350084 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun009.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + +-- !!! Functional dependencies + +module Main where + +class Foo a b | a -> b where + foo :: a -> b + +instance Foo [a] (Maybe a) where + foo [] = Nothing + foo (x:_) = Just x + +instance Foo (Maybe a) [a] where + foo Nothing = [] + foo (Just x) = [x] + +test3:: [a] -> [a] +test3 = foo . foo +-- First foo must use the first instance, +-- second must use the second. So we should +-- get in effect: test3 (x:xs) = [x] + +main:: IO () +main = print (test3 "foo") diff --git a/testsuite/tests/typecheck/should_run/tcrun009.stdout b/testsuite/tests/typecheck/should_run/tcrun009.stdout new file mode 100644 index 0000000000..cb59695753 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun009.stdout @@ -0,0 +1 @@ +"f" diff --git a/testsuite/tests/typecheck/should_run/tcrun010.hs b/testsuite/tests/typecheck/should_run/tcrun010.hs new file mode 100644 index 0000000000..7621f4d4e0 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun010.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + +-- !!! Functional dependencies +-- This one gave "zonkIdOcc: FunDep_a11w" in earlier days + +module Main (main) where + +data ERR a b = EOK a | ERR b deriving (Show) +data Error = No | Notatall deriving (Show, Eq) + + +class MonadErr m e | m -> e where + aerturn :: e -> m a + areturn :: a -> m a + acatch :: a -> (a -> m b) -> (e -> m b) -> m b + (>>>=) :: m a -> (a -> m b) -> m b + (>>>) :: m a -> m b -> m b + +data BP a = BP (Int -> (ERR a Error, Int)) + +instance MonadErr BP Error where + aerturn k = BP $ \s -> (ERR k, s) + areturn k = BP $ \s -> (EOK k, s) + acatch k try handler = BP $ \s -> let BP try' = try k + (r,s1) = try' s + (BP c2, s2) = case r of + EOK r -> (areturn r, s1) + ERR r -> (handler r, s) + in c2 s2 + a >>> b = a >>>= \_ -> b + + (BP c1) >>>= fc2 = BP $ \s0 -> let (r,s1) = c1 s0 + BP c2 = case r of + EOK r -> fc2 r + ERR r -> BP (\s -> (ERR r, s)) + in c2 s1 + +run_BP :: Int -> BP a -> (ERR a Error, Int) +run_BP st (BP bp) = bp st + +foo :: (ERR Int Error, Int) +foo = run_BP 111 (aerturn No) + +main = print (show foo) diff --git a/testsuite/tests/typecheck/should_run/tcrun010.stdout b/testsuite/tests/typecheck/should_run/tcrun010.stdout new file mode 100644 index 0000000000..ae94b77716 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun010.stdout @@ -0,0 +1 @@ +"(ERR No,111)" diff --git a/testsuite/tests/typecheck/should_run/tcrun011.hs b/testsuite/tests/typecheck/should_run/tcrun011.hs new file mode 100644 index 0000000000..5c6cab8ea0 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun011.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ExistentialQuantification, FlexibleContexts, + MultiParamTypeClasses #-} + +-- !!! Existential data tyes +-- Hugs didn't like this one + +module Main (main) where + + +class MyClass a b where + foo :: a -> b -> Int + +data Special = forall b. (MyClass Int b)=> MkSpecial b +data General a = forall b. (MyClass a b)=> MkGeneral b + +instance MyClass Int Bool where + foo x False = -x + foo x True = x + +xs :: [General Int] +xs = [MkGeneral True, MkGeneral False] + +main = print [foo (3::Int) x | MkGeneral x <- xs] + -- Without the (::Int) part we get an + -- incomprehensible error message :-( diff --git a/testsuite/tests/typecheck/should_run/tcrun011.stdout b/testsuite/tests/typecheck/should_run/tcrun011.stdout new file mode 100644 index 0000000000..7984134ce3 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun011.stdout @@ -0,0 +1 @@ +[3,-3] diff --git a/testsuite/tests/typecheck/should_run/tcrun012.hs b/testsuite/tests/typecheck/should_run/tcrun012.hs new file mode 100644 index 0000000000..a3c946a24e --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun012.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ImplicitParams #-} + +-- !!! Implicit parameter test + +module Main where + +main = do { let ?x = 13 in putStrLn $ show $ foo + ; let ?x = 14 in putStrLn $ show $ baz () } + +foo :: (?x :: Int) => Int +foo = ?x + +-- Check that defaulting works too +baz () = ?x + diff --git a/testsuite/tests/typecheck/should_run/tcrun012.stdout b/testsuite/tests/typecheck/should_run/tcrun012.stdout new file mode 100644 index 0000000000..df9e19c591 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun012.stdout @@ -0,0 +1,2 @@ +13 +14 diff --git a/testsuite/tests/typecheck/should_run/tcrun013.hs b/testsuite/tests/typecheck/should_run/tcrun013.hs new file mode 100644 index 0000000000..dc156c0d83 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun013.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ParallelListComp #-} + +-- !!! Parallel list comprehensions + +module Main where + +f xs = [ (x,y) | x <- xs, x>3 | y <- xs ] + +main = print (f [0..10]) + diff --git a/testsuite/tests/typecheck/should_run/tcrun013.stdout b/testsuite/tests/typecheck/should_run/tcrun013.stdout new file mode 100644 index 0000000000..bb1e684d68 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun013.stdout @@ -0,0 +1 @@ +[(4,0),(5,1),(6,2),(7,3),(8,4),(9,5),(10,6)] diff --git a/testsuite/tests/typecheck/should_run/tcrun014.hs b/testsuite/tests/typecheck/should_run/tcrun014.hs new file mode 100644 index 0000000000..751e9aa5bf --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun014.hs @@ -0,0 +1,22 @@ +-- !!! Newtypes + +-- This one made ghc 5.01 (after newtype squashing) fall over +-- by generating Core code that contained a pattern match on +-- the InPE data constructor (which doesn't exist) + +module Main where + + +data Expr e = One e | Many [e] +newtype PExpr a = InPE (Expr (PExpr a), Int) + +one :: Int -> PExpr e -> PExpr e +one l x = InPE (One (plus1 x), l) + +plus1 :: PExpr a -> PExpr a +plus1 x@(InPE (_, loc)) = InPE (Many [plus1 x], loc) + +get :: PExpr e -> Int +get (InPE (_,l)) = l + +main = print (get (plus1 (InPE (Many [], 0)))) diff --git a/testsuite/tests/typecheck/should_run/tcrun014.stdout b/testsuite/tests/typecheck/should_run/tcrun014.stdout new file mode 100644 index 0000000000..573541ac97 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun014.stdout @@ -0,0 +1 @@ +0 diff --git a/testsuite/tests/typecheck/should_run/tcrun015.hs b/testsuite/tests/typecheck/should_run/tcrun015.hs new file mode 100644 index 0000000000..a75e7e88d5 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun015.hs @@ -0,0 +1,21 @@ +-- !!! Newtypes + +-- A variation of tc014 that Sigbjorn said failed + +module Main where + +data Expr a b = One a | Many [b] +newtype Pat a = InP (Expr a (Pat a), Int) +newtype PExpr a = InPE (Expr a (PExpr a), Int) + +plus1 x@(InPE (_, loc)) = InPE (Many [x], loc) +one x l = InPE (One (plus1 x), l) + +outP (InP x) = x + +getPatNames p + = case outP p of + (One n, _) -> [n] + (Many ps, _) -> concatMap getPatNames ps + +main = print (take 10 (map getPatNames (repeat (InP (One "n", 1))))) diff --git a/testsuite/tests/typecheck/should_run/tcrun015.stdout b/testsuite/tests/typecheck/should_run/tcrun015.stdout new file mode 100644 index 0000000000..7e8952116f --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun015.stdout @@ -0,0 +1 @@ +[["n"],["n"],["n"],["n"],["n"],["n"],["n"],["n"],["n"],["n"]] diff --git a/testsuite/tests/typecheck/should_run/tcrun016.hs b/testsuite/tests/typecheck/should_run/tcrun016.hs new file mode 100644 index 0000000000..b498ed4220 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun016.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances #-} + +-- !!! Functional dependencies +-- This one made the 5.00.1 typechecker go into an infinite loop. +-- The context simplifier keep thinking it was doing an 'improve' +-- step, and hence kept going round and round. + +module Main where + +main = print (get ((AttributeLeaf (MyLabel "x") 4)::Env1) (MyLabel "x")) + +class Eq l => Domain d l | d -> l where + (<<) :: d -> d -> d + empty :: d +class Domain e l => Environment e l t | e -> l t where + get :: e -> l -> Maybe t + attribute :: l -> t -> e + +class Eq' a where + (=?=) :: a -> a -> Bool + +newtype MyLabel = MyLabel String deriving Eq + +instance Eq' MyLabel where + l =?= l' = l == l' + +data BinTreeEnv l t = + EmptyEnv | + AttributeLeaf l t | + Union (BinTreeEnv l t) (BinTreeEnv l t) + +instance (Eq l, Eq' l) => Domain (BinTreeEnv l t) l where + EmptyEnv << d = d + d << EmptyEnv = d + d << d' = Union d d' + empty = EmptyEnv + +instance (Eq l, Eq' l) => Environment (BinTreeEnv l t) l t where + get EmptyEnv l = Nothing + get (AttributeLeaf l t) l' = if l =?= l' then Just t + else Nothing + get (Union d d') l = error "!??" + + attribute l t = AttributeLeaf l t + +type Env1 = BinTreeEnv MyLabel Integer + diff --git a/testsuite/tests/typecheck/should_run/tcrun016.stdout b/testsuite/tests/typecheck/should_run/tcrun016.stdout new file mode 100644 index 0000000000..56ead6b617 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun016.stdout @@ -0,0 +1 @@ +Just 4 diff --git a/testsuite/tests/typecheck/should_run/tcrun017.hs b/testsuite/tests/typecheck/should_run/tcrun017.hs new file mode 100644 index 0000000000..f994df3a4f --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun017.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ImplicitParams, Rank2Types #-} + +-- !!! Implicit parameters, and Rank-2 types +-- This one made the 5.00.1 not print anything + +module Main where + +foo :: ((?x :: Int) => IO a) -> Int -> IO a + -- Note the rank2 type +foo s z = do let ?x = z in s -- Should pick up ?x = z + let ?x = z+3 in s -- Ditto z+3 + +main = foo (print ?x) 42 + diff --git a/testsuite/tests/typecheck/should_run/tcrun017.stdout b/testsuite/tests/typecheck/should_run/tcrun017.stdout new file mode 100644 index 0000000000..3f49878157 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun017.stdout @@ -0,0 +1,2 @@ +42 +45 diff --git a/testsuite/tests/typecheck/should_run/tcrun018.hs b/testsuite/tests/typecheck/should_run/tcrun018.hs new file mode 100644 index 0000000000..9f9bd14d0f --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun018.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +class Monad m => C1 m x + +class (Monad m, C1 m x) => C2 m x + where + c2 :: x -> m x + +class C1 m x => C3 m x + where + c3 :: x -> m x + +instance Monad m => C1 m Bool + +instance C2 Maybe Bool + where + c2 = return + +instance C3 Maybe Bool + where + c3 = return + + +main = do { print (c2 True :: Maybe Bool) ; + print (c3 True :: Maybe Bool) } + +------------------------------------------------------------------------ +{- Here's the email from Ralf Laemmel + reporting a bug in Hugs + +1. If you evaluate "test", + then you get as expected "Just True". + +2. Now remove the "Monad M" constraint + in the class C2. [giving the class C3] + This is of course legal and semantics-preserving + since the monad constraints is implied by C1 + anyway. + +3. Now evaluate "test" again. Oops, it diverges. + +I did this Hugs Version February 2001 under Solaris +and Linux. Command line option -98 is needed of course. +Funny enough, if CTRL-C the evaluation of "test" +and you try it the second time (without reloading +anything etc.), then you see "Program error: {_Gc Black +Hole}". Of course, there is no such black hole. + +I extracted the above fragment from a huge problem. +The scheme is the following. It seems have to do +with multi-parameter classes. It definitely has to +do with multi-layered class hierarchies where one +class has a class-wide superclass, as C2 has C1 in +the example. It seems that the superclass is +properly propagated during type-inference/checking +but it is not properly propagated, as for as code +determination in overloading resolution. + +Please, let me know if I can be of further assistance. +I am actually amazed how general this scheme is +(3 classes, 2 parameters). How does it come that it +was not detected much earlier. + +Anyway, good luck, +Ralf + + +P.S.: I have more problems in a larger application. +Certain overloaded expressions diverge. I can recover +from that usually by using explicit function types +for top-level functions, where again -- as in C1 above +-- I repeat some constraints which are derivable. I was +not able to extract a simple program for that problem. +But I would be glad to help you by checking if the +problem is gone after you did the bug fix. + + +-- +Dr.-Ing. Ralf Laemmel +CWI & VU, Amsterdam, The Netherlands +http://www.cwi.nl/~ralf/ +http://www.cs.vu.nl/~ralf/ + +-}
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_run/tcrun018.stdout b/testsuite/tests/typecheck/should_run/tcrun018.stdout new file mode 100644 index 0000000000..66b4edf967 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun018.stdout @@ -0,0 +1,2 @@ +Just True +Just True diff --git a/testsuite/tests/typecheck/should_run/tcrun019.hs b/testsuite/tests/typecheck/should_run/tcrun019.hs new file mode 100644 index 0000000000..266e01d9c0 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun019.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ImplicitParams, RankNTypes #-} + +-- GHC 5.02 got this one wrong. + +module Main where + +-- Implicit parameters bug +-- mbs@cse.ogi.edu 24-Oct-2001 22:21:27 + +f :: (?x :: Int) => ((?x :: Int) => Int) -> Int -> Int +f g y = if y == 0 + then g + else let ?x = ?x + 1 + in f g (y - 1) + +h :: (?x :: Int) => Int +h = ?x + +main = print (let ?x = 0 in f h 10) +-- The result should be 10! + diff --git a/testsuite/tests/typecheck/should_run/tcrun019.stdout b/testsuite/tests/typecheck/should_run/tcrun019.stdout new file mode 100644 index 0000000000..f599e28b8a --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun019.stdout @@ -0,0 +1 @@ +10 diff --git a/testsuite/tests/typecheck/should_run/tcrun020.hs b/testsuite/tests/typecheck/should_run/tcrun020.hs new file mode 100644 index 0000000000..98cbc71e3c --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun020.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +-- Hugs (2001) diverges when evaluating main, unless (Monad m) is +-- added as an extra superclass to C2, which should not be necessary. + +module Main where + +class Monad m => C1 m x + +class (C1 m x) => C2 m x where + c2 :: x -> m x + +instance Monad m => C1 m Bool + +instance C2 Maybe Bool where + c2 = return + +test :: Maybe Bool +test = c2 True + +main = print test + diff --git a/testsuite/tests/typecheck/should_run/tcrun020.stdout b/testsuite/tests/typecheck/should_run/tcrun020.stdout new file mode 100644 index 0000000000..3e69f58e11 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun020.stdout @@ -0,0 +1 @@ +Just True diff --git a/testsuite/tests/typecheck/should_run/tcrun021.hs b/testsuite/tests/typecheck/should_run/tcrun021.hs new file mode 100644 index 0000000000..50497dd640 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun021.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + TypeSynonymInstances, FlexibleInstances #-} + +-- This bizarre program failed because TcSimplify built a loop of +-- dictionaries, due to an obscure bug in the way in which superclasses +-- were added + +module Main where + +import Data.List +import Data.Map + +class (Ord oid) => Object o oid | o -> oid where + +data Access oid + +class (Object o oid) => SecurityModel model o oid | model -> o + +class (SecurityModel model o oid) => SecurityPolicy policy model o oid where + checkAccess :: policy -> model -> Access oid -> Bool + checkAccess _ _ _ = True + checkModel :: policy -> model -> Bool + checkModel _ _ = True + +------------------------------------------------------------ +-- The Linux instance +------------------------------------------------------------ + +type LinuxObjectId = Either [String] String + +data LinuxObject = File [String] deriving (Eq, Show) + +instance Object LinuxObject LinuxObjectId + +data LinuxSecurityModel = + LinuxSecurityModel { lsmObjectSet :: Map LinuxObjectId LinuxObject } + + +-- Now defined in Data.Map, don't think this affects the bug: +-- instance (Show a, Show b) => Show (Map a b) where +-- show fm = show (fmToList fm) + +instance Show LinuxSecurityModel where + show lsm = "LSM:" ++ "\tObjects: " ++ show (lsmObjectSet lsm) + +instance SecurityModel LinuxSecurityModel LinuxObject LinuxObjectId + +data LinuxSecurityPolicy = LinuxSecurityPolicy +instance SecurityPolicy LinuxSecurityPolicy LinuxSecurityModel LinuxObject LinuxObjectId + +model :: Map LinuxObjectId LinuxObject +model = fromList [ (Left [], File []), (Left ["home"], File ["home"]) ] + + +-- works +-- model :: (LinuxObjectId, LinuxObject) +-- model = (Left [], File []) + +main :: IO () +main = do { putStrLn (show model) } diff --git a/testsuite/tests/typecheck/should_run/tcrun021.stdout b/testsuite/tests/typecheck/should_run/tcrun021.stdout new file mode 100644 index 0000000000..c16e4c39e1 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun021.stdout @@ -0,0 +1 @@ +fromList [(Left [],File []),(Left ["home"],File ["home"])] diff --git a/testsuite/tests/typecheck/should_run/tcrun022.hs b/testsuite/tests/typecheck/should_run/tcrun022.hs new file mode 100644 index 0000000000..54613d7917 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun022.hs @@ -0,0 +1,23 @@ +-- This test checks in which way the type checker handles phantom types in +-- RULES. We would like these type variables to be generalised, but some +-- versions of GHC instantiated them to `()', which seriously limited the +-- applicability of such RULES. + +module Main (main) +where + +data T a = C + +foo :: T a -> String +{-# NOINLINE foo #-} +foo C = "rewrite rule did NOT fire" + +{-# RULES + +-- this rule will not fire if the type argument of `T' is constrained to `()' +-- +"foo/C" foo C = "rewrite rule did fire" + + #-} + +main = putStrLn $ foo (C :: T Int) diff --git a/testsuite/tests/typecheck/should_run/tcrun022.stdout b/testsuite/tests/typecheck/should_run/tcrun022.stdout new file mode 100644 index 0000000000..3943681c07 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun022.stdout @@ -0,0 +1 @@ +rewrite rule did fire diff --git a/testsuite/tests/typecheck/should_run/tcrun023.hs b/testsuite/tests/typecheck/should_run/tcrun023.hs new file mode 100644 index 0000000000..3a6166b015 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun023.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ImplicitParams #-} + +-- Implicit parameters should not give rise to ambiguity. + +module Main (main) where + +foo :: (?x :: [a]) => Int -> String +foo n = show (n + length ?x) + + +main = do { putStrLn (let ?x = [True,False] in foo 3) ; + putStrLn (let ?x = "fred" in foo 4) } + diff --git a/testsuite/tests/typecheck/should_run/tcrun023.stdout b/testsuite/tests/typecheck/should_run/tcrun023.stdout new file mode 100644 index 0000000000..2050fde75a --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun023.stdout @@ -0,0 +1,2 @@ +5 +8 diff --git a/testsuite/tests/typecheck/should_run/tcrun024.hs b/testsuite/tests/typecheck/should_run/tcrun024.hs new file mode 100644 index 0000000000..82c6f49e33 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun024.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ImplicitParams, TypeSynonymInstances, FlexibleInstances #-} + +-- Class ops that bind no new type variables + +module Main where + + import Data.List( sort ) + + just = [Just "fred",Just "bill"] + + main = do { putStrLn (let ?p = "ok1" in fc1); + putStrLn (let ?p = "ok2" in fc2); + putStrLn (show (fd1 just)) ; + putStrLn (show (fd2 just)) } + + -- This class has no tyvars in its class op context + -- One uses a newtype, the other a data type + class C1 a where + fc1 :: (?p :: String) => a; + class C2 a where + fc2 :: (?p :: String) => a; + opc :: a + + instance C1 String where + fc1 = ?p; + instance C2 String where + fc2 = ?p; + opc = "x" + + -- This class constrains no new type variables in + -- its class op context + class D1 a where + fd1 :: (Ord a) => [a] -> [a] + class D2 a where + fd2 :: (Ord a) => [a] -> [a] + opd :: a + + instance D1 (Maybe a) where + fd1 xs = sort xs + instance D2 (Maybe a) where + fd2 xs = sort xs + opd = Nothing + diff --git a/testsuite/tests/typecheck/should_run/tcrun024.stdout b/testsuite/tests/typecheck/should_run/tcrun024.stdout new file mode 100644 index 0000000000..bdafbe58ac --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun024.stdout @@ -0,0 +1,4 @@ +ok1 +ok2 +[Just "bill",Just "fred"] +[Just "bill",Just "fred"] diff --git a/testsuite/tests/typecheck/should_run/tcrun025.hs b/testsuite/tests/typecheck/should_run/tcrun025.hs new file mode 100644 index 0000000000..b7a565934e --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun025.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ImplicitParams #-} + +-- Like tcrun024, but cross module + +module Main where + import TcRun025_B + + just = [Just "fred",Just "bill"] + + main = do { putStrLn (let ?p = "ok1" in fc1); + putStrLn (let ?p = "ok2" in fc2); + putStrLn (show (fd1 just)) ; + putStrLn (show (fd2 just)) } + + diff --git a/testsuite/tests/typecheck/should_run/tcrun025.stdout b/testsuite/tests/typecheck/should_run/tcrun025.stdout new file mode 100644 index 0000000000..bdafbe58ac --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun025.stdout @@ -0,0 +1,4 @@ +ok1 +ok2 +[Just "bill",Just "fred"] +[Just "bill",Just "fred"] diff --git a/testsuite/tests/typecheck/should_run/tcrun026.hs b/testsuite/tests/typecheck/should_run/tcrun026.hs new file mode 100644 index 0000000000..7e52d3ce54 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun026.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Rank2Types #-} + +-- Crashed GHC 5.04 with tcTyC +-- panic: tcSplitTyConApp forall x{-r6S-} :: *. +-- Main.L{-rr-} x{-r6S-} + +-- GHC 6.3: this is now an error (can do subsumption in patterns) + +module Main where + +newtype FA c = FA (forall x . c x) +newtype L x = L [x] + +my_nil = FA (L []) :: FA L + +sample :: String +sample = case my_nil of FA (L x) -> "foo"++x + +-- -- but this works fine +-- sample = case my_nil of FA x -> case x of L y -> "foo"++y + +main = print sample diff --git a/testsuite/tests/typecheck/should_run/tcrun026.stderr b/testsuite/tests/typecheck/should_run/tcrun026.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun026.stderr diff --git a/testsuite/tests/typecheck/should_run/tcrun026.stdout b/testsuite/tests/typecheck/should_run/tcrun026.stdout new file mode 100644 index 0000000000..810c96eeeb --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun026.stdout @@ -0,0 +1 @@ +"foo" diff --git a/testsuite/tests/typecheck/should_run/tcrun027.hs b/testsuite/tests/typecheck/should_run/tcrun027.hs new file mode 100644 index 0000000000..734d230394 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun027.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ImplicitParams #-} + +-- Killed GHC 5.04.1 + +module Main where + +type CTPar = ([Double],Int) + +us :: (?ctPar :: CTPar) => [Double] +us = let (d,_) = ?ctPar in d + +main = let ?ctPar = ([3.4],2) in print us diff --git a/testsuite/tests/typecheck/should_run/tcrun027.stdout b/testsuite/tests/typecheck/should_run/tcrun027.stdout new file mode 100644 index 0000000000..dabf967d39 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun027.stdout @@ -0,0 +1 @@ +[3.4] diff --git a/testsuite/tests/typecheck/should_run/tcrun028.hs b/testsuite/tests/typecheck/should_run/tcrun028.hs new file mode 100644 index 0000000000..f4f8fd9d61 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun028.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -dcore-lint #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, UndecidableInstances #-} + +-- This is a rather exotic functional-dependency test. +-- It crashed GHC 5.04.3 with a core-lint error, because +-- of a bug in tcSimplifyRestricted (fixed Apr 03) + +module Main where + + +class ComposePS a b c | a b -> c where + (.>) :: PSOp a -> PSOp b -> PSOp c + (V a) .> (V b) = V (a ++ b) + +instance (ConcatPS a b c, CheckPS c Id Id d) => ComposePS a b d + +------------------------------------------------------------------------------ + +data PSOp a = V [String] deriving Show + +data Id +data Push t rest +data Pop t rest + + +class Reverse a b c | a b -> c +instance Reverse Id b b +instance Reverse a (Pop t b) c => Reverse (Pop t a) b c +instance Reverse a (Push t b) c => Reverse (Push t a) b c + +------------------------------------------------------------------------------ + +class ConcatPS a b c | a b -> c where + ccat :: a -> b -> c +instance ConcatPS Id a a +instance ConcatPS a b c => ConcatPS (Pop t a) b (Pop t c) +instance ConcatPS a b c => ConcatPS (Push t a) b (Push t c) + +------------------------------------------------------------------------------ + +class CheckPS a b c d | a b c -> d where + check :: a -> b -> c -> d + check _ _ _ = error "oki" + +instance Reverse a b c => CheckPS Id a b c + +instance CheckPS a b (Push t c) d => CheckPS (Push t a) b c d + +instance CheckPS a (Pop t b) Id d => CheckPS (Pop t a) b Id d + +instance CheckPS a b c d => CheckPS (Pop t a) b (Push t c) d + + +v1 :: PSOp (Pop a Id) +v1 = V [] + +v2 :: PSOp Id +v2 = V [] + +t = v1 .> v2 + +main = print t diff --git a/testsuite/tests/typecheck/should_run/tcrun028.stdout b/testsuite/tests/typecheck/should_run/tcrun028.stdout new file mode 100644 index 0000000000..7d447a7415 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun028.stdout @@ -0,0 +1 @@ +V [] diff --git a/testsuite/tests/typecheck/should_run/tcrun029.hs b/testsuite/tests/typecheck/should_run/tcrun029.hs new file mode 100644 index 0000000000..55071be483 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun029.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DatatypeContexts #-} +-- Killed GHC 5.02.3 + +-- Confusion about whether the wrapper for a data constructor +-- with a "stupid context" includes the stupid context or not +-- Core lint catches it, but it seg-faults if it runs + +module Main where + +data Color = Red + | Black + deriving Show + +data Ord k => Tree k d = None + | Node{color::Color, + key::k, + item::d, + left::(Tree k d), + right::(Tree k d)} + deriving Show + +insert k i t = (insert2 t) {color=Black} + where insert2 None = Node{color=Red, + key=k, + item=i, + left=None, + right=None} + +main = print (insert 1 2 None)
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_run/tcrun029.stdout b/testsuite/tests/typecheck/should_run/tcrun029.stdout new file mode 100644 index 0000000000..127a2b4781 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun029.stdout @@ -0,0 +1 @@ +Node {color = Black, key = 1, item = 2, left = None, right = None} diff --git a/testsuite/tests/typecheck/should_run/tcrun030.hs b/testsuite/tests/typecheck/should_run/tcrun030.hs new file mode 100644 index 0000000000..fe28a33091 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun030.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- Test recursive dictionaries + +module Main where + +data D r = ZeroD | SuccD (r (D r)); + +instance (Eq (r (D r))) => Eq (D r) where + ZeroD == ZeroD = True + (SuccD a) == (SuccD b) = a == b + _ == _ = False; + +equalDC :: D [] -> D [] -> Bool; +equalDC = (==); + +foo :: D [] +foo = SuccD [SuccD [ZeroD], ZeroD] + +main = print (foo == foo) diff --git a/testsuite/tests/typecheck/should_run/tcrun030.stdout b/testsuite/tests/typecheck/should_run/tcrun030.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun030.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/typecheck/should_run/tcrun031.hs b/testsuite/tests/typecheck/should_run/tcrun031.hs new file mode 100644 index 0000000000..fbffe97c0e --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun031.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} + +-- A newtype-deriving test + +module Main where + +class C a b where + op :: a -> b -> b +instance C [a] Char where + op [] x = x + op _ x = 'z' + +newtype T = T Char deriving( Show, C [a] ) + +main = do { print (op [] 'x') + ; print (op [] (T 'y')) } diff --git a/testsuite/tests/typecheck/should_run/tcrun031.stdout b/testsuite/tests/typecheck/should_run/tcrun031.stdout new file mode 100644 index 0000000000..347fadaa0c --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun031.stdout @@ -0,0 +1,2 @@ +'x' +T 'y' diff --git a/testsuite/tests/typecheck/should_run/tcrun032.hs b/testsuite/tests/typecheck/should_run/tcrun032.hs new file mode 100644 index 0000000000..8aa43637ba --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun032.hs @@ -0,0 +1,20 @@ + +{-# LANGUAGE UndecidableInstances #-}
+
+-- This tests the recursive-dictionary stuff.
+
+module Main where
+
+data Fix f = In (f (Fix f))
+
+instance Show (f (Fix f)) => Show (Fix f) where
+ show (In x) = "In " ++ show x -- No parens, but never mind
+
+instance Eq (f (Fix f)) => Eq (Fix f) where
+ (In x) == (In y) = x==y
+
+data L x = Nil | Cons Int x deriving( Show, Eq )
+
+main = do { print (In Nil);
+ print (In Nil == In Nil) }
+
diff --git a/testsuite/tests/typecheck/should_run/tcrun032.stdout b/testsuite/tests/typecheck/should_run/tcrun032.stdout new file mode 100644 index 0000000000..9639b4b410 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun032.stdout @@ -0,0 +1,2 @@ +In Nil
+True
diff --git a/testsuite/tests/typecheck/should_run/tcrun033.hs b/testsuite/tests/typecheck/should_run/tcrun033.hs new file mode 100644 index 0000000000..f9cf6a3faa --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun033.hs @@ -0,0 +1,31 @@ + +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, + UndecidableInstances, TypeSynonymInstances #-} + +-- This test made GHC 6.3 build a superclass loop, in +-- the instance ClassA a String declaration + +module Main where + +class (Sat (a -> b -> String), ClassB b) => ClassA a b + +class ClassB a where + fun :: a -> String + +class Sat x where + sat :: x + +instance ClassA a b => Sat (a -> b -> String) where + sat = const fun + +instance ClassA a String +-- Badness was that the ClassB superclass dict was loopy +-- +-- Needs Sat (a -> String -> String), ClassB String +-- --> ClassA a String, ClassB String +-- and adding ClassA gives superclass ClassB. + +instance ClassB String where + fun = id + +main = print ((sat :: Int -> String -> String) 3 "hello") diff --git a/testsuite/tests/typecheck/should_run/tcrun033.stdout b/testsuite/tests/typecheck/should_run/tcrun033.stdout new file mode 100644 index 0000000000..3bd41263bf --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun033.stdout @@ -0,0 +1 @@ +"hello"
diff --git a/testsuite/tests/typecheck/should_run/tcrun034.hs b/testsuite/tests/typecheck/should_run/tcrun034.hs new file mode 100644 index 0000000000..ac07869b40 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun034.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ExplicitForAll, TypeOperators #-} + +module Main where + +-- Infix type operator +f1 :: forall m a b. (a `m` b) -> ((a `m` b) -> a) -> a +f1 x g = g x + +-- Infix type operator +f2 :: forall a b (-->). (a --> b) -> ((a --> b) -> b) -> b +f2 x g = g x + +main = do { print (f1 (3,5) fst); print (f2 (3,5) snd) } + diff --git a/testsuite/tests/typecheck/should_run/tcrun034.stdout b/testsuite/tests/typecheck/should_run/tcrun034.stdout new file mode 100644 index 0000000000..7ee0007bf1 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun034.stdout @@ -0,0 +1,2 @@ +3 +5 diff --git a/testsuite/tests/typecheck/should_run/tcrun035.hs b/testsuite/tests/typecheck/should_run/tcrun035.hs new file mode 100644 index 0000000000..ee9f27bb7b --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun035.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Rank2Types #-} + +-- Tests subsumption for infix operators (in this case (.)) +-- Broke GHC 6.4! + +-- Now it breaks the impredicativity story +-- (id {a}) . (id {a}) :: a -> a +-- And (forall m. Monad m => m a) /~ IO a + +module Main(main) where + +foo :: (forall m. Monad m => m a) -> IO a +foo = id . id + +main :: IO () +main = foo (return ()) diff --git a/testsuite/tests/typecheck/should_run/tcrun035.stderr b/testsuite/tests/typecheck/should_run/tcrun035.stderr new file mode 100644 index 0000000000..67d341883e --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun035.stderr @@ -0,0 +1,9 @@ + +tcrun035.hs:13:12: + Couldn't match expected type `IO a' + with actual type `forall (m :: * -> *). Monad m => m a' + Expected type: (forall (m :: * -> *). Monad m => m a) -> IO a + Actual type: (forall (m :: * -> *). Monad m => m a) + -> forall (m :: * -> *). Monad m => m a + In the second argument of `(.)', namely `id' + In the expression: id . id diff --git a/testsuite/tests/typecheck/should_run/tcrun036.hs b/testsuite/tests/typecheck/should_run/tcrun036.hs new file mode 100644 index 0000000000..cef36a613d --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun036.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE Rank2Types #-} + +-- Another test for the new feature that contexts in a mutually +-- recursive group do not need to be of the same length +-- I'm putting it here mainly to document the need + +-- GHC used to say: +-- +-- Bug.lhs:23:10: +-- Inferred type is less polymorphic than expected +-- Quantified type variable `c' is mentioned in the environment: +-- printCatalog :: c -> IO () (bound at Bug.lhs:28:0) +-- In the `viewCatalog' field of a record + +-- Bug.lhs:27:0: +-- Contexts differ in length +-- When matching the contexts of the signatures for +-- printer :: Viewer +-- printCatalog :: forall c. (Catalog c) => View c +-- The signature contexts in a mutually recursive group should all be identical + +module Main where + +class Catalog c where + traverse :: c -> Viewer -> IO () + +instance Catalog Int where + traverse i v = viewShowable v i + +type View a = a -> IO () + +data Viewer = Viewer { + viewShowable :: forall s. Show s => View s, + viewCatalog :: forall c. Catalog c => View c + } + +printer :: Viewer +--printer = Viewer { +-- viewCatalog = \x -> traverse x printer, +-- viewShowable = putStrLn . show } +printer = Viewer { + viewCatalog = printCatalog, + viewShowable = putStrLn . show } + +printCatalog :: forall c. Catalog c => View c +printCatalog x = traverse x printer + +data X = X { + cat :: Int + } + +instance Catalog X where + traverse x v = do + viewCatalog v (cat x) + +main = do + let x = X { cat = 20 } + traverse x printer diff --git a/testsuite/tests/typecheck/should_run/tcrun036.stdout b/testsuite/tests/typecheck/should_run/tcrun036.stdout new file mode 100644 index 0000000000..209e3ef4b6 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun036.stdout @@ -0,0 +1 @@ +20 diff --git a/testsuite/tests/typecheck/should_run/tcrun037.hs b/testsuite/tests/typecheck/should_run/tcrun037.hs new file mode 100644 index 0000000000..e79817d5cb --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun037.hs @@ -0,0 +1,13 @@ + + +module Main where + +class C a where + op :: (Show a, Show b) => a -> b -> String + -- This class op has local quantification, but + -- also adds a constraint on 'a' + +instance C Bool where + op x y = show x ++ " " ++ show y + +main = do { putStrLn (op True 'x'); putStrLn (op False (3::Int)) } diff --git a/testsuite/tests/typecheck/should_run/tcrun037.stdout b/testsuite/tests/typecheck/should_run/tcrun037.stdout new file mode 100644 index 0000000000..ef74440844 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun037.stdout @@ -0,0 +1,2 @@ +True 'x' +False 3 diff --git a/testsuite/tests/typecheck/should_run/tcrun038.hs b/testsuite/tests/typecheck/should_run/tcrun038.hs new file mode 100644 index 0000000000..26337cdb95 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun038.hs @@ -0,0 +1,8 @@ +module Main where
+
+import TcRun038_B( Foo(..), bar )
+
+instance Foo Int where
+ op x = x+1
+
+main = print (bar (3::Int))
diff --git a/testsuite/tests/typecheck/should_run/tcrun038.stdout b/testsuite/tests/typecheck/should_run/tcrun038.stdout new file mode 100644 index 0000000000..84b19cd5a7 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun038.stdout @@ -0,0 +1 @@ +11
diff --git a/testsuite/tests/typecheck/should_run/tcrun039.hs b/testsuite/tests/typecheck/should_run/tcrun039.hs new file mode 100644 index 0000000000..916d5330e4 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun039.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE GADTs, ExplicitForAll #-} +
+-- Test for GADTs and implication constraints
+
+module Main where
+
+data T a where
+ MkT :: Num a => a -> T a
+
+f :: Read a => T a -> String -> a
+f (MkT n) s = n + read s
+
+----------------
+data GADT a where
+ MkG :: Num a => a -> GADT [a]
+
+g :: forall b. Read b => GADT b -> String -> b
+g (MkG n) s = -- Here we know Read [b]
+ n : (read s)
+
+main = do print (f (MkT (3::Int)) "4")
+ print (g (MkG (3::Int)) "[4,5]")
diff --git a/testsuite/tests/typecheck/should_run/tcrun039.stdout b/testsuite/tests/typecheck/should_run/tcrun039.stdout new file mode 100644 index 0000000000..a13aef23d7 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun039.stdout @@ -0,0 +1,2 @@ +7
+[3,4,5]
diff --git a/testsuite/tests/typecheck/should_run/tcrun040.hs b/testsuite/tests/typecheck/should_run/tcrun040.hs new file mode 100644 index 0000000000..adfaf95898 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun040.hs @@ -0,0 +1,27 @@ +-- Sven Panne found this example; a mistake in typechecking +-- lazy patterns made functions too strict in a version of +-- GHC 6.7 + +module Main where + +import Foreign + +-- Strangely enough, this works if newtype is used... +data Elem a = Elem a + +instance Storable a => Storable (Elem a) where + sizeOf ~(Elem r) = 3 * sizeOf r + alignment ~(Elem r) = alignment r + peek ptr = do r <- peekElemOff (castPtr ptr) 0; return (Elem r) + poke ptr (Elem r) = poke (castPtr ptr) r + +main :: IO () +main = do + putStrLn "*** main 1" + allocaBytes 100 $ \buf -> do + poke buf (Elem 12345) + putStrLn "*** main 2" + Elem x <- peekElemOff buf 0 + print (x :: Int) + putStrLn "*** main 3" + diff --git a/testsuite/tests/typecheck/should_run/tcrun040.stdout b/testsuite/tests/typecheck/should_run/tcrun040.stdout new file mode 100644 index 0000000000..827c4f698a --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun040.stdout @@ -0,0 +1,4 @@ +*** main 1 +*** main 2 +12345 +*** main 3 diff --git a/testsuite/tests/typecheck/should_run/tcrun041.hs b/testsuite/tests/typecheck/should_run/tcrun041.hs new file mode 100644 index 0000000000..f78141adc7 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun041.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TupleSections, UnboxedTuples #-} +module Main where + +a :: Int -> (Int, Bool) +a = ( , True) + +b :: Bool -> (Int, Bool) +b = (1, ) + +c :: a -> (a, Bool) +c = (, True || False) + +d = (,1,) + + +e = (# , True #) + +f = (# 1, #) + +g = (# , True || False #) + +h = (# ,1, #) + + +unchanged :: a -> (# Int #) +unchanged _binding = (# #) 1 + + +main = do + print (a 1, b False, c "Hello", c 1337, d "Yeah" "Baby") + case e 1 of { (# x1, x2 #) -> + case f False of { (# x3, x4 #) -> + case g "Hello" of { (# x5, x6 #) -> + case g 1337 of { (# x7, x8 #) -> + case h "Yeah" "Baby" of { (# x9, x10, x11 #) -> + print (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) }}}}} + diff --git a/testsuite/tests/typecheck/should_run/tcrun041.stdout b/testsuite/tests/typecheck/should_run/tcrun041.stdout new file mode 100644 index 0000000000..83a55b7ca7 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun041.stdout @@ -0,0 +1,2 @@ +((1,True),(1,False),("Hello",True),(1337,True),("Yeah",1,"Baby")) +(1,True,1,False,"Hello",True,1337,True,"Yeah",1,"Baby") diff --git a/testsuite/tests/typecheck/should_run/tcrun042.hs b/testsuite/tests/typecheck/should_run/tcrun042.hs new file mode 100644 index 0000000000..1ea5c2467f --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun042.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TupleSections, RankNTypes, ImpredicativeTypes #-} +module Main where + +e :: a -> (forall b. b -> b -> b) -> (a, String, forall c. c -> c -> c) +e = (,"Hello" ++ "World",) + +dropFunction :: (a, String, forall c. c -> c -> c) -> (a, String, Int) +dropFunction (x, y, z) = (x, y, z 10 20) + +main = print (dropFunction $ e "Meh" (flip const), dropFunction $ e 10 const)
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_run/tcrun042.stdout b/testsuite/tests/typecheck/should_run/tcrun042.stdout new file mode 100644 index 0000000000..3ce33b9abd --- /dev/null +++ b/testsuite/tests/typecheck/should_run/tcrun042.stdout @@ -0,0 +1 @@ +(("Meh","HelloWorld",20),(10,"HelloWorld",10)) diff --git a/testsuite/tests/typecheck/should_run/testeq2.hs b/testsuite/tests/typecheck/should_run/testeq2.hs new file mode 100644 index 0000000000..811131b453 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/testeq2.hs @@ -0,0 +1,68 @@ + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, FlexibleContexts, + OverlappingInstances, UndecidableInstances #-} + +-- +-- Test case adopted from the HList library +-- http://www.cwi.nl/~ralf/HList/ +-- +-- Tests functional dependencies, overlapping instances.... + +module Main where + + +-- +-- Type-level Booleans; nothing weird +-- +data HTrue; hTrue :: HTrue; hTrue = undefined +data HFalse; hFalse :: HFalse; hFalse = undefined +class HBool x; instance HBool HTrue; instance HBool HFalse +instance Show HTrue where show _ = "HTrue" +instance Show HFalse where show _ = "HFalse" + + +-- +-- Value-level incarnation; nothing too weird. +-- Rely on lazy show for type-level Booleans +-- +typeEq :: TypeEq t t' b => t -> t' -> b +typeEq = undefined + + +-- +-- Type-level cast +-- +class TypeCast a b | a -> b, b->a where typeCast :: a -> b +class TypeCast' t a b | t a -> b, t b -> a where typeCast' :: t->a->b +class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b +instance TypeCast' () a b => TypeCast a b where typeCast x = typeCast' () x +instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast'' +instance TypeCast'' () a a where typeCast'' _ x = x + + +-- +-- Type-level type equality +-- + +class TypeEq' () x y b => TypeEq x y b | x y -> b +class TypeEq' q x y b | q x y -> b +class TypeEq'' q x y b | q x y -> b +instance TypeEq' () x y b => TypeEq x y b +-- This instance used to work <= GHC 6.2 +-- instance TypeEq' () x x HTrue +-- There were some problems however with GHC CVS 6.3. +-- So we favour the following, more stable (?) instance instead. +instance TypeCast b HTrue => TypeEq' () x x b +instance TypeEq'' q x y b => TypeEq' q x y b +instance TypeEq'' () x y HFalse + + +-- +-- Let's test. +-- The following should print "(HTrue,HFalse)". +-- + +main = print $ ( typeEq "42" "88" + , typeEq "42" (42::Int) + ) diff --git a/testsuite/tests/typecheck/should_run/testeq2.stdout b/testsuite/tests/typecheck/should_run/testeq2.stdout new file mode 100644 index 0000000000..7f7d90eae7 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/testeq2.stdout @@ -0,0 +1 @@ +(HTrue,HFalse)
diff --git a/testsuite/tests/typecheck/testeq1/FakePrelude.hs b/testsuite/tests/typecheck/testeq1/FakePrelude.hs new file mode 100644 index 0000000000..80161655d0 --- /dev/null +++ b/testsuite/tests/typecheck/testeq1/FakePrelude.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + OverlappingInstances, UndecidableInstances #-} + +-- +-- Test case adopted from the HList library +-- http://www.cwi.nl/~ralf/HList/ +-- + +module FakePrelude where + + +-- +-- Type-level Booleans; nothing weird +-- +data HTrue; hTrue :: HTrue; hTrue = undefined +data HFalse; hFalse :: HFalse; hFalse = undefined +class HBool x; instance HBool HTrue; instance HBool HFalse +instance Show HTrue where show _ = "HTrue" +instance Show HFalse where show _ = "HFalse" + + +-- +-- Type-level type equality +-- +class HBool b => TypeEq x y b | x y -> b + + +-- +-- Value-level incarnation; nothing too weird. +-- Rely on lazy show for type-level Booleans +-- +typeEq :: TypeEq t t' b => t -> t' -> b +typeEq = undefined + + +-- +-- Type-level cast +-- +class TypeCast x y | x -> y, y -> x + where + typeCast :: x -> y diff --git a/testsuite/tests/typecheck/testeq1/Main.hs b/testsuite/tests/typecheck/testeq1/Main.hs new file mode 100644 index 0000000000..1e28d00192 --- /dev/null +++ b/testsuite/tests/typecheck/testeq1/Main.hs @@ -0,0 +1,24 @@ + +{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} + +-- +-- Test case adopted from the HList library +-- http://www.cwi.nl/~ralf/HList/ +-- +-- Tests functional dependencies and overlapping instances + +module Main where + +import FakePrelude +import TypeEq +import TypeCast + + +-- +-- Let's test. +-- The following should print "(HTrue,HFalse)". +-- + +main = print $ ( typeEq "42" "88" + , typeEq "42" (42::Int) + ) diff --git a/testsuite/tests/typecheck/testeq1/Makefile b/testsuite/tests/typecheck/testeq1/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/typecheck/testeq1/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/typecheck/testeq1/TypeCast.hs b/testsuite/tests/typecheck/testeq1/TypeCast.hs new file mode 100644 index 0000000000..96a4d66e57 --- /dev/null +++ b/testsuite/tests/typecheck/testeq1/TypeCast.hs @@ -0,0 +1,16 @@ + +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} + +-- +-- Test case adopted from the HList library +-- http://www.cwi.nl/~ralf/HList/ +-- + +module TypeCast where + +import FakePrelude + +-- +-- We are ready to reveal the definition of type cast. +-- +instance TypeCast x x where typeCast = id diff --git a/testsuite/tests/typecheck/testeq1/TypeEq.hs b/testsuite/tests/typecheck/testeq1/TypeEq.hs new file mode 100644 index 0000000000..599893cc09 --- /dev/null +++ b/testsuite/tests/typecheck/testeq1/TypeEq.hs @@ -0,0 +1,22 @@ + +{-# LANGUAGE MultiParamTypeClasses, + FlexibleInstances, OverlappingInstances, UndecidableInstances #-} + +-- +-- Test case adopted from the HList library +-- http://www.cwi.nl/~ralf/HList/ +-- + +module TypeEq where + +import FakePrelude + +-- +-- Type-level type equality; +-- defined in terms of type-level cast +-- +instance TypeEq x x HTrue +instance (HBool b, TypeCast HFalse b) => TypeEq x y b +-- +-- NOTE! instance TypeEq x y HFalse -- would violate functional dependency +-- diff --git a/testsuite/tests/typecheck/testeq1/test.T b/testsuite/tests/typecheck/testeq1/test.T new file mode 100644 index 0000000000..dbb63fb9f8 --- /dev/null +++ b/testsuite/tests/typecheck/testeq1/test.T @@ -0,0 +1,9 @@ + +test('typecheck.testeq1', + [skip_if_fast, + extra_clean(['Main.hi', 'Main.o', + 'TypeCast.hi', 'TypeCast.o', + 'FakePrelude.hi', 'FakePrelude.o', + 'TypeEq.hi', 'TypeEq.o'])], + multimod_compile_and_run, + ['Main', '-v0']) diff --git a/testsuite/tests/typecheck/testeq1/typecheck.testeq1.stdout b/testsuite/tests/typecheck/testeq1/typecheck.testeq1.stdout new file mode 100644 index 0000000000..7f7d90eae7 --- /dev/null +++ b/testsuite/tests/typecheck/testeq1/typecheck.testeq1.stdout @@ -0,0 +1 @@ +(HTrue,HFalse)
|