module Classes where

class Foo a where
    bar :: a -> Int
    baz :: Int -> (a, a)

instance Foo Int where
    bar = id
    baz x = (x, x)

instance Foo [a] where
    bar = length
    baz _ = ([], [])

class Foo a => Foo' a where
    quux :: (a, a) -> a
    quux (x, y) = norf [x, y]

    norf :: [a] -> a
    norf = quux . baz . sum . map bar

instance Foo' Int where
    norf = sum

instance Foo' [a] where
    quux = uncurry (++)

class Plugh p where
    plugh :: p a a -> p b b -> p (a -> b) (b -> a)

instance Plugh Either where
    plugh (Left a) (Left {}) = Right $ const a
    plugh (Right a) (Right {}) = Right $ const a
    plugh _ (Left b) = Left $ const b
    plugh _ (Right b) = Left $ const b


module Identifiers where

foo, bar, baz :: Int -> Int -> Int
foo x y = x + x * bar y x * y + y
bar x y = y + x - baz x y - x + y
baz x y = x * y * y * y * x

quux :: Int -> Int
quux x = foo (bar x x) (bar x x)

norf :: Int -> Int -> Int -> Int
norf x y z
    | x < 0 = quux x
    | y < 0 = quux y
    | z < 0 = quux z
    | otherwise = norf (-x) (-y) (-z)

main :: IO ()
main = do
    putStrLn . show $ foo x y
    putStrLn . show $ quux z
    putStrLn . show $ Identifiers.norf x y z
  where
    x = 10
    y = 20
    z = 30


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Polymorphism where

foo :: a -> a -> a
foo = undefined

foo' :: forall a. a -> a -> a
foo' = undefined

bar :: a -> b -> (a, b)
bar = undefined

bar' :: forall a b. a -> b -> (a, b)
bar' = undefined

baz :: a -> (a -> [a -> a] -> b) -> b
baz = undefined

baz' :: forall a b. a -> (a -> [a -> a] -> b) -> b
baz' = undefined

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

quux' :: forall a. a -> (forall a. a -> a) -> a
quux' x f = f x

num :: Num a => a -> a -> a
num = undefined

num' :: forall a. Num a => a -> a -> a
num' = undefined

eq :: (Eq a, Eq b) => [a] -> [b] -> (a, b)
eq = undefined

eq' :: forall a b. (Eq a, Eq b) => [a] -> [b] -> (a, b)
eq' = undefined

mon :: Monad m => (a -> m a) -> m a
mon = undefined

mon' :: forall m a. Monad m => (a -> m a) -> m a
mon' = undefined

norf :: a -> (forall a. Ord a => a -> a) -> a
norf x f = x

norf' :: forall a. a -> (forall a. Ord a => a -> a) -> a
norf' x f = x

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

thud :: forall a b. (a -> b) -> a -> (a, b)
thud f x =
    (x :: a, y) :: (a, b)
  where
    y = (f :: a -> b) x :: b


{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

module Records where

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

point :: Int -> Int -> Point
point x y = Point { x = x, y = y }

lengthSqr :: Point -> Int
lengthSqr (Point { x = x, y = y }) = x * x + y * y

lengthSqr' :: Point -> Int
lengthSqr' (Point { x, y }) = y * y + x * x

translateX, translateY :: Point -> Int -> Point
translateX p d = p { x = x p + d }
translateY p d = p { y = y p + d }

translate :: Int -> Int -> Point -> Point
translate x y p =
    aux p
  where
    (dx, dy) = (x, y)
    aux Point{..} = p { x = x + dx, y = y + dy }


{-# LANGUAGE TypeFamilies #-}

module Types where

data Quux = Bar | Baz

newtype Foo = Foo ()

type FooQuux = (Foo, Quux)
type QuuxFoo = (Quux, Foo)

data family Norf a b

data instance Norf Foo Quux = NFQ Foo Quux
data instance Norf Quux Foo = NQF Quux Foo

type family Norf' a b

type instance Norf' Foo Quux = (Foo, Quux)
type instance Norf' Quux Foo = (Quux, Foo)

norf1 :: Norf Foo Quux -> Int
norf1 (NFQ (Foo ()) Bar) = 0
norf1 (NFQ (Foo ()) Baz) = 1

norf2 :: Norf Quux Foo -> Int
norf2 (NQF Bar (Foo ())) = 0
norf2 (NQF Baz (Foo ())) = 1

norf1' :: Norf' Foo Quux -> Int
norf1' (Foo (), Bar) = 0
norf1' (Foo (), Baz) = 1

norf2' :: Norf' Quux Foo -> Int
norf2' (Bar, Foo ()) = 0
norf2' (Baz, Foo ()) = 1


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
module MoreExplicitForalls where

import Data.Proxy

data family F1 a
data instance forall (x :: Bool). F1 (Proxy x) = MkF

class C a where
  type F2 a b

instance forall a. C [a] where
  type forall b. F2 [a] b = Int

type family G a b where
  forall x y. G [x] (Proxy y) = Double
  forall z.   G z   z         = Bool


module T15904 (main) where

import System.Environment

main :: IO ()
main = do
  args <- getArgs
  mapM_ putStrLn args


module Main where
-- Test that there are actually entries in the .mix file for an imported
-- literate module generated with --make.
import T2991LiterateModule
main = return ()


\begin{code}
module T2991LiterateModule where
cover_me = 1
\end{code}


{-# OPTIONS_GHC -O2 #-}

-- Reading the interface file caused a black hole
-- in earlier versions of GHC

-- Also, foo should compile to very tight code with -O2
-- (The O2 was nothing to do with the black hole though.)

module ShouldCompile where

import ATLoop_help

foo :: FooT Int -> Int -> Int
foo t n = t `seq` bar n
   where
     bar 0 = 0
     bar n | even n = bar (n `div` 2)
     bar n          = bar (n - int t)


{-# LANGUAGE TypeFamilies #-}
module ATLoop_help where

import Data.Kind (Type)

class Foo a where
   data FooT a :: Type
   int :: FooT a -> Int

instance Foo Int where
    data FooT Int = FooInt !Int
    int (FooInt n) = n


{-# LANGUAGE TypeFamilies, FlexibleContexts #-}

-- Results in context reduction stack overflow

module Class1 where

import Data.Kind (Type)

class C a where
  foo :: a x -> a y

class C (T a) => D a where
  type T a :: Type -> Type

  bar :: a -> T a x -> T a y

instance C Maybe where
  foo Nothing = Nothing

instance D () where
  type T () = Maybe

  bar x t = foo t


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

module Class2 where

data family T a
data instance T Int = TInt Int

data U = U (T Int)

instance Show a => Show (T a) where
  showsPrec k t = showString "T"

instance Show U where
  showsPrec k (U x) = showsPrec k x


{-# LANGUAGE TypeFamilies #-}

module Class3 where

class C a where
  foo :: a -> a
instance C ()

bar :: (a ~ ()) => a -> a
bar = foo


{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}

module ClassEqContext  where

class a ~ b => C a b


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module ClassEqContext  where

class (Show a,a ~ b) => C a b


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module ClassEqContext  where

class a ~ b => C a b

instance C Char Char


{-# LANGUAGE TypeFamilies #-}

module ClosedFam1 where

import ClosedFam1a

type family Foo a where
  Foo Int = Bool
  Foo [a] = Maybe a


module ClosedFam1a where

import {-# SOURCE #-} ClosedFam1


{-# LANGUAGE TypeFamilies #-}

module ClosedFam2 where

import ClosedFam2a

type family Foo a where
  Foo Int = Bool
  Foo [a] = Maybe a


module ClosedFam2a where
import {-# SOURCE #-} ClosedFam2


{-# LANGUAGE TypeFamilies #-}

module Col  where

type family Elem c

type instance Elem [e] = e

class Col c where
 singleton :: Elem c -> c
 add :: c -> Elem c -> c

instance Col [e] where
 singleton = \x -> [x]
 add = flip (:)


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}

module Col  where

type family Elem c

type instance Elem [e] = e

class (Eq (Elem c)) => Col c where
  count     :: Elem c -> c -> Int

instance Eq e => Col [e] where
  count     x = length . filter (==x)


{-# LANGUAGE TypeFamilies #-}

module ColInference  where

type family Elem c

type instance Elem [e] = e

class Col c where
 isEmpty   :: c -> Bool
 add       :: c -> Elem c -> c
 headTail  :: c -> (Elem c,c)

addAll :: (Col c1, Col c2, Elem c1 ~ Elem c2) => c1 -> c2 -> c2
addAll c1 c2
        | isEmpty c1
        = c2
        | otherwise
        = let (x,c1') = headTail c1
          in addAll c1' (add c2 x)


{-# LANGUAGE TypeFamilies #-}

module ColInference  where

type family Elem c

type instance Elem [e] = e

class Col c where
 isEmpty   :: c -> Bool
 add       :: c -> Elem c -> c
 headTail  :: c -> (Elem c,c)

-- addAll :: (Col c1, Col c2, Elem c1 ~ Elem c2) => c1 -> c2 -> c2
-- addAll c1 c2
--      | isEmpty c1
--      = c2
--      | otherwise
--      = let (x,c1') = headTail c1
--        in addAll c1' (add c2 x)

sumCol :: (Col c, Elem c ~ Int) => c -> Int
sumCol c | isEmpty c
         = 0
         | otherwise
         = let (x,xs) = headTail c
           in x + (sumCol xs)

-- data CP :: * -> * where
--  CP :: (Col c1, Col c2, Elem c1 ~ Elem c2, Elem c2 ~ Int) => (c1,c2) -> CP Char


{-# LANGUAGE TypeFamilies #-}

module ColInference  where

type family Elem c

type instance Elem [e] = e

class Col c where
 isEmpty   :: c -> Bool
 add       :: c -> Elem c -> c
 headTail  :: c -> (Elem c,c)

addAll c1 c2
        | isEmpty c1
        = c2
        | otherwise
        = let (x,c1') = headTail c1
          in addAll c1' (add c2 x)


{-# LANGUAGE TypeFamilies #-}

module ColInference  where

type family Elem c

type instance Elem [e] = e

class Col c where
 isEmpty   :: c -> Bool
 add       :: c -> Elem c -> c
 headTail  :: c -> (Elem c,c)

sawpOne c1 c2
        = let (x,c1') = headTail c1
              (y,c2') = headTail c2
          in (add c1' y,add c2' x)


{-# LANGUAGE TypeFamilies #-}

module Main where

type family Elem c

class Col c where
 isEmpty   :: c -> Bool
 add       :: c -> Elem c -> c
 headTail  :: c -> (Elem c,c)

-- LIST
instance Col [a] where
  isEmpty         = null
  add             = flip (:)
  headTail (x:xs) =  (x,xs)

type instance Elem [a] = a

-- SEQUENCE
data Sequence a = Nil | Snoc (Sequence a) a deriving Show

instance Col (Sequence a) where
  isEmpty Nil = True
  isEmpty _   = False

  add     s x = Snoc s x

  headTail (Snoc s x) = (x,s)

type instance Elem (Sequence a) = a

--
addAll c1 c2
        | isEmpty c1
        = c2
        | otherwise
        = let (x,c1') = headTail c1
          in addAll c1' (add c2 x)

--
main = print $ addAll c1 c2
       where c1 = ['a','b','c']
             c2 = (Snoc (Snoc (Snoc Nil 'd') 'e') 'f')


{-# LANGUAGE TypeFamilies #-}

module ColInference  where

type family Elem c

type instance Elem [e] = e

class Col c where
 isEmpty   :: c -> Bool
 add       :: c -> Elem c -> c
 headTail  :: c -> (Elem c,c)

sawpOne c1 c2
        = let (x,c1') = headTail c1
              (y,c2') = headTail c2
          in (add c1' y,add c1' x)


{-# LANGUAGE TypeFamilies #-}

module ColInference  where

type family Elem c

type instance Elem [e] = e

class Col c where
 isEmpty   :: c -> Bool
 add       :: c -> Elem c -> c
 headTail  :: c -> (Elem c,c)

sawpOne c1 c2
        = let (x,c1') = headTail c1
              (y,c2') = headTail c2
          in (add c1' y,add c1' y)


{-# LANGUAGE TypeFamilies, FlexibleContexts #-}

module ColInference6  where

type family Elem c

type instance Elem [e] = e

class Col c where
  toList :: c -> [Elem c]

sumCol c = sum . toList $ c


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}

-- This test uses the PushC rule of the System FC operational semantics
-- Written by Tom Schrijvers

module CoTest3 where

data T a = K (a ~ Int => a -> Int)

{-# INLINE[2] f #-}
f :: T s1 ~ T s2 => T s1 -> T s2
f x = x

{-# INLINE[3] test #-}
test :: T s1 ~ T s2 => (s1 ~ Int => s1 -> Int) -> (s2 ~ Int => s2 -> Int)
test g = case f (K g) of
           K r -> r
e :: s ~ Int => s -> s -> Int
e _ s = s

final :: s1 ~ s2 => s1 -> (s2 ~ Int => s2 -> Int)
final x = test (e x)


{-# LANGUAGE TypeFamilies #-}
module DataFamDeriv where

data family Foo a
data Bar = Bar
data instance Foo Bar
    = Bar1 | Bar2 | Bar3 | Bar4 | Bar5 | Bar6 | Bar7 | Bar8 | Bar9
    deriving Eq


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

module ShouldCompile where

data family T a

data instance T Int = A | B
                    deriving Eq

foo :: T Int -> Bool
foo x = x == x

data instance T Char = C

instance Eq (T Char) where
  C == C = False

data family R a
data instance R [a] = R

deriving instance Eq (R [a])

class C a where
  data S a

instance C Int where
  data S Int = SInt deriving Eq

bar :: S Int -> Bool
bar x = x == x


{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}

module ShouldCompile where

import Control.Applicative (Applicative)

data family S a

newtype instance S Int = S Int
                       deriving Eq

data family S2 a b

newtype instance S2 Int b = S2 (IO b)
                          deriving (Functor, Applicative, Monad)


{-# LANGUAGE TypeFamilies #-}

module Exp (C, C(type T), T, foo, S)
where

class C a where
  data T a :: *
  foo :: a -> a

data family S a b :: *


{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeInType #-}

module ExplicitForAllFams where

import Data.Proxy
import Data.Kind

-- From Proposal 0007

data family F a
data instance forall (x :: Bool). F (Proxy x) = MkF

class C a where
  type G a b
instance forall a. C [a] where
  type forall b. G [a] b = Int

type family H a b where
  forall x y. H [x] (Proxy y) = Double
  forall z.   H z   z         = Bool

-- More tests

type family D a b where
  forall (a :: Type -> Type) (b :: a Int) k (c :: k). D (Proxy b) (Proxy c) = ()
  forall (a :: Bool) (b :: Proxy a). D (Proxy b) () = Int
  forall (a :: Type). D a a = Maybe a


{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE TypeFamilies #-}

module ExplicitForAllFams2 where

import Data.Kind (Type)

-- Even more tests

type family CF a b where
  forall x y.         CF [x] (Maybe y) = (x,y)
  forall (z :: Type). CF z   z         = Bool
  forall.             CF _   _         = ()

type family OF a
type instance forall a b. OF (Maybe a, Either a b) = Either [a] b

data family DF a
data instance forall a b. DF (Maybe a, Either a b) = DF a a b

data family NF a
newtype instance forall a b. NF (Maybe a, Either a b) = NF { unNF :: Either [a] b }

class Cl a where
  type AT a b
  data AD a b
instance forall a. Cl (Maybe a) where
  type forall b. AT (Maybe a) b = b
  data forall b. AD (Maybe a) b = AD b

-- Should produce warnings

type family N a where
  forall t a. N (t a) = [a]
  forall a.   N a     = ()

type family N' a where
  N' (t a) = [a]
  N' a     = ()


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

-- This wrongly fails with
--
--   Can't construct the infinite type n = PLUS n ZERO

module GADT1 where

data ZERO
data SUCC n

data Nat n where
  Zero :: Nat ZERO
  Succ :: Nat n -> Nat (SUCC n)

type family PLUS m n
type instance PLUS ZERO n = n
type instance PLUS (SUCC m) n = SUCC (PLUS m n)

data EQUIV x y where
  EQUIV :: EQUIV x x

plus_zero :: Nat n -> EQUIV (PLUS n ZERO) n
plus_zero Zero = EQUIV
plus_zero (Succ n) = case plus_zero n of
                       EQUIV -> EQUIV

{-

From Succ branch of plus_zero

[G] n ~ SUCC n1     -- n1 existentially bound
[G] PLUS n1 ZERO ~ n1

[W] PLUS n ZERO ~ n

--> [W] PLUS (SUCC n1) ZERO ~ SUCC n1
--> [W] SUCC (PLUS n1 ZERO) ~ SUCC n1
--> [W] SUCC n1 ~ SUCC n1

-}


{-# LANGUAGE TypeFamilies, GADTs, RankNTypes #-}

module GADT10 where

-- [Sept 2010] Now works in GHC 7.0!

-- This fails with
--
-- GADT10.hs:37:0:
--     All of the type variables in the constraint `x ~
--                                                  y' are already in scope
--         (at least one must be universally quantified here)
--     In the type signature for `foo':
--       foo :: EQUAL x y -> ((x ~ y) => t) -> t
--
-- GADT10.hs:38:4:
--     Couldn't match expected type `y' against inferred type `x'
--       `y' is a rigid type variable bound by
--           the type signature for `foo' at GADT10.hs:8:15
--       `x' is a rigid type variable bound by
--           the type signature for `foo' at GADT10.hs:8:13
--     In the pattern: EQUAL
--     In the definition of `foo': foo EQUAL t = t
--
-- The first error can be fixed by using FlexibleContexts but I don't think that
-- should be required here. In fact, if we remove RankNTypes, we get
--
--     Illegal polymorphic or qualified type: forall (co_wild_B1 :: x ~
--                                                                  y).
--                                            t
--     In the type signature for `foo':
--       foo :: EQUAL x y -> ((x ~ y) => t) -> t
--
-- which seems to contradict (at least sort of) the first error message.

data EQUAL x y where
  EQUAL :: EQUAL x x

foo :: EQUAL x y -> (x~y => t) -> t
foo EQUAL t = t

bar :: EQUAL x y -> x -> y
bar equ x = foo equ x


{-# LANGUAGE TypeFamilies, GADTs, RankNTypes, EmptyDataDecls #-}

module ShouldCompile where

data Z
data S a

type family Sum n m
type instance Sum n Z = n
type instance Sum n (S m) = S (Sum n m)

data Nat n where
  NZ :: Nat Z
  NS :: (S n ~ sn) => Nat n -> Nat sn

data EQ a b = forall q . (a ~ b) => Refl

zerol :: Nat n -> EQ n (Sum Z n)
zerol NZ = Refl
-- zerol (NS n) = case zerol n of Refl -> Refl


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

-- Tests whether a type signature can refine a type
-- See the definition of bug2a

module ShouldCompile where

import qualified Data.Kind as K (Type)

data Typed
data Untyped

type family TU a b :: K.Type
type instance TU Typed b = b
type instance TU Untyped b = ()

-- A type witness type, use eg. for pattern-matching on types
data Type a where
    TypeInt     :: Type Int
    TypeBool    :: Type Bool
    TypeString  :: Type String
    TypeList    :: Type t -> Type [t]

data Expr :: K.Type -> K.Type -> K.Type {- tu a -} where
    Const :: Type a -> a -> Expr tu (TU tu a)
    Var2  :: a -> TU tu (Type a) -> Expr tu (TU tu a)

bug1 :: Expr Typed Bool -> ()
bug1 (Const TypeBool False) = ()

bug2a :: Expr Typed Bool -> ()
bug2a (Var2 x (TypeBool :: Type Bool)) = ()

bug2c :: Expr Typed Bool -> ()
bug2c (Var2 x TypeBool) = ()

bug2b :: Expr Typed (TU Typed Bool) -> ()
bug2b (Var2 x TypeBool) = ()


{-# LANGUAGE TypeFamilies, GADTs #-}

module GADT13 where

import Data.Kind (Type)

data family HiThere a :: Type

data instance HiThere () where
    HiThere :: HiThere ()


{-# LANGUAGE TypeFamilies, TypeOperators, GADTs,  RankNTypes, FlexibleContexts #-}
module Equality( (:=:), eq_elim, eq_refl ) where

data a:=: b where
  EQUAL :: a :=: a

eq_refl :: a :=: a
eq_refl = EQUAL

eq_elim :: (a~b) => a :=: b -> (a~b => p) -> p
eq_elim EQUAL p = p


{-# LANGUAGE TypeFamilies, GADTs #-}

-- Fails with
--
--   Couldn't match expected type `y' against inferred type `x'

module GADT2 where

data EQUAL x y where
  EQUAL :: x~y => EQUAL x y

foo :: EQUAL x y -> x -> y
foo EQUAL x = x


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

-- Panics in bind_args

module GADT3 where

data EQUAL x y where
  EQUAL :: x~y => EQUAL x y

data ZERO
data SUCC n

data Nat n where
  Zero :: Nat ZERO
  Succ :: Nat n -> Nat (SUCC n)

type family PLUS m n
type instance PLUS ZERO n = n

plus_zero :: Nat n -> EQUAL (PLUS ZERO n) n
plus_zero Zero = EQUAL
plus_zero (Succ n) = EQUAL

data FOO n where
  FOO_Zero :: FOO ZERO

foo :: Nat m -> Nat n -> FOO n -> FOO (PLUS m n)
foo Zero n s = case plus_zero n of EQUAL -> s


{-# LANGUAGE TypeFamilies, GADTs #-}

module GADT4 where

type family F a
type instance F () = ()

data T a where
  T :: T ()

foo :: T () -> T (F ()) -> ()
foo T T = ()


{-# LANGUAGE TypeFamilies, GADTs #-}

module GADT5 where

data T a where
  T :: T (a,b)
  -- this works:
  -- T :: p ~ (a,b) => T p

type family F a

bar :: a -> T (F a) -> ()
bar x T = ()


{-# LANGUAGE TypeFamilies, GADTs #-}

module GADT6 where

data Pair p  where
  Pair :: p~(a,b) => a -> b -> Pair p
  -- this works:
  -- Pair :: a -> b -> Pair (a,b)

foo :: Pair ((), ()) -> a
foo (Pair () ()) = undefined


{-# LANGUAGE TypeFamilies, GADTs #-}

module GADT7 where

data Pair p  where
  Pair :: p~(a,b) => a -> b -> Pair p
  -- this works:
--  Pair :: a -> b -> Pair (a,b)

foo :: a
foo = case Pair () () of
   -- this works:
--   case Pair () () :: Pair ((), ()) of
        Pair x y -> undefined


{-# LANGUAGE TypeFamilies, GADTs #-}

module GADT8 where

data Pair p  where
  Pair :: p~(a,b) => a -> b -> Pair p
  -- this works:
  -- Pair :: a -> b -> Pair (a,b)

foo :: Pair ((), ()) -> Pair ((), ())
foo (Pair x y) = Pair x y


{-# LANGUAGE TypeFamilies, GADTs #-}

-- Fails with
--
--   Couldn't match expected type `z' against inferred type `y'
--
-- See also GADT2

module GADT2 where

data EQUAL x y where
  EQUAL :: x~y => EQUAL x y

foo :: EQUAL x y -> EQUAL y z -> x -> z
foo EQUAL EQUAL x = x


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

-- Rather exotic example posted to Haskell mailing list 17 Oct 07
-- It concerns context reduction and functional dependencies

module FooModule where

class Concrete a b | a -> b where
        bar :: a -> String

class Wuggle b | -> b  -- To make the Concrete instance work

instance (Show a, Wuggle b) => Concrete a b where
        bar = error "urk"

wib :: Concrete a b => a -> String
-- Weird test case: (Concrete a b) is simplifiable
wib x = bar x

-- Uncommenting this solves the problem:
-- instance Concrete Bool Bool

{- This is a nice example of the trickiness of functional dependencies.
Here's what is happening.

Consider type inference for 'wib'.  GHC 6.6 figures out that the call
of 'bar' gives rise to the constraint (Concrete p q), where x has type
'p'.  Ah, but x must have type 'a', so the constraint is (Concrete a
q).

Now GHC tries to satisfy (Concrete a q) from (Concrete a b). If it
applied improvement right away it'd succeed, but sadly it first looks
at instances declarations.  Success: we can get (Concrete a q) from
(Show a).  So it uses the instance decl and now we can't get (Show a)
from (Concrete a b).

OK,  found that in GHC 6.6, adding
        instance Concrete Bool Bool
fixed the problem. That's weird isn't it?  The reason is this. When GHC looks
at the instance decls, it now sees *two* instance decls matching
(Concrete a q), and so it declines for now to use either of them
(since it's not clear which would be the right one).  Once it has
finished with instance decls it tries improvement.  And, yes, it now
sees that q=b, so all is well.

You might say that GHC should use improvement more vigorously, and
perhaps you'd be right.  And indeed the upcoming GHC 6.8 does exactly
that.
-}


{-# LANGUAGE TypeFamilies #-}

module GivenCheck where

type family S x

f :: a -> S a
f = undefined

g :: S a ~ Char => a -> Char
g y   | False           = f y
      | otherwise       = 'a'


{-# LANGUAGE TypeFamilies #-}

module GivenCheckDecomp where

type family S x

f :: a -> S a
f = undefined

g :: [S a] ~ [Char] => a -> Char
g y   | 'a' == 'b'      = f y


{-# LANGUAGE TypeFamilies #-}

module GivenCheckSwapMain where

type family S x

f :: a -> S a
f = undefined

g :: Char ~ S a => a -> Char
g y   | False           = f y
      | otherwise       = 'a'


{-# LANGUAGE TypeFamilies #-}

module GivenCheckTop where

type family S x

type instance S [e] = e

f :: a -> S a
f = undefined

g :: S [a] ~ Char => a -> Char
g y = y


{-# LANGUAGE TypeFamilies, TypeOperators, RankNTypes #-}

module HO where

import Data.IORef
import Data.Kind

type family SMRef    (m::(Type -> Type)) :: Type -> Type
type family SMMonad  (r::(Type -> Type)) :: Type -> Type

type instance SMRef   IO        = IORef
type instance SMMonad IORef     = IO

class SMMonad (SMRef m) ~ m => SM m where
        new   :: forall a. a -> m (SMRef m a)
        read  :: forall a. (SMRef m a) -> m a
        write :: forall a. (SMRef m a) -> a -> m ()


{-# LANGUAGE TypeFamilies #-}

module Imp
where

import Exp (C, T, S)

instance C Int where
  data T Int = TInt

data instance S Int Bool = SIntBool


{-# LANGUAGE TypeFamilies #-}

-- Test type families

module ShouldCompile where

import Data.Kind (Type)

data family T a :: Type

data instance T Bool = TBool !Bool

class C a where
  foo :: (a -> a) -> T a -> T a

instance C Bool where
  foo f (TBool x) = TBool $ f (not x)


{-# LANGUAGE TypeFamilies #-}

module ShouldCompile where

import Ind2_help(C(..))

zipT :: (C a, C b) => T a -> T b -> T (a,b)
zipT x y = mkT (unT x, unT y)


{-# LANGUAGE TypeFamilies #-}

module Ind2_help where

import Data.Kind (Type)

class C a where
  data T a :: Type
  unT :: T a -> a
  mkT :: a -> T a

instance (C a, C b) => C (a,b) where
  data T (a,b) = TProd (T a) (T b)
  unT (TProd x y) = (unT x, unT y)
  mkT (x,y)       = TProd (mkT x) (mkT y)


-- This used lots of memory, and took a long time to compile, with GHC 6.12:
-- http://www.haskell.org/pipermail/glasgow-haskell-users/2010-May/018835.html

{-# LANGUAGE FlexibleContexts, TypeFamilies #-}

module IndTypesPerf where

import IndTypesPerfMerge

data Rec1 = Rec1 !Int

mkRec1 v = mk $ merge v () where mk (Tagged i :* ()) = Rec1 i


{-# LANGUAGE EmptyDataDecls, TypeFamilies, UndecidableInstances,
             ScopedTypeVariables, TypeOperators,
             FlexibleInstances, NoMonomorphismRestriction,
             MultiParamTypeClasses, FlexibleContexts #-}
module IndTypesPerfMerge where

data a :* b = a :* b
infixr 6 :*

data TRUE
data FALSE
data Zero
data Succ a

type family Equals m n
type instance Equals Zero Zero = TRUE
type instance Equals (Succ a) Zero = FALSE
type instance Equals Zero (Succ a) = FALSE
type instance Equals (Succ a) (Succ b) = Equals a b

type family LessThan m n
type instance LessThan Zero Zero = FALSE
type instance LessThan (Succ n) Zero = FALSE
type instance LessThan Zero (Succ n) = TRUE
type instance LessThan (Succ m) (Succ n) = LessThan m n

newtype Tagged n a = Tagged a deriving (Show,Eq)

type family Cond p a b

type instance Cond TRUE a b = a
type instance Cond FALSE a b = b

class Merger a where
    type Merged a
    type UnmergedLeft a
    type UnmergedRight a
    mkMerge :: a -> UnmergedLeft a -> UnmergedRight a -> Merged a

class Mergeable a b where
    type MergerType a b
    merger :: a -> b -> MergerType a b

{-
merge ::
    forall a b.
    (Merger (MergerType a b), Mergeable a b,
     UnmergedLeft (MergerType a b) ~ a,
     UnmergedRight (MergerType a b) ~ b) =>
    a -> b -> Merged (MergerType a b)
-}
merge x y = mkMerge (merger x y) x y

{- ------------- NASTY TYPE FOR merge -----------------
   -- See Trac #11408

   x:tx, y:ty
   mkMerge @ gamma
   merger @ alpha beta
   merge :: tx -> ty -> tr

Constraints generated:
   gamma ~ MergerType alpha beta
   UnmergedLeft gamma ~ tx
   UnmergedRight gamma ~ ty
   alpha ~ tx
   beta ~ ty
   tr ~ Merged gamma
   Mergeable tx ty
   Merger gamma

One solve path:
  gamma := t
  tx := alpha := UnmergedLeft t
  ty := beta  := UnmergedRight t

  Mergeable (UnmergedLeft t) (UnmergedRight t)
  Merger t
  t ~ MergerType (UnmergedLeft t) (UnmergedRight t)

  LEADS TO AMBIGUOUS TYPE

Another solve path:
  tx := alpha
  ty := beta
  gamma := MergerType alpha beta

  UnmergedLeft (MergerType alpha beta) ~ alpha
  UnmergedRight (MergerType alpha beta) ~ beta
  Merger (MergerType alpha beta)
  Mergeable alpha beta

  LEADS TO NON-AMBIGUOUS TYPE
---------------  -}

data TakeRight a
data TakeLeft a
data DiscardRightHead a b c d
data LeftHeadFirst a b c d
data RightHeadFirst a b c d
data EndMerge

instance Mergeable () () where
    type MergerType () () = EndMerge
    merger = undefined

instance Mergeable () (a :* b) where
    type MergerType () (a :* b) = TakeRight (a :* b)
    merger = undefined
instance Mergeable (a :* b) () where
    type MergerType (a :* b) () = TakeLeft (a :* b)
    merger = undefined

instance Mergeable (Tagged m a :* t1) (Tagged n b :* t2) where
    type MergerType (Tagged m a :* t1) (Tagged n b :* t2) =
        Cond (Equals m n) (DiscardRightHead (Tagged m a) t1 (Tagged n b) t2)
           (Cond (LessThan m n) (LeftHeadFirst (Tagged m a) t1 (Tagged n b) t2)
               (RightHeadFirst (Tagged m a ) t1 (Tagged n b) t2))
    merger = undefined

instance Merger EndMerge where
    type Merged EndMerge = ()
    type UnmergedLeft EndMerge = ()
    type UnmergedRight EndMerge = ()
    mkMerge _ () () = ()

instance Merger (TakeRight a) where
    type Merged (TakeRight a) = a
    type UnmergedLeft (TakeRight a) = ()
    type UnmergedRight (TakeRight a) = a
    mkMerge _ () a = a

instance Merger (TakeLeft a) where
    type Merged (TakeLeft a) = a
    type UnmergedLeft (TakeLeft a) = a
    type UnmergedRight (TakeLeft a) = ()
    mkMerge _ a () = a

instance
    (Mergeable t1 t2,
     Merger (MergerType t1 t2),
     t1 ~ UnmergedLeft (MergerType t1 t2),
     t2 ~ UnmergedRight (MergerType t1 t2)) =>
    Merger (DiscardRightHead h1 t1 h2 t2) where
    type Merged (DiscardRightHead h1 t1 h2 t2) = h1 :* Merged (MergerType t1 t2)
    type UnmergedLeft (DiscardRightHead h1 t1 h2 t2) = h1 :* t1
    type UnmergedRight (DiscardRightHead h1 t1 h2 t2) = h2 :* t2
    mkMerge _ (h1 :* t1) (h2 :* t2) = h1 :* mkMerge (merger t1 t2) t1 t2

instance
    (Mergeable t1 (h2 :* t2),
     Merger (MergerType t1 (h2 :* t2)),
     t1 ~ UnmergedLeft (MergerType t1 (h2 :* t2)),
     (h2 :* t2) ~ UnmergedRight (MergerType t1 (h2 :* t2))) =>
    Merger (LeftHeadFirst h1 t1 h2 t2) where
    type Merged (LeftHeadFirst h1 t1 h2 t2) = h1 :* Merged (MergerType t1 (h2 :* t2))
    type UnmergedLeft (LeftHeadFirst h1 t1 h2 t2) = h1 :* t1
    type UnmergedRight (LeftHeadFirst h1 t1 h2 t2) = h2 :* t2
    mkMerge _ (h1 :* t1) (h2 :* t2) = h1 :* mkMerge (merger t1 (h2 :* t2)) t1 (h2 :* t2)

instance
    (Mergeable (h1 :* t1) t2,
     Merger (MergerType (h1 :* t1) t2),
     (h1 :* t1) ~ UnmergedLeft (MergerType (h1 :* t1) t2),
     t2 ~ UnmergedRight (MergerType (h1 :* t1) t2)) =>
    Merger (RightHeadFirst h1 t1 h2 t2) where
    type Merged (RightHeadFirst h1 t1 h2 t2) = h2 :* Merged (MergerType (h1 :* t1) t2)
    type UnmergedLeft (RightHeadFirst h1 t1 h2 t2) = h1 :* t1
    type UnmergedRight (RightHeadFirst h1 t1 h2 t2) = h2 :* t2
    mkMerge _ (h1 :* t1) (h2 :* t2) = h2 :* mkMerge (merger (h1 :* t1) t2) (h1 :* t1) t2


{-# LANGUAGE TypeFamilies, TypeOperators #-}

-- Test infix type constructors in type families

module Infix where

type family x :+: y
type instance Int :+: Int = Int


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
{-# LANGUAGE EmptyDataDecls, FlexibleInstances, UndecidableInstances #-}

module InstContextNorm
where

import Data.Kind (Type)

data EX _x _y (p :: Type -> Type)
data ANY

class Base p

class Base (Def p) => Prop p where
 type Def p

instance Base ()
instance Prop () where
 type Def () = ()

instance (Base (Def (p ANY))) => Base (EX _x _y p)
instance (Prop (p ANY)) => Prop (EX _x _y p) where
 type Def (EX _x _y p) = EX _x _y p

data FOO x

instance Prop (FOO x) where
 type Def (FOO x) = ()

data BAR

instance Prop BAR where
 type Def BAR = EX () () FOO

  -- Needs Base (Def BAR)
  -- And (Def Bar = Ex () () FOO)
  -- so we need Base (Def (Foo ANY))


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

module InstEqContext  where

{- encoding of
 -      class C a | -> a
 -}
class a ~ Int => C a

instance C Int

unC :: (C a) => a -> Int
unC i = undefined

test :: Int
test = unC undefined


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE TypeFamilies, EmptyDataDecls #-}

module InstEqContext2  where

data E v a = E a
data RValue

instance (Eq a, v ~ RValue) => Eq (E v a) where
    E x == E y  =  x == y

a :: E v Int
a = undefined

foo = a == a


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

module InstEqContext  where

{- encoding of
 -      class C a | -> a
 - with extra indirection
 -}
class a ~ Int => D a
instance D Int

class D a => C a
instance C Int

unC :: (C a) => a -> Int
unC i = undefined

test :: Int
test = unC undefined


{-# LANGUAGE TypeFamilies #-}

module Kind where

import Data.Kind (Type)

class C (a :: Type -> Type) where
  type T a

foo :: a x -> T a
foo = undefined


{-# LANGUAGE TypeFamilies #-}

module NewTyCo1 where

data family T a
newtype instance T Int = TInt Int

foo :: T Int -> Int
foo (TInt n) = n


{-# LANGUAGE TypeFamilies #-}

module NewTyCo2 where

import NewTyCo1

bar x = foo x + 1


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

module NonLinearLHS where

type family E a b
type instance E a a = [a]

foo :: E [Int] (E Int Int) -> Int
foo = sum . concat

data family F a b
data instance F a a = MkF [a]

goo :: F Int Int -> F Bool Bool
goo (MkF xs) = MkF $ map odd xs

-- HList-like type equality

data True; data False;

type family EqTy a b
type instance EqTy a a = True

class EqTyP a b result
instance (EqTy a b ~ isEq, Proxy isEq result) => EqTyP a b result

class Proxy inp out
instance (result ~ True) => Proxy True result
instance (result ~ False) => Proxy notTrue result

testTrue :: EqTyP Int Int r => r
-- Weird test case: (EqTyP Int Int) is simplifiable
testTrue = undefined

testFalse :: EqTyP Int Bool r => r
-- Weird test case: (EqTyP Int Bool) is simplifiable
testFalse = undefined


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}

module Numerals where

import Data.Kind

data Z          -- empty data type
data S a        -- empty data type

data SNat n where  -- natural numbers as singleton type
  Zero :: SNat Z
  Succ :: SNat n -> SNat (S n)

zero  = Zero
one   = Succ zero
two   = Succ one
three = Succ two
-- etc...we really would like some nicer syntax here

type family (:+:) n m :: Type
type instance Z     :+: m = m
type instance (S n) :+: m = S (n :+: m)

add :: SNat n -> SNat m -> SNat (n :+: m)
add Zero     m = m
add (Succ n) m = Succ (add n m)


{-# LANGUAGE TypeFamilies #-}

module Overlap1 where

type family F a where
  F Int = Int
  F a = Bool

g :: F Int
g = 5

h :: F Char
h = False


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

module Overlap12 where

type family And (a :: Bool) (b :: Bool) :: Bool where
  And False x = False
  And True x = x
  And x False = False
  And x True = x
  And x x = x

data Proxy p = P

a :: Proxy (And False x)
a = (P :: Proxy False)

b :: Proxy x -> Proxy (And True x)
b x = x

c :: Proxy (And x False)
c = (P :: Proxy False)

d :: Proxy x -> Proxy (And x True)
d x = x

e :: Proxy x -> Proxy (And x x)
e x = x


{-# LANGUAGE TypeFamilies #-}

module Overlap13 where

type family F a b where
  F a a = Int
  F a Int = Int
  F a b = b

g :: a -> F a Int
g x = (5 :: Int)


{-# LANGUAGE TypeFamilies #-}

module Overlap14 where

import Data.Proxy

type family F a b c where
  F a a Int = Int
  F b c d   = Bool

foo :: Proxy b -> F b [b] Bool
foo _ = False


{-# LANGUAGE TypeFamilies #-}

module Overlap2 where

type family F a b where
  F a a = Int
  F a b = Bool

g :: F Char Double
g = False

h :: F Double Double
h = -2


{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}

module OversatDecomp where

import Data.Kind (Type)

class Blah f a where
  blah :: a -> T f f a

class A (f :: Type -> Type) where
  type T f :: (Type -> Type) -> Type -> Type

wrapper :: Blah f a => a -> T f f a
wrapper x = blah x


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeFamilies #-}
module PushedInAsGivens where

type family F a

bar y = let foo :: (F Int ~ [a]) => a -> Int
            foo x = length [x,y]
        in (y,foo y)

-- This example demonstrates why we need to push in
-- an unsolved wanted as a given and not a given/solved.
-- [Wanted] F Int ~ [beta]
--- forall a. F Int ~ [a] => a ~ beta
-- We push in the [Wanted] as given, it will interact and solve the implication
-- constraint, and finally we quantify over F Int ~ [beta]. If we push it in as
-- Given/Solved, it will be discarded when we meet the given (F Int ~ [a]) and
-- we will not be able to solve the implication constraint.

-- Oct 14: actually this example is _really_ strange, and doesn't illustrate
-- the real issue in Trac #4935, for which there is a separate test
--
-- The example here requires us to infer a type
--   bar :: F Int ~ [a] => ...
-- which is a strange type to quantify over; better to complain about
-- having no instance for F Int.


{-# LANGUAGE TypeFamilies #-}

-- See Trac #1204

module ShouldCompile where

data FooC = FooC

data family T c
data instance T FooC = MkT { moo :: Int }

t1 :: Int -> T FooC
t1 i = MkT { moo = i }

t2 :: T FooC -> Int
t2 (MkT { moo = i }) = i

t3 :: T FooC -> Int
t3 m = moo m

f :: T FooC -> T FooC
f r = r { moo = 3 }

------------------------------------------------------------------------------
class D c where
  data D1 c
  works :: Int -> D1 c -> D1 c
  buggy :: Int -> D1 c -> D1 c
  buggy2 :: Int -> D1 c -> D1 c

instance D FooC where
  data D1 FooC = D1F { noo :: Int }

  works x d = d  -- d unchanged, so OK

  buggy x d@(D1F { noo = k }) =
    d { noo = k + x }

  buggy2 x d@(D1F { noo = k }) =
    (d :: D1 FooC) { noo = k + x }


{-# LANGUAGE InstanceSigs, GADTs, StandaloneDeriving, DataKinds, KindSignatures, MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-}

-- Implementation of deletion for red black trees by Matt Might
-- Editing to preserve the red/black tree invariants by Stephanie Weirich,
-- Dan Licata and John Hughes, at WG2.8 August 2014

-- Original available from:
--   http://matt.might.net/articles/red-black-delete/code/RedBlackSet.hs
-- Slides:
--   http://matt.might.net/papers/might2014redblack-talk.pdf

module MightRedBlackGADT where

import Prelude hiding (max)
import Data.List(nub,sort)
import Control.Monad(liftM)
import Data.Type.Equality
import Data.Kind (Type)
import Data.Maybe(isJust)

--
data Color = Red | Black | DoubleBlack | NegativeBlack

-- Singleton type, connects the type level color to data
-- not necessary in a full-spectrum dependently-typed language
data SColor (c :: Color) where
   R  :: SColor Red -- red
   B  :: SColor Black -- black
   BB :: SColor DoubleBlack -- double black
   NB :: SColor NegativeBlack -- negative black

-- natural numbers for tracking the black height
data Nat = Z | S Nat

-- Well-formed Red/Black trees
-- n statically tracks the black height of the tree
-- c statically tracks the color of the root node
data CT (n :: Nat) (c :: Color) (a :: Type) where
   E  :: CT Z Black a
   T  :: Valid c c1 c2 =>
         SColor c -> (CT n c1 a) -> a -> (CT n c2 a) -> CT (Incr c n) c a

-- this type class forces the children of red nodes to be black
-- and also excludes double-black and negative-black nodes from
-- a valid red-black tree.
class Valid (c :: Color) (c1 :: Color) (c2 :: Color) where
instance Valid Red Black Black
instance Valid Black c1 c2

-- incrementing the black height, based on the color
type family Incr (c :: Color) (n :: Nat) :: Nat
type instance Incr Black n             = S n
type instance Incr DoubleBlack n       = S (S n)
type instance Incr Red   n             = n
type instance Incr NegativeBlack (S n) = n

-- the top level type of red-black trees
-- the data constructor forces the root to be black and
-- hides the black height.
data RBSet a where
  Root :: (CT n Black a) -> RBSet a

deriving instance Show (SColor c)
deriving instance Show a => Show (CT n c a)
instance Show a => Show (RBSet a) where
  show (Root x) = show x

showT :: CT n c a -> String
showT E = "E"
showT (T c l x r) =
    "(T " ++ show c ++ " " ++ showT l ++ " "
          ++ "..." ++ " " ++ showT r ++ ")"

-- the test equality class gives us a proof that type level
-- colors are equal.
-- testEquality :: SColor c1 -> SColor c2 -> Maybe (c1 ~ c2)
instance TestEquality SColor where
  testEquality R R   = Just Refl
  testEquality B B   = Just Refl
  testEquality BB BB = Just Refl
  testEquality NB NB = Just Refl
  testEquality _ _   = Nothing

-- comparing two Red/Black trees for equality.
-- unfortunately, because we have two instances, we can't
-- use the testEquality class.
(%==%) :: Eq a => CT n1 c1 a -> CT n2 c2 a -> Bool
E %==% E = True
T c1 a1 x1 b1 %==% T c2 a2 x2 b2 =
  isJust (testEquality c1 c2) && a1 %==% a2 && x1 == x2 && b1 %==% b2

instance Eq a => Eq (RBSet a) where
  (Root t1) == (Root t2) = t1 %==% t2

 -- Public operations --

empty :: RBSet a
empty = Root E

member :: (Ord a) => a -> RBSet a -> Bool
member x (Root t) = aux x t where
  aux :: Ord a => a -> CT n c a -> Bool
  aux x E = False
  aux x (T _ l y r) | x < y     = aux x l
                    | x > y     = aux x r
                    | otherwise = True

elements :: Ord a => RBSet a -> [a]
elements (Root t) = aux t [] where
      aux :: Ord a => CT n c a -> [a] -> [a]
      aux E acc = acc
      aux (T _ a x b) acc = aux a (x : aux b acc)

 -- INSERTION --

insert :: (Ord a) => a -> RBSet a -> RBSet a
insert x (Root s) = blacken (ins x s)
 where ins :: Ord a => a -> CT n c a -> IR n a
       ins x E = IN R E x E
       ins x s@(T color a y b) | x < y     = balanceL color (ins x a) y b
                               | x > y     = balanceR color a y (ins x b)
                               | otherwise = (IN color a y b)

       blacken :: IR n a -> RBSet a
       blacken (IN _ a x b) = Root (T B a x b)

-- an intermediate data structure that temporarily violates the
-- red-black tree invariants during insertion. (IR stands for infra-red).
-- This tree must be non-empty, but is allowed to have two red nodes in
-- a row.
data IR n a where
   IN :: SColor c -> CT n c1 a -> a -> CT n c2 a -> IR (Incr c n) a

-- `balance` rotates away coloring conflicts
-- we separate it into two cases based on whether the infraction could
-- be on the left or the right

balanceL :: SColor c -> IR n a -> a -> CT n c1 a -> IR (Incr c n) a
balanceL B (IN R (T R a x b) y c) z d = IN R (T B a x b) y (T B c z d)
balanceL B (IN R a x (T R b y c)) z d = IN R (T B a x b) y (T B c z d)
balanceL c (IN B a x b) z d           = IN c (T B a x b) z d
balanceL c (IN R a@(T B _ _ _) x b@(T B _ _ _)) z d = IN c (T R a x b) z d
balanceL c (IN R a@E x b@E) z d       = IN c (T R a x b) z d

balanceR :: SColor c -> CT n c1 a -> a -> IR n a -> IR (Incr c n) a
balanceR B a x (IN R (T R b y c) z d) = IN R (T B a x b) y (T B c z d)
balanceR B a x (IN R b y (T R c z d)) = IN R (T B a x b) y (T B c z d)
balanceR c a x (IN B b z d)           = IN c a x (T B b z d)
balanceR c a x (IN R b@(T B _ _ _) z d@(T B _ _ _)) = IN c a x (T R b z d)
balanceR c a x (IN R b@E z d@E)       = IN c a x (T R b z d)

 -- DELETION --

-- like insert, delete relies on a helper function that may (slightly)
-- violate the red-black tree invariant

delete :: (Ord a) => a -> RBSet a -> RBSet a
delete x (Root s) = blacken (del x s)
 where blacken :: DT n a -> RBSet a
       blacken (DT B a x b)  = Root (T B a x b)
       blacken (DT BB a x b) = Root (T B a x b)
       blacken DE  = Root E
       blacken DEE = Root E
       -- note: del always produces a black or
       -- double black tree. These last two cases are unreachable
       -- but it may be difficult to prove it.
       blacken (DT R a x b) = Root (T B a x b)
       blacken (DT NB a x b) = Root (T B a x b)

       del :: Ord a => a -> CT n c a -> DT n a
       del x E = DE
       del x s@(T color a y b) | x < y     = bubbleL color (del x a) y b
                               | x > y     = bubbleR color a y (del x b)
                               | otherwise = remove s

-- deletion tree, the result of del
-- could have a double black node
-- (but only at the top or as a single leaf)
data DT n a where
  DT  :: SColor c -> CT n c1 a -> a -> CT n c2 a -> DT (Incr c n) a
  DE  :: DT Z a
  DEE :: DT (S Z) a

-- Note: we could unify this with the IR data structure by
-- adding the DE and DEE data constructors. That would allow us to
-- reuse the same balancing function (and blacken function)
-- for both insertion and deletion.
-- However, if an Agda version did that it might get into trouble,
-- trying to show that insertion never produces a leaf.

instance Show a => Show (DT n a) where
  show DE = "DE"
  show DEE = "DEE"
  show (DT c l x r) =
    "(DT " ++ show c ++ " " ++ show l ++ " "
           ++ "..." ++ " " ++ show r ++ ")"

-- Note: eliding a to make error easier below.
showDT :: DT n a -> String
showDT DE = "DE"
showDT DEE = "DEE"
showDT (DT c l x r) =
    "(DT " ++ show c ++ " " ++ showT l ++ " "
           ++ "..." ++ " " ++ showT r ++ ")"

-- maximum element from a red-black tree
max :: CT n c a -> a
max E = error "no largest element"
max (T _ _ x E) = x
max (T _ _ x r) = max r

-- Remove the top node: it might leave behind a double black node
-- if the removed node is black (note that the height is preserved)
remove :: CT n c a -> DT n a
remove (T R E _ E) = DE
remove (T B E _ E) = DEE
remove (T B E _ (T R a x b)) = DT B a x b
remove (T B (T R a x b) _ E) = DT B a x b
remove (T color l y r) = bubbleL color (removeMax l) (max l) r

-- remove the maximum element of the tree
removeMax :: CT n c a -> DT n a
removeMax E                 = error "no maximum to remove"
removeMax s@(T _ _ _ E)     = remove s
removeMax s@(T color l x r) = bubbleR color l x (removeMax r)

-- make a node more red (i.e. decreasing its black height)
-- note that the color of the resulting node is not part of the
-- result height because the result of this operation doesn't
-- necessarily satisfy the RBT invariants
redden :: CT (S n) c a -> DT n a
redden (T B a x y)  = DT R a x y
redden (T BB a x y) = DT B a x y
redden (T R a x y)  = DT NB a x y

-- assert that a tree is red. Dynamically fail otherwise
-- this is a cheat that Haskell let's us get away with, but Agda
-- would not
assertRed :: DT n a -> CT n Red a
assertRed (DT R (T B aa ax ay) x (T B ac az ad)) =
  (T R (T B aa ax ay) x (T B ac az ad))
assertRed t = error ("not a red tree " ++ showDT t)

dbalanceL :: SColor c -> DT n a -> a -> CT n c1 a -> DT (Incr c n) a
-- reshuffle (same as insert)
dbalanceL B (DT R (T R a x b) y c) z d = DT R (T B a x b) y (T B c z d)
dbalanceL B (DT R a x (T R b y c)) z d = DT R (T B a x b) y (T B c z d)
-- double-black (new for delete)
dbalanceL BB (DT R (T R a x b) y c) z d = DT B (T B a x b) y (T B c z d)
dbalanceL BB (DT R a x (T R b y c)) z d = DT B (T B a x b) y (T B c z d)
dbalanceL BB (DT NB a@(T B _ _ _) x (T B b y c)) z d =
  case (dbalanceL B (redden a) x b) of
    r@(DT R _ _ _)  -> DT B (assertRed r)  y (T B c z d)
    (DT B a1 x1 y1) -> DT B (T B a1 x1 y1) y (T B c z d)
-- fall through cases (same as insert)
dbalanceL c (DT B a x b) z d                         = DT c (T B a x b) z d
dbalanceL c (DT R a@(T B _ _ _) x b@(T B _ _ _)) z d = DT c (T R a x b) z d
dbalanceL c (DT R a@E x b@E) z d                     = DT c (T R a x b) z d
-- more fall through cases (new for delete)
dbalanceL c DE x b = (DT c E x b)
dbalanceL c a x b = error ("no case for " ++ showDT a)

dbalanceR :: SColor c -> CT n c1 a -> a -> DT n a -> DT (Incr c n) a
dbalanceR B a x (DT R (T R b y c) z d) = DT R (T B a x b) y (T B c z d)
dbalanceR B a x (DT R b y (T R c z d)) = DT R (T B a x b) y (T B c z d)
dbalanceR BB a x (DT R (T R b y c) z d) = DT B (T B a x b) y (T B c z d)
dbalanceR BB a x (DT R b y (T R c z d)) = DT B (T B a x b) y (T B c z d)
dbalanceR BB a x (DT NB (T B b y c) z d@(T B _ _ _)) =
  case (dbalanceR B c z (redden d)) of
        r@(DT R _ _ _)  -> DT B (T B a x b) y (assertRed r)
        (DT B a1 x1 y1) -> DT B (T B a x b) y (T B a1 x1 y1)

dbalanceR c a x (DT B b z d)           = DT c a x (T B b z d)
dbalanceR c a x (DT R b@(T B _ _ _) z d@(T B _ _ _)) = DT c a x (T R b z d)
dbalanceR c a x (DT R b@E z d@E) = DT c a x (T R b z d)
dbalanceR c a x DE = DT c a x E
dbalanceR c a x b = error ("no case for " ++ showDT b)

bubbleL :: SColor c -> DT n a -> a -> CT n c1 a -> DT (Incr c n) a
-- don't want to prove generally that
-- (Incr (Blacker c) 'Z ~ Incr c ('S 'Z)) so expand by cases.
-- (Note: Do we need all three of these cases?)
bubbleL B DEE x r   = dbalanceR BB E x (redden r)
bubbleL R DEE x r   = dbalanceR B E x (redden r)
bubbleL NB DEE x r  = dbalanceR R E x (redden r)
-- same thing here
bubbleL B l@(DT BB a y b) x r  = dbalanceR BB (T B a y b) x (redden r)
bubbleL R l@(DT BB a y b) x r  = dbalanceR B (T B a y b) x (redden r)
bubbleL NB l@(DT BB a y b) x r = dbalanceR R (T B a y b) x (redden r)
-- fall through case
bubbleL color l x r = dbalanceL color l x r

bubbleR :: SColor c -> CT n c1 a -> a -> DT n a -> DT (Incr c n) a
bubbleR B r x DEE    = dbalanceL BB (redden r) x E
bubbleR R r x DEE    = dbalanceL B  (redden r) x E
bubbleR NB r x DEE   = dbalanceL R  (redden r) x E
-- same thing here
bubbleR B r x l@(DT BB a y b) = dbalanceL BB (redden r) x (T B a y b)
bubbleR R r x l@(DT BB a y b)  = dbalanceL B (redden r) x (T B a y b)
bubbleR NB r x l@(DT BB a y b) = dbalanceL R (redden r) x (T B a y b)
-- fall through case
bubbleR color l x r = dbalanceR color l x r


{-# LANGUAGE TypeFamilies #-}

module Refl where

import Data.Kind (Type)

type family T a :: Type -> Type

foo :: a x -> a y
foo = undefined

bar :: a -> T a x -> T a y
bar x t = foo t

{- GHC complains that it could not deduce (T a x ~ T a x) where problem is
that with -dppr-debug, we get "x{tv a7z} [sk]" on the lhs and "x{tv a7C}
[box]" on the rhs
 -}


{-# LANGUAGE TypeFamilies #-}

module Refl2 where

import Data.Kind (Type)

type family T (a :: Type -> Type) :: Type -> Type

data U a x = U (T a x)

mkU :: a x -> U a x
mkU x = U undefined

-- The first definition says "Could not deduce (T a x ~ T a x)", the other two
-- work fine

foo :: a x -> U a x
foo x = case mkU x of U t -> id (U t)
-- foo x = case mkU x of U t -> id ((U :: T a x -> U a x) t)
-- foo x = case mkU x of U t -> U t


{-# LANGUAGE TypeFamilies #-}

module RelaxedExamples where

type family F1 a
type family F2 a
type family F3 a
type family F4 a

type instance F1 x      = x
type instance F2 [Bool] = F2 Char
type instance F3 (a, b) = (F3 a, F3 b)
type instance F4 x      = (x, x)


{-# LANGUAGE TypeFamilies, RankNTypes #-}

-- This test made the type checker produce an
-- ill-kinded coercion term.

module Roman where

import Control.Monad.ST
import Data.Kind (Type)

type family Mut (v :: Type -> Type) :: Type -> Type -> Type
type family State (m :: Type -> Type)
type instance State (ST s) = s

unsafeFreeze :: Mut v (State (ST s)) a -> ST s (v a)
unsafeFreeze = undefined

new :: (forall v s. ST s (v s a)) -> v a
new p = runST (do
                 mv <- p
                 unsafeFreeze mv)

---------------------------------------------
-- Here's a simpler version that also failed

type family FMut :: Type -> Type      -- No args
                                      -- Same thing happens with one arg

type family   FState (m :: Type)
type instance FState Char = Int

funsafeFreeze :: FMut (FState Char) -> ()
funsafeFreeze = undefined

flop :: forall mv. mv Int
flop = undefined

noo =  flop `rapp` funsafeFreeze

rapp :: a -> (a->()) -> ()
rapp arg fun = fun arg


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

module Rules1 where

class C a where
  data T a

instance (C a, C b) => C (a,b) where
  data T (a,b) = TPair (T a) (T b)

mapT :: (C a, C b) => (a -> b) -> T a -> T b
{-# NOINLINE mapT #-}  -- Otherwwise we get a warning from the rule
mapT = undefined

zipT :: (C a, C b) => T a -> T b -> T (a,b)
{-# NOINLINE [1] zipT #-}
zipT = undefined

{-# RULES

"zipT/mapT" forall f x y.
  zipT (mapT f x) y = mapT (\(x,y) -> (f x, y)) (zipT x y)

 #-}


{-# LANGUAGE TypeFamilies #-}

module ShouldCompile where

import Data.Kind (Type)

class C a where
  data Sd a :: Type
  data Sn a :: Type
  type St a :: Type

instance C Int where
  data    Sd Int = SdC Char
  newtype Sn Int = SnC Char
  type    St Int = Char


{-# LANGUAGE TypeFamilies #-}

module Simple10 where

type family T a

foo, bar :: T a -> a
foo = undefined
bar x = foo x


{-# LANGUAGE TypeFamilies #-}

module Simple11 where

type family F a

same :: a -> a -> a
same = undefined

mkf :: a -> F a
mkf p = undefined

-- Works with explicit signature
-- foo :: a -> a -> (F a, a)
foo p q = same (mkf p, p) (mkf q, q)


{-# LANGUAGE TypeFamilies #-}

module Simple12 where

type family F a

same :: a -> a -> a
same = undefined

mkf :: a -> F a
mkf p = undefined

-- works with either of these signatures
-- foo :: a ~ F a => a -> a
-- foo :: a ~ F a => a -> F a
foo p = same p (mkf p)


{-# LANGUAGE TypeFamilies #-}

-- This should fail, I think, because of the loopy equality,
-- but the error message is hopeless

module Simple13 where

type family F a

same :: a -> a -> a
same = undefined

mkf :: a -> [F a]
mkf p = undefined

foo :: a ~ [F a] => a -> a
foo p = same p (mkf p)

{- p :: a

  [G] g : a ~ [F a]
  [W] w : a ~ [F a]

--->
  g' = g;[x]                g'=aq4
  [G] g'  : a ~ [fsk]       g=aqW
  [W] x : F a ~ fsk         x=aq3

  [W] w : a ~ [F a]

  --> subst a
       x = F g' ; x2
   [W] x2 : F fsk ~ fsk     x2=aq5

  -->  (subst a)
      w = g' ; w2
  [W] w2 : [fsk] ~ [F a]

  --> decompose
       w2 = [w3]
   [W] w3 : fsk ~ F a

cycle is
   aq3 = Sym (F aq4) ; aq5    x = Sym (F g') ; x2
   aq4 = apw ; aq3            g' =
-}


{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts, ScopedTypeVariables #-}

module Simple14 where

data EQ_ x y = EQ_

-- Nov 2014: actually eqE has an ambiguous type
eqE :: EQ_ x y -> (x~y => EQ_ z z) -> p
eqE = error "eqE"

eqI :: EQ_ x x
eqI = error "eqI"

ntI :: (forall p. EQ_ x y -> p) -> EQ_ x y
ntI = error "ntI"

foo :: forall m n. EQ_ (Maybe m) (Maybe n)
foo = ntI (`eqE` (eqI :: EQ_ m n))
-- Alternative
-- foo = ntI (\eq -> eq `eqE` (eqI :: EQ_ m n))

-- eq :: EQ_ (Maybe m) (Maybe n)
-- Need (Maybe m ~ Maybe n) =>  EQ_ m n ~ EQ_ zeta zeta
-- which redues to (m~n) => m ~ zeta
-- but then we are stuck


{-# LANGUAGE TypeFamilies #-}

module Simple15 where

(<$) :: p -> (p -> q) -> q
x <$ f = f x

type family Def p

def :: Def p -> p
def = undefined

data EQU a b = EQU

equ_refl :: EQU a a
equ_refl = EQU

data FOO = FOO
type instance Def FOO = EQU () ()

foo :: FOO
foo = equ_refl Simple15.<$ def
-- This works:
-- foo = def $ equ_refl


{-# LANGUAGE TypeFamilies #-}
-- submitted by g9ks157k@acme.softbase.org as #1713
module TypeFamilyBug where

import Data.Kind (Type)

type family TestFamily a :: Type

type instance TestFamily () = [()]

testFunction :: value -> TestFamily value -> ()
testFunction = const (const ())

testApplication :: ()
testApplication = testFunction () (return ())


{-# LANGUAGE TypeFamilies #-}
module Simple17 where

foo :: Int -> Int
foo n = bar n
  where
    bar :: t ~ Int => Int -> t
    bar n = n


{-# LANGUAGE TypeFamilies #-}

module Simple18 where

type family F a

type instance F Int = [Int]

foo :: F Int
foo = [1]


{-# LANGUAGE TypeFamilies, LiberalTypeSynonyms #-}
                           -- ^ crucial for exercising the code paths to be
                           --   tested here

module ShouldCompile where

import Data.Kind (Type)

type family Element c :: Type

f :: x -> Element x
f x = undefined


{-# LANGUAGE TypeFamilies #-}

module ShouldCompile where

class C3 a where
  data S3  a            -- kind is optional
  data S3n a            -- kind is optional
  foo3  :: a -> S3 a
  foo3n :: a -> S3n a
  bar3  :: S3 a -> a
  bar3n :: S3n a -> a

instance C3 Int where
  data    S3  Int  = D3Int
  newtype S3n Int  = D3Intn ()
  foo3  _          = D3Int
  foo3n _          = D3Intn ()
  bar3  D3Int      = 1
  bar3n (D3Intn _) = 1

instance C3 Char where
  data S3 Char = D3Char
  foo3 _       = D3Char
  bar3 D3Char  = 'c'

bar3' :: S3 Char -> Char
bar3' D3Char = 'a'

instance C3 Bool where
  data S3 Bool = S3_1 | S3_2
  foo3 False = S3_1
  foo3 True  = S3_2
  bar3 S3_1 = False
  bar3 S3_2 = True

-- It's ok to omit ATs in instances, as it is ok to omit method definitions,
-- but similar to methods, "undefined" is the only inhabitant of these types,
-- then.
instance C3 Float where
  foo3 1.0 = undefined
  bar3 _   = 1.0


{-# LANGUAGE TypeFamilies #-}

module ShouldCompile where

type family F a
type instance F [a] = [F a]

foo :: (F [a] ~ a) => a
foo = undefined


{-# LANGUAGE TypeFamilies #-}

module ShouldCompile where

import Prelude hiding (foldr, foldr1)

import Data.Maybe

type family Elem x

class Foldable a where
  foldr :: (Elem a -> b -> b) -> b -> a -> b

  foldr1 :: (Elem a -> Elem a -> Elem a) -> a -> Elem a
  foldr1 f xs = fromMaybe (error "foldr1: empty structure")
                  (foldr mf Nothing xs)
     where mf x Nothing  = Just x
           mf x (Just y) = Just (f x y)


{-# LANGUAGE TypeFamilies #-}

module ShouldCompile where

data X1 = X1

class C t where
    type D t
    f :: t -> D t -> ()

instance C X1 where
    type D X1 = Bool -> Bool
    f _ h = ()

foo = f X1 (\x -> x)


{-# LANGUAGE TypeFamilies #-}

module ShouldCompile where

plus :: (a ~ (Int -> Int)) => Int -> a
plus x y = x + y


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-}

module Simple24 where

import Data.Kind (Type)

linear :: HasTrie (Basis v) => (Basis v, v)
linear =  basisValue

class HasTrie a where

type family Basis u :: Type

basisValue :: (Basis v,v)
basisValue = error "urk"


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

module ShouldCompile where

import Data.Kind (Type)

class C7 a b where
  data S7 b :: Type

instance C7 Char (a, Bool) where
  data S7 (a, Bool) = S7_1


{-# LANGUAGE TypeFamilies #-}

module ShouldCompile where

import Data.Kind (Type)

class C8 a where
  data S8 a :: Type -> Type

instance C8 Int where
  data S8 Int a = S8Int a


{-# LANGUAGE TypeFamilies #-}

module ShouldCompile where

import Data.Kind (Type)

data family C9 a b :: Type
data instance C9 Int Int = C9IntInt
data instance C9 [a] Int = C9ListInt
data instance C9 [Int] [a]   = C9ListList2

type family D a
type instance D (Int, a) = (Int, a)
type instance D (a, Int) = (Int, Int)

type family E a
type instance E (Char, b) = ([Char], b)
type instance E (a, Int)  = (String, Int)


{-# LANGUAGE TypeFamilies #-}

module ShouldCompile where

import Data.IORef
import Data.Kind (Type)

data family T a
data instance T a = T

foo :: T Int -> T Char
foo T = T

type family S a
type instance S a = a

type family SMRef (m:: Type -> Type) :: Type -> Type
type instance SMRef IO = IORef


{-# LANGUAGE TypeFamilies #-}

module ShouldCompile where

import Data.Kind (Type)

class C1 a where
  data S1 a :: Type

-- instance of data families can be data or newtypes
instance C1 Char where
  newtype S1 Char = S1Char ()


{-# LANGUAGE TypeFamilies #-}

module Simple8 where

type family F a

-- Manuel says that duplicate instances are ok. This gives a strange error but
-- works if one of the duplicates is removed.

type instance F () = ()
-- type instance F () = ()

foo :: F () -> ()
foo x = x


{-# LANGUAGE TypeFamilies #-}

module Simple9 where

import Data.Kind (Type)

-- The test succeeds with
--
-- type family F a b
-- type instance F () b = Maybe b

type family F a :: Type -> Type
type instance F () = Maybe

type family G a
type instance G (Maybe a) = Int

foo :: G (F () a) -> Int
foo x = x


-- From the GHC users mailing list, 3/9/14

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Sock where

import Data.Proxy
import Data.Kind

data Message

data SocketType = Dealer | Push | Pull

data SocketOperation = Read | Write

data SockOp :: SocketType -> SocketOperation -> Type where
    SRead :: Foo 'Read sock => SockOp sock 'Read
    SWrite :: Foo Write sock => SockOp sock Write

data Socket :: SocketType -> Type where
    Socket :: proxy sock
           -> (forall op . Foo op sock => SockOp sock op -> Operation op)
           -> Socket sock

type family Foo (op :: SocketOperation) (s :: SocketType) :: Constraint where
    Foo 'Read s = Readable s
    Foo Write s = Writable s

type family Operation (op :: SocketOperation) :: Type where
    Operation 'Read = IO Message
    Operation Write = Message -> IO ()

type family Readable (t :: SocketType) :: Constraint where
    Readable Dealer = ()
    Readable Pull = ()

type family Writable (t :: SocketType) :: Constraint where
    Writable Dealer = ()
    Writable Push = ()

dealer :: Socket Dealer
dealer = undefined

push :: Socket Push
push = undefined

pull :: Socket Pull
pull = undefined

readSocket :: forall sock . Readable sock => Socket sock -> IO Message
readSocket (Socket _ f) = f (SRead :: SockOp sock 'Read)


{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
module T10020 where

class NullaryClass where
    data NullaryData


{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
module T10079 where

import Control.Applicative
import Data.Coerce

broken :: Bizarre (->) w => w a b t -> ()
broken = getConst #. bazaar (Const #. const ())

class Profunctor p where
  (#.) :: Coercible c b => (b -> c) -> p a b -> p a c

instance Profunctor (->) where
  (#.) = (.)

class Bizarre p w | w -> p where
  bazaar :: Applicative f => p a (f b) -> w a b t -> f t


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

module T10139 where

import Data.Monoid
import Data.Kind
import Data.Coerce

class Monoid v => Measured v a | a -> v where
  _measure :: v -> a
data FingerTree v a = Dummy v a
singleton :: Measured v a => a -> FingerTree v a
singleton = undefined

class DOps a where
  plus :: a -> D a -> a

type family D a :: Type
type instance D (FingerTree (Size Int, v) (Sized a)) = [Diff (Normal a)]

type family Normal a :: Type

data Diff a = Add Int a

newtype Sized a = Sized a
newtype Size a = Size a

-- This works:
{-
instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where
  plus = foldr (\(Add index val) seq -> singleton ((coerce) val))
-}

-- This hangs:
instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where
  plus = foldr (flip f)
    where f _seq x = case x of
            Add _index val -> singleton ((coerce) val)


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-} -- only necessary in 7.10
{-# LANGUAGE FlexibleContexts #-}    -- necessary for showFromF' example
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module T10226 where

type family F    a
type family FInv a

-- This definition is accepted in 7.8 without anything extra, but requires
-- AllowAmbiguousTypes in 7.10 (this, by itself, is not a problem):
showFromF :: (Show a, FInv (F a) ~ a) => F a -> String
showFromF fa = undefined

-- Consider what happens when we attempt to call `showFromF` at some type b.
-- In order to check that this is valid, we have to find an a such that
--
-- > b ~ F a /\ Show a /\ FInv (F a) ~ a
--
-- Introducing an intermediate variable `x` for the result of `F a` gives us
--
-- > b ~ F a /\ Show a /\ FInv x ~ a /\ F a ~ x
--
-- Simplifying
--
-- > b ~ x /\ Show a /\ FInv x ~ a /\ F a ~ x
--
-- Set x := b
--
-- > Show a /\ FInv b ~ a /\ F a ~ b
--
-- Set a := FInv b
--
-- > Show (FInv b) /\ FInv b ~ FInv b /\ F (FInv b) ~ b
--
-- Simplifying
--
-- > Show (FInv b) /\ F (FInv b) ~ b
--
-- Indeed, we can give this definition in 7.8, but not in 7.10:
showFromF' :: (Show (FInv b), F (FInv b) ~ b) => b -> String
showFromF' = showFromF

{- [G] F (FInv b) ~ b
   [W] FInv (F alpha) ~ alpha
   [W] F alpha ~ b
-->
   [G] g1: FInv b ~ fsk1
   [G] g2: F fsk1 ~ fsk2
   [G} g3: fsk2 ~ b

   [W] F alpha ~ fmv1
   [W] FInv fmv1 ~ fmv2
   [W] fmv2 ~ alpha
   [W] fmv1 ~ b

   [D] d1: F alpha ~ fmv1
   [D] d2: FInv fmv1 ~ fmv2
   [D] d3: fmv2 ~ alpha
   [D] d4: fmv1 ~ b

--> d2 + d4: [D] FInv b ~ fmv2
       + g1: [D] fmv2 ~ b
--> d3: b ~ alpha, and we are done

-}

{-------------------------------------------------------------------------------
  In 7.10 the definition of showFromF' is not accepted, but it gets stranger.
  In 7.10 we cannot _call_ showFromF at all, even at a concrete type. Below
  we try to call it at type b ~ Int. It would need to show

  > Show (FInv Int) /\ F (FInt Int) ~ Int

  all of which should easily get resolved, but somehow don't.
-------------------------------------------------------------------------------}

type instance F    Int = Int
type instance FInv Int = Int

test :: String
test = showFromF (0 :: Int)

{-

  [WD] FInv (F alpha) ~ alpha
  [WD] F alpha ~ Int

-->
  [WD] F alpha ~ fuv0
* [WD] FInv fuv0 ~ fuv1
  [WD] fuv1 ~ alpha
  [WD] fuv0 ~ Int

-->
  [WD] F alpha ~ fuv0
  [W] FInv fuv0 ~ fuv1
*  [D] FInv Int ~ fuv1
  [WD] fuv1 ~ alpha
  [WD] fuv0 ~ Int

-->
  [WD] F alpha ~ fuv0
  [W] FInv fuv0 ~ fuv1
* [D] fuv1 ~ Int
  [WD] fuv1 ~ alpha
  [WD] fuv0 ~ Int

-->
  [WD] F alpha ~ fuv0
  [W] FInv fuv0 ~ fuv1
  [D] alpha := Int
  [WD] fuv1 ~ alpha
  [WD] fuv0 ~ Int
-}


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

module T10318 where

import Data.Kind (Type)

-- | Product of non-zero elements always non-zero.
-- Every integral domain has a field of fractions.
-- The field of fractions of any field is itself.
class (Frac (Frac a) ~ Frac a, Fractional (Frac a), IntegralDomain (Frac a))
  => IntegralDomain a where
  type Frac a :: Type
  embed :: a -> Frac a

instance IntegralDomain Integer where
  type Frac Integer = Rational
  embed = fromInteger

instance IntegralDomain Rational where
  type Frac Rational = Rational
  embed = id

g :: IntegralDomain a => a -> a
g x = g x

h :: a -> Frac a
h x = h x

-- This is the test function

f :: IntegralDomain a => a -> Frac a
f x = g (h (h x))
  -- Given: IntegralDomain (Frac a)
  -- Wanted: IntegralDomain (Frac (Frac a))


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

module T10340 where

import GHC.Exts (Any)

class MonadState s m where
  get :: m s

newtype State s a = State (s -> (s, a))

instance MonadState s (State s) where
  get = State $ \s -> (s, s)

foo :: State Any Any
foo = get


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module T10507 where

import Data.Type.Equality ( (:~:)(Refl) )
import Prelude (Maybe(..), undefined)
import GHC.TypeLits ( Nat, type (<=))

data V (n::Nat)

testEq :: (m <= n) => V m -> V n -> Maybe (m :~: n)
testEq = undefined

uext :: (1 <= m, m <= n) => V m -> V n -> V n
uext e w =
  case testEq e w of
    Just Refl -> e


{-# LANGUAGE TypeFamilies #-}
module T10634 where

import Data.Int (Int8, Int16, Int32)

type family Up a
type instance Up Int8  = Int16
type instance Up Int16 = Int32

class (Up (Down a) ~ a) => Convert a where
   type Down a
   down :: a -> Down a

instance Convert Int16 where
   type Down Int16 = Int8
   down = fromIntegral

instance Convert Int32 where
   type Down Int32 = Int16
   down = fromIntegral

x :: Int8
x = down 8

{- From x = down 8

[WD] Num alpha
[WD] Convert alpha
[WD] Down alpha ~ Int8

--> superclasses
[D] Up (Down alpha) ~ alpha

--> substitute (Down alpha ~ Int8)
[D] Up Int8 ~ alpha

--> alpha := Int16
-}


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

module T10713 where

import Data.Proxy

type family TEq t s where
  TEq t t = 'True
  TEq t s = 'False
data family T a

foo :: Proxy (TEq (T Int) (T Bool)) -> Proxy 'False
foo = id


{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-missing-methods #-}
module T10753 where

import Data.Kind (Type)

class MonadState s m | m -> s where
  get :: m s

newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
instance (Monad m) => Monad (StateT s m) where
instance (Functor m, Monad m) => Applicative (StateT s m) where
instance (Functor m) => Functor (StateT s m) where

instance (Monad m) => MonadState s (StateT s m) where

class HasConns (m :: Type -> Type) where
    type Conn m

foo :: (Monad m) => StateT (Conn m) m ()
foo =
    do _ <- get
       return ()


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

module T10806 where

import GHC.TypeLits (Nat, type (<=))

data Q a where
    Q :: (a <= b, b <= c) => proxy a -> proxy b -> Q c

triggersLoop :: Q b -> Q b -> Bool
triggersLoop (Q _ _) (Q _ _) = print 'x' 'y'


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

module T10815 where

import Data.Proxy

type family Any :: k

class kproxy ~ 'KProxy => C (kproxy :: KProxy k) where
  type F (a :: k)
  type G a :: k

instance C ('KProxy :: KProxy Bool) where
  type F a = Int
  type G a = Any


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}

{-# OPTIONS_GHC -Wall #-}

module T10931 ( BugC(..) ) where

import Data.Kind (Type)

data IdT f a = IdC (f a)

class ( m ~ Outer m (Inner m) ) => BugC (m :: Type -> Type) where
    type Inner m :: Type -> Type
    type Outer m :: (Type -> Type) -> Type -> Type

    bug :: ( forall n. ( n ~ Outer n (Inner n)
                       , Outer n ~ Outer m
                       )
            => Inner n a)
        -> m a

instance BugC (IdT m) where
    type Inner (IdT m) = m
    type Outer (IdT m) = IdT

    bug f = IdC f


{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}

module T11067 where

import Data.Monoid
import GHC.Exts (Constraint)

type family Skolem (p :: k -> Constraint) :: k
type family SkolemF (p :: k2 -> Constraint) (f :: k1 -> k2) :: k1

-- | A quantified constraint
type Forall (p :: k -> Constraint) = p (Skolem p)
type ForallF (p :: k2 -> Constraint) (f :: k1 -> k2) = p (f (SkolemF p f))

-- These work
class ForallF Monoid t => Monoid1 t
instance ForallF Monoid t => Monoid1 t

class ForallF Monoid1 t => Monoid2 t
instance ForallF Monoid1 t => Monoid2 t
-- In both declarations (Forall Monoid1 t) expands to
-- (Monoid1 (t (SkolemF Monoid1 t))), which is simplifiable

-- Changing f a ~ g a to, (Ord (f a), Ord (g a)), say, removes the error
class (f a ~ g a) => H f g a
instance (f a ~ g a) => H f g a

-- This one gives a superclass cycle error.
class Forall (H f g) => H1 f g
instance Forall (H f g) => H1 f g
-- In both declarations (Forall (H f g)) expands to
-- H f g (Skolem (H f g)), which is simplifiable


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

module T11187 where
import Data.Type.Coercion

type family X

coercionXX :: Coercion X X
coercionXX = Coercion

coercionXX1 :: Coercion X X
coercionXX1 = c where
  c :: x ~ X => Coercion x x
  c = Coercion

coercionXX2 :: Coercion X X
coercionXX2 = c where c = Coercion


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
  -- this is needed because |FamHelper a x| /< |Fam a x|
  -- This file compiled with -dunique-increment=-1 made GHC crash before

module T11361 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, PolyKinds #-}

module T11361a where

class C a where
  type F (a :: k) :: *
  type F (x :: *) = x    -- Not right!


{-# LANGUAGE TypeFamilies #-}
module T11408 where

type family UL a
type family UR a
type family MT a b

mkMerge :: a -> UL a -> UR a -> Int
mkMerge = undefined

merger :: a -> b -> MT a b
merger = undefined

{-
merge ::
 forall a b. (UL (MT a b) ~ a, UR (MT a b) ~ b) => a -> b -> Int
or
 forall t. (MT (UL t) (UR t) ~ t) => UL t -> UR t -> Int

These types are equivalent, and in fact neither is ambiguous,
but the solver has to work quite hard to prove that.
-}
merge x y = mkMerge (merger x y) x y


{-# LANGUAGE TypeFamilies #-}

module T11581 where

import Data.Kind (Type)

type family F a :: Type -> Type
type family G a

type instance G [a] = F a (Int,Bool)


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

module T12175 where

import GHC.Exts

class Foo a
instance Foo a => Foo (a,b)

type family TElt r :: Constraint
type instance TElt r = (Foo r, ())
-- type TElt r = (Foo r, Eq r)

data CT r = CT [r]

toCT :: Foo r => CT r -> CT r
toCT = undefined

foo :: CT (a,b) -> (CT a, CT b)
foo = undefined

unzipT :: TElt (a,b) => CT (a,b) -> (CT a, CT b)
unzipT x = foo (toCT x)

{-  Type checking for unzipT

[G] TElt (a,b)
    --> {by rewrite}                 (Foo (a,b), ())
    --> {by superclasses of tuple}   Foo (a,b), ()

toCT @(a,b)
    --> [W] Foo (a,b)
    --> {by instance decl}  Foo a    (insoluble)
 -}


{-# language DataKinds, PolyKinds, GADTs, TypeFamilies, RankNTypes,
             TypeOperators, ConstraintKinds #-}

module T12369 where

import Data.Kind

data family Fix :: (k -> Type) -> k
newtype instance Fix f = In { out :: f (Fix f) }

type FREE k = (k -> Constraint) -> (k -> k)
type f  ~> g = forall a. f a -> g a
type f ~~> g = forall a b. f a b -> g a b

data    family   Free k :: FREE k

newtype instance Free Type k p where
  Free0 :: (forall q. k q => (p  -> q) -> q) -> Free Type k p

newtype instance Free (j -> Type) k p a where
  Free1 :: (forall q. k q => (p  ~> q) -> q a) -> Free (j -> Type) k p a

newtype instance Free (j1 -> j2 -> Type) k p a b where
  Free2 :: (forall q. k q => (p ~~> q) -> q a b) -> Free (j1 -> j2 -> Type) k p a b

data family Free2 :: FREE k

newtype instance Free2 :: FREE Type where
  Free20 :: (forall q. k q => (p  -> q) -> q) -> Free2 k p

newtype instance Free2 :: forall k. FREE (k -> Type) where
  Free21 :: (forall q. k q => (p  ~> q) -> q a) -> Free2 k p a

newtype instance Free2 :: forall k1 k2. FREE (k1 -> k2 -> Type) where
  Free22 :: (forall q. k q => (p ~~> q) -> q a b) -> Free2 k p a b


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

module T12444a where

type family F a :: *
type instance F (Maybe x) = Maybe (F x)

foo :: a -> Maybe (F a)
foo = undefined

-- bad :: (F (Maybe t) ~ t) => Maybe t -> [Maybe t]
bad x = [x, foo x]


{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module T12522 where

foo = f (Just 'c')

data D1 x
data D2

type family TF x = t | t -> x
type instance TF (D1 x, a) = Maybe (TF (x, a))
type instance TF (D2, ()) = Char

f :: TF (x, a) -> ()
f _ = ()

foo1 = f_good (Just 'c')
foo2 = f_bad (Just 'c')

type family TF2 x y = t | t -> x y
type instance TF2 Int Float = Char

type family TF_Good x y = t | t -> x y
type instance TF_Good a (Maybe x) = Maybe (TF2 a x)

f_good :: TF_Good a x -> ()
f_good _ = ()

type family TF_Bad x y = t | t -> x y
type instance TF_Bad (Maybe x) a = Maybe (TF2 a x)

f_bad :: TF_Bad x a -> ()
f_bad _ = ()

{-

Maybe Char ~ TF (xx, aa)

Model [D] s_aF4 ~ Maybe Char

       [W] TF (x_aDY, a_aJn) ~ s_aF4    FunEq
--> {aJn = aJp)
       [W} TF (x_aDY, a_aJp) ~ s_aF4    FunEq
--> {new derived equalities}
       [D] x_aDY ~ D1 x_aJq
       [D] a_aJp ~ a_aJR
-}


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}

module T12522b where

import Data.Kind (Type)

newtype I a = I a

type family Curry (as :: [Type]) b = f | f -> as b where
    Curry '[] b = I b
    Curry (a:as) b = a -> Curry as b

data Uncurried (as :: [Type]) b

def :: Curry as b -> Uncurried as b
def = undefined

-- test2 :: Uncurried [Bool, Bool] Bool
test2 = def $ \a b -> I $ a && b


{-# LANGUAGE TypeFamilies, MonoLocalBinds #-}
module T12526 where

import Data.Kind (Type)

type family P (s :: Type -> Type) :: Type -> Type -> Type
type instance P Signal = Causal

type family S (p :: Type -> Type -> Type) :: Type -> Type
type instance S Causal = Signal

class (P (S p) ~ p) => CP p
instance CP Causal

data Signal a = Signal
data Causal a b = Causal

shapeModOsci :: CP p => p Float Float
shapeModOsci = undefined

f :: Causal Float Float -> Bool
f = undefined

-- This fails
ping :: Bool
ping = let osci = shapeModOsci in  f osci

-- This works
-- ping :: Bool
-- ping = f shapeModOsci

{-

    osci :: p Float Float
    [W] CP p, [D] P (S p) ~ p
-->
    [W] CP p, [D] P fuv1 ~ fuv2, S p ~ fuv1, fuv2 ~ p
-->
    p := fuv2
    [W] CP fuv2, [D] P fuv1 ~ fuv2, S fuv2 ~ fuv1

-}

-- P (S p) ~ p
-- p Float Float ~ Causal Float Float

{-
  P (S p) ~ p
  p Float Float ~ Causal Float Float

--->
  S p ~ fuv1    (FunEq)
  P fuv1 ~ fuv2 (FunEq)
  fuv2 ~ p
  p F F ~ Causal F F

--->
  p := fuv2

  fuv2 ~ Causal
  S fuv2 ~ fuv1 (FunEq)
  P fuv1 ~ fuv2 (FunEq)

---> unflatten
  fuv1 := S fuv2
  fuv2 := Causal

-}


{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module T12538 where

data Tagged t a = Tagged a

type family Tag a where
  Tag (Tagged t a) = Tagged t a
  Tag a = Tagged Int a

class (r ~ Tag a) => TagImpl a r | a -> r where
  tag :: a -> r

instance {-# OVERLAPPING #-} (r ~ Tag (Tagged t a)) => TagImpl (Tagged t a) r where
  tag = id

#ifdef WRONG
instance {-# OVERLAPPING #-} (r ~ Tagged t a, r ~ Tag a) => TagImpl a r where
#else
instance {-# OVERLAPPING #-} (r ~ Tagged Int a, r ~ Tag a) => TagImpl a r where
#endif
  tag = Tagged @Int

data family   DF x
data instance DF (Tagged t a) = DF (Tagged t a)

class ToDF a b | a -> b where
  df :: a -> b

instance (TagImpl a a', b ~ DF a') => ToDF a b where
  df = DF . tag

main :: IO ()
main = pure ()


{-# LANGUAGE RankNTypes, TypeFamilies #-}

module T12676 where

data family T a
data instance T () = MkT

foo :: (forall s. T ()) -> ()
foo MkT = ()


{-# LANGUAGE PolyKinds, TypeFamilies #-}

module Bug where

import GHC.Exts

class HasRep a where
  type Rep a :: TYPE r


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

module T13244 where

import Data.Int
import Data.Word
import GHC.Prim
import GHC.Types

type family Rep x where
  Rep Int    = IntRep
  Rep Int8   = IntRep
  Rep Int16  = IntRep
  Rep Int32  = IntRep
  Rep Int64  = Int64Rep
  Rep Bool   = IntRep
  Rep Char   = IntRep
  Rep Word   = WordRep
  Rep Word8  = WordRep
  Rep Word16 = WordRep
  Rep Word32 = WordRep
  Rep Word64 = Word64Rep
  Rep Float  = FloatRep
  Rep Double = DoubleRep

class Unbox x where
  type Unboxed x :: TYPE (Rep x)
  unbox :: x -> Unboxed x
  box :: Unboxed x -> x

instance Unbox Int where
  type Unboxed Int = Int#
  unbox (I# i) = i
  box = I#


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T13398a where

data Nat
data Rate
data StaticTicks where
        (:/:) :: Nat -> Rate -> StaticTicks
type ticks :/ rate = ticks ':/: rate

class HasStaticDuration (s :: k) where
  type SetStaticDuration s (pt :: StaticTicks) :: k

instance HasStaticDuration (t :/ r) where
  type SetStaticDuration (t :/ r) (t' :/ r') = t' :/ r'


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
module T13398b where

import GHC.TypeLits

class C a where
  type T a (b :: Bool) :: a

instance C Nat where
  type T Nat 'True  = 1
  type T Nat 'False = 0


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module T13662 (run) where

import Data.Kind (Type)

newtype Value a = Value a

type family Repr (f :: Type -> Type) a :: Type
type instance Repr f Int = f Int

class (Repr Value i ~ Value ir) => Native i ir where

instance Native Int Int where

fromInt :: (Native i ir) => i -> a
fromInt = undefined

apply :: (Int -> a -> a) -> a -> a
apply weight = id

run :: Float -> Float
run =
   let weight = \clip v -> fromInt clip * v
   in  apply weight


{-# LANGUAGE TypeFamilyDependencies #-}

module T13705 where

data D x

type family F t = s | s -> t
type instance F (D t) = D (F t)

f :: F s -> ()
f _ = ()

g :: D (F t) -> ()
g x = f x


{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeInType #-}
module T13777 where

import Data.Kind
import Data.Proxy

data S :: forall k. Proxy k -> Type where
  MkS :: S ('Proxy :: Proxy Maybe)

data T (a :: b) :: forall c (d :: Type) e.
                   (forall f. Proxy f) -> Proxy c -> Proxy d -> Proxy e
                -> Type where

  -- NB: This was originally a failing test, but now that we have #15273, it works!


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

module T14045 where

import Data.Kind

data family Sing (a :: k)
data instance Sing :: Bool -> Type where
  SFalse :: Sing False
  STrue  :: Sing True


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module T14131 where

import Data.Kind
import Data.Proxy

data family Nat :: k -> k -> Type
newtype instance Nat :: (k -> Type) -> (k -> Type) -> Type where
  Nat :: (forall xx. f xx -> g xx) -> Nat f g

type family   F :: Maybe a
type instance F = (Nothing :: Maybe a)

class C k where
  data CD :: k -> k -> Type
  type CT :: k

instance C (Maybe a) where
  data CD :: Maybe a -> Maybe a -> Type where
    CD :: forall a (m :: Maybe a) (n :: Maybe a). Proxy m -> Proxy n -> CD m n
  type CT = (Nothing :: Maybe a)

class Z k where
  type ZT :: Maybe k
  type ZT = (Nothing :: Maybe k)


{-# Language TypeOperators, KindSignatures, DataKinds, PolyKinds,
             TypeFamilies, GADTs #-}

module T14162 where

import Data.Kind

data SubList (a :: Maybe w) :: Type where
  SubNil :: SubList 'Nothing

data family Sing (a :: k)

data instance Sing (x :: SubList ys) where
  SSubNil :: Sing SubNil

{-
SubList :: forall (w::*). Maybe w -> *
SubNil  :: forall (w::*). SubList w (Nothing w)

wrkSubNil :: forall (w::*) (a :: Maybe w).
             (a ~ Nothing w) =>
             SubList w a

Sing :: forall k. k -> *

RepTc :: forall (w_aSy : *)
                (ys_aRW :: Maybe w_aSy)
                (x_aRX :: SubList w_aSy ys_aRW).
                *

axiom forall (w : *) (ys : Maybe w) (x : SubList ys).
   Sing (SubList ys) (x : SubList ys) ~ RepTc w ys x

data RepTc w ys x where
  SSubNil :: RepTc w (Nothing w) (SubNil w)

SSubNil :: forall (w :: *). Sing (SubList w (Nothing w)) (SubNil w)

wrkSSubMil :: forall (w : *) (ys : Maybe w) (x : Sublist w ys).
              () =>
              RepTc w ys x
-}


{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
module T14164 where

data G (x :: a) = GNil | GCons (G x)

type family F (xs :: [a]) (g :: G (z :: a)) = (res :: [a]) | res -> a where
  F (x:xs) GNil         = x:xs
  F (x:xs) (GCons rest) = x:F xs rest


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

module T14237 where

f :: (Integer ~ a) => a -> Integer
f = (+ 1)


{-# Language UndecidableInstances, DataKinds, TypeOperators, TypeFamilies,
             PolyKinds, GADTs, LambdaCase, ScopedTypeVariables #-}

module T14554 where

import Data.Kind
import Data.Proxy

type a ~> b = (a, b) -> Type

data IdSym0 :: (Type,Type) -> Type

data KIND = X | FNARR KIND KIND

data TY :: KIND -> Type where
  ID    :: TY (FNARR X X)
  FNAPP :: TY (FNARR k k') -> TY k -> TY k'

data TyRep (kind::KIND) :: TY kind -> Type where
  TID    :: TyRep (FNARR X X)  ID
  TFnApp :: TyRep (FNARR k k') f
         -> TyRep k            a
         -> TyRep k'           (FNAPP f a)

type family IK (kind::KIND) :: Type where
  IK X            = Type
  IK (FNARR k k') = IK k ~> IK k'

type family IT (ty::TY kind) :: IK kind

zero :: TyRep X a -> IT a
zero x = case x of
            TFnApp TID a -> undefined


{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -O1 #-}
module T14680 where

import GHC.Base (getTag)
import GHC.Exts (Int(..), tagToEnum#)

data family TyFamilyEnum
data instance TyFamilyEnum = TyFamilyEnum1 | TyFamilyEnum2 | TyFamilyEnum3

suc :: TyFamilyEnum -> TyFamilyEnum
suc a_aaf8
        = case getTag a_aaf8 of
             a_aaf9
               -> if 2 ==  I# a_aaf9
                  then error "succ{TyFamilyEnum}: tried to take `succ' of last tag in enumeration"
                  else case I# a_aaf9 + 1 of
                         I# i_aafa -> tagToEnum# i_aafa :: TyFamilyEnum


{-# LANGUAGE LiberalTypeSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
module T15057 where

type T f = f Int
type S a = a -> a

type family TF a
type instance TF Int = T S
  -- Ensure that -dcore-lint doesn't trip up on this unsaturated use
  -- of the type synonym S


{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
module T15122 where

import Data.Kind
import Data.Proxy

data IsStar (a :: k) where
  IsStar :: IsStar (a :: Type)

type family F (a :: k) :: k

foo :: (F a ~ F b) => IsStar a -> Proxy b
                   -> Proxy (F a) -> Proxy (F b)
foo IsStar _ p = p


{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}

module T15142 where

import Data.Kind

class ListTuple (tuple :: Type) (as :: [(k, Type)]) where
  type ListToTuple as :: Type

class C (a :: Type) (b :: k) where
  type T b


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module T15144 where

import Data.Coerce
import Data.Proxy

type family F x

f :: Coercible (F a) b => Proxy a -> F a -> b
f _ = coerce

-- In #15144, we inferred the less-general type
-- g :: Proxy a -> F a -> F a
g p x = f p x

h :: Coercible (F a) b => Proxy a -> F a -> b
h p x = g p x


{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module T15138 where

data family Sn a
newtype instance Sn (Either a b) where
  SnC :: forall b a. Char -> Sn (Either a b)


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

module T15322 where

import Data.Proxy (Proxy (..))
import Type.Reflection
import GHC.TypeLits (KnownNat, type (+))

f :: forall n . (Typeable (n+1), KnownNat n) => Proxy n -> TypeRep (n+1)
f _ = typeRep


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

module T15322a where

import Data.Proxy (Proxy (..))
import Type.Reflection
import GHC.TypeLits (KnownNat, type (+))

f :: forall n . (KnownNat n) => Proxy n -> TypeRep (n+1)
f _ = typeRep


{-# LANGUAGE TypeInType #-} -- or PolyKinds
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

module T15352 where

import Data.Kind

class C (x :: Type) (y :: k) where
  type F y

type Hom k = k -> k -> Type

type family Ob (p :: Hom k) :: k -> Constraint

class ( obP ~ Ob p
      , opP ~ Dom p
      , obQ ~ Ob q
      , opQ ~ Dom q
      , p ~ Dom f
      , q ~ Cod f
      ) => Functor' (obP :: i -> Constraint)
                    (opP :: Hom i)
                    (p :: Hom i)
                    (obQ :: j -> Constraint)
                    (opQ :: Hom j)
                    (q :: Hom j)
                    (f :: i -> j) where
  type Dom f :: Hom i
  type Cod f :: Hom j


{-# Language RankNTypes, TypeOperators, DataKinds, PolyKinds, GADTs, TypeInType, TypeFamilies #-}

module T15664 where

import Data.Kind

type family Apply (kind) (f :: kind) :: Type
data        ApplyT(kind) :: kind -> Type

type f ~> g = (forall xx. f xx -> g xx)

unravel :: ApplyT(k) ~> Apply(k)
unravel = unravel


{-# LANGUAGE TypeFamilies, PolyKinds #-}

module T15704 where

import Data.Kind

data family D :: k

type family F (a :: k) :: Type

type instance F D = Int
type instance F (D a) = Char


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

module Bug where

class C a where
  type F (x :: Maybe a)


{-# LANGUAGE TypeInType, RankNTypes, TypeFamilies #-}

module T15740a where

import Data.Kind
import Data.Proxy

type family F2 :: forall k. k -> Type

-- This should succeed
type instance F2 = Proxy


{-# Language PolyKinds #-}
{-# Language TypeFamilies #-}
{-# Language KindSignatures #-}
{-# Language DataKinds #-}
{-# Language MultiParamTypeClasses #-}

module T15764a where

import Data.Kind
import Data.Proxy
import GHC.TypeLits

class C6 (k :: Type) (a :: k) (b :: Proxy (a :: k)) where
 type T6 (proxy :: Proxy '(k, (b :: Proxy a)))


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
module T15852 where

import Data.Kind
import Data.Proxy

data family DF a (b :: k)
data instance DF (Proxy c) :: Proxy j -> Type


{-# Language RankNTypes             #-}
{-# Language DataKinds              #-}
{-# Language KindSignatures         #-}
{-# Language PolyKinds              #-}
{-# Language TypeFamilyDependencies #-}
{-# Language GADTs                  #-}
{-# Language TypeSynonymInstances   #-}
{-# Language FlexibleInstances      #-}
{-# Language QuantifiedConstraints  #-}

module T15943 where

import Data.Type.Equality
import Data.Coerce
import Data.Type.Coercion
import Data.Kind

newtype WrapFalse a b = WrapFalse (Hom False a b)
newtype WrapTrue  a b = WrapTrue  (Hom True  a b)

class
  (forall (x :: ob) (y :: ob). Coercible (WrapFalse x y) (WrapTrue y x))
  =>
  RÃki ob where

  type Hom (or::Bool) = (res :: ob -> ob -> Type) | res -> or

instance RÃki Type where
  type Hom False = (->)
  type Hom True  = Op

newtype Op :: Type -> Type -> Type where
  Op :: (b -> a) -> Op a b


{-# LANGUAGE TypeFamilies, StandaloneDeriving, DeriveDataTypeable, FlexibleInstances #-}

module T1769 where

import Data.Typeable

data family T a
deriving instance Typeable T
-- deriving instance Functor T

data instance T [b] = T1 | T2 b
deriving instance Eq b => Eq (T [b])


{-# OPTIONS_GHC -XTypeFamilies #-}

module ShouldCompile where

type family T a

f :: a -> T a -> Int
f p x = x `seq` 3


{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}

module T2102 where

type family Cat ts0 ts
type instance Cat ()      ts' = ts'
type instance Cat (s, ts) ts' = (s, Cat ts ts')

class (Cat ts () ~ ts) => Valid ts
instance Valid () -- compiles OK
instance Valid ts => Valid (s, ts) -- fails to compile

-- need to prove Cat (s, ts) () ~ (s, Cat ts ())
-- for the superclass of class Valid.
-- (1) From Valid ts: Cat ts () ~ ts
-- (2) Therefore:     (s, Cat ts ()) ~ (s, ts)

coerce :: forall f ts. Valid ts => f (Cat ts ()) -> f ts
coerce x = x


{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}

module T2203b where

class Foo a where
   type TheFoo a
   foo :: TheFoo a -> a
   foo' :: a -> Int

class Bar b where
   bar :: b -> Int

instance (b ~ TheFoo a, Foo a) => Bar (Either a b) where
   bar (Left a) = foo' a
   bar (Right b) = foo' (foo b :: a)

instance Foo Int where
   type TheFoo Int = Int
   foo = id
   foo' = id

val :: Either Int Int
val = Left 5

res :: Int
res = bar val


{-# LANGUAGE TypeFamilies, GADTs, EmptyDataDecls, TypeOperators #-}

module Test where

import Data.Kind (Type)

data Zero
data Succ a

data FZ
data FS fn

data Fin n fn where
  FZ :: Fin (Succ n) FZ
  FS :: Fin n fn -> Fin (Succ n) (FS fn)

data Nil
data a ::: b

type family Lookup ts fn :: Type
type instance Lookup (t ::: ts) FZ = t
type instance Lookup (t ::: ts) (FS fn) = Lookup ts fn

data Tuple n ts where
  Nil   :: Tuple Zero Nil
  (:::) :: t -> Tuple n ts -> Tuple (Succ n) (t ::: ts)

proj :: Fin n fn -> Tuple n ts -> Lookup ts fn
proj FZ      (v ::: _)  = v
proj (FS fn) (_ ::: vs) = proj fn vs


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- Trac #2238
-- Notice that class CTF has just one value field, but
-- it also has an equality predicate.
-- See Note [Class newtypes and equality predicates] in BuildTyCl

module Foo where

data A
data B

-- via functional dependencies

class HowFD a how | a -> how

class HowFD a how => CFD a how where
  cfd :: a -> String
  cfd _ = "cfd"
instance HowFD a how => CFD a how

instance HowFD Bool A

-- via type families

type family HowTF a

class how ~ HowTF a => CTF a how where
  ctf :: a -> String
  ctf _ = "ctf"

instance how ~ HowTF a => CTF a how

type instance HowTF Bool = A


{-# LANGUAGE TypeFamilies #-}
module Small where

import Data.Kind (Type)

class CoCCC k where
        type Coexp k :: Type -> Type -> Type
        type Sum k :: Type -> Type -> Type
        coapply' :: k b (Sum k (Coexp k a b) a)
        cocurry' :: k c (Sum k a b) -> k (Coexp k b c) a
        uncocurry' :: k (Coexp k b c) a -> k c (Sum k a b)

coapply   :: CoCCC k => k b (Sum k (Coexp k a b) a)
{-# INLINE [1] coapply #-}
coapply = coapply'

cocurry   :: CoCCC k => k c (Sum k a b) -> k (Coexp k b c) a
{-# INLINE [1] cocurry #-}
cocurry = cocurry'

uncocurry :: CoCCC k => k (Coexp k b c) a -> k c (Sum k a b)
{-# INLINE [1] uncocurry #-}
uncocurry = uncocurry'

{-# RULES
"cocurry coapply"               cocurry coapply = id
"cocurry . uncocurry"           forall x. cocurry (uncocurry x) = x
"uncocurry . cocurry"           forall x. uncocurry (cocurry x) = x
 #-}


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

module T2448 where

import Data.Kind (Type)

-- Demonstrates a bug in propagating type equality constraints

class VectorSpace v where
  type Scalar v :: Type

class VectorSpace v => InnerSpace v

instance (VectorSpace u,VectorSpace v, Scalar u ~ Scalar v) =>
  VectorSpace (u,v)
  where
  type Scalar (u,v) = Scalar u

instance (InnerSpace u,InnerSpace v, Scalar u ~ Scalar v) => InnerSpace (u,v)


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

module T2627 where

data R a b
data W a b
data Z

type family Dual a
type instance Dual Z = Z
type instance Dual (R a b) = W a (Dual b)
type instance Dual (W a b) = R a (Dual b)

data Comm a where
    Rd :: (a -> Comm b) -> Comm (R a b)
    Wr :: a  -> Comm b  -> Comm (W a b)
    Fin :: Int -> Comm Z

conn :: (Dual a ~ b, Dual b ~ a) => Comm a -> Comm b -> (Int, Int)
conn (Fin x) (Fin y) = (x,y)
conn (Rd k) (Wr a r) = conn (k a) r
conn (Wr a r) (Rd k) = conn r (k a)


{-# LANGUAGE TypeFamilies, EmptyDataDecls #-}

module T2639 where

data Eps

data family Work a v
data instance Work Eps v = Eps v

type family Dual a
type instance Dual Eps = Eps

class Connect s where
    connect :: (Dual s ~ c, Dual c ~ s) => Work s a -> Work c b -> (a,b)

instance Connect Eps where
    connect (Eps a) (Eps b) = (a,b)


{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
    -- The type of 'empty' is indeed ambiguous

module T2715 where

import Data.Kind (Type)

data Interval v where
   Intv :: (Ord v, Enum v) => (v,v) -> Interval v

type family Domain (d :: Type -> Type) :: Type -> Type
type instance Domain Interval = Interval

type family Value (d :: Type -> Type) :: Type

class IDomain d where
   empty   :: (Ord (Value d), Enum (Value d)) => Domain d (Value d)

class (IDomain d1) -- (IDomain d1, IDomain d2, Value d1 ~ Value d2)
   => IIDomain (d1 :: Type -> Type) (d2 :: Type -> Type ) where
   equals  :: Domain d1 (Value d1) -> Domain d2 (Value d2) -> Bool

instance Ord (Value Interval)
      => IDomain Interval where
   empty = Intv (toEnum 1, toEnum 0)

instance Ord (Value Interval)
      => IIDomain Interval Interval where
   equals  (Intv ix) (Intv iy) = ix == iy


{-# LANGUAGE TypeFamilies, NoMonomorphismRestriction #-}

module T2767a where

import Data.Kind (Type)

main = return ()

-- eval' :: Solver solver => Tree solver a -> [(Label solver,Tree solver a)] -> solver [a]
eval' (NewVar f) wl = do v <- newvarSM
                         eval' (f v) wl
eval' Fail       wl = continue wl

-- continue :: Solver solver => [(Label solver,Tree solver a)] -> solver [a]
continue ((past,t):wl) = do gotoSM past
                            eval' t wl
data Tree s a
                = Fail
                | NewVar (Term s -> Tree s a)

class Monad solver => Solver solver where
        type Term solver        :: Type
        type Label solver       :: Type
        newvarSM        :: solver (Term solver)
        gotoSM          :: Label solver -> solver ()


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

module T2850 where

import Data.Kind (Type)

class K a where
  bar :: a -> a

class K (B a) => M a where
  data B a :: Type
  foo :: B a -> B a

instance M Bool where
  data B Bool = B1Bool Bool | B2Bool Bool
  foo = id

instance K (B Bool) where
  bar = id

-- The 'deriving K' gives the (K (B Int)) instance
-- needed for the superclasses of M
instance M Int where
  newtype B Int = BInt (B Bool) deriving K
  foo = id


{-# LANGUAGE TypeFamilies #-}
-- Test Trac #2944

module T2944 where

import Data.Kind (Type)

type family T a :: Type

f1 :: T a ~ () => a
f1 = f2

f2 :: T a ~ () => a
f2 = f1


{-# LANGUAGE TypeFamilies #-}

-- Trac #3017

module Foo where
 class Coll c where
   type Elem c
   empty :: c
   insert :: Elem c -> c -> c

 data ListColl a = L [a]
 instance Coll (ListColl a) where
   type Elem (ListColl a) = a
   empty = L []
   insert x (L xs) = L (x:xs)

 emptyL :: ListColl a
 emptyL = empty

 test2 c = insert (0, 0) c


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# OPTIONS_GHC -fwarn-missing-signatures #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}

module Bug where

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

instance C Int Bool where
    f = undefined
instance (C a c, C b d) => C (a -> b) (c -> d) where
    f = undefined

foo :: Int -> Int
foo = undefined

bar = f foo


{-# LANGUAGE TypeFamilies #-}

module T3208a where

class SUBST s where
    type STerm s

class OBJECT o where
    type OTerm o
    apply :: (SUBST s, OTerm o ~ STerm s) => s -> o

fce' f = fce . apply $ f

fce f = fce' f


{-# LANGUAGE TypeFamilies #-}

-- This should fail

module T3208b where

class SUBST s where
    type STerm s

class OBJECT o where
    type OTerm o
    apply :: (SUBST a, OTerm o ~ STerm a) => a -> o

fce' :: (OTerm a ~ STerm a, OBJECT a, SUBST a) => a -> c
fce' f = fce (apply f)
-- f :: a
-- apply f :: (SUBST a, OBJECT o, OTerm o ~ STerm a) => o
-- fce called with a=o, gives wanted (OTerm o ~ STerm o, OBJECT o, SUBST o)
-- o is a unif var.

fce :: (OTerm o ~ STerm o, OBJECT o, SUBST o) => o -> c
fce f = fce' f

{-  (OTerm a ~ STerm a, OBJECT a, SUBST a)
 => (SUBST a, OBJECT o, OTerm o ~ STerm a, OTerm o ~ STerm o, OBJECT o, SUBST o)

 =     OTerm o ~ u1
       STerm o ~ u1
       Sterm a ~ u1

 =  (SUBST a, OBJECT o, STerm o ~ STerm a, OTerm o ~ STerm o, OBJECT o, SUBST o)
-}