-- From a blog post: http://www.jonmsterling.com/posts/2012-01-12-unifying-monoids-and-monads-with-polymorphic-kinds.html

{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE TypeFamilies #-}

module Main where

import Data.Kind
import Control.Monad (Monad(..), join, ap, liftM)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))

-- First we define the type class Monoidy:

class Monoidy (to :: k0 -> k1 -> Type) (m :: k1)  where
  type MComp to m :: k1 -> k1 -> k0
  type MId   to m :: k0
  munit :: MId to m `to` m
  mjoin :: MComp to m m m `to` m

-- We use functional dependencies to help the typechecker understand that
-- m and ~> uniquely determine comp (times) and id.

-- This kind of type class would not have been possible in previous
-- versions of GHC; with the new kind system, however, we can abstract
-- over kinds!2 Now, letâ€™s create types for the additive and
-- multiplicative monoids over the natural numbers:

newtype Sum a = Sum a deriving Show
newtype Product a = Product a deriving Show
instance Num a â‡’ Monoidy (â†’) (Sum a) where
  type MComp (â†’) (Sum a) = (,)
  type MId   (â†’) (Sum a) = ()
  munit _ = Sum 0
  mjoin (Sum x, Sum y) = Sum $ x + y

instance Num a â‡’ Monoidy (â†’) (Product a) where
  type MComp (â†’) (Product a) = (,)
  type MId   (â†’) (Product a) = ()
  munit _ = Product 1
  mjoin (Product x, Product y) = Product $ x * y

-- It will be slightly more complicated to make a monadic instance with
-- Monoidy. First, we need to define the identity functor, a type for
-- natural transformations, and a type for functor composition:

data Id Î± = Id { runId :: Î± } deriving Functor

-- A natural transformation (Î›â€†f g Î±.â€†(f Î±)â€„â†’â€„(g Î±)) may be encoded in Haskell as follows:

data NT f g = NT { runNT :: âˆ€ Î±. f Î± â†’ g Î± }

-- Functor composition (Î›â€†f g Î±.â€†f (g Î±)) is encoded as follows:

data FC f g Î± = FC { runFC :: f (g Î±) }

-- Now, let us define some type T which should be a monad:

data Wrapper a = Wrapper { runWrapper :: a } deriving (Show, Functor)
instance Monoidy NT Wrapper where
  type MComp NT Wrapper = FC
  type MId   NT Wrapper = Id
  munit = NT $ Wrapper . runId
  mjoin = NT $ runWrapper . runFC

-- With these defined, we can use them as follows:

test1 = do { print (mjoin (munit (), Sum 2))
                 -- Sum 2
           ; print (mjoin (Product 2, Product 3))
                 -- Product 6
           ; print (runNT mjoin $ FC $ Wrapper (Wrapper "hello, world"))
                 -- Wrapper {runWrapper = "hello, world" }
           }

-- We can even provide a special binary operator for the appropriate monoids as follows:

(<+>) :: (Monoidy (â†’) m, MId (â†’) m ~ (), MComp (â†’) m ~ (,))
       â‡’ m â†’ m â†’ m
(<+>) = curry mjoin

test2 = print (Sum 1 <+> Sum 2 <+> Sum 4)  -- Sum 7

-- Now, all the extra wrapping that Haskell requires for encoding this is
-- rather cumbersome in actual use. So, we can give traditional Monad and
-- Monoid instances for instances of Monoidy:

instance (MId (â†’) m ~ (), MComp (â†’) m ~ (,), Monoidy (â†’) m)
       â‡’ Semigroup m where
  (<>) = curry mjoin

instance (MId (â†’) m ~ (), MComp (â†’) m ~ (,), Monoidy (â†’) m)
       â‡’ Monoid m where
  mempty = munit ()

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

instance Monad Wrapper where
  return x = runNT munit $ Id x
  x >>= f = runNT mjoin $ FC (f `fmap` x)

-- And so the following works:

test3
 = do { print (mappend mempty (Sum 2))
             -- Sum 2
      ; print (mappend (Product 2) (Product 3))
             -- Product 6
      ; print (join $ Wrapper $ Wrapper "hello")
             -- Wrapper {runWrapper = "hello" }
      ; print (Wrapper "hello, world" >>= return)
             -- Wrapper {runWrapper = "hello, world" }
      }

main = test1 >> test2 >> test3


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

module PolyInstances where

import Data.Kind
import Data.Proxy

class C (a :: k)

instance (C a, C b) => C (a b)

data Dict :: Constraint -> Type

instance C Dict

foo :: C p => proxy p -> ()
foo = undefined

bar :: forall (p :: Constraint) proxy. C p => proxy p -> ()
bar _ = foo (Proxy :: Proxy (Dict p))


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

module PolyKinds01 where

import Data.Kind (Type)

data Nat = Ze | Su Nat

data Vec :: Type -> Nat -> Type where
  VNil  :: Vec a Ze
  VCons :: a -> Vec a n -> Vec a (Su n)

vec :: Vec Nat (Su Ze)
vec = VCons Ze VNil


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

module PolyKinds02 where

data Nat = Ze | Su Nat

data Vec :: * -> Nat -> * where
  VNil  :: Vec a Ze
  VCons :: a -> Vec a n -> Vec a (Su n)

vec :: Vec Nat Nat -- Kind error
vec = vec


{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE PolyKinds                  #-}

module PolyKinds03 where

data Proxy t
data TypeRep = TypeRep

class MyTypeable t where
  myTypeOf :: Proxy t -> TypeRep

instance MyTypeable Int  where myTypeOf _ = TypeRep
instance MyTypeable []   where myTypeOf _ = TypeRep


module PolyKinds04 where

data A f
data B = B1 (A Maybe)

-- Should fail. `A` is kind checked alone, and its kind is defaulted to * -> *.
-- The constructor `B1` then uses `A` with the wrong kind.


{-# LANGUAGE PolyKinds                  #-}

module PolyKinds05 where

data A f
data B = B1 (A Maybe)

-- Should work. We have -XPolyKinds on, so `A` gets the polymorphic kind
--   forall k. k -> *


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

module PolyKinds06 where

data A = A1 | A2 (B 'B1)

data B :: A -> * where
  B1 :: B 'A1


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

module PolyKinds07 where

data A = A1 | A2 (B 'B1)

data B a where
  B1 :: B 'A1

-- We correctly fail, but should probably provide a better error message


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

module PolyKinds08 where

data U a = U

instance Functor U where
  fmap f U = U

instance (Show a) => Show (U a) where
  show U = ""


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

module Main where

import Data.Kind (Type)

--------------------------------------------------------------------------------
-- Simple generic programming (instant-generics-like library)
--------------------------------------------------------------------------------
data U a = UNIT | SUM (U a) (U a) | PRODUCT (U a) (U a) | REC a

-- GADT interpretation
data I :: U Type -> Type where
  Unit          :: I UNIT
  Inl           :: I a -> I (SUM a b)
  Inr           :: I b -> I (SUM a b)
  Product       :: I a -> I b -> I (PRODUCT a b)
  Rec           :: a -> I (REC a)

-- Class embedding types and their generic representation
class Generic (a :: Type) where
  type Rep a :: U Type
  from :: a -> I (Rep a)
  to   :: I (Rep a) -> a

-- Generic size on representations
class GSize (a :: U Type) where
  gsize :: I a -> Int

instance GSize UNIT where
  gsize Unit = 0

instance (GSize a, GSize b) => GSize (SUM a b) where
  gsize (Inl x) = gsize x
  gsize (Inr x) = gsize x

instance (GSize a, GSize b) => GSize (PRODUCT a b) where
  gsize (Product a b) = gsize a + gsize b

instance (Size a) => GSize (REC a) where
  gsize (Rec x) = 1 + size x

-- Size on datatypes
class Size (a :: Type) where
  size :: a -> Int
  default size :: (Generic a, GSize (Rep a)) => a -> Int
  size = gsize . from

instance (Size a) => Size [a] -- default
instance Size Char where size _ = 1 -- adhoc

-- Example encoding: lists
instance Generic [a] where
  type Rep [a] = SUM UNIT (PRODUCT (REC a) (REC [a]))
  from []    = Inl Unit
  from (h:t) = Inr (Product (Rec h) (Rec t))
  to (Inl Unit)                      = []
  to (Inr (Product (Rec h) (Rec t))) = h:t

-- Testing size
test1 = size "abc"

main = print test1


{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE DataKinds                  #-}

module Main where

import Data.Kind

-- Type-level peano naturals (value-level too, but we don't use those)
data Nat = Ze | Su Nat

type T0 = Ze
type T1 = Su T0
type T2 = Su T1

-- (!) at the type level
type family El (n :: Nat) (l :: [Type]) :: Type
type instance El Ze     (h ': t) = h
type instance El (Su n) (h ': t) = El n t

{-
-- The following might be useful, but are not used at the moment
-- ($) at the type level (well, not quite ($), in fact...)
class Apply (fs :: [Type]) (es :: [Type]) where
  type ApplyT (fs :: [Type]) (es :: [Type]) :: [Type]
  apply :: ListV fs -> ListV es -> ListV (ApplyT fs es)

instance Apply '[] '[] where
  type ApplyT '[] '[] = '[]
  apply NilV NilV = NilV

instance (Apply fs es) => Apply ((e1 -> e2) ': fs) (e1 ': es) where
  type ApplyT ((e1 -> e2) ': fs) (e1 ': es) = e2 ': ApplyT fs es
  apply (ConsV f fs) (ConsV e es) = ConsV (f e) (apply fs es)
-}

-- Value mirror for the list kind
data ListV :: [Type] -> Type where
  NilV  :: ListV '[]
  ConsV :: a -> ListV t -> ListV (a ': t)

data ListV2 :: [[Type]] -> Type where
  NilV2  :: ListV2 '[]
  ConsV2 :: ListV a -> ListV2 t -> ListV2 (a ': t)

listv1 :: ListV (Int ': '[])
listv1 = ConsV 3 NilV

listv2 :: ListV2 ((Int ': '[]) ': '[])
listv2 = ConsV2 listv1 NilV2

--data ListVX :: Maybe -> Type where

data TripleV :: (Type, Type -> Type, Type) -> Type where
  TripleV :: a -> c -> TripleV '(a, [], c)

-- Value mirror for the Nat kind
data NatV :: Nat -> Type where
  ZeW :: NatV Ze
  SuW :: NatV n -> NatV (Su n)

-- Generic universe
data MultiP x = UNIT
              | KK x -- wish I could just write Type instead of x
              | SUM  (MultiP x) (MultiP x)
              | PROD (MultiP x) (MultiP x)
              | PAR Nat
              | REC

-- Universe interpretation
data Interprt :: MultiP Type -> [Type] -> Type -> Type where
  Unit  :: Interprt UNIT lp r
  K     :: x -> Interprt (KK x) lp r
  L     :: Interprt a lp r -> Interprt (SUM a b) lp r
  R     :: Interprt b lp r -> Interprt (SUM a b) lp r
  Prod  :: Interprt a lp r -> Interprt b lp r -> Interprt (PROD a b) lp r
  Par   :: NatV n -> El n lp -> Interprt (PAR n) lp r
  Rec   :: r -> Interprt REC lp r

-- Embedding values into the universe
class Generic a where
  type Rep a :: MultiP Type
  type Es a  :: [Type]
  from :: a -> Interprt (Rep a) (Es a) a
  to   :: Interprt (Rep a) (Es a) a -> a

-- Parameter map over the universe
class PMap (rep :: MultiP Type) where
  pmap :: (forall n. NatV n -> El n lp1 -> El n lp2)
       -> (r -> s) -> Interprt rep lp1 r -> Interprt rep lp2 s

instance PMap UNIT where
  pmap _ _ Unit = Unit

instance PMap (KK x) where
  pmap _ _ (K x) = K x

instance (PMap a, PMap b) => PMap (SUM a b) where
  pmap f g (L x) = L (pmap f g x)
  pmap f g (R x) = R (pmap f g x)

instance (PMap a, PMap b) => PMap (PROD a b) where
  pmap f g (Prod x y) = Prod (pmap f g x) (pmap f g y)

instance PMap (PAR p) where
  pmap f _ (Par n p) = Par n (f n p)

instance PMap REC where
  pmap _ g (Rec p) = Rec (g p)

-- User-facing function
pmapu :: (Generic a, Generic b, PMap (Rep a), Rep a ~ Rep b)
      => (forall n. NatV n -> El n (Es a)-> El n (Es b)) -> a -> b
pmapu f = to . pmap f (pmapu f). from

-- Example: lists
instance Generic [a] where
  type Rep [a] = SUM UNIT (PROD (PAR T0) REC)
  type Es  [a] = a ': '[]
  from [] = L Unit
  from (h:t) = R (Prod (Par ZeW h) (Rec t))
  to (L Unit) = []
  to (R (Prod (Par ZeW h) (Rec t))) = h:t

-- Map on lists: we can define an auxiliary function with the usual type...
pmapList :: forall a b. (a -> b) -> [a] -> [b]
pmapList f l = pmapu g l where
  g :: forall n. NatV n -> El n (Es [a]) -> El n (Es [b])
  g ZeW x = f x

-- ... or use pmapu directly
pmapExample1 :: [String]
pmapExample1 = pmapu f [1..10::Int] where
  f :: forall n. NatV n -> El n (Es [Int]) -> El n (Es [String])
  f ZeW = show

-- Example: Either
instance Generic (Either a b) where
  type Rep (Either a b) = SUM (PAR T0) (PAR T1)
  type Es  (Either a b) = a ': b ': '[]
  from (Left  a) = L (Par ZeW a)
  from (Right b) = R (Par (SuW ZeW) b)
  to (L (Par ZeW a)) = Left a
  to (R (Par (SuW ZeW) b)) = Right b

pmapEither :: forall a1 a2 b1 b2.
              (a1 -> a2) -> (b1 -> b2) -> Either a1 b1 -> Either a2 b2
pmapEither f g = pmapu h where
  h :: forall n. NatV n -> El n (Es (Either a1 b1)) -> El n (Es (Either a2 b2))
  h ZeW = f
  h (SuW ZeW) = g

main = print pmapExample1


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

module PolyKinds11 where

-- Test inference

data Nat = Ze | Su Nat

data Vec a n where -- Vec :: * -> Nat -> *
  VNil  :: Vec a Ze
  VCons :: a -> Vec a n -> Vec a (Su n)


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

module PolyKinds12 where

type family If1 (b::Bool) (t::k) (f::k) :: k
type instance If1 True t f = t
type instance If1 False t f = f

data SBool b where
  STrue :: SBool True
  SFalse :: SBool False

test1 :: SBool b -> If1 b Int Char
test1 STrue = 42
test1 SFalse = 'H'

test2 :: SBool b -> If1 b Int Char
test2 STrue = 42
test2 SFalse = 'H'

type family Apply (f :: k1 -> k2) (x :: k1) :: k2
type instance Apply f x = f x

higher1v1 :: SBool b -> (If1 b Maybe []) Char
higher1v1 STrue = Just 'H'
higher1v1 SFalse = "Hello"

higher1v2 :: SBool b -> Apply (If1 b Maybe []) Char
higher1v2 STrue = Just 'H'
higher1v2 SFalse = "Hello"

higher2 :: SBool b -> If1 b Maybe [] Int
higher2 STrue  = Just 42
higher2 SFalse = [45]


{-# LANGUAGE PolyKinds          #-}
{-# LANGUAGE FlexibleInstances  #-}

module PolyKinds13 where

data Proxy a = Proxy

instance Show (Proxy a) where
  show _ = "Proxy"

instance Functor Proxy where
  fmap _ Proxy = Proxy

data TypeRep = TypeRep

class MyTypeable t where
-- MyTypeable :: forall k. k -> Constraint
  myTypeOf :: Proxy t -> TypeRep
  myTypeOf _ = TypeRep

data Apply f t = Apply (f t)
-- Apply :: forall k.  (k -> *) -> k -> *

instance MyTypeable Apply
-- df :: forall k. MyTypeable ((k -> *) -> k -> *) (Apply k)
instance MyTypeable Int
instance MyTypeable Maybe


-- From  http://www.reddit.com/r/haskell/comments/ti5il/redblack_trees_in_haskell_using_gadts_existential/

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds#-}
{-# LANGUAGE KindSignatures#-}
module RedBlackTree where

import Data.Kind (Type)

data Nat = Zero | Succ Nat deriving (Eq, Ord, Show)
type One = Succ Zero

data RedBlack = Black | Red deriving (Eq, Ord, Show)

-- red-black trees are rooted at a black node
data RedBlackTree a = forall n. T ( Node Black n a )
deriving instance Show a => Show (RedBlackTree a)

-- all paths from a node to a leaf have exactly n black nodes
data Node :: RedBlack -> Nat -> Type -> Type where
  -- all leafs are black
  Leaf  :: Node Black One a
  -- internal black nodes can have children of either color
  B     :: Node cL n a    -> a -> Node cR n a    -> Node Black (Succ n) a
  -- internal red nodes can only have black children
  R     :: Node Black n a -> a -> Node Black n a -> Node Red n a
deriving instance Show a => Show (Node c n a)

-- one-hole context for red-black trees
data Context :: Nat -> RedBlack -> Nat -> Type -> Type  where
  -- if we're at the root, the hole is a black node
  Root :: Context n Black n a
  -- we can go left or right from a red node hole, creating a hole for a black node
  BC   :: Bool -> a -> Node Black n a -> Context m Red n a          -> Context m Black n a
  -- we can go left or right from a black node hole, creating a hole for either
  EC   :: Bool -> a -> Node cY n a    -> Context m Black (Succ n) a -> Context m cX n a
deriving instance Show a => Show (Context m c n a)

data Zipper m a = forall c n. Zipper (Node c n a) (Context m c n a)
deriving instance Show a => Show (Zipper m a)

-- create a zipper
unZip :: Node Black n a -> Zipper n a
unZip = flip Zipper Root

-- destroy a zipper
zipUp :: Zipper m a -> Node Black m a
zipUp (Zipper x Root) = x
zipUp (Zipper x (BC goLeft a y c)) = zipUp $ Zipper (if goLeft then R x a y else R y a x) c
zipUp (Zipper x (EC goLeft a y c)) = zipUp $ Zipper (if goLeft then B x a y else B y a x) c

-- locate the node that should contain a in the red-black tree
zipTo :: Ord a => a -> Zipper n a -> Zipper n a
zipTo _ z@(Zipper Leaf _) = z
zipTo a z@(Zipper (R l a' r) c) = case compare a a' of
  EQ -> z
  LT -> zipTo a $ Zipper l (BC True a' r c)
  GT -> zipTo a $ Zipper r (BC False a' l c)
zipTo a z@(Zipper (B l a' r) c) = case compare a a' of
  EQ -> z
  LT -> zipTo a $ Zipper l (EC True a' r c)
  GT -> zipTo a $ Zipper r (EC False a' l c)

-- create a red-black tree
empty :: RedBlackTree a
empty =  T Leaf

-- insert a node into a red-black tree
-- (see http://en.wikipedia.org/wiki/Red%E2%80%93black_tree#Insertion)
insert :: Ord a => a -> RedBlackTree a -> RedBlackTree a
insert a t@(T root) = case zipTo a (unZip root) of
    -- find matching leaf and replace with red node (pointing to two leaves)
    Zipper Leaf c -> insertAt (R Leaf a Leaf) c
    -- if it's already in the tree, there's no need to modify it
    _ -> t

insertAt :: Node Red n a -> Context m c n a -> RedBlackTree a
-- 1) new node is root => paint it black and done
insertAt (R l a r) Root = T $ B l a r
-- 2) new node's parent is black => done
insertAt x (EC b a y c) = T . zipUp $ Zipper x (EC b a y c)
-- 3) uncle is red => paint parent/uncle black, g'parent red.  recurse on g'parent
insertAt x (BC pb pa py (EC gb ga (R ul ua ur) gc)) = insertAt g gc
  where p = if pb then B x pa py else B py pa x
        u = B ul ua ur
        g = if gb then R p ga u else R u ga p
-- 4) node is between parent and g'parent => inner rotation
insertAt (R l a r) (BC False pa py pc@(EC True _ _ _)) = insertAt (R py pa l) (BC True a r pc)
insertAt (R l a r) (BC True pa py pc@(EC False _ _ _)) = insertAt (R r pa py) (BC False a l pc)

-- 5) otherwise => outer rotation
insertAt x (BC True pa py (EC True ga gy@Leaf gc)) =
 T . zipUp $ Zipper (B x pa $ R py ga gy) gc
insertAt x (BC True pa py (EC True ga gy@(B _ _ _) gc)) =
  T . zipUp $ Zipper (B x pa $ R py ga gy) gc
-- XXX: GHC seems unable to infer that gy is Black so I have to do both cases
--      explicitly, rather than
-- insertAt x (BC False pa py (EC False ga gy gc)) =
--   T . zipUp $ Zipper (B (R gy ga py) pa x) gc
--
-- insertAt x (BC True pa py (EC True ga gy gc)) =
--    T . zipUp $ Zipper (B x pa $ R py ga gy) gc
{-
  BC   :: Bool -> a -> Node Black n a -> Context m Red n a          -> Context m Black n a
  EC   :: Bool -> a -> Node cY n a    -> Context m Black (Succ n) a -> Context m cX n a

  BC True pa py (EC True ga gy gc) :: Context m c n a
  Hence c~Black
        EC True ga gy gc :: Context m Red n a
        gy :: Node cY n a
-}

insertAt x (BC False pa py (EC False ga gy@Leaf gc)) =
  T . zipUp $ Zipper (B (R gy ga py) pa x) gc
insertAt x (BC False pa py (EC False ga gy@(B _ _ _) gc)) =
  T . zipUp $ Zipper (B (R gy ga py) pa x) gc

-- can't derive, since we abstract over n, so we have to manually
-- check for identical structure
instance Eq a => Eq (RedBlackTree a) where
  T Leaf == T Leaf = True
  T (B l@(B _ _ _) a r@(B _ _ _)) == T (B l'@(B _ _ _) a' r'@(B _ _ _)) =
      a == a' && T l == T l' && T r == T r'
  T (B (R ll la lr) a r@(B _ _ _)) == T (B (R ll' la' lr') a' r'@(B _ _ _)) =
      a == a' && la == la' &&
      T ll == T ll' && T lr == T lr' && T r == T r'
  T (B l@(B _ _ _) a r@(R rl ra rr)) == T (B l'@(B _ _ _) a' r'@(R rl' ra' rr')) =
      a == a' && ra == ra' &&
      T l == T l' && T rl == T rl' && T rr == T rr'
  T (B (R ll la lr) a r@(R rl ra rr)) == T (B (R ll' la' lr') a' r'@(R rl' ra' rr')) =
      a == a' && la == la' && ra == ra' &&
      T ll == T ll' && T lr == T lr' && T rl == T rl' && T rr == T rr'
  _ == _ = False

-- can't derive, since B abstracts over child node colors, so
-- manually check for identical structure
instance (Eq a) => Eq (Node c n a)  where
  Leaf == Leaf                = True
  R l a r == R l' a' r'       = a == a' && l == l' && r == r'
  b@(B _ _ _) == b'@(B _ _ _) = T b == T b'
  _ == _                      = False


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

module T10041 where

data family Sing (a :: k)
data instance Sing (xs :: [k]) where
  SNil :: Sing '[]

class SingI (a :: Ä¸) where


{-# LANGUAGE DataKinds, TypeOperators, ConstraintKinds, TypeFamilies, NoMonoLocalBinds, NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module T10134 where

import GHC.TypeLits as L
import T10134a
import Prelude

type Positive n = ((n-1)+1)~n

data Dummy n d = Dummy { vec :: Vec n (Vec d Bool) }

nextDummy :: Positive (2 L.* (n+d)) => Dummy n d -> Dummy n d
nextDummy d = Dummy { vec = vec dFst }
   where (dFst,dSnd) = nextDummy' d

nextDummy' :: Positive (2 L.* (n+d)) => Dummy n d -> ( Dummy n d, Bool )
nextDummy' _ = undefined


{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module T10134a where

import Data.Kind (Type)
import GHC.TypeLits

data Vec :: Nat -> Type -> Type where
  Nil  :: Vec 0 a
  (:>) :: a -> Vec n a -> Vec (n + 1) a


{-# LANGUAGE ConstraintKinds #-}

module T10451 where

type S a = ( Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a )

type T a = ( Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a
           , Eq a, Eq a, Eq a, Eq a)


{-# LANGUAGE RankNTypes, PolyKinds, DataKinds, TypeFamilies #-}
module GHCBug where

data Proxy p = Proxy

data KProxy (a :: *) = KProxy

h :: forall k r . (Proxy ('KProxy :: KProxy k) ~ Proxy ('KProxy :: KProxy *) => r) -> r
h = undefined


{-# LANGUAGE PolyKinds #-}
module T10516 where

type App f a = f a

newtype X f a = X (f a)

f :: f a -> X (App f) a
f = X


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

module T10570 where

import Data.Proxy

class ConsByIdx2 x a m cls | x -> m where
    consByIdx2 :: x -> a -> m cls

instance ConsByIdx2 Int a Proxy cls where
    consByIdx2 _ _ = Proxy


{-# LANGUAGE ScopedTypeVariables, RankNTypes, GADTs, PolyKinds #-}

module T10670 where

import Unsafe.Coerce
import Data.Kind (Type)

data TypeRepT (a::k) where
  TRCon :: TypeRepT a

data G2 c a where
  G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b)

getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a)
{-# NOINLINE getT2 #-}
getT2 c t = Nothing

tyRepTArr :: TypeRepT (->)
{-# NOINLINE tyRepTArr #-}
tyRepTArr = TRCon

s :: forall a x. TypeRepT (a :: Type) -> Maybe x
s tf = case getT2 tyRepTArr tf :: Maybe (G2 (->) a) of
          Just (G2 _ _) -> Nothing
          _ -> Nothing


{-# LANGUAGE GADTs , PolyKinds #-}

module Bug2 where

import Unsafe.Coerce

data TyConT (a::k) = TyConT String

eqTyConT :: TyConT a -> TyConT b -> Bool
eqTyConT (TyConT a) (TyConT b) = a == b

tyConTArr :: TyConT (->)
tyConTArr = TyConT "(->)"

data TypeRepT (a::k) where
  TRCon :: TyConT a -> TypeRepT a
  TRApp :: TypeRepT a -> TypeRepT b -> TypeRepT (a b)

data GetAppT a where
  GA :: TypeRepT a -> TypeRepT b -> GetAppT (a b)

getAppT :: TypeRepT a -> Maybe (GetAppT a)
getAppT (TRApp a b) = Just $ GA a b
getAppT _ = Nothing

eqTT :: TypeRepT (a::k1) -> TypeRepT (b::k2) -> Bool
eqTT (TRCon a) (TRCon b) = eqTyConT a b
eqTT (TRApp c a) (TRApp d b) = eqTT c d && eqTT a b
eqTT _ _ = False

data G2 c a where
  G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b)

getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a)
getT2 c t = do GA t' b <- getAppT t
               GA c' a <- getAppT t'
               if eqTT c c'
                 then Just (unsafeCoerce $ G2 a b :: G2 c a)
                 else Nothing

tyRepTArr :: TypeRepT (->)
tyRepTArr = TRCon tyConTArr

s tf = case getT2 tyRepTArr tf
       of Just (G2 _ _) -> Nothing
          _ -> Nothing


{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module T10742 where

import GHC.TypeLits

data T a where MkT :: T Int

test :: ((x <=? y) ~ 'True, (y <=? z) ~ 'True)
     => proxy x y z -> ()
test _ = case MkT of MkT -> ()


{-# LANGUAGE
    ScopedTypeVariables
  , DataKinds
  , GADTs
  , RankNTypes
  , TypeOperators
  , PolyKinds -- Comment out PolyKinds and the bug goes away.
  #-}
{-# OPTIONS_GHC -O #-}
  -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it

module KeyValue where

import Data.Kind

data AccValidation err a = AccFailure err | AccSuccess a

data KeyValueError = MissingValue

type WithKeyValueError = AccValidation [KeyValueError]

missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs
missing = rpure missingField
  where
    missingField :: forall x. (WithKeyValueError :. f) x
    missingField = Compose $ AccFailure [MissingValue]

data Rec :: (u -> Type) -> [u] -> Type where
  RNil :: Rec f '[]
  (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs)

newtype Compose (f :: l -> Type) (g :: k -> l) (x :: k)
  = Compose { getCompose :: f (g x) }

type (:.) f g = Compose f g

class RecApplicative rs where
  rpure
    :: (forall x. f x)
    -> Rec f rs


{-# LANGUAGE PolyKinds, RankNTypes #-}

module T11142 where

import Data.Kind

data SameKind :: k -> k -> *

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


{-# LANGUAGE PolyKinds, KindSignatures #-}

module T11203 where

data SameKind :: k -> k -> *

data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)


{-# OPTIONS_GHC -O #-}
  -- Trac #11248, comment:6 showed that this tests failed with -O

{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies,
             KindSignatures, ConstraintKinds #-}

module T11248 where

import GHC.TypeLits

type a / b = FDiv a b
type a ** b = FMul a b

type family FDiv a b where
  FDiv 11648 128 = 91

type family FMul a b where
  FMul 64 91 = 5824

type family FGCD a b where
  FGCD 128 448 = 64
  FGCD 128 5824 = 64

type family FLCM a b where
  FLCM 128 5824 = 11648

data CT (m :: Nat) (m' :: Nat)
type H0 = 128
type H1 = 448
type H0' = 11648
type H1' = 5824

main' = let x = undefined :: CT H0 H0'
        in foo x :: CT H1 H1'

foo x = bug x

type Ctx2 e r s e' r' =
  (e ~ FGCD r e', r' ~ FLCM r e', e ~ FGCD r s)

type Ctx1 e r s e' r' =
  (Ctx2 e r s e' r', e' ~ (e ** (r' / r)))

bug :: (Ctx1 e r s e' r')
  => CT r r' -> CT s s'
bug = undefined


{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies,
             KindSignatures, ConstraintKinds #-}

module T11249 where

import GHC.TypeLits

type a / b = FDiv a b
type a ** b = FMul a b

type family FDiv a b where
  FDiv 11648 128 = 91

type family FMul a b where
  FMul 64 91 = 5824

type family FGCD a b where
  FGCD 128 448 = 64
  FGCD 128 5824 = 64

type family FLCM a b where
  FLCM 128 5824 = 11648

data CT (m :: Nat) (m' :: Nat)
type H0 = 128
type H1 = 448
type H0' = 11648
type H1' = 5824

main' = let x = undefined :: CT H0 H0'
        in foo x :: CT H1 H1'

foo x = bug x

type Ctx2 e r s e' r' =
  (e ~ FGCD r e', r' ~ FLCM r e', e ~ FGCD r s)

bug :: (Ctx2 e r s e' r', e' ~ (e ** (FDiv r' r)))
  => CT r r' -> CT s s'
bug = undefined


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

module T11255 where

type family Default :: k
type instance Default = '(Default, Default)


{-# LANGUAGE ConstraintKinds #-}

module A where

type K a = (Show a, Read a)
class K a => C a where


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

module T11362 where
-- this file when compiled with -dunique-increment=-1 made GHC crash

import Data.Kind (Type)

data Sum a b = L a | R b

data Sum1 (a :: k1 -> Type) (b :: k2 -> Type) :: Sum k1 k2 -> Type where
  LL :: a i -> Sum1 a b (L i)
  RR :: b i -> Sum1 a b (R i)

data Code i o = F (Code (Sum i o) o)

-- An interpretation for `Code` using a data family works:
data family In (f :: Code i o) :: (i -> Type) -> (o -> Type)

data instance In (F f) r o where
  MkIn :: In f (Sum1 r (In (F f) r)) o -> In (F f) r o

-- Requires polymorphic recursion
data In' (f :: Code i o) :: (i -> Type) -> o -> Type where
  MkIn' :: In' g (Sum1 r (In' (F g) r)) t -> In' (F g) r t


{-# LANGUAGE FlexibleInstances, PolyKinds #-}
module T11399 where

import Data.Kind

newtype UhOh (k :: * -> *) (a :: k *) = UhOh (k *)

-- UhOh :: forall (k : * -> *). k * -> *

instance Functor a => Functor (UhOh a) where


{-# LANGUAGE  PolyKinds, RankNTypes #-}

module T11459 where

type Failure f r   = String -> f r
type Success a f r = a -> f r

newtype Parser a = Parser {
      unParser :: forall f r.
                  Failure f r
               -> Success a f r
               -> f r
    }


{-# LANGUAGE ImplicitParams, ConstraintKinds #-}

module T11466 where

-- This should be ok
type Bla = ?x::Int

-- This should be ook
f :: Bla => Int -> Int
f y = ?x + y

data T = T

-- But this should be rejected
instance Bla => Eq T


{-# language KindSignatures, PolyKinds, TypeFamilies,
  NoImplicitPrelude, FlexibleContexts,
  MultiParamTypeClasses, GADTs,
  ConstraintKinds, FlexibleInstances, UndecidableInstances,
  FunctionalDependencies, UndecidableSuperClasses #-}

module T11480a where

import Data.Kind (Type, Constraint)
import qualified Prelude

data Nat (c :: i -> i -> Type) (d :: j -> j -> Type) (f :: i -> j) (g :: i -> j)

class Functor p (Nat p (->)) p => Category (p :: i -> i -> Type)

class (Category dom, Category cod)
   => Functor (dom :: i -> i -> Type) (cod :: j -> j -> Type) (f :: i -> j)
    | f -> dom cod

instance (Category c, Category d) => Category (Nat c d)
instance (Category c, Category d) => Functor (Nat c d) (Nat (Nat c d) (->)) (Nat c d)
instance (Category c, Category d) => Functor (Nat c d) (->) (Nat c d f)

instance Category (->)
instance Functor (->) (->) ((->) e)
instance Functor (->) (Nat (->) (->)) (->)


{-# language KindSignatures #-}
{-# language PolyKinds #-}
{-# language DataKinds #-}
{-# language TypeFamilies #-}
{-# language RankNTypes #-}
{-# language NoImplicitPrelude #-}
{-# language FlexibleContexts #-}
{-# language MultiParamTypeClasses #-}
{-# language GADTs #-}
{-# language ConstraintKinds #-}
{-# language FlexibleInstances #-}
{-# language TypeOperators #-}
{-# language ScopedTypeVariables #-}
{-# language DefaultSignatures #-}
{-# language FunctionalDependencies #-}
{-# language UndecidableSuperClasses #-}

-- This code, supplied by Edward Kmett, uses UndecidableSuperClasses along
-- with a bunch of other stuff, so it's a useful stress test.
-- See Trac #11480 comment:12.

module T11480b where

import Data.Kind (Constraint, Type)
import Data.Type.Equality as Equality
import Data.Type.Coercion as Coercion
import qualified Prelude
import Prelude (Either(..))

newtype Y (p :: i -> j -> Type) (a :: j) (b :: i) = Y { getY :: p b a }

type family Op (p :: i -> j -> Type) :: j -> i -> Type where
  Op (Y p) = p
  Op p = Y p

class Vacuous (p :: i -> i -> Type) (a :: i)
instance Vacuous p a

data Dict (p :: Constraint) where
  Dict :: p => Dict p

class Functor (Op p) (Nat p (->)) p => Category (p :: i -> i -> Type) where
  type Ob p :: i -> Constraint
  type Ob p = Vacuous p

  id :: Ob p a => p a a
  (.) :: p b c -> p a b -> p a c

  source :: p a b -> Dict (Ob p a)
  default source :: (Ob p ~ Vacuous p) => p a b -> Dict (Ob p a)
  source _ = Dict

  target :: p a b -> Dict (Ob p b)
  default target :: (Ob p ~ Vacuous p) => p a b -> Dict (Ob p b)
  target _ = Dict

  op :: p b a -> Op p a b
  default op :: Op p ~ Y p => p b a -> Op p a b
  op = Y

  unop :: Op p b a -> p a b
  default unop :: Op p ~ Y p => Op p b a -> p a b
  unop = getY

class (Category p, Category q) =>
      Functor (p :: i -> i -> Type)
              (q :: j -> j -> Type)
              (f :: i -> j) | f -> p q where
  fmap :: p a b -> q (f a) (f b)

data Nat (p :: i -> i -> Type)
         (q :: j -> j -> Type) (f :: i -> j) (g :: i -> j) where
  Nat :: (Functor p q f, Functor p q g) =>
         { runNat :: forall a. Ob p a => q (f a) (g a) } -> Nat p q f g

instance (Category p, Category q) => Category (Nat p q) where
  type Ob (Nat p q) = Functor p q
  id = Nat id1 where
    id1 :: forall f x. (Functor p q f, Ob p x) => q (f x) (f x)
    id1 = id \\ (ob :: Ob p x :- Ob q (f x))
  Nat f . Nat g = Nat (f . g)
  source Nat{} = Dict
  target Nat{} = Dict

ob :: forall p q f a. Functor p q f => Ob p a :- Ob q (f a)
ob = Sub (case source (fmap (id :: p a a) :: q (f a) (f a)) of Dict -> Dict)

instance (Category p, Category q) =>
         Functor (Y (Nat p q)) (Nat (Nat p q) (->)) (Nat p q) where
  fmap (Y f) = Nat (. f)

instance (Category p, Category q) => Functor (Nat p q) (->) (Nat p q f) where
  fmap = (.)

contramap :: Functor p q f => Op p b a -> q (f a) (f b)
contramap = fmap . unop

instance Category (->) where
  id = Prelude.id
  (.) = (Prelude..)

instance Functor (->) (->) ((->) e) where
  fmap = (.)

instance Functor (Y (->)) (Nat (->) (->)) (->) where
  fmap (Y f) = Nat (. f)

instance (Category p, Op p ~ Y p) => Category (Y p) where
  type Ob (Y p) = Ob p
  id = Y id
  Y f . Y g = Y (g . f)
  source (Y f) = target f
  target (Y f) = source f
  unop = Y
  op = getY

instance (Category p, Op p ~ Y p) => Functor (Y p) (->) (Y p a) where
  fmap = (.)

instance (Category p, Op p ~ Y p) => Functor p (Nat (Y p) (->)) (Y p) where
  fmap f = Nat (. Y f)

--------------------------------------------------------------------------------
-- * Constraints
--------------------------------------------------------------------------------

infixl 1 \\ -- comment required for cpp
(\\) :: a => (b => r) -> (a :- b) -> r
r \\ Sub Dict = r

newtype p :- q = Sub (p => Dict q)

instance Functor (:-) (->) Dict where
  fmap p Dict = case p of
    Sub q -> q

instance Category (:-) where
  id = Sub Dict
  f . g = Sub (Dict \\ f \\ g)

instance Functor (:-) (->) ((:-) e) where
  fmap = (.)

instance Functor (Y (:-)) (Nat (:-) (->)) (:-) where
  fmap (Y f) = Nat (. f)

--------------------------------------------------------------------------------
-- * Common Functors
--------------------------------------------------------------------------------

instance Functor (->) (->) ((,) e) where
  fmap f ~(a,b) = (a, f b)

instance Functor (->) (->) (Either e) where
  fmap _ (Left a) = Left a
  fmap f (Right b) = Right (f b)

instance Functor (->) (->) [] where
  fmap = Prelude.fmap

instance Functor (->) (->) Prelude.Maybe where
  fmap = Prelude.fmap

instance Functor (->) (->) Prelude.IO where
  fmap = Prelude.fmap

instance Functor (->) (Nat (->) (->)) (,) where
  fmap f = Nat (\(a,b) -> (f a, b))

instance Functor (->) (Nat (->) (->)) Either where
  fmap f0 = Nat (go f0) where
    go :: (a -> b) -> Either a c -> Either b c
    go f (Left a)  = Left (f a)
    go _ (Right b) = Right b

--------------------------------------------------------------------------------
-- * Type Equality
--------------------------------------------------------------------------------

instance Category (:~:) where
  id = Refl
  (.) = Prelude.flip Equality.trans

instance Functor (Y (:~:)) (Nat (:~:) (->)) (:~:) where
  fmap (Y f) = Nat (. f)

instance Functor (:~:) (->) ((:~:) e) where
  fmap = (.)

--------------------------------------------------------------------------------
-- * Type Coercions
--------------------------------------------------------------------------------

instance Category Coercion where
  id = Coercion
  (.) = Prelude.flip Coercion.trans

instance Functor (Y Coercion) (Nat Coercion (->)) Coercion where
  fmap (Y f) = Nat (. f)

instance Functor Coercion (->) (Coercion e) where
  fmap = (.)


{-# language PolyKinds #-}
{-# language FlexibleContexts #-}
{-# language ConstraintKinds #-}
{-# language FlexibleInstances #-}
{-# language FunctionalDependencies #-}
{-# language UndecidableInstances #-}

import GHC.Exts (Constraint)

class RÃki (p :: i -> i -> *)
class (RÃki p) => Varpi p q f | f -> p q
instance Varpi () () f => Varpi (->) (->) (Either f) where


{-# LANGUAGE RankNTypes, PolyKinds, GADTs, UndecidableSuperClasses, UndecidableInstances #-}

module T11520 where

import GHC.Types hiding (TyCon)

data TypeRep (a :: k)

class Typeable k => Typeable (a :: k) where
    typeRep :: TypeRep a

data Compose (f :: k1 -> *) (g :: k2 -> k1) (a :: k2) = Compose (f (g a))

-- Note how the kind signature on g is incorrect
instance (Typeable f, Typeable (g :: k), Typeable k) => Typeable (Compose f g) where
    typeRep = undefined


{-# language KindSignatures #-}
{-# language PolyKinds #-}
{-# language DataKinds #-}
{-# language TypeFamilies #-}
{-# language RankNTypes #-}
{-# language NoImplicitPrelude #-}
{-# language FlexibleContexts #-}
{-# language MultiParamTypeClasses #-}
{-# language GADTs #-}
{-# language ConstraintKinds #-}
{-# language FlexibleInstances #-}
{-# language TypeOperators #-}
{-# language ScopedTypeVariables #-}
{-# language DefaultSignatures #-}
{-# language FunctionalDependencies #-}
{-# language UndecidableSuperClasses #-}
{-# language UndecidableInstances #-}

module T11523 where

import GHC.Types (Constraint, Type)
import qualified Prelude

type Cat i = i -> i -> Type

newtype Y (p :: i -> j -> Type) (a :: j) (b :: i) = Y { getY :: p b a }

class Vacuous (a :: i)
instance Vacuous a

class (Functor p, Dom p ~ Op p, Cod p ~ Nat p (->)) => Category (p :: Cat i) where
  type Op p :: Cat i
  type Op p = Y p
  type Ob p :: i -> Constraint
  type Ob p = Vacuous

class (Category (Dom f), Category (Cod f)) => Functor (f :: i -> j) where
  type Dom f :: Cat i
  type Cod f :: Cat j

class    (Functor f, Dom f ~ p, Cod f ~ q) => Fun (p :: Cat i) (q :: Cat j) (f :: i -> j) | f -> p q
instance (Functor f, Dom f ~ p, Cod f ~ q) => Fun (p :: Cat i) (q :: Cat j) (f :: i -> j)

data Nat (p :: Cat i) (q :: Cat j) (f :: i -> j) (g :: i -> j)

instance (Category p, Category q) => Category (Nat p q) where
  type Ob (Nat p q) = Fun p q

instance (Category p, Category q) => Functor (Nat p q) where
  type Dom (Nat p q) = Y (Nat p q)
  type Cod (Nat p q) = Nat (Nat p q) (->)

instance (Category p, Category q) => Functor (Nat p q f) where
  type Dom (Nat p q f) = Nat p q
  type Cod (Nat p q f) = (->)

instance Category (->)

instance Functor ((->) e) where
  type Dom ((->) e) = (->)
  type Cod ((->) e) = (->)

instance Functor (->) where
  type Dom (->) = Y (->)
  type Cod (->) = Nat (->) (->)

instance (Category p, Op p ~ Y p) => Category (Y p) where
  type Op (Y p) = p

instance (Category p, Op p ~ Y p) => Functor (Y p a) where
  type Dom (Y p a) = Y p
  type Cod (Y p a) = (->)

instance (Category p, Op p ~ Y p) => Functor (Y p) where
  type Dom (Y p) = p
  type Cod (Y p) = Nat (Y p) (->)

{-
Given:  Category p, Op p ~ Y p

   -->  Category p, Op p ~ Y p
        Functor p, Dom p ~ Op p, Cod p ~ Nat p (->)

   -->  Category p, Op p ~ Y p
        Functor p, Dom p ~ Op p, Cod p ~ Nat p (->)
        Category (Dom p), Category (Cod p)
-}


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

module T11554 where

import Data.Kind

data P (x :: k) = Q

data A :: Type where
  B :: forall (a :: A). P a -> A


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

module T11611 where

data A a where
  A :: A (a:as) -> a -> A as

deriving instance Show a => Show (A a)


{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PolyKinds #-}
module T11616 where

class Whoami a where
  whoami :: String

instance Whoami Int where
  whoami = "int"

instance Whoami Bool where
  whoami = "[y/n]"

instance Whoami Maybe where
  whoami = "call me maybe"

whoisint :: String
whoisint = whoami @Int


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

module T11640 where

import Data.Kind

data HEq :: forall k1. k1 -> forall k2. k2 -> Type where


{-# LANGUAGE PolyKinds, TypeOperators, TypeFamilies,
             MultiParamTypeClasses #-}

module T11648 where

import Data.Kind

class Monoidy (to :: k0 -> k1 -> Type) (m :: k1)  where
  type MComp to m :: k1 -> k1 -> k0
  mjoin :: MComp to m m m `to` m


{-# LANGUAGE DataKinds, PolyKinds #-}

module T11648b where

import Data.Proxy

data X (a :: Proxy k)


{-# LANGUAGE RankNTypes, DataKinds, PolyKinds, GADTs, TypeFamilies, UndecidableInstances #-}
module NotInScope where

import Data.Proxy
import Data.Kind (Type)

type KindOf (a :: k) = ('KProxy :: KProxy k)
data TyFun :: Type -> Type -> Type
type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2

data Lgo2 l1
          l2
          l3
          (l4 :: b)
          (l5 :: TyFun [a] b)
  = forall (arg :: [a]) . KindOf (Apply (Lgo2 l1 l2 l3 l4) arg) ~ KindOf (Lgo l1 l2 l3 l4 arg) =>
    Lgo2KindInference

data Lgo1 l1
          l2
          l3
          (l4 :: TyFun b (TyFun [a] b -> Type))
  = forall (arg :: b) . KindOf (Apply (Lgo1 l1 l2 l3) arg) ~ KindOf (Lgo2 l1 l2 l3 arg) =>
    Lgo1KindInference

type family Lgo f
                z0
                xs0
                (a1 :: b)
                (a2 :: [a]) :: b where
  Lgo f z0 xs0 z '[]         = z
  Lgo f z0 xs0 z ('(:) x xs) = Apply (Apply (Lgo1 f z0 xs0) (Apply (Apply f z) x)) xs


{-# LANGUAGE GADTs, DataKinds, PolyKinds, ConstraintKinds #-}
module T11821a where
import Data.Proxy
type SameKind (a :: k1) (b :: k2) = ('Proxy :: Proxy k1) ~ ('Proxy :: Proxy k2)


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}

-- The code from the ticket lacked these extensions,
-- but crashed the compiler with "GHC internal error"
-- It doesn't crash now; and in this test case I've added
-- the extensions, which makes it compile cleanly
{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances, FunctionalDependencies #-}

module T12055 where

import GHC.Base ( Constraint, Type )
import GHC.Exts ( type (~~) )

type Cat k = k -> k -> Type

class Category (p :: Cat k) where
    type Ob p :: k -> Constraint

class (Category (Dom f), Category (Cod f)) => Functor (f :: j -> k) where
    type Dom f :: Cat j
    type Cod f :: Cat k
    functor :: forall a b.
               Iso Constraint (:-) (:-)
               (Ob (Dom f) a)     (Ob (Dom f) b)
               (Ob (Cod f) (f a)) (Ob (Cod f) (f b))

class (Functor f , Dom f ~ p, Cod f ~ q) =>
    Fun (p :: Cat j) (q :: Cat k) (f :: j -> k) | f -> p q
instance (Functor f , Dom f ~ p, Cod f ~ q) =>
    Fun (p :: Cat j) (q :: Cat k) (f :: j -> k)

data Nat (p :: Cat j) (q :: Cat k) (f :: j -> k) (g :: j -> k)

type Iso k (c :: Cat k) (d :: Cat k) s t a b =
    forall p. (Cod p ~~ Nat d (->)) => p a b -> p s t

data (p :: Constraint) :- (q :: Constraint)


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}

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

-- The code from the ticket lacked necessary extension FlexibleContexts
-- which crashed the compiler with "GHC internal error"
-- This test case reproduces that scenario
{- # LANGUAGE FlexibleContexts #-}

module T12055a where

import GHC.Base ( Constraint, Type )
import GHC.Exts ( type (~~) )

type Cat k = k -> k -> Type

class Category (p :: Cat k) where
    type Ob p :: k -> Constraint

class (Category (Dom f), Category (Cod f)) => Functor (f :: j -> k) where
    type Dom f :: Cat j
    type Cod f :: Cat k
    functor :: forall a b.
               Iso Constraint (:-) (:-)
               (Ob (Dom f) a)     (Ob (Dom f) b)
               (Ob (Cod f) (f a)) (Ob (Cod f) (f b))

class (Functor f , Dom f ~ p, Cod f ~ q) =>
    Fun (p :: Cat j) (q :: Cat k) (f :: j -> k) | f -> p q
instance (Functor f , Dom f ~ p, Cod f ~ q) =>
    Fun (p :: Cat j) (q :: Cat k) (f :: j -> k)

data Nat (p :: Cat j) (q :: Cat k) (f :: j -> k) (g :: j -> k)

type Iso k (c :: Cat k) (d :: Cat k) s t a b =
    forall p. (Cod p ~~ Nat d (->)) => p a b -> p s t

data (p :: Constraint) :- (q :: Constraint)


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

module T12444 where

data Nat = Zero | Succ Nat

data SNat (n :: Nat) where
  SZero :: SNat Zero
  SSucc :: SNat n -> SNat (Succ n)

type family (:+:) (a :: Nat) (b :: Nat) :: Nat where
  m :+: Zero = m
  m :+: (Succ n) = Succ (m :+: n)

foo :: SNat (Succ c) -> SNat b -> SNat (Succ (c :+: b))
foo _ x = x

{-
sadd :: ((Succ n1 :+: n) ~ Succ (n1 :+: n), (Succ n1) ~ m)
     => SNat m -> SNat n -> SNat (m :+: n)
sadd SZero n = n
-}

{- [G]  a ~ Succ c
        Succ c + b ~ Succ (c+b)
        a ~ Zero

-->
        Zero ~ Succ c            TyEq
        fsk1 ~ Succ fsk2         TyEq
        fsk1 ~ (Succ c) + b      FunEq
        fsk2 ~ c+b               FunEq
----
[W] b ~ a+b  --->   b ~ Succ (c+b)

Derived
       a ~ Succ c
       fsk1 ~ Succ fsk2
       b ~ Succ fsk2

work   (Succ c) + b ~ fsk1
       c+b ~ fsk2

-}

{-

[G] a ~ [b]
--> Derived shadow [D] a ~ [b]
    When adding this to the model
    don't kick out a derived shadow again!

[G] (a ~ b)  --> sc   a ~~ b, a ~# b
  Silly to then kick out (a~b) and (a~~b)
  and rewrite them to (a~a) and (a~~a)

Insoluble constraint does not halt solving;
indeed derived version stays. somehow
-}


{-# LANGUAGE GADTs, ConstraintKinds, PolyKinds, KindSignatures, RankNTypes #-}

module T12593 where

import Data.Kind

newtype Free k p a b where
   Free :: (forall q. k q => (forall c d. p c d -> q c d) -> q a b)
        -> Free k p a b

run :: k2 q => Free k k1 k2 p a b
             -> (forall (c :: k) (d :: k1). p c d -> q c d)
             -> q a b
run (Free cat) = cat


{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}

module T12668 where

import GHC.Exts

data Some r = Some (TYPE r -> TYPE r)

doSomething :: forall (r :: RuntimeRep). forall (a :: TYPE r). ()
            => Int -> (a -> Int) -> a -> a
doSomething n f =
    case n of
      1 -> error "hello"
      3 -> error "hello"


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

module Main where

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

class XNum (a :: TYPE rep) where
  (+) :: a -> a -> a
  fromInteger :: Integer -> a

instance P.Num a => XNum a where
  (+) = (P.+)
  fromInteger = P.fromInteger

instance XNum Int# where
  (+) = (+#)
  fromInteger i = case fromInteger i of
                   I# n -> n

u :: Bool
u = isTrue# v_
  where
    v_ :: forall rep (a :: TYPE rep). XNum a => a
    v_ = fromInteger 10

main = print u


{-# LANGUAGE TypeFamilies, ConstraintKinds  #-}

module Foo where

import GHC.Exts

f :: F [a] => a -> Bool
f x = x == x

type family F a :: Constraint
type instance F [a] = (Show a, (Show a, (Show a, (Show a, (Show a,
                       Show a, (Show a, (Show a, (Show a, (Show a, Eq a)))))))))


{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
module T13267 where

type C1 a = (Show (a -> Bool))

instance C1 Int where

type C2 a = (Show Bool, Show Int)

instance C2 Int where


{-# LANGUAGE
  MonoLocalBinds,
  PolyKinds,

  FunctionalDependencies,
  FlexibleContexts #-}

-- reduced version of
-- http://code.haskell.org/~aavogt/HList_dredge_ghc802/Data/HList/Dredge.hs
--
-- F ~ EnsureLabel
-- g_f  ~ dredge
-- g_f' ~ dredge'

{- ghc-8.0.2

too_eager.hs:25:14: warning: [-Wdeferred-type-errors]
    â€¢ No instance for (F t0 (Proxy b0)) arising from a use of â€˜g_fâ€™
    â€¢ In the first argument of â€˜idâ€™, namely â€˜(g_f a)â€™
      In the expression: id (g_f a)
      In an equation for â€˜g_f'â€™: g_f' a = id (g_f a)

ghc-7.10.3 can wait to select the instance for F

-}

module T13371 where

import Data.Proxy

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

g ::  Proxy b -> c
g _ = undefined

-- a type signature (what ghc infers) makes it work
-- g_f :: F a (Proxy b) => a -> c
g_f a = g (f a)

g_f' a = id (g_f a)


{-# LANGUAGE GADTs #-}
module T13391a where

-- this caused a panic during the work on T13391.

data A a where
  A3 :: b ~ Int => b -> A Int


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
module T13393 ( ) where

import Control.Monad.Trans.RWS.Strict (RWST)
import Data.Functor.Identity (Identity)
import Data.Kind (Type)
import Data.Word (Word16)

data Rate
data Audio (sampleRate :: Rate) (channelLayout :: Type) (encoding :: Type)
data EncodeResult = MkEncodeResult
  { encodeResultLeftOverInput :: !(Maybe [Word16])
  }
data EncodeFailure
data AacEncErrorCode
data Aac (aot :: AacCodec)
data AacCodec
newtype AacEncSt (rate :: Rate) channels (codec :: AacCodec) = MkAacEncSt
  { _leftOvers :: Maybe [Word16]
  }

-- makeLenses ''AacEncSt

type Iso s t a b = forall p f. (Functor f) => (a -> f b) -> s -> (f t)
instance (Monad m, Monoid w) => MonadState s (RWST r w s m) where

iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso sa bt x = fmap bt . x . sa
{-# INLINE iso #-}

leftOvers ::
  forall rate_a750
         channels_a753
         codec_a757
         rate_aaYK
         channels_aaYL
         codec_aaYM.
  Iso (AacEncSt rate_a750 channels_a753 codec_a757) (AacEncSt rate_aaYK channels_aaYL codec_aaYM) (Maybe [Word16]) (Maybe [Word16])
leftOvers = (iso (\ (MkAacEncSt x_aaYN) -> x_aaYN)) MkAacEncSt
{-# INLINE leftOvers #-}

type ASetter s t a b = (a -> Identity b) -> s -> Identity t
class Monad m => MonadState s m | m -> s where

(.=) :: MonadState s m => ASetter s s a b -> b -> m ()
l .= b = undefined
{-# INLINE (.=) #-}

type AacEncT rate channels codec m a = RWST Int () (AacEncSt rate channels codec) m a

encodeLinearToAac
  :: AacEncT rate channels codec IO (Either EncodeFailure (Maybe (Audio rate channels (Aac codec))))
encodeLinearToAac = do
  mapM putBackLeftOverInputAndReturnOutput undefined
  undefined
  where
    putBackLeftOverInputAndReturnOutput (MkEncodeResult x) = do
      leftOvers .= x
      undefined


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module T13394 where

import Data.ByteString

newtype ProperName =
  ProperName { runProperName :: ByteString
               -- purescript actually uses the Text type, but this works
               -- just as well for the purposes of illustrating the bug
             }
newtype ModuleName = ModuleName [ProperName]

pattern TypeDataSymbol :: ModuleName
pattern TypeDataSymbol = ModuleName [ProperName "Type"]


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module T13394 where

import Data.ByteString

newtype ProperName =
  ProperName { runProperName :: ByteString
               -- purescript actually uses the Text type, but this works
               -- just as well for the purposes of illustrating the bug
             }
newtype ModuleName = ModuleName [ProperName]

pattern TypeDataSymbol :: ModuleName
pattern TypeDataSymbol = ModuleName [ProperName "Type", ProperName "Data"]


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
module T13555 where

import Data.Functor.Identity (Identity(..))

data T a
type Polynomial a = T a
newtype GF fp d = GF (Polynomial fp)
type CRTInfo r = (Int -> r, r)
type Tagged s b = TaggedT s Identity b
newtype TaggedT s m b = TagT { untagT :: m b }

class Reflects a i where
  value :: Tagged a i

class CRTrans mon r where
  crtInfo :: Reflects m Int => TaggedT m mon (CRTInfo r)

instance CRTrans Maybe (GF fp d) where
  crtInfo :: forall m . (Reflects m Int) => TaggedT m Maybe (CRTInfo (GF fp d))
  crtInfo = undefined


{-# LANGUAGE DataKinds, PolyKinds #-}

module T13625 where

data X :: Y where Y :: X


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

{- Defines a C-like printf function using DataKinds extensions. -}

module T13659 where

import Data.Kind (Type)

-- format string parameterized by a list of types
data Format (fmt :: [Type]) where
  X :: Format '[]                   -- empty string, i.e. ""
  L :: a -> String -> Format '[]    -- string literal, e.g. "hello"
  S :: a -> Format '[String]        -- "%s"
  I :: Format a -> Format '[Int, a] -- "%d"


{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module T13738 where

import Data.Coerce
import Data.Proxy

foo x = coerce @(forall (a :: k). Proxy a -> Int)
               @(forall (a :: k). Proxy a -> Int)
        x


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module T13985 where

import Data.Kind
import Data.Proxy

data family Fam
data instance Fam = MkFam (forall (a :: k). Proxy a)

type family T
type instance T = Proxy (Nothing :: Maybe a)

class C k where
  data CD :: k
  type CT :: k

instance C Type where
  data CD = forall (a :: k). CD (Proxy a)
  type CT = Proxy (Nothing :: Maybe a)

class Z a where
  type ZT a
  type ZT a = Proxy (Nothing :: Maybe x)


{-# Language TypeFamilies, ScopedTypeVariables, PolyKinds, DataKinds #-}

import Data.Kind

class R (c :: k -> Constraint) where
  type R_ (c :: k -> Constraint) :: k -> Type

instance R Eq where
  type R_ Eq a = a -> a -> Bool


module T14172 where

import Data.Functor.Compose
import T14172a

traverseCompose :: (a -> f b) -> g a -> f (h _)
traverseCompose = _Wrapping Compose . traverse


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module T14172a where

import Data.Kind
import Data.Coerce
import Data.Functor.Compose
import Data.Functor.Identity

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

instance Profunctor (->) where
  dimap ab cd bc = cd . bc . ab
  {-# INLINE dimap #-}
  (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b
  {-# INLINE (#.) #-}

type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
type Iso' s a = Iso s s a a

iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso sa bt = dimap sa (fmap bt)
{-# INLINE iso #-}

type AnIso s t a b = Exchange a b a (Identity b) -> Exchange a b s (Identity t)

data Exchange a b s t = Exchange (s -> a) (b -> t)

instance Profunctor (Exchange a b) where
  dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
  {-# INLINE dimap #-}
  (#.) _ = coerce
  {-# INLINE ( #. ) #-}

withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso ai k = case ai (Exchange id Identity) of
  Exchange sa bt -> k sa (runIdentity #. bt)
{-# INLINE withIso #-}

class Wrapped s where
  type Unwrapped s :: Type
  _Wrapped' :: Iso' s (Unwrapped s)

class Wrapped s => Rewrapped (s :: Type) (t :: Type)

class    (Rewrapped s t, Rewrapped t s) => Rewrapping s t
instance (Rewrapped s t, Rewrapped t s) => Rewrapping s t

instance (t ~ Compose f' g' a') => Rewrapped (Compose f g a) t
instance Wrapped (Compose f g a) where
  type Unwrapped (Compose f g a) = f (g a)
  _Wrapped' = iso getCompose Compose

_Wrapping :: Rewrapping s t => (Unwrapped s -> s) -> Iso s t (Unwrapped s) (Unwrapped t)
_Wrapping _ = _Wrapped
{-# INLINE _Wrapping #-}

_Wrapped :: Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped = withIso _Wrapped' $ \ sa _ -> withIso _Wrapped' $ \ _ bt -> iso sa bt
{-# INLINE _Wrapped #-}


{-# LANGUAGE RankNTypes, KindSignatures, PolyKinds #-}
module T14174 where

data T k (x :: k) = MkT

data S x = MkS (T (x Int) x)


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module T14174a where

import Data.Kind

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

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

data FunArrow = (:->) | (:~>)

class FunType (arr :: FunArrow) where
  type Fun (k1 :: Type) arr (k2 :: Type) :: Type

class FunType arr => AppType (arr :: FunArrow) where
  type App k1 arr k2 (f :: Fun k1 arr k2) (x :: k1) :: k2

type FunApp arr = (FunType arr, AppType arr)

instance FunType (:->) where
  type Fun k1 (:->) k2 = k1 -> k2

instance AppType (:->) where
  type App k1 (:->) k2 (f :: k1 -> k2) x = f x

instance FunType (:~>) where
  type Fun k1 (:~>) k2 = k1 ~> k2

instance AppType (:~>) where
  type App k1 (:~>) k2 (f :: k1 ~> k2) x = f @@ x

infixr 0 -?>
type (-?>) (k1 :: Type) (k2 :: Type) (arr :: FunArrow) = Fun k1 arr k2

type family ElimBool (p :: Bool -> Type)
                     (z :: Bool)
                     (pFalse :: p False)
                     (pTrue  :: p True)
            :: p z where
  -- Commenting out the line below makes the panic go away
  ElimBool p z pFalse pTrue = ElimBoolPoly (:->) p z pFalse pTrue

type family ElimBoolPoly (arr :: FunArrow)
                         (p :: (Bool -?> Type) arr)
                         (z :: Bool)
                         (pFalse :: App Bool arr Type p False)
                         (pTrue  :: App Bool arr Type p True)
            :: App Bool arr Type p z


{-# LANGUAGE DataKinds, PolyKinds #-}
module T14209 where

data MyProxy k (a :: k) = MyProxy
data Foo (z :: MyProxy k (a :: k))


{-# LANGUAGE PolyKinds #-}

module T124265 where

import Control.Monad.Trans.State( StateT )

f :: proxy _ -> ()
f _ = ()

foo :: StateT _ _ ()
foo = undefined


{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PolyKinds #-}
module T14270 (pattern App) where

import Data.Kind (Type)
import GHC.Fingerprint (Fingerprint, fingerprintFingerprints)
import GHC.Types (RuntimeRep, TYPE, TyCon)

data (a :: k1) :~~: (b :: k2) where
  HRefl :: a :~~: a

data TypeRep (a :: k) where
    TrTyCon :: {-# UNPACK #-} !Fingerprint -> !TyCon -> [SomeTypeRep]
            -> TypeRep (a :: k)

    TrApp   :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
               {-# UNPACK #-} !Fingerprint
            -> TypeRep (a :: k1 -> k2)
            -> TypeRep (b :: k1)
            -> TypeRep (a b)

    TrFun   :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                      (a :: TYPE r1) (b :: TYPE r2).
               {-# UNPACK #-} !Fingerprint
            -> TypeRep a
            -> TypeRep b
            -> TypeRep (a -> b)

data SomeTypeRep where
    SomeTypeRep :: forall k (a :: k). !(TypeRep a) -> SomeTypeRep

typeRepFingerprint :: TypeRep a -> Fingerprint
typeRepFingerprint = undefined

mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
           TypeRep (a :: k1 -> k2)
        -> TypeRep (b :: k1)
        -> TypeRep (a b)
mkTrApp rep@(TrApp _ (TrTyCon _ con _) (x :: TypeRep x)) (y :: TypeRep y)
  | con == funTyCon  -- cheap check first
  , Just (IsTYPE (rx :: TypeRep rx)) <- isTYPE (typeRepKind x)
  , Just (IsTYPE (ry :: TypeRep ry)) <- isTYPE (typeRepKind y)
  , Just HRefl <- withTypeable x $ withTypeable rx $ withTypeable ry
                  $ typeRep @((->) x :: TYPE ry -> Type) `eqTypeRep` rep
  = undefined
mkTrApp a b = TrApp fpr a b
  where
    fpr_a = typeRepFingerprint a
    fpr_b = typeRepFingerprint b
    fpr   = fingerprintFingerprints [fpr_a, fpr_b]

pattern App :: forall k2 (t :: k2). ()
            => forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b)
            => TypeRep a -> TypeRep b -> TypeRep t
pattern App f x <- (splitApp -> Just (IsApp f x))
  where App f x = mkTrApp f x

data IsApp (a :: k) where
    IsApp :: forall k k' (f :: k' -> k) (x :: k'). ()
          => TypeRep f -> TypeRep x -> IsApp (f x)

splitApp :: forall k (a :: k). ()
         => TypeRep a
         -> Maybe (IsApp a)
splitApp (TrApp _ f x)     = Just (IsApp f x)
splitApp rep@(TrFun _ a b) = Just (IsApp (mkTrApp arr a) b)
  where arr = bareArrow rep
splitApp (TrTyCon{})       = Nothing

withTypeable :: forall a r. TypeRep a -> (Typeable a => r) -> r
withTypeable = undefined

eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2).
             TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep = undefined

typeRepKind :: TypeRep (a :: k) -> TypeRep k
typeRepKind = undefined

bareArrow :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                    (a :: TYPE r1) (b :: TYPE r2). ()
          => TypeRep (a -> b)
          -> TypeRep ((->) :: TYPE r1 -> TYPE r2 -> Type)
bareArrow = undefined

data IsTYPE (a :: Type) where
    IsTYPE :: forall (r :: RuntimeRep). TypeRep r -> IsTYPE (TYPE r)

isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a)
isTYPE = undefined

class Typeable (a :: k) where

typeRep :: Typeable a => TypeRep a
typeRep = undefined

funTyCon :: TyCon
funTyCon = undefined

instance (Typeable f, Typeable a) => Typeable (f a)
instance Typeable ((->) :: TYPE r -> TYPE s -> Type)
instance Typeable TYPE


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

module T14450 where

import Data.Kind

data TyFun :: Type -> Type -> Type

type a ~> b = TyFun a b -> Type

type Cat ob = ob -> ob -> Type

type SameKind (a :: k) (b :: k) = (() :: Constraint)

type family Apply (f :: a ~> b) (x :: a) :: b where
  Apply IddSym0 x = Idd x

class Varpi (f :: i ~> j) where
  type Dom (f :: i ~> j) :: Cat i
  type Cod (f :: i ~> j) :: Cat j

  varpa :: Dom f a a' -> Cod f (Apply f a) (Apply f a')

type family Idd (a::k) :: k where
  Idd (a::k) = a

data IddSym0 :: k ~> k where
  IddSym0KindInference :: IddSym0 l

instance Varpi (IddSym0 :: k ~> k) where
  type Dom (IddSym0 :: Type ~> Type) = (->)


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

import Data.Kind

type HRank1 ty = forall k1. k1 -> ty
type HRank2 ty = forall k2. k2 -> ty

data HREFL11 :: HRank1 (HRank1 Type) -- FAILS
data HREFL12 :: HRank1 (HRank2 Type)
data HREFL21 :: HRank2 (HRank1 Type)
data HREFL22 :: HRank2 (HRank2 Type) -- FAILS


{-# Language DataKinds, PolyKinds, TypeFamilies, TypeOperators, AllowAmbiguousTypes #-}

module T14520 where

import Data.Kind

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

data family Sing (a::k)

type family XXX (f::a~>>b) (x::a) :: b

type family Id   :: (kat :: a ~>> (a ~>> Type)) `XXX` (b :: a) `XXX` b

sId :: Sing w -> Sing (Id :: bat w w)
sId = sId


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

module T14555 where

import Data.Kind
import GHC.Types (TYPE, Type)

data Exp :: [TYPE rep] -> TYPE rep -> Type where
--data Exp (x :: [TYPE rep]) (y :: TYPE rep) where
--data Exp (x :: [TYPE rep]) y where
  Lam :: Exp (a:xs) b -> Exp xs (a -> b)


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE MagicHash #-}

module T14561 where

import GHC.Types
import GHC.Prim

badId :: forall r (a :: TYPE r). a -> a
badId = unsafeCoerce#
-- Un-saturated application of a levity-polymorphic
-- function that must be eta-expanded

goodId :: forall (a :: Type). a -> a
goodId = unsafeCoerce#
-- But this one is OK


{-# Language RankNTypes, KindSignatures, PolyKinds #-}
{-# OPTIONS_GHC -fprint-explicit-runtime-reps #-}

import GHC.Types (TYPE)
import Data.Kind

data Lan (g::TYPE rep -> TYPE rep') (h::TYPE rep -> TYPE rep'') a where
  Lan :: forall rep rep' xx (g::TYPE rep -> TYPE rep') (h::TYPE rep -> Type) a.
         (g xx -> a) -> h xx -> Lan g h a


{-# LANGUAGE PolyKinds, DataKinds, TypeOperators #-}
module T14580 where
import Data.Kind

type Cat ob = ob -> ob -> Type
data ISO' :: Cat i -> i -> i -> Type
type ISO cat a b = ISO' cat a b -> Type
type (a <--> b) iso cat = ISO (iso :: cat a b)


{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module T14710 where

import Data.Proxy

class C a b where
  c1 :: Proxy (x :: a) -> b
  c2 :: forall (x :: a). Proxy x -> b

f :: forall a. a -> a
f x = const x (const g1 g2)
  where
    g1 :: Proxy (x :: a)
    g1 = Proxy

    g2 :: forall (x :: a). Proxy x
    g2 = Proxy

h1 :: forall k a. Proxy (a :: k)
h1 = Proxy

h2 :: forall k (a :: k). Proxy a
h2 = Proxy


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module T14723 () where

import Data.Coerce( coerce )
import Data.Kind (Type)
import Data.Proxy (Proxy(..))
import Data.String (fromString)
import Data.Int (Int64)
import GHC.Stack (HasCallStack)
import GHC.TypeLits (Nat, Symbol)

data JType = Iface Symbol

data J (a :: JType)

newIterator
  :: IO (J ('Iface "java.util.Iterator"))
newIterator = do
    let tblPtr :: Int64
        tblPtr = undefined
    iterator <-
         (qqMarker (Proxy :: Proxy "wuggle")
                   (Proxy :: Proxy "waggle")
                   (Proxy :: Proxy "tblPtr")
                   (Proxy :: Proxy 106)
                   (tblPtr, ())
                   Proxy
                   (undefined :: IO Int))
    undefined

class Coercible (a :: Type) where
  type Ty a :: JType

instance Coercible Int64 where
  type Ty Int64 = Iface "Int64"
instance Coercible Int where
  type Ty Int = Iface "Int"

class Coercibles xs (tys :: k) | xs -> tys
instance Coercibles () ()
instance (ty ~ Ty x, Coercible x, Coercibles xs tys) => Coercibles (x, xs) '(ty, tys)

qqMarker
  :: forall
     k                   -- the kind variable shows up in Core
     (args_tys :: k)     -- JType's of arguments
     tyres               -- JType of result
     (input :: Symbol)   -- input string of the quasiquoter
     (mname :: Symbol)   -- name of the method to generate
     (antiqs :: Symbol)  -- antiquoted variables as a comma-separated list
     (line :: Nat)       -- line number of the quasiquotation
     args_tuple          -- uncoerced argument types
     b.                  -- uncoerced result type
     (tyres ~ Ty b, Coercibles args_tuple args_tys, Coercible b, HasCallStack)
  => Proxy input
  -> Proxy mname
  -> Proxy antiqs
  -> Proxy line
  -> args_tuple
  -> Proxy args_tys
  -> IO b
  -> IO b
qqMarker = undefined


{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
module T14846 where

import Data.Kind
import Data.Proxy

type Cat ob = ob -> ob -> Type

data Struct :: (k -> Constraint) -> Type where
  S :: Proxy (a::k) -> Struct (cls::k -> Constraint)

type Structured a cls = (S ('Proxy :: Proxy a)::Struct cls)

data AStruct :: Struct cls -> Type where
  AStruct :: cls a => AStruct (Structured a cls)

class StructI xx (structured::Struct (cls :: k -> Constraint)) where
  struct :: AStruct structured

instance (Structured xx cls ~ structured, cls xx) => StructI xx structured where
  struct :: AStruct (Structured xx cls)
  struct = AStruct

data Hom :: Cat k -> Cat (Struct cls) where

class Category (cat::Cat ob) where
  i :: StructI xx a => rÃki a a

instance Category riki => Category (Hom riki :: Cat (Struct cls)) where
  i :: forall xx a. StructI xx a => Hom riki a a
  i = case struct :: AStruct (Structured a cls) of


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

data Proxy k (a :: k) = MkProxy
data Proxy2 k a = MkP (Proxy k a)

data Proxy2' k a where
  MkP' :: Proxy k a -> Proxy2' k a

data T a where
  T :: Int -> T Bool

type family F a where
  F Int = True
  F _   = False


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
module T14873 where

import Data.Kind (Type)

data family Sing (a :: k)

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

data TyFun :: Type -> Type -> Type
type a ~> b = TyFun a b -> Type
infixr 0 ~>
type family Apply (f :: k1 ~> k2) (x :: k1) :: k2

class SingI (a :: k) where
  sing :: Sing a

data ColSym1 :: f a -> a ~> Bool
type instance Apply (ColSym1 x) y = Col x y

class PColumn (f :: Type -> Type) where
  type Col (x :: f a) (y :: a) :: Bool

class SColumn (f :: Type -> Type) where
  sCol :: forall a (x :: f a) (y :: a).
    Sing x -> Sing y -> Sing (Col x y :: Bool)

instance (SColumn f, SingI x) => SingI (ColSym1 (x :: f a) :: a ~> Bool) where
  sing = SLambda (sCol (sing @_ @x))

{-  When the bug was present, this smaller kind-incorrect version also
    elicited the same piResultTy crash

    But it's kind-incorrect, whereas the main test case should compile file

class SingI (a :: k) where

class SColumn (f :: Type -> Type) where

instance -- forall (f :: Type -> Type) a (x :: f a).
         SColumn f => SingI (x :: f a)
-}


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeInType #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
module Bug where

import Data.Proxy

f2 :: forall a (x :: a). Proxy (x :: _)
f2 = Proxy


{-# Language RankNTypes, ConstraintKinds, TypeInType, GADTs #-}

module T14939 where

import Data.Kind

type Cat ob = ob -> ob -> Type

type Alg cls ob = ob

newtype FrÃ (cls::Type -> Constraint) :: (Type -> Alg cls Type) where
  FrÃ :: { with :: forall x. cls x => (a -> x) -> x }
      -> FrÃ cls a

data AlgCat (cls::Type -> Constraint) :: Cat (Alg cls Type) where
  AlgCat :: (cls a, cls b) => (a -> b) -> AlgCat cls a b

leftAdj :: AlgCat cls (FrÃ cls a) b -> (a -> b)
leftAdj (AlgCat f) a = undefined


{-# LANGUAGE GADTs, PolyKinds, DataKinds #-}
module T15116 where

import Data.Proxy

data A (a :: k) where
  MkA :: A MkA


{-# LANGUAGE PolyKinds, DataKinds #-}
module T15116a where

import Data.Proxy

data B = MkB (Proxy 'MkB)


{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
module T15170  where

import Data.Kind
import Data.Proxy

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

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

wat :: forall (a :: Type)
              (b :: a ~> Type)
              (c :: forall (x :: a). Proxy x ~> b @@ x ~> Type)
              (f :: forall (x :: a) (y :: b @@ x). Proxy x ~> Proxy y ~> c @@ ('Proxy :: Proxy x) @@ y)
              (x :: a).
      (forall (xx :: a) (yy :: b @@ xx). Proxy (f @@ ('Proxy :: Proxy xx) @@ ('Proxy :: Proxy yy)))
   -> ()
wat _ = ()


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
module Bug where

import Data.Kind
import Data.Proxy
import Data.Type.Equality

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

f :: forall k (f :: k -> Type) (a :: k) (r :: f a). Proxy r -> F r :~: r
f = undefined

g :: forall (f :: Type -> Type) (a :: Type) (r :: f a). Proxy r -> F r :~: r
g r | Refl <- f -- Uncommenting the line below makes it work again
                -- @Type
                @f @a @r r
    = Refl


{-# LANGUAGE PolyKinds, TypeFamilies #-}
{-# OPTIONS_GHC -ddump-types -fprint-explicit-foralls #-}
module T15592 where

data T f (a::k1) b = MkT (f a b) (T f a b)


{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
module T15592b where

import Data.Kind

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


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

import Data.Kind

class RÃki (ob :: Type) where
 type Hom :: ob -> ob -> Type

data
  Kl_kind :: forall ob . (ob -> ob) -> ob -> Type where
  Kl      :: k -> Kl_kind (m :: ob -> ob) k

type family
  UnKl (kl :: Kl_kind m k) = (res :: k) where
  UnKl (Kl a) = a


{-# Language LiberalTypeSynonyms #-}
{-# Language PolyKinds           #-}
{-# Language RankNTypes          #-}
{-# Language DataKinds           #-}

import Data.Kind

type Cat ob = ob -> ob -> Type

data Zero :: forall (cat :: forall xx. xx -> Type) a. forall b. Cat (forall b. cat b u)


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
module T15795 where

import Data.Kind

type KindOf (a :: k) = k

data T :: forall j (a :: j). KindOf a -> Type where
  MkT :: forall k (b :: k). T b

f :: forall k (b :: k). T b
f = error "urk"


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

module T15795a where
import Data.Kind

data F :: forall (cat1 :: ob1). ob1 -> Type where
  Prod :: F (a :: u)


{-# Language PolyKinds #-}

module T15804 where

data T :: (a :: k) -> *


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

module T15817 where

import Data.Kind

data family   X :: forall (a :: Type). Type
data instance X = MkX


{-# Language RankNTypes   #-}
{-# Language DataKinds    #-}
{-# Language PolyKinds    #-}
{-# Language GADTs        #-}
{-# Language TypeFamilies #-}

module T15874 where

import Data.Kind

data Var where
  Op :: Var
  Id :: Var

type Varianced = (forall (var :: Var). Type)

data family   Parser :: Varianced
data instance Parser = P


{-# Language KindSignatures #-}
{-# Language PolyKinds      #-}

module T15881 where

import Data.Kind

data A n (a :: n n) :: Type


{-# Language KindSignatures #-}
{-# Language PolyKinds      #-}

module T15881a where

import Data.Kind

data A n (a :: n) :: a -> Type


{-# LANGUAGE GADTs, TypeInType, ExistentialQuantification #-}

module T16221 where

-- Failed Lint
data T3 a = forall k (b :: k). MkT3 (T3 b) !Int

-- Works with GADT
data T4 a where
   MkT4 :: T4 b -> !Int -> T4 a

-- Works with CUSK
data T5 (a :: j) = forall k (b :: k). MkT5 (T5 b) !Int


{-# LANGUAGE TypeInType, ExistentialQuantification #-}

module T16221a where

data SameKind :: k -> k -> *
data T2 a = forall k (b :: k). MkT2 (SameKind a b) !Int


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

module T16263 where

import Data.Kind

data Q :: Eq a => Type where {}


{-# LANGUAGE MultiParamTypeClasses, TypeInType, ConstrainedClassMethods, ScopedTypeVariables #-}

module T16342 where

import Data.Proxy

class C (a::ka) x where
  cop :: D a x => x -> Proxy a -> Proxy a
  cop _ x = x :: Proxy (a::ka)

class D (b::kb) y where
  dop :: C b y => y -> Proxy b -> Proxy b
  dop _ x = x :: Proxy (b::kb)


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

module T5716 where

import Data.Kind (Type)

data family DF a
data instance DF Int = DFInt

data U = U1 (DF Int)

data I :: U -> Type where I1 :: I (U1 DFInt)


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

module T5716a where

data family DF a
data instance DF a = Bar (Bar a)


{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE PolyKinds                  #-}

module T5717 where

data TypeRep = TypeRep

data Proxy t = Proxy

typeRep :: Proxy a -> TypeRep
typeRep Proxy = TypeRep

-- This one works fine:
typeOf :: forall a. a -> TypeRep
typeOf _ = typeRep (Proxy :: Proxy a)

-- But this one panics!
typeOf1 :: forall t a. t a -> TypeRep
typeOf1 _ = typeRep (Proxy :: Proxy t)


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

module T5770 where

convert :: a -> b
convert = convert

type family Foo a
type instance Foo Int = Bool

barT5770 :: forall a b c dummya. (b -> c) -> Foo a -> a
barT5770 f = (convert f :: Foo a -> a)

barT5769 :: forall b a. b -> (a, Foo a)
barT5769 f = (convert f :: (a, Foo a))

barT5768 :: forall a b. b -> (a, Foo a)
barT5768 f = (convert f :: (a, Foo a))


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

module T5771 where

class IndexedMonad m where
  unit :: a -> m i i a
  bind :: m i j a -> (a -> m j k b) -> m i k b

newtype IndexedIO i j a = IndexedIO {runIndexedIO :: IO a}

-- i and j are both *; instance is accepted
instance IndexedMonad IndexedIO where
  unit = IndexedIO . return
  bind m k = IndexedIO $ runIndexedIO m >>= runIndexedIO . k
infixl 1 `bind`

data HList xs where
  N    :: HList '[]
  (:>) :: a -> HList as -> HList (a ': as)
infixr 5 :>

newtype HLState xs ys a = HLState {runHLState :: HList xs -> (a, HList ys)}

-- i and j are now [*]; rejected with the MPTCs message
instance IndexedMonad HLState where
  unit x = HLState $ \s -> (x, s)
  bind (HLState f) k = HLState $ \xs ->
    case f xs of (a, ys) -> runHLState (k a) ys


{-# LANGUAGE PolyKinds, DataKinds #-}

module T5798 where

data Proxy t = ProxyC

test :: Proxy '[Int, Bool]
test = ProxyC


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

module T5862 where

import Data.Kind (Type)

data Nat = Zero | Succ Nat

data SNat a where
  SZero :: SNat 'Zero
  SSucc :: SNat n -> SNat ('Succ n)

data SBool a where
  SFalse :: SBool 'False
  STrue :: SBool 'True

data SMaybe a where
  SNothing :: SMaybe 'Nothing
  SJust :: Sing a -> SMaybe ('Just a)

type family Sing (a :: k)
type instance Sing (a :: Nat) = SNat a
type instance Sing (a :: Bool) = SBool a
type instance Sing (a :: Maybe Type) = SMaybe a -- want to say Maybe k


module T5881 where

import T5881a (T')

type DOne = T'


{-# LANGUAGE DataKinds #-}
module T5881a where
data K = T
type T' = T


{-# LANGUAGE DataKinds #-}

-- This bug related to type trimming, and
-- hence showed up only with -O0

module Bug() where

data UnaryTypeC a = UnaryDataC a

type Bug = 'UnaryDataC


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

module T5935 where

data SList a where
  SNil :: SList '[]

x :: SList ('[] :: [Bool])
x = SNil


{-# LANGUAGE PolyKinds, KindSignatures, DataKinds, GADTs #-}
module T5937 where

import Data.Kind (Type)

data SMaybe :: (k -> Type) -> Maybe k -> Type where
   SNothing :: SMaybe s 'Nothing
   SJust :: s a -> SMaybe s ('Just a)


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

import Data.Kind (Type)

type family KindFam (a :: k)
type instance KindFam (a :: Type) = Int
type instance KindFam (a :: Bool) = Bool
type instance KindFam (a :: Maybe k) = Char -- doesn't work


{-# LANGUAGE DataKinds, TypeOperators #-}

module T5948 where

type Foo = (Int ': '[])

type Bar = Int ': '[]


-- This module should compile with -XIncoherentInstances, but didn't in 7.4

{- Here we define all the stuff that is needed for our singleton
   types:
 - phantom types (when GHC 7.4 arrives, the user-defined kinds)
 - corresponding singleton types

These are basically the constructs from Omega,
reimplemented in Haskell for our purposes. -}

{-# LANGUAGE GADTs, KindSignatures, StandaloneDeriving,
             RankNTypes, TypeFamilies, FlexibleInstances, IncoherentInstances #-}
module TypeMachinery where

import Data.Kind (Type)

-- The natural numbers:
--  o first the phantom types

data Z; data S n

-- o the using the above the singleton type Nat'

data Nat' :: Type -> Type where
  Z :: Nat' Z
  S :: Nat' n -> Nat' (S n)

deriving instance Show (Nat' a)

-- Type-level addition

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

-- Nat' addition

plus :: Nat' a -> Nat' b -> Nat' (Plus a b)
plus Z n = n
plus (S m) n = S (plus m n)

-- Equality on Nat'

sameNat' :: Nat' a -> Nat' b -> Bool
sameNat' Z Z = True
sameNat' (S m) (S n) = sameNat' m n
sameNat' _ _ = False

-- A data type for existentially hiding
-- (e.g.) Nat' values

data Hidden :: (Type -> Type) -> Type where
  Hide :: Show (a n) => a n -> Hidden a

deriving instance Show (Hidden t)

toNat' :: Integral i => i -> Hidden Nat'
toNat' 0 = Hide Z
toNat' n = case toNat' (n - 1) of
           Hide n -> Hide (S n)

-- Now we are ready to make Hidden Nat' an Integral type

instance Eq (Hidden Nat') where
  Hide a == Hide b = sameNat' a b

instance Ord (Hidden Nat') where
  Hide Z `compare` Hide Z = EQ
  Hide Z `compare` Hide _ = LT
  Hide _ `compare` Hide Z = GT
  Hide (S m) `compare` Hide (S n) = Hide m `compare` Hide n

instance Enum (Hidden Nat') where
  toEnum = toEnum . fromIntegral
  fromEnum = fromIntegral

instance Num (Hidden Nat') where
  fromInteger = toNat'
  signum (Hide Z) = 0
  signum _ = 1
  abs n = n
  Hide a + Hide b = Hide $ plus a b
  a * b = fromInteger $ toInteger a * toInteger b
  negate a = error "negate(Hidden Nat')"

instance Real (Hidden Nat') where
  toRational = toRational . toInteger

instance Integral (Hidden Nat') where
  toInteger (Hide Z) = 0
  toInteger (Hide (S n)) = 1 + toInteger (Hide n)
  quotRem a b = let (a', b') = toInteger a `quotRem` toInteger b in (fromInteger a', fromInteger b')

-- McBride's Fin data type. By counting backwards from the
-- result index, it only admits a fixed number of inhabitants.

data Fin :: Type -> Type where
    Stop :: Fin (S Z)
    Retreat :: Fin s -> Fin (S s)

deriving instance Show (Fin a)


{-# LANGUAGE DataKinds, MultiParamTypeClasses, FunctionalDependencies,
             PolyKinds, UndecidableInstances, ScopedTypeVariables #-}

module T6015 where

data Proxy a = Proxy

class Value a t | a -> t where value :: Proxy a -> t

instance Value True Bool where value _ = True

instance Value a t => Value (Just a) (Maybe t)
    where value _ = Just (value (Proxy :: Proxy a))

test = value (Proxy :: Proxy (Just True))


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE PolyKinds, KindSignatures, FunctionalDependencies,  FlexibleInstances,
              UndecidableInstances, TypeOperators, DataKinds,  FlexibleContexts #-}

module T6015a where

import Prelude hiding ((++))

data T a = T

class ((a :: [k]) ++ (b :: [k])) (c :: [k]) | a b -> c
instance ('[] ++ b) b
instance (a ++ b) c => ((x ': a) ++ b) (x ': c)

test = T :: ('[True] ++ '[]) l => T l


{-# LANGUAGE DataKinds, FunctionalDependencies, FlexibleInstances,
             UndecidableInstances, PolyKinds, KindSignatures,
             ConstraintKinds, FlexibleContexts #-}

module T6020 where

class Id (a :: k) (b :: k) | a -> b
instance Id a a

f :: Id x y => x -> y
f = f

--class Test (x :: a) (y :: a) | x -> y
--instance (Id x y, Id y z) => Test x z

-- (Id x0 y0, Id y0 z0, x~x0, z~z0)
-- (Id x y0, Id y0 z, y0~z, y0~y)

--test :: Test True True => ()
--test = ()


{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
{-# LANGUAGE DataKinds, FunctionalDependencies, FlexibleInstances,
              UndecidableInstances, PolyKinds, KindSignatures,
              ConstraintKinds, FlexibleContexts, GADTs #-}

module T6020a where

class Id (a :: k) (b :: k) | b -> a
instance a ~ b => Id a b

class Test (x :: a) (y :: a)
instance (Id x y, Id y z) => Test x z
-- Weird test case: (Id x y) and (Id y z) are both simplifiable

test :: Test True True => ()
-- Weird test case: (Test True True) is simplifiable
test = ()


{-# LANGUAGE KindSignatures, PolyKinds, MultiParamTypeClasses, FlexibleInstances #-}
module T6021 where

class Panic a b
instance Panic (a :: b) b


module T6025 where

import T6025a

other = OTrue


{-# LANGUAGE DataKinds, GADTs #-}
module T6025a (Other (..)) where

data Other a where
  OTrue :: Other True
  OFalse :: Other False


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

module T6035 where

import Data.Kind (Type)

data Nat = Zero | Succ Nat

type family Sing (a :: k) :: k -> Type

data SNat n where
  SZero :: SNat Zero
  SSucc :: SNat n -> SNat (Succ n)

data SList (a :: [k]) where
  SNil :: SList '[]
  SCons :: Sing h h -> SList t -> SList (h ': t)

type instance Sing (a :: Nat) = SNat
type instance Sing (a :: [k]) = SList

nil :: SList '[]
nil = SNil

zero :: SList '[ '[] ]
zero = SCons SNil SNil

term :: SList '[ '[Zero], '[]]
term = SCons (SCons SZero SNil) (SCons SNil SNil)


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

module T6036 where

data family Sing (a :: k)

data instance Sing (a :: Maybe k) where
  SNothing :: Sing 'Nothing
  SJust :: Sing b -> Sing ('Just b)

data Nat = Zero | Succ Nat

data instance Sing (a :: Nat) where
  SZero :: Sing Zero
  SSucc :: Sing n -> Sing (Succ n)

term = SJust SZero


{-# LANGUAGE PolyKinds, KindSignatures #-}

module Foo where

data T (a :: j k) = MkT


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

module T6044 where

type family Foo (a :: k) :: Maybe k
type instance Foo a = Just a


{-# LANGUAGE DataKinds, KindSignatures, PolyKinds, GADTs,  ExistentialQuantification #-}

module T6049 where

import Data.Kind (Type)

data SMaybe :: (k -> Type) -> Maybe k -> Type where
   SNothing :: forall k (s :: k -> Type). SMaybe s Nothing
   SJust :: forall k (s :: k -> Type) (a :: k). SMaybe s (Just a)


{-# LANGUAGE FlexibleContexts, DataKinds #-}

module T6054 where

import T6054a

foo = print (Proxy :: Bar '() a => Proxy a)


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

module T6054a where

class Bar a (p :: Bool) | a -> p
data Proxy a = Proxy deriving Show


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, GADTs, MultiParamTypeClasses, KindSignatures,
             FunctionalDependencies, FlexibleInstances, UndecidableInstances, ExistentialQuantification #-}

module T6068 where

import Prelude hiding (Maybe, Nothing)
import Data.Kind (Type)

data Maybe :: Type -> Type where
  Nothing :: Maybe a

data family Sing (a :: k)

data instance Sing (a :: Maybe k) where
  SNothing :: Sing Nothing

data KProxy (a :: Type) = KProxy
data Existential (p :: KProxy k) =
  forall (a :: k). Exists (Sing a)

class HasSingleton a (kp :: KProxy k) | a -> kp where
  exists :: a -> Existential kp

class Floop a b | a -> b

instance Floop a (mp :: KProxy (Maybe ak)) => HasSingleton (Maybe a) mp where
  exists Nothing = Exists SNothing

-- instance forall (a ::Type) (mp :: KProxy (Maybe ak)).
--          HasSingleton (Maybe ak) (Maybe a) mp where
--   exists Nothing = Exists SNothing


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

module T6081 where

import Data.Kind (Type)

data KProxy (a :: Type) = KP

class KindClass (kp :: KProxy k)
instance KindClass (KP :: KProxy [k])


{-# LANGUAGE GADTs, RankNTypes, PolyKinds #-}
module T6093 where

import qualified Data.Kind as K (Type)

-- Polymorphic kind recursion
data R :: forall k. k -> K.Type where
    MkR :: R f -> R (f ())

data IOWitness (a :: k) = IOW

data Type :: forall k. k -> K.Type where
  SimpleType :: IOWitness a -> Type a
  ConstructedType :: Type f -> Type a -> Type (f a)


{-# LANGUAGE PolyKinds, DataKinds, KindSignatures, RankNTypes,
             TypeFamilies, FlexibleInstances, UndecidableInstances #-}

module T6118 where

import GHC.Exts (Any)
import Data.Kind (Type)

data Nat = Zero | Succ Nat
data List a = Nil | Cons a (List a)

class SingE (a :: k) where
  type Demote a :: Type

instance SingE (a :: Bool) where
  type Demote a = Bool
instance SingE (a :: Nat) where
  type Demote a = Nat

instance SingE (a :: Maybe k) where
  type Demote (a :: Maybe k) = Maybe (Demote (Any :: k))

instance SingE (a :: List k) where
  type Demote (a :: List k) = List (Demote (Any :: k))


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

module T6129 where

data family D a
data instance D a = DInt

data X a where
  X1 :: X DInt


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

module T6137 where

import Data.Kind (Type)

data Sum a b = L a | R b

data Sum1 (a :: k1 -> Type) (b :: k2 -> Type) :: Sum k1 k2 -> Type where
  LL :: a i -> Sum1 a b (L i)
  RR :: b i -> Sum1 a b (R i)

data Code i o = F (Code (Sum i o) o)

-- An interpretation for `Code` using a data family works:
data family In (f :: Code i o) :: (i -> Type) -> (o -> Type)

data instance In (F f) r x where
  MkIn :: In f (Sum1 r (In (F f) r)) x -> In (F f) r x

{- data R:InioFrx o i f r x where
     where  MkIn :: forall o i (f :: Code (Sum i o) o)
                               (r :: i -> Type)
                               (x :: o).
                    In (Sum i o) o f (Sum1 o i r (In i o ('F i o f) r)) x
                    -> R:InioFrx o i f r x

   So  R:InioFrx :: forall o i. Code i o -> (i -> Type) -> o -> Type

  data family In i o (f :: Code i o) (a :: i -> Type) (b :: o)

  axiom D:R:InioFrx0 ::
    forall o i (f :: Code (Sum i o) o).
      In i o ('F i o f) = R:InioFrx o i f

  D:R:InioFrx0 ::    R:InioFrx o i f ~ In i o ('F i o f)
-}
-- Requires polymorphic recursion
data In' (f :: Code i o) :: (i -> Type) -> o -> Type where
  MkIn' :: In' g (Sum1 r (In' (F g) r)) t -> In' (F g) r t


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

module T7020 where

import GHC.Exts

data family Sing (a :: k)

class SingKind (Any :: k) => SingI (s :: k) where
   sing :: Sing s

data SingInstance (a :: k) where
   SingInstance :: SingI a => SingInstance a

class (b ~ Any) => SingKind (b :: k) where
   singInstance :: forall (a :: k). Sing a -> SingInstance a


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

module T7022 where

import T7022b

foo :: SList a -> Bool
foo = undefined


{-# LANGUAGE TemplateHaskell #-}

module T7022a where

import Language.Haskell.TH

makeSList :: Q [Dec]
-- makes "type SList (a :: [k]) = Sing a"
makeSList = do
   a <- newName "a"
   k <- newName "k"
   return [TySynD (mkName "SList") [KindedTV a (AppT ListT (VarT k))]
                  (AppT (ConT (mkName "Sing")) (VarT a))]


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

module T7022b where

import T7022a

data family Sing (a :: k)

$( makeSList )


{-# LANGUAGE PolyKinds, GADTs #-}

module T7053 where

data TypeRep (a :: k) where
   TyApp   :: TypeRep a -> TypeRep b -> TypeRep (a b)


{-# LANGUAGE PolyKinds, GADTs #-}

module T7053a where

import Data.Kind (Type)

-- This time with a fully-specified kind signature
data TypeRep (a :: k) :: Type where
   TyApp   :: TypeRep a -> TypeRep b -> TypeRep (a b)


{-# LANGUAGE PolyKinds, TypeFamilies #-}

module T7073 where

class Foo a where
   type Bar a
   type Bar a = Int


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE GADTs, ConstraintKinds, TypeFamilies,
    DataKinds, ScopedTypeVariables, TypeOperators #-}

module T7090 where

import GHC.Exts

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

data Nat = Zero | Succ Nat

type family Plus (a :: Nat) (b :: Nat) :: Nat
type instance Plus Zero b = b
type instance Plus (Succ a) b = Succ (Plus a b)

type One = Succ Zero

type family (a :: Nat) :==: (b :: Nat) :: Bool

boolToProp :: (a :==: b) ~ True => Dict (a ~ b)
boolToProp = undefined

data T (n :: Nat) = MkT

foo :: forall n. (Succ n :==: Plus n One) ~ True => T n
foo = case (boolToProp :: Dict (Succ n ~ Plus n One)) of
           Dict -> MkT


{-# LANGUAGE DataKinds, TypeOperators, PolyKinds, FlexibleInstances, FlexibleContexts #-}

module T7095 where

data Wrapped t = Wrapped

class Len l where
    len :: l -> Int

instance Len (Wrapped '[]) where
    len = const 0

instance (Len (Wrapped xs)) => Len (Wrapped (x ': xs)) where
    len x = 1 + (len $ wrappedTail x)

wrappedTail :: Wrapped (x ': xs) -> Wrapped xs
wrappedTail = const Wrapped

-- | test1 == zero just as excepted.
test1 = len (undefined  :: Wrapped '[])

-- | Since I have typeclasses defined for Wrapped (* ': [*]) and for (Wrapped '[])
-- I except to get 1 here, but this does not typecheck with following  message:
-- No instance for (Len (Wrapped [*] ([] *)))
test2 = len (undefined  :: Wrapped '[Int])


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

module T7128 where

class Foo a (b :: k) | a -> k
instance Foo Bool False


module T7151 where

type Foo = [Int, String]


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

module T7176 where

type family Sing (a :: b)

data SMaybe (a :: Maybe c) where
   SNothing :: SMaybe Nothing
   SJust :: Sing a -> SMaybe (Just a)
type instance Sing (a :: Maybe d) = SMaybe a

sIsJust :: forall e (a :: Maybe e). Sing a -> ()
sIsJust SNothing = ()
sIsJust (SJust _) = ()


{-# LANGUAGE PolyKinds #-}

module T7224 where

class PMonad' (m :: i -> i -> * -> *) where
  ret'  :: a -> m i i a
  bind' :: m i j a -> (a -> m j k b) -> m i k b


{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeFamilies #-}
{-# LANGUAGE TypeOperators, UndecidableInstances #-}
module T7230 where

data Nat = Zero | Succ Nat deriving (Show, Eq, Ord)

data family Sing (x :: k)

data instance Sing (n :: Nat) where
  SZero :: Sing Zero
  SSucc :: Sing n -> Sing (Succ n)

type SNat (n :: Nat) = Sing n

data instance Sing (b :: Bool) where
  STrue  :: Sing True
  SFalse :: Sing False

type SBool (b :: Bool) = Sing b

data instance Sing (xs :: [k]) where
  SNil  :: Sing ('[] :: [k])
  SCons :: Sing x -> Sing xs -> Sing (x ': xs)

type SList (xs :: [k]) = Sing (xs :: [k])

type family (:<<=) (n :: Nat) (m :: Nat) :: Bool
type instance Zero   :<<= n      = True
type instance Succ n :<<= Zero   = False
type instance Succ n :<<= Succ m = n :<<= m

(%:<<=) :: SNat n -> SNat m -> SBool (n :<<= m)
SZero   %:<<= _       = STrue
SSucc _ %:<<= SZero   = SFalse
SSucc n %:<<= SSucc m = n %:<<= m

type family   (b :: Bool) :&& (b' :: Bool) :: Bool
type instance True  :&& b = b
type instance False :&& b = False

type family   Increasing (xs :: [Nat]) :: Bool
type instance Increasing '[]  = True
type instance Increasing '[n] = True
type instance Increasing (n ': m ': ns) = n :<<= m :&& Increasing (m ': ns)

crash :: (Increasing xs) ~ True => SList xs -> SBool (Increasing xs)
crash (SCons x (SCons y xs)) = x %:<<= y
crash _                      = STrue


{-# LANGUAGE ConstraintKinds, TypeFamilies #-}
module T7238 where

import GHC.Exts

class Pair p where
        type Ctxt p a :: Constraint
        l :: Ctxt p a => p a -> a

data Unit a = Unit

instance Pair Unit where
        type Ctxt Unit a = a ~ ()
        l _ = ()


{-# LANGUAGE PolyKinds #-}

module T7272 where

import T7272a

class C (a :: k)


{-# LANGUAGE PolyKinds #-}

module T7272a where

import {-# SOURCE #-} T7272


{-# LANGUAGE TypeFamilies, PolyKinds, MultiParamTypeClasses, FlexibleContexts,
             AllowAmbiguousTypes #-}
module T7278 where

type family TF (t  :: k) :: * -> * -> *

class C (t :: k) (dcs :: * -> * -> *)

f :: (C (t :: k) (TF t)) => TF t p1 p0 -> t p1 p0
f = undefined -- panic caused by (t :: k) in the signature's context


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

module T7328 where

data Proxy a

class Foo a where
    foo :: a ~ f i => Proxy (Foo f)


{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}

module T7332 where

import GHC.Exts( IsString(..) )
import Data.Kind (Type)
import Data.Monoid
import Data.Semigroup

newtype DC d = DC d
    deriving (Show, Semigroup, Monoid)

instance IsString (DC String) where
    fromString = DC

class Monoid acc => Build acc r where
    type BuildR r :: Type       -- Result type
    build :: (acc -> BuildR r) -> acc -> r

instance Monoid dc => Build dc (DC dx) where
    type BuildR (DC dx) = DC dx
    build tr acc = tr acc

instance (Build dc r, a ~ dc) => Build dc (a->r) where
    type BuildR (a->r) = BuildR r
    build tr acc s = build tr (acc `mappend` s)

-- The type is inferred
-- tspan :: (Monoid d, Build (DC d) r, BuildR r ~ DC d) => r
tspan :: (Build (DC d) r, BuildR r ~ DC d) => r
tspan = build (id :: DC d -> DC d) mempty

{- Solving 'tspan'

Given:    Build (DC d) r, BuildR r ~ DC d
 (by sc)  Monoid (DC d)

   Wanted:
       Build acc0 r0
       Monid acc0
       acc0 ~ DC d0
       DC d0 ~ BuildR r0
       r ~ r0
==>
       Build (DC d0) r
       Monoid (DC d0)  -->  Monoid d0
       DC d0 ~ BuildR r

From Given: BuildR r = DC d, hence
       DC d0 ~ DC d
hence
       d0 ~ d

===>
       Build (DC d) r
       Monoid (DC d)

Now things are delicate.  Either the instance Monoid (DC d) will fire or,
if we are lucky, we might spot that (Monoid (DC d)) is a superclass of
a given.  But now (Decl 15) we add superclasses lazily, so that is less
likely to happen, and was always fragile.  So include (Monoid d) in the
signature, as was the case in the original ticket.
-}

foo = tspan "aa"

foo1 = tspan (tspan "aa")

bar = tspan "aa" :: DC String