{-# OPTIONS_GHC -dcore-lint -fdefer-typed-holes #-}
module T12947 where

import qualified Control.Monad.Fail as Fail

newtype P m a = P { unP :: (a -> IO (m ())) -> IO (m ()) }

instance Functor (P m) where

instance Applicative (P m) where

instance Monad (P m) where

instance (Fail.MonadFail m) => Fail.MonadFail (P m) where
  fail msg = ContT $ \ _ -> Fail.fail msg


{-# LANGUAGE RankNTypes #-}
module T12966 where
-- This should fail with a proper error message, not a compiler panic.
type Maybeify c = forall d. (c d) => ((~) (Maybe d))


{-# LANGUAGE RebindableSyntax, PolyKinds, ExplicitForAll #-}

module T12973 where

import qualified Prelude as P
import GHC.Exts

class Num (a :: TYPE r) where
  (+) :: a -> a -> a
  fromInteger :: P.Integer -> a

foo :: forall r (a :: TYPE r). Num a => a
foo = 3 + 4


module T13068 where
import T13068a
class C a where
    f :: a


module T13068a where
import {-# SOURCE #-} T13068
instance C Int where


{-# LANGUAGE BangPatterns #-}

module Main where

!(Just x) = Nothing

main = putStrLn "hi there!"


{-# LANGUAGE UnicodeSyntax, MagicHash, DataKinds, PolyKinds, TypeFamilies #-}

-- from Conal Elliott
-- Actually, this *should* work. But I want to put it in the testsuite
-- as a succeeding "compile_fail" test to make sure that we don't panic.

module RepRep where

import GHC.Exts

type family RepRep a âˆ· RuntimeRep

class HasRep a where
  type Rep a âˆ· TYPE (RepRep a)
  repr âˆ· a â†’ Rep a
  abst âˆ· Rep a â†’ a

type instance RepRep Int = IntRep

instance HasRep Int where
  type Rep Int = Int#
  abst n = I# n
  repr (I# n) = n


module Main where

import T13292a

-- main :: IO ()
main = someFunc


module T13292a( someFunc ) where

--someFunc :: IO ()
someFunc = return ()


{-# LANGUAGE GADTs #-}
module T13300 where

data W where
  WI :: Int
  WD :: Double

data Superblock
  = A { f :: W }
  | B { f :: W }


{-# LANGUAGE RankNTypes #-}
module T13311 where

f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b
f _ = mempty

g :: IO ()
g = do
  f
  putChar 'a'


{-# language ConstraintKinds, FlexibleContexts, TypeFamilies,
    UndecidableInstances, DeriveFunctor #-}

module T13320 where

import GHC.Exts        (Constraint)

data QCGen

newtype Gen a = MkGen { unGen :: QCGen -> Int -> a }
  deriving Functor

sized :: (Int -> Gen a) -> Gen a
sized f = MkGen (\r n -> let MkGen m = f n in m r n)

class Arbitrary a where
  arbitrary :: Gen a

type family X_Var Î¾

data TermX Î¾ = Var (X_Var Î¾)

type ForallX (Ï† :: * -> Constraint) Î¾ = ( Ï† (X_Var Î¾) )

-- This type signature used to be necessary to prevent the
-- type checker from looping.
-- genTerm :: ForallX Arbitrary Î¾ => Int -> Gen (TermX Î¾)
genTerm 0 = Var <$> arbitrary
genTerm n = Var <$> genTerm (n - 1)

instance ForallX Arbitrary Î¾ => Arbitrary (TermX Î¾) where
  arbitrary = sized genTerm


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{- # OPTIONS_GHC -fno-defer-type-errors #-}
module T13446 where

import Data.Coerce (Coercible)
import Data.Kind (Type, Constraint)
import GHC.TypeLits (Symbol)

data Dict :: Constraint -> Type where
  Dict :: a => Dict a

infixr 9 :-
newtype a :- b = Sub (a => Dict b)
instance a => Show (a :- b) where
  showsPrec d (Sub Dict) = showParen (d > 10) $ showString "Sub Dict"

class Lifting p f where
  lifting :: p a :- p (f a)

data Blah a = Blah

newtype J (a :: JType) = J (Blah (J a))
newtype JComparable a = JComparable (J (T (JTy a)))

instance Lifting JReference JComparable where
  lifting = Sub 'a'

class (Coercible a (J (JTy a))) => JReference a where
  type JTy a :: JType

type T a
  = 'Generic ('Iface "java.lang.Comparable") '[a]
data JType = Class Symbol
           | Generic JType [JType]
           | Iface Symbol
type JObject = J (Class "java.lang.Object")
instance JReference JObject where
  type JTy JObject = 'Class "java.lang.Object"


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}

module T13487 where

import Data.Kind (Constraint)
import GHC.TypeLits

data Foo a b where
  K :: Error a b => a -> b -> Foo a b

type family Error a b :: Constraint where
  Error Int Int = ()
  Error _   _   = TypeError ('Text "GHC panic in 3... 2... 1...")

foo = K 'a' 'b'


{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses #-}
module Bug where

class FunDep lista a | lista -> a
instance FunDep [a] a

singleton :: FunDep lista a => a -> lista
singleton _ = undefined

-- this error is expected:
--   Couldn't match type 'Char' with '()'
--   arising from a functional dependency between
--     constraint 'FunDep [Char] ()' arising from a use of 'singleton'
--     instance 'FunDep [a] a'
illTyped :: [Char]
illTyped = singleton ()
  {-  [W] FunDep [Char] () -}

-- but this one is not:
--   Couldn't match type '()' with 'Char'
--     arising from a functional dependency between constraints:
--       'FunDep [Char] Char' arising from a use of 'singleton' (in 'wellTyped')
--       'FunDep [Char] ()' arising from a use of 'singleton' (in 'illTyped')
wellTyped :: [Char]
wellTyped = singleton 'a'
  {-   [W] FunDep [Char] Char -}


{-# LANGUAGE MagicHash, UnboxedTuples #-}

module T13530 where

import GHC.Exts

g :: Int -> (# Int#, a #)
g (I# y) = (# y, undefined #)

f :: Int -> (# Int#, Int# #)
f x = g x


{-# LANGUAGE MagicHash #-}

module T13610 where

import GHC.Prim
import GHC.Types

main = do
    let primDouble = 0.42## :: Double#
    let double = 0.42 :: Double
    IO (\s -> mkWeakNoFinalizer# double () s)


{-# LANGUAGE MagicHash, UnboxedTuples #-}
import GHC.Prim
import GHC.Types

main = do
    let local = ()
    let null = 0## :: Word#
    let triple = (# local, null, null #)
    IO (\s -> case mkWeakNoFinalizer# triple () s of (# s, r #) -> (# s, () #))


{-# OPTIONS_GHC -dcore-lint -fdefer-typed-holes #-}
module T13640 where

import Prelude hiding ((.))

class Functor' f where
  map' :: (a -> b) -> f a -> f b

class Bifunctor' f where
  map2' :: (a -> b) -> f a c -> f b c

bimap' :: Bifunctor' f => (a -> b) -> (c -> d) -> (f a c -> f b d)
bimap' f g = map2' f . map'


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
module T13677 where

import GHC.Exts (Constraint)

data Dict a where
  Dict :: a => Dict a

foo :: Dict (Int ~ Int) => Int
foo = undefined


{-# LANGUAGE DeriveFunctor, TypeApplications #-}

module T13819 where

import Data.Coerce
import Control.Applicative

newtype A a = A (IO a)
  deriving Functor

instance Applicative A where
  pure = pure @(_ -> WrappedMonad A _) @(_ -> A _) pure

instance Monad A where


{-# LANGUAGE TypeApplications #-}
module T13902 where

f :: a -> a
f x = x

g :: Int
g = f @Int 42 5


{-# LANGUAGE PolyKinds #-}
module T13909 where

import Data.Kind

data Hm (k :: Type) (a :: k) :: Type

class HasName (a :: k) where
  getName :: proxy a -> String

instance HasName Hm where
  getName _ = "Hm"


{-# LANGUAGE MagicHash #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Main where

import GHC.Exts
import Data.Kind
import GHC.Generics

class GUnbox (f :: Type -> Type) (r :: RuntimeRep) where
    type GUnboxed f r :: TYPE r
    gunbox :: f p -> GUnboxed f r

instance (GUnbox f rf, GUnbox g rg) => GUnbox (f :*: g) ('TupleRep '[rf, rg]) where
    type GUnboxed (f :*: g) ('TupleRep '[rf, rg]) = (# GUnboxed f rf, GUnboxed g rg #)
    -- if I remove implementation of `gunbox` it compiles successfully
    gunbox (x :*: y) = (# gunbox x, gunbox y #)

instance (GUnbox f rf, GUnbox g rg) => GUnbox (f :+: g) ('SumRep '[rf, rg]) where
    type GUnboxed (f :+: g) ('SumRep '[rf, rg]) = (# GUnboxed f rf | GUnboxed g rg #)
    gunbox (L1 l) = (# gunbox l | #)
    gunbox (R1 r) = (# | gunbox r #)

main :: IO ()
main = pure ()


{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
module T13983 where

import Data.Proxy

type Wat = forall (a :: k). Proxy a


{-# LANGUAGE TypeFamilies #-}
module T14000 where

class C a where
    type T a
    c :: a -> T a

foo = c noSuchThing   -- noSuchThing is not in scope


{-# LANGUAGE ConstraintKinds #-}
module T14048a where

import Data.Kind

data Foo :: Constraint


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
module T14048b where

import Data.Kind

data family Foo :: Constraint


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
module T14048c where

import Data.Kind

data family   Foo :: k
data instance Foo :: Constraint


{-# LANGUAGE DataKinds, TypeFamilies #-}

newtype X = RollX (() -> X)

type family F t :: X where
    F t = RollX (t -> ())


module T14232 where

f :: (String -> a) String -> a
f g s = g s


{-# LANGUAGE GADTs, MultiParamTypeClasses #-}

module T14325 where

class (a~b) => C a b

foo :: C a b => a -> b
foo x = x

hm3 :: C (f b) b => b -> f b
hm3 x = foo x


{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds, DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module T14350 where

import Data.Kind

data Proxy a = Proxy
data family Sing (a :: k)

data SomeSing k where
  SomeSing :: Sing (a :: k) -> SomeSing k

class SingKind k where
  type Demote k :: Type
  fromSing :: Sing (a :: k) -> Demote k
  toSing   :: Demote k -> SomeSing k

data instance Sing (x :: Proxy k) where
  SProxy :: Sing 'Proxy

instance SingKind (Proxy k) where
  type Demote (Proxy k) = Proxy k
  fromSing SProxy = Proxy
  toSing Proxy = SomeSing SProxy

data TyFun :: Type -> Type -> Type
type a ~> b = TyFun a b -> Type
infixr 0 ~>

type family Apply (f :: k1 ~> k2) (x :: k1) :: k2
type a @@ b = Apply a b
infixl 9 @@

newtype instance Sing (f :: k1 ~> k2) =
  SLambda { applySing :: forall t. Sing t -> Sing (f @@ t) }

instance (SingKind k1, SingKind k2) => SingKind (k1 ~> k2) where
  type Demote (k1 ~> k2) = Demote k1 -> Demote k2
  fromSing sFun x = case toSing x of SomeSing y -> fromSing (applySing sFun y)
  toSing = undefined

dcomp :: forall (a :: Type)
                (b :: a ~> Type)
                (c :: forall (x :: a). Proxy x ~> b @@ x ~> Type)
                (f :: forall (x :: a) (y :: b @@ x). Proxy x ~> Proxy y ~> c @@ ('Proxy :: Proxy x) @@ y)
                (g :: forall (x :: a). Proxy x ~> b @@ x)
                (x :: a).
         Sing f
      -> Sing g
      -> Sing x
      -> c @@ ('Proxy :: Proxy x) @@ (g @@ ('Proxy :: Proxy x))
dcomp f g x = applySing f Proxy Proxy


module T14390 where

import Data.Type.Equality
instance (~~) Int Int


{-# Language TypeApplications #-}
{-# Language ImpredicativeTypes #-}
-- This isn't a test for impredicative types; it's
-- just that visible type application on a for-all type
-- is an easy way to provoke the error.
--
-- The ticket #14605 has a much longer example that
-- also fails; it does not use ImpredicativeTypes

module T14605 where

import GHC.Prim (coerce)

duplicate = coerce @(forall x. ()) @(forall x. x)


{-# OPTIONS_GHC -fdefer-type-errors #-}
    -- This line is crucial to the bug

{-# Language GADTs #-}
{-# Language InstanceSigs #-}
{-# Language KindSignatures #-}
{-# Language TypeFamilies #-}
{-# Language DataKinds #-}
{-# Language FlexibleInstances #-}

module T14607 where

import Data.Kind

data LamCons :: Type -> Type -> () -> Type where
  C :: LamCons a a '()

class Mk a where
  mk :: LamCons a a '()

instance Mk a where
  mk :: LamCons a '()
  mk = mk

-- At some point, this program was accepted. That's fine. But right now,
-- it's rejected with a kind error, and we can't generally defer kind
-- errors, so I'm saying that behavior is OK.

-- Later (May 18) the kind error ended up being in an term-level
-- implication constraint, which /does/ have an evidence binding
-- So now the kind error can be deferred.
-- Consequence of a fast-path for tcImplicitTKBndrsX I think.

-- Later (Nov 18) we are back to a kind error, which is fine


{-# LANGUAGE RankNTypes #-}

module T14618 where

safeCoerce :: a -> b
safeCoerce = f'
    where
        f :: d -> forall c. d
        f x = x

        f' = f


{-# LANGUAGE TypeOperators, GADTs #-}

-- Enable -Werror to fail in case we get this warning:
--
--   UNPACK pragma lacks '!' on the first argument of â€˜Aâ€™
--
-- In this test case we expect to get this warning and fail,
-- see T14761c for the opposite.
{-# OPTIONS -Werror #-}

module T14761a where

data A = A { a :: {-# UNPACK #-} Maybe Int }

data x && y = Pair x y

data B = B { b :: {-# UNPACK #-} Maybe Int && [] Char && Int }

data G where
  MkG2 :: {-# UNPACK #-} Maybe Int && [] Char && Int -> G


{-# LANGUAGE BangPatterns #-}

module T14761b where

data A = A { a :: ! Maybe Int}


module T14884 where

x :: IO ()
x = _ print "abc"


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
module T14904a where

import Data.Kind

type family F (f :: forall a. g a) :: Type where
  F (f :: forall a. g a) = Int


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
module T14904b where

import Data.Kind

type family F f :: Type where
  F ((f :: forall a. g a) :: forall a. g a) = Int


{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE DataKinds #-}

module T15067 where

import Type.Reflection

floopadoop :: TypeRep (# Bool | Int #)
floopadoop = typeRep


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeInType #-}
module T15330 where

import Data.Kind
import Data.Proxy

data T :: forall a. a -> Type

f1 :: Proxy (T True)
f1 = "foo"

f2 :: forall (t :: forall a. a -> Type).
      Proxy (t True)
f2 = "foo"


{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
module T15361 where

import Data.Kind
import Data.Type.Equality

-- Don't report (* ~ *) here
foo :: forall (a :: Type) (b :: Type) (c :: Type).
       a :~~: b -> a :~~: c
foo HRefl = HRefl

data Chumbawamba :: Type -> Type where
  IGetKnockedDown :: (Eq a, Ord a) => a -> Chumbawamba a

-- Don't report (Eq a) here
goo :: Chumbawamba a -> String
goo (IGetKnockedDown x) = show x


{-# LANGUAGE  MultiParamTypeClasses, RankNTypes #-}

module T15438 where

class C a b

foo :: (forall a b. C a b => b -> b) -> Int
foo = error "urk"


{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
module T15515 where

import Data.Kind
import Data.Proxy

class C a where
  c :: Proxy a

type family F

data D :: F -> Type

instance C (D :: F -> Type) where
  c = Proxy

c' :: Proxy (D :: F -> Type)
c' = c @(D :: F -> Type)


{-# LANGUAGE StrictData #-}

module T15523 where

newtype Duration = Foo
data Literal = LitDuration Duration


module T15527 where

f :: (Int -> Int) -> (Int -> Int) -> (Int -> Int)
f =  (.) @Int


{-# LANGUAGE DataKinds, ExistentialQuantification, GADTs, PolyKinds, TypeOperators #-}
{-# LANGUAGE TypeInType, TypeFamilies #-}
module T15552 where

import Data.Kind

data Elem :: k -> [k] -> Type

data EntryOfVal (v :: Type) (kvs :: [Type]) where
  EntryOfVal :: forall (v :: Type) (kvs :: [Type]) (k :: Type).
                Elem (k, v) kvs -> EntryOfVal v kvs

type family EntryOfValKey (eov :: EntryOfVal v kvs) :: Type

type family GetEntryOfVal (eov :: EntryOfVal v kvs) :: Elem (EntryOfValKey eov, v) kvs

type family FirstEntryOfVal (v :: Type) (kvs :: [Type]) :: EntryOfVal v kvs where


{-# LANGUAGE DataKinds, ExistentialQuantification, GADTs, PolyKinds, TypeOperators #-}
{-# LANGUAGE TypeInType, TypeFamilies #-}
{-  # LANGUAGE UndecidableInstances #-}
module T15552 where

import Data.Kind

data Elem :: k -> [k] -> Type where
  Here :: Elem x (x : xs)
  There :: Elem x xs -> Elem x (y : xs)

data EntryOfVal (v :: Type) (kvs :: [Type]) where
  EntryOfVal :: forall (v :: Type) (kvs :: [Type]) (k :: Type).
                Elem (k, v) kvs -> EntryOfVal v kvs

type family EntryOfValKey (eov :: EntryOfVal v kvs) :: Type where
  EntryOfValKey ('EntryOfVal (_ :: Elem (k, v) kvs)) = k

type family GetEntryOfVal (eov :: EntryOfVal v kvs)
            :: Elem (EntryOfValKey eov, v) kvs
  where
    GetEntryOfVal ('EntryOfVal e) = e

type family FirstEntryOfVal (v :: Type) (kvs :: [Type]) :: EntryOfVal v kvs
  where FirstEntryOfVal v (_ : kvs)
           = 'EntryOfVal (There (GetEntryOfVal (FirstEntryOfVal v kvs)))
--type instance FirstEntryOfVal v (_ : kvs)
--         = 'EntryOfVal ('There (GetEntryOfVal (FirstEntryOfVal v kvs)))


{-# LANGUAGE PolyKinds, TypeApplications, DataKinds, RankNTypes #-}

module T15592 where
import Data.Proxy

data VisProxy k (a :: k) = MkVP
class D (a :: Proxy j) (b :: Proxy k) c where
  meth1 :: forall z. D @j @k a b z => z -> Proxy '(a, b)
  meth2 :: Proxy k j -> Proxy '(a, b, c)


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
module Bug (f) where

import Data.Kind
import Data.Proxy

data TyFun :: Type -> Type -> Type
type a ~> b = TyFun a b -> Type
infixr 0 ~>

type family F x :: Type -> Type
data F1Sym :: forall x a. x ~> F x a
data F2Sym :: forall x a. F x a ~> x
data Comp :: forall b c a. (b ~> c) -> (a ~> b) -> (a ~> c)

sg :: forall a b c (f :: b ~> c) (g :: a ~> b) (x :: a).
      Proxy f -> Proxy g -> Proxy (Comp f g)
sg _ _ = Proxy

f :: forall (x :: Type). Proxy x -> ()
f _ = ()
  where
    g :: forall z ab. Proxy ((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab)
    g = sg Proxy Proxy


{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module T15648 where

import Data.Kind (Type)
import Data.Type.Equality (type (~~))
import T15648a (ueqT)

data LegitEquality :: Type -> Type -> Type where
  Legit :: LegitEquality a a

data JankyEquality :: Type -> Type -> Type where
  Jank :: $ueqT a b -> JankyEquality a b

unJank :: JankyEquality a b -> $ueqT a b
unJank (Jank x) = x

legitToJank :: LegitEquality a b -> JankyEquality a b
legitToJank Legit = Jank

mkLegit :: a ~~ b => LegitEquality a b
mkLegit = Legit

ueqSym :: forall (a :: Type) (b :: Type).
          $ueqT a b -> $ueqT b a
ueqSym = unJank $ legitToJank $ mkLegit @b @a


module T15648a where

import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax

ueqT :: Q Type
ueqT = conT $ mkNameG_tc "ghc-prim" "GHC.Prim" "~#"


{-# LANGUAGE FunctionalDependencies, FlexibleContexts #-}

module T15767 where

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

y = x where
  x :: (C () b, C Bool b) => b
  x  = f ()


{-# Language RankNTypes       #-}
{-# Language TypeFamilies     #-}
{-# Language TypeApplications #-}
{-# Language PolyKinds        #-}

module T15793 where
import Data.Kind

type family
  F1 (a :: Type) :: Type where
  F1 a = Maybe a

f1 :: F1 a
f1 = Nothing

type family
  F2 :: forall (a :: Type). Type where
  F2 @a = Maybe a


{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
module Bug where

newtype N a where
  MkN :: Show a => a -> N a
type family T a
type instance T (N a) = N a


{-# Language    RankNTypes          #-}
{-# Language    TypeFamilies        #-}
{-# Language    ScopedTypeVariables #-}
{-# Language    TypeApplications    #-}
{-# Language    DataKinds           #-}
{-# Language    PolyKinds           #-}
{-# Language    TypeOperators       #-}
{-# Language    GADTs               #-}
{-# Language    FlexibleInstances   #-}

module T15797 where
import Data.Kind

class RÃki (obj :: Type) where
  type Obj :: obj -> Constraint
  type Obj = BÃ¦ @k :: k -> Constraint

class    BÃ¦    (a :: k)
instance BÃ¦ @k (a :: k)

data
  EQ :: forall ob. ob -> ob -> Type where
  EQ :: EQ a a

instance
  RÃki (EQ @ob)


{-# Language CPP               #-}
{-# Language DataKinds         #-}
{-# Language RankNTypes        #-}
{-# Language PatternSynonyms   #-}
{-# Language TypeOperators     #-}
{-# Language PolyKinds         #-}
{-# Language GADTs             #-}
{-# Language TypeFamilies      #-}
{-# Language TypeApplications  #-}
{-# Language FlexibleContexts  #-}
{-# Language FlexibleInstances #-}
{-# Language InstanceSigs      #-}

module T15799 where
import qualified GHC.TypeLits as TypeLits
import GHC.TypeLits (Nat, KnownNat)
import Data.Kind

data Op obj = Op obj

type family
 UnOp (op_a :: Op obj) :: obj where
 UnOp ('Op obj) = obj

class
 RÃki (obj :: Type) where
 type (-->) :: Op obj -> obj -> Type
 type (<--) :: obj -> Op obj -> Type

 unop :: forall (a :: obj) (b :: obj). (a <-- 'Op b) -> ('Op b --> a)

data (<=) :: Op Nat -> Nat -> Type where
  LessThan :: (KnownNat (UnOp op_a), KnownNat b, UnOp op_a TypeLits.<= b)
           => (op_a <= b)

newtype (>=) :: Nat -> Op Nat -> Type where
  Y :: (a <= b) -> (b >= a)

instance RÃki Nat where
 type (-->) = (<=)
 type (<--) = (>=)

 unop :: (a >= b) -> (b <= a)
 unop GreaterThan = LessThan

pattern GreaterThan :: () => (KnownNat (UnOp b), KnownNat a, UnOp b <= a) => a >= b
pattern GreaterThan = Y LessThan


{-# Language CPP                   #-}
{-# Language QuantifiedConstraints #-}
{-# Language TypeApplications      #-}
{-# Language PolyKinds             #-}
{-# Language TypeOperators         #-}
{-# Language DataKinds             #-}
{-# Language TypeFamilies          #-}
{-# Language TypeSynonymInstances  #-}
{-# Language FlexibleInstances     #-}
{-# Language GADTs                 #-}
{-# Language UndecidableInstances  #-}
{-# Language MultiParamTypeClasses #-}
{-# Language FlexibleContexts      #-}

module Bug where
import Data.Coerce
import Data.Kind

type Cat ob = ob -> ob -> Type

type Obj = Type

class    Coercible (op_a --> b) (b <-- op_a) => (op_a -#- b)
instance Coercible (op_a --> b) (b <-- op_a) => (op_a -#- b)

class    (forall (op_a :: obj) (b :: obj). op_a -#- b) => OpOpNoOp obj
instance (forall (op_a :: obj) (b :: obj). op_a -#- b) => OpOpNoOp obj

class
  RÃki (obj :: Obj) where
  type (-->) :: obj -> obj -> Type

  iÃ° :: a --> (a::obj)

class
  OpOpNoOp obj
  =>
  OpRÃki (obj :: Obj) where
  type (<--) :: obj -> obj -> Type

data Op a = Op a

type family UnOp op where UnOp ('Op obj) = obj

newtype Y :: Cat (Op a) where
  Y :: (UnOp b --> UnOp a) -> Y a b

instance RÃki Type where
 type (-->) = (->)
 iÃ° x = x

instance OpRÃki (Op Type) where
 type (<--) @(Op Type) = Y @Type


{-# Language RankNTypes       #-}
{-# Language TypeApplications #-}
{-# Language PolyKinds        #-}
{-# Language GADTs            #-}

module T15807 where
import Data.Kind

data
  App :: forall (f :: k -> Type). k -> Type
  where
  MkApp :: f a -> App @f a


{-# Language TypeApplications #-}
{-# Language TypeFamilies        #-}

module T15816 where
import Data.Kind

data family U
data instance U @Int


--
-- Check that we produce only one error message for each type
-- signature. See ticket #1595.
--

module T1595 where

foo1, bar1 :: DoesNotExist
foo1 = undefined
bar1 = undefined

class Test a where
  foo2, bar2 :: a -> DoesNotExist


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
module T15954 where

import Data.Kind

type A a = Int
type B1 (a :: Type -> Type) = forall x. x -> x
type C1 = B1 A

data NonShow
type B2 (a :: Type -> Type) = Show NonShow => Int
type C2 = B2 A


{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}

module T15962 where

import Data.Kind (Type)

type Exp a = a -> Type
type family Eval (e :: Exp a) :: a

data OpKind = Conjunction

data Dual (k :: OpKind) :: Exp OpKind

data Map :: (a -> Exp b) -> [ a ] -> Exp [ b ]

type instance Eval (Map f (a ': as)) = Eval (f a) ': Eval (Map f as)

data Big :: [ OpKind ] -> Type where
  Big  :: [ Big ks ] -> Big ('Conjunction ': ks)

dualBig :: Big ks -> Big (Eval (Map Dual ks))
dualBig = _

instance Semigroup (Big a) where
  Big xs <> Big ys = Big (xs <> ys)

instance Monoid (Big ('Conjunction ': ks)) where
  mempty = iDontExist

flatten :: Monoid (Big ks) => Big (k ': k ': ks) -> Big ks
flatten = undefined


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
module T16059a where

type Foo b = Eq b => b

f :: forall b (a :: Eq b => b). Int
f = 27

g :: forall b (a :: Foo b). Int
g = 42


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UnboxedTuples #-}
module T16059b where

type Foo = forall a. a
type Bar = (# #)


module T16059c where

import T16059b

f :: Foo -> a -> f
f g x = g x


module T16059d where

import T16059b

type Bar' = Bar


module T16059e where

import T16059b

type Const a b = a

-- This is accepted, since the rank-n type `Foo` never makes it into the type
-- of `f` post-expansion...
f :: Const Int Foo -> Int
f _ = 42

-- ...but this *is* rejected, since `Foo` does make it into the type of `g`
-- post-expansion.
g :: Const Foo Foo -> Int
g _ = f 27


{-# LANGUAGE GADTs, TypeOperators, PolyKinds #-}

module T16074 where

import GHC.Types

data a :~: b where Refl :: a :~: a

foo :: TYPE a :~: TYPE b
foo = Refl


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module T16204c where

import Data.Kind

data family Sing :: forall k. k -> Type
type family Rep  :: Type

sTo :: forall (a :: Rep). Sing a
sTo = sTo

x :: forall (a :: Type). Sing a
x = id sTo


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module T16255 where

import Data.Kind
import GHC.TypeLits

data SBool :: Bool -> Type
type family F1 :: forall k. k -> Type where
  F1 @Bool = SBool

data family D1 :: forall k. k -> Type
-- Note that this similar-looking data family instance is OK, since data family
-- instances permit oversaturation in their equations.
data instance D1 @Bool :: Bool -> Type

type family F2 (x :: j) :: forall k. Either j k where
  F2 5 @Symbol = Left 4


{-# LANGUAGE FlexibleInstances #-}

-- This just tests what the kind error message looks like
-- Trac #1633

module T1633 where

instance Functor Bool


{-# LANGUAGE MultiParamTypeClasses #-}

module Foo where

class Wob a b where
   to :: a -> b
   from :: b -> a

foo x = [x, to (from x)]
-- Ambiguous type:  Wob a b => b -> [b]
-- Should be rejected


-- Test for Trac #1899

module T1899 where

 data Constraint a = Formula [[Proposition a]]
 data Proposition a = Prop a
                    | Auxiliary [Proposition a]

 transRHS :: [a] -> Int -> Constraint a
 transRHS varSet b =
     if b < 0
       then Formula [[Prop (Auxiliary undefined)]]
       else Formula $
                 [[Prop (Auxiliary varSet),
                   Prop (Auxiliary varSet)]
                 ]


-- Trac #2126

module Foo where

newtype X


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

module T2247 where

class FD a b | a -> b
instance CFD a b => FD a b

class {- FD a b => -} CFD a b
instance CFD Bool Char
instance CFD Bool Bool

f' :: FD Bool Bool => Bool
f' = True

g' :: FD Bool Char => Bool
g' = False

x = f'


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

-- Trac #2307

module ShouldFail where

 class C a b c | a -> b, a -> c
 instance C Int (Maybe String) Float
 instance C Int (Maybe Bool)   Double


module T2354(test) where

class AsInt a where
  {-# NOINLINE toInt #-}
  toInt   :: a -> Int
  {-# NOINLINE fromInt #-}
  fromInt :: Int -> a


-- Test for Trac #2414
-- Should provoke an occurs-check error

module ShouldFail where

unfoldr :: (b -> Maybe (Bool, b)) -> Bool
unfoldr = unfoldr

f = unfoldr Just


module T2534 where

foo = foldr (>>=) [] []


-- Trac #2538
module ShouldFail where
import Data.Ix

f :: (Eq a => a -> a) -> Int
f = error "urk"

g :: [Eq a => a -> a] -> Int
g = error "urk"

h :: Ix (Eq a => a -> a) => Int
h = error "urk"


{-# OPTIONS_GHC -XFunctionalDependencies -XMultiParamTypeClasses #-}

module T2688 where

class VectorSpace v s | v -> s where
    (*^)    :: s -> v -> v
    (^/)    :: v -> s -> v
    v ^/ s = v *^ (1/s)


{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}

-- Trac #2714

module T2714 where

f :: ((a -> b) -> b) -> (forall c. c -> a)
f = ffmap

ffmap :: Functor f => (p->q) -> f p -> f q
ffmap = error "urk"

{-
   a ~ f q
   c ~ f p
   (p->q) ~ (a->b) -> b

 =>
   a ~ f q
   c ~ f p
   p ~ a->b
   q ~ b
 =>
   a ~ f b
   c ~ f (a->b)
-}


{-# LANGUAGE MagicHash #-}
{-# OPTIONS_GHC -Wunbanged-strict-patterns #-}

-- Trac #2806

module Foo where

import GHC.Base

foo :: Int
foo = 3
    where (I# _x) = 4


{-# LANGUAGE ImpredicativeTypes, FlexibleContexts #-}
module T2846 where

f :: String
f = show ([1,2,3] :: [Num a => a])


{-# LANGUAGE MultiParamTypeClasses #-}

-- Trac #2994

module T2994 where

class MonadReader a b

newtype Reader' r a = Reader' (r -> a)

instance MonadReader Int

instance MonadReader (Reader' r)

instance MonadReader r r (Reader' r)


{-# OPTIONS -XImplicitParams -XRankNTypes #-}
module Bug where

t :: forall a. ((?p :: Int) => a) -> String
t _ = "Hello"

f :: (forall a. a -> String) -> Int
f _ = 3

result :: Int
result = f t

-- This should work.
-- Elaborated result = f (/\a. \x:a. t @a (\p::Int. x))
-- But it did not work in 8.0.1; fixed in HEAD


{-# LANGUAGE GADTs, TypeOperators #-}
module T3155 where

-- Test Trac #3155
-- Gave bad error message in GHC 6.10

data Any s where
  Any :: s ix -> ix -> Any s

data AnyR s r where
  AnyR :: s ix -> r ix -> AnyR s r

unR :: (forall ix. r ix -> ix) -> AnyR s r -> Any s
unR f (AnyR ix rix) = Any ix (f rix)


{-# LANGUAGE ExistentialQuantification #-}

-- Trac #3176

module Foo where

data ES = forall a. Show a => ES {unES:: a}

smallPrintES f t = show $ unES $ f t


-- Trac #3323
module T3323 where

import GHC.IO.Handle.Types
import GHC.IO.Handle.Internals

-- The point here is that Handle__ is an existential type,
-- so the haDevice field can't be updated.
--
-- The bug was that, haDevice is a "naughty" selector, we
-- couldn't find its type constructor.
--
-- This only happened when you go via an interface file, which is why
-- this test imports an existential.  To make the test more
-- standalone, you'd need to make it a two-module test

f :: Handle__ -> Handle__
f h = h {haDevice=undefined}


{-# LANGUAGE ScopedTypeVariables #-}

-- Trac #3406
-- A pattern signature that discards the bound variables

module T3406 where

type ItemColID a b = Int  -- Discards a,b

get :: ItemColID a b -> a -> ItemColID a b
get (x :: ItemColID a b) = x :: ItemColID a b


{-# LANGUAGE ExistentialQuantification #-}

module T3468 where

import T3468a

data Tool d = forall a r . F a


module T3468a where

import {-# SOURCE #-} T3468


{-# LANGUAGE ImplicitParams, TypeFamilies #-}
module T3540 where

thing ::  (a~Int)
thing = undefined

thing1 ::  Int -> (a~Int)
thing1 = undefined

thing2 ::  (a~Int) -> Int
thing2 = undefined

thing3 :: (?dude :: Int) -> Int
thing3 = undefined

thing4:: (Eq a) -> Int
thing4 = undefined


{-# LANGUAGE RankNTypes #-}

module T3592 where

type T a = Show a => a

f :: T a -> String
f = show

g :: T a -> String
g x = show x


-- c.f Trac #3613

module T3613 where

import Control.Monad

foo :: Maybe ()
foo = return ()

bar :: IO ()
bar = return ()

fun1 = let fooThen m = foo>> m
       in fooThen (bar>> undefined)

fun2 = let fooThen m = foo>> m
       in fooThen (do {bar; undefined})


{-# LANGUAGE GADTs #-}

module T3950 where

-- Id :: (* -> * -> *) -> * -> * -> *
data Id p x y = Id (p x y)

-- Sealed :: (* -> *) -> *
data Sealed p where
    Sealed :: p x -> Sealed p

-- w :: (* -> * -> *) -> *
-- Id p :: * -> * -> *
rp :: Bool -> Maybe (w (Id p))
rp _ = Just rp'
     where rp' :: Sealed (Id p x)
           rp' = undefined


{-# OPTIONS_GHC -Werror #-}

module T3966 where

data Foo a b = Foo {-# UNPACK #-} !(a -> b)


 {-# OPTIONS  -XMultiParamTypeClasses  -XFunctionalDependencies  -XFlexibleInstances #-}
module HaskellBug where

data Relation c -- The basic Relation
      = Rel { relnm :: String -- The name of the relation
            , relsrc :: c -- Source concept
            , reltrg :: c -- ^Target concept
            }
        deriving Eq

-- This declaration is ok; should not get an error here
class (Eq concept)=> Association rel concept | rel -> concept where
     source, target :: rel -> concept
      -- e.g. Declaration Concept -> Concept
     sign  :: rel -> (concept,concept)
     sign x = (source x,target x)
     homogeneous :: rel -> Bool
     homogeneous s = source s == target s

instance (Eq c)=>Association (Relation c) c where
     source = relsrc
     target = reltrg

-- This declaration has a kind error
-- The error should be reported here
class (Eq c, Association r c) => Morphic r c where
     multiplicities :: r c -> [c]
     multiplicities _ = []


{-# LANGUAGE MultiParamTypeClasses #-}
module T4921 where

class C a b where
    f :: (a,b)

instance C Int Char where
    f = undefined

x = fst f

y = fst f :: Int


{-# LANGUAGE FlexibleInstances #-}

-- A very delicate interaction of overlapping instances

module T5051 where

data T = T deriving( Eq, Ord )
instance {-# OVERLAPPING #-} Eq [T]

foo :: Ord a => [a] -> Bool
foo x = x >= x

-- Bizarrely, the defn of 'foo' failed in GHC 7.0.3 with
-- T5051.hs:14:10:
--    Overlapping instances for Eq [a]
--      arising from a use of `>'
--    Matching instances:
--      instance Eq a => Eq [a] -- Defined in GHC.Classes
--      instance [overlap ok] Eq [T] -- Defined at T5051.hs:9:10-15
--    (The choice depends on the instantiation of `a'
--     To pick the first instance above, use -XIncoherentInstances
--     when compiling the other instance declarations)
--    In the expression: x > x
--
-- Reason: the dfun for Ord [a] (in the Prelude) had a "silent"
-- superclass parameter, thus
--     $dfOrdList :: forall a. (Eq [a], Ord a) => Ord [a]
-- Using the dfun means we need Eq [a], and that gives rise to the
-- overlap error.
--
-- This is terribly confusing: the use of (>=) means we need Ord [a],
-- and if we have Ord a (which we do) we should be done.
-- A very good reason for not having silent parameters!
-- But, alas, we need them!
--
-- Dec 14: now we don't have them any more, the test passes!


module T5084 where

-- Superclass method pragma test (fail)
class Foo a where
    bar :: a -> a
    {-# INLINE bar #-}

-- Instance test (ok)
instance Foo Int where
    bar = (+1)
    {-# INLINE bar #-}


{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}

module Test where

instance {-# OVERLAPPABLE #-} Show a => Eq a where
   x == y =  length (show x) == length (show y)

f :: Show a => a -> a -> Bool
f x y = x == y

p = f (3 :: Int) 4


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

module T5236 where

data A
data B

class Id a b | a -> b, b -> a

instance Id A A
instance Id B B

-- The fundeps mean that this type signature
-- has a (derived) insoluble Given, A~B, but
-- we now ignore that (Trac #12466)
loop :: Id A B => Bool
loop = True

-- f :: Bool
-- f = loop


{-# LANGUAGE ImplicitParams #-}

-- Produced a duplicated error message in 7.0

module T5246 where

foo :: (?x :: Int) => a
foo = undefined

bar = let ?x = "hello"
      in foo


{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-}
module T5300 where

import Control.Monad.Trans.State (StateT)

class C1 a b c | a -> b
class C2 a b c

data T b = T

f1 :: (Monad m, C1 a b c) => a -> StateT (T b) m a
f1 f = undefined

f2 :: (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) => a1 -> StateT (T b2) m a2
f2 fm = f1 fm >>= return . undefined


{-# LANGUAGE MagicHash #-}
module T5570 where

import GHC.Exts

main :: IO ()
main = print $ D# $ 3.0##


{-# OPTIONS -XFunctionalDependencies -XUndecidableInstances -XFlexibleInstances #-}

module T5684 where

class B a b | a -> b where
  op :: a -> b -> ()

class A a | -> a

instance A b => B Bool b

{- This used to be a bug in various versions of GHC <= 7.2.2
   The source of the problem is the kicking out of inert Solved goals back to
   the worklist, which violated our invariant that when two constraints of the
   same class meet (workitem-inert) then the combination (Given-Wanted) is impossible.
   Actually it turns our that it is possible. The order in which the constraints appear
   below is important so we add two combinations to make sure that the testcase is
   order-insensitive. -}

flop1 =  [ op False False    -- (3) Creates a functional dependency which kicks the solved out
                             --     back in the worklist. Next time round the solved workitem
                             --     meets the wanted from stage (2) and boom, the assertion fails!

         , op 'c' undefined  -- (2) Creates a ([W] B Char beta) permanently in inerts
         , op True undefined -- (1) Creates ([W] B Bool alpha)
                             -- which immediately becomes [S] B Bool alpha
         ]

flop2 =  [ op False False
         , op True undefined
         , op 'c' undefined
         ]

flop3 =  [ op 'c' undefined
         , op True undefined
         , op False False
         ]

flop4 =  [ op 'c' undefined
         , op False False
         , op True undefined
         ]

flop5 =  [ op True undefined
         , op 'c' undefined
         , op False False
         ]

flop6 =  [ op True undefined
         , op False False
         , op 'c' undefined
         ]

{- Now, in HEAD we no longer have cached GivenSolved goals in the inerts and hence
   this situation can no longer appear. If a Given gets kicked out it is only because
   it got rewritten by a given equality: Notice that since Givens now never contain
   plain old unification variables (since they are not GivenSolveds!) they can never be
   rewritten by a spontaneously solved either! So our invariant now holds. -}


{-# LANGUAGE ScopedTypeVariables #-}

module Main where
import Data.IORef

main :: IO ()
main = do { (r :: IORef (t -> t)) <- newIORef id
             -- r <- newIORef i -- => Type-check error

          ; writeIORef r (\v -> if v then False else True)

          ; c <- readIORef r

          ; print $ c True
          ; print $ c 1234 }


{-# LANGUAGE ScopedTypeVariables #-}

module GHCBug where

import Control.Applicative as Ap
import Control.Monad (MonadPlus, mplus, mzero)
import Data.Functor.Identity (Identity, runIdentity)

newtype PrintRuleInterp v = MkPRI { printRule_ :: Int -> String }
class Test p where
  test :: p a -> p a

instance Test PrintRuleInterp where
  test (f :: p a) =
    MkPRI $ printRule_ f

newtype RecDecParser a = MkRD {
  parseRD :: String -> [(String, a)]
  }

pure_ v = MkRD $ \s -> pure (s , v)

instance MonadPlus RecDecParser where
  mzero = MkRD $ const Ap.empty
  mplus a b = MkRD $ const Ap.empty


{-# LANGUAGE NoImplicitPrelude, TypeFamilies #-}

module T5853 where
import Prelude (undefined,Bool(..),Show(..),(.))

type family Elem f :: *
type family Subst f b :: *

class (Subst fa (Elem fa) ~ fa) => F fa where
        (<$>) :: (Elem fa ~ a, Elem fb ~ b,
                  Subst fa b ~ fb, Subst fb a ~ fa) =>
                         (a -> b) -> (fa -> fb)

{-# RULES
 "map/map" forall f g xs. f <$> (g <$> xs) = (f.g) <$> xs
        #-}


{-# LANGUAGE FlexibleInstances, GADTs #-}
module T5858 where

class InferOverloaded a where
  infer :: a -> String

-- instance (t1 ~ String, t2 ~ String) => InferOverloaded (t1,t2) where
instance (t1 ~ String) => InferOverloaded (t1,t1) where
  infer = show . fst

foo = infer ([],[])


module T5957 where

flex :: Int -> Show a => a -> String
flex i a = show a ++ show i


{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
module T5978 where

class C from to | from -> to where

instance C Float Char where
instance C Double Bool where

polyFoo :: (C from to) => from
polyFoo = undefined

polyBar ::
   (C fromA toA, C fromB toB) =>
   (toA -> toB) ->
   fromA -> fromB
polyBar = undefined

monoBar :: Double
monoBar = polyBar id monoFoo
-- fromA = Float, fromB = Double, toA = toB
-- [W] C Float to, C Double to
-- => [D] to ~ Char, [D] to ~ Bool

monoFoo :: Float
monoFoo = polyFoo


{-# LANGUAGE InstanceSigs #-}

module T6001 where

data DayKind = Work | Rest

instance Num DayKind where
  fromInteger :: Int -> DayKind
  fromInteger = undefined


{-# LANGUAGE TypeFamilyDependencies #-}

module T6018Afail where

import Data.Kind (Type)

type family G a b c = (result :: Type) | result -> a b c
type instance G Int  Char Bool = Bool
type instance G Char Bool Int  = Int


{-# LANGUAGE TypeFamilyDependencies #-}

module T6018Bfail where

import Data.Kind (Type)

type family H a b c = (result :: Type) | result -> a b c


{-# LANGUAGE TypeFamilies #-}

module T6018Cfail where

import T6018Bfail

type instance H Int  Char Bool = Bool
type instance H Char Bool Int  = Int


{-# LANGUAGE TypeFamilies #-}

module T6018Dfail where

import T6018Bfail

type instance H Bool Int  Char = Int


{-# LANGUAGE TypeFamilyDependencies, DataKinds, UndecidableInstances, PolyKinds,
             MultiParamTypeClasses, FlexibleInstances #-}

module T6018fail where

import Data.Kind (Type)

import T6018Afail -- defines G, identical to F
import T6018Cfail -- imports H from T6018Bfail, defines some equations for H
import T6018Dfail -- imports H from T6018Bfail, defines conflicting eqns

type family F a b c = (result :: Type) | result -> a b c
type instance F Int  Char Bool = Bool
type instance F Char Bool Int  = Int
type instance F Bool Int  Char = Int

type instance G Bool Int  Char = Int

type family I a b c = r | r -> a b
type instance I Int  Char Bool = Bool
type instance I Int  Int  Int  = Bool
type instance I Bool Int  Int  = Int

-- Id is injective...
type family Id a = result | result -> a
type instance Id a = a

-- ...but despite that we disallow a call to Id
type family IdProxy a = r | r -> a
type instance IdProxy a = Id a

data N = Z | S N

-- P is not injective, although the user declares otherwise. This
-- should be rejected on the grounds of calling a type family in the
-- RHS.
type family P (a :: N) (b :: N) = (r :: N) | r -> a b
type instance P  Z    m = m
type instance P (S n) m = S (P n m)

-- this is not injective - not all injective type variables mentioned
-- on LHS are mentioned on RHS
type family J a b c = r | r -> a b
type instance J Int b c = Char

-- same as above, but tyvar is now nested inside a tycon
type family K (a :: N) (b :: N) = (r :: N) | r -> a b
type instance K (S n) m = S m

-- Make sure we look through type synonyms to catch errors
type MaybeSyn a = Id a
type family L a = r | r -> a
type instance L a = MaybeSyn a

-- These should fail because given the RHS kind
-- there is no way to determine LHS kind
class PolyKindVarsC a where
    type PolyKindVarsF a = (r :: k) | r -> a

instance PolyKindVarsC '[] where
    type PolyKindVarsF '[] = '[]

type family PolyKindVars (a :: k0) = (r :: k1) | r -> a
type instance PolyKindVars '[] = '[]

-- This should fail because there is no way to determine k from the RHS
type family Fc (a :: k) (b :: k) = r | r -> k
type instance Fc a b = Int

-- This should fail because there is no way to determine a, b and k from the RHS
type family Gc (a :: k) (b :: k) = r | r -> a b
type instance Gc a b = Int

-- fails because injectivity is not compositional in this case
type family F1 a = r | r -> a
type instance F1 [a]       = Maybe (GF1 a)
type instance F1 (Maybe a) = Maybe (GF2 a)

type family GF1 a = r | r -> a
type instance GF1 Int = Bool

type family GF2 a = r | r -> a
type instance GF2 Int = Bool

type family HF1 a
type instance HF1 Bool = Bool

type family W1 a = r | r -> a
type instance W1 [a] = a

type family W2 a = r | r -> a
type instance W2 [a] = W2 a

-- not injective because of infinite types
type family Z1 a = r | r -> a
type instance Z1 [a]       = (a, a)
type instance Z1 (Maybe b) = (b, [b])

type family G1 a = r | r -> a
type instance G1 [a]       = [a]
type instance G1 (Maybe b) = [(b, b)]

type family G3 a b = r | r -> b
type instance G3 a Int  = (a, Int)
type instance G3 a Bool = (Bool, a)

type family G4 a b = r | r -> a b
type instance G4 a b = [a]

type family G5 a = r | r -> a
type instance G5 [a] = [GF1 a] -- GF1 injective
type instance G5 Int = [Bool]

type family G6 a = r | r -> a
type instance G6 [a]  = [HF1 a] -- HF1 not injective
type instance G6 Bool = Int

type family G7a a b (c :: k) = r | r -> a b
type family G7 a b (c :: k) = r | r -> a b c
type instance G7 a b c = [G7a a b c]

class C a b where
    type FC a (b :: Type) = r | r -> b
    type instance FC a b = b

instance C Int Char where
    type FC Int Char = Bool

-- this should fail because the default instance conflicts with one of the
-- earlier instances
instance C Int Bool {- where
    type FC Int Bool = Bool-}

-- and this should fail because it violates "bare variable in the RHS"
-- restriction
instance C Char a


{-# LANGUAGE TypeFamilyDependencies, DataKinds, PolyKinds,
             UndecidableInstances #-}
module T6018failclosed where

-- Id is injective...
type family IdClosed a = result | result -> a where
    IdClosed a = a

-- ...but despite that we disallow a call to Id
type family IdProxyClosed (a :: *) = r | r -> a where
    IdProxyClosed a = IdClosed a

data N = Z | S N

-- PClosed is not injective, although the user declares otherwise. This
-- should be rejected on the grounds of calling a type family in the
-- RHS.
type family PClosed (a :: N) (b :: N) = (r :: N) | r -> a b where
    PClosed  Z    m = m
    PClosed (S n) m = S (PClosed n m)

-- this is not injective - not all injective type variables mentioned
-- on LHS are mentioned on RHS
type family JClosed a b c = r | r -> a b where
    JClosed Int b c = Char

-- this is not injective - not all injective type variables mentioned
-- on LHS are mentioned on RHS (tyvar is now nested inside a tycon)
type family KClosed (a :: N) (b :: N) = (r :: N) | r -> a b where
    KClosed (S n) m = S m

-- hiding a type family application behind a type synonym should be rejected
type MaybeSynClosed a = IdClosed a
type family LClosed a = r | r -> a where
    LClosed a = MaybeSynClosed a

type family FClosed a b c = (result :: *) | result -> a b c where
    FClosed Int  Char Bool = Bool
    FClosed Char Bool Int  = Int
    FClosed Bool Int  Char = Int

type family IClosed a b c = r | r -> a b where
    IClosed Int  Char Bool = Bool
    IClosed Int  Int  Int  = Bool
    IClosed Bool Int  Int  = Int

type family E2 (a :: Bool) = r | r -> a where
  E2 False = True
  E2 True  = False
  E2 a     = False

-- This exposed a subtle bug in the implementation during development. After
-- unifying the RHS of (1) and (2) the LHS substitution was done only in (2)
-- which made it look like an overlapped equation. This is not the case and this
-- definition should be rejected. The first two equations are here to make sure
-- that the internal implementation does list indexing corrcectly (this is a bit
-- tricky because the list is kept in reverse order).
type family F a b  = r | r -> a b where
  F Float  IO      = Float
  F Bool   IO      = Bool
  F a      IO      = IO a   -- (1)
  F Char   b       = b Int  -- (2)

-- This should fail because there is no way to determine a, b and k from the RHS
type family Gc (a :: k) (b :: k) = r | r -> k where
    Gc a b = Int


{-# LANGUAGE TypeFamilyDependencies  #-}

module T6018failclosed2 where

-- this one is a strange beast. Last equation is unreachable and thus it is
-- removed. It is then impossible to typecheck barapp and thus we generate an
-- error
type family Bar a = r | r -> a where
    Bar Int  = Bool
    Bar Bool = Int
    Bar Bool = Char

bar :: Bar a -> Bar a
bar x = x

barapp :: Char
barapp = bar 'c'


{-# LANGUAGE Rank2Types #-}

module T6069 where

import Control.Monad.ST
import Data.STRef

fourty_two :: forall s. ST s Int
fourty_two = do
   x <- newSTRef (42::Int)
   readSTRef x

f1 = (print . runST) fourty_two -- (1)
f2 = (print . runST) $ fourty_two -- (2)
f3 = ((print . runST) $) fourty_two -- (3)


{-# LANGUAGE BangPatterns #-}
module T6078 where

import GHC.Ptr
import Foreign

byteStringSlice len = \fpbuf ip0 ipe s0 ->
     let ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len
     -- Note that the panic goes away if we use a bang-pattern as follows
     -- let !ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len
     in  ip1p


{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances #-}

module T6161 where

data family Fam  a

data instance Fam Float = FamFloat Float

class Super a where
  testSup :: a -> Float

class Super a => Duper a where
  testDup :: a -> Float

--class ( Super (Fam a) ) => Foo a where
class Duper (Fam a) => Foo a where
  testFoo :: Fam a -> Float

instance Foo a => Duper (Fam a) where
  testDup x = testFoo x + testSup x

--instance Super (Fam Float) where
--  testSup (FamFloat x) = x

instance Foo Float where
  testFoo (FamFloat _) = 5.0

testProg :: Float
testProg = testDup (FamFloat 3.0)

{- Reasoning:

dfDuperFam :: Foo a -> Duper (Fam a)
dfDuperFam d = Duper (sc (sc d)) (...testDup...)

dfFooFloat :: Foo Float
dfFooFloat = Foo (dfDuperFloat dx) ...

dx :: Foo Float
dx = dfFooFloat

[W] d1 :: Duper (Fam Float)

    -- Use Duper instnance
    d1 = dfDuperFam d2
[W] d2 :: Foo Float
-}


{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE ConstraintKinds      #-}
{-# LANGUAGE UndecidableInstances #-}

module T7019a where

newtype Free c a = Free { runFree :: forall r. c r => (a -> r) -> r }

type C c = forall a. c (Free c a)

-- Notice that C is a synonym, illegal!
instance C c => Monad (Free c) where
  return a = Free ($ a)
  Free f >>= g = f g


{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE RankNTypes           #-}

module T7019a where

class Context c where
  func1 :: c -> String

-- Illegal forall in context
class (forall b. Context (Associated a b)) => Class a where
  data Associated a :: * -> *


{-# LANGUAGE TypeFamilies, GADTs #-}

module T7175 where

type family F a

data G1 a where
   G1C :: F Int

data G2 a where
   G2C :: F Int


module T7210 where

import Data.IntMap

data T = C { f :: !IntMap Int }


{-# LANGUAGE RankNTypes #-}
module T7264 where

data Foo = Foo (forall r . r -> String)

mmap :: (a->b) -> Maybe a -> Maybe b
mmap f (Just x) = Just (f x)
mmap f Nothing  = Nothing

-- mkFoo2 :: (forall r. r -> String) -> Maybe Foo
-- Should be rejected because it requires instantiating
-- mmap at a polymorphic type
mkFoo2 val = mmap Foo (Just val)


{-# LANGUAGE UndecidableInstances #-}
module T7279 where

data T a = MkT

instance (Eq a, Show b) => Eq (T a)


module T7368 where

f  = b  (l  Nothing)

l :: b a -> c b
l = undefined

b :: (a -> b) -> c
b = undefined


{-# LANGUAGE Rank2Types, KindSignatures #-}
module T7368 where

newtype Bad w = Bad (forall a. (w a -> a))
-- Bad :: forall w. (forall a. w a -> a) -> Bad w

fun :: forall (f :: * -> *). f (Bad f) -> Bool
fun (Bad x) = True

{-  f (Bad f) ~ Bad w
-->
    f ~ Bad
    Bad f ~ w
-}


module T7410 where

foo :: (Either Int, Int)
foo = foo


{-# LANGUAGE DefaultSignatures, FlexibleContexts, DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}

module T7437 where

import GHC.Generics

class GPut f where
    gput :: f a -> [()]

class Put a where
    put :: a -> [()]

    default put :: (Generic t, GPut (Rep t)) => t -> [()]
    put = gput . from


module T7453 where

newtype Id a = Id { runId :: a }

-- cast1 :: a -> b
cast1 v = runId z
    where z :: Id t
          z = aux
              where aux = Id v

-- cast2 :: a -> b
cast2 v = z ()
    where z :: () -> t
          z = aux
              where aux = const v

-- cast3 :: a -> b
cast3 v = z
    where z :: t
          z = v
              where aux = const v

cast1' :: a -> b
cast1' = cast1

cast2' :: a -> b
cast2' = cast2

cast3' :: a -> b
cast3' = cast3


{-# LANGUAGE ImplicitParams #-}
module T7525 where

hmm :: Bool
hmm = let ?a = True in ?a && ?b

{- The error message should say

    Could not deduce (?b::Bool)
      arising from a use of implicit parameter `?b'
    from the context (?a::Bool)

That is, the context should be (?a :: Bool) not (?a :: t0).
-}


{-# LANGUAGE RankNTypes, InstanceSigs #-}
module T7545 where

class C a where
   f :: a -> b

-- This is now accepted because the instance signature is more general
instance C (a -> b) where
   f :: x
   f = undefined


{-# LANGUAGE TypeOperators #-}

module T7609 where

data X a b

f :: (a `X` a, Maybe)
f = undefined

g :: (a `X` a) => Maybe
g = undefined


{-# LANGUAGE TypeOperators, KindSignatures #-}
module T7645 where

import Data.Kind

data (+) a b = P

f :: ((+) a (a :: Type), Maybe)
f = undefined


module T7697 where

f :: Int => Int
f x = x


module T7734 where

x `f` y = x x
(&) x y = x x


-- Correct type, which is inferred by GHC 7.6.1 and
-- works fine with GHC 7.6.2:
-- test :: Maybe (Maybe (r -> ())) -> r -> ()

-- Incorrect type, resulting in a runtime <<loop>>,
-- inferred by GHC 7.6.2 and also accepted by GHC 7.6.1:
-- test :: a -> r -> ()

module T7748a where

test :: a -> r -> ()
test zd
 = let f = let g = case zd of
                       Nothing       -> const ()
                       Just Nothing  -> const ()
                       Just (Just p) -> p
           in  g
   in f

{-
There is a bug in the type checker of 7.6.1 and 7.6.2, which accepts
an incorrect type resulting in <<loop>> at runtime. Furthermore, 7.6.2
even automatically infers this incorrect type. Hence, the attached
code has the following behavior:

- No explicit type: Code works in 7.6.1, loops in 7.6.2
- Correct explicit type: Code works fine in 7.6.1 and 7.6.2
- Incorrect explicit type: Code loops in 7.6.1 and 7.6.2

The incorrect type has a parameter that is too polymorphic, i.e. an
"a" type is accepted while the function does a pattern match on the
parameter from which it is clear that it should be a Maybe type. In
7.4.* versions this incorrect type is not accepted.
-}


module T7778 where

v :: ((Num Int => Num) ()) => ()
v = v


{-# LANGUAGE RankNTypes, TypeFamilies, LiberalTypeSynonyms #-}
module T7809 where

type PolyId = (forall a. a -> a)

type family F a

foo :: F PolyId
foo = undefined


module T7851 where

import Control.Monad.Trans.State

bar = do print
         print "Hello"


module T7856 where

tmp :: String -> IO ()
tmp = sequence_ lst
  where lst = [putStrLn "hi"]

-- sequence_ :: Monad m => [m a] -> m ()

{-    m () ~ (->) String (IO ())    -- From result of sequence_
      m a  ~ IO ()                  -- From argument of sequence_

Depends which one gets treated first.
  m := IO
is better than
  m := (->) String
It's a bit random which is chosen.

I'll put it in regression suite so we see if it wobbles around.
-}


module T7857 where

import Text.Printf

f :: a -> b
f = undefined

g i = f $ printf "" i


module T7869 where

f = (\x -> f x) :: [a] -> b


{-# LANGUAGE TypeFamilies #-}
module T7892 where

class C (f :: * -> *) where
   type F (f :: *) :: *


{-# LANGUAGE PolyKinds, FlexibleContexts, TypeFamilies #-}
module T8030 where

-- The types of op1 and op2 are both ambiguous
-- and should be reported as such

class C (a :: k) where
  type Pr a :: *
  op1 :: Pr a
  op2 :: Pr a -> Pr a -> Pr a


{-# LANGUAGE TypeFamilies #-}
module T8034 where

class C a where
  type F a
  foo :: F a -> F a


{-# LANGUAGE GADTs, TypeFamilies #-}

module T8044 where

data X a where
  XInt :: X Int
  XBool :: X Bool
  XChar :: X Char

type family Frob a where
  Frob Int = Int
  Frob x   = Char

frob :: X a -> X (Frob a)
frob XInt = XInt
frob _    = XChar


{-# LANGUAGE TypeFamilies #-}

module T8142 where

tracer :: (Functor f, Coinductive f) => (c -> f c) -> (c -> f c)
tracer = h where h = (\(_, b) -> ((outI . fmap h) b)) . out

class Functor g => Coinductive g where
  type Nu g :: *
  out     :: Nu g -> g (Nu g)
  outI    :: g (Nu g) -> Nu g


{-# LANGUAGE MagicHash #-}

module T8262 where

foo x = Just (1#)


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NegativeLiterals #-}

type T = -1


{-# LANGUAGE GADTs, AllowAmbiguousTypes #-}
module T8392a where

-- Should complain even with AllowAmbiguousTypes
--
-- But (Trac #12466) we now don't complain about
-- contradictory signatures
-- Instead we get a redundant pattern-match warning,
-- in the post-typechecking pattern-match checks
foo :: (Int ~ Bool) => a -> a
foo x = x


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ImpredicativeTypes #-}

module T8428 where

import Control.Monad.ST

data IdentityT m a = IdentityT { runIdentityT :: m a }

runIdST :: IdentityT (forall s. ST s) a -> a
runIdST = runST . runIdentityT
-- Test formatting in the error message.
-- In fact this should be rejected as a kind error (#8388)


{-# LANGUAGE ScopedTypeVariables #-}
module T8450 where

runEffect :: Either Bool r -> r
runEffect = undefined

run :: forall a. a
run = runEffect $ (undefined :: Either a ())

{-  Either a () ~ Either Bool alpha
    a ~ alpha -}


module T8514 where

type T a = (a, Maybe)


module T8570 where

import T8570a (Image(filepath), logo)
import T8570b (Field(Image))

foo = let Image {filepath = x} = logo in x


module T8570a where
data Image = Image { filepath :: () }
logo = Image ()


module T8603 where

import Control.Monad
import Data.Functor
import Control.Monad.Trans.Class( lift )
import Control.Monad.Trans.State( StateT )

newtype RV a = RV { getPDF :: [(Rational,a)] } deriving (Show, Eq)

instance Functor RV where
  fmap f = RV . map (\(x,y) -> (x, f y)) . getPDF

instance Applicative RV where
  pure = return
  (<*>) = ap

instance Monad RV where
  return x = RV [(1,x)]
  rv >>= f = RV $
    do (p,a) <- getPDF rv
       guard (p > 0)
       (q,b) <- getPDF $ f a
       guard (q > 0)
       return (p*q, b)

type RVState s a = StateT s RV a

uniform :: [a] -> RV a
uniform x = RV [(1/fromIntegral (length x), y) | y <- x]

testRVState1 :: RVState s Bool
testRVState1
  = do prize <- lift uniform [1,2,3]
       return False

-- lift :: (MonadTrans t, Monad m) => m a -> t m a


-- Trac #8806

module T8806 where

f :: Int => Int
f x = x + 1

g :: (Int => Show a) => Int
g = undefined


{-# LANGUAGE TypeFamilies #-}

-- Trac #8883

module T8883 where

type family PF a :: * -> *

class Regular a where
  from :: a -> PF a a

-- For fold we infer following type signature:
--
-- fold :: (Functor (PF a), Regular a) => (PF a b -> b) -> a -> b
--
-- However, this signature requires FlexibleContexts since the first
-- type-class constraint is not of the form (class type-variable) nor
-- (class (type-variable type1 type2 ... typen)). Since this extension
-- is not enabled compilation should fail.
fold f = f . fmap (fold f) . from


{-# LANGUAGE ImplicitParams #-}
module T8912 where

class C a where
  toInt :: a -> Int

instance (?imp :: Int) => C [a] where
  toInt _ = ?imp

test :: Int
test = let ?imp = 5 in toInt "Hello, world"


module T9030 where

bad :: Bool
bad = ()

square :: Integral i => i -> i
square x = x^2


{-# LANGUAGE GADTs #-}

module T9109 where

data G a where
  GBool :: G Bool

foo GBool = True


{-# LANGUAGE RankNTypes #-}
module T9196 where

f :: (forall a. Eq a) => a -> a
f x = x

g :: (Eq a => Ord a) => a -> a
g x = x


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

module T9201 where

class MonoidalCCC (f :: x -> y) (d :: y -> y -> *) | f -> d where
  ret :: d a (f a)


{-# LANGUAGE DataKinds, TypeOperators, GADTs #-}

module T9260 where

import GHC.TypeLits

data Fin n where
  Fzero :: Fin (n + 1)
  Fsucc :: Fin n -> Fin (n + 1)

test :: Fin 1
test = Fsucc Fzero

{- Only the second error is legitimate.

% ghc --version
The Glorious Glasgow Haskell Compilation System, version 7.8.2
% ghc -ignore-dot-ghci /tmp/Error.hs
[1 of 1] Compiling Error            ( /tmp/Error.hs, /tmp/Error.o )

/tmp/Error.hs:12:8:
    Couldn't match type â€˜0â€™ with â€˜1â€™
    Expected type: Fin 1
      Actual type: Fin (0 + 1)
    In the expression: Fsucc Fzero
    In an equation for â€˜testâ€™: test = Fsucc Fzero

/tmp/Error.hs:12:14:
    Couldn't match type â€˜1â€™ with â€˜0â€™
    Expected type: Fin 0
      Actual type: Fin (0 + 1)
    In the first argument of â€˜Fsuccâ€™, namely â€˜Fzeroâ€™
    In the expression: Fsucc Fzero
-}


{-# LANGUAGE DeriveFunctor#-}
module Main where

data Event a b = Event a deriving (Functor)

newtype F f = F (f (F f))

data EventF a = EventF (F (Event a)) deriving (Functor)


{-# LANGUAGE TypeFamilies #-}

module T9318 where

type family F x
type instance F Int = Bool

foo :: F Int -> ()
foo True = ()

bar :: F Int -> ()
bar 'x' = ()


module T9323 where

broken :: [Int]
broken = ()

ambiguous :: a -> String
ambiguous _ = show 0


module T9415 where

class D a => C a where
  meth :: D a => ()
class C a => D a


module T9605 where

f1 :: Monad m => m Bool
f1 = undefined

f2 :: Monad m => m Bool
f2 = f1 undefined


{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses #-}
module T9612 where
import Data.Monoid
import Control.Monad.Trans.Writer.Lazy( Writer, WriterT )
import Data.Functor.Identity( Identity )

class (Monoid w, Monad m) => MonadWriter w m | m -> w where
    writer :: (a,w) -> m a
    tell   :: w -> m ()
    listen :: m a -> m (a, w)
    pass   :: m (a, w -> w) -> m a

f ::(Eq a) => a -> (Int, a) -> Writer [(Int, a)] (Int, a)
f y (n,x) {- | y == x    = return (n+1, x)
             | otherwise = -}
   = do tell (n,x)
        return (1,y)

instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where


{-# LANGUAGE MultiParamTypeClasses #-}
module T9739 where

class Class3 a => Class1 a where

class Class2 t a where
  class2 :: (Class3 t) => a -> m

class (Class1 t, Class2 t t) => Class3 t where


module T9774 where

import Control.Exception

foo = putStrLn (assert True 'a')


-- From comment:76 in Trac #9858
-- This exploit still works in GHC 7.10.1.
-- By Shachaf Ben-Kiki, Ã˜rjan Johansen and Nathan van Doorn

{-# LANGUAGE Safe #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ImpredicativeTypes #-}

module T9858a where

import Data.Typeable

type E = (:~:)
type PX = Proxy (((),()) => ())
type PY = Proxy (() -> () -> ())

data family F p a b

newtype instance F a b PX = ID (a -> a)
newtype instance F a b PY = UC (a -> b)

{-# NOINLINE ecast #-}
ecast :: E p q -> f p -> f q
ecast Refl = id

supercast :: F a b PX -> F a b PY
supercast = case cast e of
    Just e' -> ecast e'
  where
    e = Refl
    e :: E PX PX

uc :: a -> b
uc = case supercast (ID id) of UC f -> f


{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE FlexibleContexts #-}

module T9858b where
import Data.Typeable

test = typeRep (Proxy :: Proxy (Eq Int => Int))


{-# LANGUAGE ImpredicativeTypes, FlexibleContexts #-}

module T9858e where
import Data.Typeable

i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep
i p = typeRep p

j = i (Proxy :: Proxy (Eq Int => Int))


{-# LANGUAGE PolyKinds, TypeFamilies, StandaloneDeriving #-}

module T9999 where

import Data.Typeable

data family F a

class C a where
  data F1 a
  type F2 a

main = typeRep (Proxy :: Proxy F) == typeRep (Proxy :: Proxy F1)


{-# LANGUAGE RoleAnnotations, RankNTypes, ScopedTypeVariables #-}

import Data.Coerce (coerce, Coercible)
import Data.Ord (Down)

newtype Age = Age Int deriving Show

type role Map nominal _
data Map a b = Map a b deriving Show

foo1 = coerce $ one :: ()

foo2 :: forall m. Monad m => m Age
foo2 = coerce $ (return one :: m Int)

foo3 = coerce $ Map one () :: Map Age ()

foo4 = coerce $ one :: Down Int

newtype Void = Void Void
foo5 = coerce :: Void -> ()

------------------------------------
-- This next one generates an exponentally big type as it
-- tries to unwrap.  See comment:15 in Trac #11518
-- Adding asserions that force the types can make us
-- run out of space.
newtype VoidBad a = VoidBad (VoidBad (a,a))
foo5' = coerce :: (VoidBad ()) -> ()

------------------------------------
-- This shoul fail with a context stack overflow
newtype Fix f = Fix (f (Fix f))
foo6 = coerce :: Fix (Either Int) -> Fix (Either Age)
foo7 = coerce :: Fix (Either Int) -> ()

one :: Int
one = 1
main = return ()


{-# LANGUAGE MultiParamTypeClasses #-}

import Data.Coerce (Coercible)

instance Coercible () ()

main = return ()


{-# LANGUAGE RoleAnnotations, RankNTypes, ScopedTypeVariables #-}

import Data.Coerce (coerce, Coercible)

newtype List a = List [a]
data T f = T (f Int)

newtype NT1 a = NT1 (a -> Int)
newtype NT2 a = NT2 (a -> Int)

foo :: T NT1 -> T NT2
foo = coerce

main = return ()


-- !!! This should fail with a type error: the instance method
-- !!! has a function type when it should have the type [a].
module ShouldFail where

class A a where
 op :: a

instance (A a, A a) => A [a] where
 op [] = []


module ShouldFail where

c (x:y) = x
c z = z


module ShouldFail where

(d:e) = [1,'a']


module ShouldFail where

(f,g) = (1,2,3)


module ShouldFail where

(h:i) = (1,'a')


module ShouldFail where

(j,k) = case (if True then True else False) of
         True -> (True,1)
         False -> (1,True)


module ShouldFail where

n x | True = x+1
    | False = True


module ShouldFail where

p = [(1::Int)..(2::Integer)]


module ShouldFail where

q = \ (y:z) -> z+2


module ShouldFail where

z = \y -> x x where x = y


module ShouldFail where

f [] = 1
f True = 2


module ShouldFail where

f x = g+1
      where g y = h+2
                  where h z = z z


module ShouldFail where

data AList a = ANull | ANode a (AList a)

type IntList = AList Int

g (ANull) = 2
g (ANode b (ANode c d)) | b = c+1
                        | otherwise = 4


module ShouldFail where

type AnnExpr a = (a,Expr a)

data Expr a = Var [Char]
              | App (AnnExpr a) (AnnExpr a)

g (Var name) = [name]
g (App e1 e2) = (g e1)++(g e2)


module ShouldFail where

class C a where
 op1 :: a -> a

class (C a) => B a where
 op2 :: a -> a -> a

instance (B a) => B [a] where
 op2 xs ys = xs


module ShouldFail where

class A a where
 p1 :: a -> a
 p2 :: a -> a -> a

class (A b) => B b where
 p3 :: b
 p4 :: b -> b

class (A c) => C c where
 p5 :: c -> c
 p6 :: c -> Int

class (B d,C d) => D d where
 p7 :: d -> d

instance D [a] where
 p7 l = []


module ShouldFail where

class A a where
 p1 :: a -> a
 p2 :: a -> a -> a

class (A b) => B b where
 p3 :: b

instance (A a) => B [a] where
 p3 = []

data X = XC --, causes stack dump

--instance B Bool where
-- p3 = True


-- !!! Illegally giving methods in a pattern binding (for no v good reason...)

module ShouldFail where

data Foo = MkFoo Int

instance Eq Foo where
    ((==), (/=)) = (\x -> \y -> True, \x -> \y -> False)


module ShouldFail where

-- !!! Duplicate instances

data B = C

class A a where
 op :: a -> Bool

instance A B where
 op C = True

instance A B where
 op C = True


-- !!! tests for CycleErr in classes
module TcFail where

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

class (A a) => B a where
 op2 :: a -> a -> a


-- !!! tests for ArityErr
module TcFail where

data A a b = B (A a)


-- !!! tests for InstOpErr
module ShouldFail where

data Foo = Bar | Baz

f x = x > Bar


module ShouldFail where

f x = if 'a' then 1 else 2


{- This test gives the following not-very-wonderful error message.

  "tc_sig.hs", line 3: Type signature does not match the inferred type:
    Signature: t76 -> Int
    Inferred type: t75

It *is* an error, because x does not have the polytype
        forall a. Eq a => a -> Int
because it is monomorphic, but the error message isn't very illuminating.
-}

module ShouldFail where

f x = (x :: (Eq a) => a -> Int)


-- from Jon Hill
module ShouldFail where

buglet = [ x | (x,y) <- buglet ]


{-
From: Jon Hill <hilly@dcs.qmw.ac.uk@jess.gla.ac.uk@pp.dcs.glasgow.ac.uk>
To: glasgow-haskell-bugs
Subject: Unfriendly error message
Date: Thu, 25 Jun 1992 09:22:55 +0100

Hello again,

I came across a rather nasty error message when I gave a function an
incorrect type signature (the context is wrong). I can remember reading
in the source about this problem - I just thought I'd let you know anyway :-)
-}
module ShouldFail where

test::(Num a, Eq a) => a -> Bool
test x = (x `mod` 3) == 0

{-
granite> ndph bug002.ldh
Data Parallel Haskell Compiler, version 0.01 (Glasgow 0.07)

"<unknown>", line <unknown>: Cannot express dicts in terms of dictionaries available:
dicts_encl:
   "<built-in>", line : dict.87 :: <Num a>
   "<built-in>", line : dict.88 :: <Eq a>
dicts_encl':
   "<built-in>", line : dict.87 :: <Num a>
   "<built-in>", line : dict.88 :: <Eq a>
dicts:
   "<built-in>", line : dict.87 :: <Num a>
   "<built-in>", line : dict.88 :: <Eq a>
super_class_dict: "<built-in>", line : dict.80 :: <Integral a>
Fail: Compilation errors found

dph: execution of the Haskell compiler had trouble

-}


-- !!! instances with empty where parts: duplicate
--
module ShouldFail where

data NUM = ONE | TWO
instance Num NUM
instance Num NUM
instance Eq NUM
instance Show NUM


{-# LANGUAGE FlexibleInstances #-}

-- !!! prelude class name in an instance-tycon position
--
module ShouldFail where

data NUM = ONE | TWO
instance Num NUM
  where ONE + ONE = TWO
instance Num NUM
instance Eq Num
--instance Text Num


-- !!! PreludeCore entities cannot be redefined at the top-level
--
module ShouldFail where

data NUM = ONE | TWO

f a b = a + b
f :: NUM -> NUM -> NUM

ONE + ONE = TWO


-- !!! duplicate class-method declarations

module ShouldFail where

data NUM = ONE | TWO
instance Eq NUM where
        a == b = True
        a /= b = False
        a == b = False
        a /= b = True


-- !!! instances of functions
--
module ShouldFail where

data NUM = ONE | TWO

class EQ a where
        (===) :: a -> a -> Bool

class ORD a where
        (<<) :: a -> a -> Bool
        a << b = True

instance EQ (a -> b) where
        f === g = True

instance ORD (a -> b)

f = (<<) === (<<)
--f :: (EQ a,Num a) => a -> a -> Bool

{-
instance EQ NUM where
--      a /= b = False
        a === b = True
--      a /= b = False

-}


{-# LANGUAGE ImplicitParams #-}

module ShouldFail where

class (?imp :: Int) => D t where
    methodD :: t -> t

-- Don't repeat implicit parameter constraint on the instance
instance D Int where
    methodD x = x + ?imp


module ShouldFail where

-- !!! weird class/instance examples off the haskell list
--

class Foo a          where foo :: a -> a
class Foo a => Bar a where bar :: a -> a

instance Num a => Foo [a] where
    foo []     = []
    foo (x:xs) = map (x+) xs

instance (Eq a, Show a) => Bar [a] where
    bar []     = []
    bar (x:xs) = foo xs where u = x==x
                              v = show x

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

{-
class Foo a => Bar2 a where bar2 :: a -> a

instance (Eq a, Show a) => Foo [a]

instance Num a => Bar2 [a]

data X a = X a
-}


-- The translation of this program should assign only one dictionary to
-- the function search (an Ord dictionary). Instead, it assigns two.
-- The output produced currently displays this.

-- 10/12/92:  This program is actually erroneous.  The pattern-binding for
-- search falls under the monomorphism restriction, and there is no
-- call to search which might fix its type.  So there should be a complaint.
-- But the actual error message is horrible:
--
-- "bug001.hs", line 26: Ambiguous overloading:
--     class "Ord_", type "a" (at a use of an overloaded identifier: gt)
--     class "Eq_", type "a" (at a use of an overloaded identifier: eq)

module TcFail where

class Eq_ a where
 eq :: a -> a -> Bool

instance Eq_ Int where
 eq = eqIntEq

instance (Eq_ a) => Eq_ [a] where
 eq = \ xs ys ->
     if (null xs)
        then (null ys)
        else if (null ys)
                then False
                else (&&) (eq (hd xs) (hd ys)) (eq (tl xs) (tl ys))

class (Eq_ a) => Ord_ a where
 gt :: a -> a -> Bool

instance Ord_ Int where
 gt = ordIntGt

search
 = \ a bs -> if gt (hd bs) a
                then False
                else if eq a (hd bs) then True else search a (tl bs)

hd :: [a] -> a
hd (a:as) = a

tl :: [a] -> [a]
tl (a:as) = as

ordIntGt :: Int -> Int -> Bool
ordIntGt 2 3 = True

eqIntEq :: Int -> Int -> Bool
eqIntEq  2 3 = True

{-

===============================================
Main.Eq__INST_PreludeBuiltin.Int =
    let
      AbsBinds [] [] [(eq, eq)]
          {- nonrec -}
          {-# LINE 2 "test3.hs" -}

          eq :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool
          eq = Main.eqIntEq
    in ({-dict-} [] [eq])

Main.Eq__INST_PreludeBuiltin.List =
    /\ t135 ->
        \{-dict-} _dict138 ->
            let
              {- nonrec -}
              _dict136 = {-singleDict-} _dict138
              {- nonrec -}
              _dict129 = {-singleDict-} _dict136
              AbsBinds [] [] [(eq, eq)]
                  {- nonrec -}

                  _dict133 =
                      Main.Eq__INST_PreludeBuiltin.List
                          [t135] [{-singleDict-} _dict136]
                  {- nonrec -}
                  {-# LINE 5 "test3.hs" -}

                  eq :: [t135] -> [t135] -> PreludeCore.Bool
                  eq = \ xs ys ->

if (Main.null t135) xs then
                                      (Main.null t135) ys
                                  else

                                      if (Main.null t135) ys then
                                          PreludeCore.False
                                      else

                                          Main.and

                                              ((Main.Eq_.eq t135 _dict129)

                                                   ((Main.hd t135) xs)
                                                   ((Main.hd t135) ys))

(Main.Eq_.eq [t135] _dict133)

                                                   ((Main.tl t135) xs)
                                                   ((Main.tl t135) ys))
            in ({-dict-} [] [eq])
Main.Ord__INST_PreludeBuiltin.Int =
    let
      {- nonrec -}
      _dict142 = Main.Eq__INST_PreludeBuiltin.Int [] []
      AbsBinds [] [] [(gt, gt)]
          {- nonrec -}
          {-# LINE 16 "test3.hs" -}

          gt :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool
          gt = Main.ordIntGt
    in ({-dict-} [_dict142] [gt])

Main.Eq_.eq = /\ a -> \{-classdict-} [] [eq] -> eq

Main.Ord_.gt = /\ a -> \{-classdict-} [_dict56] [gt] -> gt

Main.Ord__TO_Main.Eq_ = /\ a -> \{-classdict-} [_dict58] [gt] -> ???_dict58???

AbsBinds [t60] [] [(hd, Main.hd)]
    {- nonrec -}

    hd :: [t60] -> t60
    hd (a PreludeBuiltin.: as)
               = a

AbsBinds [t68] [] [(tl, Main.tl)]
    {- nonrec -}

    tl :: [t68] -> [t68]
    tl (a PreludeBuiltin.: as)
               = as

AbsBinds [t91] [_dict85, _dict88] [(search, Main.search)]
    {- rec -}
    {-# LINE 19 "test3.hs" -}

    search :: t91 -> [t91] -> PreludeCore.Bool
    search
        = \ a bs ->

if (Main.Ord_.gt t91 _dict85) ((Main.hd t91) bs) a then
                        PreludeCore.False
                    else

                        if (Main.Eq_.eq t91 _dict88) a ((Main.hd t91) bs) then
                            PreludeCore.True
                        else

                            search a ((Main.tl t91) bs)
AbsBinds [] [] [(and, Main.and)]
    {- nonrec -}
    and :: PreludeCore.Bool -> PreludeCore.Bool -> PreludeCore.Bool
    and PreludeCore.True PreludeCore.True
                = PreludeCore.True
AbsBinds [] [] [(ordIntGt, Main.ordIntGt)]
    {- nonrec -}
    _dict97 = PreludeCore.Num_INST_PreludeBuiltin.Int [] []
    {- nonrec -}
    _dict98 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] []
    {- nonrec -}
    _dict100 = PreludeCore.Num_INST_PreludeBuiltin.Int [] []
    {- nonrec -}
    _dict101 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] []
    {- nonrec -}

    ordIntGt :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool
    ordIntGt
        2 3 = PreludeCore.True
AbsBinds [] [] [(eqIntEq, Main.eqIntEq)]
    {- nonrec -}
    _dict105 = PreludeCore.Num_INST_PreludeBuiltin.Int [] []
    {- nonrec -}
    _dict106 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] []
    {- nonrec -}
    _dict108 = PreludeCore.Num_INST_PreludeBuiltin.Int [] []
    {- nonrec -}
    _dict109 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] []
    {- nonrec -}

    eqIntEq :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool
    eqIntEq
        2 3 = PreludeCore.True

AbsBinds [t112] [] [(null, Main.null)]
    {- nonrec -}

    null :: [t112] -> PreludeCore.Bool
    null [] = PreludeCore.True
-}


-- !!! tcfail044: duplicated type variable in instance decls
--
module ShouldFail where

instance (Eq a) => Eq (a->a)
instance Show (a->b)

instance (Num a) => Num (a->a) where
    f + g    = \x -> f x + g x
    negate f = \x -> - (f x)
    f * g    = \x -> f x * g x
    fromInteger n = \x -> fromInteger n

ss :: Float -> Float
cc :: Float -> Float
tt :: Float -> Float

ss = sin * sin
cc = cos * cos
tt = ss + cc

--main = putStr ((show (tt 0.4))++ "  "++(show (tt 1.652)))


-- !! function types in deriving Eq things
-- From a bug report by Dave Harrison <D.A.Harrison@newcastle.ac.uk>

module ShouldFail where

type    Process a = Pid -> Time -> Message a -> ( MessList a,
                                                  Continuation a)

data    Continuation a = Do (Process a) deriving Eq

type    ProcList a = [ (Pid, Status, Process a) ]
data    Status     = Active | Passive | Busy Integer | Terminated
                     deriving Eq

data Message a = Create (Process a) | Created Pid   | Activate Pid  |
                 Passivate Pid      | Terminate Pid | Wait Pid Time |
                 Query Pid a        | Data Pid a    | Event         |
                 Output Pid String
               deriving Eq

type    MessList a = [ Message a ]

type    Pid  = Integer
type    Time = Integer


module ShouldFail where

class A a where
 op1 :: a -> a

instance A (a,(b,c)) where
 op1 a = a


module ShouldFail where

class (B a) => C a where
 op1 :: a -> a


module ShouldFail where

instance B Bool where
 op1 a = a


module ShouldFail where

data C a = B a c


module ShouldFail where

f x = (x + 1 :: Int) :: Float


module ShouldFail where

data Foo = MkFoo Bool

instance Eq Foo where
    (MkFoo x) == (MkFoo y) = x == y

instance Eq Foo where
    -- forgot to type "Ord" above
    (MkFoo x) <= (MkFoo y) = x <= y


module ShouldFail where

-- !!! inadvertently using -> instead of =>

f :: (RealFrac a) -> a -> a
f x = x


module ShouldFail where
import Data.Array

-- !!! inadvertently using => instead of ->

f :: (Array a) => a -> b
f x = x


-- !! signature bugs exposed by Sigbjorn Finne
--
module ShouldFail where

type Flarp a = (b,b)

--More fun can be had if we change the signature slightly

type Bob a = a

type Flarp2 a = Bob (b,b)


-- !!! bug report from Satnam
--
module ShouldFail
where

type Module = (String,[Declaration])

data Declaration
  = Architecture String StructuralExpression |
    Behaviour String Parameter Parameter BehaviouralExpression
    deriving (Eq, Show)

data Parameter = ParameterVariable String | ParameterList [Parameter]
                 deriving (Eq, Show)

nameOfModule :: Module -> String
nameOfModule (name, _) = name

data StructuralExpression
  = Variable String |
    Serial StructuralExpression StructuralExpression |
    Par [StructuralExpression]
    deriving (Eq, Show)

data BehaviouralExpression
  = BehaviouralVariable String
    | AndExpr BehaviouralExpression BehaviouralExpression
    | OrExpr BehaviouralExpression BehaviouralExpression
    | NotExpr BehaviouralExpression
    deriving (Eq, Show)

type BehaviouralRelation
  = (behaviouralExpression, behaviouralExpression)
---- ^ typo ----------------^ typo (but so what?)

type BehaviouralRelationList = [BehaviouralRelation]


-- !!! no type variable on a context
-- !!! reported by Sigbjorn Finne

module ShouldFail where

moby :: Num => Int -> a -> Int
moby x y = x+y


{-

------- Forwarded Message

Date:    Wed, 30 Nov 1994 16:34:18 +0100
From:    John Hughes <rjmh@cs.chalmers.se>
To:      augustss@cs.chalmers.se, simonpj@dcs.gla.ac.uk
Subject: Nice little program

Lennart, Simon,

You might like to look at the fun little program below.

THUMBS DOWN to hbc for compiling it (it prints [72, 101, 108, 108, 111])
THUMBS UP to ghc for rejecting it --- but what an error message!
nhc and gofer both reject it with the right error message.
I haven't tried Yale Haskell.

Enjoy!
- ----------------------------
-}

class HasX a where
  setX :: x->a->a

data X x = X x
instance HasX (X x) where
  setX x (X _) = X x

changetype x = case setX x (X (error "change type!")) of X y->y

main = print (changetype "Hello" :: [Int])

{-
------- End of Forwarded Message
-}


{-# LANGUAGE DatatypeContexts #-}
module ShouldFail where

infixr 1 `rangeOf`

data Ord a => SubRange a = SubRange (a, a) a

type IntSubRange = SubRange Int

subRangeValue :: SubRange a -> a
subRangeValue (SubRange (lower, upper) value) = value

subRange :: SubRange a -> (a, a)
subRange (SubRange r value) = r

newRange :: (Ord a, Show a) => (a, a) -> a -> SubRange a
newRange r value = checkRange (SubRange r value)

checkRange :: (Ord a, Show a) => SubRange a -> SubRange a
checkRange (SubRange (lower, upper) value)
  = if (value < lower) || (value > upper) then
      error ("### sub range error. range = " ++ show lower ++
              ".." ++ show upper ++ " value = " ++ show value ++ "\n")
    else
      SubRange (lower, upper) value

instance Eq a => Eq (SubRange a) where
  (==) a b = subRangeValue a == subRangeValue  b

instance (Ord a) => Ord (SubRange a) where
  (<)  = relOp (<)
  (<=) = relOp (<=)
  (>=) = relOp (>=)
  (>)  = relOp (>)

relOp :: Ord a => (a->a->Bool) -> SubRange a -> SubRange a -> Bool
relOp op a b = (subRangeValue a) `op` (subRangeValue b)

rangeOf :: (Ord a, Show a) => SubRange a -> SubRange a -> SubRange a
rangeOf a b = checkRange (SubRange (subRange b) (subRangeValue a))

showRange :: Show a => SubRange a -> String
showRange (SubRange (lower, upper) value)
  = show value ++ " :" ++ show lower ++ ".." ++ show upper

showRangePair :: (Show a, Show b) => (SubRange a, SubRange b) -> String
showRangePair (a, b)
  = "(" ++ showRange a ++ ", " ++ showRange b ++ ")"

showRangeTriple :: (Show a, Show b, Show c) =>
                   (SubRange a, SubRange b, SubRange c) -> String
showRangeTriple (a, b, c)
  = "(" ++ showRange a ++ ", " ++ showRange b ++ ", " ++ showRange c ++ ")"

instance Num a => Num (SubRange a) where
  negate = numSubRangeNegate
  (+) = numSubRangeAdd
  (-) = numSubRangeSubtract
  (*) = numSubRangeMultiply
  fromInteger a = SubRange (fromInteger a, fromInteger a) (fromInteger a)

numSubRangeNegate :: (Ord a, Show a, Num a) => SubRange a -> SubRange a
numSubRangeNegate (SubRange (lower, upper) value)
  = checkRange (SubRange (lower, upper) (-value))

numSubRangeBinOp :: Num a => (a -> a -> a) ->
                    SubRange a -> SubRange a -> SubRange a
numSubRangeBinOp op a b
  = SubRange (result, result) result
    where
    result = (subRangeValue a) `op` (subRangeValue b)

-- partain:
numSubRangeAdd, numSubRangeSubtract, numSubRangeMultiply :: Num a => SubRange a -> SubRange a -> SubRange a

numSubRangeAdd = numSubRangeBinOp (+)
numSubRangeSubtract = numSubRangeBinOp (-)
numSubRangeMultiply = numSubRangeBinOp (*)

unsignedBits :: Int -> (Int, Int)
unsignedBits n = (0, 2^n-1)

signedBits :: Int -> (Int, Int)
signedBits n = (-2^(n-1), 2^(n-1)-1)

si_n :: Int -> Int -> IntSubRange
si_n bits value = SubRange (signedBits bits) value

si8, si10, si16 :: Int -> IntSubRange
si8  = si_n 8
si10 = si_n 10
si16 = si_n 16


-- !! Make sure that state threads don't escape
-- !! (example from Neil Ashton at York)
--
module ShouldFail where

import GHC.Arr
import Control.Monad.ST ( runST )

type IndTree s t = STArray s (Int,Int) t

itgen :: Constructed a => (Int,Int) -> a -> IndTree s a
itgen n x =
        runST (
        newSTArray ((1,1),n) x)

itiap :: Constructed a => (Int,Int) -> (a->a) -> IndTree s a -> IndTree s a
itiap i f arr =
        runST (
        readSTArray arr i >>= \val ->
        writeSTArray arr i (f val) >>
        return arr)

itrap :: Constructed a => ((Int,Int),(Int,Int)) -> (a->a) -> IndTree s a -> IndTree s a
itrap ((i,k),(j,l)) f arr = runST (itrap' i k)
        where
        itrap' i k = if k > l then return arr
                     else (itrapsnd i k >>
                        itrap' i (k+1))
        itrapsnd i k = if i > j then return arr
                     else (readSTArray arr (i,k) >>= \val ->
                        writeSTArray arr (i,k) (f val) >>
                        itrapsnd (i+1) k)

itrapstate :: Constructed b => ((Int,Int),(Int,Int)) -> (a->b->(a,b)) -> ((Int,Int)->c->a) ->
                (a->c) -> c -> IndTree s b -> (c, IndTree s b)
itrapstate ((i,k),(j,l)) f c d s arr = runST(itrapstate' i k s)
        where
        itrapstate' i k s = if k > l then return (s,arr)
                            else (itrapstatesnd i k s >>= \(s,arr) ->
                                itrapstate' i (k+1) s)
        itrapstatesnd i k s = if i > j then return (s,arr)
                            else (readSTArray arr (i,k) >>= \val ->
                               let (newstate, newval) = f (c (i,k) s) val
                               in writeSTArray arr (i,k) newval >>
                               itrapstatesnd (i+1) k (d newstate))

-- stuff from Auxiliary: copied here (partain)

sap :: (a->b) -> (c,a) -> (c,b)
sap f (x,y) = (x, f y)

fap :: (a->b) -> (a,c) -> (b,c)
fap f (x,y) = (f x, y)

nonempty :: [a] -> Bool
nonempty []    = False
nonempty (_:_) = True

-- const :: a -> b -> a
-- const k x = k

-- id :: a -> a
-- id x = x

compose :: [a->a] -> a -> a
compose = foldr (.) id

class Constructed a where
   normal :: a -> Bool

instance Constructed Bool where
   normal True = True
   normal False = True

instance Constructed Int where
   normal 0 = True
   normal n = True

instance (Constructed a, Constructed b) => Constructed (a,b) where
   normal (x,y) = normal x && normal y

-- pair :: (Constructed a, Constructed b) => a -> b -> (a,b)
-- pair x y | normal x && normal y = (x,y)

instance Constructed (Maybe a) where
   normal Nothing = True
   normal (Just _) = True

just :: Constructed a => a -> Maybe a
just x | normal x = Just x


{-
From: Marc van Dongen <dongen@cs.ucc.ie>
Date: Wed, 9 Apr 1997 14:06:39 +0100 (BST)

I just wanted to report that the erroneous and tiny
program added below can not be compiled within 6MB of
heap (Admitted it can be compiled with a bigger heap).
It was part of a bigger program that could not be
compiled within 20MB of heap.

[GHC 2.03 and earlier.]  Turned out to be a bug in the
error recovery mechanism.

-}

module ShouldFail where

too_much :: [Int] -> [(Int,Int)] -> [(Int,[Int])] -> Bool
too_much ds ((k,m):q1) s0
  = case (list1,list2) of
      []  -> error "foo" -- too_much ds q2m  s2m
  where list1 = ds
        list2 = ds
        {-
        list1 = [k' | k' <- ds, k == k']
        list2 = [k' | k' <- ds, m == k']
        s1   = aas s0 k
        raM  = []
        raKM = listUnion (\a b -> a) [] []
        s1k  = s1
        q1k  = raM
        s2k  = s1
        q2k  = raM
        s2m  = s1
        q2m  = raM
        s2km = foldr (flip aas) s1 raKM
        q2km = raKM
        -}

listUnion :: (v -> v -> Bool) -> [v] -> [v] -> [v]
listUnion _  _ _
  = []

aas :: (a,b) -> a -> (a,b)
aas s _
  = s


{-
From: Wolfgang Drotschmann <drotschm@athene.informatik.uni-bonn.de>
Resent-Date:  Thu, 15 May 1997 17:23:09 +0100

I'm still using the old ghc-2.01. In one program I ran into a problem
I couldn't fix. But I played around with it, I found a small little
script which reproduces it very well:

panic! (the `impossible' happened):
        tlist
-}

module TcFail where

type State = ([Int] Bool)


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

-- !!! Mis-matched contexts in a mutually recursive group

{-  # LANGUAGE NoRelaxedPolyRec #-}
-- With the new type checker you can't turn off RelaxedPolyRec
-- so this test always succeeds

module ShouldFail where

f :: (Ord d) => d -> d
f c = g c

g :: e -> e
g c = c
  where p = f (1 :: Int)


{- This program crashed GHC 2.03

   From: Marc van Dongen <dongen@cs.ucc.ie>
   Date: Sat, 31 May 1997 14:35:40 +0100 (BST)

  zonkIdOcc: g_aoQ

  panic! (the `impossible' happened):
          lookupBindC:no info!
  for: g_aoQ
  (probably: data dependencies broken by an optimisation pass)
  static binds for:
  Tmp.$d1{-rmM,x-}
  local binds for:
-}

module ShouldFail where

data AB p q = A
            | B p q

g :: (Ord p,Ord q) => (AB p q) -> Bool
g (B _ _) = g A


-- what error do you get if you redefined Prelude instances?

module ShouldFail where

f :: (Eq a) => (a,a) -> (a,a) -> Bool
f x y = x == y

instance Eq a => Eq (a,b) where
    (m,n) == (o,p) = m == o


{-# LANGUAGE MagicHash #-}

-- !!! Test top-level unboxed types

module ShouldFail where

import GHC.Base
import GHC.Prim

x = 1#

y :: Int#
y = x +# 1#

main =  let
          z = x -# y
        in
        if isTrue# (z ># 3#) then putStrLn "Yes"
                             else putStrLn "No"


{-# LANGUAGE RankNTypes #-}

{-
        From: Ralf Hinze <ralf@uran.informatik.uni-bonn.de>
        Date: Fri, 15 Aug 1997 15:20:51 +0200 (MET DST)

I *suppose* that there is a bug in GHC's type checker. The following
program, which I think is ill-typed, passes silently the type checker.
Needless to say that it uses some of GHC's arcane type extensions.
-}

module ShouldFail where

data ContT m a          =  KContT (forall res. (a -> m res) -> m res)
unKContT (KContT x)     =  x

callcc                  :: ((a -> ContT m b) -> ContT m a) -> ContT m a
callcc f                =  KContT (\cont -> unKContT (f (\a -> KContT (\cont' -> cont a))) cont)

{-
`ContT' is a continuation monad transformer. Note that we locally
qualify over the result type `res' (sometimes called answer or
output).  IMHO this make it impossible to define control constructs
like `callcc'. Let's have a closer look: the code of `callcc' contains
the subexpression `KContT (\cont' -> cont a)'. To be well-typed the
argument of `KContT' must have the type `(All res) => (a -> m res) -> m
res'. Quantification is not possible, however, since the type variable
in `cont's type cannot be forall'd, since it also appears at an outer
level.  Right? Or wrong?
-}


module ShouldFail where

-- !!! declaring a default method in a class that doesn't have that method.

class Foo a where
  op :: a -> a

  op2 x = x     -- Bogus declaration


module ShouldFail where

-- !!! Using a type constructor as a class name

f :: Integer i => i
f =               0


{-# LANGUAGE MagicHash #-}

module ShouldFail where

-- !!! unboxed field in newtype declaration

import GHC.Exts ( Int# )

newtype Unboxed = Unboxed Int#

f = [ Unboxed 1#, Unboxed 2# ] -- shouldn't be allowed!


{-# LANGUAGE MultiParamTypeClasses #-}

-- !!! Multi-param type classes test: ambiguity bug

-- GHC actually accepts this program because
--      q :: Collection c a => a -> Bool
-- and there is no a priori reason to suppose that
-- q would be ambiguous in every context. For example,
-- it could be fine if we had
--      instance c Int where ...
-- Of course, it'd be hard to fill in the "..." in this particular
-- case, but that relies on observations about the form of the types
-- of the class methods, surely beyond what a compiler should do.
--
-- Still, the type is ambiguous because there's nothing to fix 'c'

module ShouldFail where

class Collection c a where
    empty :: c a
    add :: a -> c a -> c a
    isempty :: c a -> Bool

singleton x = add x empty

q x = isempty (singleton x)


module Main(main) where
import Data82
import Inst82_1
import Inst82_2

data Baz = Baz deriving Read

main     = print ((read "FooData")::FooData)


module ShouldFail where

data Bar = Bar { flag :: Bool } deriving( Show )

data State = State { bar :: Bar, baz :: Float }

display :: State -> IO ()
display (State{ bar = Bar { flag = f, baz = b }}) = print (f,b)

-- Typo! The line above should better be:
-- display (State{ bar = Bar { flag = f }, baz = b }) = print (f,b)

-- GHC 4.04 (as released) crashed with
--      panic! (the `impossible' happened): tcLookupValue: b{-r4n-}
-- Bug reported by Sven Panne


-- !!! Check that using a label belonging to another constructor
-- !!! is flagged as being incorrect.
module ShouldFail where

data F
 = F { x :: Int }
 | G { y :: Int }

z :: F
z = F { y = 2 }


-- !!! Check that not supplying bindings for strict fields
-- !!! is flagged as being incorrect.
module ShouldFail where

data F
 = F { x :: Int, y :: !Int }

z :: F
z = F { x = 2 }


{-# LANGUAGE ExistentialQuantification #-}

-- !!! Check that we can't derive instances of existential types
module ShouldFail where

data Ex = forall a. Ex [a] deriving( Eq )


{-# LANGUAGE RankNTypes, FlexibleInstances #-}

-- !!! Check that forall types can't be arguments
module ShouldFail where

data T s a = MkT s a

instance Ord a => Ord (forall s. T s a)
-- A for-all should not appear as an argument to Ord

g :: T s (forall b.b)
g = error "urk"


-- !!! Check non-constructors in patterns fail tidily
-- !!! The -O made ghc 4.08 go into a loop!
-- Unfortunately the -O has to go in the Makefile

module ShouldFail where

compute :: String -> String
compute ("hd" ++ _) = "_"


{-# LANGUAGE MagicHash #-}

module ShouldFail where

import GHC.Base

my_undefined :: a  -- This one has kind *, not OpenKind
my_undefined = undefined

die :: Int -> ByteArray#
die _ = my_undefined


{-# LANGUAGE ParallelListComp #-}

-- !!! Illegal conflicting parallel bindings

module ShouldFail where

xys = [ () | let a = 13 | let a = 17 ]


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

module ShouldFail where

-- A stripped down functional-dependency
-- example that causes GHC 4.08.1 to crash with:
-- "basicTypes/Var.lhs:194: Non-exhaustive patterns in function readMutTyVar"
-- Reported by Thomas Hallgren Nov 00

-- July 07: I'm changing this from "should fail" to "should succeed"
-- See Note [Important subtlety in oclose] in FunDeps

primDup :: Int -> IO Int
primDup = undefined

dup () = call primDup

--      call :: Call c h => c -> h
--
--      call primDup :: {Call (Int -> IO Int) h} => h  with
--  Using the instance decl gives
--      call primDup :: {Call (IO Int) h'} => Int -> h'
--  The functional dependency means that h must be constant
--  Hence program is rejected because it can't find an instance
--  for {Call (IO Int) h'}

class Call    c h | c -> h where
    call  :: c -> h

instance Call c h => Call (Int->c) (Int->h) where
    call f = call . f


module ShouldFail where

-- This nonsense tickled a missing-kind-check error in ghc5.00.2

type A = Int 1


{-# LANGUAGE MagicHash #-}

-- !!! Test top-level unboxed types

module ShouldFail where

import GHC.Base

x = 1#


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances #-}
module ShouldFail where

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

-- These instances are incompatible because we can unify
-- the first two parameters, though it's rather obscure:
--      p -> (a,b)
--      t -> (,) (a,a)
--      c -> (,) a
--      r -> s
--
-- So a constraint which would sow this up is
--      Foo ((Int,Int)->Int)
--          ((Int,Int), (Int,Int))
--          t
-- This matches both.  Not easy to spot, and the error
-- message would be improved by giving the unifier, or
-- a witness.

instance Foo (p->s)     (t p)    (t s)
instance Foo ((a,b)->r) (c a,c b)(c r)


module ShouldFail where

-- !!! Ambiguous constraint in type signature

f :: Eq a => Int -> Int
f x = x


{-# LANGUAGE UndecidableInstances #-}

module ShouldFail where

-- The constraint in the context of an instance declaration
-- is ambiguous, but we have UndecidableInstances on, so
-- it could conceivably be ok (we'd need OverlappingInstances
-- too in this case).  So we allow it.
-- See Note [The ambiguity check for type signatures] in TcMType

class Bar a
instance Bar a => Bar Bool


{-# LANGUAGE ExistentialQuantification #-}

-- This bogus program slipped past GHC 5.02!

module ShouldFail where

data DS = forall a. C (a -> Int)

call (C f) arg = f arg


-- This one broke GHC 5.02, because of the unsaturated
-- uses of type synonyms, which are nevertheless kind-correct.

module ShouldCompile where

type A i = i
type B = A


-- This one broke GHC 5.02, because of the unsaturated
-- uses of type synonyms, which are nevertheless kind-correct.

module ShouldCompile where

type A i = i
data T k = MkT (k Int)

f :: T A        -- BAD!
f = error "foo"


{-# LANGUAGE DatatypeContexts #-}
module ShouldFail where

import Data.Ratio

data Integral a => P a = P { p :: a }

f :: Integral a => P (Ratio a) -> P (Ratio a)
f x = x { p = p x }


module ShouldCompile where
import GHC.ST
import GHC.STRef
import GHC.Arr

-- Another 'escape' example

f:: ST t Int
f = do
    v <- newSTRef 5
    let g :: ST s Int
        -- Implicitly forall s. ST s Int
        g = readSTRef v
    g


{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

-- Test the handling of conditionals in rank-n stuff
-- Should fail, regardless of branch ordering

module ShouldFail where

-- These two are ok
f1 = (\ (x :: forall a. a->a) -> x)
f2 = (\ (x :: forall a. a->a) -> x) id 'c'

-- These fail
f3 v = (if v then
          (\ (x :: forall a. a->a) -> x)
        else
          (\ x -> x)
      ) id 'c'

f4 v = (if v then
          (\ x -> x)
        else
          (\ (x :: forall a. a->a) -> x)
       ) id 'c'


{-# LANGUAGE ExistentialQuantification #-}

-- Existential context should quantify over some new type variables
--
-- Jan07: this is now fine, because we've lifted the restrction
--        that the context on a constructor should mention
--        existential type variables

module ShouldFail where

data S m t a = Ok a | Cont (M m t a)
data M m t a = Monad m => M { unM::(m (S m t a))}


-- This one risked building a recursive dictionary rather than
-- failing, in GHC before 5.03.   Actually, 5.02 managed it ok,
-- but I think more by luck than good judgement.

module ShouldFail where

class S a
class S a => C a where { opc :: a -> a }
class S b => D b where { opd :: b -> b }

instance C Int where
   opc = opd

instance D Int where
   opd = opc


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

type Thing m = m ()

type Const a b = a

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


-- The instance decl is illegal without UndecidableInstances

module ShouldFail where

data Rec f = In (f (Rec f))

instance Eq (f (Rec f)) => Eq (Rec f) where
         (In x) == (In y) = x == y