[project @ 2005-08-11 08:55:19 by simonpj]

Update output; add a test

testsuite/tests/ghc-regress/typecheck/should_fail/tcfail028.stderr

-
-tcfail028.hs:4:15:
-    `A a' is not applied to enough type arguments
-    Expected kind `?', but `A a' has kind `k_abR -> *'
-    In the data type declaration for `A'
+
+tcfail028.hs:4:15:
+    `A a' is not applied to enough type arguments
+    Expected kind `?', but `A a' has kind `k -> *'
+    In the data type declaration for `A'

testsuite/tests/ghc-regress/typecheck/should_fail/tcfail128.stderr

@@ -7,11 +7,11 @@ tcfail128.hs:18:15:
     In a 'do' expression: v <- thaw tmp
     In the definition of `main':
 	main = do
-		 let help :: [FlatVector]
-		     tmp :: Vector FlatVector
-		     sL = [1, 4, 6, 3, 2, 5]
+		 let sL = [1, 4, 6, 3, 2, 5]
 		     dim = length sL
+		     help :: [FlatVector]
 		     help = [... | s <- ...]
+		     tmp :: Vector FlatVector
 		     tmp = listVector (1, dim) help
 		 v <- thaw tmp
 		 return ()

testsuite/tests/ghc-regress/typecheck/should_fail/tcfail132.stderr

 
 tcfail132.hs:21:35:
     Kind mis-match
-    Expected kind `k_acI -> k_acM -> k_acQ -> *',
-    but `Object f' f t' has kind `k_acI -> k_acM -> *'
+    Expected kind `k -> k1 -> k2 -> *', but `Object f' f t' has kind `k -> k1 -> *'
     In the type synonym declaration for `LiftObject'

testsuite/tests/ghc-regress/typecheck/should_fail/tcfail135.stderr

-
-tcfail135.hs:6:22:
-    `f' is not applied to enough type arguments
-    Expected kind `?', but `f' has kind `k_abV -> *'
-    In the type `f a -> f'
-    In the class declaration for `Foo'
+
+tcfail135.hs:6:22:
+    `f' is not applied to enough type arguments
+    Expected kind `?', but `f' has kind `k -> *'
+    In the type `f a -> f'
+    In the class declaration for `Foo'

testsuite/tests/ghc-regress/typecheck/should_fail/tcfail136.stderr

 
 tcfail136.hs:9:34:
     `SymDict' is not applied to enough type arguments
-    Expected kind `?', but `SymDict' has kind `k_ac1 -> *'
+    Expected kind `?', but `SymDict' has kind `k -> *'
     In the data type declaration for `SymTable'

testsuite/tests/ghc-regress/typecheck/should_run/all.T

@@ -41,6 +41,7 @@ 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_and_run, [''])
+test('tcrun036', only_compiler_types(['ghc']), compile_and_run, [''])
 
 test('church', normal, compile_and_run, [''])
 test('testeq2', normal, compile_and_run, [''])

testsuite/tests/ghc-regress/typecheck/should_run/tcrun036.hs

+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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