{-#OPTIONS_GHC -Wpartial-fields #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}

module T7196 where

data T a = A
  { m1  :: a
  , m2  :: a
  , _m3 :: a
  } | B
  {
    m1 :: a
  }

pattern P{x} = x

data family F a
data instance F a where
  F1 :: { f1 :: Int } -> F Int
  F2 :: { f2 :: Int } -> F Char


{-# LANGUAGE FunctionalDependencies #-}  {-# LANGUAGE FlexibleInstances #-}

module T7171 where

import T7171a
import Data.ByteString

-- this works
-- test1 :: [Int] -> [Int]
-- test1 = test

-- this fails
test2 :: ByteString -> ByteString
test2 = test


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE FunctionalDependencies #-}  {-# LANGUAGE FlexibleInstances #-}

module T7171a where

import Data.ByteString as B
import Data.Word

class Foo a b | a -> b

class (Foo a b) => Bar a b | a -> b

instance Foo [a] a
instance Bar [a] a
instance Foo ByteString Word8
instance Bar ByteString Word8

test :: Bar full item => full -> full
test inp = inp


module T7173 where

-- se and sb are mutually recursive
--   se takes a numeric parameter (which it ignores)
--   sb passes it a constant 10
--
-- so sb :: Num a => ...type not involving a...
--
-- So the ambiguity check must default ambiguous p,
-- rather than complaining that sb is ambiguous.

showEnv' env t = se 10 env t
 where
   se p env (Bind n b sc) = sb env n b
   sb env n t             = se 10 env t

data TT n = Bind n (TT n) (TT n)


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}

module Patch (qc_prim) where

import Data.Kind (Type)

class PrimPatch (prim :: Type -> Type -> Type)

class PrimPatch (PrimOf p) => PrimPatchBase p where
    type PrimOf (p :: Type -> Type -> Type) :: Type -> Type -> Type

type TestGenerator thing gen = (forall t ctx . (forall xx yy . thing xx yy -> t) -> (gen ctx -> t))

type family ModelOf (patch :: Type -> Type -> Type) :: Type -> Type

data WithState s p x y = WithState {
                              _wsStartState :: s x
                            , _wsPatch      :: p x y
                            , _wsEndState   :: s y
                            }

arbitraryThing :: x -> TestGenerator thing (thing x)
arbitraryThing _ f p = f p

qc_prim :: forall prim x y .
           (PrimPatch prim
           , PrimOf prim ~ prim
           ) => prim x y -> [()]
qc_prim _ =
  concat
  [
   patch_repo_properties      (undefined :: prim x a)    "arbitrary"    arbitraryThing'
  ]
      where arbitraryThing' = arbitraryThing (undefined :: a)

patch_repo_properties :: p x y -> String -> TestGenerator (WithState (ModelOf (PrimOf p)) p) gen -> [()]
patch_repo_properties _ _genname _gen = undefined


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test2 where

class C a b | b -> a

data A = A
data X a = X
data Y = Y

type family TF b

f :: (forall b. (C a b, TF b ~ Y) => b) -> X a
f _ = undefined

u :: (C A b, TF b ~ Y) => b
u = undefined

v :: X A
v = (f :: (forall b. (C A b, TF b ~ Y) => b) -> X A) u -- This line causes an error (see below)

{-
GHC 7.6.1-rc1 (7.6.0.20120810) rejects this code with the following error message.

Test2.hs:24:52:
    Couldn't match expected type `Y'
                with actual type `TF (forall b. (C A b, TF b ~ Y) => b)'
    In the first argument of `f ::
                                (forall b. (C A b, TF b ~ Y) => b) -> X', namely
      `u'
    In the expression: (f :: (forall b. (C A b, TF b ~ Y) => b) -> X) u
    In an equation for `v':
        v = (f :: (forall b. (C A b, TF b ~ Y) => b) -> X) u

GHC 7.4.1 rejected this code with a different error message:

Test2.hs:24:6:
    Cannot deal with a type function under a forall type:
    forall b. (C A b, TF b ~ Y) => b
    In the expression: f :: (forall b. (C A b, TF b ~ Y) => b) -> X
    In the expression: (f :: (forall b. (C A b, TF b ~ Y) => b) -> X) u
    In an equation for `v':
        v = (f :: (forall b. (C A b, TF b ~ Y) => b) -> X) u
-}


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}

module T7220a where

class C a b | b -> a

data X = X
data Y = Y

type family TF b

f :: (forall b. (C a b, TF b ~ Y) => b) -> X
-- This type is really ambiguous
-- GHC 7.8 didn't detect that, and accepted the type, but would fail
-- when given    g :: <the same type>
--               g x = f x
-- But it would succeed if you said just
--               g = f
-- Now we fail in all ways!

f _ = undefined


{-# LANGUAGE MonoLocalBinds, NoMonomorphismRestriction, RankNTypes #-}
module T7268 where

data X = X { a :: forall a . a -> Bool }

ida :: forall b. b -> Bool
X { a = ida } = error "urk"

bar :: c -> Bool
bar = ida


module T7312 where

-- this works
mac :: Double -> (Double->Double) -> (Double-> Double)
mac ac m = \ x -> ac + x * m x

-- this doesn't
mac2 :: Double -> (->) Double Double -> (->) Double Double
mac2 ac m = \ x -> ac + x * m x


{-# LANGUAGE FunctionalDependencies, PolyKinds #-}

module T7384 where

class Baz a b | a -> b where
   bar :: a -> ()

instance Baz Bool Bool where
   bar _ = ()

foo = bar False


{-# OPTIONS_GHC -Wall -Werror#-}
module T7408 (Context, mkContext) where
import Foreign

newtype Context = Context (Ptr ())
foreign import ccall mkContext :: IO Context


module T6117a where

-- Tests that Lint does not complain about
-- a mis-match between * and Constraint

class B a where
     b :: a

newtype Additive a = Additive a

instance B a => B (Additive a) where
    b = Additive b


{-# LANGUAGE ExistentialQuantification, DataKinds, PolyKinds, KindSignatures, GADTs #-}
module T7503a where
    import Data.Kind
    import GHC.Exts hiding (Any)

    data WrappedType = forall a. WrapType a

    data A :: WrappedType -> Type where
        MkA :: forall (a :: Type). AW a -> A (WrapType a)

    type AW  (a :: k) = A (WrapType a)
    type AW' (a :: k) = A (WrapType a)

    class C (a :: k) where
        aw :: AW a -- workaround: AW'

    instance C [] where
        aw = aw


{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
{-# LANGUAGE FlexibleContexts, Rank2Types #-}

module Test where

type Constrained x y r = (Eq x, Eq y) => x -> y -> r

f :: Constrained String String ()
-- Weird test case: (Eq String, Eq String) is simplifiable
f = undefined


module T7562 where

data Pair2 = Pair2 {-# UNPACK #-} Int


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module T7641 where

data Foo b = Foo deriving Show

class ToFoo a b where
    toFoo :: a -> Foo b

instance ToFoo (c -> ()) b where
    toFoo _ = Foo

baz () = toFoo $ \_ -> ()


{-# LANGUAGE MagicHash, TypeFamilies #-}

module T7643 where

import GHC.Exts

type family T
type instance T = RealWorld

foo :: () -> State# T
foo _ = unsafeCoerce# realWorld#


{-# LANGUAGE ScopedTypeVariables #-}
module T7827 where

bug :: a -> ()
bug ((_ :: a) :: a) = ()


{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
{-# LANGUAGE
     FlexibleContexts
   , FlexibleInstances
   , FunctionalDependencies
   , MultiParamTypeClasses
   , KindSignatures
   , UndecidableInstances #-}

module T7875 where

import Data.Kind (Type)

class Het a b | a -> b where
  het :: m (f c) -> a -> m b

class GHet (a :: Type -> Type) (b :: Type -> Type) | a -> b
instance            GHet (K a) (K [a])
instance Het a b => GHet (K a) (K b)

data A a   = A (A a)
data K x a = K x

instance Het (A a) (A [a]) where het = het1

het1 :: (GHet (K a) (K b)) => m (f c) -> a -> m b
-- Weird test case: (GHet (K a) (K b)) is simplifiable
het1 = undefined

{- Wanted
     (GHet (K (A a)) (K (A [a])))

-- Fundeps give ([A a] ~ A [a])
-}


{-# LANGUAGE RankNTypes, MagicHash #-}

module T7888 where
import GHC.Err( undefined )
import GHC.Prim

{- The fix for #11431 makes this no longer work. But it shouldn't really,
without impredicativity.
f :: (forall a. a) -> b
f = undefined
-}

-- this still had better work, though!
g :: Int -> Int#
g _ = undefined


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -O #-}    -- -O casused a Lint error in the simplifier, so I'm putting that in
                          -- all the time, so we don't miss it in a fast validate

module T7891 where

import Data.Kind (Type)

newtype T = T (forall t. t -> t)

tf :: T
tf = T id

-- Can't write this type signature:
f :: t -> t
T f = tf

-- But with an indirection we can:
g :: t -> t
g = f

-- We can still use f as it were fully polymorphic (which is good):
a :: ()
a = f ()
b :: Char
b = f 'b'

-------------

class C t where
  data F t :: Type
  mkF :: t -> F t

instance C () where
  data F () = FUnit (forall t. t -> t)
  mkF () = FUnit id

-- Can't write a type for f here either:
k :: t -> t
FUnit k = mkF ()


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE KindSignatures #-}

module T7903 where

import Data.Kind (Type)

instance Eq (((->) a :: Type -> Type) b)
instance (Ord b) => Ord (((->) a) b)


{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances, AllowAmbiguousTypes #-}

module T8392 where

class Fun f a b where
    fun :: f -> a -> b

instance (b ~ Int, a ~ Int) => Fun F a b
    where fun _ = (+1)

data F = F

data Compose a b = Compose a b

-- ghc-7.6 version
instance (Fun f b c, Fun g a b) => Fun (Compose f g) a c where
    fun (Compose f g) a = fun f (fun g a :: b)


{-# LANGUAGE ImplicitParams #-}
module T8474 where

data D = D Int deriving Show

-- In 7.7 this took exponential time!
slow_to_compile :: IO ()
slow_to_compile = do
  tst1 <- return 1

  let ?tst1 = tst1
{-
  let ?tst2 = tst1
  let ?tst3 = tst1
  let ?tst4 = tst1
  let ?tst5 = tst1
  let ?tst6 = tst1
  let ?tst7 = tst1
-}

  print $ D ?tst1


{-# LANGUAGE FlexibleContexts #-}

module T8555 where
import Data.Coerce

foo :: Coercible [a] [b] => a -> b
foo = coerce


{-# LANGUAGE PolyKinds #-}
module Tagged where

newtype Tagged s b = Tagged b deriving Eq


{-# LANGUAGE RankNTypes, GeneralizedNewtypeDeriving, ImpredicativeTypes #-}
module Foo where

class C a where op :: (forall b. b -> a) -> a

newtype T x = MkT x deriving( C )


{-# LANGUAGE ConstraintKinds, RankNTypes, GADTs #-}
module T8644 where

data Dict c where Dict :: c => Dict c

foo :: Dict c -> (c => r) -> r
foo Dict x = x

bar :: Dict ()
bar = Dict


{-# LANGUAGE MagicHash #-}
module Main where
import GHC.Exts

go :: () -> Int#
go () = 0#

main = print (I# (go $ ()))


{-# LANGUAGE UnboxedTuples #-}
module T8762 where

type Ty a = Int

bug :: Ty a -> (# Ty a, () #)
bug ty = (# ty, () #)

foo = let (# a, b #) = bug undefined
      in ()


{-# LANGUAGE FlexibleContexts #-}

module T8555 where
import Data.Coerce

foo :: Coercible a b => b -> a
foo = coerce

bar :: (Coercible a b, Coercible b c) => b -> c -> a
bar b c = coerce c


{-# LANGUAGE ScopedTypeVariables, RankNTypes, PolyKinds #-}
module T8856 where

import Data.Proxy

foo = (undefined :: Proxy a) :: forall a. Proxy a


{-# LANGUAGE RoleAnnotations #-}

-- Also see Note [Order of Coercible Instances]

module T9117 where

import Data.Coerce

newtype Phant a = MkPhant Char
type role Phant representational

ex1 :: Phant Bool
ex1 = coerce (MkPhant 'x' :: Phant Int)


module T9117_2 where

import Data.Coerce

newtype Foo a = Foo (Foo a)
newtype Age = MkAge Int

ex1 :: (Foo Age) -> (Foo Int)
ex1 = coerce


module T9117_3 where

import Data.Type.Coercion
import Data.Coerce

eta :: Coercible f g => Coercion (f a) (g a)
eta = Coercion


{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, UndecidableInstances #-}

module T9151 where

import Data.Proxy

class PEnum (kproxy :: KProxy a) where
  type ToEnum (x :: a) :: Bool
  type ToEnum x = TEHelper

type TEHelper = ToEnum Int


{-# LANGUAGE UnboxedTuples #-}

module T9404 where

foo _ = case seq () (# #) of (# #) -> ()
foo2 _ = case () `seq` (# #) of (# #) -> ()


{-# LANGUAGE RankNTypes, TypeFamilies #-}

module T9404b where

type family ListTF x where
  ListTF x = [x]

bar :: (forall x. ListTF x -> Int) -> ()
bar _ = ()

myconst :: ((forall r. ListTF r -> Int) -> ()) -> x -> (forall r. ListTF r -> Int) -> ()
myconst x _ = x

foo = (bar `myconst` ()) $ length
foo2 = (myconst bar ()) $ length


{-# LANGUAGE RankNTypes #-}
module T9569a where

g :: (Int -> Int) -> Int
g f = f 4

f1 :: (forall a. a -> a) -> Int
f1 = g

f2 :: (forall a. a -> a) -> Int
f2 x = g x


{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies #-}
{-# OPTIONS_GHC -fwarn-redundant-constraints #-}
module TcTypeNatSimple where

import GHC.TypeLits
import Data.Proxy

type family SomeFun (n :: Nat)

-- See the Trac ticket; whether this succeeds or fails is distinctly random

-- upon creation, commit f861fc6ad8e5504a4fecfc9bb0945fe2d313687c, this failed

-- with Simon's optimization to the flattening algorithm, commit
-- 37b3646c9da4da62ae95aa3a9152335e485b261e, this succeeded

-- with the change to stop Deriveds from rewriting Deriveds (around Dec. 12, 2014),
-- this failed again

-- 2016-01-23: it just started passing again, when
-- -fwarn-redundant-constraints was removed from the default warning set.
-- Turning the warning back on for this module, ghc reports (and probably has
-- for some time):
--      Redundant constraints: (x <= y, y <= x)
--      In the type signature for:
--            ti7 :: (x <= y, y <= x) => Proxy (SomeFun x) -> Proxy y -> ()

ti7 :: (x <= y, y <= x) => Proxy (SomeFun x) -> Proxy y -> ()
ti7 _ _ = ()


{-# OPTIONS_GHC -fdefer-type-errors #-}
{-# LANGUAGE ImpredicativeTypes #-}

module T9834 where
import Control.Applicative
import Data.Functor.Identity

type Nat f g = forall a. f a -> g a

newtype Comp p q a = Comp (p (q a))

liftOuter :: (Functor p, Applicative q) => p a -> (Comp p q) a
liftOuter pa = Comp (pure <$> pa)

runIdComp :: Functor p => Comp p Identity a -> p a
runIdComp (Comp p) = runIdentity <$> p

wrapIdComp :: Applicative p => (forall q. Applicative q => Nat (Comp p q) (Comp p q)) -> p a -> p a
wrapIdComp f = runIdComp . f . liftOuter

class Applicative p => ApplicativeFix p where
  afix :: (forall q. Applicative q => (Comp p q) a -> (Comp p q) a) -> p a
  afix = wrapIdComp


{-# LANGUAGE UndecidableInstances #-}

module T9892 where

import Control.Applicative
import Control.Category
import Prelude hiding ((.),id)

newtype FocusingPlus w k s a = FocusingPlus { unfocusingPlus :: k (s, w) a }

instance Functor (k (s, w)) => Functor (FocusingPlus w k s) where
  fmap f (FocusingPlus as) = FocusingPlus (fmap f as)

instance Applicative (k (s, w)) => Applicative (FocusingPlus w k s) where
  pure = FocusingPlus . pure
  FocusingPlus kf <*> FocusingPlus ka = FocusingPlus (kf <*> ka)


{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wredundant-constraints #-}

module T9939 where

f1 :: (Eq a, Ord a) => a -> a -> Bool
-- Eq a redundant
f1 x y = (x == y) && (x > y)

f2 :: (Eq a, Ord a) => a -> a -> Bool
-- Ord a redundant, but Eq a is reported
f2 x y = (x == y)

f3 :: (Eq a, a ~ b, Eq b) => a -> b -> Bool
-- Eq b redundant
f3 x y = x==y

data Equal a b where
  EQUAL :: Equal a a

f4 :: (Eq a, Eq b) => a -> b -> Equal a b -> Bool
-- Eq b redundant
f4 x y EQUAL = y==y


{-# LANGUAGE FunctionalDependencies #-}
module T9971 where

type Vertex v = v Double

class C a b | b->a  where
  op :: a -> b

foo :: Vertex x
foo = error "urk"

bar x = [op foo, op foo]
 -- This gives rise to a [D] Vertex a1 ~ Vertex a2
 -- And that made the canonicaliser go into a loop (Trac #9971)


{-# OPTIONS_GHC -fwarn-redundant-constraints #-}

module T9973 where

duplicateDecl :: (Eq t) => t -> IO ()
-- Trac #9973 was a bogus "redundant constraint" here
duplicateDecl sigs
 = do { newSpan <- return typeSig

         -- **** commenting out the next three lines causes the original warning to disappear
       ; let rowOffset = case typeSig of {  _  -> 1 }

       ; undefined }
   where
     typeSig = definingSigsNames sigs

definingSigsNames :: (Eq t) => t -> ()
definingSigsNames x = undefined
  where
    _ = x == x   -- Suppress the complaint on this


module ShouldSucceed where

a x = y+2 where y = x+3


module ShouldSucceed where

b = if True then 1 else 2


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)


module ShouldSucceed where

f x = case x of
       True -> True
       False -> x


module ShouldSucceed where

g ((x:z),y) = x
g (x,y) = 2


module ShouldSucceed where

j = 2

k = 1:j:l

l = 0:k

m = j+j


module ShouldSucceed where

n True = 1
n False = 0


module ShouldSucceed where

o (True,x) = x
o (False,y) = y+1


module ShouldSucceed where

p = [(y+2,True) | y <- [1,2]]


module ShouldSucceed where

q = \ y -> y


module ShouldSucceed where

(r,s) = (1,'a')


module ShouldSucceed where

u x = \ (y,z) -> x


module ShouldSucceed where

f x@_ y@_ = x


module ShouldSucceed where

v | True = v+1
  | False = v


module ShouldSucceed where

w = a where a = y
            y = 2


module ShouldSucceed where

(al:am) = [y+1 | (y,z) <- [(1,2)]]


module ShouldSucceed where

f x = a where a = x:a


module ShouldSucceed where

f x = a

a = (x,x)

x = x


module ShouldSucceed where

main = iD iD

iD x = x


module ShouldSucceed where

main  = s k k

s f g x = f x (g x)

k x y = x


module ShouldSucceed where

main x = s k k x

s f g x = f x (g x)

k x y = x


module ShouldSucceed where

g x = f (f True x) x where f x y = if x then y else (f x y)


module ShouldSucceed where

g x = f (f True x) x
f x y = if x then y else (f x y)


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)


module ShouldSucceed where

type H = (Int,Bool)


module ShouldSucceed where

type G = [Int]

data K = H Bool | M G


module ShouldSucceed where

type H = [Bool]

type G = (H,Char)


module ShouldSucceed where

data Rec = Node Int Rec


module ShouldSucceed where

data AList b = Node b [b] | Other (b,Char)


module ShouldSucceed where

data Twine = Twine2 Twist

data Twist = Twist2 Twine

type F = Twine


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


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)


module ShouldSucceed where

class (Eq a) => A a where
 op1 :: a -> a


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


module ShouldSucceed where

f (x:xs) = if (x == (fromInteger 2)) then xs else []


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]


-- !!! 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


-- !!! 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)


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


-- once produced a bug, here as regression test

module ShouldSucceed where

f _ | otherwise = ()


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
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
-}


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" -}


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


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


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


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

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]
-}


module ShouldSucceed where

type A a = B a

type B c = C

type C = Int


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]


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


module ShouldSucceed where

(x,y) = (\p -> p,\q -> q)


-- !!! 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]


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])


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

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]


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]


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


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


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


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


module ShouldSucceed where

data Boolean = FF | TT

idb :: Boolean -> Boolean
idb x = x


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 :: (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) =>
                 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


module ShouldSucceed where

data Pair a b = MkPair a b
f x = [ a | (MkPair c a) <- x ]


module ShouldSucceed where

f [] = []
f (x:xs) = x : (f xs)


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)


module ShouldSucceed where

x = 'a'
(y:ys) = ['a','b','c'] where p = x


-- !!! 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]


-- !!! 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


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- !!! 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)


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- !!! 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 {}


--module Parse(Parse(..),whiteSpace,separatedBy) where
--import StdLib
module ShouldSucceed where

import Data.Char

class Parse a where
       parseFile :: String -> [a]
       parseLine :: String -> a
       parseType :: String -> (a,String)
       parse :: String -> (a,String)
       forced :: a -> Bool

       parseFile string | all forced x = x
                       where x = map parseLine (lines' string)
       parseLine = pl.parse where pl (a,_) = a
       parse = parseType.whiteSpace
       forced x = True

instance Parse Int where
       parseType str = pl (span' isDigit str)
               where    pl (l,r) = (strToInt l,r)
       forced n | n>=0 = True

instance Parse Char where
       parseType (ch:str) = (ch,str)
       forced n = True

instance (Parse a) => Parse [a] where
        parseType more = (map parseLine (separatedBy ',' (l++",")),out)
                       where    (l,']':out) = span' (\x->x/=']') (tail more)
        forced = all forced

separatedBy :: Char -> String -> [String]
separatedBy ch [] = []
separatedBy ch xs = twaddle ch (span' (\x->x/=ch) xs)
               where    twaddle ch (l,_:r) = l:separatedBy 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')


-- !!! an example Simon made up
--
module ShouldSucceed where

f x = (x+1, x<3, g True, g 'c')
        where
        g y = if x>2 then [] else [y]
{-
Here the type-check of g will yield an LIE with an Ord dict
for x.  g still has type forall a. a -> [a].  The dictionary is
free, bound by the x.

It should be ok to add the signature:
-}

f2 x = (x+1, x<3, g2 True, g2 'c')
        where
        -- NB: this sig:
        g2 :: a -> [a]
        g2 y = if x>2 then [] else [y]
{-
or to write:
-}

f3 x = (x+1, x<3, g3 True, g3 'c')
        where
        -- NB: this line:
        g3 :: a -> [a]
        g3 = (\ y -> if x>2 then [] else [y])::(a -> [a])


-- !!! 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


{- 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


-- !!! From a bug report from Satnam.
-- !!! To do with re-exporting importees from PreludeGla* modules.
module ShouldSucceed ( module GHC.Prim ) where

import GHC.Prim

type FooType = Int
data FooData = FooData


{-
  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)


{-# LANGUAGE RankNTypes #-}

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                             :: (Eq a, Num a) => [a] -> IO ()
out x | sum x == 0              =  putStr "ok\n"
      | otherwise               =  putStr "ok\n"


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- Check that "->" is an instance of Eval

module ShouldSucceed where

instance Show (a->b) where
        show _ = error "attempt to show function"

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


-- !!! Stress test for type checker

module ShouldSucceed where

import Prelude hiding (head)

one :: a
one = one

head (x:xs) = x

bottom xs = head xs

absIf a b c = a

absAnd a b = head [a,b]

fac_rec fac0 n a
  = (absIf (absAnd (s_3_0 n) one)
           (s_2_0 a)
           (fac0 (absAnd (s_3_2 n) one) (absAnd (s_3_1 n) (s_2_1 a))))

f_rec f0 a
  = (f0 (s_1_0 a))

g_rec g0 g1 x y z p
  = (absIf (absAnd (s_3_0 p) one)
           (absAnd (s_1_0 x) (s_3_0 z))
           (absAnd
              (g0 (s_1_0 y) one one (absAnd (s_3_1 p) one))
              (g1 (s_3_2 z) (s_3_1 z) one (absAnd (s_3_2 p) one))))

s_2_0 (v0,v1)   = v0
s_2_1 (v0,v1)   = v1
s_1_0 v0  = v0
s_3_0 (v0,v1,v2)   = v0
s_3_1 (v0,v1,v2)   = v1
s_3_2 (v0,v1,v2)   = v2

fac n a = fac_rec fac_rec4 n a

fac_rec4 n a  = (fac_rec fac_rec3 n a)
fac_rec3 n a  = (fac_rec fac_rec2 n a)
fac_rec2 n a  = (fac_rec fac_rec1 n a)
fac_rec1 n a  = (fac_rec fac_rec0 n a)
fac_rec0 n a  = (bottom [n,a])

f a = (f_rec f_rec2 a)

f_rec2 a  = (f_rec f_rec1 a)
f_rec1 a  = (f_rec f_rec0 a)
f_rec0 a  = (bottom [a])

g x y z p = (g_rec g_rec8 g_rec8 x y z p)

{-
g x y z p = (g_rec g_rec16 g_rec16 x y z p)

g_rec16 x y z p  = (g_rec g_rec15 g_rec15 x y z p)
g_rec15 x y z p  = (g_rec g_rec14 g_rec14 x y z p)
g_rec14 x y z p  = (g_rec g_rec13 g_rec13 x y z p)
g_rec13 x y z p  = (g_rec g_rec12 g_rec12 x y z p)
g_rec12 x y z p  = (g_rec g_rec11 g_rec11 x y z p)
g_rec11 x y z p  = (g_rec g_rec10 g_rec10 x y z p)
g_rec10 x y z p  = (g_rec g_rec9 g_rec9 x y z p)
g_rec9 x y z p  = (g_rec g_rec8 g_rec8 x y z p)
-}

g_rec8 x y z p  = (g_rec g_rec7 g_rec7 x y z p)
g_rec7 x y z p  = (g_rec g_rec6 g_rec6 x y z p)
g_rec6 x y z p  = (g_rec g_rec5 g_rec5 x y z p)
g_rec5 x y z p  = (g_rec g_rec4 g_rec4 x y z p)
g_rec4 x y z p  = (g_rec g_rec3 g_rec3 x y z p)
g_rec3 x y z p  = (g_rec g_rec2 g_rec2 x y z p)
g_rec2 x y z p  = (g_rec g_rec1 g_rec1 x y z p)
g_rec1 x y z p  = (g_rec g_rec0 g_rec0 x y z p)
g_rec0 x y z p  = (bottom [x,y,z,p])


{-      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


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- !!! 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)


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE RankNTypes #-}

module ShouldSucceed where

data Empty q                    =  Empty (forall a. Ord a => q a)
q                               :: (Ord a) => [a]
q                               =  []
e0, e1, e2                      :: Empty []
e0                              =  Empty []
e1                              =  Empty ([] :: (Ord a) => [a])
e2                              =  Empty q


module ShouldSucceed where

import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)

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 => Functor (State c) where
    fmap = liftM

instance Eq c => Applicative (State c) where
    pure = return
    (<*>) = ap

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


module ShouldSucceed where

-- From a bug report by Sven Panne.

foo = bar
   where bar = \_ -> (truncate boing, truncate boing)
         boing = 0


{-
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.


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
-}


{-# LANGUAGE RankNTypes #-}
-- !!! 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


-- !!! 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.
-}


-- !! 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


-- !!! 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)


-- !!! 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)


{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

-- !!! Caused ghc-4.04proto to report a bogus type error
-- !!! (as reported by Keith)

-- The type error arose from a mistake in tcMatches.tc_match

-- Involves pattern type signatures

module ShouldCompile where

p :: forall a. a -> a
p = let y = p in \ (x::a) -> x


-- !!! Checking that Main.main's type can now be of the form (IO a)
module Main(main) where

main = putStrLn "Hello" >> return (id)


{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

module ShouldCompile where

import Control.Monad.ST
import Data.STRef

-- (Modified now that we don't have result type signatures)

f:: forall s. ST s Int
f = do v <- newSTRef 5
       let g :: ST s Int
             -- ^ should be in scope
           g = readSTRef v
       g


{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}

-- !!! Mutually recursive kind inference
-- Exposes a bug in 4.08 (fixed in 4.08 pl1)

module ShouldCompile where

-- This pair will tickle the bug
class Lookup c k a where
    lookupAll :: Sequence seq a => c -> k -> seq a

class Lookup (s a) Int a => Sequence s a where
    foo :: s a

-- This decl will tickle it all by itself
class Matrix a e where
   amap2  :: (Matrix a d) =>
             (e -> d -> e) -> a ix e -> a ix d -> a ix e


-- !!! 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


{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
-- !!! Scopes in kind checking

-- Exposes a bizarre bug in 4.08.1
--    TestSh.hs:6:
--      `Shape' is not in scope
--      When checking kinds in `HasConfigValue Shape nodeTypeParms'
--      In the class declaration for `HasShape'

module ShouldCompile where

data Shape value = Box | Circle

class HasConfigValue Shape nodeTypeParms => HasShape nodeTypeParms where {}

class HasConfigValue option configuration where
   ($$$) :: option value -> configuration value -> configuration value


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             UndecidableInstances #-}
-- UndecidableInstances because 'b' appears in the context but not the head

module ShouldCompile where

-- This accepted by Hugs, but not by GHC 4.08.1
-- Reported by Thomas Hallgren Nov 00

class P a
class R a b | b->a

instance (P a,R a b) => P [b]

{- GHC 4.08.1 doesn't seem to allow variables in the context that
don't appear after the =>, but which are still ok since they are
determined by the functional dependenices.  -}


-- !!! 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.

{-# NOINLINE [1] foo #-}
foo 1 = 2
{-# NOINLINE [1] bar #-}
bar 0 = 1

foobar = 2

{-# RULES
  "foo/bar" foo bar = foobar
 #-}


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

-- !!! Functional dependencies
-- This broke an early impl of functional dependencies
-- (complaint about ambiguity)

module ShouldCompile where

class C a b | a -> b where f :: a -> b

g :: (C a b, Eq b) => a -> Bool
g x = f x == f x


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- !!! 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')


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances #-}

-- !!! Functional dependencies
-- This broke an early impl of functional dependencies

module ShouldCompile where

class Foo r a | r -> a where
    foo :: a -> r

instance Foo (Maybe e) e where
    foo = Just

bad:: Num e => Maybe e
bad = foo 0


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances #-}
-- !!! Functional dependencies
-- This broke an early impl of functional dependencies
-- (complaining about ambiguity)

module ShouldCompile where

class Foo r a | r -> a where
    foo :: r -> a

instance Foo [m a] (m a)

bad:: Monad m => m a
bad = foo bar

bar:: Monad m => [m a]
bar = []


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances #-}
-- !!! Functional dependencies
-- This broke an early impl of functional dependencies
-- (caused a panic)

module ShouldCompile where

class Foo r a | r -> a where
    foo :: r -> a

instance Foo [m a] (m a)

bad:: Monad m => m a
bad = foo bar

bar:: [m a]
bar = []


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances, UndecidableInstances #-}
-- UndecidableInstances now needed because the Coverage Condition fails

-- !!! Functional dependencies
-- This one gave another fail in tcReadMutVar

module M1 where

class HasFoo a foo | a -> foo where
    foo :: a -> foo
instance HasFoo Int Int where
    foo = id

instance HasFoo a b => HasFoo [a] b where
    foo = foo . head

test:: [[Int]] -> Int
test = foo


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             UndecidableInstances #-}

-- !!! An instance decl with a context containing a free type variable
-- The interest here is that there's a "b" in the instance decl
-- context that isn't mentioned in the instance head.
-- Hence UndecidableInstances

module ShouldCompile where

class HasConverter a b | a -> b where
   convert :: a -> b

data Foo a = MkFoo a

instance (HasConverter a b,Show b) => Show (Foo a) where
   show (MkFoo value) = show (convert value)


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             ExistentialQuantification #-}

-- !!! Functional dependencies and existentials

-- Hugs (February 2000) doesn't like it. It says
--  Variable "e" in constraint is not locally bound

module ShouldCompile where

class Collection c e | c -> e where
   empty :: c
   put   :: c -> e -> c

data SomeCollection e = forall c . Collection c e => MakeSomeCollection c


-- !!! 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"


{-# LANGUAGE ImplicitParams #-}

-- !!! Implicit Parameters

-- If the implicit param isn't recognized as a PredType, x and y
-- will be inferred to have two params instead of one.

module ShouldCompile where

x () = ?wibble

y () = x ()

same :: a -> a -> b
same x y = undefined

a () = same x id
b () = same y id


{-# LANGUAGE ImplicitParams #-}

-- !!! Implicit Parameters

-- GHC 5.00 doesn't handle this:

--  Could not deduce `?wibble :: t' from the context ()
--  Probable fix:
--      Add `?wibble :: t' to the banding(s) for {y}
--  Or add an instance declaration for `?wibble :: t'
--  arising from use of implicit parameter `?wibble' at tc122.hs:18
--  in the definition of function `y': wibble

module ShouldCompile where

x () = y
    where y = ?wibble


{-# LANGUAGE ImplicitParams #-}

-- !!! Monotypes w/ Implicit Parameters

-- GHC 5.00 doesn't handle this:

--  Couldn't match `{?wibble :: Int}' against `()'
--      Expected type: {?wibble :: Int}
--      Inferred type: ()
--  In the first argument of `x', namely `()'
--  in the definition of function `y': x ()

module ShouldCompile where

x () = (?wibble :: Int)

y () = x ()


{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -O #-}    -- -O casused a Lint error in the simplifier, so I'm putting that in
                          -- all the time, so we don't miss it in a fast validate

-- !!! 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 b c. b->c->c }

-- Test pattern bindings for polymorphic fields
f :: T -> (Int,Char, Char)
f t = let T { t1 = my_t1, t2 = my_t2 } = t
      in
      (my_t1 3, my_t1 'c', my_t2 2 'c')

f2 :: T -> (Int,Char, Char)
f2 t = let T { t1 = my_t1, t2 = my_t2 } = t
       in
       (my_t1 3, my_t1 'c', my_t2 2 'c')

-- Test record update with polymorphic fields
g :: T -> T
g t = t { t2 = \x y -> y }


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances, UndecidableInstances #-}
-- UndecidableInstances now needed because the Coverage Condition fails

-- !!! Functional dependency test. Hugs [Apr 2001] fails to typecheck this
-- We should infer this type for foo
--      foo :: Q (S (S Z)) (S Z)

module ShouldCompile where

data Z = Z
data S a = S a

class Add a b c | a b -> c where add :: a -> b -> c

instance Add Z a a
instance Add a b c => Add (S a) b (S c)

class Mul a b c | a b -> c where mul :: a -> b -> c

instance Mul Z a Z
instance (Mul a b c, Add b c d) => Mul (S a) b d

data Q a b = Q a b

-- Problem here.  This is the addition of rational
-- numbers: (a/b) + (c/d) = (ad+bc)/bd

instance (Mul a d ad,
          Mul b c bc,
          Mul b d bd,
          Add ad bc ad_bc) => Add (Q a b) (Q c d) (Q ad_bc bd)

z = Z
sz = S Z
ssz = S (S Z)

foo = add (Q sz sz) (Q sz sz)


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
-- UndecidableInstances now needed because the Coverage Condition fails

-- !!! Functional dependency test. Hugs [Apr 2001] fails to typecheck this
-- Rather bizarre example submitted by Jonathon Bell

module ShouldCompile where

-- module Foo where

class Bug f a r | f a -> r where
   bug::f->a->r

instance                Bug (Int->r) Int      r
instance (Bug f a r) => Bug f        (c a)    (c r)

f:: Bug(Int->Int) a r => a->r
f = bug (id::Int->Int)

g1 = f (f [0::Int])
-- Inner f gives result type
--      f [0::Int] :: Bug (Int->Int) [Int] r => r
-- Which matches the second instance declaration, giving r = [r']
--      f [0::Int] :: Bug (Int->Int) Int r' => r'
-- Wwich matches the first instance decl giving r' = Int
--      f [0::Int] :: Int
-- The outer f now has constraint
--      Bug (Int->Int) Int r
-- which makes r=Int
-- So g1::Int

g2 = f (f (f [0::Int]))
-- The outer f repeats the exercise, so g2::Int
-- This is the definition that Hugs rejects


{-# LANGUAGE ImplicitParams #-}

-- !!! Another implicit parameter test, from Alastair Reid

module ShouldCompile where

import Data.Maybe

type Env = ([(String,Int)],Int)

ident1 :: (?env :: Env) => String -> Int
ident1 x = y
 where
  env = ?env
  y   = fromJust (lookup x (fst env))

ident2 :: (?env :: Env) => String -> Int
ident2 x = y
 where
  y   = fromJust (lookup x (fst ?env))

-- Two more tests from Jeff Lewis
x () = y where y = ?wibble

f () = ?wibble :: Int
g () = f ()


-- !!! 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


{-# LANGUAGE ImplicitParams #-}

-- !!! Test inheritance of implicit parameters.
-- GHC 5.00.2 fails this test

-- The thing is to do with whether an implicit parameter
-- constraint can be "inherited".  See notes in TcSimplify.lhs

module ShouldCompile where

data R = R {f :: Int}

foo :: (?x :: Int) => R -> R
foo r = r {f = ?x}

baz :: (?x :: Int) => Int
baz = (?x +1) :: Int


{-# LANGUAGE ImplicitParams #-}

-- !!! Desugaring of record updates
-- Showed up a bug in the newtype-squashing machinery

module ShouldCompile where

data R = R {field :: Int}

test:: (?param :: R) => a -> Int
test x = field (?param {field = 42})
        -- The type of the record to be updated is
        -- {?param :: R} as well as plain R
        -- which confused the compiler


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

-- !!! Typechecking of functional dependencies
-- Showed up (another) bug in the newtype-squashing machinery

module ShouldCompile where

class Split2 a b | a -> b, b -> a where
    combine2 :: (b,b) -> a

class Split4 a b | a -> b, b -> a where
    combine4 :: (b,b) -> a

newtype Word16 = Word16 Int
newtype Word32 = Word32 Int
newtype Word64 = Word64 Int

instance Split2 Word32 Word16 where
    combine2 = undefined

instance Split2 Word64 Word32 where
    combine2 a = undefined

instance Split4 Word64 Word16 where
    combine4 (a, b) =
        combine2 ( (combine2 (a, b)), combine2 (a, b))


-- !!! 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


{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-}

-- !!! Existentials

-- This one killed GHC 5.00.1:
--    Inferred type is less polymorphic than expected
--    Quantified type variable `a' is unified with another quantified type variable `a'
--    When checking a pattern that binds f :: a -> Int
--    In the definition of `f': f (T (x :: a) f) = T (undefined :: a) f

module Test where

data T = forall a. T a (a->Int)

f :: T -> T
f (T (x::a) f) = T (undefined::a) f


{-# LANGUAGE ScopedTypeVariables #-}

-- !!! Scoped type variables: result sig

module Test where

f :: Int -> Int
f x :: Int = x

g :: Int -> Int
g x :: a = x :: a       -- Here, a is a name for Int


{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification #-}

-- !!! scoped type variables w/ existential types
-- this test failed in GHC 5.00

module ShouldCompile where

data T = forall a. MkT [a]

f :: T -> T
f (MkT [t::a]) = MkT t3
    where t3::[a] = [t,t,t]


{-# LANGUAGE ScopedTypeVariables #-}

-- !!! scoped type variables
-- this test failed in pre-release GHC 5.02

module ShouldCompile where

f :: forall x. x -> x -> x
f (x::x) (y::x) = x
-- Two points: (a) we are using x as a term variable and as a type variable
--             (b) the type variable appears twice, but that is OK


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances #-}
{-# OPTIONS -dcore-lint #-}

{-       This one killed GHC 5.02

The problem is that in rather obscure cases (involving functional
dependencies) it is possible to get an AbsBinds [] [] (no tyvars, no
dicts) which nevertheless has some "dictionary bindings".  These come
out of the typechecker in non-dependency order, so we need to Rec them
just in case.   Otherwise we get a CoreLint out-of-scope error.

Reported by Armin Groesslinger

-}

module ShouldCompile
where

data X a = X a

class Y a b | a -> b where
    y :: a -> X b

instance Y [[a]] a where
    y ((x:_):_) = X x

g :: Num a => [X a] -> [X a]
g xs = h xs
    where
    h ys = ys ++ map (k (y [[0]])) xs

k :: X a -> X a -> X a
k _ _ = y ([] ++ [[]] ++ [])


{-# LANGUAGE RankNTypes #-}

-- 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)


{-# LANGUAGE ScopedTypeVariables #-}

-- Scoped type variables on pattern bindings
-- This should *fail* on GHC 5.02 and lower,
-- It's a post-5.02 enhancements to allow them.

-- It's an error again in GHC 6.6!

module ShouldCompile where

f x = let (p::a,q::a) = x in (q::a,p)

g a b = let y::a = a in
        let  v :: a
             v = b
         in v


-- !!! 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


-- 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


{-# LANGUAGE ImplicitParams, RankNTypes #-}

-- Rank-2 types with implicit parameters.
-- GHC 5.02 erroneously rejected this

module ShouldCompile where

    f :: ((?param :: a) => b) -> a -> b
    f foo a = let ?param = a in foo

    g :: (?param :: a) => a
    g = ?param

    h :: a -> a
    h = f g


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE RankNTypes, ImplicitParams, UnboxedTuples #-}

-- Test two slightly exotic things about type signatures

module ShouldCompile where

        -- The for-all hoisting should hoist the
        -- implicit parameter to give
        --      r :: (?param::a) => a
    r :: Int -> ((?param :: a) => a)
    r = error "urk"

        -- The unboxed tuple is OK because it is
        -- used on the right hand end of an arrow
    type T = (# Int, Int #)

    f :: Int -> T
    f = error "urk"


{-# LANGUAGE RankNTypes #-}

-- The interesting thing 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


-- 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


{-# LANGUAGE RankNTypes #-}

-- 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


{-# LANGUAGE LiberalTypeSynonyms #-}
{-# LANGUAGE RankNTypes #-}

module ShouldCompile where

type Generic i o = forall x. i x -> o x
type Id x = x

foo :: Generic Id Id
foo = error "urk"

-- The point here is that we instantiate "i" and "o"
-- with a partially applied type synonym.  This is
-- OK in GHC because we check type validity only *after*
-- expanding type synonyms (with LiberalTypeSynonyms enabled).
--
-- However, a bug in GHC 5.03-Feb02 made this break a
-- type invariant (see Type.mkAppTy)


{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

module ShouldCompile where

f v = (\ (x :: forall a. a->a) -> True) id -- 'c'


{-# LANGUAGE RankNTypes #-}

-- A test for rank-3 types

module ShouldCompile where

data Fork a                   =  ForkC a a

mapFork                       :: forall a1 a2 . (a1 -> a2) -> (Fork a1 -> Fork a2)
mapFork mapA (ForkC a1 a2)    =  ForkC (mapA a1) (mapA a2)

data SequF s a    =  EmptyF | ZeroF (s (Fork a)) | OneF a (s (Fork a))
newtype HFix h a  =  HIn (h (HFix h) a)

type Sequ =  HFix SequF

mapSequF  :: forall s1 s2 . (forall b1 b2 . (b1 -> b2) -> (s1 b1 -> s2 b2))
                         -> (forall a1 a2 . (a1 -> a2) -> (SequF s1 a1 -> SequF s2 a2))
mapSequF mapS mapA EmptyF     =  EmptyF
mapSequF mapS mapA (ZeroF as) =  ZeroF (mapS (mapFork mapA) as)
mapSequF mapS mapA (OneF a as)=  OneF (mapA a) (mapS (mapFork mapA) as)

mapHFix :: forall h1 h2 . (forall f1 f2 . (forall c1 c2 . (c1 -> c2) -> (f1 c1 -> f2 c2))
                                          -> (forall b1 b2 . (b1 -> b2) -> (h1 f1 b1 -> h2 f2 b2)))
                          -> (forall a1 a2 . (a1 -> a2) -> (HFix h1 a1 -> HFix h2 a2))
mapHFix mapH mapA (HIn v)     =  HIn (mapH (mapHFix mapH) mapA v)

mapSequ  :: forall a1 a2 . (a1 -> a2) -> (Sequ a1 -> Sequ a2)
mapSequ  =  mapHFix mapSequF


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             UndecidableInstances #-}
-- -XUndecidableInstances now needed because the Coverage Condition fails

-- This one blew up Hugs (Apr 02)

module ShouldCompile where

--  Context reduction can introduce opportunities for context improvement,
--  so add an additional `improve' step afterwards.  The bug is demonstrated by
--  the following code:

  class C a b c | a b -> c where
    m :: a -> b -> c

  instance C Integer Integer Integer where
    m = error "urk"

  newtype T a = T a

  instance C a b c => C (T a) (T b) (T c) where
    m = error "urk"

  i :: T Integer
  i = undefined

  x = m (m i i) i -- This line blows up w/ unresolved top-level overloading


-- No ScopedTypeVariables, so (v::a) means (v:: forall a.a)

module ShouldCompile where

data T a = T a

instance Eq (T a) where
  (==) x y = let v :: a
                 v = undefined
             in
                v


-- 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 () = ()


{-# LANGUAGE LiberalTypeSynonyms #-}

-- The type sig for 'test' is illegal in H98 because of the
-- partial application of the type sig.
-- But with LiberalTypeSynonyms it should be OK because when
-- you expand the type synonyms it's just Int->Int
--      c.f should_fail/tcfail107.hs

module ShouldCompile where

type Thing m = m ()

type Const a b = a

test :: Thing (Const Int) -> Thing (Const Int)
test = test


{-# LANGUAGE TypeOperators #-}

-- Test infix type constructors

module ShouldCompile where

infixl 4 :*:
infixl 3 :+:

data a :*: b = a :*: b
data a :+: b = a :+: b

data T a b = T (a `b` Int)

type Foo a b = a `T` b

f :: Int :*: Bool :+: Char
f = (3 :*: True) :+: 'c'


{-# LANGUAGE RankNTypes #-}

-- 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


{-# LANGUAGE RankNTypes #-}

-- 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


{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- Don't do the cunning new newtype-deriving thing
-- when the type constructor is recursive

module Main where

newtype A = A [A] deriving (Eq)

-- The derived instance would be:
-- instance Eq A where
--      (A xs) == (A ys) = xs==ys
--   $df :: Eq [A] => Eq A
--   $df d = d |> Eq (sym co)

x :: A
x = A [A [], A [A []]]

main = print (x == x)


{-# LANGUAGE RankNTypes #-}

--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


{-# LANGUAGE RankNTypes #-}
-- 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


{-# LANGUAGE RankNTypes #-}

-- These ones failed with 5.04.  They need a coercion
-- in the pattern matching compiler, so they are a bit
-- tricky.

-- GHC 6.3: these are back to failures, because we no longer do
--          type subsumption in pattern-matching

-- GHC 7.0: back to success

module ShouldCompile where

newtype Bug s a = Bug a

runBug :: (forall s. Bug s a) -> a
runBug (Bug _) = undefined

newtype BugN s a = BugN a

runBugN :: (forall s. BugN s a) -> a
runBugN (BugN _) = undefined

data Foo a b = Foo { foo :: a -> b }

baz :: String -> (forall a b . Foo a b) -> IO ()
baz s (Foo { foo = foo }) = putStrLn s


{-# LANGUAGE RankNTypes #-}

-- This one killed GHC 5.05 and earlier
-- The problem was in a newtype with a record selector, with
-- a polymorphic argument type.  MkId generated a bogus selector
-- function

module ShouldCompile where

type M3 a = forall r. (forall b. M3' b -> (b -> M3' a) -> r) -> r

newtype M3' a = M3' { mkM3' :: M3 a }

flop :: forall a b. M3' b -> (b -> M3' a) -> Int
flop = \m' k -> mkM3' m' (\bm k1 -> error "urk")

-- Suppose mkM3' has the straightforward type:
--     mkM3' :: forall a. M3' a -> M3 a
-- Then (mkM3' m') :: forall r. (forall b. ...) -> r
-- If we simply do a subsumption check of this against
--    alpha -> Int
-- where alpha is the type inferred for (\bm k1 ...)
-- this won't work.

-- But if we give mkM3' the type
--     forall a r. M3' a -> (forall b. ...) -> r
-- everthing works fine.  Very very delicate.

---------------- A more complex case -------------
bind :: M3 a -> (a -> M3 b) -> M3 b
bind m k b = b (M3' m) (\a -> M3' (k a))

observe :: M3 a -> a
observe m
      = m (\m' k -> mkM3' m'
                (\bm k1 -> observe (bind (mkM3' bm)
                        (\a -> bind (mkM3' (k1 a)) (\a -> mkM3' (k a)))))
                )


{-# LANGUAGE ImplicitParams #-}

module ShouldCompile where

data UniqueSupply = US Integer

newUnique :: (?uniqueSupply :: UniqueSupply) => Integer
newUnique = r
    where US r = ?uniqueSupply
        -- The lazy pattern match in the where clause killed GHC 5.04
        -- because the type {?uniqueSupply::UniqueSupply} of the RHS
        -- of the 'where' didn't look like a UniqueSupply


{-# LANGUAGE ConstrainedClassMethods #-}
{-# OPTIONS_GHC -dcore-lint #-}

-- Fails GHC 5.04.2 with -dcore-lint
-- The issue ariseswhen you have a method that
-- constrains a class variable

module Test where

class C a where
    f :: (Eq a) => a

instance C () where
    f = f


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             ExistentialQuantification, RankNTypes,
             FlexibleInstances #-}

-- Arguably, the type signature for f1 should be enough to make
-- this program compile, but in 5.04 it wasn't; the
-- extra sig in f2 was needed.
--
-- This is a pretty borderline case.

module ShouldCompile where

    class C t a b | t a -> b
    instance C Char a Bool

    data P t a = forall b. (C t a b) => MkP b

    data Q t = MkQ (forall a. P t a)

    f1 :: Q Char
    f1 = MkQ (MkP True)

    f2 :: Q Char
    f2 = MkQ (MkP True :: forall a. P Char a)


{-# LANGUAGE MagicHash #-}

-- It used to be that (->) would have a very restrictive kind when used in
-- prefix position. This restriction was lifted after the levity polymorphism
-- work in 2016.

module ShouldSucceed where
import GHC.Base

type T = (->) Int#

-- Here's the old comment from TypeRep:
--
-- funTyCon = mkFunTyCon funTyConName
--              (mkArrowKinds [liftedTypeKind, liftedTypeKind]
--                              liftedTypeKind)
-- You might think that (->) should have type (? -> ? -> *), and you'd be right
-- But if we do that we get kind errors when saying
--      instance Control.Arrow (->)
-- because the expected kind is (*->*->*).  The trouble is that the
-- expected/actual stuff in the unifier does not go contra-variant, whereas
-- the kind sub-typing does.  Sigh.  It really only matters if you use (->) in
-- a prefix way, thus:  (->) Int# Int#.  And this is unusual.


{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}

-- 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

-- Having done this, we reject f on the grounds
-- that its type is ambiguous: adding the type
-- signature   g :: C a (b,c) => a -> b
-- would fail

module ShouldCompile where

class C a b where { op :: a -> b }

g x = fst (op x)


-- 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


-- This test killed GHC 6.0.2 when it read the interface file for
-- Tc170_Aux, because there was a
--      forall a. (# ... #)
-- in the default method for 'position'
--
-- NB: only fails when compiled in batch mode. In --make mode, GHC
--     doesn't read the interface file, so all is well.

module ShouldCompile where

import Tc170_Aux

data Bitmap = Bitmap

instance Dimensions Bitmap where
  frame = error "urk"


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Tc170_Aux where

class ReadMode mode

data Attr m w a = Attr (w -> IO a) (w -> a -> IO ())

mapAttr :: ReadMode m => (a -> b) -> (a -> b -> a) -> Attr m w a -> Attr m w b
mapAttr get set (Attr getter setter)
    = Attr (\w   -> do a <- getter w; return (get a))
           (\w b -> do a <- getter w; setter w (set a b))

data Rect  = Rect
data Point = Point
topLeft    = undefined
rectMoveTo = undefined

class Dimensions w where
  frame    :: ReadMode m => Attr m w Rect

  position :: ReadMode m => Attr m w Point
  position  = mapAttr (\f -> topLeft f) (\f p -> rectMoveTo p f) frame


-- Data types with no constructors

module ShouldCompile where

data S
data T a

f :: [T a] -> Int
f xs = length xs


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


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, UndecidableInstances #-}

module Tc173a where

class FormValue value where
   isFormValue :: value -> ()
   isFormValue _ = ()

class FormTextField value

instance FormTextField String

instance {-# OVERLAPPABLE #-} FormTextField value => FormTextFieldIO value

class FormTextFieldIO value

instance FormTextFieldIO value => FormValue value

instance {-# OVERLAPPING #-} FormTextFieldIO value => FormTextFieldIO (Maybe value)


{-# LANGUAGE UndecidableInstances #-}
module Tc173b where

import Tc173a

is :: ()
is = isFormValue (Just "")


{-# LANGUAGE UnboxedTuples #-}

module ShouldCompile where

f x = (# x, x #) :: (# Int, Int #)


-- 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)


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE FlexibleInstances #-}

{-  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 {-# OVERLAPPABLE #-} FromStr [a] where
     fromStr _ = typeError undefined  -- line 8

instance {-# OVERLAPPING #-} FromStr [(String,a)] where  -- line 10
     fromStr _ = typeError undefined  -- line 11


{-# LANGUAGE FlexibleInstances, UndecidableInstances,
             MultiParamTypeClasses, FunctionalDependencies #-}

-- This is a rather complicated program that uses functional
-- dependencies to do Peano arithmetic.
--
-- GHC 6.2 dies because tcSimplifyRestricted was trying to
-- be too clever.  See 'Plan B' in tcSimplifyRestricted

module ShouldCompile where

-- This is the offending definition.  It falls under
-- the monomorphism restriction, so tcSimplifyRestricted applies
bug = ins b (ins b Nil)

------------------------------------
data LAB l r = LAB l r deriving Show

data OR a b = OR a b deriving Show

data Cons x y = Cons x y deriving Show

data Nil = Nil deriving Show

data T = T

data F = F

data A = A deriving Show

data B = B deriving Show

data Zero = Zero

data Succ n = Succ n

b = ((LAB B []),[])

-- insertion function
-- insert label pairs in the a list of list, each list contains a collection of
-- label pair that sharing the common label.

class Ins r l l' | r l -> l' where
    ins :: r -> l -> l'

instance Ins ((LAB l1 r1),r1') Nil (Cons (Cons ((LAB l1 r1),r1') Nil) Nil) where
    ins l Nil = (Cons (Cons l Nil) Nil)

instance ( L2N l1 n1
     , L2N l2 n2
     , EqR n1 n2 b
     , Ins1 ((LAB l1 r1),r1') (Cons (Cons ((LAB l2 r2),r2') rs) rs') b l
     ) => Ins ((LAB l1 r1),r1') (Cons (Cons ((LAB l2 r2),r2') rs) rs') l
    where
      ins ((LAB l1 r1),r1') (Cons (Cons ((LAB l2 r2),r2') rs) rs')
        = ins1  ((LAB l1 r1),r1') (Cons (Cons ((LAB l2 r2),r2') rs) rs')
                (eqR (l2n l1)  (l2n l2))
-- Note that n1 and n2 are functionally defined by l1 and l2, respectively,
-- and b is functionally defined by n1 and n2.

class Ins1 r l b l' | r l b -> l' where
    ins1 :: r -> l -> b -> l'

instance Ins1 ((LAB l1 r1),r1') (Cons r rs) T
              (Cons (Cons ((LAB l1 r1),r1') r) rs) where
   ins1 l (Cons r rs) _ = (Cons (Cons l r) rs)

instance ( Ins ((LAB l1 r1),r1') rs rs')
      => Ins1 ((LAB l1 r1),r1') (Cons r rs) F (Cons r rs') where
    ins1 l (Cons r rs) _ = (Cons r (ins l rs))

-- class for mapping label to number

class L2N l n | l -> n where
    l2n :: l -> n

instance L2N A Zero where
    l2n A = Zero

instance L2N B (Succ Zero) where
    l2n B = Succ Zero

-- class for comparing number type

class EqR n1 n2 b | n1 n2 -> b where
    eqR :: n1 -> n2 -> b

instance EqR Zero Zero T where
    eqR _ _ = T

instance EqR Zero (Succ n) F where
    eqR _ _ = F

instance EqR (Succ n) Zero F where
    eqR _ _ = F

instance (EqR n1 n2 b) => EqR (Succ n1) (Succ n2) b where
    eqR (Succ n1) (Succ n2) = eqR n1 n2


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE FlexibleInstances #-}

-- This one tickled the kind-check in TcType.matchTys,
-- which should use sub-kinding

module ShouldCompile where

type TypeRep = ()

class Typeable2 t where
  typeOf2 :: t a b -> TypeRep

class Typeable1 t where
  typeOf1 :: t a -> TypeRep

class Typeable0 a where
  typeOf0 :: a -> TypeRep

instance Typeable2 (->) where
  typeOf2 = undefined

instance (Typeable2 t, Typeable0 a) => Typeable1 (t a) where
  typeOf1 = undefined

instance (Typeable1 t, Typeable0 a) => Typeable0 (t a) where
  typeOf0 = undefined

class Typeable0 a => Data0 a where
  dataTypeOf0 :: a -> Bool

instance (Data0 a, Data0 b) => Data0 (a -> b) where
  dataTypeOf0 = undefined

foo :: (Typeable0 a, Typeable0 b) => (a -> b) -> TypeRep
foo f = typeOf0 f


{-# LANGUAGE ExistentialQuantification, FlexibleInstances, UndecidableInstances #-}

-- Tests context reduction for existentials

module TestWrappedNode where

class Foo a where { op :: a -> Int }

instance {-# OVERLAPPABLE #-} Foo a => Foo [a] where    -- NB overlap
  op (x:xs) = op x
instance {-# OVERLAPPING #-} 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.


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances, UndecidableInstances #-}

-- This tests an aspect of functional dependencies, revealing a bug in GHC 6.0.1
-- discovered by Martin Sulzmann

module ShouldCompile where

data PHI = PHI
data EMPT = EMPT
data LAB l a = LAB l a
data Phi = Phi

data A = A
data A_H = A_H [Char]

class LNFyV r1 r2 h1 h2 | r1 -> r2, r1 r2 -> h1 h2 where
    lnfyv :: r1->r2->h1->h2

instance ( REtoHT (LAB l c) h)
        => LNFyV (LAB l c) ((LAB l c),EMPT) h (h,[Phi]) where -- (L2)
    lnfyv = error "urk"

class REtoHT s t | s->t
instance REtoHT (LAB A [Char]) A_H    -- (R4)

foo = lnfyv (LAB A "") ((LAB A ""),EMPT) (A_H "1")

{-
ghci 6.0.1

*Test> :t (lnfyv (LAB A "") ((LAB A ""),EMPT) (A_H "1") )

No instance for (LNFyV (LAB A [Char])
                       (LAB A [Char], EMPT)
                       A_H
                       (h, [Phi]))
  arising from use of `lnfyv' at <No locn>

hugs November 2002

Test> :t (lnfyv (LAB A "") ((LAB A ""),EMPT) (A_H "1"))
lnfyv (LAB A "") (LAB A "",EMPT) (A_H "1") :: (A_H,[Phi])

hugs is right, here's why

(lnfyv (LAB A "") ((LAB A ""),EMPT) (A_H "1")) yields

                  LNFyV (LAB A Char) ((LAB A Char),EMPT) (A_H) c

improve by (L2)   LNFyV (LAB A Char) ((LAB A Char),EMPT) (A_H) (A_H,[Phi]), c=(A_H,[Phi])
reduce by (L2)    REtoHT (LAB A Char) A_H, c=(A_H,[Phi])
reduce by (R4)    c=(A_H,[Phi])

-}


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances, FlexibleContexts, UndecidableInstances #-}

-- Example of improvement, due to George Russel

module Folders where

data Folder = Folder

newtype SB x = SB x
newtype SS x = SS x

data NodeArcsHidden = NodeArcsHidden

class HasSS hasS x | hasS -> x where
   toSS :: hasS -> SS x

instance HasSS (SB x) x where
   toSS (SB x) = (SS x)

class HMV option graph node where
   modd :: option -> graph -> node value -> IO ()

instance HMV NodeArcsHidden graph node
      => HMV (Maybe NodeArcsHidden) graph node
  where
   modd = error "burk"

gn :: HMV NodeArcsHidden graph node
   => graph
   -> SS (graph -> node Int -> IO ())
gn graph = fmapSS (\ arcsHidden -> (\ graph node -> modd arcsHidden graph node))
                  (toSS (error "C" :: SB (Maybe NodeArcsHidden)))

-- The call to modd gives rise to
--      HMV option graph node
-- The call to toSS gives rise to
--      HasSS (SB (Maybe NodeArcsHidden)) x
-- where (toSS (error ...)) :: SS x
-- and hence arcsHidden :: x
--
-- Then improvement should give x = Maybe NodeArcsHidden
-- and hence option=Maybe NodeArcsHidden

fmapSS :: (a->b) -> SS a -> SS b
fmapSS = error "urk"


{-# LANGUAGE DatatypeContexts, ExistentialQuantification #-}

-- Tests the "stupid theta" in pattern-matching
-- when there's an existential as well

module ShouldCompile  where

data (Show a) => Obs a = forall b. LiftObs a b

f :: Show a => Obs a -> String
f (LiftObs _ _) = "yes"


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE ExistentialQuantification, RankNTypes #-}

-- 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"


{-# LANGUAGE ImplicitParams, ExistentialQuantification #-}

-- Both these two fail in 6.2.2

module ShouldCompile where

-- A record with an 'existential' context that binds no
-- type vars, so record selectors should be OK
data Test1 = (?val::Bool) => Test1 { name :: String }

instance Show Test1 where
    show p = name p

-- Same, but no record selector; GHC 6.2.2 failed because it tried
-- to derive generic to/from
data Test2 = (?val::Bool) => Test2 String
f (Test2 s) | ?val = s


{-# LANGUAGE MagicHash, BangPatterns #-}

-- Killed GHC 6.3 HEAD

module Bug where
import GHC.Base

foo v = let !(I# x#) = 7 * 7 in "Forty-Two"


-- 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 ShouldCompile where

class Foo a where
     foo :: a

instance Foo (a -> b) where
     foo = error "urk"

test :: ()
test = foo 1


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE UndecidableInstances, FlexibleInstances,
             MultiParamTypeClasses, FunctionalDependencies #-}
-- UndecidableInstances now needed because the Coverage Condition fails

-- Hugs failed this functional-dependency test
-- Reported by Iavor Diatchki Feb 05

module ShouldCompile where

data N0
newtype Succ n    = Succ n

class Plus a b c | a b -> c
instance Plus N0 n n
instance Plus a b c => Plus (Succ a) b (Succ c)

( # )              :: Plus x y z => x -> y -> z
( # )               = undefined

class BitRep t n | t -> n where
  toBits         :: t -> n

instance BitRep Bool (Succ N0) where
  toBits = error "urk"

instance BitRep (Bool,Bool,Bool) (Succ (Succ (Succ N0))) where
  toBits (x,y,z) = toBits x # toBits y # toBits z

-- Hugs complains that it cannot solve the constraint:
-- Plus (Succ N0) (Succ N0) (Succ (Succ N0))


{-# LANGUAGE TypeOperators, MultiParamTypeClasses, LiberalTypeSynonyms #-}

-- Test infix type constructors for type synonyms

module ShouldCompile where

infix 9 :-+-:
type (f :-+-: g) t o1 o2 = Either (f t o1 o2) (g t o1 o2)

data Foo a b c = Foo (a,b,c)

type App f = f Int Bool Int

f :: (Foo :-+-: Foo) Bool Int Bool
f = error "urk"

g :: App (Foo :-+-: Foo)
g = error "urk"

-------- classes --------

class (Eq a, Eq b) => a :&: b where
   op :: a -> b

h :: (a :&: b) => a -> b
h x = op x


{-# LANGUAGE NoMonoPatBinds #-}
        -- Disable experimental 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)


{-# LANGUAGE CPP, KindSignatures #-}

-- The record update triggered a kind error in GHC 6.2

module Foo where

import Data.Kind (Type)

data HT (ref :: Type -> Type)
  = HT { kcount :: Int }

set_kcount :: Int -> HT s -> HT s
set_kcount kc ht = ht{kcount=kc}


{-# LANGUAGE RankNTypes #-}

-- 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 polymorphic.
--    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)