{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}

#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DeriveGeneric              #-}
#endif

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE PolyKinds                  #-}
#endif

{-# OPTIONS_GHC -fno-warn-orphans #-}

{-|
Module:      Derived.PolyKinds
Copyright:   (C) 2014-2015 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Stability:   Provisional
Portability: GHC

Defines data types with poly-kinded type variables.
-}
module Derived.PolyKinds (
      TyConCompose(..)
    , TyConProxy(..)
    , TyConReallyHighKinds
    , TyFamilyCompose(..)
    , TyFamilyProxy(..)
    , TyFamilyReallyHighKinds(..)
    ) where

#include "generic.h"

import           Data.Functor.Classes (Show1(..))

import           Generics.Deriving.Base
#if !defined(__LANGUAGE_DERIVE_GENERIC1__) || MIN_VERSION_template_haskell(2,7,0)
import qualified Generics.Deriving.TH as Generics
#endif

import           Test.QuickCheck (Arbitrary)

import           TextShow (TextShow(..), TextShow1(..), TextShow2(..))
import           TextShow.TH (deriveTextShow2, makeShowbPrec,
                              makeLiftShowbPrec, makeLiftShowbPrec2)

#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0))
import           Data.Functor.Classes (showsUnary1)
#else
import           Data.Functor.Classes (Show2(..), showsUnaryWith)
import           GHC.Show (appPrec, appPrec1, showSpace)
#endif

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

newtype TyConCompose f g h j k a b =
    TyConCompose (f (g (j a) (k a)) (h (j a) (k b)))
#if __GLASGOW_HASKELL__ >= 702
  deriving Generic
#endif

deriving instance Arbitrary (f (g (j a) (k a)) (h (j a) (k b))) =>
  Arbitrary (TyConCompose f g h j k a b)

#if defined(__LANGUAGE_DERIVE_GENERIC1__)
deriving instance ( Functor (f (g (j a) (k a)))
                  , Functor (h (j a))
                  ) => Generic1 (TyConCompose f g h j k a)
#endif

deriving instance Show (f (g (j a) (k a)) (h (j a) (k b))) =>
  Show (TyConCompose f g h j k a b)

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

newtype TyConProxy a b where
    TyConProxy :: () -> TyConProxy a b
  deriving ( Arbitrary
           , Show
#if __GLASGOW_HASKELL__ >= 702
           , Generic
# if defined(__LANGUAGE_DERIVE_GENERIC1__)
           , Generic1
# endif
#endif
           )

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

newtype TyConReallyHighKinds f a b c d e = TyConReallyHighKinds (f a b c d e)
  deriving ( Arbitrary
           , Show
#if __GLASGOW_HASKELL__ >= 702
           , Generic
# if defined(__LANGUAGE_DERIVE_GENERIC1__)
           , Generic1
# endif
#endif
           )

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

data family TyFamilyCompose
#if __GLASGOW_HASKELL__ >= 706
    (t :: k1 -> k2 -> *)
    (u :: k3 -> k4 -> k1)
    (v :: k3 -> k4 -> k2)
    (w :: k5 -> k3)
    (x :: k5 -> k4)
    (y :: k5)
    (z :: k5)
#else
    (t :: * -> * -> *)
    (u :: * -> * -> *)
    (v :: * -> * -> *)
    (w :: * -> *)
    (x :: * -> *)
    (y :: *)
    (z :: *)
#endif
    :: *

newtype instance TyFamilyCompose f g h j k a b =
    TyFamilyCompose (f (g (j a) (k a)) (h (j a) (k b)))
#if __GLASGOW_HASKELL__ >= 706
  deriving Generic
#endif

deriving instance Arbitrary (f (g (j a) (k a)) (h (j a) (k b))) =>
  Arbitrary (TyFamilyCompose f g h j k a b)

deriving instance Show (f (g (j a) (k a)) (h (j a) (k b))) =>
  Show (TyFamilyCompose f g h j k a b)

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

data family TyFamilyProxy
#if __GLASGOW_HASKELL__ >= 706
    (x :: k1) (y :: k2)
#else
    (x :: *)  (y :: *)
#endif
    :: *

newtype instance TyFamilyProxy a b where
    TyFamilyProxy :: () -> TyFamilyProxy a b
  deriving ( Arbitrary
           , Show
#if __GLASGOW_HASKELL__ >= 706
           , Generic
#endif
           )

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

data family TyFamilyReallyHighKinds
#if __GLASGOW_HASKELL__ >= 706
    (g :: k1 -> k2 -> k3 -> k4 -> k5 -> *)
    (v :: k1)
    (w :: k2)
    (x :: k3)
    (y :: k4)
    (z :: k5)
#else
    (g :: * -> * -> * -> * -> * -> *)
    (v :: *)
    (w :: *)
    (x :: *)
    (y :: *)
    (z :: *)
#endif
    :: *

newtype instance TyFamilyReallyHighKinds f a b c d e =
    TyFamilyReallyHighKinds (f a b c d e)
  deriving ( Arbitrary
           , Show
#if __GLASGOW_HASKELL__ >= 706
           , Generic
#endif
           )

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

#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0))
-- | Kludge to get type with the same instances as @g a@
newtype Apply g a = Apply (g a)

instance (Show1 g, Show a) => Show (Apply g a) where
    showsPrec d (Apply x) = showsPrec1 d x

instance (Functor (f (g (j a) (k a))), Functor (h (j a)),
          Show1 (f (g (j a) (k a))), Show1 (h (j a)), Show1 k) =>
  Show1 (TyConCompose f g h j k a) where
    showsPrec1 p (TyConCompose x) =
      showsUnary1 "TyConCompose" p $ fmap (Apply . fmap Apply) x
instance Show1 (TyConProxy (a :: *)) where
    showsPrec1 = showsPrec
instance Show1 (f a b c d) => Show1 (TyConReallyHighKinds f a b c d) where
    showsPrec1 p (TyConReallyHighKinds x) =
      showsUnary1 "TyConReallyHighKinds" p x
instance (Functor (f (g (j a) (k a))), Functor (h (j a)),
          Show1 (f (g (j a) (k a))), Show1 (h (j a)), Show1 k) =>
  Show1 (TyFamilyCompose f g h j k a) where
    showsPrec1 p (TyFamilyCompose x) =
      showsUnary1 "TyFamilyCompose" p $ fmap (Apply . fmap Apply) x
instance Show1 (TyFamilyProxy (a :: *)) where
    showsPrec1 = showsPrec
instance Show1 (f a b c d) => Show1 (TyFamilyReallyHighKinds f a b c d) where
    showsPrec1 p (TyFamilyReallyHighKinds x) =
      showsUnary1 "TyFamilyReallyHighKinds" p x

-- TODO: Move this to base-orphans someday
instance (Show a, Show b, Show c, Show d) => Show1 ((,,,,) a b c d) where
    showsPrec1 = showsPrec
#else
instance (Show1 (f (g (j a) (k a))), Show1 (h (j a)), Show1 k) =>
  Show1 (TyConCompose f g h j k a) where
    liftShowsPrec sp sl p (TyConCompose x) =
        showsPrecCompose sp sl "TyConCompose" p x
instance Show1 (TyConProxy (a :: *)) where
    liftShowsPrec = liftShowsPrec2 undefined undefined
instance Show1 (f a b c d) => Show1 (TyConReallyHighKinds f a b c d) where
    liftShowsPrec sp sl p (TyConReallyHighKinds x) =
        showsUnaryWith (liftShowsPrec sp sl) "TyConReallyHighKinds" p x
instance (Show1 (f (g (j a) (k a))), Show1 (h (j a)), Show1 k) =>
  Show1 (TyFamilyCompose f g h j k a) where
    liftShowsPrec sp sl p (TyFamilyCompose x) =
        showsPrecCompose sp sl "TyFamilyCompose" p x
instance Show1 (TyFamilyProxy (a :: *)) where
    liftShowsPrec = liftShowsPrec2 undefined undefined
instance Show1 (f a b c d) => Show1 (TyFamilyReallyHighKinds f a b c d) where
    liftShowsPrec sp sl p (TyFamilyReallyHighKinds x) =
        showsUnaryWith (liftShowsPrec sp sl) "TyFamilyReallyHighKinds" p x

instance (Show2 f, Show2 g, Show2 h, Show1 j, Show1 k) =>
  Show2 (TyConCompose f g h j k) where
    liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyConCompose x) =
        showsPrecCompose2 sp1 sl1 sp2 sl2 "TyConCompose" p x
instance Show2 TyConProxy where
    liftShowsPrec2 _ _ _ _ p (TyConProxy x) = showParen (p > appPrec) $
          showString "TyConProxy "
        . showsPrec appPrec1 x
instance Show2 (f a b c) => Show2 (TyConReallyHighKinds f a b c) where
    liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyConReallyHighKinds x) =
        showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "TyConReallyHighKinds" p x
instance (Show2 f, Show2 g, Show2 h, Show1 j, Show1 k) =>
  Show2 (TyFamilyCompose f g h j k) where
    liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyFamilyCompose x) =
        showsPrecCompose2 sp1 sl1 sp2 sl2 "TyFamilyCompose" p x
instance Show2 TyFamilyProxy where
    liftShowsPrec2 _ _ _ _ p (TyFamilyProxy x) = showParen (p > appPrec) $
          showString "TyFamilyProxy "
        . showsPrec appPrec1 x
instance Show2 (f a b c) => Show2 (TyFamilyReallyHighKinds f a b c) where
    liftShowsPrec2 sp1 sl1 sp2 sl2 p (TyFamilyReallyHighKinds x) =
        showsUnaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2) "TyFamilyReallyHighKinds" p x

showsPrecCompose :: (Show1 (f (g (j a) (k a))), Show1 (h (j a)), Show1 k)
                 => (Int -> b -> ShowS) -> ([b] -> ShowS)
                 -> String -> Int -> f (g (j a) (k a)) (h (j a) (k b)) -> ShowS
showsPrecCompose sp sl name p x = showParen (p > appPrec) $
      showString name . showSpace
    . liftShowsPrec (liftShowsPrec (liftShowsPrec sp sl)
                                   (liftShowList  sp sl))
                    (liftShowList  (liftShowsPrec sp sl)
                                   (liftShowList  sp sl))
                    appPrec1 x

showsPrecCompose2 :: (Show2 f, Show2 g, Show2 h, Show1 j, Show1 k)
                  => (Int -> a -> ShowS) -> ([a] -> ShowS)
                  -> (Int -> b -> ShowS) -> ([b] -> ShowS)
                  -> String -> Int -> f (g (j a) (k a)) (h (j a) (k b)) -> ShowS
showsPrecCompose2 sp1 sl1 sp2 sl2 name p x = showParen (p > appPrec) $
      showString name . showSpace
    . liftShowsPrec2 (liftShowsPrec2 (liftShowsPrec sp1 sl1)
                                     (liftShowList  sp1 sl1)
                                     (liftShowsPrec sp1 sl1)
                                     (liftShowList  sp1 sl1))
                     (liftShowList2  (liftShowsPrec sp1 sl1)
                                     (liftShowList  sp1 sl1)
                                     (liftShowsPrec sp1 sl1)
                                     (liftShowList  sp1 sl1))
                     (liftShowsPrec2 (liftShowsPrec sp1 sl1)
                                     (liftShowList  sp1 sl1)
                                     (liftShowsPrec sp2 sl2)
                                     (liftShowList  sp2 sl2))
                     (liftShowList2  (liftShowsPrec sp1 sl1)
                                     (liftShowList  sp1 sl1)
                                     (liftShowsPrec sp2 sl2)
                                     (liftShowList  sp2 sl2))
                     appPrec1 x

-- TODO: Move these to base-orphans someday
instance (Show a, Show b, Show c, Show d) => Show1 ((,,,,) a b c d) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList
instance (Show a, Show b, Show c) => Show2 ((,,,,) a b c) where
    liftShowsPrec2 sp1 _ sp2 _ _ (a, b, c, d, e) =
        showChar '(' . shows a . showChar ','
                     . shows b . showChar ','
                     . shows c . showChar ','
                     . sp1 0 d . showChar ','
                     . sp2 0 e . showChar ')'
#endif

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

$(return [])

instance TextShow (f (g (j a) (k a)) (h (j a) (k b))) =>
  TextShow (TyConCompose f g h j k a b) where
    showbPrec = $(makeShowbPrec ''TyConCompose)
instance (TextShow1 (f (g (j a) (k a))), TextShow1 (h (j a)), TextShow1 k) =>
  TextShow1 (TyConCompose f g h j k a) where
    liftShowbPrec = $(makeLiftShowbPrec ''TyConCompose)
$(deriveTextShow2 ''TyConCompose)

instance TextShow (TyConProxy a b) where
    showbPrec = $(makeShowbPrec ''TyConProxy)
instance TextShow1 (TyConProxy a) where
    liftShowbPrec = $(makeLiftShowbPrec ''TyConProxy)
$(deriveTextShow2 ''TyConProxy)

instance TextShow (f a b c d e) => TextShow (TyConReallyHighKinds f a b c d e) where
    showbPrec = $(makeShowbPrec ''TyConReallyHighKinds)
instance TextShow1 (f a b c d) => TextShow1 (TyConReallyHighKinds f a b c d) where
    liftShowbPrec = $(makeLiftShowbPrec ''TyConReallyHighKinds)
instance TextShow2 (f a b c) => TextShow2 (TyConReallyHighKinds f a b c) where
    liftShowbPrec2 = $(makeLiftShowbPrec2 ''TyConReallyHighKinds)

#if MIN_VERSION_template_haskell(2,7,0)
instance TextShow (f (g (j a) (k a)) (h (j a) (k b))) =>
  TextShow (TyFamilyCompose f g h j k a b) where
    showbPrec = $(makeShowbPrec 'TyFamilyCompose)
instance (TextShow1 (f (g (j a) (k a))), TextShow1 (h (j a)), TextShow1 k) =>
  TextShow1 (TyFamilyCompose f g h j k a) where
    liftShowbPrec = $(makeLiftShowbPrec 'TyFamilyCompose)
$(deriveTextShow2 'TyFamilyCompose)

instance TextShow (TyFamilyProxy a b) where
    showbPrec = $(makeShowbPrec 'TyFamilyProxy)
instance TextShow1 (TyFamilyProxy a) where
    liftShowbPrec = $(makeLiftShowbPrec 'TyFamilyProxy)
$(deriveTextShow2 'TyFamilyProxy)

instance TextShow (f a b c d e) => TextShow (TyFamilyReallyHighKinds f a b c d e) where
    showbPrec = $(makeShowbPrec 'TyFamilyReallyHighKinds)
instance TextShow1 (f a b c d) => TextShow1 (TyFamilyReallyHighKinds f a b c d) where
    liftShowbPrec = $(makeLiftShowbPrec 'TyFamilyReallyHighKinds)
instance TextShow2 (f a b c) => TextShow2 (TyFamilyReallyHighKinds f a b c) where
    liftShowbPrec2 = $(makeLiftShowbPrec2 'TyFamilyReallyHighKinds)
#endif

#if !defined(__LANGUAGE_DERIVE_GENERIC1__)
$(Generics.deriveMeta           ''TyConCompose)
$(Generics.deriveRep1           ''TyConCompose)

instance ( Functor (f (g (j a) (k a)))
         , Functor (h (j a))
         ) => Generic1 (TyConCompose f g h j k a) where
    type Rep1 (TyConCompose f g h j k a) = $(Generics.makeRep1 ''TyConCompose) f g h j k a
    from1 = $(Generics.makeFrom1 ''TyConCompose)
    to1   = $(Generics.makeTo1   ''TyConCompose)

$(Generics.deriveMeta           ''TyConProxy)
$(Generics.deriveRepresentable1 ''TyConProxy)
$(Generics.deriveMeta           ''TyConReallyHighKinds)
$(Generics.deriveRepresentable1 ''TyConReallyHighKinds)
#endif

#if __GLASGOW_HASKELL__ < 702
$(Generics.deriveRepresentable0 ''TyConCompose)
$(Generics.deriveRepresentable0 ''TyConProxy)
$(Generics.deriveRepresentable0 ''TyConReallyHighKinds)
#endif

#if MIN_VERSION_template_haskell(2,7,0)
-- TODO: Reinstate CPP bounds once Trac #11357 is fixed
$(Generics.deriveMeta           'TyFamilyCompose)
$(Generics.deriveRep1           'TyFamilyCompose)

instance ( Functor (f (g (j a) (k a)))
         , Functor (h (j a))
         ) => Generic1 (TyFamilyCompose f g h j k a) where
    type Rep1 (TyFamilyCompose f g h j k a) = $(Generics.makeRep1 'TyFamilyCompose) f g h j k a
    from1 = $(Generics.makeFrom1 'TyFamilyCompose)
    to1   = $(Generics.makeTo1   'TyFamilyCompose)

$(Generics.deriveMeta           'TyFamilyProxy)
$(Generics.deriveRepresentable1 'TyFamilyProxy)
$(Generics.deriveMeta           'TyFamilyReallyHighKinds)
$(Generics.deriveRepresentable1 'TyFamilyReallyHighKinds)

# if __GLASGOW_HASKELL__ < 706
$(Generics.deriveRepresentable0 'TyFamilyCompose)
$(Generics.deriveRepresentable0 'TyFamilyProxy)
$(Generics.deriveRepresentable0 'TyFamilyReallyHighKinds)
# endif
#endif