{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE Arrows, CPP, TypeOperators #-}

-- Test infix type notation and arrow notation

module Test where

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

-- For readability, I use infix notation for arrow types.  I'd prefer the
-- following, but GHC doesn't allow operators like "-=>" as type
-- variables.
--
-- comp1 :: Arrow (-=>) => b-=>c -> c-=>d -> b-=>d

comp1 :: Arrow to => b `to` c -> c `to` d -> b `to` d
comp1 f g = proc x -> do
            b <- f -< x
            g -< b

-- arrowp produces
-- comp1 f g = (f >>> g)

comp :: Arrow to => (b `to` c, c `to` d) `to` (b `to` d)
comp = arr (uncurry (>>>))

-- app :: Arrow to => (b c, b) `to` c

type R = Float
type I = Int

z1,z2 :: Arrow to => I `to` (R `to` R)
z1 = undefined
z2 = z1

z3 :: Arrow to => (I,I) `to` (R `to` R,R `to` R)
z3 = z1 *** z2

z4 :: Arrow to => (I,I) `to` (R `to` R)
z4 = z3 >>> comp

comp4,comp5 :: Arrow to =>
  b `to` (c `to` d) -> e `to` (d `to` f) -> (b,e) `to` (c `to` f)

comp4 g f = proc (b,e) -> do
            g' <- g -< b
            f' <- f -< e
            returnA -< (g' >>> f')

comp5 g f = (g *** f) >>> comp

lam,lam2 :: Arrow to => (e,b) `to` c -> e `to` (b `to` c)

lam f = arr $ \ e -> arr (pair e) >>> f

pair a b = (a,b)

-- I got the definition lam above by starting with

lam2 f = proc e ->
         returnA -< (proc b -> do
                     c <- f -< (e,b)
                     returnA -< c)

-- I desugared with  the arrows preprocessor, removed extra parens and
-- renamed "arr" to "pure", to get
--
--  lam f = pure (\ e -> pure (\ b -> (e, b)) >>> f)

-- Note that lam is arrow curry

-- curry :: ((e,b) -> c) -> (e -> b -> c)

-- All equivalent:

curry1 f e b = f (e,b)

curry2 f = \ e -> \ b -> f (e,b)

curry3 f = \ e -> f . (\ b -> (e,b))

curry4 f = \ e -> f . (pair e)

comp6 :: Arrow to => b `to` (c `to` d) -> e `to` (d `to` f)
                  -> b `to` (e `to` (c `to` f))
comp6 g f = lam $ comp5 g f

-- What about uncurrying?

-- uncurryA :: Arrow to => b `to` (c `to` d)
--                     -> (b,c) `to` d
-- uncurryA f = proc (b,c) -> do
--              f' <- f -< b
--              returnA -< f' c

-- Why "lam" instead of "curryA" (good name also): so I can use Arrows
-- lambda notation, similar to

compF g f = \ b e -> g b . f e

-- But I haven't figured out how to.

-- comp7 :: Arrow to => b `to` (c `to` d) -> e `to` (d `to` f)
--                   -> b `to` (e `to` (c `to` f))
-- comp7 g f = proc b -> proc e -> do
--             g' <- g -< b
--             f' <- f -< e
--             returnA -< (g' >>> f')

-- Try "(| lam \ b -> ... |)" in the FOP arrows chapter
-- cmd ::= form exp cmd1 ... cmdn.  Parens if nec

-- (| lam (\ b -> undefined) |)

-- Oh!  The arrow syntax allows bindings with *infix* operators.  And I
-- don't know how to finish comp7.

-- Uncurried forms:

comp8 :: Arrow to => (b,c) `to` d -> (e,d) `to` k -> (b,c,e) `to` k
comp8 g f = proc (b,c,e) -> do
            d <- g -< (b,c)
            f -< (e,d)

-- This looks like straightforward `to` translation.  With insertions of
-- curry & uncurry operators, it'd probably be easy to handle curried
-- definitions as well.

-- Simpler example, for experimentation

comp9 :: Arrow to => (c,d) `to` e -> b `to` d -> (b,c) `to` e
comp9 g f = proc (b,c) -> do
            d <- f -< b
            g -< (c,d)

-- Desugared:

comp9' :: Arrow to => (c,d) `to` e -> b `to` d -> (b,c) `to` e
comp9' g f = first f >>> arr (\ (d,c) -> (c,d)) >>> g


-- A newtype representation problem crashed GHC 6.4

module ShouldCompile where

newtype Signal a = Signal Symbol

newtype Symbol = Symbol (S Symbol)

data S s = Bool Bool

liftl :: Signal a -> Symbol
liftl (Signal a) = a


{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

-- Tests the special case of
--      non-recursive, function binding,
--      with no type signature

module ShouldCompile where

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

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


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

-- This one made GHC 6.4 loop because Unify.unify
-- didn't deal correctly with unifying
--      a :=: Foo a
-- where
--      type Foo a = a

module ShouldSucceed where

newtype PRef a = PRef a
type Drop1 a = a
class Ref a r | a -> r  where readRef :: a -> r
instance Ref (PRef a) (Drop1 a) where readRef (PRef v) = v


-- Test the refined dependency analysis of bindings
-- with -fglagow-exts

module ShouldCompile where

  f1 :: Eq a => a -> Bool
  f1 x = (x == x) || g1 True

  g1 :: Ord a => a -> Bool
  g1 y = (y <= y) || f1 True

---------

  f2 :: Eq a => a -> Bool
  f2 x = (x == x) || g2 True || g2 "Yes"

  g2 y = (y <= y) || f2 True


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

-- Another dependency analysis test
-- Notice that 'a' and 'b' are mutually recursive,
-- but have different contexts.
--
-- This is the program submitted by Robert van Herk [rherk@cs.uu.nl]
-- to motivate the refined dependency analysis.

module ShouldCompile where
import Data.IORef

class MyReader r v | r -> v where
  myRead :: r -> IO v

data R v = R (IORef v)
instance MyReader (R v) v where
  myRead (R v) =
    do v <- readIORef v
       return v

a :: IO ()
a =
  do r <- createReader
     b r

b :: MyReader r Int => r -> IO ()
b r =
  do i <- myRead r
     if i > 10
       then a
       else putStrLn (show i)

createReader :: IO (R Int)
createReader =
  do ref <- newIORef 0
     return (R ref)


{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

-- This should work, because the type sig and the type
-- in the pattern match exactly

module Foo where

foo :: (forall a. a -> b) -> b
foo (f :: forall a. a -> b) = f undefined :: b


{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}

-- This code defines a default method with a highly dubious type,
-- because 'v' is not mentioned, and there are no fundeps
-- Hence needing AllowAmbiguousTypes
--
-- However, arguably the instance declaration should be accepted,
-- beause it's equivalent to
--      instance Baz Int Int where { foo x = x }
-- which *does* typecheck

-- GHC does not actually macro-expand the instance decl.  Instead, it
-- defines a default method function, thus
--
--      $dmfoo :: Baz v x => x -> x
--      $dmfoo y = y
--
-- Notice that this is an ambiguous type: you can't call $dmfoo
-- without triggering an error.  And when you write an instance decl,
-- it calls the default method:
--
--      instance Baz Int Int where foo = $dmfoo
--
-- I'd never thought of that.  You might think that we should just
-- *infer* the type of the default method (here forall a. a->a), but
-- in the presence of higher rank types etc we can't necessarily do
-- that.

module Foo1 where

class Baz v x where
   foo :: x -> x
   foo y = y

instance Baz Int Int


{-# OPTIONS_GHC -w #-}
{-# LANGUAGE ConstrainedClassMethods #-}  -- Needed for 'baz'

-- A nasty case that crashed GHC 6.4 with a Lint error;
-- see Note [Multiple instantiation] in TcExpr

module ShouldCompile where

class C a where
  foo :: Eq b => b -> a -> Int
  baz :: Eq a => Int -> a -> Int

instance C Int where
  baz = foo


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

{-      Email 30 Jan 2006

> the attached program compiles under GHC, but not with Hugs. as far as
> i see, Hugs don't use dependencies in class headers to figure out that
> there is only one "vMkIOError" that can be called in the last
> definition

OK, I think it's a bug (though the example is bizarre).  Sadly Hugs's
support for FDs is rough around the edges (and unlikely to improve
soon).

-}

module ShouldCompile where

        class (Monad m) => Stream m h | h->m where
                vMkIOError :: h -> Int

        data BinHandle = forall h . Stream IO h => BinH h

        instance Stream IO BinHandle where
                vMkIOError (BinH h) = vMkIOError h


-- Tests that subFunTys works when the argument is a type of form (a ty1 ty2)

module ShouldCompile where

newtype StreamArrow a b c = Str (a [b] [c])

foo = Str $ (\x -> x)


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

-- Check that we can have a forall after a forall

module Foo4 where

type AnyE a = forall err. Either err a

foo :: Monad m => AnyE (m t)
foo = undefined


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# OPTIONS_GHC -dcore-lint #-}
{-# LANGUAGE ImplicitParams #-}

-- The dict-bindings attached to an IPBinds
-- need not be in recursive order.  This is
-- a long-standing bug, which lasted up to
-- and including GHC 6.4.2

module Bug795(foo) where

data Arg = E Integer | T Bool deriving (Eq, Show)

foo :: Integer -> [Arg] -> IO String
foo 1 as = do { let ?err = "my custom error"
               ; let ws = (show (firstE as))
               ; return (show (firstE as)) }

firstE :: (?err :: String) => [Arg] -> Integer
firstE = error "urk"


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

-- Tests infix type constructors in GADT declarations

module ShouldCompile where

import Data.Kind

infix 1 `DArrowX`       -- (->) has precedence 0

data DArrowX :: Type -> Type -> Type where
  First   :: a `DArrowX`  a' -> (a,b) `DArrowX` (a',b)


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

-- This one showed up a bug in pre-subsumption

module ShouldCompile where

class Data a where {}

type GenericQ r = forall a. Data a => a -> r

everything :: (r -> r -> r) -> GenericQ r
everything k f  = error "urk"

-- | Get a list of all entities that meet a predicate
listify :: (r -> Bool) -> GenericQ [r]
listify p = everything (++)


-- Tests enhanced polymorphism

module ShouldCompile where

foo xs = let
           f :: Eq a => [a] -> [a]
           f [] = []
           f xs | null (g [True]) = []
                | otherwise       = tail (g xs)

           g :: Eq b => [b] -> [b]
           g [] = []
           g xs | null (f "hello") = []
                | otherwise       = tail (f xs)
        in f xs


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

-- This program failed to typecheck in an early version of
-- GHC with impredicative polymorphism, but it was fixed by
-- doing pre-subsumption in the subsumption check.
-- Trac bug #821

module ShouldCompile where

type PPDoc = (?env :: Int) => Char

f :: Char -> PPDoc
f  = succ


{-# LANGUAGE UnboxedTuples #-}

-- Unboxed tuples; cf tcfail115, tcfail120

module ShouldFail where

type T a = Int -> (# Int, Int #)

-- Should be ok
h t = \x -> case t x of (# r, s #) -> r


{-# LANGUAGE RankNTypes #-}

module ShouldCompile where

f :: forall a. a -> forall b. b -> Int
f = error "urk"

-- Both these should be ok, but an early GHC 6.6 failed

g1 = [ (+) :: Int -> Int -> Int, f ]
g2 = [ f, (+) :: Int -> Int -> Int ]


{-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags -XScopedTypeVariables -XGADTs #-}

-- Nov 2014: impredicative types are very dodgy so I am
--           FAR from confident that these tests give the right errors

-- Here are a bunch of tests for impredicative polymorphism
-- mainly written by Dimitrios

-- Sept 16: I'm just accepting the bizarre output.
-- None of this is right

module ShouldCompile where

xs :: [forall a. a->a]
xs = [\x -> x]

foo = id xs

-- Annotation resolves impredicative instantiation
bar = ((:)::(forall a.a ->a) -> [forall a. a->a] -> [forall a. a ->a])
               (head foo) foo

-- result type resolves everything! really neat
barr :: [forall a. a -> a]
barr = (head foo):(tail foo)

zoo = tail xs
zooo = head xs

-- This is the only unsatisfactory case...annotating
-- one of the arguments does not do the job...but maybe
-- this is reasonable to expect ...
-- bar3 = ((head foo) :: forall a. a ->a) : foo

data Pair a b where
   P :: a -> b -> Pair a b

data List a where
   Nil  :: List a
   Cons :: a -> List a -> List a
--   FromMono :: (a->a) -> List (forall a. a->a)
--   This constructor looks utterly bogus, so
--   I'm commenting it out; SLPJ 7 Jan 08

f :: Int -> Pair Int Int
f x = P x x

h0 :: (forall a. a -> a) -> Int
h0 g = let y = P (g 3) (g (P 3 4))
      in 3

h1 (g::(forall a. a ->a))
   = let y = P (g 3) (g (P 3 4))
     in 3

h2 :: (forall a. a -> a) -> Int
h2 (g::(forall a. a ->a)) = let y = P (g 3) (g (P 3 4))
                            in 3

xs1 :: List (forall a. a ->a)
xs1 = let cons = Cons :: (forall a. a ->a)
                      -> List (forall a. a->a)
                      -> List (forall a. a ->a)
      in cons (\x -> x) Nil

xs2 :: List (forall a. a -> a)
xs2 = (Cons :: ((forall a. a->a)
            -> List (forall a. a->a)
            -> List (forall a. a->a)))
        (\x ->x) Nil

foo2 :: forall a. List a -> a -> a
foo2 x y = y

bar4 = (foo2 :: List (forall a. a->a) -> (forall a. a->a) -> (forall a.a->a))
           xs1 (\x -> x)


-- This one crashed the 6.6 release candidate

module ShouldCompile where

-- A specialise pragma with no type signature
fac n = fac (n + 1)
{-# SPECIALISE fac :: Int -> Int #-}


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

-- This tests scoped type variables, used in an expression
-- type signature in t1 and t2

module Foo7 where
import Control.Monad
import Control.Monad.ST
import Data.Array.MArray
import Data.Array.ST
import Data.STRef
import Data.Set hiding (map,filter)

-- a store that allows to mark keys
class Mark m store key | store -> key m where
     new   :: (key,key) -> m store
     mark  :: store -> key -> m ()
     markQ :: store -> key -> m Bool
     seen  :: store -> m [ key ]

-- implementation 1
instance Ord key => Mark (ST s) (STRef s (Set key)) key where
     new   _   = newSTRef empty
     mark  s k = modifySTRef s (insert k)
     markQ s k = liftM (member k) (readSTRef s)
     seen  s   = liftM elems (readSTRef s)

-- implementation 2
instance Ix key => Mark (ST s) (STUArray s key Bool) key where
     new   bnd = newArray bnd False
     mark  s k = writeArray s k True
     markQ     = readArray
     seen  s   = liftM (map fst . filter snd) (getAssocs s)

-- traversing the hull suc^*(start) with loop detection
trav suc start i = new i >>= \ c -> mapM_ (compo c) start >> return c
     where compo c x = markQ c x >>= flip unless (visit c x)
           visit c x = mark c x >> mapM_ (compo c) (suc x)

-- sample graph
f 1 = 1 : []
f n = n : f (if even n then div n 2 else 3*n+1)

t1 = runST ( (trav f [1..10] (1,52) >>= \ (s::STRef s (Set Int)) -> seen s)
            :: forall s. ST s [Int] )

t2 = runST ( (trav f [1..10] (1,52) >>= \ (s::STUArray s Int Bool) -> seen s)
            :: forall s. ST s [Int] )


{-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags -XGADTs #-}

-- This program sent GHC 6.6 into a loop, because the fixpointing
-- of the substitution in type refinement got its in-scope-set
-- from the answer!

module ShouldCompile where

------------------
data Foo a b where F :: a -> Foo () a

bar :: Foo () (forall a.a) -> ()
bar (F _) = ()

------------------
data Foo2 a where F2 :: a -> Foo2 [a]

bar2 :: Foo2 [forall a.a] -> ()
bar2 (F2 _) = ()


{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

-- Test for trac #366
-- The C2 case is impossible due to the types

module ShouldCompile where

data T a where
    C1 :: T Char
    C2 :: T Float

exhaustive :: T Char -> Char
exhaustive C1 = ' '


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

-- Test for trac #816
-- GHC's typechecker loops when trying to type this, resulting in a
-- context stack overflow.

{- Maybe this should typecheck:

   Given: Foo x y, Bar y z
   Wanted: Foo x beta, Bar beta z

If we happened to process (Foo x beta) first we
might generate the extra equality beta~y, and we are good

If we process (Bar beta z) first, we end up in an infinite
loop, using the (Bar x z) instance repeatedly.

If instead we'd had
   class (F x ~ y) => Foo x y where
     type F x
     foo :: x -> y

Then after canonicalising we get
     Given: Foo x y, Bar y z, F x ~ y
     Wanted: Foo x beta, Bar beta z
-}

module ShouldCompile where

class Foo x y | x -> y where
 foo :: x -> y

class Bar x z where
 bar :: x -> z -> Int

instance (Foo x y, Bar y z) => Bar x z where
 bar x z = bar (foo x) z


{-# OPTIONS_GHC -w #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}

module ShouldCompile where

import Control.Monad.Reader

instance Eq (a -> b) where
     _ == _ = error "whoops"

instance Show (a -> b) where
     show = const "<fun>"

-- This is the example from Trac #179
foo x = show (\_ -> True)

-- This is the example from Trac #963
instance (Num a, Monad m, Eq (m a), Show (m a)) => Num (m a) where
test = 1 True


{-# LANGUAGE ImplicitParams #-}

module ShouldCompile where

bar :: (Show a, ?c::a) => String
-- This type should not be reported as ambiguous
-- See the call in
bar = show ?c

foo = let { ?c = 'x' } in bar


{-# LANGUAGE ImplicitParams, NoMonomorphismRestriction #-}

module ShouldCompile where

-- c.f. tc218.hs, only no type signature here
-- Instead, the NoMonomorphismRestriction language
bar = show ?c

foo1 = let { ?c = 'x' } in bar
foo2 = let { ?c = True } in bar


{-# LANGUAGE DeriveDataTypeable #-}

-- See Trac #1033

module Pointful' where

import Data.Generics
import Control.Monad.State

data HsExp = HsWildCard deriving( Typeable, Data )
data HsName = HsName deriving( Typeable, Data )

-- rename :: () -> HsExp -> State (HsName, [HsName]) HsExp
-- Type sig commented out
rename1 = \_ -> everywhereM (mkM (\e -> case e of HsWildCard -> return e))

rename2 _ = everywhereM (mkM (\e -> case e of  HsWildCard -> return e))

uncomb1 :: State (HsName, [HsName]) HsExp
uncomb1 = rename1 () undefined

uncomb2 :: State (HsName, [HsName]) HsExp
uncomb2 = rename2 () undefined


{-# LANGUAGE GADTs #-}

-- A program very like this triggered a kind error with GHC 6.6

module Foo where

data PatchSeq p a b where
    Nil   :: PatchSeq p a b
    U  :: p a b -> PatchSeq p a b
    (:-)  :: PatchSeq p a b -> PatchSeq p b c -> PatchSeq p a c

-- is_normal :: PatchSeq p a b -> Bool
is_normal Nil = True
is_normal (U _) = True
is_normal (U _ :- _) = True
is_normal _ = False


{-# LANGUAGE ImplicitParams, RankNTypes #-}

-- Tests impredivative polymorphism with left-to-right
-- flow information; see the uses of "$"

module TestIP where

import Control.Monad.ST
import Data.STRef

-- Here's a use of runST with ($)
foo = runST $ (do { v <- newSTRef 0; readSTRef v })

-- Here's a use of implicit parameters with ($)

type PPDoc = (?env :: Int) => Char -> Char

f :: PPDoc -> PPDoc
f c = g $ c

-- Fully annotated version of f, as compiled by GHC 6.4.2
--
-- f ?env c = $ (C->C) (C->C)
--              (\(x:C->C). g ?env (\?env. x))
--              (c ?env)
--
-- The subsumption test needed from the call to $ is this:
--      ?env => (?env => C -> C) -> C -> C   <=  a->b
--      (?env => C -> C) -> C -> C   <=  a->b
--      (a) C->C <= b
--      (b) a <= (?env => C -> C)
-- And perhaps surprisingly (b) succeeds!

g :: PPDoc -> PPDoc
g d = d


{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
module Foo where

-- This example suggested by Yitzchak Gale

import Control.Monad.State
import Control.Monad.Error

class Error e => Game b mv e | b -> mv e where
    newBoard :: MonadState b m => m ()
        -- This method is unambiguous, because
        -- m determines b (via a fundep in MonadState)


{-# OPTIONS_GHC -XOverloadedStrings #-}
module T where

import Data.String

newtype MyString = MyString String deriving (Eq, Show)
instance IsString MyString where
    fromString = MyString

greet1 :: MyString -> MyString
greet1 "hello" = "world"
greet1 other = other

greet2 :: String -> String
greet2 "hello" = "world"
greet2 other = other

greet3 :: (Eq s, IsString s) => s -> s
greet3 "hello" = "world"
greet3 other = other

test = do
    print $ greet1 "hello"
    print $ greet2 "fool"
    print $ greet3 ("foo" :: String)
    print $ greet3 ("bar" :: MyString)


{-# LANGUAGE GADTs #-}

-- Newtype in GADT syntax

module ShouldCompile where

newtype Bug a where Bug :: a -> Bug a


{-# OPTIONS_GHC -O -funbox-strict-fields #-}

-- The combination of unboxing and a recursive newtype crashed GHC 6.6.1
-- Trac #1255
-- Use -O to force the unboxing to happen

module Foo where

newtype Bar = Bar Bar -- Recursive

data Gah = Gah { baaz  :: !Bar }


-- Ensure that tuple instances are brought into scope
-- See Trac #1385

module ShouldCompile where

foo = (1,True) == (2,False)


{-# LANGUAGE ExistentialQuantification #-}

-- Without a type sig this is slightly tricky.
-- See Trac #1430

-- Reason: we get an implication constraint (forall a. Typeable a => Typeable b),
-- when generalising unExTypeable.  We want to infer a context for the
-- whole thing of (Typeable b).
-- See Note [Inference and implication constraints] in TcSimplify

module Foo where

import Data.Typeable

data ExTypeable = forall a. Typeable a => ExTypeable a

-- unExTypeable :: Typeable h => ExTypeable -> Maybe h
unExTypeable (ExTypeable a) = cast a


{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}

-- trac #1406: Constraint doesn't reduce in the presence of quantified
--             type variables

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

module Problem where

data Z
data S a

class HPrefix l
instance (NSub (S Z) ndiff, HDrop ndiff l l) => HPrefix l
-- Weird test case: (NSub (S Z) ndiff) is simplifiable

class NSub n1 n3 | n1 -> n3
instance NSub Z Z
instance NSub n1 n3 => NSub (S n1) n3

class HDrop n l1 l2 | n l1 -> l2
instance HDrop Z l l

t_hPrefix :: HPrefix l => l -> ()
-- Weird test case: (HPrefix l) is simplifiable
t_hPrefix = undefined

-- In ghc 6.6.1 this works...
thr' :: (forall r. l -> a) -> a
thr' f = f undefined
thP4' = thr' t_hPrefix

-- ... but this doesn't work...?
thr :: (forall r. r -> a) -> a
thr f = f undefined
thP4 = thr t_hPrefix


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

-- Trac #1445

module Bug where

f :: () -> (?p :: ()) => () -> ()
f _ _ = ()

g :: (?p :: ()) => ()
g = f () ()


{-# OPTIONS_GHC -ddump-types -dsuppress-module-prefixes #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-}

-- See Trac #1456

-- The key thing here is that foo should get the type
--     foo :: forall b s t1. (Zork s (Z [Char]) b)
--         => Q s (Z [Char]) t1 -> ST s ()

-- Note the quantification over 'b', which was previously
-- omitted; see Note [Important subtlety in oclose] in FunDeps

module ShouldCompile where

import GHC.ST

data Q s a chain = Node s a chain

data Z a  = Z  a

s :: Q t (Z [Char]) t1 -> Q t (Z [Char]) t1
s = undefined

class  Zork s a b | a -> b where
  huh :: Q s a chain ->  ST s ()

foo b = huh (s b)


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

-- This one fixed the constraint solver (Lint error)
-- See Trac #1494

module ShouldCompile where

import Control.Monad.State

newtype L m r = L (StateT Int m r)

instance Functor (L m) where
  fmap = undefined

instance Applicative (L m) where
  pure  = undefined
  (<*>) = undefined

instance Monad m => Monad (L m) where
  (>>=)  = undefined
  return = undefined

zork :: (Monad m) => a -> L m ()
zork = undefined

mumble e = do { modify id; zork e }


{-# LANGUAGE RankNTypes #-}

module ShouldCompile where

newtype Swizzle = MkSwizzle (forall a. Ord a => [a] -> [a])


{-# OPTIONS_GHC -XLiberalTypeSynonyms #-}

module ShouldCompile where

type T a b = a
type S m   = m ()

f :: S (T Int)
f = undefined


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances,
             MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
    -- 'x' and 'v' are ambiguous

-- Trac #1564

module Foo where

import Text.PrettyPrint
import Prelude hiding(head,tail)

class FooBar m k l | m -> k l where
 a :: m graphtype

instance FooBar [] Bool Bool where
  a = error "urk"

instance FooBar Maybe Int Int where
  a = error "urk"

class (Monad m)=>Gr g ep m where
 x:: m Int
 v:: m Int

instance (Monad m,  FooBar m x z) =>  Gr g ep m  where
  x = error "urk"
  v = error "urk"

-- Old GHC claims for y:  y :: (Monad m, FooBar m GHC.Prim.Any GHC.Prim.Any)
--                          => m Int (which is wrong)
-- The uses in foo and bar show if that happens
y () = x

foo :: [Int]
foo = y ()

bar :: Maybe Int
bar = y ()


{-# LANGUAGE RankNTypes #-}

module ShouldCompile where

-- Check that we can have a forall to the right of a double-arrow

f :: forall a. (Num a) => forall b. (Ord b) => a -> b -> b -> a
f x y z = if y>z then x+1 else x

g :: (Num a) => (Ord b) => a -> b -> b -> a
g x y z = if y>z then x+1 else x


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

-- This one caught a bug in the implementation of functional
-- dependencies, where improvement must happen when
-- checking the call in 'test4'

module ShouldCompile where

newtype M s a = M a

class Modular s a | s -> a

wim ::  forall a w. Integral a
                      => a -> (forall s. Modular s a => M s w) -> w
wim i k = error "urk"

test4'  ::  (Modular s a, Integral a) => M s a
test4'  =   error "urk"

test4   =   wim 4 test4'
--   Integral a0, (Modular s a0 => Modular s1 a1, Integral a1, M s1 a1 ~ M s w0)
--   Under the implication, [D] a1 ~ a0, [W] a1 ~ w0
--   Hence a1 := w0, [D] w0 ~ a0


-- This innocuous module made GHC 6.6 have exponential behaviour
-- when doing validity checking on the synonym declarations
--
-- This lot is enough to make the test time out, I hope

module ShouldCompile where

data TIACons1 i r c = K (c i) (r c)

type TIACons2  t x = TIACons1 t (TIACons1 t x)
type TIACons3  t x = TIACons2 t (TIACons1 t x)
type TIACons4  t x = TIACons2 t (TIACons2 t x)
type TIACons7  t x = TIACons4 t (TIACons3 t x)
type TIACons8  t x = TIACons4 t (TIACons4 t x)
type TIACons15 t x = TIACons8 t (TIACons7 t x)
type TIACons16 t x = TIACons8 t (TIACons8 t x)
type TIACons31 t x = TIACons16 t (TIACons15 t x)
type TIACons32 t x = TIACons16 t (TIACons16 t x)
type TIACons47 t x = TIACons32 t (TIACons15 t x)
type TIACons48 t x = TIACons32 t (TIACons16 t x)


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

module ShouldCompile where

import Tc239_Help

f1 :: Show a => WrapIO e a
f1 = return undefined

f2 :: Show a => WrapIO2 a
f2 = f1


module Tc239_Help ( WrapIO, WrapIO2 ) where

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

newtype WrapIO e a = MkWrapIO { unwrap :: IO a }

type WrapIO2 a = WrapIO String a

instance Functor (WrapIO e) where
    fmap = liftM

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

instance Monad (WrapIO e) where
  return x = MkWrapIO (return x)

  m >>= f  = MkWrapIO (do x <- unwrap m
                          unwrap (f x) )

  fail str = error str


-- Checks that the types of the old binder and the binder implicitly introduced by grouping are linked

{-# OPTIONS_GHC -XTransformListComp #-}

module ShouldCompile where

import Data.List(inits)

foo :: [[[Int]]]
foo = [ x
      | x <- [1..10]
      , then group using inits
      , then group using inits
      ]


{-# OPTIONS_GHC -XGADTs -XRankNTypes -O1 #-}
-- Trac #2018

module Bug1 where

 data A a where
   MkA :: A ()

 class C w where
   f :: forall a . w a -> Maybe a

 instance C A where
   f MkA  = Just ()


{-# LANGUAGE ScopedTypeVariables #-}
module Bug where

f1 :: forall a. [a] -> [a]
f1 (x:xs) = xs ++ [ x :: a ]   -- OK

f2 :: forall a. [a] -> [a]
f2 = \(x:xs) -> xs ++ [ x :: a ]   -- OK

-- This pair is a cut-down version of Trac #2030
isSafe alts = isSafeAlts alts

isSafeAlts :: forall m . Int -> m Int
isSafeAlts x = error "urk"
  where
    isSafeAlt :: Int -> m Int
    isSafeAlt alt = isSafe `seq` error "urk"


{-# OPTIONS_GHC -Wall #-}

module Bug where

-- When we warn about this, we give a warning saying
--    Inferred type: (.+.) :: forall a. a
-- but we used to not print the parentheses.

(.+.) = undefined


{-# LANGUAGE TypeFamilies, GADTs #-}

-- Tests record update in the presence of
-- existentials, GADTs, type families

module Rec where

----------------- Existential
data S a where
   S1 :: { fs1 :: a, fs2 :: b } -> S a
   S2 :: { fs1 :: a } -> S a

updS s x = s { fs1=x }

{-
------------------ GADT
data T a b where
   T1 :: { ft1 :: a, ft2 :: c, ft3 :: d } -> T a Int
   T2 :: { ft1 :: a, ft3 :: c } -> T a Int
   T3 :: T Int b

f :: T a1 b -> a2 -> T a2 b
f x v = x { ft1 = v }

------------------ Type family
data family R a
data instance R (a,b) where
   R1 :: { fr1 :: a, fr2 :: b, fr3 :: c } -> R (a,b)
   R2 :: { fr1 :: a, fr3 :: c } -> R (a,b)

updR r x = r { fr1=x }
-}


-- Test for trac #2937

{-# LANGUAGE GADTs, TypeFamilies #-}

module Tc245 where

import Tc245_A

instance Foo Int where
    data Bar Int x where
        Baz :: Bar Int String


{-# LANGUAGE TypeFamilies #-}
module Tc245_A where

import Data.Kind (Type)

class Foo a where
    data Bar a :: Type -> Type


-- Test for trac #3066
-- GHC with optimisation off would go into an infinite loop

module Tc246 () where

newtype Foo = Foo Foo


{-# LANGUAGE GADTs, EmptyDataDecls, KindSignatures #-}

module ShouldCompile where

import Data.Kind (Type)

-- Various forms of empty data type declarations

data T1

data T2 where

data T3 :: Type -> Type

data T4 a :: Type -> Type

data T5 a :: Type -> Type where


{-# LANGUAGE ExplicitForAll #-}

module ShouldCompile where

identity :: forall a. a -> a
identity x = x


module Ctx where

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


{-# LANGUAGE TypeFamilies #-}
module ShouldCompile where

import Data.Kind (Type)

class Cls a where
    type Fam a :: Type
    type Fam a = Maybe a

instance Cls Int where
    -- Gets type family from default

inc :: (Fam a ~ Maybe Int) => a -> Fam a -> Fam a
inc _proxy (Just x) = Just (x + 1)
inc _proxy Nothing  = Just 0

foo :: Maybe Int -> Maybe Int
foo = inc (undefined :: Int)


{-# LANGUAGE TypeFamilies #-}
module ShouldCompile where

import Tc251_Help

instance Cls Int where

inc :: (Fam a ~ Maybe Int) => a -> Fam a -> Fam a
inc _proxy (Just x) = Just (x + 1)
inc _proxy Nothing  = Just 0

foo :: Maybe Int -> Maybe Int
foo = inc (undefined :: Int)


{-# LANGUAGE TypeFamilies #-}
module Tc251_Help where

import Data.Kind (Type)

class Cls a where
    type Fam a :: Type
    type Fam a = Maybe a


{-# LANGUAGE TypeFamilies #-}
module ShouldCompile where

import Data.Kind (Type)

class Cls a where
    type Fam a :: Type
    type Fam a = Maybe a

instance Cls Int where
    -- Overriding default
    type Fam Int = Bool

nott :: (Fam a ~ Bool) => a -> Fam a -> Fam a
nott _proxy False = True
nott _proxy True  = False

foo :: Bool -> Bool
foo = nott (undefined :: Int)


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
  -- this is needed because |FamHelper a x| /< |Fam a x|
module ShouldCompile where

import Data.Kind (Type)

class Cls a where
    type Fam a b :: Type
    -- Multiple defaults!
    type Fam a x = FamHelper a x

type family FamHelper a x
type instance FamHelper a Bool = Maybe a
type instance FamHelper a Int  = (String, a)

instance Cls Int where
    -- Gets type family from default

inc :: (Fam a Bool ~ Maybe Int, Fam a Int ~ (String, Int)) => a -> Fam a Bool -> Fam a Int -> Fam a Bool
inc _proxy (Just x) (_, y) = Just (x + y + 1)
inc _proxy Nothing  (_, y) = Just y

foo :: Maybe Int -> (String, Int) -> Maybe Int
foo = inc (undefined :: Int)


{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fwarn-missing-methods #-}
module AssocTyDef01 where

class Cls a where
    type Typ a

instance Cls Int where
    -- No default: should get warning


{-# LANGUAGE TypeFamilies, ConstraintKinds, UndecidableInstances #-}
module Ctx where

import Data.Kind ( Type, Constraint )

type family Indirect :: Type -> Constraint
type instance Indirect = Show

class Cls a where
    f :: a -> String

instance Indirect a => Cls [a] where
    f = show


{-# LANGUAGE TypeFamilies, ConstraintKinds, UndecidableInstances, UndecidableSuperClasses #-}
module Ctx where

import Data.Kind ( Type, Constraint )

type family Indirect :: Type -> Constraint
type instance Indirect = Show

class Indirect a => Cls a where

foo :: Cls a => a -> String
foo = show


{-# LANGUAGE KindSignatures, ConstraintKinds, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
module Ctx where

import Data.Kind ( Type, Constraint )

data Proxy (ctxt :: Type -> Constraint) = Proxy

-- At one time, this one worked:
nonmeth :: ctxt Int => Proxy ctxt -> a
nonmeth prox = nonmeth prox

class Foo (ctxt :: Type -> Constraint) a where
    meth :: ctxt a => Proxy ctxt -> a

instance ctxt Int => Foo ctxt Int where
    -- But this one didn't:
    meth prox = meth prox

-- The error was:
-- Could not deduce (ctxt Int) arising from a use of `meth'
-- from the context (ctxt Int)

-- The problem was that irreducible evidence did not interact with
-- evidence of equal type.


{-# LANGUAGE ConstraintKinds, TypeFamilies, UndecidableInstances #-}

module AltPrelude where

import Data.Kind (Constraint)

class MyFunctor f where
       type FunctorCtxt f a :: Constraint
       type FunctorCtxt f a = ()
       (<$>) :: (FunctorCtxt f a, FunctorCtxt f b) => (a -> b) -> f a -> f b

class MyFunctor ap => MyApplicative ap where
       type ApplicativeCtxt ap a :: Constraint
       type ApplicativeCtxt ap a = FunctorCtxt ap a
       (<***>) :: (ApplicativeCtxt ap a, ApplicativeCtxt ap b) => ap (a -> b) -> ap a -> ap b


-- Test we don't get a cycle for "phantom" superclasses
{-# LANGUAGE ConstraintKinds, MultiParamTypeClasses, FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
    -- 'meth' is ambiguous

module TcOK where

class A cls c where
    meth :: cls c => c -> c

class A B c => B c where


-- Test we don't get a cycle for "phantom" superclasses,
-- even if the phantomness is behind a type synonym
{-# LANGUAGE ConstraintKinds, MultiParamTypeClasses, FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
    -- 'meth' is ambiguous

module TcOK where

class A ctxt c where
    meth :: ctxt => c -> c

type Bish = B Int

class A Bish c => B c where


{-# LANGUAGE TypeOperators #-}
module TcOK where

newtype (f <.> g) a = Compose (f (g a))


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

-- Liberated IncoherentInstances behavior (#8141)

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

instance C Int b where foo = undefined
instance C a Int where foo = undefined

x :: (Int, Int)
x = foo

main = return ()


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

-- Get a non-incoherent instance from that file
import Tc263_Help

instance C [a] b where foo = undefined
instance C a Int where foo = undefined

y :: ([Int],Int)
y = foo

main = return ()


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

module Tc263_Help where

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

instance C [Int] b where foo = undefined


{-# LANGUAGE TypeFamilies #-}

module Tc265 where

data T a = MkT (F a)
type family F a where
  F (T a) = a
  F (T Int) = Bool


module Tc266 where
import Tc266a
data T = T
f = T


module Tc266a where
import {-# SOURCE #-} Tc266


{-# LANGUAGE DeriveDataTypeable #-}
module Tc267a where
import {-# SOURCE #-} Tc267b
data T = T deriving (Show)
data S = S
x = y


{-# LANGUAGE DeriveDataTypeable #-}
module Tc267b where
import Tc267a
y = S


{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ConstraintKinds #-}
module Tc268 where
import GHC.Exts
type A = (() :: Constraint)


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

import GHC.Types

{-
-- We'd like this to kind check, but it doesn't today,
-- see Note [Missed opportunity to retain higher-rank kinds]

-- TSyn is in an SCC of its own, so we can read off the
-- kind directly.
data T (p :: forall k. k -> Type) = T
type TSyn = T
-}

-- S and SSyn are in an SCC, so we do kind inference for
-- everything.  Need an explicit type signature.
data K (a :: k) = K
data S (p :: forall k. k -> Type) = S (SSyn K)
type SSyn = (S :: (forall k. k -> Type) -> Type)


module Tc270 where

-- Type synonym stress test... though, it does seem that we
-- are quadratic in the number of nested type synonyms.

type T0 = ()
type T1 = T0
type T2 = T1
type T3 = T2
type T4 = T3
type T5 = T4
type T6 = T5
type T7 = T6
type T8 = T7
type T9 = T8
type T10 = T9
type T11 = T10
type T12 = T11
type T13 = T12
type T14 = T13
type T15 = T14
type T16 = T15
type T17 = T16
type T18 = T17
type T19 = T18
type T20 = T19
type T21 = T20
type T22 = T21
type T23 = T22
type T24 = T23
type T25 = T24
type T26 = T25
type T27 = T26
type T28 = T27
type T29 = T28
type T30 = T29
type T31 = T30
type T32 = T31
type T33 = T32
type T34 = T33
type T35 = T34
type T36 = T35
type T37 = T36
type T38 = T37
type T39 = T38
type T40 = T39
type T41 = T40
type T42 = T41
type T43 = T42
type T44 = T43
type T45 = T44
type T46 = T45
type T47 = T46
type T48 = T47
type T49 = T48
type T50 = T49
type T51 = T50
type T52 = T51
type T53 = T52
type T54 = T53
type T55 = T54
type T56 = T55
type T57 = T56
type T58 = T57
type T59 = T58
type T60 = T59
type T61 = T60
type T62 = T61
type T63 = T62
type T64 = T63
type T65 = T64
type T66 = T65
type T67 = T66
type T68 = T67
type T69 = T68
type T70 = T69
type T71 = T70
type T72 = T71
type T73 = T72
type T74 = T73
type T75 = T74
type T76 = T75
type T77 = T76
type T78 = T77
type T79 = T78
type T80 = T79
type T81 = T80
type T82 = T81
type T83 = T82
type T84 = T83
type T85 = T84
type T86 = T85
type T87 = T86
type T88 = T87
type T89 = T88
type T90 = T89
type T91 = T90
type T92 = T91
type T93 = T92
type T94 = T93
type T95 = T94
type T96 = T95
type T97 = T96
type T98 = T97
type T99 = T98
type T100 = T99
type T101 = T100
type T102 = T101
type T103 = T102
type T104 = T103
type T105 = T104
type T106 = T105
type T107 = T106
type T108 = T107
type T109 = T108
type T110 = T109
type T111 = T110
type T112 = T111
type T113 = T112
type T114 = T113
type T115 = T114
type T116 = T115
type T117 = T116
type T118 = T117
type T119 = T118
type T120 = T119
type T121 = T120
type T122 = T121
type T123 = T122
type T124 = T123
type T125 = T124
type T126 = T125
type T127 = T126
type T128 = T127
type T129 = T128
type T130 = T129
type T131 = T130
type T132 = T131
type T133 = T132
type T134 = T133
type T135 = T134
type T136 = T135
type T137 = T136
type T138 = T137
type T139 = T138
type T140 = T139
type T141 = T140
type T142 = T141
type T143 = T142
type T144 = T143
type T145 = T144
type T146 = T145
type T147 = T146
type T148 = T147
type T149 = T148
type T150 = T149
type T151 = T150
type T152 = T151
type T153 = T152
type T154 = T153
type T155 = T154
type T156 = T155
type T157 = T156
type T158 = T157
type T159 = T158
type T160 = T159
type T161 = T160
type T162 = T161
type T163 = T162
type T164 = T163
type T165 = T164
type T166 = T165
type T167 = T166
type T168 = T167
type T169 = T168
type T170 = T169
type T171 = T170
type T172 = T171
type T173 = T172
type T174 = T173
type T175 = T174
type T176 = T175
type T177 = T176
type T178 = T177
type T179 = T178
type T180 = T179
type T181 = T180
type T182 = T181
type T183 = T182
type T184 = T183
type T185 = T184
type T186 = T185
type T187 = T186
type T188 = T187
type T189 = T188
type T190 = T189
type T191 = T190
type T192 = T191
type T193 = T192
type T194 = T193
type T195 = T194
type T196 = T195
type T197 = T196
type T198 = T197
type T199 = T198
type T200 = T199
type T201 = T200
type T202 = T201
type T203 = T202
type T204 = T203
type T205 = T204
type T206 = T205
type T207 = T206
type T208 = T207
type T209 = T208
type T210 = T209
type T211 = T210
type T212 = T211
type T213 = T212
type T214 = T213
type T215 = T214
type T216 = T215
type T217 = T216
type T218 = T217
type T219 = T218
type T220 = T219
type T221 = T220
type T222 = T221
type T223 = T222
type T224 = T223
type T225 = T224
type T226 = T225
type T227 = T226
type T228 = T227
type T229 = T228
type T230 = T229
type T231 = T230
type T232 = T231
type T233 = T232
type T234 = T233
type T235 = T234
type T236 = T235
type T237 = T236
type T238 = T237
type T239 = T238
type T240 = T239
type T241 = T240
type T242 = T241
type T243 = T242
type T244 = T243
type T245 = T244
type T246 = T245
type T247 = T246
type T248 = T247
type T249 = T248
type T250 = T249
type T251 = T250
type T252 = T251
type T253 = T252
type T254 = T253
type T255 = T254
type T256 = T255
type T257 = T256
type T258 = T257
type T259 = T258
type T260 = T259
type T261 = T260
type T262 = T261
type T263 = T262
type T264 = T263
type T265 = T264
type T266 = T265
type T267 = T266
type T268 = T267
type T269 = T268
type T270 = T269
type T271 = T270
type T272 = T271
type T273 = T272
type T274 = T273
type T275 = T274
type T276 = T275
type T277 = T276
type T278 = T277
type T279 = T278
type T280 = T279
type T281 = T280
type T282 = T281
type T283 = T282
type T284 = T283
type T285 = T284
type T286 = T285
type T287 = T286
type T288 = T287
type T289 = T288
type T290 = T289
type T291 = T290
type T292 = T291
type T293 = T292
type T294 = T293
type T295 = T294
type T296 = T295
type T297 = T296
type T298 = T297
type T299 = T298
type T300 = T299
type T301 = T300
type T302 = T301
type T303 = T302
type T304 = T303
type T305 = T304
type T306 = T305
type T307 = T306
type T308 = T307
type T309 = T308
type T310 = T309
type T311 = T310
type T312 = T311
type T313 = T312
type T314 = T313
type T315 = T314
type T316 = T315
type T317 = T316
type T318 = T317
type T319 = T318
type T320 = T319
type T321 = T320
type T322 = T321
type T323 = T322
type T324 = T323
type T325 = T324
type T326 = T325
type T327 = T326
type T328 = T327
type T329 = T328
type T330 = T329
type T331 = T330
type T332 = T331
type T333 = T332
type T334 = T333
type T335 = T334
type T336 = T335
type T337 = T336
type T338 = T337
type T339 = T338
type T340 = T339
type T341 = T340
type T342 = T341
type T343 = T342
type T344 = T343
type T345 = T344
type T346 = T345
type T347 = T346
type T348 = T347
type T349 = T348
type T350 = T349
type T351 = T350
type T352 = T351
type T353 = T352
type T354 = T353
type T355 = T354
type T356 = T355
type T357 = T356
type T358 = T357
type T359 = T358
type T360 = T359
type T361 = T360
type T362 = T361
type T363 = T362
type T364 = T363
type T365 = T364
type T366 = T365
type T367 = T366
type T368 = T367
type T369 = T368
type T370 = T369
type T371 = T370
type T372 = T371
type T373 = T372
type T374 = T373
type T375 = T374
type T376 = T375
type T377 = T376
type T378 = T377
type T379 = T378
type T380 = T379
type T381 = T380
type T382 = T381
type T383 = T382
type T384 = T383
type T385 = T384
type T386 = T385
type T387 = T386
type T388 = T387
type T389 = T388
type T390 = T389
type T391 = T390
type T392 = T391
type T393 = T392
type T394 = T393
type T395 = T394
type T396 = T395
type T397 = T396
type T398 = T397
type T399 = T398
type T400 = T399
type T401 = T400
type T402 = T401
type T403 = T402
type T404 = T403
type T405 = T404
type T406 = T405
type T407 = T406
type T408 = T407
type T409 = T408
type T410 = T409
type T411 = T410
type T412 = T411
type T413 = T412
type T414 = T413
type T415 = T414
type T416 = T415
type T417 = T416
type T418 = T417
type T419 = T418
type T420 = T419
type T421 = T420
type T422 = T421
type T423 = T422
type T424 = T423
type T425 = T424
type T426 = T425
type T427 = T426
type T428 = T427
type T429 = T428
type T430 = T429
type T431 = T430
type T432 = T431
type T433 = T432
type T434 = T433
type T435 = T434
type T436 = T435
type T437 = T436
type T438 = T437
type T439 = T438
type T440 = T439
type T441 = T440
type T442 = T441
type T443 = T442
type T444 = T443
type T445 = T444
type T446 = T445
type T447 = T446
type T448 = T447
type T449 = T448
type T450 = T449
type T451 = T450
type T452 = T451
type T453 = T452
type T454 = T453
type T455 = T454
type T456 = T455
type T457 = T456
type T458 = T457
type T459 = T458
type T460 = T459
type T461 = T460
type T462 = T461
type T463 = T462
type T464 = T463
type T465 = T464
type T466 = T465
type T467 = T466
type T468 = T467
type T469 = T468
type T470 = T469
type T471 = T470
type T472 = T471
type T473 = T472
type T474 = T473
type T475 = T474
type T476 = T475
type T477 = T476
type T478 = T477
type T479 = T478
type T480 = T479
type T481 = T480
type T482 = T481
type T483 = T482
type T484 = T483
type T485 = T484
type T486 = T485
type T487 = T486
type T488 = T487
type T489 = T488
type T490 = T489
type T491 = T490
type T492 = T491
type T493 = T492
type T494 = T493
type T495 = T494
type T496 = T495
type T497 = T496
type T498 = T497
type T499 = T498
type T500 = T499
type T501 = T500
type T502 = T501
type T503 = T502
type T504 = T503
type T505 = T504
type T506 = T505
type T507 = T506
type T508 = T507
type T509 = T508
type T510 = T509
type T511 = T510
type T512 = T511
type T513 = T512
type T514 = T513
type T515 = T514
type T516 = T515
type T517 = T516
type T518 = T517
type T519 = T518
type T520 = T519
type T521 = T520
type T522 = T521
type T523 = T522
type T524 = T523
type T525 = T524
type T526 = T525
type T527 = T526
type T528 = T527
type T529 = T528
type T530 = T529
type T531 = T530
type T532 = T531
type T533 = T532
type T534 = T533
type T535 = T534
type T536 = T535
type T537 = T536
type T538 = T537
type T539 = T538
type T540 = T539
type T541 = T540
type T542 = T541
type T543 = T542
type T544 = T543
type T545 = T544
type T546 = T545
type T547 = T546
type T548 = T547
type T549 = T548
type T550 = T549
type T551 = T550
type T552 = T551
type T553 = T552
type T554 = T553
type T555 = T554
type T556 = T555
type T557 = T556
type T558 = T557
type T559 = T558
type T560 = T559
type T561 = T560
type T562 = T561
type T563 = T562
type T564 = T563
type T565 = T564
type T566 = T565
type T567 = T566
type T568 = T567
type T569 = T568
type T570 = T569
type T571 = T570
type T572 = T571
type T573 = T572
type T574 = T573
type T575 = T574
type T576 = T575
type T577 = T576
type T578 = T577
type T579 = T578
type T580 = T579
type T581 = T580
type T582 = T581
type T583 = T582
type T584 = T583
type T585 = T584
type T586 = T585
type T587 = T586
type T588 = T587
type T589 = T588
type T590 = T589
type T591 = T590
type T592 = T591
type T593 = T592
type T594 = T593
type T595 = T594
type T596 = T595
type T597 = T596
type T598 = T597
type T599 = T598
type T600 = T599
type T601 = T600
type T602 = T601
type T603 = T602
type T604 = T603
type T605 = T604
type T606 = T605
type T607 = T606
type T608 = T607
type T609 = T608
type T610 = T609
type T611 = T610
type T612 = T611
type T613 = T612
type T614 = T613
type T615 = T614
type T616 = T615
type T617 = T616
type T618 = T617
type T619 = T618
type T620 = T619
type T621 = T620
type T622 = T621
type T623 = T622
type T624 = T623
type T625 = T624
type T626 = T625
type T627 = T626
type T628 = T627
type T629 = T628
type T630 = T629
type T631 = T630
type T632 = T631
type T633 = T632
type T634 = T633
type T635 = T634
type T636 = T635
type T637 = T636
type T638 = T637
type T639 = T638
type T640 = T639
type T641 = T640
type T642 = T641
type T643 = T642
type T644 = T643
type T645 = T644
type T646 = T645
type T647 = T646
type T648 = T647
type T649 = T648
type T650 = T649
type T651 = T650
type T652 = T651
type T653 = T652
type T654 = T653
type T655 = T654
type T656 = T655
type T657 = T656
type T658 = T657
type T659 = T658
type T660 = T659
type T661 = T660
type T662 = T661
type T663 = T662
type T664 = T663
type T665 = T664
type T666 = T665
type T667 = T666
type T668 = T667
type T669 = T668
type T670 = T669
type T671 = T670
type T672 = T671
type T673 = T672
type T674 = T673
type T675 = T674
type T676 = T675
type T677 = T676
type T678 = T677
type T679 = T678
type T680 = T679
type T681 = T680
type T682 = T681
type T683 = T682
type T684 = T683
type T685 = T684
type T686 = T685
type T687 = T686
type T688 = T687
type T689 = T688
type T690 = T689
type T691 = T690
type T692 = T691
type T693 = T692
type T694 = T693
type T695 = T694
type T696 = T695
type T697 = T696
type T698 = T697
type T699 = T698
type T700 = T699
type T701 = T700
type T702 = T701
type T703 = T702
type T704 = T703
type T705 = T704
type T706 = T705
type T707 = T706
type T708 = T707
type T709 = T708
type T710 = T709
type T711 = T710
type T712 = T711
type T713 = T712
type T714 = T713
type T715 = T714
type T716 = T715
type T717 = T716
type T718 = T717
type T719 = T718
type T720 = T719
type T721 = T720
type T722 = T721
type T723 = T722
type T724 = T723
type T725 = T724
type T726 = T725
type T727 = T726
type T728 = T727
type T729 = T728
type T730 = T729
type T731 = T730
type T732 = T731
type T733 = T732
type T734 = T733
type T735 = T734
type T736 = T735
type T737 = T736
type T738 = T737
type T739 = T738
type T740 = T739
type T741 = T740
type T742 = T741
type T743 = T742
type T744 = T743
type T745 = T744
type T746 = T745
type T747 = T746
type T748 = T747
type T749 = T748
type T750 = T749
type T751 = T750
type T752 = T751
type T753 = T752
type T754 = T753
type T755 = T754
type T756 = T755
type T757 = T756
type T758 = T757
type T759 = T758
type T760 = T759
type T761 = T760
type T762 = T761
type T763 = T762
type T764 = T763
type T765 = T764
type T766 = T765
type T767 = T766
type T768 = T767
type T769 = T768
type T770 = T769
type T771 = T770
type T772 = T771
type T773 = T772
type T774 = T773
type T775 = T774
type T776 = T775
type T777 = T776
type T778 = T777
type T779 = T778
type T780 = T779
type T781 = T780
type T782 = T781
type T783 = T782
type T784 = T783
type T785 = T784
type T786 = T785
type T787 = T786
type T788 = T787
type T789 = T788
type T790 = T789
type T791 = T790
type T792 = T791
type T793 = T792
type T794 = T793
type T795 = T794
type T796 = T795
type T797 = T796
type T798 = T797
type T799 = T798
type T800 = T799
type T801 = T800
type T802 = T801
type T803 = T802
type T804 = T803
type T805 = T804
type T806 = T805
type T807 = T806
type T808 = T807
type T809 = T808
type T810 = T809
type T811 = T810
type T812 = T811
type T813 = T812
type T814 = T813
type T815 = T814
type T816 = T815
type T817 = T816
type T818 = T817
type T819 = T818
type T820 = T819
type T821 = T820
type T822 = T821
type T823 = T822
type T824 = T823
type T825 = T824
type T826 = T825
type T827 = T826
type T828 = T827
type T829 = T828
type T830 = T829
type T831 = T830
type T832 = T831
type T833 = T832
type T834 = T833
type T835 = T834
type T836 = T835
type T837 = T836
type T838 = T837
type T839 = T838
type T840 = T839
type T841 = T840
type T842 = T841
type T843 = T842
type T844 = T843
type T845 = T844
type T846 = T845
type T847 = T846
type T848 = T847
type T849 = T848
type T850 = T849
type T851 = T850
type T852 = T851
type T853 = T852
type T854 = T853
type T855 = T854
type T856 = T855
type T857 = T856
type T858 = T857
type T859 = T858
type T860 = T859
type T861 = T860
type T862 = T861
type T863 = T862
type T864 = T863
type T865 = T864
type T866 = T865
type T867 = T866
type T868 = T867
type T869 = T868
type T870 = T869
type T871 = T870
type T872 = T871
type T873 = T872
type T874 = T873
type T875 = T874
type T876 = T875
type T877 = T876
type T878 = T877
type T879 = T878
type T880 = T879
type T881 = T880
type T882 = T881
type T883 = T882
type T884 = T883
type T885 = T884
type T886 = T885
type T887 = T886
type T888 = T887
type T889 = T888
type T890 = T889
type T891 = T890
type T892 = T891
type T893 = T892
type T894 = T893
type T895 = T894
type T896 = T895
type T897 = T896
type T898 = T897
type T899 = T898
type T900 = T899
type T901 = T900
type T902 = T901
type T903 = T902
type T904 = T903
type T905 = T904
type T906 = T905
type T907 = T906
type T908 = T907
type T909 = T908
type T910 = T909
type T911 = T910
type T912 = T911
type T913 = T912
type T914 = T913
type T915 = T914
type T916 = T915
type T917 = T916
type T918 = T917
type T919 = T918
type T920 = T919
type T921 = T920
type T922 = T921
type T923 = T922
type T924 = T923
type T925 = T924
type T926 = T925
type T927 = T926
type T928 = T927
type T929 = T928
type T930 = T929
type T931 = T930
type T932 = T931
type T933 = T932
type T934 = T933
type T935 = T934
type T936 = T935
type T937 = T936
type T938 = T937
type T939 = T938
type T940 = T939
type T941 = T940
type T942 = T941
type T943 = T942
type T944 = T943
type T945 = T944
type T946 = T945
type T947 = T946
type T948 = T947
type T949 = T948
type T950 = T949
type T951 = T950
type T952 = T951
type T953 = T952
type T954 = T953
type T955 = T954
type T956 = T955
type T957 = T956
type T958 = T957
type T959 = T958
type T960 = T959
type T961 = T960
type T962 = T961
type T963 = T962
type T964 = T963
type T965 = T964
type T966 = T965
type T967 = T966
type T968 = T967
type T969 = T968
type T970 = T969
type T971 = T970
type T972 = T971
type T973 = T972
type T974 = T973
type T975 = T974
type T976 = T975
type T977 = T976
type T978 = T977
type T979 = T978
type T980 = T979
type T981 = T980
type T982 = T981
type T983 = T982
type T984 = T983
type T985 = T984
type T986 = T985
type T987 = T986
type T988 = T987
type T989 = T988
type T990 = T989
type T991 = T990
type T992 = T991
type T993 = T992
type T994 = T993
type T995 = T994
type T996 = T995
type T997 = T996
type T998 = T997
type T999 = T998
type T1000 = T999


module Tc271 where

import Tc271a

class K a where
    f :: a -> a
    g :: a -> a

h :: K a => a -> a
h = f . g . h2


module Tc271a where
import {-# SOURCE #-} Tc271

h2 :: K a => a -> a
h2 = h


{-# LANGUAGE RoleAnnotations #-}
{-# OPTIONS_GHC -fwarn-unused-imports  #-}

import Data.Coerce
import Data.Proxy
import Data.Monoid (First(First)) -- check whether the implicit use of First is noted

-- see https://ghc.haskell.org/trac/ghc/wiki/Design/NewCoercibleSolver/V2

foo1 :: f a -> f a
foo1 = coerce

newtype X = MkX (Int -> X)
foo2 :: X -> X
foo2 = coerce

newtype X2 a = MkX2 Char
type role X2 nominal

foo3 :: X2 Int -> X2 Bool
foo3 = coerce

newtype Age = MkAge Int
newtype Y a = MkY a
type role Y nominal

foo4 :: Y Age -> Y Int
foo4 = coerce

newtype Z a = MkZ ()
type role Z representational

foo5 :: Z Int -> Z Bool
foo5 = coerce

newtype App f a = MkApp (f a)

foo6 :: f a -> App f a
foo6 = coerce

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

foo8 :: (Coercible a b, Coercible b c) => Proxy b -> a -> c
foo8 _ = coerce

main = print (coerce $ Just (1::Int)  :: First Int)


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
module TcCustomSolverSuper where

import GHC.TypeLits
import Data.Typeable

{-

When solving super-class instances, GHC solves the evidence without
using the solver (see `tcSuperClasses` in `TcInstDecls`).

However, some classes need to be excepted from this behavior,
as they have custom solving rules, and this test checks that
we got this right.

PS: this test used to have Typeable in the context too, but
    that's a redundant constraint, so I removed it

PPS: the whole structre of tcSuperClasses has changed,
     so I'm no longer sure what is being tested here
-}

class (KnownNat x)    => C x
class (KnownSymbol x) => D x

instance C 2
instance D "2"


{-# LANGUAGE LambdaCase #-}

module TcLambdaCase where

import Data.Bits ((.|.))

f1 :: (a -> a) -> (a -> a)
f1 = \case x -> x

f2 :: Num a => a -> a
f2 = \case x -> x + x

f3 :: Int -> (Int, Int)
f3 = (\case y -> (y + y, y * y)) . (.|. 12)

f4 = \case _ -> undefined


{-# LANGUAGE StaticPointers #-}

module StaticPointers01 where

import GHC.StaticPtr

f0 :: StaticPtr (Int -> Int)
f0 = static g

f1 :: StaticPtr (Bool -> Bool -> Bool)
f1 = static (&&)

f2 :: StaticPtr (Bool -> Bool -> Bool)
f2 = static ((&&) . id)

g :: Int -> Int
g = id


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StaticPointers     #-}

module StaticPointers02 where

import GHC.StaticPtr
import Data.Typeable

f2 :: Typeable a => StaticPtr (a -> a)
f2 = static id

f3 :: StaticPtr (Char -> Int)
f3 = static method

f4 :: Typeable a => StaticPtr (T a -> a)
f4 = static t_field

g :: Int -> Int
g = id

f5 :: Typeable a => StaticPtr (a -> a)
f5 = static (id . id)

f6 :: Typeable a => StaticPtr (a -> IO a)
f6 = static return

f7 :: Typeable a => StaticPtr (a -> IO a)
f7 = static (\x -> getLine >> return x)

data T a = T { t_field :: a }
  deriving Typeable

class C a where
  method :: a -> Int

instance C Char where
  method = const 0


{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies #-}
module TcTypeNatSimple where
import GHC.TypeLits as L
import Data.Proxy

--------------------------------------------------------------------------------
-- Test evaluation
e1 :: Proxy (2 + 3) -> Proxy 5
e1 = id

e2 :: Proxy (2 L.* 3) -> Proxy 6
e2 = id

e3 :: Proxy (2 ^ 3) -> Proxy 8
e3 = id

e4 :: Proxy (0 + x) -> Proxy x
e4 = id

e5 :: Proxy (x + 0) -> Proxy x
e5 = id

e6 :: Proxy (x L.* 0) -> Proxy 0
e6 = id

e7 :: Proxy (0 L.* x) -> Proxy 0
e7 = id

e8 :: Proxy (x L.* 1) -> Proxy x
e8 = id

e9 :: Proxy (1 L.* x) -> Proxy x
e9 = id

e10 :: Proxy (x ^ 1) -> Proxy x
e10 = id

e11 :: Proxy (1 ^ x) -> Proxy 1
e11 = id

e12 :: Proxy (x ^ 0) -> Proxy 1
e12 = id

e13 :: Proxy (1 <=? 2) -> Proxy True
e13 = id

e14 :: Proxy (2 <=? 1) -> Proxy False
e14 = id

e15 :: Proxy (x <=? x) -> Proxy True
e15 = id

e16 :: Proxy (0 <=? x) -> Proxy True
e16 = id

e17 :: Proxy (3 - 2) -> Proxy 1
e17 = id

e18 :: Proxy (a - 0) -> Proxy a
e18 = id

e19 :: Proxy (Div 10 3) -> Proxy 3
e19 = id

e20 :: Proxy (Div x 1) -> Proxy x
e20 = id

e21 :: Proxy (Mod 10 3) -> Proxy 1
e21 = id

e22 :: Proxy (Mod x 1) -> Proxy 0
e22 = id

e23 :: Proxy (Log2 10) -> Proxy 3
e23 = id

--------------------------------------------------------------------------------
-- Test interactions with inerts

-- ti1 :: Proxy (x + y) -> Proxy x -> ()
-- ti1 _ _ = ()

ti2 :: Proxy (y + x) -> Proxy x -> ()
ti2 _ _ = ()

ti3 :: Proxy (2 L.* y) -> ()
ti3 _ = ()

ti4 :: Proxy (y L.* 2) -> ()
ti4 _ = ()

ti5 :: Proxy (2 ^ y) -> ()
ti5 _ = ()

ti6 :: Proxy (y ^ 2) -> ()
ti6 _ = ()

ti8 :: Proxy (x - y) -> Proxy x -> ()
ti8 _ _ = ()

ti9 :: Proxy (y - x) -> Proxy x -> ()
ti9 _ _ = ()


{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies #-}
module TcTypeNatSimple where
import GHC.TypeLits
import Data.Proxy

--------------------------------------------------------------------------------
-- Test evaluation

te1 :: Proxy (AppendSymbol "" x) -> Proxy x
te1 = id

te2 :: Proxy (AppendSymbol x "") -> Proxy x
te2 = id

te3 :: Proxy (AppendSymbol "type" "level") -> Proxy "typelevel"
te3 = id

--------------------------------------------------------------------------------
-- Test interactions with inerts

tei1 :: Proxy (AppendSymbol y x) -> Proxy x -> ()
tei1 _ _ = ()

tei2 :: Proxy (AppendSymbol "foo" x) -> ()
tei2 _ = ()

tei3 :: Proxy (AppendSymbol x "foo") -> ()
tei3 _ = ()


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

-- This test checks that deep skolemisation and deep
-- instantiation work right.  A buggy prototype
-- of GHC 7.0, where the type checker generated wrong
-- code, sent applyTypeToArgs into a loop.

module Twins where

import Data.Data

type GenericQ r = forall a. Data a => a -> r
type GenericM m = forall a. Data a => a -> m a

gzip :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe)
gzip f x y
  = f x y
     `orElse`
    if toConstr x == toConstr y
    then gzipWithM (gzip f) x y
    else Nothing

gzipWithM :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m)
gzipWithM _ = error "urk"

orElse :: Maybe a -> Maybe a -> Maybe a
orElse = error "urk"


{-# LANGUAGE TypeInType, TypeOperators, TypeFamilies,
             UndecidableInstances, ConstraintKinds #-}
module TypeInTypeSubstitutions where

import GHC.TypeLits as L
import Data.Type.Bool
import Data.Type.Equality
import Data.List (sort)

-- We define a very simplistic O notation, with sufficient expressiveness
-- to capture the complexity of a few simple sorting algorithms
data AsympPoly = NLogN Nat Nat

-- Synonyms for common terms
type N     = NLogN 1 0
type LogN  = NLogN 0 1
type One   = NLogN 0 0

-- Just to be able to write it nicely
type O (a :: AsympPoly) = a

type family (^.) (n :: AsympPoly) (m :: Nat) :: AsympPoly where
  (NLogN a b) ^. n = (NLogN (a L.* n) (b L.* n))

type family (*.) (n :: AsympPoly) (m :: AsympPoly) :: AsympPoly where
  (NLogN a b) *. (NLogN c d) = NLogN (a+c) (b+d)

type family OCmp (n :: AsympPoly) (m :: AsympPoly) :: Ordering where
  OCmp (NLogN a b) (NLogN c d) = If (CmpNat a c == EQ)
                                    (CmpNat b d)
                                    (CmpNat a c)

type family OGEq (n :: AsympPoly) (m :: AsympPoly) :: Bool where
  OGEq n m = Not (OCmp n m == 'LT)

type (>=.) n m = OGEq n m ~ True

infix 4 >=.
infixl 7 *., ^.

-- Stable sorts must be stable, but unstable can be, but don't need to.
type IsStable s = (s || True) ~ True
-- We encode in the return type of the sorting function its average complexity,
-- memory use and stability.
newtype Sorted (cpu :: AsympPoly) -- The minimum operational complexity
                                       -- this algorithm satisfies.
               (mem :: AsympPoly) -- The minimum space complexity this
                                       -- algorithm satisfies.
               (stable :: Bool)        -- Whether the sort is stable or not.
               a                       -- What was being sorted.
               = Sorted {sortedBy :: [a]}

-- Merge sort is O(N*Log(N)) on average in complexity, so that's the
-- minimum complexity we promise to satisfy. Same goes with memory, which is
-- O(N), and as we all know, mergesort is a stable sorting algoritm.
mergeSort :: (Ord a, n >=. O(N*.LogN), m >=. O(N), IsStable s) =>
             [a] -> Sorted n m s a
mergeSort = Sorted . sort

insertionSort :: (Ord a, n >=. O(N^.2), m >=. O(One), IsStable s) =>
                 [a] -> Sorted n m s a
insertionSort = Sorted . sort

-- Note that we don't actually check the complexity (as evidenced by them all
-- being implemented with sort, a smooth applicative merge sort). With more
-- dependent types however, some of these properties might be verifiable.
quickSort :: (Ord a, n >=. O(N*.LogN), m >=. O(N)) => [a] -> Sorted n m False a
quickSort = Sorted . sort

heapSort :: (Ord a, n >=. O(N*.LogN), m >=. O(One)) => [a] -> Sorted n m False a
heapSort = Sorted . sort

-- Here we say that sorted can use at most operational complexity O(N^2), space
-- complexity of at most (O(N)) and that it should be stable.
mySortA :: Sorted (O(N^.2)) (O(N)) True Integer
mySortA = _a [3,1,2]

mySortB :: Sorted (O(N*.LogN)) (O(N)) False Integer
mySortB = _b [3,1,2]

mySortC :: Sorted (O(N*.LogN)) (O(One)) False Integer
mySortC = _c [3,1,2]

main :: IO ()
main = print (sortedBy mySortA)


{-# LANGUAGE MagicHash #-}
{-# OPTIONS_GHC -funbox-small-strict-fields #-}
module Test where

import GHC.Exts

-- The following should be unboxed automatically:
data A = A Int#
data B = B !A
data C = C !()
data D = D !B
data E = E !D !D

d = D (B (A 0#))
e = E d d

data F = F Int#
newtype G = G F
data H = H !G !G

h = H (G (F 1#)) (G (F 1#))

-- This should not be unboxed:

data I = I !H !H

i = I h h


{-# LANGUAGE
            NoImplicitPrelude
           , ExistentialQuantification
  #-}

module Test where

hGetContents handle_ = handle_{ haType=SemiClosedHandle}

data HandleType = SemiClosedHandle

class Show a where
  show :: a -> a

-- they have to check whether the handle has indeed been closed.
data Handle__
  = forall dev . (Show dev) =>
    Handle__ {
      haDevice      :: !dev,
      haType        :: HandleType           -- type (read/write/append etc.)
}


module ValidHoleFits where

data Moo = Moo Integer


module Foo where

import Prelude hiding (putStr, putStrLn)
import qualified System.IO (putStr, putStrLn)
import Data.Maybe
import qualified ValidHoleFits

ps :: String -> IO ()
ps = putStrLn

a :: Int -> IO Int
a _ = return 1
b :: Int -> IO Int
b _ = return 2
c :: Int -> IO Int
c _ = do { x <- a 0
         ; y <- _ x
         ; return y }

test :: [Maybe a] -> [a]
test = _

test2 :: Integer -> ValidHoleFits.Moo
test2 = _

k :: Maybe Integer
k = _ 2

f :: String
f = show _

h :: String
h = show (_ (_ :: Bool))

-- Built-in Syntax
myCons :: a -> [a] -> [a]
myCons = _

main :: IO ()
main = _ "hello, world"


{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}

module ValidSubsInteractions where

import Data.Kind

data SBool :: Bool -> Type where
  SFalse :: SBool 'False
  STrue  :: SBool 'True

f :: SBool 'True
f = _


{-# LANGUAGE TypeApplications, ScopedTypeVariables, PolyKinds,
             TypeFamilies, RankNTypes,
             FlexibleContexts #-}
-- tests about visible type application

module Vta1 where

import Data.Kind (Type)

quad :: a -> b -> c -> d -> (a, b, c, d)
quad = (,,,)

silly = quad @_ @Bool @Char @_ 5 True 'a' "Hello"

pairup_nosig x y = (x, y)

pairup_sig :: a -> b -> (a,b)
pairup_sig u w = (u, w)

answer_sig = pairup_sig @Bool @Int False 7 --
-- (False, 7) :: (Bool, Int)

answer_read = show (read @Int "3") -- "3" :: String
answer_show = show @Integer (read "5") -- "5" :: String
answer_showread = show @Int (read @Int "7") -- "7" :: String

intcons a = (:) @Int a

intpair x y = pairup_sig @Int x y

answer_pairup = pairup_sig @Int 5 True -- (5, True) :: (Int, Bool)
answer_intpair = intpair 1 "hello" -- (1, "hello") :: (Int, String)
answer_intcons = intcons 7 []      -- [7] :: [Int]

type family F a
type instance F Char = Bool

g :: F a -> a
g _ = undefined

f :: Char
f = g True

answer = g @Char False

mapSame :: forall b. (forall a. a -> a) -> [b] -> [b]
mapSame _ [] = []
mapSame fun (x:xs) = fun @b x : (mapSame @b fun xs)

pair :: forall a. a-> (forall b. b -> (a, b))
pair x y = (x, y)

b = pair @Int 3 @Bool True
c = mapSame id [1,2,3]
d = pair 3 @Bool True

pairnum :: forall a. Num a => forall b. b -> (a, b)
pairnum = pair 3

e = (pair 3 :: forall a. Num a => forall b. b -> (a, b)) @Int @Bool True
h = pairnum @Int @Bool True

data First (a :: Type -> Type) = F
data Proxy (a :: k) = P -- This expands to P (kind variable) (type variable)
data Three (a :: Type -> k -> Type) = T

foo :: Proxy a -> Int
foo _ = 0

first :: First a -> Int
first _ = 0

fTest = first F
fMaybe = first @Maybe F

test = foo P
bar = foo @Bool P -- should work

too :: Three a -> Int
too _ = 3

threeBase = too T
threeOk = too @Either T

blah = Nothing @Int

newtype N = MkN { unMkN :: forall a. Show a => a -> String }

n = MkN show

boo = unMkN n @Bool

boo2 :: forall (a :: Type -> Type) . Proxy a -> Bool
boo2 _ = False

base = boo2 P
bar'= boo2 @Maybe P -- should work


{-# LANGUAGE RankNTypes, TypeApplications #-}

module Vta2 where

checkIf :: Bool -> (forall a. a -> a) -> (Bool, Int)
checkIf _ = if True
            then \f -> (f True, f 5)
            else \f -> (f False, f @Int 3)

checkCase :: Bool -> (forall a. a -> a) -> (Bool, Int)
checkCase _ = case True of
                True -> \f -> (f True, f 5)
                False -> \f -> (f False, f @Int 3)


{-# LANGUAGE TypeFamilies #-}
module AssocTyDef01 where

class OtherCls a where
    type OtherTyp a

class Cls a where
    type Typ a
    type OtherType a = Int
      -- Default for another class AT: want error


{-# LANGUAGE TypeFamilies #-}
module AssocTyDef02 where

class Cls a where
    type Typ a
    type Typ [b] = Int
      -- Default is not parametric in type class params


{-# LANGUAGE TypeFamilies #-}
module AssocTyDef03 where

class Cls a where
    data Typ a
    type Typ a = Int
      -- Default for data family :-(


{-# LANGUAGE TypeFamilies #-}
module AssocTyDef04 where

class Cls a where
    type Typ a
    type Typ a = Maybe
      -- Wrong kind for default


{-# LANGUAGE TypeFamilies #-}
module AssocTyDef05 where

class Cls a where
    type Typ a
    type Typ = Maybe
      -- Too few params for default


{-# LANGUAGE TypeFamilies #-}
module AssocTyDef06 where

class Cls a where
    type Typ a
    type Typ a b = Int
      -- Too many params for default


{-# LANGUAGE TypeFamilies #-}
module AssocTyDef07 where

class Cls a where
    type Typ a = Int
     -- Default without family


module AssocTyDef07 where

class Cls a where
    type Typ a = Int
     -- Default without family OR extension flag


{-# LANGUAGE TypeFamilies #-}
module AssocTyDef01 where

type family OtherTyp a

class Cls a where
    type Typ a
    type OtherType a = Int
      -- Default for top level AT: want error


{-# LANGUAGE PatternSynonyms, TypeOperators, TypeFamilies, MultiParamTypeClasses, GADTs #-}

module ClassOperator where

import Data.Kind

-- | Class with fixity, including associated types
class a ><> b where
  type a <>< b :: Type
  data a ><< b
  (>><), (<<>) :: a -> b -> ()

  -- | Multiple fixities
  (**>), (**<), (>**), (<**) :: a -> a -> ()

infixr 1 ><>
infixl 2 <><
infixl 3 ><<
infixr 4 >><
infixl 5 <<>

infixr 8 **>, >**
infixl 8 **<, <**


{-# LANGUAGE UndecidableInstances, FlexibleInstances #-}

module ContextStack1 where

class Cls a where meth :: a

instance Cls [a] => Cls a

t :: ()
t = meth


{-# LANGUAGE AllowAmbiguousTypes, TypeFamilies #-}

module ContextStack2 where

import Data.Kind (Type)

type family TF a :: Type
type instance TF (a,b) = (TF a, TF b)

-- Succeeds with new approach to fuvs
-- Aug 2016
t :: (a ~ TF (a,Int)) => Int
t = undefined

{- a ~ TF (a,Int)
     ~ (TF a, TF Int)
     ~ (TF (TF (a,Int)), TF Int)
     ~ (TF (TF a, TF Int), TF Int)
     ~ ((TF (TF a), TF (TF Int)), TF Int)

      fsk ~ a
      TF (a, Int) ~ fsk
-->
      fsk ~ a
*     fsk ~ (TF a, TF Int)
        (flatten lhs)
         a ~ (TF a, TF Int)
        (flatten rhs)
        a ~ (fsk1, TF Int)
(wk)  TF a ~ fsk1

--> (rewrite inert)

   fsk ~ (fsk1, TF Int)
   a ~ (fsk1, TF Int)
(wk) TF a ~ fsk1

-->
      fsk ~ (fsk1, TF Int)
      a   ~ (fsk1, TF Int)

*     TF (fsk1, fsk2) ~ fsk1
(wk)  TF Tnt ~ fsk2

-->
      fsk ~ (fsk1, TF Int)
      a   ~ (fsk1, TF Int)

*     fsk1 ~ (TF fsk1, TF fsk2)
        (flatten rhs)
        fsk1 ~ (fsk3, TF fsk2)

(wk)  TF Int ~ fsk2
      TF fsk1 ~ fsk3
-}


{-# LANGUAGE DataKinds, UndecidableInstances #-}
module T1 where
import GHC.TypeLits

data MyType = MyType

instance
  TypeError (Text "Values of type 'MyType' cannot be compared for equality.")
    => Eq MyType where (==) = undefined

err x = x == MyType


{-# LANGUAGE DataKinds, UndecidableInstances #-}
{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts #-}
module T2 where

import GHC.TypeLits

type family IntRep a where
  IntRep Int      = Integer
  IntRep Integer  = Integer
  IntRep Bool     = Integer
  IntRep a        = TypeError (Text "The type '" :<>: ShowType a :<>:
                               Text "' cannot be represented as an integer.")

convert :: Num (IntRep a) => a -> IntRep a
convert _ = 5

err = convert id


{-# LANGUAGE DataKinds #-}
module T3 where

import GHC.TypeLits

f :: TypeError (Text "This is a type error")
f = undefined


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

-- The "bad case" in #11391
module CustomTypeErrors04 where

import Data.Kind
import GHC.TypeLits (TypeError, ErrorMessage(..))

type family Resolve (t :: Type -> Type) :: Type -> Type where
  Resolve _ = TypeError (Text "ERROR")

testNOTOK1 :: Resolve [] Int
testNOTOK1 = ()


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

-- The "tricky case" in #11391
module CustomTypeErrors05 where

import Data.Kind
import GHC.TypeLits (TypeError, ErrorMessage(..))

type family Resolve (t :: Type -> Type) :: Type -> Type where
  Resolve _ = TypeError (Text "ERROR")

testNOTOK2 :: Resolve [] Int
testNOTOK2 = 1


type Foo = Int
type Bar = Bool

main = print $ (1 :: Foo) == (False :: Bar)


-- In case of types with nested type synonyms, all synonyms should be expanded

{-# LANGUAGE RankNTypes #-}

import Control.Monad.ST

type Foo = Int
type Bar = Bool

type MyFooST s = ST s Foo
type MyBarST s = ST s Bar

fooGen :: forall s . MyFooST s
fooGen = undefined

barGen :: forall s . MyBarST s
barGen = undefined

main = print (runST fooGen == runST barGen)


-- We test two things here:
--
-- 1. We expand only as much as necessary. In this case, we shouldn't expand T.
-- 2. When we find a difference(T3 and T5 in this case), we do minimal expansion
--    e.g. we don't expand both of them to T1, instead we expand T5 to T3.

module Main where

type T5 = T4
type T4 = T3
type T3 = T2
type T2 = T1
type T1 = Int

type T a = Int -> Bool -> a -> String

f :: T (T3, T5, Int) -> Int
f = undefined

a :: Int
a = f (undefined :: T (T5, T3, Bool))

main = print a


-- Synonyms shouldn't be expanded since type error is visible without
-- expansions. Error message should not have `Type synonyms expanded: ...` part.

module Main where

type T a = [a]

f :: T Int -> String
f = undefined

main = putStrLn $ f (undefined :: T Bool)


{-# LANGUAGE FlexibleContexts #-}

module FailDueToGivenOverlapping where

class C a where

class D a where
 dop :: a -> ()

instance C a => D [a]

-- should succeed since we can't learn anything more for 'a'
foo :: (C a, D [Int]) => a -> ()
foo x = dop [x]

class E a where
 eop :: a -> ()

instance E [a] where
 eop = undefined

-- should fail since we can never be sure that we learnt
-- everything about the free unification variable.
bar :: E [Int] => () -> ()
bar _ = eop [undefined]


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

-- Here's a nice example of a fundep loop, correctly
-- rejected by the undecidable-instance check.
-- See comments below.

module FDLoop where

class C a b | a -> b where f :: a -> b
newtype T a = T a

instance (C a b, Eq b) => Eq (T a) where (==) = undefined

g x = (undefined :: d -> d -> d -> ()) (T x) (f x) (undefined :: Eq e => e)

{-    Analysis

   f :: C a b => a -> b
   x :: a
   b ~ T a
   need: C a b
   b ~ e
   need: Eq e

Hence need (C a (T a), Eq (T a))
Apply instance for Eq
     = (C a (T a), C a g, Eq g)
Apply functional dependency: g ~ T a
     = (C a (T a), C a (T a), Eq (T a))
And now we are back where we started
-}


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

module FDsFromGivens where

class C a b | a -> b where
   cop :: a -> b -> ()

{- Failing, as it righteously should! It's inaccessible code -}
-- But (c.f. test T5236) we no longer reject this in the
-- typechecker (see Trac #12466)
-- Instead we get a redundant pattern-match warning,
-- in the post-typechecking pattern-match checks
g1 :: (C Char [a], C Char Bool) => a -> ()
g1 x = ()


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

module FDsFromGivens2 where

class C a b | a -> b where
   cop :: a -> b -> ()

data KCC where
  KCC :: C Char Char => () -> KCC

f :: C Char [a] => a -> a
f = undefined

bar :: KCC -> a -> a
bar (KCC _) = f


{-# LANGUAGE RankNTypes, GADTs, TypeFamilies #-}
module Test where

data T a where
  MkT :: a -> T a
  MkT3 :: forall a. (a ~ Bool) => T a

-- Mismatches in givens
bloh :: T Int -> ()
bloh x = case x of
           MkT3 -> ()

type family F a b
type family G a b
type instance F a Bool = a
type instance G a Char = a

goo1 :: forall a b. (F a b ~ [a]) => b -> a  -> a
goo1 = undefined

goo2 :: forall a. G a Char ~ [Int] => a -> a
goo2 = undefined

-- Just an occurs check
test1 = goo1 False undefined

-- A frozen occurs check, now transformed to decomposition error
test2 = goo2 (goo1 False undefined)
test3 = goo1 False (goo2 undefined)

-- A frozen occurs check, now transformed to both a decomposition and occurs check
data M a where
  M :: M a
data T2 a b where
  T2 :: T2 a b

goo3 :: forall a b. F a b ~ T2 (M a) a => b -> a -> a
goo3 = undefined

goo4 :: forall a c. G a Char ~ T2 (T2 c c) c => a -> a
goo4 = undefined

test4 = goo4 (goo3 False undefined)
test5 = goo3 False (goo4 undefined)


{-# LANGUAGE ImplicitParams #-}

module IPFail where

f0 :: (?x :: Int) => () -> Bool
f0 () = let ?x = 5 in ?x


-- inspired by comment:25 on #12708

{-# LANGUAGE PolyKinds #-}

module LevPolyBounded where

import GHC.Exts

class XBounded (a :: TYPE r) where
  minBound :: a
  maxBound :: a


{-# LANGUAGE TypeFamilies, MultiParamTypeClasses
  , FlexibleContexts, FlexibleInstances, UndecidableInstances
  , TypeSynonymInstances, GeneralizedNewtypeDeriving
  #-}

module LongWayOverlapping where

class M a where

class M a => XMLG a

instance M [a]

instance XMLG [m] where     -- Generates an implication wanted:  forall m. M [m]

class M a => EmbAsChild a b where
  emb :: b -> [a]

instance EmbAsChild [Char] Bool where
  emb _ = emb 'c'

  -- This one generates an unsolvable EmbAsChild [Char] Char

-- Original problem is:
-- [w] EmbAsChild [Char] Char
-- [w] forall m. M [m]
-- Now, by converting the wanted to given and pushing it inside the implication
-- we have the following:
-- [g] EmbAsChild [Char] Char
-- [g] M [Char]   <~~ The superclass of the first given!
-- [w] M [m]
-- And now OOPS we can't solve M [m] because we are supposed to delay our choice
-- as much as possible!

-- DV:
-- One possible solution is to STOP PUSHING wanteds as givens inside an implication
-- in a checking context. I think it's the best thing to do and I've implemented it.

-- In inference mode that's ok and the error message is very comprehensible, see
-- test case PushedInFlatsOverlap.hs


-- Checks that the correct type is used checking the using clause of the transform

{-# LANGUAGE MonadComprehensions, TransformListComp #-}

module ShouldFail where

import Data.List(inits)

z :: [Int]
z = [x | x <- [3, 2, 1], then inits]


-- Checks that the ordering constraint on the groupWith function is respected

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}

module ShouldFail where

import GHC.Exts (groupWith)

data Unorderable = Gnorf | Pinky | Brain

foo = [ ()
      | x <- [Gnorf, Brain]
      , then group by x using groupWith
      ]


-- Checks that the correct type is used checking the using clause of the group

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}
module ShouldFail where
import GHC.Exts( the )
import GHC.List

data Unorderable = Gnorf | Pinky | Brain

foo = [ GHC.List.length x
      | x <- [Gnorf, Brain]
      , then group using take 5
      ]


-- Checks that the types of the old binder and the binder
-- implicitly introduced by grouping are linked

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}

module ShouldFail where

foo = [ x + 1
      | x <- ["Hello", "World"]
      , then group using take 5
      ]


-- Checks that using the "by" clause in a transform requires a function parameter

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}

module ShouldFail where

import Data.List(take)

z = [x | x <- [1..10], then take 5 by x ]


-- Checks that the correct type is used checking the using clause of
-- the group when a by clause is present

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}
module ShouldFail where
import GHC.List

foo = [ GHC.List.length x
      | x <- [1..10]
      , then group by x using take 2
      ]


-- Checks that using the "by" clause in a transform requires a function parameter

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}

module ShouldFail where

import Data.List(take)

z = [x | x <- [1..10], then group by x using take ]


{-# OPTIONS_GHC -Werror -fwarn-missing-export-lists #-}
module ShouldFail where

foo :: String
foo = "foo"


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

-- This is a superclass loop test
-- It should fail with a type error, but
-- it's all too easy to succeed with a bogus recursive dictionary

module SCLoop where

class SC a where
  f :: a -> ()

class SC a => A a b where
  op :: a -> b -> ()
  op x _ = f x

instance A a b => A a [b]
-- dfun1 :: \d::(A a b) -> DA (sc d)

instance SC a  => A a (Maybe b)
-- dfun2 :: \d::SC a -> DA d

foo = op () ([Just True])

{- Here is the explanation:
~~~~~~~~~~~~~~~~~~~~~~~~~~~

[Wanted]  d1 : (A () [Maybe Bool])
~~~>                              d1 := dfun1 d2
[Wanted]  d2 : (A () (Maybe Bool))
~~~>                              d2 := dfun2 d3
[Wanted]  d3 : SC ()
[Derived] d4 : SC ()               d4 := sc d1
~~~>
      d3 := sc d1
      isGoodRecEv will check:
                  d3 == sc d1
                     == sc (dfun1 d2)
                     == sc (dfun1 (dfun2 d3) ==> PASSES!   (gravity = 1)
        This is BAD BAD BAD, because we get a loop

      If we had inlined the definitions:
                  d3 == sc d1
                     == sc (DA (sc d2))
                     == sc (DA (sc (DA d3))) ==> DOES NOT! (gravity = 0)

We should get "No instance for SC ()"
-}


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

module SilentParametersOverlapping where

class C a where
  c :: a -> ()

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

instance C [a] where
  c x = ()

instance {- silent: C [(a,b)] => -} B [(a,b)] where
  b x = c [(undefined,undefined)]
  -- We get wanted: C [(gamma, delta)],
  -- and gamma,delta are unconstrained
  -- We can apply the C [a] instance without difficulty, but
  --  that fails due to silent dfun parameters


{-# LANGUAGE MagicHash #-}

module StrictBinds where

import GHC.Exts

foo = let x = 3# +# y
          y = x in
      True


{-# LANGUAGE RankNTypes #-}
module T10194 where

type X = forall a . a

comp :: (X -> c) -> (a -> X) -> (a -> c)
comp = (.)


module T10285 where

import T10285a
import Data.Type.Coercion
import Data.Coerce

oops :: Coercion (N a) (N b) -> a -> b
oops Coercion = coerce

unsafeCoerce :: a -> b
unsafeCoerce = oops coercion


{-# LANGUAGE RoleAnnotations #-}

module T10285a (N, coercion) where

import Data.Type.Coercion

newtype N a = MkN Int
type role N representational

coercion :: Coercion (N a) (N b)
coercion = Coercion


module T10351 where

class C a where
  op :: a -> ()

f x = op [x]


module T10495 where

import Data.Coerce

foo = coerce


{-# LANGUAGE TypeFamilies #-}

module T10534 where

import T10534a

newtype instance DF a = MkDF ()

unsafeCoerce :: a -> b
unsafeCoerce = silly


{-# LANGUAGE TypeFamilies, FlexibleContexts #-}

module T10534a where

import Data.Coerce

data family DF a

silly :: Coercible (DF a) (DF b) => a -> b
silly = coerce


{-# LANGUAGE RankNTypes #-}

module T10619 where

-- tests that type checking doesn't care about order. all of these
-- should fail and be reported.

foo _ = if True
        then ((\x -> x) :: (forall a. a -> a) -> forall b. b -> b)
        else \y -> y

bar _ = if True
        then \y -> y
        else ((\x -> x) :: (forall a. a -> a) -> forall b. b -> b)

baz True  = (\x -> x) :: (forall a. a -> a) -> forall b. b -> b
baz False = \y -> y

quux False = \y -> y
quux True  = (\x -> x) :: (forall a. a -> a) -> forall b. b -> b


{-# LANGUAGE RoleAnnotations #-}

module T10698 where
import Data.Coerce

data Map k a  = Map k a
type role Map nominal representational

map1 :: (k1->k2) -> Map k1 a -> Map k2 a
map1 f (Map a b) = Map (f a) b
{-# NOINLINE  [1] map1 #-}
{-# RULES
"map1/coerce" map1 coerce = coerce
 #-}

map2 :: (a -> b) -> Map k a -> Map k b
map2 f (Map a b) = Map a (f b)
{-# NOINLINE [1] map2 #-}

{-# RULES
"map2/coerce" map2 coerce = coerce
 #-}


{-# LANGUAGE FlexibleContexts #-}
module T10715 where

import Data.Coerce (coerce, Coercible)
import Data.Ord ( Down )  -- convenient newtype

data X a

-- See Trac #10715 for a long discussion about whether
-- this should be accepted or not.
--
-- But in Trac #12466 we decided to accept contradictory
-- type signatures, so definition is now accepeted even
-- though you can never call it.  Instead we get a
-- redundant pattern-match warning, in the
-- post-typechecking pattern-match checks
doCoerce :: Coercible a (X a) => a -> X a
doCoerce = coerce


module T10715b where

-- test error message: should complain about an occurs check

import Data.Coerce

foo = coerce `asTypeOf` head


{-# LANGUAGE TypeFamilyDependencies #-}
module T10836 where

type family Foo a = r | r -> a where
    Foo Int  = Int
    Foo Bool = Int

type family Bar a = r | r -> a where
    Bar Int  = Int
    Bar Bool = Int


{-# LANGUAGE MonomorphismRestriction, NoExtendedDefaultRules #-}
module T10971b where
import Data.Traversable (fmapDefault)
f = \x -> length x
g = \f x -> fmapDefault f x
h = \f x -> (fmapDefault f x, length x)


{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-}
module T10971c where

import Data.Traversable (fmapDefault)

f = \x -> length x
g = \f x -> fmapDefault f x
h = \f x -> (fmapDefault f x, length x)


import T10971c

main = do
  print $ f (Just 1)
  print $ g (+1) (Just 5)
  print $ h (const 5) Nothing


module T11112 where

sort :: Ord s -> [s] -> [s]
sort xs = xs


{-# OPTIONS_GHC -fdefer-typed-holes #-}

module T11274 where

data Asd = Asd

someHole = _asd

missingInstance :: Asd -> Asd -> Bool
missingInstance x y = x == y


{-# LANGUAGE TypeApplications #-}

module T11313 where

x = fmap @ (*)

-- test error message output, which was quite silly before


-- Should AllowAmbiguousTypes really be needed here?
{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, AllowAmbiguousTypes #-}
module T11347 where

newtype Id1 a = MkId1 a
newtype Id2 a = MkId2 (Id1 a) deriving (UnsafeCast b)

type family Discern a b
type instance Discern (Id1 a) b = a
type instance Discern (Id2 a) b = b

class UnsafeCast to from where
  unsafe :: from -> Discern from to

instance UnsafeCast b (Id1 a) where
  unsafe (MkId1 x) = x

unsafeCoerce :: a -> b
unsafeCoerce x = unsafe (MkId2 (MkId1 x))


{-# LANGUAGE TypeApplications, RankNTypes #-}

module T11355 where

foo = const @_ @((forall a. a) -> forall a. a) () (id @(forall a. a))


module T11356 where

class T p p => C p

type T x = C x


{-# LANGUAGE MagicHash, PolyKinds #-}

module Foo where

instance Eq (Either a)


module T11541 where

g :: Ord k => k -> v -> ()
g k v = ()

f x y =
   let m = min x y
   in  g m foo


module T11563 where

data T a = MkT
class C t
instance C s => C T


{-# LANGUAGE TypeFamilies #-}

module T11623 where

type family T where { Maybe T = Int }


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
module BadError where

import GHC.TypeLits
import Data.Proxy

f :: Proxy (a :: Symbol) -> Int
f _ = f (Proxy :: Proxy (Int -> Bool))


{-# LANGUAGE MonoLocalBinds #-}
module T11698 where

f x = (k 'v', k True)
  where
    h = const True x
    k z = const h (k z) -- k type should not be generalized because h is closed.


{-# LANGUAGE PolyKinds #-}

module T11724 where

import GHC.Exts

data Foo (r :: RuntimeRep) (a :: TYPE r) = Foo a


{-# LANGUAGE TypeApplications, ScopedTypeVariables #-}
module T11947 where

theFloatDigits :: forall a. RealFloat a => Int
-- The type is ambiguous, despite potential defaulting
theFloatDigits = floatDigits (undefined @_ @a)


{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, NoMonoLocalBinds #-}
-- The NoMonoLocalBinds is crucial to making inference fail
-- See Trac #11948 comment:2
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}

module T11948 where

type family F b

newtype Foo r = Foo r

type instance F (Foo r) = Foo (F r)

class Bar a b where
  bar :: a -> b

instance (Bar a b) => Bar (Foo a) (Foo b)

bug :: forall zq. (Bar (Foo (F zq)) (Foo zq))
               => Foo (F zq) -> Foo zq
bug sk = let x = bar sk :: Foo zq
         in x


{-# LANGUAGE ExtendedDefaultRules #-}

module T11974b where

default (Either, Monad, [], Maybe, Either Bool, Integer, Double, Blah)

data Blah


{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies #-}
{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, FlexibleContexts #-}

module T11990a where

import GHC.TypeLits
import Data.Proxy

type family PartialTF t :: Symbol where
  PartialTF Int  = "Int"
  PartialTF Bool = "Bool"
  PartialTF a    = TypeError (Text "Unexpected type @ PartialTF: "
                                                         :<>: ShowType a)

testPartialTF :: forall a.(KnownSymbol (PartialTF a)) => a -> String
testPartialTF t = symbolVal (Proxy :: Proxy (PartialTF a))

t1 = testPartialTF 'a'

{- Above code rightly fails with the following error:
    â€¢ Unexpected type: Char
    â€¢ In the expression: testPartialTF 'a'
      In an equation for â€˜t1â€™: t1 = testPartialTF 'a'
-}


{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies #-}
{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, FlexibleContexts #-}

module T11990b where

import GHC.TypeLits
import Data.Proxy

type family PartialTF t :: Symbol where
  PartialTF Int  = "Int"
  PartialTF Bool = "Bool"
  PartialTF a    = TypeError (Text "Unexpected type @ PartialTF: "
                                                         :<>: ShowType a)

type family NestedPartialTF (tsym :: Symbol) :: Symbol where
  NestedPartialTF "Int" = "int"
  NestedPartialTF "Bool" = "bool"
  NestedPartialTF a =
    TypeError (Text "Unexpected type @ NestedPartialTF: " :<>: ShowType a)

testPartialTF :: forall a.(KnownSymbol (PartialTF a)) => a -> String
testPartialTF t = symbolVal (Proxy :: Proxy (PartialTF a))

testNesPartialTF ::
  forall a.(KnownSymbol (NestedPartialTF (PartialTF a))) => a -> String
testNesPartialTF t = symbolVal (Proxy :: Proxy (NestedPartialTF (PartialTF a)))

t2 = testNesPartialTF 'a'


module T12035 where
import T12035a
type T = Bool
y = f True

-- This should error that 'type T = Int' doesn't match 'data T',
-- NOT that f expects argument of type T but got Bool.
--
-- NB: This test will start passing if we allow abstract data
-- types to be implemented using type synonyms.


module T12035a where
import {-# SOURCE #-} T12035
f :: T -> T
f x = x


module T12042 where
import qualified T12042a as B
type S = B.R
type R = B.U


module T12042a (module T12042a, module T12042) where
import {-# SOURCE #-} T12042
type U = S


{-# LANGUAGE TypeApplications #-}

module T12045b where

import Data.Kind

x :: Int @Type
x = 5


{-# LANGUAGE PolyKinds, TypeApplications, KindSignatures, DataKinds, GADTs
             , TypeFamilies, RankNTypes #-}

module T12045c where
import Data.Kind

type family F a where
  F @Type a = Bool
  F @(Type -> Type) b = Char


module T12063 where
import T12063a
x :: S
x = undefined


module T12063a where
import {-# SOURCE #-} T12063
type S = T


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnicodeSyntax #-}
module T12803a where

type Constrd a = Num a â‡’ a

data ADT a = ADT (Constrd a) ExistentiallyLost

data ExistentiallyLost = âˆ€ u. TC u â‡’ ExistentiallyLost u

class u ~ (ATF1 u, ATF2 u) â‡’ TC u where
    type ATF1    u âˆ· *
    type ATF2    u âˆ· *
    uie_handlers   âˆ· ADT Int

-- Loop:
--  - ADT depends on ExistentiallyLost (also the Constrd appendage)
--  - ExistentiallyLost depends on TC
--  - TC depends on ADT


{-# LANGUAGE GADTs #-}

module T12083b where

class Class a where
    test :: a -> (Eq a => r) -> r

data P a b where
    Con :: (Class a, a ~ b) => P a b


{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module T12102 where

import Data.Kind
import GHC.TypeLits

type family IsTypeLit a where
  IsTypeLit Nat    = 'True
  IsTypeLit Symbol = 'True
  IsTypeLit a      = 'False

data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type where
  MkNat    :: T 42
  MkSymbol :: T "Don't panic!"


module T12124 where

data Whoops = Whoops Int Int

foo :: Maybe Int
foo = return (case Whoops 1 2 of
                 Whoops a -> a
                 _ -> 0)


{-# LANGUAGE DefaultSignatures #-}
-- {-# LANGUAGE AllowAmbiguousTypes #-} -- Not required with GHC 8.0.1.

module T12151 where

class Put a where
    put :: a

    default put :: t  -- This should be `a` instead of `t`
    put = undefined


{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fdefer-out-of-scope-variables #-}

module T12170a where

-- import Control.Monad  -- comment this out to cause error
import Data.IORef

class MonadRef m where
    type Ref m :: * -> *
    newRef :: a -> m (Ref m a)
    readRef :: Ref m a -> m a

instance MonadRef IO where
    type Ref IO = IORef
    newRef = newIORef
    readRef = readIORef

foo :: IO ()
foo = newRef (pure ()) >>= join . readRef


module Foo where

bar = \x -> \x -> _

baz = \x -> \y -> \z -> \x -> \z -> _


{-# LANGUAGE MagicHash, ScopedTypeVariables, UnboxedTuples #-}

module T12373 where

import GHC.MVar
import GHC.Prim
import GHC.Types

main :: IO ()
main = IO (\rw -> newMVar# rw) >> return ()


{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fdefer-typed-holes #-}

module T12406 where

-- import Control.Monad  -- comment this out to cause error
import Data.IORef

class MonadRef m where
    type Ref m :: * -> *
    newRef :: a -> m (Ref m a)
    readRef :: Ref m a -> m a

instance MonadRef IO where
    type Ref IO = IORef
    newRef = newIORef
    readRef = readIORef

foo :: IO ()
foo = newRef (pure ()) >>= join . readRef


{-# LANGUAGE TypeFamilyDependencies #-}
module T12430 where

type C a = Int
type family F x = y | y -> x where
  F x = C x


{-# LANGUAGE TypeApplications #-}

module T12529 where

f = p @ Int


{-# LANGUAGE RankNTypes #-}
module T12563 where

foo :: ((forall a. f a) -> f r) -> f r
foo g = undefined

x = \g -> foo g


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fdefer-typed-holes #-}
module T12589 where

import Data.Proxy

hcpure :: proxy c -> (forall a. c a => f a) -> h f xs
hcpure _ _ = undefined

a = minBound
  & hcpure (Proxy @Bounded)


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module T12648 where

import Data.Kind (Type, Constraint)
import Unsafe.Coerce (unsafeCoerce)

type family Skolem (p :: k -> Constraint) :: k
type family Forall (p :: k -> Constraint) :: Constraint
type instance Forall p = Forall_ p
class p (Skolem p) => Forall_ (p :: k -> Constraint)
instance p (Skolem p) => Forall_ (p :: k -> Constraint)

inst :: forall p a. Forall p :- p a
inst = unsafeCoerce (Sub Dict :: Forall p :- p (Skolem p))

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

newtype a :- b = Sub (a => Dict b)

infixl 1 \\ -- required comment

(\\) :: a => (b => r) -> (a :- b) -> r
r \\ Sub Dict = r

class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m | m -> b

instance MonadBase IO IO -- where liftBase = id

class MonadBase b m => MonadBaseControl b m | m -> b where
  type StM m a :: Type
  liftBaseWith :: (RunInBase m b -> b a) -> m a

type RunInBase m b = forall a. m a -> b (StM m a)

instance MonadBaseControl IO IO where
    type StM IO a = a
    liftBaseWith f = f id
    {-# INLINABLE liftBaseWith #-}

class    (StM m a ~ a) => IdenticalBase m a
instance (StM m a ~ a) => IdenticalBase m a

newtype UnliftBase b m = UnliftBase { unliftBase :: forall a. m a -> b a }

mkUnliftBase :: forall m a b. (Forall (IdenticalBase m), Monad b)
             => (forall c. m c -> b (StM m c)) -> m a -> b a
mkUnliftBase r act = r act \\ (inst :: Forall (IdenticalBase m) :- IdenticalBase m a)

class    (MonadBaseControl b m, Forall (IdenticalBase m)) => MonadBaseUnlift b m | m -> b
instance (MonadBaseControl b m, Forall (IdenticalBase m)) => MonadBaseUnlift b m

askUnliftBase :: forall b m. (MonadBaseUnlift b m) => m (UnliftBase b m)
askUnliftBase = liftBaseWith unlifter
  where
    unlifter :: (forall c. m c -> b (StM m c)) -> b (UnliftBase b m)
    unlifter r = return $ UnliftBase (mkUnliftBase r)

f :: (MonadBaseUnlift m IO) => m a
f = do

 _ <- askUnliftBase

 return ()


{-# Language PolyKinds, ViewPatterns, RebindableSyntax,
             MagicHash, NoImplicitPrelude #-}

module T12709 where

import GHC.Types
import Prelude hiding (Num (..))
import qualified Prelude as P
import GHC.Prim

data BoxUnbox = BUB Int Int#

class Num (a :: TYPE rep) where
  (+) :: a -> a -> a

  fromInteger :: Integer -> a

instance Num Int where
  (+) = (P.+)
  fromInteger = P.fromInteger

instance Num Int# where
  (+) = (+#)
  fromInteger (fromInteger -> I# n) = n

a :: BoxUnbox
a = let u :: Num (a :: TYPE rep) => a
        u = 1 + 2 + 3 + 4
     in
        BUB u u


{-# LANGUAGE GADTs, MagicHash #-}

module T12729 where

import GHC.Exts

newtype A where
   MkA :: Int# -> A

newtype B = MkB Int#


{-# LANGUAGE RankNTypes, TypeOperators, ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds, GADTs #-}

module T12785b where

import Data.Kind

data Peano = Z | S Peano

data HTree n a where
  Point :: a -> HTree Z a
  Leaf :: HTree (S n) a
  Branch :: a -> HTree n (HTree (S n) a) -> HTree (S n) a

data STree n :: forall a . (a -> Type) -> HTree n a -> Type where
  SPoint :: f a -> STree Z f (Point a)
  SLeaf :: STree (S n) f Leaf
  SBranch :: f a -> STree n (STree (S n) f) stru -> STree (S n) f (a `Branch` stru)
  SBranchX :: (Payload (S n) (Payload n stru) ~ a)
          => f a -> STree n (STree (S n) f) stru -> STree (S n) f (a `Branch` stru)

data Hidden :: Peano -> (a -> Type) -> Type where
  Hide :: STree n f s -> Hidden n f

nest :: HTree m (Hidden (S m) f) -> Hidden m (STree ('S m) f)
nest (Point (Hide st)) = Hide (SPoint st)
nest Leaf = Hide SLeaf
nest (Hide a `Branch` (nest . hmap nest -> Hide tr)) = Hide $ a `SBranchX` tr

hmap :: (x -> y) -> HTree n x -> HTree n y
hmap f (Point a) = Point (f a)
hmap f Leaf = Leaf
hmap f (a `Branch` tr) = f a `Branch` hmap (hmap f) tr

type family Payload (n :: Peano) (s :: HTree n x) where
  Payload Z (Point a) = a
  Payload (S n) (a `Branch` stru) = a


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

module T10778 where

type family F a :: *
class C a b | a -> b

instance C p (F q) => C p [q]
-- This instance should fail the (liberal) coverage condition


{-# LANGUAGE FlexibleInstances #-}

module T12837 where

import GHC.TypeLits
import Data.Typeable

data K = K

instance Typeable K
instance KnownNat n
instance KnownSymbol n


x :: String -> String
x s = print (reverse s + 1)

myshow :: (String -> String) -> String
myshow x = show x


{-# LANGUAGE DefaultSignatures #-}
module T12918a where

import Control.Monad.Trans.Class

class Monad m => MonadSupply m where
  fresh :: m Integer
  default fresh :: MonadTrans t => t m Integer
  fresh = lift fresh


{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE RankNTypes #-}
module T12918b where

class Foo1 a where
  -- These ones should be rejected
  bar1         :: a -> b
  default bar1 :: b -> a
  bar1 = undefined

  bar2         :: a -> b
  default bar2 :: x
  bar2 = undefined

  bar3         :: a -> b
  default bar3 :: a -> Int
  bar3 = undefined

  bar4         :: a -> Int
  default bar4 :: a -> b
  bar4 = undefined

  -- These ones are OK
  baz1         :: forall b c. a -> b -> c
  default baz1 :: forall b c. a -> b -> c
  baz1 = undefined

  baz2         :: forall b c. a -> b -> c
  default baz2 :: forall c b. a -> b -> c
  baz2 = undefined

  baz3         :: a -> b -> c
  default baz3 :: a -> x -> y
  baz3 = undefined


{-# LANGUAGE OverloadedStrings #-}
module T12921 (stat) where

{-# ANN module "HLint: ignore Reduce duplication" #-}

stat :: Int -> Int
stat = choice []

-- 'choice' is deliberately out of scope in this test