[prev in list] [next in list] [prev in thread] [next in thread]
List: haskell-jhc
Subject: [jhc] darcs patch: import ghc parsing regression tests (and 2 more)
From: John Meacham <john () repetae ! net>
Date: 2010-08-26 11:18:34
Message-ID: 20100826111834.B386E641F5 () sliver ! repetae ! net
[Download RAW message or body]
Tue Aug 10 17:26:07 PDT 2010 John Meacham <john@repetae.net>
* import ghc parsing regression tests
Tue Aug 10 18:44:51 PDT 2010 John Meacham <john@repetae.net>
* add imported ghc typechecking regression tests
Wed Aug 11 22:44:46 PDT 2010 John Meacham <john@repetae.net>
* improve Grin Linting a little
["import-ghc-parsing-regression-tests.dpatch" (text/x-darcs-patch)]
New patches:
[import ghc parsing regression tests
John Meacham <john@repetae.net>**20100811002607
Ignore-this: 7a3676c7655fe26c52dd7eddd3c356dc
] adddir ./regress/tests/0_parse/2_pass/ghc
addfile ./regress/tests/0_parse/2_pass/ghc/T3741.hs
addfile ./regress/tests/0_parse/2_pass/ghc/config.yaml
addfile ./regress/tests/0_parse/2_pass/ghc/read001.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read002.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read004.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read005.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read008.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read009.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read010.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read011.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read014.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read015.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read016.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read017.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read018.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read019.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read021.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read022.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read023.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read024.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read025.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read026.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read028.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read029.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read030.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read031.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read032.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read033.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read034.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read036.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read037.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read038.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read039.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read040.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read042.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read043.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read044.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read045.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read048.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read049.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read050.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read054.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read056.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read057.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read058.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read060.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read061.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read062.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read064.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read066.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read067.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read068.hs
addfile ./regress/tests/0_parse/2_pass/ghc/read_1821.hs
hunk ./regress/tests/0_parse/2_pass/ghc/T3741.hs 1
+笑 :: Int
+笑 = 3
+
+main = print 笑
hunk ./regress/tests/0_parse/2_pass/ghc/config.yaml 1
+tests:
+ read028:
+ skip: known_bug
+ read030:
+ skip: known_bug
+ read042:
+ skip: BangPatterns
+ read050:
+ skip: KindSignatures
+ read054:
+ skip: ParallelListComp
+ read058:
+ skip: RecursiveDo
+ read062:
+ skip: TransformListComp
hunk ./regress/tests/0_parse/2_pass/ghc/read001.hs 1
+-- !!! import qualified Prelude should leave (), [] etc in scope
+
+module ShouldCompile where
+
+import qualified Prelude
+
+f :: Prelude.IO ()
+f = Prelude.return ()
hunk ./regress/tests/0_parse/2_pass/ghc/read002.hs 1
+-- !!! tests fixity reading and printing
+module ShouldCompile where
+
+infixl 1 `f`
+infixr 2 \\\
+infix 3 :==>
+infix 4 `MkFoo`
+
+data Foo = MkFoo Int | Float :==> Double
+
+x `f` y = x
+
+(\\\) :: (Eq a) => [a] -> [a] -> [a]
+(\\\) xs ys = xs
hunk ./regress/tests/0_parse/2_pass/ghc/read004.hs 1
+module ShouldCompile where
+
+{-
+From: Kevin Hammond <kh>
+To: partain
+Subject: Re: parsing problem w/ queens
+Date: Wed, 9 Oct 91 17:31:46 BST
+
+OK, I've fixed that little problem by disallowing,
+-}
+
+f x = x + if True then 1 else 2
+g x = x + 1::Int
+
+-- (the conditional/sig need to be parenthesised). If this is
+-- problematic, let me know!
hunk ./regress/tests/0_parse/2_pass/ghc/read005.hs 1
+module ShouldCompile where
+
+-- !!! Empty comments terminating a file..
+main = print "Hello" --
hunk ./regress/tests/0_parse/2_pass/ghc/read008.hs 1
+module ShouldCompile where
+
+{-# SPECIALISE f :: Int -> Int #-}
+f n = n + 1
hunk ./regress/tests/0_parse/2_pass/ghc/read009.hs 1
+-- !!! combining undeclared infix operators
+module ShouldCompile where
+
+-- should default to 'infixl 9'
+
+test = let f x y = x+y in 1 `f` 2 `f` 3
+
hunk ./regress/tests/0_parse/2_pass/ghc/read010.hs 1
+-- !!! Infix record constructor.
+module ShouldCompile where
+
+data Rec = (:<-:) { a :: Int, b :: Float }
hunk ./regress/tests/0_parse/2_pass/ghc/read011.hs 1
+-- !!! do & where interaction
+module ShouldCompile where
+
+f1 :: IO a -> IO [a]
+f1 x = do
+ v <- x
+ return [v]
+ where
+ g x = [x,x]
+
+f2 :: IO a -> IO [a]
+f2 x = do
+ v <- x
+ return (g v)
+ where
+ g x = [x,x]
+
+f3 :: IO a -> IO [a]
+f3 x = do
+ v <- x
+ return (g v)
+ where
+ g x = [x,x]
+
hunk ./regress/tests/0_parse/2_pass/ghc/read014.hs 1
+-- !!! Empty export lists are legal (and useful.)
+module ShouldCompile () where
+
+ng1 x y = negate y
+
+instance (Num a, Num b) => Num (a,b)
+ where
+ negate (a,b) = (ng 'c' a, ng1 'c' b) where ng x y = negate y
hunk ./regress/tests/0_parse/2_pass/ghc/read015.hs 1
+-- !!! Testing whether the parser likes empty declarations..
+module ShouldCompile where { ;;;;;x=let{;;;;;y=2;;;;}in y;;;;;}
hunk ./regress/tests/0_parse/2_pass/ghc/read016.hs 1
+-- !!! Checking that both import lists and 'hiding' lists might
+-- !!! be empty.
+module ShouldCompile where
+
+import List ()
+import List hiding ()
+
+x :: Int
+x = 1
+
hunk ./regress/tests/0_parse/2_pass/ghc/read017.hs 1
+-- !!! Checking that empty declarations are permitted.
+module ShouldCompile where
+
+
+class Foo a where
+
+class Foz a
+
+x = 2 where
+y = 3
+
+instance Foo Int where
+
+f = f where g = g where
+type T = Int
hunk ./regress/tests/0_parse/2_pass/ghc/read018.hs 1
+-- !!! Checking that empty contexts are permitted.
+module ShouldCompile where
+
+data () => Foo a = Foo a
+
+newtype () => Bar = Bar Int
+
+f :: () => Int -> Int
+f = (+1)
+
+
+class () => Fob a where
+
+instance () => Fob Int where
+instance () => Fob Float
+
hunk ./regress/tests/0_parse/2_pass/ghc/read019.hs 1
+-- !!! Checking what's legal in the body of a class declaration.
+module ShouldCompile where
+
+class Foo a where {
+ (--<>--) :: a -> a -> Int ;
+ infixl 5 --<>-- ;
+ (--<>--) _ _ = 2 ; -- empty decl at the end.
+};
+
+
hunk ./regress/tests/0_parse/2_pass/ghc/read021.hs 1
+-- !!! Empty export list
+
+module ShouldCompile() where
+
+instance Show (a->b) where
+ show f = "<<function>>"
hunk ./regress/tests/0_parse/2_pass/ghc/read022.hs 1
+module ShouldCompile where
+
+f (x :: Int) = x + 1
hunk ./regress/tests/0_parse/2_pass/ghc/read023.hs 1
+module ShouldCompile where
+
+-- M.<keyword> isn't a qualified identifier
+f = Just.let x=id in x
+
+-- ---------------------------------------------------------------------------
+-- we changed the behaviour of this one in GHC, but the following test
+-- is strictly speaking legal Haskell:
+
+-- f' = Just.\1 where (.\) = ($)
+
+-- -----------------------------------------------------
+-- M.{as,hiding,qualified} *are* qualified identifiers:
+
+g = ShouldCompile.as
+
+-- ---------------------------------------------------------------------------
+-- special symbols (!, -) can be qualified to make varids.
+
+g' = (ShouldCompile.!)
+
+as x = x
+(!) x = x
hunk ./regress/tests/0_parse/2_pass/ghc/read024.hs 1
+-- !!! checking that special ids are correctly handled.
+module ShouldCompile where
+
+as :: [as]
+as = [head as]
+
+qualified :: [qualified]
+qualified = [head qualified]
+
+hiding :: [hiding]
+hiding = [head hiding]
+
+export :: [export]
+export = [head export]
+
+label :: [label]
+label = [head label]
+
+dynamic :: [dynamic]
+dynamic = [head dynamic]
+
+unsafe :: [unsafe]
+unsafe = [head unsafe]
+
+stdcall :: [stdcall]
+stdcall = [head stdcall]
+
+ccall :: [ccall]
+ccall = [head ccall]
+
hunk ./regress/tests/0_parse/2_pass/ghc/read025.hs 1
+-- !!! Check the handling of 'qualified' and 'as' clauses
+module ShouldCompile where
+
+import List as L ( intersperse )
+
+x = L.intersperse
+
+y = intersperse
+
hunk ./regress/tests/0_parse/2_pass/ghc/read026.hs 1
+module ShouldCompile where
+
+(<>) :: (a -> Maybe b) -> (b -> Maybe c) -> (a -> Maybe c)
+(m1 <> m2) a1 = case m1 a1 of
+ Nothing -> Nothing
+ Just a2 -> m2 a2
hunk ./regress/tests/0_parse/2_pass/ghc/read028.hs 1
+module ShouldCompile where
+
+data T a b = (:^:) a b
hunk ./regress/tests/0_parse/2_pass/ghc/read029.hs 1
+-- !!! Special Ids and ops
+
+-- The special ids 'as', 'qualified' and 'hiding' should be
+-- OK in both qualified and unqualified form.
+-- Ditto special ops
+
+module ShouldCompile where
+import Prelude hiding ( (-) )
+
+as = ShouldCompile.as
+hiding = ShouldCompile.hiding
+qualified = ShouldCompile.qualified
+x!y = x ShouldCompile.! y
+x-y = x ShouldCompile.- y
hunk ./regress/tests/0_parse/2_pass/ghc/read030.hs 1
+-- !!! Infix decls w/ infix data constructors
+
+-- GHC used to barf on this...
+
+module ShouldCompile where
+
+infix 2 |-, |+
+
+ps |- q:qs = undefined
+ps |+ p:q:qs = undefined
hunk ./regress/tests/0_parse/2_pass/ghc/read031.hs 1
+-- !!! "--" can start a legal lexeme
+
+module ShouldCompile where
+
+infix 2 --+, -->
+
+ps --> True = True
+
+(--+) a b = a && b
+
hunk ./regress/tests/0_parse/2_pass/ghc/read032.hs 1
+module ShouldCompile where
+
+-- !!! Record declarations with zero fields are allowed
+data Foo = Foo{}
hunk ./regress/tests/0_parse/2_pass/ghc/read033.hs 1
+module ShouldCompile where
+
+x = const 1.0e+x where e = 3
hunk ./regress/tests/0_parse/2_pass/ghc/read034.hs 1
+module ShouldCompile where
+
+-- !!! Section precedences
+
+-- infixl 6 +, -
+-- infixr 5 ++, :
+
+f = (++ [] ++ [])
+g = (3 + 4 +)
+
+-- prefix negation is like infixl 6.
+h x = (-x -)
hunk ./regress/tests/0_parse/2_pass/ghc/read036.hs 1
+module ShouldCompile where
+
+f :: Double
+f = 42e42 -- this should be a float
hunk ./regress/tests/0_parse/2_pass/ghc/read037.hs 1
+module ShouldCompile where
+
+-- This file contains several non-breaking space characters,
+-- aka '\xa0'. The compiler should recognise these as whitespace.
+
+f = ( + )
hunk ./regress/tests/0_parse/2_pass/ghc/read038.hs 1
+module ShouldCompile where
+a ---> b = a + a
+foo = 3
+ ---> 4
+ ---> 5
hunk ./regress/tests/0_parse/2_pass/ghc/read039.hs 1
+{-# LANGUAGE ForeignFunctionInterface, CPP #-}
+-- Test the LANGUAGE pragma
+module ShouldCompile where
+
+#if 1
+foreign import ccall "foo" foo :: Int -> IO Int
+#endif
hunk ./regress/tests/0_parse/2_pass/ghc/read040.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- A type signature on the LHS of a do-stmt was a parse
+-- error in 6.4.2, but ok thereafter
+
+module ShouldCompile where
+
+f () = do { x :: Bool <- return True
+ ; return x }
hunk ./regress/tests/0_parse/2_pass/ghc/read042.hs 1
+{-# OPTIONS -XBangPatterns #-}
+
+-- Various bang-pattern and lazy-pattern tests
+
+module ShouldCompile where
+
+main1,main2,main3,main4,main5,main6,main7 :: IO ()
+
+main1 = do
+ !c <- return ()
+ return ()
+
+main2 = return () >>= \ !c -> return ()
+
+main3 = do
+ (!c) <- return ()
+ return ()
+
+main4 = return () >>= \ (!c) -> return ()
+
+main5 = let !x = 1 in return ()
+
+main6 = do
+ ~c <- return ()
+ return ()
+
+main7 = return () >>= \ ~c -> return ()
+
+
hunk ./regress/tests/0_parse/2_pass/ghc/read043.hs 1
+
+{-# OPTIONS -fwarn-tabs #-}
+
+-- Check we get a warning for tabs
+
+module ShouldCompile where
+
+tab1 = 'a'
+notab = 'b'
+tab2 = 'c'
+
hunk ./regress/tests/0_parse/2_pass/ghc/read044.hs 1
+-- test case from #1091
+main =
+ case True of {- | -}
+ True -> putStrLn "Hello World\n"
+ False {- | -} -> putStrLn "Goodbye Cruel World\n"
hunk ./regress/tests/0_parse/2_pass/ghc/read045.hs 1
+{
+main =
+putStr "hello";
+}
hunk ./regress/tests/0_parse/2_pass/ghc/read048.hs 1
+
+{-# OPTIONS_GHC -XEmptyDataDecls #-}
+
+module Foo where
+
+data Foo
+
hunk ./regress/tests/0_parse/2_pass/ghc/read049.hs 1
+
+{-# LANGUAGE EmptyDataDecls #-}
+
+module Foo where
+
+data Foo
+
hunk ./regress/tests/0_parse/2_pass/ghc/read050.hs 1
+
+{-# OPTIONS_GHC -XKindSignatures #-}
+
+module Foo where
+
+data Foo (a :: *) = Foo a
+
hunk ./regress/tests/0_parse/2_pass/ghc/read054.hs 1
+
+{-# OPTIONS_GHC -XParallelListComp #-}
+
+module Foo where
+
+foo = [ ()
+ | () <- foo
+ | () <- foo
+ ]
+
hunk ./regress/tests/0_parse/2_pass/ghc/read056.hs 1
+
+{-# OPTIONS_GHC -XGeneralizedNewtypeDeriving #-}
+
+module Foo where
+
+class C a
+instance C Int
+
+newtype Foo = Foo Int
+ deriving C
+
hunk ./regress/tests/0_parse/2_pass/ghc/read057.hs 1
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Foo where
+
+class C a
+instance C Int
+
+newtype Foo = Foo Int
+ deriving C
+
hunk ./regress/tests/0_parse/2_pass/ghc/read058.hs 1
+
+{-# OPTIONS_GHC -XRecursiveDo #-}
+
+module Foo where
+
+import Control.Monad.Fix
+
+z :: Maybe [Int]
+z = mdo x <- return (1:x)
+ return (take 4 x)
+
hunk ./regress/tests/0_parse/2_pass/ghc/read060.hs 1
+
+{-# OPTIONS_GHC -XFunctionalDependencies #-}
+{-# OPTIONS_GHC -XMultiParamTypeClasses #-}
+
+module Foo where
+
+class Foo a b | a -> b
+
hunk ./regress/tests/0_parse/2_pass/ghc/read061.hs 1
+
+{-# LANGUAGE FunctionalDependencies #-}
+{-# OPTIONS_GHC -XMultiParamTypeClasses #-}
+
+module Foo where
+
+class Foo a b | a -> b
+
hunk ./regress/tests/0_parse/2_pass/ghc/read062.hs 1
+{-# OPTIONS_GHC -XTransformListComp #-}
+
+module Foo where
+
+import List
+import GHC.Exts
+
+foo = [ ()
+ | x <- [1..10]
+ , then take 5
+ , then sortWith by x
+ , then group by x
+ , then group using inits
+ , then group by x using groupWith
+ ]
+
hunk ./regress/tests/0_parse/2_pass/ghc/read064.hs 1
+
+module Foo where
+
+{-# THISISATYPO foo #-}
+foo :: ()
+foo = ()
+
hunk ./regress/tests/0_parse/2_pass/ghc/read066.hs 1
+
+{-# OPTIONS_NO_SUCH_PRAGMA --no-such-flag #-}
+
+-- We should parse the above as an unrecognised pragma, not as an OPTIONS
+-- pragma containing "_NO_SUCH_PRAGMA -wibble". Trac #2847.
+
+module Test where
+
hunk ./regress/tests/0_parse/2_pass/ghc/read067.hs 1
+
+{-# OPTIONS_HUGS --some-hugs-flag #-}
+
+-- We should ignore the above pragma, as we recognise that it is
+-- hugs-specific. We shouldn't even warn about it.
+
+module Test where
+
hunk ./regress/tests/0_parse/2_pass/ghc/read068.hs 1
+-- Test for trac #3079 - parsing fails if a LANGUAGE pragma straddles
+-- a 1024 byte boundary.
+-- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+-- xxxxxxxxxxxxxxxxxxxxxxx
+-- xxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--
+--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--
+--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+--
+--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+import Prelude
+
+main :: IO ()
+main = return ()
+
hunk ./regress/tests/0_parse/2_pass/ghc/read_1821.hs 1
+
+-- Trac #1821
+
+module Par where
+
+f x = x
+ where
+-- ######### x86_64 machine code:
+ g y = y
+ h y = y
[add imported ghc typechecking regression tests
John Meacham <john@repetae.net>**20100811014451
Ignore-this: 7f625abf2f8d562bc76b71396a7e03f0
] adddir ./regress/tests/1_typecheck/2_pass/ghc
addfile ./regress/tests/1_typecheck/2_pass/ghc/T1470.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T1495.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T2045.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T2478.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T2497.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T2572.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T2735.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T2799.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T3219.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T3342.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T3346.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T3409.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/T3955.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/config.yaml
addfile ./regress/tests/1_typecheck/2_pass/ghc/faxen.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/syn-perf.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/syn-perf2.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc001.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc002.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc003.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc004.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc005.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc006.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc007.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc008.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc009.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc010.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc011.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc012.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc013.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc014.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc015.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc016.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc017.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc018.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc019.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc020.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc021.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc022.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc023.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc024.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc025.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc026.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc027.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc028.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc029.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc030.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc031.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc032.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc033.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc034.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc035.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc036.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc037.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc038.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc039.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc040.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc041.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc042.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc043.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc044.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc045.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc046.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc047.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc048.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc049.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc050.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc051.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc052.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc053.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc054.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc055.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc056.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc057.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc058.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc059.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc060.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc061.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc062.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc063.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc064.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc065.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc066.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc067.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc068.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc069.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc070.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc073.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc074.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc076.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc077.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc078.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc079.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc080.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc081.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc082.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc084.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc086.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc087.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc088.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc089.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc090.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc091.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc092.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc093.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc094.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc095.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc096.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc097.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc098.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc099.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc100.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc101.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc102.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc104.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc105.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc106.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc107.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc108.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc109.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc111.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc112.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc113.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc114.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc115.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc116.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc117.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc118.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc119.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc120.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc124.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc125.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc126.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc128.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc131.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc132.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc133.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc134.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc135.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc136.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc137.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc140.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc141.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc142.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc143.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc146.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc147.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc148.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc149.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc150.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc151.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc152.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc153.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc154.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc155.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc156.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc157.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc158.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc159.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc160.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc161.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc162.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc163.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc165.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc166.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc168.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc169.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc171.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc172.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc174.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc175.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc176.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc177.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc178.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc179.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc180.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc181.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc182.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/tc183.hs
adddir ./regress/tests/1_typecheck/2_pass/ghc/uncat
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/config.yaml
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc184.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc185.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc186.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc187.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc188.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc189.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc190.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc191.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc192.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc193.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc194.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc195.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc196.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc197.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc198.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc199.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc200.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc201.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc202.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc203.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc204.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc205.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc206.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc207.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc208.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc209.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc210.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc211.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc212.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc213.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc214.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc215.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc216.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc217.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc218.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc219.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc220.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc221.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc222.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc223.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc224.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc225.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc226.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc227.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc228.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc229.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc230.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc231.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc232.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc233.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc234.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc235.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc236.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc237.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc238.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc240.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc241.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc242.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc243.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc244.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc246.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc247.hs
addfile ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc248.hs
hunk ./regress/tests/1_typecheck/2_pass/ghc/T1470.hs 1
+{-# 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]
+instance Foo [Char]
hunk ./regress/tests/1_typecheck/2_pass/ghc/T1495.hs 1
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/T2045.hs 1
+{-# 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]
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/T2478.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+module ShouldCompile where
+
+ data Eq t => TrafoE t = forall env2 . TrafoE Int t
+
+ newSRef () = TrafoE
hunk ./regress/tests/1_typecheck/2_pass/ghc/T2497.hs 1
+{-# 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
+ #-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/T2572.hs 1
+ {-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
+
+-- Trac #2572
+
+module Foo where
+
+type GTypeFun = forall a . a -> ()
+
+gmapType :: Int -> GTypeFun
+gmapType _ (_ :: a) = undefined
hunk ./regress/tests/1_typecheck/2_pass/ghc/T2735.hs 1
+-- Trac #2735
+
+module Bug where
+
+data S = S { s1 :: (), s2 :: () }
+
+f s = s { s1 = (), s2 = s1 s }
hunk ./regress/tests/1_typecheck/2_pass/ghc/T2799.hs 1
+{-# 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/T3219.hs 1
+-- 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}
hunk ./regress/tests/1_typecheck/2_pass/ghc/T3342.hs 1
+{-# 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/T3346.hs 1
+{-# 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/T3409.hs 1
+{-# 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"
hunk ./regress/tests/1_typecheck/2_pass/ghc/T3955.hs 1
+{-# 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.
+-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/config.yaml 1
+tests:
+ T3219:
+ skip: known_bug
+
+ T1470:
+ skip: MultiParamTypeClasses
+ T2572:
+ skip: ScopedTypeVars
+ T2799:
+ skip: GADTs
+ T3346:
+ skip: TypeFamilies
+ T3955:
+ skip: GNTD
+ syn-perf:
+ skip: InfixTypes
+ tc092:
+ skip: known_bug
+ tc095:
+ skip: known_bug
+ tc102:
+ skip: ScopedTypeVars
+ tc105:
+ skip: ST
+ tc106:
+ skip: MPTC
+ tc108:
+ skip: MPTC
+ tc112:
+ skip: FunDeps
+ tc114:
+ skip: FunDeps
+ tc115:
+ skip: FunDeps
+ tc116:
+ skip: FunDeps
+ tc117:
+ skip: FunDeps
+ tc118:
+ skip: FunDeps
+ tc125:
+ skip: FunDeps
+ tc126:
+ skip: FunDeps
+ tc132:
+ skip: ST
+ tc133:
+ skip: Scoped
+ tc134:
+ skip: Scoped
+ tc136:
+ skip: Scoped
+ tc137:
+ skip: FunDeps
+ tc141:
+ skip: FunDeps
+ tc148:
+ skip: known_bug
+ tc152:
+ skip: FunDeps
+ tc156:
+ skip: InfixTypes
+ tc166:
+ skip: FunDeps
+ tc168:
+ skip: FunDeps
+ tc175:
+ skip: known_bug
+ tc177:
+ skip: FunDeps
+ tc179:
+ skip: OverlappingInstances
+ tc180:
+ skip: FunDeps
+ tc181:
+ skip: FunDeps
+ tc183:
+ skip: known_bug
+ T3342:
+ skip: ViewPatterns
+ tc109:
+ skip: FunDeps
+ tc119:
+ skip: FunDeps
+ tc131:
+ skip: FunDeps
+ tc135:
+ skip: Scoped
+ tc174:
+ skip: known_bug
+ tc178:
+ skip: known_bug
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/faxen.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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)
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/syn-perf.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+-- 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)
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/syn-perf2.hs 1
+-- 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
+ ))))))))
+ ))))))))
+ ))))))))
+ ))))))))
+ ))))))))
+ ))))))))
+ ))))))))
+ ))))))))
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc001.hs 1
+module ShouldSucceed where
+
+a x = y+2 where y = x+3
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc002.hs 1
+module ShouldSucceed where
+
+b = if True then 1 else 2
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc003.hs 1
+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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc004.hs 1
+module ShouldSucceed where
+
+f x = case x of
+ True -> True
+ False -> x
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc005.hs 1
+module ShouldSucceed where
+
+g ((x:z),y) = x
+g (x,y) = 2
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc006.hs 1
+module ShouldSucceed where
+
+h = 1:h
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc007.hs 1
+module ShouldSucceed where
+
+j = 2
+
+k = 1:j:l
+
+l = 0:k
+
+m = j+j
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc008.hs 1
+module ShouldSucceed where
+
+n True = 1
+n False = 0
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc009.hs 1
+module ShouldSucceed where
+
+o (True,x) = x
+o (False,y) = y+1
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc010.hs 1
+module ShouldSucceed where
+
+p = [(y+2,True) | y <- [1,2]]
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc011.hs 1
+module ShouldSucceed where
+
+x@_ = x
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc012.hs 1
+module ShouldSucceed where
+
+q = \ y -> y
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc013.hs 1
+module ShouldSucceed where
+
+(r,s) = (1,'a')
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc014.hs 1
+module ShouldSucceed where
+
+t = 1+t
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc015.hs 1
+module ShouldSucceed where
+
+u x = \ (y,z) -> x
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc016.hs 1
+module ShouldSucceed where
+
+f x@_ y@_ = x
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc017.hs 1
+module ShouldSucceed where
+
+v | True = v+1
+ | False = v
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc018.hs 1
+module ShouldSucceed where
+
+w = a where a = y
+ y = 2
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc019.hs 1
+module ShouldSucceed where
+
+(al:am) = [y+1 | (y,z) <- [(1,2)]]
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc020.hs 1
+module ShouldSucceed where
+
+f x = a where a = x:a
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc021.hs 1
+module ShouldSucceed where
+
+f x = a
+
+a = (x,x)
+
+x = x
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc022.hs 1
+module ShouldSucceed where
+
+main = iD iD
+
+iD x = x
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc023.hs 1
+module ShouldSucceed where
+
+main = s k k
+
+s f g x = f x (g x)
+
+k x y = x
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc024.hs 1
+module ShouldSucceed where
+
+main x = s k k x
+
+s f g x = f x (g x)
+
+k x y = x
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc025.hs 1
+module ShouldSucceed where
+
+g x = f (f True x) x where f x y = if x then y else (f x y)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc026.hs 1
+module ShouldSucceed where
+
+g x = f (f True x) x
+f x y = if x then y else (f x y)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc027.hs 1
+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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc028.hs 1
+module ShouldSucceed where
+
+type H = (Int,Bool)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc029.hs 1
+module ShouldSucceed where
+
+type G = [Int]
+
+data K = H Bool | M G
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc030.hs 1
+module ShouldSucceed where
+
+type H = [Bool]
+
+type G = (H,Char)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc031.hs 1
+module ShouldSucceed where
+
+data Rec = Node Int Rec
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc032.hs 1
+module ShouldSucceed where
+
+data AList b = Node b [b] | Other (b,Char)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc033.hs 1
+module ShouldSucceed where
+
+data Twine = Twine2 Twist
+
+data Twist = Twist2 Twine
+
+type F = Twine
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc034.hs 1
+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
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc035.hs 1
+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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc036.hs 1
+module ShouldSucceed where
+
+class (Eq a) => A a where
+ op1 :: a -> a
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc037.hs 1
+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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc038.hs 1
+module ShouldSucceed where
+
+f (x:xs) = if (x == (fromInteger 2)) then xs else []
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc039.hs 1
+module ShouldSucceed where
+
+class (Eq a) => A a where
+ op1 :: a -> a
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc040.hs 1
+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]
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc041.hs 1
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc042.hs 1
+-- !!! 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)
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc043.hs 1
+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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc044.hs 1
+-- once produced a bug, here as regression test
+
+module ShouldSucceed where
+
+f _ | otherwise = ()
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc045.hs 1
+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
+-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc046.hs 1
+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" -}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc047.hs 1
+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
+
+
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc048.hs 1
+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
+
+
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc049.hs 1
+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]]
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc050.hs 1
+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
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc051.hs 1
+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]
+-}
+
+
+
+
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc052.hs 1
+module ShouldSucceed where
+
+type A a = B a
+
+type B c = C
+
+type C = Int
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc053.hs 1
+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]
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc054.hs 1
+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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc055.hs 1
+module ShouldSucceed where
+
+(x,y) = (\p -> p,\q -> q)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc056.hs 1
+-- !!! 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]
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc057.hs 1
+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])
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc058.hs 1
+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]
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc059.hs 1
+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]
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc060.hs 1
+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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc061.hs 1
+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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc062.hs 1
+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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc063.hs 1
+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
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc064.hs 1
+module ShouldSucceed where
+
+data Boolean = FF | TT
+
+idb :: Boolean -> Boolean
+idb x = x
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc065.hs 1
+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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc066.hs 1
+module ShouldSucceed where
+
+data Pair a b = MkPair a b
+f x = [ a | (MkPair c a) <- x ]
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc067.hs 1
+module ShouldSucceed where
+
+f [] = []
+f (x:xs) = x : (f xs)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc068.hs 1
+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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc069.hs 1
+module ShouldSucceed where
+
+x = 'a'
+(y:ys) = ['a','b','c'] where p = x
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc070.hs 1
+module ShouldSucceed where
+
+
+data Boolean = FF | TT
+
+
+idb :: Boolean -> Boolean
+idb x = x
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc073.hs 1
+
+module ShouldSucceed where
+
+f [] = []
+f (x:xs) = x : (f xs)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc074.hs 1
+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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc076.hs 1
+-- !!! 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]
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc077.hs 1
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc078.hs 1
+-- !!! 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc079.hs 1
+-- !!! 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 {}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc080.hs 1
+--module Parse(Parse(..),whiteSpace,seperatedBy) where
+--import StdLib
+module ShouldSucceed where
+
+import 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')
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc081.hs 1
+-- !!! 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 = (\ y -> if x>2 then [] else [y])::(a -> [a])
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc082.hs 1
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc084.hs 1
+{- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc086.hs 1
+{-
+ 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc087.hs 1
+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"
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc088.hs 1
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc089.hs 1
+-- !!! Stress test for type checker
+
+module ShouldSucceed where
+
+import Prelude hiding (head)
+
+one = one
+
+head (x:xs) = x
+
+bottom = head
+
+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])
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc090.hs 1
+{- 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
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc091.hs 1
+-- !!! 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)
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc092.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+-- -fglasgow-exts because it uses local universal quantification
+
+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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc093.hs 1
+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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc094.hs 1
+module ShouldSucceed where
+
+-- From a bug report by Sven Panne.
+
+foo = bar
+ where bar = \_ -> (truncate boing, truncate boing)
+ boing = 0
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc095.hs 1
+{-
+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.
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc096.hs 1
+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
+-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc097.hs 1
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc098.hs 1
+-- !!! 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.
+-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc099.hs 1
+-- !! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc100.hs 1
+-- !!! 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc101.hs 1
+-- !!! 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc102.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc104.hs 1
+-- !!! Checking that Main.main's type can now be of the form (IO a)
+module Main(main) where
+
+main = putStrLn "Hello" >> return (id)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc105.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc106.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc107.hs 1
+-- !!! 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc108.hs 1
+-- !!! 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
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc109.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE 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. -}
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc111.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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
+ #-}
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc112.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc113.hs 1
+-- !!! 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')
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc114.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc115.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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 = []
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc116.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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 = []
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc117.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# LANGUAGE 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc118.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE 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)
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc119.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc120.hs 1
+-- !!! 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"
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc124.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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 }
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc125.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# LANGUAGE 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc126.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# LANGUAGE 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc128.hs 1
+-- !!! 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc131.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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))
+
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc132.hs 1
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc133.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc134.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc135.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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]
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc136.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc137.hs 1
+{-# OPTIONS -fglasgow-exts -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 ([] ++ [[]] ++ [])
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc140.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc141.hs 1
-
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc142.hs 1
+-- !!! 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc143.hs 1
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc146.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc147.hs 1
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc148.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc149.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+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)
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc150.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+module ShouldCompile where
+
+f v = (\ (x :: forall a. a->a) -> x) id 'c'
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc151.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc152.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# LANGUAGE 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc153.hs 1
+-- No -fglasgow-exts, 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc154.hs 1
+-- 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 () = ()
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc155.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- The type sig for 'test' is illegal in H98 because of the
+-- partial application of the type sig.
+-- But with -fglasgow-exts 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc156.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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'
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc157.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc158.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc159.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- Don't do the cunning new newtype-deriving thing
+-- when the type constructor is recursive
+
+module ShouldCompile where
+
+newtype A = A [A] deriving (Eq)
+
+test :: A -> A -> Bool
+test x y = x == y
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc160.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+--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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc161.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc162.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+
+-- 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
+
+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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc163.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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)))))
+ )
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc165.hs 1
+{-# OPTIONS -dcore-lint -fglasgow-exts #-}
+
+-- 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc166.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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)
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc168.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc169.hs 1
+-- 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc171.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- Data types with no constructors
+
+module ShouldCompile where
+
+data S
+data T a
+
+f :: [T a] -> Int
+f xs = length xs
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc172.hs 1
+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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc174.hs 1
+{-# OPTIONS_JHC -funboxed-tuples #-}
+
+module ShouldCompile where
+
+f x = (# x, x #) :: (# Int, Int #)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc175.hs 1
+-- 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc176.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc177.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc178.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc179.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE 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.
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc180.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE 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])
+
+
+-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc181.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE 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"
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc182.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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"
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/tc183.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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"
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/config.yaml 1
+skip: uncategorized
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc184.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc185.hs 1
-
+{-# OPTIONS -fglasgow-exts #-}
+
+-- Killed GHC 6.3 HEAD
+
+module Bug where
+import GHC.Base
+
+foo v = let !(I# x#) = 7 * 7 in "Forty-Two"
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc186.hs 1
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc187.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# LANGUAGE UndecidableInstances #-}
+-- 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))
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc188.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc189.hs 1
+{-# 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc190.hs 1
+{-# OPTIONS -cpp -fglasgow-exts #-}
+
+-- 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}
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc191.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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)
+
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc192.hs 1
+{-# OPTIONS -fglasgow-exts -cpp #-}
+{-# LANGUAGE Arrows #-}
+
+-- Test infix type notation and arrow notation
+
+module Test where
+
+#if __GLASGOW_HASKELL__ > 608
+import Prelude hiding (id,(.))
+import Control.Category
+#endif
+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 = (,)
+
+-- 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
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc193.hs 1
+
+-- 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
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc194.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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')
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc195.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
+
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc196.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc197.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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)
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc198.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc199.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc200.hs 1
+{-# OPTIONS -w -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc201.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+{- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc202.hs 1
+
+-- 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc203.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc204.hs 1
+{-# OPTIONS -fglasgow-exts -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"
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc205.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+-- 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc206.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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 (++)
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc207.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc208.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE ImplicitParams #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc209.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc210.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+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 ]
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc211.hs 1
+{-# 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)
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc212.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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 #-}
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc213.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+-- 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] )
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc214.hs 1
+{-# 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 _) = ()
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc215.hs 1
+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fglasgow-exts #-}
+
+-- 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 = ' '
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc216.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- Test for trac #816
+-- GHC's typechecker loops when trying to type this, resulting in a
+-- context stack overflow.
+
+module ShouldCompile where
+
+class Foo x y | x -> y where
+ foo :: x -> y
+
+class Bar x y where
+ bar :: x -> y -> Int
+
+instance (Foo x y, Bar y z) => Bar x z where
+ bar x z = bar (foo x) z
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc217.hs 1
+{-# OPTIONS_GHC -fglasgow-exts -w #-}
+{-# LANGUAGE 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 exmaple 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc218.hs 1
+{-# 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
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc219.hs 1
+{-# 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc220.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+-- 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
+
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc221.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc222.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE ImplicitParams #-}
+
+-- 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
+
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc223.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+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)
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc224.hs 1
+{-# 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc225.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- Newtype in GADT syntax
+
+module ShouldCompile where
+
+newtype Bug a where Bug :: a -> Bug a
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc226.hs 1
+{-# OPTIONS_GHC -funbox-strict-fields -fglasgow-exts #-}
+
+-- 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 }
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc227.hs 1
+-- Ensure that tuple instances are brought into scope
+-- See Trac #1385
+
+module ShouldCompile where
+
+foo = (1,True) == (2,False)
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc228.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc229.hs 1
+
+-- trac #1406: Constraint doesn't reduce in the presence of quantified
+-- type variables
+
+{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc230.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+-- Trac #1445
+
+module Bug where
+
+f :: () -> (?p :: ()) => () -> ()
+f _ _ = ()
+
+g :: (?p :: ()) => ()
+g = f () ()
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc231.hs 1
+{-# OPTIONS_GHC -fglasgow-exts -ddump-types #-}
+
+-- 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)
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc232.hs 1
+
+-- 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 }
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc233.hs 1
+
+{-# OPTIONS_GHC -XPolymorphicComponents #-}
+
+module ShouldCompile where
+
+newtype Swizzle = MkSwizzle (forall a. Ord a => [a] -> [a])
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc234.hs 1
+
+{-# OPTIONS_GHC -XLiberalTypeSynonyms #-}
+
+module ShouldCompile where
+
+type T a b = a
+type S m = m ()
+
+f :: S (T Int)
+f = undefined
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc235.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- 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 ()
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc236.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+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
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc237.hs 1
+{-# 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'
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc238.hs 1
+-- 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)
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc240.hs 1
-
+-- Checks that the types of the old binder and the binder implicitly introduced by \
grouping are linked +
+{-# OPTIONS_GHC -XTransformListComp #-}
+
+module ShouldCompile where
+
+import List(inits)
+
+foo :: [[[Int]]]
+foo = [ x
+ | x <- [1..10]
+ , then group using inits
+ , then group using inits
+ ]
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc241.hs 1
+{-# 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 ()
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc242.hs 1
+{-# 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"
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc243.hs 1
+
+{-# 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
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc244.hs 1
+{-# 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 }
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc246.hs 1
+-- Test for trac #3066
+-- GHC with optimisation off would go into an infinite loop
+
+module Tc246 () where
+
+newtype Foo = Foo Foo
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc247.hs 1
+{-# 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
+
+
hunk ./regress/tests/1_typecheck/2_pass/ghc/uncat/tc248.hs 1
+{-# LANGUAGE ExplicitForAll #-}
+
+module ShouldCompile where
+
+identity :: forall a. a -> a
+identity x = x
[improve Grin Linting a little
John Meacham <john@repetae.net>**20100812054446
Ignore-this: c7613a94c296e089a985904aa049d002
] hunk ./src/Grin/Lint.hs 290
return [TyINode]
f (Error _ t) = return t
f e@(BaseOp Overwrite [w,v]) = do
+ NodeC {} <- return v
+ tcVal w
+ tcVal v
return []
f e@(BaseOp PokeVal [w,v]) = do
hunk ./src/Grin/Lint.hs 295
+ TyPtr t <- tcVal w
+ tv <- tcVal v
+ when (t /= tv) $
+ fail "PokeVal: types don't match"
return []
f e@(BaseOp PeekVal [w]) = do
TyPtr t <- tcVal w
Context:
[add 'skip' to regression options to skip certain tests
John Meacham <john@repetae.net>**20100811002445
Ignore-this: 261b5e51fa22d7af25989ee078853590
]
[allow unicode characters in haskell source
John Meacham <john@repetae.net>**20100810233304
Ignore-this: dd54c632455bd0660ff7b5170d81c8ed
]
[add regex-compat to dependencies
John Meacham <john@repetae.net>**20100810230216
Ignore-this: e7c03b8e187802ab75dbcc574614eabc
]
[accept empty class contexts
John Meacham <john@repetae.net>**20100810063832
Ignore-this: 9dea1ec61b874fcb3537b79b74b345df
]
[add 'transformers' package to included libraries
John Meacham <john@repetae.net>**20100810054906
Ignore-this: e27f376331b3fac2e3414145bf17a1c0
]
[fix desugaring of irrefutable lambda bindings
John Meacham <john@repetae.net>**20100810053944
Ignore-this: 5c70934cbe42169850481562cd5b20f3
]
[add some strictness annotations
John Meacham <john@repetae.net>**20100810053827
Ignore-this: 15ed2e2fc90656cc418a841848e43107
]
[clean ups
John Meacham <john@repetae.net>**20100806112820
Ignore-this: 64c0ae0922073b65fc0dac4bd35ba968
]
[speed up name choosing a little
John Meacham <john@repetae.net>**20100806111703
Ignore-this: ac159eeb0d34a7d26ad74253d00386ae
]
[further seperate out concrete types to speed up checking
John Meacham <john@repetae.net>**20100806092815
Ignore-this: f992ced583042d3c7797d4de93e3e3a8
]
[split type environment into concrete and mutable sets, to avoid retraversing the \
concrete imported types John Meacham <john@repetae.net>**20100806090349
Ignore-this: c276618b4b968d9149e6b3dfc36d162a
]
[create a better relation representation, speed up export chasing signifigantly
John Meacham <john@repetae.net>**20100806082622
Ignore-this: 9f49871e33348bbfc4e8fd2ee9fa71b8
]
[fix a few minor bugs in libraries found by better error reporting
John Meacham <john@repetae.net>**20100806045809
Ignore-this: e7d43927c9e11b05de455a5d0ebd1017
]
[check export lists for unknown names
John Meacham <john@repetae.net>**20100806045759
Ignore-this: 4b3ff8381117f2acae34dd6b936c8e8d
]
[ret rid of seperate subtable and errortable in favor of unified namemap
John Meacham <john@repetae.net>**20100806032455
Ignore-this: 9e8fbd31f988d77614bd49fc23cefae
]
[treat () the same as tuples when renaming
John Meacham <john@repetae.net>**20100806023948
Ignore-this: defa66a11f1081a4582a5301cff217e4
]
[move selector creation from desugar to renamer, detect multiply defined top level \
values and report an error properly. John Meacham <john@repetae.net>**20100806021241
Ignore-this: 507bce69ec8ffe0085c3a72ffc0ec571
]
[add initial version of jhc-prim
John Meacham <john@repetae.net>**20100806000900
Ignore-this: 44a9f14db168b28d731fd750bba0fee9
]
[clean up preprocessing a little
John Meacham <john@repetae.net>**20100803073754
Ignore-this: c1064468bed864231c2d5fb3a68bbeaf
]
[utilize preprocessor rather than ./configure to handle System.Info
John Meacham <john@repetae.net>**20100802100036
Ignore-this: 76681affa5b0269621974deeccda019b
]
[fix some warnings
John Meacham <john@repetae.net>**20100801083507
Ignore-this: fd350fd02d0ad5a611ee1811de28bce5
]
[fix build problem for tarball
John Meacham <john@repetae.net>**20100801082137
Ignore-this: 33671b52398eef61afa670eb031ef575
]
[update strictness and UNPACK annotations
John Meacham <john@repetae.net>**20100801080035
Ignore-this: e598a6098143c1a62373a443865b3cfb
]
[add announcement for 0.7.6
John Meacham <john@repetae.net>**20100731111353
Ignore-this: 111c27548d94bdfe0042d61b02fe5728
]
[TAG 0.7.6
John Meacham <john@repetae.net>**20100731104908
Ignore-this: d5edc6edd6d300cbae451f0e056ee018
]
Patch bundle hash:
3183ab1713e4cf8ef5b658d2b7577e62847e587e
_______________________________________________
jhc mailing list
jhc@haskell.org
http://www.haskell.org/mailman/listinfo/jhc
.
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic