{-# LANGUAGE TypeFamilies, ScopedTypeVariables#-}

module T3220 where

import Data.Kind (Type)

class Foo m where
    type Bar m :: Type
    action :: m -> Bar m -> m

right x m = action m (Right x)

right' :: (Either a b ~ Bar m, Foo m) => b -> m -> m
right' x m = action m (Right x)

instance Foo Int where
    type Bar Int = Either Int Int
    action m a = either (*) (+) a m

instance Foo Float where
    type Bar Float = Either Float Float
    action m a = either (*) (+) a m

foo = print $ right (1::Int) (3 :: Int)
bar = print $ right (1::Float) (3 :: Float)


{-# LANGUAGE TypeFamilies, DatatypeContexts #-}
module T3418 where

newtype (a ~ b) => S a b = S { unS :: a }


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

module T3423 where

newtype Trie m k a = Trie (Maybe a, m (SubKey k) (Trie m k a))

type family SubKey k
type instance SubKey [k] = k

deriving instance (Eq (m k (Trie m [k] a)), Eq a)
               => Eq (Trie m [k] a)


{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
module T3460 where

class Nat n where
    toInt :: n -> Int

class (Nat (Arity f)) => Model f where
    type Arity f

ok :: Model f => f -> Arity f -> Int
ok _ n = toInt n

bug :: (Model f, Arity f ~ n) => f -> n -> Int
bug _ n = toInt n


{-# OPTIONS_GHC -Wall -fno-warn-redundant-constraints #-}
{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, FlexibleContexts, ScopedTypeVariables #-}

module Absurd where

data Z = Z
newtype S n = S n
class Nat n where
   caseNat :: (n ~ Z => r) -> (forall p. (n ~ S p, Nat p) => p -> r) -> n -> r
instance Nat Z where
   caseNat _ _ = error "urk1"
instance Nat n => Nat (S n) where
   caseNat _ _ = error "urk2"

-- empty type
newtype Naught = Naught (forall a. a)
-- types are equal!
data TEq a b where
   TEq :: (a ~ b) => TEq a b

type family NatEqProves m n
type instance NatEqProves (S m) (S n) = TEq m n

noConf :: (Nat m, Nat n) => m -> TEq m n -> NatEqProves m n
noConf = undefined
predEq :: TEq (S a) (S b) -> TEq a b
predEq = undefined

data IsEq a b = Yes (TEq a b) | No (TEq a b -> Naught)

natEqDec :: forall m n. (Nat m, Nat n) => m -> n -> IsEq m n
natEqDec m n = caseNat undefined mIsS m where
    mIsS :: forall pm. (m ~ S pm, Nat pm) => pm -> IsEq m n
    mIsS pm = caseNat undefined nIsS n where
        nIsS :: forall pn. (n ~ S pn, Nat pn) => pn -> IsEq m n
        nIsS pn = case natEqDec pm pn of
            Yes TEq -> Yes TEq
            No contr -> No (contr . noConf m)
--            No contr -> No (contr . predEq)

-- strange things:
-- (1) commenting out the "Yes" case or changing it to "undefined" makes compilation succeed
-- (2) replacing the "No" line with with the commented out "No" line makes compilation succeed


{-# LANGUAGE TypeFamilies, FlexibleContexts #-}

-- Trac #3590: a bug in typechecking of sections

module T3590 where

import Data.Kind (Type)

newtype ListT m a =
  ListT { runListT :: m (Maybe (a, ListT m a)) }

class Monad (ItemM l) => List l where
  type ItemM l :: Type -> Type
  joinL :: [ItemM l (l a) -> l a]

instance Monad m => List (ListT m) where
  type ItemM (ListT m) = m
  joinL = [ ListT . (>>= runListT)      -- Right section
          , ListT . (runListT <<=)      -- Left section
          ]

(<<=) :: Monad m => (a -> m b) -> m a -> m b
(<<=) k m = m >>= k


{-
    Copyright 2009 Mario Blazevic

    This file is part of the Streaming Component Combinators (SCC) project.

    The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
    License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
    version.

    SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
    of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.

    You should have received a copy of the GNU General Public License along with SCC.  If not, see
    <http://www.gnu.org/licenses/>.
-}

-- | Module "Trampoline" defines the trampoline computations and their basic building blocks.

{-# LANGUAGE ScopedTypeVariables, RankNTypes, MultiParamTypeClasses, TypeFamilies, KindSignatures,
             FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances
 #-}

module T3787 where

import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Monad (liftM, liftM2, when, ap)
import Control.Monad.Identity
import Control.Monad.Trans (MonadTrans(..))

import Data.Foldable (toList)
import Data.Maybe (maybe)
import Data.Sequence (Seq, viewl)
import Data.Kind (Type)

par, pseq :: a -> b -> b
par = error "urk"
pseq = error "urk"

-- | Class of monads that can perform two computations in parallel.
class Monad m => ParallelizableMonad m where
   -- | Combine two computations into a single parallel computation. Default implementation of `parallelize` is
   -- @liftM2 (,)@
   parallelize :: m a -> m b -> m (a, b)
   parallelize = liftM2 (,)

-- | Any monad that allows the result value to be extracted, such as `Identity` or `Maybe` monad, can implement
-- `parallelize` by using `par`.
instance ParallelizableMonad Identity where
   parallelize ma mb = let a = runIdentity ma
                           b = runIdentity mb
                       in  a `par` (b `pseq` a `pseq` Identity (a, b))

instance ParallelizableMonad Maybe where
   parallelize ma mb = case ma `par` (mb `pseq` (ma, mb))
                       of (Just a, Just b) -> Just (a, b)
                          _ -> Nothing

-- | IO is parallelizable by `forkIO`.
instance ParallelizableMonad IO where
   parallelize ma mb = do va <- newEmptyMVar
                          vb <- newEmptyMVar
                          forkIO (ma >>= putMVar va)
                          forkIO (mb >>= putMVar vb)
                          a <- takeMVar va
                          b <- takeMVar vb
                          return (a, b)

-- | Suspending monadic computations.
newtype Trampoline s m r = Trampoline {
   -- | Run the next step of a `Trampoline` computation.
   bounce :: m (TrampolineState s m r)
   }

data TrampolineState s m r =
   -- | Trampoline computation is finished with final value /r/.
   Done r
   -- | Computation is suspended, its remainder is embedded in the functor /s/.
 | Suspend! (s (Trampoline s m r))

instance (Functor s, Monad m) => Functor (Trampoline s m) where
   fmap = liftM

instance (Functor s, Monad m) => Applicative (Trampoline s m) where
   pure x = Trampoline (pure (Done x))
   (<*>) = ap

instance (Functor s, Monad m) => Monad (Trampoline s m) where
   return = pure
   t >>= f = Trampoline (bounce t >>= apply f)
      where apply f (Done x) = bounce (f x)
            apply f (Suspend s) = return (Suspend (fmap (>>= f) s))

instance (Functor s, ParallelizableMonad m) => ParallelizableMonad (Trampoline s m) where
   parallelize t1 t2 = Trampoline $ liftM combine $ parallelize (bounce t1) (bounce t2) where
      combine (Done x, Done y) = Done (x, y)
      combine (Suspend s, Done y) = Suspend (fmap (liftM $ \x-> (x, y)) s)
      combine (Done x, Suspend s) = Suspend (fmap (liftM $ (,) x) s)
      combine (Suspend s1, Suspend s2) = Suspend (fmap (parallelize $ suspend s1) s2)

instance Functor s => MonadTrans (Trampoline s) where
   lift = Trampoline . liftM Done

data Yield x y = Yield! x y
instance Functor (Yield x) where
   fmap f (Yield x y) = Yield x (f y)

data Await x y = Await! (x -> y)
instance Functor (Await x) where
   fmap f (Await g) = Await (f . g)

data EitherFunctor l r x = LeftF (l x) | RightF (r x)
instance (Functor l, Functor r) => Functor (EitherFunctor l r) where
   fmap f (LeftF l) = LeftF (fmap f l)
   fmap f (RightF r) = RightF (fmap f r)

newtype NestedFunctor l r x = NestedFunctor (l (r x))
instance (Functor l, Functor r) => Functor (NestedFunctor l r) where
   fmap f (NestedFunctor lr) = NestedFunctor ((fmap . fmap) f lr)

data SomeFunctor l r x = LeftSome (l x) | RightSome (r x) | Both (NestedFunctor l r x)
instance (Functor l, Functor r) => Functor (SomeFunctor l r) where
   fmap f (LeftSome l) = LeftSome (fmap f l)
   fmap f (RightSome r) = RightSome (fmap f r)
   fmap f (Both lr) = Both (fmap f lr)

type TryYield x = EitherFunctor (Yield x) (Await Bool)

suspend :: (Monad m, Functor s) => s (Trampoline s m x) -> Trampoline s m x
suspend s = Trampoline (return (Suspend s))

yield :: forall m x. Monad m => x -> Trampoline (Yield x) m ()
yield x = suspend (Yield x (return ()))

await :: forall m x. Monad m => Trampoline (Await x) m x
await = suspend (Await return)

tryYield :: forall m x. Monad m => x -> Trampoline (TryYield x) m Bool
tryYield x = suspend (LeftF (Yield x (suspend (RightF (Await return)))))

canYield :: forall m x. Monad m => Trampoline (TryYield x) m Bool
canYield = suspend (RightF (Await return))

fromTrampoline :: Monad m => Trampoline s m x -> m x
fromTrampoline t = bounce t >>= \(Done x)-> return x

runTrampoline :: Monad m => Trampoline Identity m x -> m x
runTrampoline = fromTrampoline

pogoStick :: (Functor s, Monad m) => (s (Trampoline s m x) -> Trampoline s m x) -> Trampoline s m x -> m x
pogoStick reveal t = bounce t
                     >>= \s-> case s
                              of Done result -> return result
                                 Suspend c -> pogoStick reveal (reveal c)

pogoStickNested :: (Functor s1, Functor s2, Monad m) =>
                   (s2 (Trampoline (EitherFunctor s1 s2) m x) -> Trampoline (EitherFunctor s1 s2) m x)
                   -> Trampoline (EitherFunctor s1 s2) m x -> Trampoline s1 m x
pogoStickNested reveal t =
   Trampoline{bounce= bounce t
                      >>= \s-> case s
                               of Done result -> return (Done result)
                                  Suspend (LeftF s) -> return (Suspend (fmap (pogoStickNested reveal) s))
                                  Suspend (RightF c) -> bounce (pogoStickNested reveal (reveal c))
             }

nest :: (Functor a, Functor b) => a x -> b y -> NestedFunctor a b (x, y)
nest a b = NestedFunctor $ fmap (\x-> fmap ((,) x) b) a

-- couple :: (Monad m, Functor s1, Functor s2) =>
--           Trampoline s1 m x -> Trampoline s2 m y -> Trampoline (NestedFunctor s1 s2) m (x, y)
-- couple t1 t2 = Trampoline{bounce= do ts1 <- bounce t1
--                                      ts2 <- bounce t2
--                                      case (ts1, ts2) of (Done x, Done y) -> return $ Done (x, y)
--                                                         (Suspend s1, Suspend s2) -> return $ Suspend $
--                                                                                fmap (uncurry couple) (nest s1 s2)
--                          }

coupleAlternating :: (Monad m, Functor s1, Functor s2) =>
                     Trampoline s1 m x -> Trampoline s2 m y -> Trampoline (SomeFunctor s1 s2) m (x, y)
coupleAlternating t1 t2 =
   Trampoline{bounce= do ts1 <- bounce t1
                         ts2 <- bounce t2
                         case (ts1, ts2) of (Done x, Done y) -> return $ Done (x, y)
                                            (Suspend s1, Suspend s2) ->
                                               return $ Suspend $ fmap (uncurry coupleAlternating) (Both $ nest s1 s2)
                                            (Done x, Suspend s2) ->
                                               return $ Suspend $ fmap (coupleAlternating (return x)) (RightSome s2)
                                            (Suspend s1, Done y) ->
                                               return $ Suspend $ fmap (flip coupleAlternating (return y)) (LeftSome s1)
             }

coupleParallel :: (ParallelizableMonad m, Functor s1, Functor s2) =>
                  Trampoline s1 m x -> Trampoline s2 m y -> Trampoline (SomeFunctor s1 s2) m (x, y)
coupleParallel t1 t2 =
   Trampoline{bounce= parallelize (bounce t1) (bounce t2)
                      >>= \pair-> case pair
                                  of (Done x, Done y) -> return $ Done (x, y)
                                     (Suspend s1, Suspend s2) ->
                                        return $ Suspend $ fmap (uncurry coupleParallel) (Both $ nest s1 s2)
                                     (Done x, Suspend s2) ->
                                        return $ Suspend $ fmap (coupleParallel (return x)) (RightSome s2)
                                     (Suspend s1, Done y) ->
                                        return $ Suspend $ fmap (flip coupleParallel (return y)) (LeftSome s1)
             }

coupleNested :: (Monad m, Functor s0, Functor s1, Functor s2) =>
                Trampoline (EitherFunctor s0 s1) m x -> Trampoline (EitherFunctor s0 s2) m y ->
                Trampoline (EitherFunctor s0 (SomeFunctor s1 s2)) m (x, y)
coupleNested t1 t2 =
   Trampoline{bounce= do ts1 <- bounce t1
                         ts2 <- bounce t2
                         case (ts1, ts2) of (Done x, Done y) -> return $ Done (x, y)
                                            (Suspend (RightF s), Done y) ->
                                               return $ Suspend $ RightF $ fmap (flip coupleNested (return y)) (LeftSome s)
                                            (Done x, Suspend (RightF s)) ->
                                               return $ Suspend $ RightF $ fmap (coupleNested (return x)) (RightSome s)
                                            (Suspend (RightF s1), Suspend (RightF s2)) ->
                                               return $ Suspend $ RightF $ fmap (uncurry coupleNested) (Both $ nest s1 s2)
                                            (Suspend (LeftF s), Done y) ->
                                               return $ Suspend $ LeftF $ fmap (flip coupleNested (return y)) s
                                            (Done x, Suspend (LeftF s)) ->
                                               return $ Suspend $ LeftF $ fmap (coupleNested (return x)) s
                                            (Suspend (LeftF s1), Suspend (LeftF s2)) ->
                                               return $ Suspend $ LeftF $ fmap (coupleNested $ suspend $ LeftF s1) s2
             }

seesaw :: (Monad m, Functor s1, Functor s2) =>
           (forall x y s t. (s ~ SomeFunctor s1 s2, t ~ Trampoline s m (x, y)) => s t -> t)
           -> Trampoline s1 m x -> Trampoline s2 m y -> m (x, y)
seesaw resolve t1 t2 = pogoStick resolve (coupleAlternating t1 t2)

seesawParallel :: (ParallelizableMonad m, Functor s1, Functor s2) =>
                  (forall x y s t. (s ~ SomeFunctor s1 s2, t ~ Trampoline s m (x, y)) => s t -> t)
                  -> Trampoline s1 m x -> Trampoline s2 m y -> m (x, y)
seesawParallel resolve t1 t2 = pogoStick resolve (coupleParallel t1 t2)

resolveProducerConsumer :: forall a s s0 t t' m x.
                           (Functor s0, Monad m, s ~ SomeFunctor (TryYield a) (Await (Maybe a)),
                            t ~ Trampoline (EitherFunctor s0 s) m x) =>
                           s t -> t
-- Arg :: s t
-- (LeftSome (LeftF ...)) : SomeFunctor (EitherFunctor .. ..) (...) t
resolveProducerConsumer (LeftSome (LeftF (Yield _ c))) = c
resolveProducerConsumer (LeftSome (RightF (Await c))) = c False
resolveProducerConsumer (RightSome (Await c)) = c Nothing
resolveProducerConsumer (Both (NestedFunctor (LeftF (Yield x (Await c))))) = c (Just x)
resolveProducerConsumer (Both (NestedFunctor (RightF (Await c)))) = suspend (RightF $ RightSome $ c True)

couplePC :: ParallelizableMonad m => Trampoline (Yield a) m x -> Trampoline (Await (Maybe a)) m y -> m (x, y)
couplePC t1 t2 = parallelize (bounce t1) (bounce t2)
                 >>= \(s1, s2)-> case (s1, s2)
                                 of (Done x, Done y) -> return (x, y)
                                    (Suspend (Yield x c1), Suspend (Await c2)) -> couplePC c1 (c2 $ Just x)
                                    (Suspend (Yield _ c1), Done y) -> couplePC c1 (return y)
                                    (Done x, Suspend (Await c2)) -> couplePC (return x) (c2 Nothing)

coupleFinite :: ParallelizableMonad m => Trampoline (TryYield a) m x -> Trampoline (Await (Maybe a)) m y -> m (x, y)
coupleFinite t1 t2 =
   parallelize (bounce t1) (bounce t2)
   >>= \(s1, s2)-> case (s1, s2)
                   of (Done x, Done y) -> return (x, y)
                      (Done x, Suspend (Await c2)) -> coupleFinite (return x) (c2 Nothing)
                      (Suspend (LeftF (Yield x c1)), Suspend (Await c2)) -> coupleFinite c1 (c2 $ Just x)
                      (Suspend (LeftF (Yield _ c1)), Done y) -> coupleFinite c1 (return y)
                      (Suspend (RightF (Await c1)), Suspend s2@Await{}) -> coupleFinite (c1 True) (suspend s2)
                      (Suspend (RightF (Await c1)), Done y) -> coupleFinite (c1 False) (return y)

coupleFiniteSequential :: Monad m => Trampoline (TryYield a) m x -> Trampoline (Await (Maybe a)) m y -> m (x, y)
coupleFiniteSequential t1 t2 =
   bounce t1
   >>= \s1-> bounce t2
             >>= \s2-> case (s1, s2)
                       of (Done x, Done y) -> return (x, y)
                          (Done x, Suspend (Await c2)) -> coupleFiniteSequential (return x) (c2 Nothing)
                          (Suspend (LeftF (Yield x c1)), Suspend (Await c2)) -> coupleFiniteSequential c1 (c2 $ Just x)
                          (Suspend (LeftF (Yield _ c1)), Done y) -> coupleFiniteSequential c1 (return y)
                          (Suspend (RightF (Await c1)), Suspend s2@Await{}) -> coupleFiniteSequential (c1 True) (suspend s2)
                          (Suspend (RightF (Await c1)), Done y) -> coupleFiniteSequential (c1 False) (return y)

-- coupleNested :: (Functor s, Monad m) =>
--                 Trampoline (EitherFunctor s (Yield a)) m x
--              -> Trampoline (EitherFunctor s (Await (Maybe a))) m y -> Trampoline s m (x, y)

-- coupleNested t1 t2 =
--    lift (liftM2 (,) (bounce t1) (bounce t2))
--    >>= \(s1, s2)-> case (s1, s2)
--                    of (Done x, Done y) -> return (x, y)
--                       (Suspend (RightF (Yield _ c1)), Done y) -> coupleNested c1 (return y)
--                       (Done x, Suspend (RightF (Await c2))) -> coupleNested (return x) (c2 Nothing)
--                       (Suspend (RightF (Yield x c1)), Suspend (RightF (Await c2))) -> coupleNested c1 (c2 $ Just x)
--                       (Suspend (LeftF s), Done y) -> suspend (fmap (flip coupleNested (return y)) s)
--                       (Done x, Suspend (LeftF s)) -> suspend (fmap (coupleNested (return x)) s)
--                       (Suspend (LeftF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNested $ suspend $ LeftF s1) s2)

coupleNestedFinite :: (Functor s, ParallelizableMonad m) =>
                      Trampoline (SinkFunctor s a) m x -> Trampoline (SourceFunctor s a) m y -> Trampoline s m (x, y)
coupleNestedFinite t1 t2 = lift (parallelize (bounce t1) (bounce t2))
                           >>= stepCouple coupleNestedFinite

coupleNestedFiniteSequential :: (Functor s, Monad m) =>
                                Trampoline (SinkFunctor s a) m x
                             -> Trampoline (SourceFunctor s a) m y
                             -> Trampoline s m (x, y)
coupleNestedFiniteSequential producer consumer =
   pogoStickNested resolveProducerConsumer (coupleNested producer consumer)
-- coupleNestedFiniteSequential t1 t2 = lift (liftM2 (,) (bounce t1) (bounce t2))
--                                      >>= stepCouple coupleNestedFiniteSequential

stepCouple :: (Functor s, Monad m) =>
              (Trampoline (EitherFunctor s (TryYield a)) m x
                  -> Trampoline (EitherFunctor s (Await (Maybe a))) m y
                  -> Trampoline s m (x, y))
              -> (TrampolineState (EitherFunctor s (TryYield a)) m x,
                  TrampolineState (EitherFunctor s (Await (Maybe a))) m y)
              -> Trampoline s m (x, y)
stepCouple f couple = case couple
                      of (Done x, Done y) -> return (x, y)
                         (Done x, Suspend (RightF (Await c2))) -> f (return x) (c2 Nothing)
                         (Suspend (RightF (LeftF (Yield _ c1))), Done y) -> f c1 (return y)
                         (Suspend (RightF (LeftF (Yield x c1))), Suspend (RightF (Await c2))) -> f c1 (c2 $ Just x)
                         (Suspend (RightF (RightF (Await c1))), Suspend s2@(RightF Await{})) -> f (c1 True) (suspend s2)
                         (Suspend (RightF (RightF (Await c1))), Done y) -> f (c1 False) (return y)
                         (Suspend (LeftF s), Done y) -> suspend (fmap (flip f (return y)) s)
                         (Done x, Suspend (LeftF s)) -> suspend (fmap (f (return x)) s)
                         (Suspend (LeftF s1), Suspend (LeftF s2)) -> suspend (fmap (f $ suspend $ LeftF s1) s2)
                         (Suspend (LeftF s1), Suspend (RightF s2)) -> suspend (fmap (flip f (suspend $ RightF s2)) s1)
                         (Suspend (RightF s1), Suspend (LeftF s2)) -> suspend (fmap (f (suspend $ RightF s1)) s2)

local :: forall m l r x. (Functor r, Monad m) => Trampoline r m x -> Trampoline (EitherFunctor l r) m x
local (Trampoline mr) = Trampoline (liftM inject mr)
   where inject :: TrampolineState r m x -> TrampolineState (EitherFunctor l r) m x
         inject (Done x) = Done x
         inject (Suspend r) = Suspend (RightF $ fmap local r)

out :: forall m l r x. (Functor l, Monad m) => Trampoline l m x -> Trampoline (EitherFunctor l r) m x
out (Trampoline ml) = Trampoline (liftM inject ml)
   where inject :: TrampolineState l m x -> TrampolineState (EitherFunctor l r) m x
         inject (Done x) = Done x
         inject (Suspend l) = Suspend (LeftF $ fmap out l)

-- | Class of functors that can be lifted.
class (Functor a, Functor d) => AncestorFunctor a d where
   -- | Convert the ancestor functor into its descendant. The descendant functor typically contains the ancestor.
   liftFunctor :: a x -> d x

instance Functor a => AncestorFunctor a a where
   liftFunctor = id
instance (Functor a, Functor d', Functor d, d ~ EitherFunctor d' s, AncestorFunctor a d') => AncestorFunctor a d where
   liftFunctor = LeftF . (liftFunctor :: a x -> d' x)

liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Trampoline a m x -> Trampoline d m x
liftOut (Trampoline ma) = Trampoline (liftM inject ma)
   where inject :: TrampolineState a m x -> TrampolineState d m x
         inject (Done x) = Done x
         inject (Suspend a) = Suspend (liftFunctor $ fmap liftOut a)

type SourceFunctor a x = EitherFunctor a (Await (Maybe x))
type SinkFunctor a x = EitherFunctor a (TryYield x)

-- | A 'Sink' can be used to yield values from any nested `Trampoline` computation whose functor provably descends from
-- the functor /a/. It's the write-only end of a 'Pipe' communication channel.
data Sink (m :: Type -> Type) a x =
   Sink
   {
   -- | Function 'put' tries to put a value into the given `Sink`. The intervening 'Trampoline' computations suspend up
   -- to the 'pipe' invocation that has created the argument sink. The result of 'put' indicates whether the operation
   -- succeeded.
   put :: forall d. (AncestorFunctor a d) => x -> Trampoline d m Bool,
   -- | Function 'canPut' checks if the argument `Sink` accepts values, i.e., whether a 'put' operation would succeed on
   -- the sink.
   canPut :: forall d. (AncestorFunctor a d) => Trampoline d m Bool
   }

-- | A 'Source' can be used to read values into any nested `Trampoline` computation whose functor provably descends from
-- the functor /a/. It's the read-only end of a 'Pipe' communication channel.
newtype Source (m :: Type -> Type) a x =
   Source
   {
   -- | Function 'get' tries to get a value from the given 'Source' argument. The intervening 'Trampoline' computations
   -- suspend all the way to the 'pipe' function invocation that created the source. The function returns 'Nothing' if
   -- the argument source is empty.
   get :: forall d. (AncestorFunctor a d) => Trampoline d m (Maybe x)
   }

-- | Converts a 'Sink' on the ancestor functor /a/ into a sink on the descendant functor /d/.
liftSink :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a x -> Sink m d x
liftSink s = Sink {put= liftOut . (put s :: x -> Trampoline d m Bool),
                   canPut= liftOut (canPut s :: Trampoline d m Bool)}

-- | Converts a 'Source' on the ancestor functor /a/ into a source on the descendant functor /d/.
liftSource :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Source m d x
liftSource s = Source {get= liftOut (get s :: Trampoline d m (Maybe x))}

-- | The 'pipe' function splits the computation into two concurrent parts, /producer/ and /consumer/. The /producer/ is
-- given a 'Sink' to put values into, and /consumer/ a 'Source' to get those values from. Once producer and consumer
-- both complete, 'pipe' returns their paired results.
pipe :: forall m a a1 a2 x r1 r2. (Monad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>
        (Sink m a1 x -> Trampoline a1 m r1) -> (Source m a2 x -> Trampoline a2 m r2) -> Trampoline a m (r1, r2)
pipe producer consumer = coupleNestedFiniteSequential (producer sink) (consumer source) where
   sink = Sink {put= liftOut . (local . tryYield :: x -> Trampoline a1 m Bool),
                canPut= liftOut (local canYield :: Trampoline a1 m Bool)} :: Sink m a1 x
   source = Source (liftOut (local await :: Trampoline a2 m (Maybe x))) :: Source m a2 x

-- | The 'pipeP' function is equivalent to 'pipe', except the /producer/ and /consumer/ are run in parallel.
pipeP :: forall m a a1 a2 x r1 r2. (ParallelizableMonad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>
         (Sink m a1 x -> Trampoline a1 m r1) -> (Source m a2 x -> Trampoline a2 m r2) -> Trampoline a m (r1, r2)
pipeP producer consumer = coupleNestedFinite (producer sink) (consumer source) where
   sink = Sink {put= liftOut . (local . tryYield :: x -> Trampoline a1 m Bool),
                canPut= liftOut (local canYield :: Trampoline a1 m Bool)} :: Sink m a1 x
   source = Source (liftOut (local await :: Trampoline a2 m (Maybe x))) :: Source m a2 x

-- | The 'pipePS' function acts either as 'pipeP' or as 'pipe', depending on the argument /parallel/.
pipePS :: forall m a a1 a2 x r1 r2. (ParallelizableMonad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>
          Bool -> (Sink m a1 x -> Trampoline a1 m r1) -> (Source m a2 x -> Trampoline a2 m r2) ->
          Trampoline a m (r1, r2)
pipePS parallel = if parallel then pipeP else pipe

getSuccess :: forall m a d x . (Monad m, AncestorFunctor a d)
              => Source m a x -> (x -> Trampoline d m ()) {- ^ Success continuation -} -> Trampoline d m ()
getSuccess source succeed = get source >>= maybe (return ()) succeed

-- | Function 'get'' assumes that the argument source is not empty and returns the value the source yields. If the
-- source is empty, the function throws an error.
get' :: forall m a d x . (Monad m, AncestorFunctor a d) => Source m a x -> Trampoline d m x
get' source = get source >>= maybe (error "get' failed") return

-- | 'pour' copies all data from the /source/ argument into the /sink/ argument, as long as there is anything to copy
-- and the sink accepts it.
pour :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
        => Source m a1 x -> Sink m a2 x -> Trampoline d m ()
pour source sink = fill'
   where fill' = canPut sink >>= flip when (getSuccess source (\x-> put sink x >> fill'))

-- | 'pourMap' is like 'pour' that applies the function /f/ to each argument before passing it into the /sink/.
pourMap :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
           => (x -> y) -> Source m a1 x -> Sink m a2 y -> Trampoline d m ()
pourMap f source sink = loop
   where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> put sink (f x) >> loop))

-- | 'pourMapMaybe' is to 'pourMap' like 'Data.Maybe.mapMaybe' is to 'Data.List.Map'.
pourMapMaybe :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
                => (x -> Maybe y) -> Source m a1 x -> Sink m a2 y -> Trampoline d m ()
pourMapMaybe f source sink = loop
   where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> maybe (return False) (put sink) (f x) >> loop))

-- | 'tee' is similar to 'pour' except it distributes every input value from the /source/ arguments into both /sink1/
-- and /sink2/.
tee :: forall m a1 a2 a3 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)
       => Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Trampoline d m ()
tee source sink1 sink2 = distribute
   where distribute = do c1 <- canPut sink1
                         c2 <- canPut sink2
                         when (c1 && c2)
                            (get source >>= maybe (return ()) (\x-> put sink1 x >> put sink2 x >> distribute))

-- | 'putList' puts entire list into its /sink/ argument, as long as the sink accepts it. The remainder that wasn't
-- accepted by the sink is the result value.
putList :: forall m a d x. (Monad m, AncestorFunctor a d) => [x] -> Sink m a x -> Trampoline d m [x]
putList [] sink = return []
putList l@(x:rest) sink = put sink x >>= cond (putList rest sink) (return l)

-- | 'getList' returns the list of all values generated by the source.
getList :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Trampoline d m [x]
getList source = getList' return
   where getList' f = get source >>= maybe (f []) (\x-> getList' (f . (x:)))

-- | 'consumeAndSuppress' consumes the entire source ignoring the values it generates.
consumeAndSuppress :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Trampoline d m ()
consumeAndSuppress source = get source
                            >>= maybe (return ()) (const (consumeAndSuppress source))

-- | A utility function wrapping if-then-else, useful for handling monadic truth values
cond :: a -> a -> Bool -> a
cond x y test = if test then x else y

-- | A utility function, useful for handling monadic list values where empty list means success
whenNull :: forall a m. Monad m => m [a] -> [a] -> m [a]
whenNull action list = if null list then action else return list

-- | Like 'putList', except it puts the contents of the given 'Data.Sequence.Seq' into the sink.
putQueue :: forall m a d x. (Monad m, AncestorFunctor a d) => Seq x -> Sink m a x -> Trampoline d m [x]
putQueue q sink = putList (toList (viewl q)) sink


{-# LANGUAGE TypeFamilies #-}

module T3826 where

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

data T a = MkT a
-- MkT :: a -> T a

instance C (T b) where
  type E (T b) = b
  c x (MkT _) = MkT x

f t@(MkT x) = c x t

{- c :: E alpha -> alpha -> alpha
   t :: T beta
   x :: beta
   f :: T beta -> gamma

   [W] C alpha
   [W] E alpha ~ beta
   [W] alpha ~ T beta
   [W] gamma ~ alpha

--->                       beta = t_aqf  alpha = t_aqg
   alpha := T beta
   gamma := alpha

   [W] E (T beta) ~ beta

-->
   [W] ufsk ~ beta
   [W] E (T beta) ~ ufsk

--> (swap and subst)
   beta := ufsk
   [W] x : E (T ufsk) ~ ufsk   (do not rewrite RHS)

take a step   ax: E (T beta) ~ beta

-->
   [W] ufsk
--------------------------
 But what about this?
--------------------------

axiom F [a] = F [a]

   x : F [a] ~ fsk
step
   ax : F [a] ~ F [a]
flatten
   ax ; x : F [a] ~ fsk
   x = ax ; x       Oh dear!
-}


{-# LANGUAGE GADTs, TypeFamilies #-}

module T3851 where

import Data.Kind (Type)

type family TF a :: Type -> Type
type instance TF () = App (Equ ())

data Equ ix ix' where Refl :: Equ ix ix
data App f x = App (f x)

-- does not typecheck in 6.12.1 (but works in 6.10.4)
bar :: TF () () -> ()
bar (App Refl) = ()

-- does typecheck in 6.12.1 and 6.10.4
ar :: App (Equ ()) () -> ()
ar (App Refl) = ()

------------------
data family DF a :: Type -> Type
data instance DF () a = D (App (Equ ()) a)

bar_df :: DF () () -> ()
bar_df (D (App Refl)) = ()


{-# LANGUAGE RankNTypes, TypeFamilies #-}

-- Unification yielding a coercion under a forall

module Data.Vector.Unboxed where

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

data MVector s a = MV
data Vector a    = V

type family Mutable (v :: Type -> Type) :: Type -> Type -> Type
type instance Mutable Vector = MVector

create :: (forall s. MVector s a) -> Int
create = create1
-- Here we get  Couldn't match expected type `forall s. MVector s a'
--                          with actual type `forall s. Mutable Vector s a1'
-- Reason: when unifying under a for-all we don't solve type
--         equalities.  Think more about this.

create1 :: (forall s. Mutable Vector s a) -> Int
create1 _ = error "urk"


{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
    -- The type of sizeT is indeed ambiguous

module Foo where

import Data.Kind (Type)

data P f g r = f r :*: g r
type family TrieMapT (f :: Type -> Type) ::
  Type -> (Type -> Type) -> Type -> Type
newtype PMap m1 (m2 :: Type -> (Type -> Type) -> Type -> Type)
             k (a :: Type -> Type) ix
  = PMap (m1 k (m2 k a) ix)
type instance TrieMapT (P f g) = PMap (TrieMapT f) (TrieMapT g)

class TrieKeyT f m where
        unionT :: (TrieMapT f ~ m) => (f k -> a ix -> a ix -> a ix) ->
                m k a ix -> m k a ix -> m k a ix
        sizeT :: (TrieMapT f ~ m) => m k a ix -> Int

instance (TrieKeyT f m1, TrieKeyT g m2) => TrieKeyT (P f g) (PMap m1 m2) where
        unionT f (PMap m1) (PMap m2) = PMap (uT  (\ a -> unionT (\ b -> f (a :*: b))) m1 m2)
                where uT = unionT
        sizeT = error "urk"


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

-- See Trac #4178

module T4178 where

data True = T
data False = F

class Decide tf a b where
  type If tf a b
  nonFunctionalIf :: tf -> a -> b -> If tf a b

instance Decide True a b where
  type If True a b = a
  nonFunctionalIf T a b = a

instance Decide False a b where
  type If False a b = b
  nonFunctionalIf F a b = b

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

hasTrouble a = nonFunctionalIf F a (2 :: Int)
blurg = useRank2 hasTrouble

hasNoTrouble :: a -> Int
hasNoTrouble = hasTrouble
blurg2 = useRank2 hasNoTrouble


{-# LANGUAGE DeriveFunctor, StandaloneDeriving, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-}
module T4185 where

import Data.Kind (Type)

data family Foo k :: Type -> Type

------------- Generalised newtype deriving of user class -----------
class Bar f where
        bar :: f a -> Int
        woo :: f a -> f a

instance Bar Maybe where
        bar Nothing = 0
        bar Just{} = 1
        woo x = x

-- Deriving clause
newtype instance Foo Int a = FooInt (Maybe a) deriving (Bar)

-- Standalone deriving
newtype instance Foo Char a = FooChar (Maybe a)
deriving instance Bar (Foo Char)

{-
dBarMaybe :: Bar Maybe

newtype FooInt a = FooInt (Maybe a)
axiom ax7 a : Foo Int a ~ FooInt a   -- Family axiom
axiom ax7   : FooInt ~ Maybe         -- Newtype axiom

dBarFooInt :: Bar (Foo Int)
dBarFooInt = dBarMaybe |> Bar ax7
-}

------------- Deriving on data types for Functor -----------

-- Deriving clause
data instance Foo Bool a = FB1 a | FB2 a deriving( Functor )

-- Standalone deriving
data instance Foo Float a = FB3 a
deriving instance Functor (Foo Float)

--instance Functor (Foo Bool) where
--  fmap f (FB1 x) = FB1 (f x)
--  fmap f (FB2 y) = FB2 (f y)


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

module T4200 where

import Data.Kind (Type)

class C a where
  type In a :: Type
  op :: In a -> a -> Int

-- Should be ok; no -XUndecidableInstances required
instance (In c ~ Int) => C [c] where
  type In [c] = In c
  op _ _ = 3


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

module Main where

class (There a ~ b, BackAgain b ~ a) => Foo a b where
     type There a
     type BackAgain b
     there :: a -> b
     back :: b -> a
     tickle :: b -> b

instance Foo Char Int where
     type There Char = Int
     type BackAgain Int = Char
     there = fromEnum
     back = toEnum
     tickle = (+1)

test :: (Foo a b) => a -> a
test x = back (tickle (there x))

main :: IO ()
main = print $ test 'F'

{-

[G] Foo a b
[G] There a ~ b
[G] Back b ~ a

[W] Foo a beta      -- from 'there'
[W] Foo alpha beta  -- from tickle
[W] Foo a beta      -- from back

[D] There a ~ beta
[D] Back beta ~ a

[D] There alpha ~ beta
[D] Back beta ~ alpha

-- Hence beta = b
--       alpha = a

[W] Foo a (There t_a1jL)
[W] Foo t_a1jL (There t_a1jL)
[W] Back (There t_a1jL) ~ t_a1jL

[D] There a ~ There t_a1jL
     hence There t_a1jL ~ b
[D] Back (There t_a1jL) ~ a
[D] There t_a1jL ~ There t_a1jL
[D] Back (There t_a1jL) ~ t_a1jL
-}


{-# LANGUAGE TypeFamilies #-}
module T4356 where

import Data.Kind (Type)

type family T t :: Type -> Type -> Type
type instance T Bool = (->)

f :: T Bool Bool Bool
f = not


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

module T4358 where

type family T a

t2 :: forall a. ((T a ~ a) => a) -> a
t2 = t

t :: forall a. ((T a ~ a) => a) -> a
t = undefined


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

module T4484 where

import Data.Kind (Type)

type family F f :: Type

data Id c = Id
type instance F (Id c) = c

data C :: Type -> Type where
  C :: f -> C (W (F f))

data W :: Type -> Type

fails :: C a -> C a
fails (C _)
  = -- We know (W (F f) ~ a)
    C Id  -- We need (a ~ W (F (Id beta)))
          --    ie   (a ~ W beta)
          -- Use the equality; we need
          --         (W (F f) ~ W beta)
          --    ie   (F f ~ beta)
          -- Solve with beta := f

works :: C (W a) -> C (W a)
works (C _)
  = -- We know (W (F f) ~ W a)
    C Id -- We need (W a ~ W (F (Id beta)))
         --      ie (W a ~ W beta)
         -- Solve with beta := a


{-# LANGUAGE TypeFamilies, RankNTypes #-}

module T4492 where

type family F a b
type instance F (Maybe a) b = b -> F a b

class C a where
   go :: (forall a. Maybe a -> b -> a) -> a -> F a b

instance C a => C (Maybe a) where
   go f a b = go f (f a b)


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

module T4494 where

type family H s
type family F v

bar :: (forall t. Maybe t -> a) -> H a -> Int
bar _ = error "urk"

call :: F Bool -> Int
call x = bar (\_ -> x) (undefined :: H (F Bool))

{-
  [W] H (F Bool) ~ H alpha
  [W] alpha ~ F Bool
-->
  F Bool  ~ fuv0
  H fuv0  ~ fuv1
  H alpha ~ fuv2

  fuv1 ~ fuv2
  alpha ~ fuv0

flatten
~~~~~~~
fuv0 := alpha
fuv1 := fuv2

alpha := F Bool
-}


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

module T4497 where

norm2PropR a = twiddle (norm2 a) a

twiddle :: Normed a => a -> a -> Double
twiddle a b = undefined

norm2 :: e -> RealOf e
norm2 = undefined

class (Num (RealOf t)) => Normed t

type family RealOf x


{-# LANGUAGE TypeFamilies, RankNTypes, ScopedTypeVariables #-}
module T4935 where

import Control.Applicative

data TFalse
data TTrue

data Tagged b a = Tagged {at :: a}
type At b = forall a. Tagged b a -> a

class TBool b where onTBool :: (b ~ TFalse => c) -> (b ~ TTrue => c) -> Tagged b c
instance TBool TFalse where onTBool f _ = Tagged $ f
instance TBool TTrue where onTBool _ t = Tagged $ t

type family CondV c f t
type instance CondV TFalse f t = f
type instance CondV TTrue f t = t

newtype Cond c f a = Cond {getCond :: CondV c a (f a)}
cond :: forall c f a g. (TBool c, Functor g) => (c ~ TFalse => g a) -> (c ~ TTrue => g (f a)) -> g (Cond c f a)
cond f t = (at :: At c) $ onTBool (fmap Cond f) (fmap Cond t)
condMap :: (TBool c, Functor f) => (a -> b) -> Cond c f a -> Cond c f b
condMap g (Cond n) = cond g (fmap g) n


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

module Class ( cleverNamedResolve ) where

data FL p = FL p

class PatchInspect p where
instance PatchInspect p => PatchInspect (FL p) where

type family PrimOf p
type instance PrimOf (FL p) = PrimOf p

data WithName prim = WithName prim

instance PatchInspect prim => PatchInspect (WithName prim) where

class (PatchInspect (PrimOf p)) => Conflict p where
    resolveConflicts :: p -> PrimOf p

instance Conflict p => Conflict (FL p) where
    resolveConflicts = undefined

type family OnPrim p

class FromPrims p where

instance FromPrims (FL p) where

joinPatches :: FromPrims p => p -> p
joinPatches = id

cleverNamedResolve :: (Conflict (OnPrim p)
                      ,PrimOf (OnPrim p) ~ WithName (PrimOf p))
                   => p -> FL (OnPrim p) -> WithName (PrimOf p)
cleverNamedResolve x = resolveConflicts . joinPatches


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

module Class ( cleverNamedResolve ) where

data FL p = FL p

class PatchInspect p where
instance PatchInspect p => PatchInspect (FL p) where

type family PrimOf p
type instance PrimOf (FL p) = PrimOf p

data WithName prim = WithName prim

instance PatchInspect prim => PatchInspect (WithName prim) where

class (PatchInspect (PrimOf p)) => Conflict p where
    resolveConflicts :: p -> PrimOf p

instance Conflict p => Conflict (FL p) where
    resolveConflicts = undefined

type family OnPrim p

joinPatches :: FL p -> FL p

joinPatches = id

cleverNamedResolve :: (Conflict (OnPrim p)
                      ,PrimOf (OnPrim p) ~ WithName (PrimOf p))
                   => p -> FL (OnPrim p) -> WithName (PrimOf p)
cleverNamedResolve x = resolveConflicts . joinPatches


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

module Class ( cleverNamedResolve ) where

data FL p = FL p

class PatchInspect p where
instance PatchInspect p => PatchInspect (FL p) where

type family PrimOf p
type instance PrimOf (FL p) = PrimOf p

data WithName prim = WithName prim

instance PatchInspect prim => PatchInspect (WithName prim) where

class (PatchInspect (PrimOf p)) => Conflict p where
    resolveConflicts :: p -> PrimOf p

instance Conflict p => Conflict (FL p) where
    resolveConflicts = undefined

type family OnPrim p

joinPatches :: p -> p

joinPatches = id

cleverNamedResolve :: (Conflict (OnPrim p)
                      ,PrimOf (OnPrim p) ~ WithName (PrimOf p))
                   => p -> FL (OnPrim p) -> WithName (PrimOf p)
cleverNamedResolve x = resolveConflicts . joinPatches
-- I added the parameter 'x' to make the signature unambiguous
-- I don't think that ambiguity is essential to the original problem

{-
resolveConflicts :: q -> PrimOf q
 (w) FL (OnPrim p) ~ q
 (w) WithName (PrimOf p) ~ PrimOf q
==>
 (w) PrimOf (OnPrim p) ~ PrimOf (FL (OnPrim p))
==>
 (w) PrimOf (OnPrim p) ~ PrimOf (OnPrim p)

-}


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

class A a
class B a where b :: a -> ()
instance A a => B a where b = undefined

newtype Y a = Y (a -> ())

okIn701 :: B a => Y a
-- Weird test case: (B a) is simplifiable
okIn701 = wrap $ const () . b

okIn702 :: B a => Y a
-- Weird test case: (B a) is simplifiable
okIn702 = wrap $ b

okInBoth :: B a => Y a
-- Weird test case: (B a) is simplifiable
okInBoth = Y $ const () . b

class Wrapper a where
    type Wrapped a
    wrap :: Wrapped a -> a
instance Wrapper (Y a) where
  type Wrapped (Y a) = a -> ()
  wrap = Y

fromTicket3018 :: Eq [a] => a -> ()
-- Weird test case: (Eq [a]) is simplifiable
fromTicket3018 x = let {g :: Int -> Int; g = [x]==[x] `seq` id} in ()

main = undefined


{-# LANGUAGE GADTs, TypeOperators, TypeFamilies, ScopedTypeVariables #-}
module T5591a where

data a :=: b where
    Refl :: a :=: a

subst :: a :=: b -> f a -> f b
subst Refl = id

-- Then this doesn't work (error message at the bottom):

inj1 :: forall f a b. f a :=: f b -> a :=: b
inj1 Refl = Refl

-- But one can still construct it with a trick that Oleg used in the context of
-- Leibniz equality:

type family Arg fa

type instance Arg (f a) = a

newtype Helper fa fa' = Helper { runHelper :: Arg fa :=: Arg fa' }

inj2 :: forall f a b. f a :=: f b -> a :=: b
inj2 p = runHelper (subst p (Helper Refl :: Helper (f a) (f a)))


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, KindSignatures,
    GADTs, FlexibleInstances, FlexibleContexts #-}
module T5591b where

import Data.Kind (Type)

class Monad m => Effect p e r m | p e m -> r where
  fin :: p e m -> e -> m r

data ErrorEff :: Type -> (Type -> Type) -> Type where
  CatchError :: (e -> m a) -> ErrorEff ((e -> m a) -> m a) m

instance Monad m => Effect ErrorEff ((e -> m a) -> m a) a m where
  fin (CatchError h) = \f -> f h


module T5955 where

import T5955a

foo :: ()
foo = ()


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

module T5955a where

class (Eq (Multi a)) => MultiPrim a where
    data Multi a

instance MultiPrim Int where
    newtype Multi Int = MultiInt Int deriving (Eq)


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE EmptyDataDecls #-}

module T6088 where

class C a

newtype A n = A Int

type family Pos n
data True

instance (Pos n ~ True) => C (A n)

newtype B n = B (A n) deriving (C)
  -- This should work, giving
  -- instance C (B n)


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

module T6152 where

data U = Unit

data SU (a :: U) where
   SInt :: SU Unit

type family I (a :: U) :: U
type instance I Unit = Unit

type SUI a = SU (I a)


{-# LANGUAGE TypeFamilies #-}
module T7082 where

import Data.Kind (Type)

class R m where
  type D m a :: Type
  type D m a = ()                -- (1)
  f :: m a -> D m a -> ()

instance R Maybe where
  -- type D Maybe a = ()         -- (2)
  f = undefined

x = f (Nothing :: Maybe Int) ()


{-# LANGUAGE TypeFamilies, ExistentialQuantification #-}

module T7156 where

data T a = (a ~ ()) => T

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


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

module T7280 where

import Data.Kind (Type)

type family Mutable (v :: Type -> Type) :: Type -> Type -> Type
class MVector (v :: Type -> Type -> Type) a
class MVector (Mutable v) a => Vector v a where
   copy :: Monad m => Mutable v s a -> v a -> m ()

data Chunk v s a = Chunk (forall m. (Monad m, Vector v a) => Mutable v s a -> m ())

vstep (v:vs) = Chunk (\mv -> copy mv v)


 {-# OPTIONS -XTypeFamilies -XDataKinds -XPolyKinds #-}

module T7282 where

import Data.Kind (Type)

class Foo (xs :: [k]) where
     type Bar xs :: Type

instance Foo '[] where
     type Bar '[] = Int


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

module T7474 where

import Data.Kind (Type)

type family T :: Type -> Type

data E :: Type -> Type where
    E :: C p => T (T p) -> E p

class C' b a where c :: T b -> a

class C' (T a) a => C a

-- f :: C' (T p) a => E p -> a
f (E d) = c d


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

module T7489 where

import Data.Kind (Type)

data Credit
data Debit

data family Account (s :: Type) (t :: Type)

data instance Account Int t where
  CAccount :: Account Int Credit
  DAccount :: {  debitAccountPostings :: [Int] } -> Account Int Debit


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

module Bug where

import Data.Kind

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

data SList :: [Bool] -> Type where
  SNil :: SList '[]
  SCons :: SBool h -> SList t -> SList (h ': t)

type family (a :: [k]) :==: (b :: [k]) :: Bool where
  '[] :==: '[] = True
  (h1 ': t1) :==: (h2 ': t2) = True
  a :==: b = False

(%==%) :: SList ls1 -> SList ls2 -> SBool (ls1 :==: ls2)
SNil %==% (SCons _ _) = SFalse


{-# LANGUAGE GADTs, ConstraintKinds,
             PolyKinds, KindSignatures, DataKinds, TypeOperators,
             TypeFamilies, UndecidableInstances,
             FlexibleContexts, ScopedTypeVariables #-}
module T7786 where

import Data.Kind (Type)
import GHC.TypeLits(Symbol,Nat)

data family Sing (a :: k)

data Inventory a = Empty | More (Inventory a) a

data instance Sing (l :: Inventory a) where
  Nil :: Sing Empty
  Snoc :: Sing bs -> Sing b -> Sing (More bs b)

data KeySegment = Numic Nat | Symic Symbol

data instance Sing (n :: KeySegment) where
  Numic' :: Sing n -> Sing (Numic n)
  Symic' :: Sing ss -> Sing (Symic ss)

data instance Sing (k :: [KeySegment]) where
  Root' :: Sing ('[] :: [KeySegment])
  Symic'' :: Sing p -> Sing k -> Sing (Symic k ': p)
  Numic'' :: Sing p -> Sing k -> Sing (Numic k ': p)

type family Under (pre :: [KeySegment]) (post :: [KeySegment]) :: [KeySegment]
type instance Under '[] post = post
type instance Under (x ': xs) post = x ': xs `Under` post

under :: Sing (pre :: [KeySegment]) -> Sing (post :: [KeySegment]) -> Sing (pre `Under` post)
under Root' post = post
under (Symic'' ks k) post = under ks post `Symic''` k
under (Numic'' ks k) post = under ks post `Numic''` k

data Database :: Inventory [KeySegment] -> Type where
  Clean :: Database Empty
  Record :: (k `KeyNotIn` i) => Database i -> Sing k -> () -> Database (More i k)
  Sub :: ((sub `UnderDisjoint` k) i) => Database i -> Sing k -> Database sub -> Database ((sub `BuriedUnder` k) i)

dbKeys :: Database inv -> Sing inv
dbKeys Clean = Nil
dbKeys (Record db k _) = dbKeys db `Snoc` k
dbKeys (Sub db k sub) = (dbKeys sub `buryUnder` k) (dbKeys db)

buryUnder :: Sing sub -> Sing post -> Sing acc -> Sing ((sub `BuriedUnder` post) acc)
buryUnder Nil _ acc = acc
buryUnder (ps `Snoc` p) post acc = (ps `buryUnder` post) acc `Snoc` (p `under` post)

type key `KeyNotIn` inv = Intersect (More Empty key) inv ~ Empty
type (lhs `UnderDisjoint` post) rhs = Intersect ((lhs `BuriedUnder` post) Empty) rhs ~ Empty

type family Intersect (l :: Inventory a) (r :: Inventory a) :: Inventory a where
  Intersect Empty r = Empty
  Intersect l Empty = Empty
  Intersect (More ls l) r = InterAppend (Intersect ls r) r l

type family InterAppend (l :: Inventory a)
                        (r :: Inventory a)
                        (one :: a)
            :: Inventory a where
  InterAppend acc Empty one = acc
  InterAppend acc (More rs one) one = More acc one
  InterAppend acc (More rs r) one = InterAppend acc rs one

type family BuriedUnder (sub :: Inventory [KeySegment])
                        (post :: [KeySegment])
                        (inv :: Inventory [KeySegment])
            :: Inventory [KeySegment] where
  BuriedUnder Empty post inv = inv
  BuriedUnder (More ps p) post inv = More ((ps `BuriedUnder` post) inv) (p `Under` post)

intersectPaths :: Sing (lhs :: Inventory [KeySegment]) -> Sing (rhs :: Inventory [KeySegment]) -> Sing (lhs `Intersect` rhs)
intersectPaths = undefined

{- This foo is ambiguous
foo :: Database inv
    -> Sing post
    -> Database sub
    -> Sing (Intersect (BuriedUnder sub post 'Empty) rhs)
foo db k sub = buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db
-}

foogle :: Database inv
       -> Sing post
       -> Database sub
       -> Maybe (Sing (Intersect (BuriedUnder sub post 'Empty) inv))

foogle db k sub = return (buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db)

addSub :: Database inv -> Sing k -> Database sub -> Maybe (Database ((sub `BuriedUnder` k) inv))
addSub db k sub = do Nil :: Sing xxx <- foogle db k sub
                     return $ Sub db k sub

{-
addSub :: Database inv -> Sing k -> Database sub -> Maybe (Database ((sub `BuriedUnder` k) inv))
addSub db k sub = do Nil :: Sing xxx <- foogle db sub k
                     -- Nil :: Sing ((sub `BuriedUnder` k) Empty `Intersect` inv) <- return (buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db)
                     -- Nil :: Sing Empty <- return (buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db)
                     -- Nil <- return (buryUnder (dbKeys sub) k Nil `intersectPaths` dbKeys db)
                     return $ Sub db k sub
-}


{-# LANGUAGE TypeFamilies, RankNTypes #-}

module T7804 where

type family F f a

data Proxy a = P

sDFMap :: (forall a. Proxy f -> Proxy a -> Proxy (F f a)) -> Int
sDFMap _ = 3

{-
flat cache
 [G] F f_aqh aqj ~ fsk_aqp
 [G] F f_aqg aqj ~ fsk_aqq

 [W] aqk : f_aqh[2] ~ f_aqg
 [w] aql : fsk_aqp ~ fsk_aqq

 [G] F f_agh a_aqj ~ F f_aqg
-}


{-# LANGUAGE TypeFamilies, FlexibleContexts #-}

module T7837 where

type family Scalar a
class Fractional (Scalar a) => Norm a where
  norm :: a -> Scalar a

type instance Scalar Double = Double
instance Norm Double where norm = abs

normalize :: (Norm a, a ~ Scalar a) => a -> a
normalize x = x / norm x
{-# NOINLINE normalize #-}

normalize_Double :: Double -> Double
normalize_Double = signum
{-# NOINLINE normalize_Double #-}

-- This rule should fire in 'foo'
{-# RULES "normalize/Double" normalize = normalize_Double #-}

foo :: Double
foo = normalize (4 :: Double)


{-# LANGUAGE TypeFamilies #-}
module T8002 where

import T8002a


{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}

module T8002a where

import T8002b

class QA a where
   type QRep a
   type QRep a = QRep (Maybe a)

instance QA () where
   type QRep () = ()


{-# LANGUAGE TypeFamilies #-}
module T8002b where

type family Rep a
type instance Rep Int = Int


{-# LANGUAGE FlexibleContexts #-}
module T8011( clean )  where

import Data.Char (isAlphaNum)
import Data.List (dropWhile)
import T8011a ( ToURL(URLT, toURL) )

clean :: (ToURL url, Show (URLT url)) => url -> String
clean = filter isAlphaNum . show . toURL


{-# LANGUAGE TypeFamilies #-}
module T8011a ( ToURL(toURL, nullURL, errorURL, URLT) ) where

class ToURL a where
     type URLT a
     toURL :: a -> URLT a
     nullURL :: a
     errorURL :: a -> URLT a


{-# LANGUAGE TypeFamilies #-}

module T8018 where

data Foo a = Bar (F a)

type family F a where
  F (Foo a) = Bool


{-# LANGUAGE TypeFamilies #-}

module T8020 where

type family F a b where
  F (Maybe a) [a] = Int
  F b c           = Bool

data Proxy a = P

type family G

foo :: Proxy d -> F d d -> Bool
foo _ = not

bar :: Bool -> Bool
bar = foo (P :: Proxy G)


 {-# LANGUAGE TypeFamilies #-}

module T8500 where

import T8500a

instance C Int where
   type F Int = Double

instance C Bool


{-# LANGUAGE TypeFamilies #-}

module T8500a where

class C a where
   type F a
   type F a = [a]


{-# LANGUAGE RankNTypes, FlexibleContexts, TypeFamilies #-}
module T8651 where

import Data.Monoid

type family Id a

type instance Id a = a
 --type instance Id [a] = [Id a]

foo :: (Monoid (Id String) => r) -> r
foo x = x

bar = foo "Hello"


{-# LANGUAGE TypeFamilies, ConstraintKinds #-}
{-# OPTIONS_GHC -fwarn-missing-signatures #-}  -- Report f's inferred type

module T8889 where

import GHC.Exts

class C f where
  type C_fmap f a :: Constraint
  foo :: C_fmap f a => (a -> b) -> f a -> f b

f x = foo x


{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PolyKinds #-}

module T8913 where

import Data.Kind (Type)

class GCat f where
   gcat :: f p -> Int

cat :: (GCat (MyRep a), MyGeneric a) => a -> Int
cat x = gcat (from x)

class MyGeneric a where
   type MyRep a :: Type -> Type
   from :: a -> (MyRep a) p


{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
module T8978 where

import Data.Kind (Type)

type Syn a = Associated a

class Eq (Associated a) => Foo a where
    type Associated a :: Type
    foo :: a -> Syn a -> Bool

instance Foo () where
    type Associated () = Int
    foo _ x = x == x


{-# LANGUAGE TypeFamilies #-}
module T8979 where

type family F a
type family G a

type H a = G a

f :: F (G Char) -> F (H Char)
f a = a


{-# LANGUAGE TypeFamilies #-}

module T9085 where

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


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

module T9090 where

import GHC.Exts (Constraint)

type family F (c :: Constraint) :: Constraint
type instance F (Eq a) = Eq a

-- checks
f :: Eq b => (forall a. F (Eq a) => f a -> Bool) -> f b -> Bool
f _ = error "urk" -- g x = g x

-- checks
f' :: Eq b => (forall a. Eq a => f a -> Bool) -> f b -> Bool
f' = f

-- checks, so GHC seems to think that both types are interchangeable
f'' :: Eq b => (forall a. F (Eq a) => f a -> Bool) -> f b -> Bool
f'' = f'

-- checks
test' y = f' (\ (Just x) -> x /= x) y

-- fails
test y = f (\ (Just x) -> x /= x) y

-- fails too, unsurprisingly
test'' y = f'' (\ (Just x) -> x /= x) y


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

module T9211 where

-- foo :: (forall f g. (Functor f) => f a -> f b) -> [a] -> [b]
foo :: (forall f g. (Functor f, g ~ f) => g a -> g b) -> [a] -> [b]
foo tr x = tr x

t = foo (fmap not) [True]


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}

module SingletonsBug where

import Control.Applicative
import Data.Traversable (for)
import Data.Kind (Type, Constraint)

-----------------------------------
-- From 'constraints' library
-- import Data.Constraint (Dict(..))
data Dict :: Constraint -> Type where
  Dict :: a => Dict a

-----------------------------------
-- From 'singletons' library
-- import Data.Singletons hiding( withSomeSing )

class SingI (a :: k) where
  -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@
  -- extension to use this method the way you want.
  sing :: Sing a

data family Sing (a :: k)

data KProxy (a :: Type) = KProxy

data SomeSing (kproxy :: KProxy k) where
  SomeSing :: Sing (a :: k) -> SomeSing ('KProxy :: KProxy k)

-- SingKind :: forall k. KProxy k -> Constraint
class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where
  -- | Get a base type from a proxy for the promoted kind. For example,
  -- @DemoteRep ('KProxy :: KProxy Bool)@ will be the type @Bool@.
  type DemoteRep kparam :: Type

  -- | Convert a singleton to its unrefined version.
  fromSing :: Sing (a :: k) -> DemoteRep kparam

  -- | Convert an unrefined type to an existentially-quantified singleton type.
  toSing   :: DemoteRep kparam -> SomeSing kparam

withSomeSing :: SingKind ('KProxy :: KProxy k)
             => DemoteRep ('KProxy :: KProxy k)
             -> (forall (a :: k). Sing a -> r)
             -> r
withSomeSing _ _ = error "urk"

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

data SubscriptionChannel = BookingsChannel
type BookingsChannelSym0 = BookingsChannel
data instance Sing (z_a5I7 :: SubscriptionChannel) where
   SBookingsChannel :: Sing BookingsChannel

instance SingKind ('KProxy :: KProxy SubscriptionChannel) where
  type DemoteRep ('KProxy :: KProxy SubscriptionChannel) = SubscriptionChannel
  fromSing SBookingsChannel = BookingsChannel
  toSing BookingsChannel = SomeSing SBookingsChannel

instance SingI BookingsChannel where
  sing = SBookingsChannel

type family T (c :: SubscriptionChannel) :: Type
type instance T 'BookingsChannel = Bool

witnessC :: Sing channel -> Dict (Show (T channel), SingI channel)
witnessC SBookingsChannel = Dict

forAllSubscriptionChannels
  :: forall m r. (Applicative m)
  => (forall channel. (SingI channel, Show (T channel)) => Sing channel -> m r)
  -> m r
forAllSubscriptionChannels f =
  withSomeSing BookingsChannel $ \(sChannel) ->
    case witnessC sChannel of
      Dict -> f sChannel


{-# LANGUAGE InstanceSigs, TypeFamilies #-}
module T9582 where

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

instance C Int where
  type T Int = String
  m :: Int -> String
  m _ = "bla"

-- Method signature does not match class; it should be m :: T Int
--    In the instance declaration for â€˜C Intâ€™


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

module T9662 where

data Exp a = Exp
data (a:.b) = a:.b

type family Plain e :: *
type instance Plain (Exp a) = a
type instance Plain (a:.b) = Plain a :. Plain b

class (Plain (Unlifted pattern) ~ Tuple pattern) => Unlift pattern where
   type Unlifted pattern
   type Tuple pattern

modify :: (Unlift pattern) =>
   pattern ->
   (Unlifted pattern -> a) ->
   Exp (Tuple pattern) -> Exp (Plain a)
modify p f = undefined

data Atom a = Atom

atom :: Atom a
atom = Atom

instance (Unlift pa, int ~ Atom Int) => Unlift (pa :. int) where
   type Unlifted (pa :. int) = Unlifted pa :. Exp Int
   type Tuple (pa :. int) = Tuple pa :. Int

data Shape sh = Shape

backpermute ::
   (Exp sh -> Exp sh') ->
   (Exp sh' -> Exp sh) ->
   Shape sh -> Shape sh'
backpermute = undefined

test :: Shape (sh:.k:.m:.n) -> Shape (sh:.m:.n:.k)
test =
   backpermute
      (modify (atom:.atom:.atom:.atom)
         (\(sh:.k:.m:.n) -> (sh:.m:.n:.k)))
      id

-- With this arg instead of just 'id', it worked
--    (modify (atom:.atom:.atom:.atom)
--       (\(ix:.m:.n:.k) -> (ix:.k:.m:.n)))


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

module T9747 where
import Data.List (intercalate)
import Data.Proxy
import Data.Kind (Type, Constraint)

data HList :: [Type] -> Type where
  Nil :: HList '[]
  Cons :: a -> HList as -> HList (a ': as)

type family HListAll (c :: Type -> Constraint)
                     (ts :: [Type]) :: Constraint where
  HListAll c '[] = ()
  HListAll c (t ': ts) = (c t, HListAll c ts)

showHList :: HListAll Show ts => HList ts -> String
showHList = ("[" ++ ) . (++"]") . intercalate ", " . go
  where
    go :: HListAll Show ts => HList ts -> [String]
    go Nil = []
    go (Cons x xs) = show x : go xs

-- Things work okay up to this point
test :: String
test = showHList (Cons (2::Int)
                 (Cons (3.1 :: Float)
                 (Cons 'c' Nil)))

type family ConFun (t :: Type) :: Type -> Constraint
data Tag
type instance ConFun Tag = Group

class (Show a, Eq a, Ord a) => Group a

-- This is notionally similar to showHList
bar :: HListAll (ConFun l) ts => Proxy l -> HList ts -> ()
bar _ _ = ()

baz :: (ConFun l a, ConFun l b) => Proxy l -> HList [a,b] -> ()
baz = bar


{-# LANGUAGE TypeFamilies #-}

module T9840 where

import Data.Kind (Type)
import T9840a

type family X :: Type -> Type where

type family F (a :: Type -> Type) where

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


{-# LANGUAGE TypeFamilies #-}

module T9840a where

import {-# SOURCE #-} T9840

type family G a where

bar :: X a -> X a
bar = id


{-# LANGUAGE GADTs, TypeFamilies #-}

module TF_GADT where

-- Check that type families can be declared in GADT syntax
-- and indeed *be* GADTs

data family T a

data instance T [a] where
  T1 :: a -> T [a]

data instance T (Maybe a) where
  T3 :: Int -> T (Maybe Int)
  T4 :: a -> b -> T (Maybe (a,b))

f :: a -> T (Maybe a) -> T (Maybe a)
f x (T3 i) = T3 x
f x (T4 p q) = T4 p (snd x)


{-# LANGUAGE TypeFamilies, PolyKinds #-}

-- See Trac #10982

module UnusedTyVarWarnings where

type family C a b where
  C a b = a                 -- should warn

type family C2 a b
type instance C2 a b = a    -- should warn

type family D a b where
  D a _b = a                -- should not warn

type family D2 a b
type instance D2 a _b = a   -- should not warn

type family E a b where
  E a _ = a                 -- should not warn

type family E2 a b
type instance E2 a _ = a    -- should not warn

type family X a b where
  X a a = Int               -- a is considered used, do not warn
  X a Int = Bool            -- here a is unused

type family Y a b c where
  Y a b b = a               -- b is used, do no warn

data family I a b c
data instance I a b c = IDC1 a | IDC2 c  -- should warn

data family J a b
data instance J a _b = JDC a  -- should not warn

data family K a b
data instance K a _ = KDC a   -- should not warn


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

-- See Trac #10982

module UnusedTyVarWarningsNamedWCs where

type family C a b where
  C a b = a                 -- should warn

type family C2 a b
type instance C2 a b = a    -- should warn

type family D a b where
  D a _b = a                -- should not warn

type family D2 a b
type instance D2 a _b = a   -- should not warn

type family E a b where
  E a _ = a                 -- should not warn

type family E2 a b
type instance E2 a _ = a    -- should not warn

type family X a b where
  X a a = Int               -- a is considered used, do not warn
  X a Int = Bool            -- here a is unused

type family Y a b c where
  Y a b b = a               -- b is used, do no warn

data family I a b c
data instance I a b c = IDC1 a | IDC2 c  -- should warn

data family J a b
data instance J a _b = JDC a  -- should not warn

data family K a b
data instance K a _ = KDC a   -- should not warn


{-# LANGUAGE TypeFamilies, DeriveGeneric #-}

module T13092b_1 where

import GHC.Generics

data X = X deriving (Generic)


{-# LANGUAGE TypeFamilies #-}

module T13092b_2 where

import T13092b_1

x :: X
x = X


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

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

import Data.Proxy
import GHC.Exts

data Message

data SocketType = Dealer | Push | Pull

data SocketOperation = Read | Write

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

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

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

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

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

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

{-
dealer :: Socket Dealer
dealer = undefined

push :: Socket Push
push = undefined

pull :: Socket Pull
pull = undefined

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


{-# LANGUAGE TypeFamilies #-}

module ClosedFam3 where

import ClosedFam3a

type family Foo a where
  Foo Int = Bool
  Foo Double = Char

type family Bar a where
  Bar Int = Bool
  Bar Double = Double

type family Baz a where
  Baz Int = Bool


module ClosedFam3a where

import {-# SOURCE #-} ClosedFam3


{-# LANGUAGE TypeFamilies #-}

module ClosedFam4 where

type family Foo a where ..


{-# LANGUAGE TypeFamilies, StandaloneDeriving #-}

-- Crashed 6.12

module T1769 where

data family T a
deriving instance Functor T


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

module ExplicitForAllFams3 where

type family H a b where
  forall a.   H [a] (Maybe b) = Double

type family J a
type instance forall a.   J (a, b) = Bool

data family K a
data instance forall a.   K (a, b)    = K4 Bool

data family L a
newtype instance forall a.   L (a, b)    = L4 { unL4 :: Bool    }

class C a where
  type CT a b
  data CD a b
instance C Int where
  type forall a.   CT [a] (Maybe b) = Bool
  data forall a.   CD [a] (Maybe b) = CD4 Bool


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

module ExplicitForAllFams4a where

type family H a b where
  forall a b. H [a] (a,a)     = Float
  forall b.   H _ _           = Maybe b


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

module ExplicitForAllFams4 where

type family J a
type instance forall a b. J [a]    = Float
type instance forall b.   J _      = Maybe b

data family K a
data instance forall a b. K (a, Bool) = K5 Float
data instance forall b.   K _         = K6 (Maybe b)

data family L a
newtype instance forall a b. L (a, Bool) = L5 { unL5 :: Float   }
newtype instance forall b.   L _         = L6 { unL56:: Maybe b }

class C a where
  type CT a b
  data CD a b

instance C Int where
  type forall a b. CT [a] (a,a)     = Float
  type forall b.   CT _ _           = Maybe b

  data forall a b. CD [a] (a,a)     = CD5 Float
  data forall b.   CD _ _           = CD6 (Maybe b)


{-# LANGUAGE TypeFamilies, FunctionalDependencies, FlexibleContexts, GADTs, ScopedTypeVariables #-}

module ExtraTcsUntch where

class C x y | x -> y where
 op :: x -> y -> ()

instance C [a] [a]

type family F a :: *

h :: F Int -> ()
h = undefined

data TEx where
  TEx :: a -> TEx

f x =
    let g1 :: forall b. b -> ()
        g1 _ = h [x]

        g2 z = case z of TEx y -> (h [[undefined]], op x [y])

    in (g1 '3', g2 undefined)

{- This example comes from Note [Extra TcS Untouchables] in TcSimplify. It demonstrates
   why when floating equalities out of an implication constraint we must record the free
   variables of the equalities as untouchables. With GHC 7.4.1 this program gives a Core
   Lint error because of an existential escaping.

    assuming x:beta

    forall b. F Int ~ [beta]                          (from g1)
    forall a. F Int ~ [[alpha]], C beta [a]           (from g2)

-}

{- Assume x:beta
   From g1 we get [W]    (forall b.  F Int ~ [beta])

   From g2 we get [W]   (forall c. 0 => F Int ~ [[alpha]] /\ C beta [c])
    (g2 is not generalised; the forall comes from the TEx pattern)

approximateWC then gives the candidate constraints to quantify
   F Int ~ [beta], F Int ~ [[alpha']]

(alpha' is the promoted version of alpha)

Now decide inferred sig for f :: F Int ~ [beta] => beta -> blah
since beta is mentioned in tau-type for f but alpha' is not

Perhaps this is a stupid constraint to generalise over (we don't
generalise over (C Int).
-}


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

module ShouldFail where

type family Const a
type instance Const a = ()

data T a where T :: c -> T (Const c)

coerce :: forall a b . a -> b
coerce x = case T x :: T (Const b) of
             T y -> y

{-
  T :: forall a. forall c. (a ~ Const c) => c -> T a

  a ~ gamma        -- Instantiate T with a=alpha, c=gamma
  alpha ~ Const b  -- Result of (T x)
  alpha ~ Const gamma  -- Constraint from (T x)

  y::c
  forall c. (Const b ~ Const c) => c ~ b

==>
  Const b ~ Const a

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

case e of
  T y -> y

  e :: T alpha

  Patterns
   forall c. (alpha ~ Const c) => c ~ b
   alpha ~ Const b

-}


{-# LANGUAGE TypeFamilies #-}

type family F a b
type instance F a a = Int
type instance F [a] a = Bool


{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeFamilies #-}

-- Type error message looks like
--      TF.hs:12:11:
--    Couldn't match expected type `Memo d'
--           against inferred type `Memo d1'
--      NB: `Memo' is a (non-injective) type function
--
-- Note the "NB", which helps point out the problem

module Foo where

class Fun d where
    type Memo d :: * -> *
    abst :: (d -> a) -> Memo d a
    appl :: Memo d a -> (d -> a)

f ::  (Fun d) => Memo d a -> Memo d a    -- (1)
f = abst . appl


{-# LANGUAGE TypeFamilies #-}

-- This is actually perfectly ok!

module NonLinearSigErr where

import Data.Kind (Type)

type family E a b
type instance E a (a :: Type) = [a]


{-# LANGUAGE TypeFamilies #-}

module NotRelaxedExamples where

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

type instance F1 Char = F1 (F1 Char)
type instance F2 [x]  = F2 [x]
type instance F3 Bool = F3 [Char]


{-# LANGUAGE TypeFamilies #-}

module OverA (C, D)
where

import Data.Kind (Type)

data family C a b :: Type

type family D a b :: Type


{-# LANGUAGE TypeFamilies #-}

module OverB
where
import OverA (C, D)

data instance C [Int] [a] = CListList2

type instance D [Int] [a] = Int


{-# LANGUAGE TypeFamilies #-}

module OverC
where
import OverA (C, D)

data instance C [a] [Int] = C9ListList

type instance D [a] [Int] = Char


module OverD where
-- Tests that we verify consistency of type families between
-- transitive imports.
import OverB
import OverC


{-# LANGUAGE TypeFamilies #-}

module OverDirectThisModA (C, D)
where

import Data.Kind (Type)

data family C a b :: Type

type family D a b :: Type


{-# LANGUAGE TypeFamilies #-}

module OverDirectThisModB
where
import OverDirectThisModA (C, D)

data instance C [Int] [a] = CListList2

type instance D [Int] [a] = Int


{-# LANGUAGE TypeFamilies #-}
-- Tests that we check family instance consistency between
-- type family instances defined in the currently compiled module
-- and the direct imports.
module OverDirectThisModC
where
import OverDirectThisModB
import OverDirectThisModA (C, D)

data instance C [a] [Int] = C9ListList

type instance D [a] [Int] = Char


{-# LANGUAGE TypeFamilies #-}

module OverIndirectThisModA (C, D)
where

import Data.Kind (Type)

data family C a b :: Type

type family D a b :: Type


{-# LANGUAGE TypeFamilies #-}

module OverIndirectThisModB
where
import OverIndirectThisModA (C, D)

data instance C [Int] [a] = CListList2

type instance D [Int] [a] = Int


module OverIndirectThisModC where
import OverIndirectThisModB


{-# LANGUAGE TypeFamilies #-}
-- Tests that we check family instance consistency between
-- type family instances defined in the currently compiled module
-- and the transitive imports.
module OverIndirectThisModD
where
import OverIndirectThisModC
  -- imports OverIndirectThisModB with conflicting instances
import OverIndirectThisModA (C, D)

data instance C [a] [Int] = C9ListList

type instance D [a] [Int] = Char


{-# LANGUAGE TypeFamilies #-}

module Overlap10 where

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

g :: a -> F a Bool
g x = False


{-# LANGUAGE TypeFamilies #-}

module Overlap11 where

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

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


{-# LANGUAGE TypeFamilies #-}

-- In an ideal world, this would work. But, GHC doesn't implement
-- a full infinite-type unifier, so it can't figure out that F b [b] Bool
-- can safely reduce to Bool.

module Overlap15 where

import Data.Proxy

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

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


{-# LANGUAGE TypeFamilies #-}

module Overlap3 where

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

g :: F Char Double
g = False

h :: F Double Double
h = -2


{-# LANGUAGE TypeFamilies #-}

module Overlap4 where

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


{-# LANGUAGE TypeFamilies #-}

module Overlap5 where

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


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

module Overlap6 where

type family And (a :: Bool) (b :: Bool) :: Bool where
  And False x = False
  And True x = False -- this is wrong!
  And x False = False
  And x True = x
  And x x = x

data Proxy p = P

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


{-# LANGUAGE TypeFamilies #-}

module Overlap7 where

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


{-# LANGUAGE TypeFamilies #-}

module Overlap9 where

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

g :: Show a => a -> F a
g x = length (show x)


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

import Data.Kind (Type)

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

instance C8 Int where
  data S8 Int a = S8Int a

-- Extra argument is not a variable; this is fine
instance C8 Bool where
  data S8 Bool Char = S8Bool


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

data family C9 a b :: *
data instance C9 Int Int = C9IntInt
-- must fail: conflicting
data instance C9 Int Int = C9IntInt2

type family D9 a b :: *
type instance D9 Int Int = Char
-- must fail: conflicting
type instance D9 Int Int = Int


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

data family C9 a b :: *
data instance C9 Int Int = C9IntInt
data instance C9 [a] Int = C9ListInt
-- must fail: conflicting
data instance C9 [a] Int = C9ListInt2

type family D9 a b :: *
type instance D9 Int Int = Int
type instance D9 [a] Int = [a]
-- must fail: conflicting
type instance D9 [a] Int = Maybe a

type instance D9 Int [a] = [a]
type instance D9 Int [b] = [b]  -- must not conflict!


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

data family C9 a b :: *
data instance C9 Int Int = C9IntInt
data instance C9 [a] Int = C9ListInt
-- must fail: conflicting
data instance C9 [Int] Int = C9ListInt2

type family D9 a b :: *
type instance D9 Int Int = Int
type instance D9 [a] Int = [a]
-- must fail: conflicting
type instance D9 [Int] Int = [Bool]

type family E9 a b :: *
type instance E9 Int   Int = Int
type instance E9 [a]   Int = [a]
type instance E9 [Int] Int = [Int]   -- does *not* conflict!
type instance E9 b     Int = b


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

data family C9 a b :: *
data instance C9 Int Int = C9IntInt
data instance C9 [a] Int = C9ListInt
data instance C9 [Int] [a]   = C9ListList2
-- must fail: conflicting
data instance C9 [a]   [Int] = C9ListList


{-# LANGUAGE TypeFamilies, RankNTypes #-}

module ShouldFail where

type family C a :: *
-- must fail: rhs is not a tau type
type instance C Int = forall a. [a]


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

type family C a :: *

data family D a :: *
-- must fail: lhs contains a type family application
data instance D [C a] = DC

type family E a :: *
-- must fail: lhs contains a type family application
type instance E [C a] = Int


{-# LANGUAGE TypeFamilies #-}

module Simple14 where

data T a = T (a~a)


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

foo :: (a,b) -> (a~b => t) -> (a,b)
foo p x = p


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

type family F a

foo :: p a -> p a
foo x = x

bar = foo (undefined :: F ())


{-# LANGUAGE TypeFamilies #-}

data family T1 a :: * -> *
data instance T1 Int           = T1_1   -- must fail: too few args


{-# LANGUAGE TypeFamilies #-}

data family T1 a :: * -> *
data instance T1 Int Bool Char = T1_3   -- must fail: too many args


{-# LANGUAGE TypeFamilies #-}

module Simple2a where

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

instance C Int where
  data    Sd a = MkSd -- :: *   -- Looks like a nullary data instance decl
  data    Sd Int = SdC Char
  newtype Sn Int = SnC Char
  type    St Int = Char


{-# LANGUAGE TypeFamilies #-}

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

instance C Int where
  data    Sd Int = SdC1 Char    -- must fail: conflicting
  data    Sd Int = SdC2 Char    --            declarations
  newtype Sn Int = SnC Char
  type    St Int = Char


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

class C1 a where
  data S1 a :: *

-- must fail: wrong category of type instance
instance C1 Int where
  type S1 Int = Bool


{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}

module ShouldFail where

import Data.Kind (Type)

-- must fail: defaults have no patterns
class C2 a b where
  type S2 a :: Type
  type S2 Int = Char


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

class C3 a where
  data    S3  a :: *
  data    S3n a :: *
  foo3  :: a -> S3 a
  foo3n :: a -> S3n a
  bar3  :: S3 a -> a
  bar3n :: S3n a -> a

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

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

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

-- must fail: signature too general
bar3wrong :: S3 a -> a
bar3wrong D3Int  = 1


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

class C3 a where
  data    S3  a :: *
  data    S3n a :: *
  foo3  :: a -> S3 a
  foo3n :: a -> S3n a
  bar3  :: S3 a -> a
  bar3n :: S3n a -> a

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

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

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

-- must fail: Can't match Int against Char
bar3wrong' D3Int  = 1
bar3wrong' D3Char = 'a'


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

-- must fail: Repeated type variable
class C4 a where
  data S4 a a :: *


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

-- must fail: AT must be in class instance
class C5 a where
  data S5 a :: *
data instance S5 Int = S5


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

-- must fail: C6 has no ATs S3 and Map
class C6 a

instance C6 Integer where
  data Map Integer v = MapInteger
  data S3 Integer = S3Integer


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

module ShouldFail where

import Data.Kind

class C7 a b where
  data S7 b :: Type

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

-- Fails because the arg to S7 should be the
-- same as that to C7
instance C7 Char (a, Int) where
  data S7 (b, Int) = S7_2


{-# OPTIONS_GHC -ftype-function-depth=3 #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, EmptyDataDecls #-}

module SkolemOccursLoop where

-- SkelemOccurs tests by Tom and Martin

data T x
type family F x
type instance F [x] = [T (F x)]

t :: a -> a -> Bool
t _ _ = True

f :: a -> F [a]
f = undefined

test1 :: (F [a] ~ a) => a -> Bool
test1 x = t x (f x)

--

data S a
type family G x
type instance G (S x, y) = S (G (x,y))

g :: a -> G [a]
g = undefined

test2 :: (G (S a,a) ~ a) => a -> Bool
-- inferred: G [a] ~ a => a -> Bool
test2 x = t x (g x)


{-# LANGUAGE TypeFamilies, PolyKinds #-}

module T10141 where

type family G (a :: k) where
   G Int  = Bool
   G Bool = Int
   G a    = a


{-# LANGUAGE TypeFamilies #-}

module T10817 where

import Data.Proxy

class C a where
  type F a
  type F a = F a

instance C Bool

x :: Proxy (F Bool)
x = Proxy


{-# LANGUAGE TypeFamilies, RankNTypes #-}

module T10899 where

class C a where
  type F a
  type F a = forall m. m a


{-# LANGUAGE TypeFamilies #-}

module T11136 where

class C a where
  type D a
  type instance D a x = x


{-# LANGUAGE TypeFamilies #-}

module T11450 where

class C x where
  type T x

instance C (Either a b) where
  type T (Either b a) = b -> a


{-# Language PolyKinds, TypeFamilies #-}

module T12041 where

import Data.Kind

class Category (p :: i -> i -> Type) where
  type Ob p :: i -> Constraint

data I a b
instance Category I where
  type Ob I = (~) Int


{-# LANGUAGE TypeFamilies #-}

module T12386 where

class C a where
   type family F a t :: *

   type family T a :: *
   type T a = F a


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

module T12522a where

import Data.Kind (Type)

newtype I a = I a

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

data Uncurried (as :: [Type]) b

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

-- test :: Uncurried [Int, String] String
test = def $ \n s -> I $ show n ++ s


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

module T12866 where

type Test2 a = (Eq (TestM a))

class Test a where
    type TestM :: *


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilyDependencies #-}

module T13271 where

import GHC.TypeLits

data T1 = T1
type T2 = TypeError (Text "You can't do that!")

type family X i = r | r -> i where
  X 1 = T1
  X 2 = T2


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module T13674 where

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

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

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

-- | Given that @a :- b@, derive something that needs a context @b@, using the context @a@
(\\) :: a => (b => r) -> (a :- b) -> r
r \\ Sub Dict = r

newtype Magic n = Magic (KnownNat n => Dict (KnownNat n))

magic :: forall n m o. (Integer -> Integer -> Integer) -> (KnownNat n, KnownNat m) :- KnownNat o
magic f = Sub $ unsafeCoerce (Magic Dict) (natVal (Proxy :: Proxy n) `f` natVal (Proxy :: Proxy m))

type family Lcm :: Nat -> Nat -> Nat where

axiom :: forall a b. Dict (a ~ b)
axiom = unsafeCoerce (Dict :: Dict (a ~ a))

lcmNat :: forall n m. (KnownNat n, KnownNat m) :- KnownNat (Lcm n m)
lcmNat = magic lcm

lcmIsIdempotent :: forall n. Dict (n ~ Lcm n n)
lcmIsIdempotent = axiom

newtype GF (n :: Nat) = GF Integer

x :: GF 5
x = GF 3

y :: GF 5
y = GF 4

foo :: (KnownNat m, KnownNat n) => GF m -> GF n -> GF (Lcm m n)
foo m@(GF x) n@(GF y) = GF $ (x*y) `mod` (lcm (natVal m) (natVal n))

bar :: (KnownNat m)  => GF m -> GF m -> GF m
bar (x :: GF m) y = foo x y - foo y x \\ lcmNat @m @m \\ Sub @() (lcmIsIdempotent @m)


{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs #-}
{-# LANGUAGE KindSignatures, MultiParamTypeClasses, TypeFamilies,
             TypeOperators #-}

module T13784 where

import Data.Kind (Type)
import Data.Monoid ((<>))

data Product :: [Type] -> Type where
    (:*) :: a -> Product as -> Product (a : as)
    Unit :: Product '[]
infixr 5 :*

instance Show (Product '[]) where
    show Unit = "Unit"

instance (Show a, Show (Product as)) => Show (Product (a : as)) where
    show (a :* as) = show a <> " :* " <> show as

class Divideable a as where
    type Divide a as :: [Type]
    divide :: Product as -> (a, Product (Divide a as))

instance Divideable a (a : as) where
    -- type Divide a (a : as) = as
    -- Conflicting type family instances, seems like OVERLAPS isn't a thing for
    -- type families.
    divide (a :* as) = (a, as)

instance Divideable b as => Divideable b (a : as) where
    type Divide b (a : as) = a : Divide b as
    divide (a :* as) = a :* divide as


{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
module T13877 where

import Data.Kind

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

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

listElim :: forall (a :: Type) (p :: [a] -> Type) (l :: [a]).
            Sing l
         -> p '[]
         -> (forall (x :: a) (xs :: [a]). Sing x -> Sing xs -> p xs -> p (x:xs))
         -> p l
listElim = listElimPoly @(:->) @a @p @l

listElimTyFun :: forall (a :: Type) (p :: [a] ~> Type) (l :: [a]).
                 Sing l
              -> p @@ '[]
              -> (forall (x :: a) (xs :: [a]). Sing x -> Sing xs -> p @@ xs -> p @@ (x:xs))
              -> p @@ l
listElimTyFun = listElimPoly @(:->) @a @p @l

listElimPoly :: forall (arr :: FunArrow) (a :: Type) (p :: ([a] -?> Type) arr) (l :: [a]).
                FunApp arr
             => Sing l
             -> App [a] arr Type p '[]
             -> (forall (x :: a) (xs :: [a]). Sing x -> Sing xs -> App [a] arr Type p xs -> App [a] arr Type p (x:xs))
             -> App [a] arr Type p l
listElimPoly SNil                      pNil _     = pNil
listElimPoly (SCons x (xs :: Sing xs)) pNil pCons = pCons x xs (listElimPoly @arr @a @p @xs xs pNil pCons)


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

import Data.Kind

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

-- This used to fail, with a mysterious error messate
--    Type indexes must match class instance head
--      Expected: T (a1 -> Either a1 b1)
--      Actual: T (a -> Either a b)
-- but now it succeeds fine

instance C Left where
  type T (a -> Either a b) = Int


{-# LANGUAGE TypeFamilies #-}

module T14033 where

newtype Zero = Zero
newtype Succ a = Succ a

type family Add n m :: * where
     Add Zero m = m
     Add (Succ n) m = Succ (Add n m)


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

module T14045a where

import Data.Kind

class C (a :: k) where
  data S (a :: k)

-- This used to fail with the mysterious error
--   Type indexes must match class instance head
--     Expected: S z
--     Actual: S a
-- But now it is fine
instance C (z :: Bool) where
  data S :: Bool -> Type where
    SF :: S False
    ST :: S True


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

module T14175 where

import Data.Kind

type family PComp (k :: j -> Type) (x :: k) :: ()


{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
module T14179 where

data family   Foo1 a
data instance Foo1 a
data instance Foo1 a

data family   Foo2 :: k -> *
data instance Foo2 :: * -> *
data instance Foo2 :: * -> *

data family Foo3 a
data instance Foo3 [a] where
  Foo3a :: Foo3 [Int]
  Foo3b :: Foo3 [Bool]
data instance Foo3 [a] where
  Foo3c :: Foo3 [a]
  Foo3d :: Foo3 [Char]


{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module T14230 where

class C k where
  data CD :: k -> k -> *

instance C (Maybe a) where
  data CD :: (k -> *) -> (k -> *) -> *


{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
module T14230a where

import Data.Kind

class C a where
  data CD k (a :: k) :: k -> *

instance C (Maybe a) where
  data CD k (a :: k -> *) :: (k -> *) -> *


{-# LANGUAGE RankNTypes, GADTs, TypeOperators, PolyKinds, DataKinds, TypeFamilies, AllowAmbiguousTypes, UndecidableInstances, TypeInType #-}

module T14246 where

import Data.Kind

data Nat = Z | S Nat

data Vect :: Nat -> Type -> Type where
  Nil  :: Vect Z a
  Cons :: a -> Vect n a -> Vect (S n) a

data Label a = Label a

data L

type family KLN (n :: k) :: Nat where
    KLN (f :: v -> k) = S (KLN (forall t. f t))
    KLN (f :: Type) = Z

type family Reveal (n :: k) (l :: Vect (KLN n) L) :: Type where
    Reveal (f :: v -> k) (Cons (Label (t :: v)) l) = Reveal (f t) l
    Reveal (a :: Type) Nil = a


{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
module T14369 where

data family Sing (a :: k)

data instance Sing (z :: Maybe a) where
  SNothing :: Sing Nothing
  SJust :: Sing x -> Sing (Just x)

class SingKind k where
  type Demote k = r | r -> k
  fromSing :: Sing (a :: k) -> Demote k

instance SingKind a => SingKind (Maybe a) where
  type Demote (Maybe a) = Maybe (Demote a)
  fromSing SNothing = Nothing
  fromSing (SJust x) = Just (fromSing x)

f :: forall (x :: forall a. Maybe a) a. SingKind a => Sing x -> Maybe (Demote a)
f = fromSing


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fprint-explicit-kinds #-}
module T14887 where

import Data.Kind
import Data.Type.Equality

type family Foo1 (e :: (a :: k) :~: (a :: k)) :: Type where
  Foo1 (e :: a :~: a) = a :~: a

type family Foo2 (k :: Type) (e :: (a :: k) :~: (a :: k)) :: Type where
  Foo2 k (e :: a :~: a) = a :~: a


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

module T14904 where

import Data.Kind

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


{-# LANGUAGE TypeFamilies, ConstraintKinds, FlexibleInstances #-}
module ShouldFail where

import GHC.Exts( Constraint )

type family F a :: Constraint

class C a where

-- Should be rejected because of the type family
instance (F a) => C [[a]] where


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

module T15740 where

import Data.Kind

type family F2 :: forall k. k -> Type
data SBool :: Bool -> Type
data Nat
data SNat :: Nat -> Type
type instance F2 = SBool
type instance F2 = SNat


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

module T15764 where

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

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


{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeOperators          #-}

module T15870 where

data Optic a where
  --Index :: Nat    -> Optic a
  --Name  :: Symbol -> Optic a
  (:.:) :: Optic a -> Optic b -> Optic a -- composition

class Gettable a (optic :: Optic a) where
  type Get a (optic :: Optic a)

{-
some basic instances, e.g.
instance Gettable (a,b) (Index 0) where
  type Get (a,b) (Index 0) = a
...
-}

instance forall a b (g1 :: Optic a) (g2 :: Optic b).
        ( Gettable a g1
        , b ~ Get a g1
        , Gettable b g2
        ) => Gettable a (g1 :.: g2) where
  type Get a (g1 :.: g2) = Get a g2


{-# LANGUAGE TypeFamilies #-}

module T1897b where

import Control.Monad
import Data.Maybe

class Bug s where
  type Depend s

  next  :: s -> Depend s -> Maybe s
  start :: s

-- isValid :: (Bug s) => [Depend s] -> Bool
-- Inferred type should be rejected as ambiguous
isValid ds = isJust $ foldM next start ds


{-# LANGUAGE TypeFamilies, FlexibleContexts #-}

module Class4 where

class  (Eq (Depend s)) => Bug s where
  type Depend s
  trans :: Depend s -> Depend s

instance Bug Int where
  type Depend Int = ()
  trans = (+1)

check :: (Bug s) => Depend s -> Bool
check d = d == trans d

{-
 Given: (Bug s, Eq (Depend s))
      = (Bug s, Eq fsk, Depend s ~ fsk)

 Wanted: (Eq alpha,                 (invocation of == at alpha)
          Depend s ~ alpha          (first arg of ==)
          Depend sigma ~ alpha      (second arg of ==)
          Bug sigma,                (invocation of trans at sigma)
          Depend sigma ~ Depend s   (first arg of trans)

          {der}Eq (Depend sigma)    (superclass of Bug sigma)

==>
 Wanted: (Eq alpha,                 (invocation of == at alpha)
          Depend s ~ alpha          (first arg of ==)
          Depend sigma ~ alpha      (second arg of ==)
          Bug sigma,                (invocation of trans at sigma)
          {der}Eq (Depend sigma)    (superclass of Bug sigma)

==>
 Wanted: (Eq alpha,                 (invocation of == at alpha)
          Depend s ~ alpha          (first arg of ==)
          Depend sigma ~ alpha      (second arg of ==)
          Bug sigma,                (invocation of trans at sigma)

          {der}Eq uf_ahj
          Depend sigma ~ uf_ahj

==> uf := alpha
 Wanted: (Eq alpha,                 (invocation of == at alpha)
          Depend s ~ alpha          (first arg of ==)
          Depend sigma ~ alpha      (second arg of ==)
          Bug sigma,                (invocation of trans at sigma)
          {der}Eq alpha)
==> discharge Eq alpha from {der}
 Wanted: (Depend s ~ alpha          (first arg of ==)
          Depend sigma ~ alpha      (second arg of ==)
          Bug sigma,                (invocation of trans at sigma)
          {der}Eq alpha)

==> use given Depend s ~ fsk
 Wanted: (alpha ~ fsk
          Depend sigma ~ alpha      (second arg of ==)
          Bug sigma,                (invocation of trans at sigma)
          {der}Eq alpha)

==> alpha := fsk
 Wanted: ({given}alpha ~ fsk
          Depend sigma ~ alpha      (second arg of ==)
          Bug sigma,                (invocation of trans at sigma)
          {der}Eq fsk)

==> discharge {der} Eq fsk
 Wanted: ({given}uf ~ fsk
          Depend sigma ~ uf      (second arg of ==)
          Bug sigma,                (invocation of trans at sigma)

-}


{-# LANGUAGE TypeFamilies, LiberalTypeSynonyms #-}

module T2157 where

type S a b = a
type family F a :: * -> *
type instance F a = S a


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

module T2203a where

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

class Bar b where
   bar :: b -> Int

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


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

module T2239 where

data A = A
data B = B

class C a where c :: a -> String
instance C Bool where c _ = "Bool"
instance C Char where c _ = "Char"

-- via TFs
type family TF a
type instance TF A = Char
type instance TF B = Bool

tf :: forall a b. (b ~ TF a,C b) => a -> String
tf a = c (undefined:: b)

tfa = tf A
tfb = tf B

-- via FDs
class FD a b | a -> b
instance FD A Char
instance FD B Bool

fd :: forall a b. (FD a b,C b) => a -> String
fd a = c (undefined:: b)

fda = fd A
fdb = fd B

class MyEq a b | a->b, b->a
instance MyEq a a

simpleFD = id :: (forall b. MyEq b Bool => b->b)

simpleTF = id :: (forall b. b~Bool => b->b)

-- Actually these two do not involve impredicative instantiation,
-- so they now succeed
complexFD = id :: (forall b. MyEq b Bool => b->b)
               -> (forall c. MyEq c Bool => c->c)

complexTF = id :: (forall b. b~Bool => b->b)
               -> (forall c. c~Bool => c->c)

{- For example, here is how the subsumption check works for complexTF
   when type-checking the expression
      (id :: (forall b. b~Bool => b->b) -> (forall c. c~Bool => c->c))

   First, deeply skolemise the type sig, (level 3) before calling
   tcExpr on 'id'.  Then instantiate id's type:

      b~Bool |-3  alpha[3] -> alpha <= (forall c. c~Bool => c->c) -> b -> b

   Now decompose the ->

      b~Bool |-3  alpha[3] ~ b->b,  (forall c. c~Bool => c->c) <= a

   And this is perfectly soluble.  alpha is touchable; and c is instantiated.
-}


{-# LANGUAGE TypeFamilies #-}

-- Trac #2334

module Test where

data family F r

newtype instance F ()  = F () () deriving Eq
newtype instance F Int  = H deriving Eq

data instance F Bool = K1
data instance F Bool = K2