{-# LANGUAGE CPP #-}

#ifndef HASKELL98
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

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

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

# if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE DataKinds #-}
# endif

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

{-# OPTIONS_GHC -fno-warn-deprecations #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Trans.Instances
-- Copyright   :  (C) 2012-16 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- Backports orphan instances which are not provided by other modules in
-- @transformers-compat@.
----------------------------------------------------------------------------
module Control.Monad.Trans.Instances () where

#ifndef MIN_VERSION_base
#define MIN_VERSION_base(a,b,c) 1
#endif

#ifndef MIN_VERSION_transformers
#define MIN_VERSION_transformers(a,b,c) 1
#endif

import           Control.Applicative.Backwards (Backwards(..))
import           Control.Applicative.Lift (Lift(..))
import qualified Control.Monad.Fail as Fail (MonadFail(..))
import           Control.Monad.IO.Class (MonadIO)
import           Control.Monad.Trans.Accum (AccumT(..))
import           Control.Monad.Trans.Class (MonadTrans(..))
import           Control.Monad.Trans.Cont (ContT(..))
import           Control.Monad.Trans.Except (ExceptT(..))
import           Control.Monad.Trans.Identity (IdentityT(..))
import           Control.Monad.Trans.Maybe (MaybeT(..))
import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
import           Control.Monad.Trans.Reader (ReaderT(..))
import           Control.Monad.Trans.Select (SelectT(..))
import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT(..))
import qualified Control.Monad.Trans.State.Strict as Strict (StateT(..))
import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..))
import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT(..))
import           Data.Functor.Classes
import           Data.Functor.Compose (Compose(..))
import           Data.Functor.Constant (Constant(..))
import           Data.Functor.Identity (Identity(..))
import           Data.Functor.Product (Product(..))
import           Data.Functor.Reverse (Reverse(..))
import           Data.Functor.Sum (Sum(..))

import           Control.Applicative
import           Control.Arrow (Arrow((***)))
import           Control.Monad (MonadPlus(..), liftM)
import           Control.Monad.Fix (MonadFix(..))
import           Data.Bits
import           Data.Foldable (Foldable(..))
import           Data.Ix (Ix(..))
import           Data.Maybe (fromMaybe)
import           Data.Monoid (Monoid(..))
import           Data.String (IsString(fromString))
import           Data.Traversable (Traversable(..))
import           Foreign (Storable(..), castPtr)

#if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,9,0))
import           Data.Complex (Complex (..))
#endif

#if !(MIN_VERSION_transformers(0,6,0))
import           Control.Monad.Trans.Error (Error(..), ErrorT(..))
import           Control.Monad.Trans.List (ListT(..), mapListT)
#endif

#if MIN_VERSION_base(4,4,0)
import           Control.Monad.Zip (MonadZip(..))
#endif

#if MIN_VERSION_base(4,7,0)
import           Data.Proxy (Proxy(..))
#endif

#if MIN_VERSION_base(4,8,0)
import           Data.Bifunctor (Bifunctor(..))
#endif

#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup as Semigroup (Semigroup(..))
#endif

#if MIN_VERSION_base(4,10,0)
import           Data.Bifoldable (Bifoldable(..))
import           Data.Bitraversable (Bitraversable(..))
#endif

#ifndef HASKELL98
import           Data.Data (Data)
import           Data.Typeable

# ifdef GENERIC_DERIVING
import           Generics.Deriving.Base
# elif __GLASGOW_HASKELL__ >= 702
import           GHC.Generics
# endif
#endif

#if !(MIN_VERSION_transformers(0,3,0))
-- Foldable/Traversable instances
instance (Foldable f) => Foldable (IdentityT f) where
    foldMap f (IdentityT a) = foldMap f a

instance (Traversable f) => Traversable (IdentityT f) where
    traverse f (IdentityT a) = IdentityT <$> traverse f a

instance (Foldable f) => Foldable (MaybeT f) where
    foldMap f (MaybeT a) = foldMap (foldMap f) a

instance (Traversable f) => Traversable (MaybeT f) where
    traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a

instance (Foldable f) => Foldable (Lazy.WriterT w f) where
    foldMap f = foldMap (f . fst) . Lazy.runWriterT

instance (Traversable f) => Traversable (Lazy.WriterT w f) where
    traverse f = fmap Lazy.WriterT . traverse f' . Lazy.runWriterT where
       f' (a, b) = fmap (\ c -> (c, b)) (f a)

instance (Foldable f) => Foldable (Strict.WriterT w f) where
    foldMap f = foldMap (f . fst) . Strict.runWriterT

instance (Traversable f) => Traversable (Strict.WriterT w f) where
    traverse f = fmap Strict.WriterT . traverse f' . Strict.runWriterT where
       f' (a, b) = fmap (\ c -> (c, b)) (f a)

# if !(MIN_VERSION_transformers(0,6,0))
instance (Foldable f) => Foldable (ErrorT e f) where
    foldMap f (ErrorT a) = foldMap (either (const mempty) f) a

instance (Traversable f) => Traversable (ErrorT e f) where
    traverse f (ErrorT a) =
        ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a

instance (Foldable f) => Foldable (ListT f) where
    foldMap f (ListT a) = foldMap (foldMap f) a

instance (Traversable f) => Traversable (ListT f) where
    traverse f (ListT a) = ListT <$> traverse (traverse f) a
# endif

-- MonadFix instances for IdentityT and MaybeT
instance (MonadFix m) => MonadFix (IdentityT m) where
    mfix f = IdentityT (mfix (runIdentityT . f))

instance (MonadFix m) => MonadFix (MaybeT m) where
    mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb))
      where bomb = error "mfix (MaybeT): inner computation returned Nothing"

# if !(MIN_VERSION_base(4,9,0))
-- Monad instances for Product
instance (Monad f, Monad g) => Monad (Product f g) where
    return x = Pair (return x) (return x)
    Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f)
      where
        fstP (Pair a _) = a
        sndP (Pair _ b) = b

instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where
    mzero = Pair mzero mzero
    Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2)

instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where
    mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f))
      where
        fstP (Pair a _) = a
        sndP (Pair _ b) = b
# endif
#endif

#if !(MIN_VERSION_transformers(0,4,0))
-- Alternative IO instance
# if !(MIN_VERSION_base(4,9,0))
-- The version bounds of transformers prior to 0.4.0.0 should prevent this
-- instance from being compiled on base-4.8.0.0 and later, but we'll put
-- a check here just to be safe.
instance Alternative IO where
    empty = mzero
    (<|>) = mplus
# endif
#endif

#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,4,3))
-- transformers-0.4-specific Eq1, Ord1, Read1, and Show1 instances for Const
instance (Eq a) => Eq1 (Const a) where
    eq1 (Const x) (Const y) = x == y
instance (Ord a) => Ord1 (Const a) where
    compare1 (Const x) (Const y) = compare x y
instance (Read a) => Read1 (Const a) where
    readsPrec1 = readsData $ readsUnary "Const" Const
instance (Show a) => Show1 (Const a) where
    showsPrec1 d (Const x) = showsUnary "Const" d x
#endif

#if !(MIN_VERSION_transformers(0,5,0)) \
  || (MIN_VERSION_transformers(0,5,0) && !(MIN_VERSION_base(4,9,0)))
-- MonadFail instances
instance (Fail.MonadFail m) => Fail.MonadFail (ContT r m) where
    fail msg = ContT $ \ _ -> Fail.fail msg
    {-# INLINE fail #-}

instance (Fail.MonadFail m) => Fail.MonadFail (IdentityT m) where
    fail msg = IdentityT $ Fail.fail msg
    {-# INLINE fail #-}

instance (Monad m) => Fail.MonadFail (MaybeT m) where
    fail _ = MaybeT (return Nothing)
    {-# INLINE fail #-}

instance (Fail.MonadFail m) => Fail.MonadFail (ReaderT r m) where
    fail msg = lift (Fail.fail msg)
    {-# INLINE fail #-}

instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Lazy.RWST r w s m) where
    fail msg = Lazy.RWST $ \ _ _ -> Fail.fail msg
    {-# INLINE fail #-}

instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Strict.RWST r w s m) where
    fail msg = Strict.RWST $ \ _ _ -> Fail.fail msg
    {-# INLINE fail #-}

instance (Fail.MonadFail m) => Fail.MonadFail (Lazy.StateT s m) where
    fail str = Lazy.StateT $ \ _ -> Fail.fail str
    {-# INLINE fail #-}

instance (Fail.MonadFail m) => Fail.MonadFail (Strict.StateT s m) where
    fail str = Strict.StateT $ \ _ -> Fail.fail str
    {-# INLINE fail #-}

instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Lazy.WriterT w m) where
    fail msg = Lazy.WriterT $ Fail.fail msg
    {-# INLINE fail #-}

instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (Strict.WriterT w m) where
    fail msg = Strict.WriterT $ Fail.fail msg
    {-# INLINE fail #-}

# if !(MIN_VERSION_transformers(0,6,0))
instance (Monad m, Error e) => Fail.MonadFail (ErrorT e m) where
    fail msg = ErrorT $ return (Left (strMsg msg))

instance (Monad m) => Fail.MonadFail (ListT m) where
    fail _ = ListT $ return []
    {-# INLINE fail #-}
# endif

# if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_base(4,9,0))
instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where
    fail = ExceptT . Fail.fail
    {-# INLINE fail #-}
# endif

# if MIN_VERSION_transformers(0,5,3) && !(MIN_VERSION_base(4,9,0))
instance (Monoid w, Functor m, Fail.MonadFail m) => Fail.MonadFail (AccumT w m) where
    fail msg = AccumT $ const (Fail.fail msg)
    {-# INLINE fail #-}

instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where
    fail msg = lift (Fail.fail msg)
    {-# INLINE fail #-}
# endif
#endif

#if !(MIN_VERSION_transformers(0,5,0))
-- Monoid Constant instance
instance (Monoid a) => Monoid (Constant a b) where
    mempty = Constant mempty
    Constant x `mappend` Constant y = Constant (x `mappend` y)

-- MonadZip instances
# if MIN_VERSION_base(4,4,0)
instance (MonadZip m) => MonadZip (IdentityT m) where
    mzipWith f (IdentityT a) (IdentityT b) = IdentityT (mzipWith f a b)

instance (MonadZip m) => MonadZip (MaybeT m) where
    mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b

instance (MonadZip m) => MonadZip (ReaderT r m) where
    mzipWith f (ReaderT m) (ReaderT n) = ReaderT $ \ a ->
        mzipWith f (m a) (n a)

instance (Monoid w, MonadZip m) => MonadZip (Lazy.WriterT w m) where
    mzipWith f (Lazy.WriterT x) (Lazy.WriterT y) = Lazy.WriterT $
        mzipWith (\ ~(a, w) ~(b, w') -> (f a b, w `mappend` w')) x y

instance (Monoid w, MonadZip m) => MonadZip (Strict.WriterT w m) where
    mzipWith f (Strict.WriterT x) (Strict.WriterT y) = Strict.WriterT $
        mzipWith (\ (a, w) (b, w') -> (f a b, w `mappend` w')) x y

#  if !(MIN_VERSION_transformers(0,6,0))
instance (MonadZip m) => MonadZip (ListT m) where
    mzipWith f (ListT a) (ListT b) = ListT $ mzipWith (zipWith f) a b
#  endif

#  if !(MIN_VERSION_base(4,8,0))
instance MonadZip Identity where
    mzipWith f (Identity x) (Identity y) = Identity (f x y)
    munzip (Identity (a, b)) = (Identity a, Identity b)
#  endif

#  if !(MIN_VERSION_base(4,9,0))
instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where
    mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2)
#  endif
# endif

# if MIN_VERSION_base(4,8,0)
-- Bifunctor Constant instance
instance Bifunctor Constant where
    first f (Constant x) = Constant (f x)
    second _ (Constant x) = Constant x
# else
-- Monoid Identity instance
instance (Monoid a) => Monoid (Identity a) where
    mempty = Identity mempty
    mappend (Identity x) (Identity y) = Identity (mappend x y)
# endif

# ifndef HASKELL98
-- Typeable instances
#  if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
deriving instance Typeable Backwards
deriving instance Typeable ContT
deriving instance Typeable IdentityT
deriving instance Typeable Lift
deriving instance Typeable MaybeT
deriving instance Typeable MonadTrans
deriving instance Typeable Lazy.RWST
deriving instance Typeable Strict.RWST
deriving instance Typeable ReaderT
deriving instance Typeable Reverse
deriving instance Typeable Lazy.StateT
deriving instance Typeable Strict.StateT
#   if !(MIN_VERSION_transformers(0,6,0))
deriving instance Typeable ErrorT
deriving instance Typeable ListT
#   endif

#   if !(MIN_VERSION_base(4,9,0))
deriving instance Typeable Compose
deriving instance Typeable MonadIO
deriving instance Typeable Product
#   endif
#  endif

-- Identity instances
#  if !(MIN_VERSION_base(4,8,0))
deriving instance Typeable1 Identity
deriving instance Data a => Data (Identity a)
#   if __GLASGOW_HASKELL__ >= 708
deriving instance Typeable 'Identity
#   endif
#  endif

#  if !(MIN_VERSION_base(4,9,0))
#   if __GLASGOW_HASKELL__ >= 708
-- Data instances for Compose and Product
deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a)
               => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *))
deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)
               => Data (Product (f :: * -> *) (g :: * -> *) (a :: *))

#    if MIN_VERSION_transformers(0,4,0)
-- Typeable/Data instances for Sum
-- These are also present in Data.Functor.Sum in transformers-compat, but only
-- these are reachable if using @transformers-0.4.0.0@
deriving instance Typeable Sum
deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)
               => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *))
#    endif
#   endif
#  endif
# endif
#endif

#if !(MIN_VERSION_transformers(0,5,1))
# if !(MIN_VERSION_base(4,8,0))
instance (Bounded a) => Bounded (Identity a) where
    minBound = Identity minBound
    maxBound = Identity maxBound

instance (Enum a) => Enum (Identity a) where
    succ (Identity x)     = Identity (succ x)
    pred (Identity x)     = Identity (pred x)
    toEnum i              = Identity (toEnum i)
    fromEnum (Identity x) = fromEnum x
    enumFrom (Identity x) = map Identity (enumFrom x)
    enumFromThen (Identity x) (Identity y) = map Identity (enumFromThen x y)
    enumFromTo   (Identity x) (Identity y) = map Identity (enumFromTo   x y)
    enumFromThenTo (Identity x) (Identity y) (Identity z) =
        map Identity (enumFromThenTo x y z)

instance (Ix a) => Ix (Identity a) where
    range     (Identity x, Identity y) = map Identity (range (x, y))
    index     (Identity x, Identity y) (Identity i) = index     (x, y) i
    inRange   (Identity x, Identity y) (Identity e) = inRange   (x, y) e
    rangeSize (Identity x, Identity y) = rangeSize (x, y)

instance (Storable a) => Storable (Identity a) where
    sizeOf    (Identity x)       = sizeOf x
    alignment (Identity x)       = alignment x
    peekElemOff p i              = fmap Identity (peekElemOff (castPtr p) i)
    pokeElemOff p i (Identity x) = pokeElemOff (castPtr p) i x
    peekByteOff p i              = fmap Identity (peekByteOff p i)
    pokeByteOff p i (Identity x) = pokeByteOff p i x
    peek p                       = fmap runIdentity (peek (castPtr p))
    poke p (Identity x)          = poke (castPtr p) x
# endif
#endif

#if !(MIN_VERSION_transformers(0,5,3))
# if !(MIN_VERSION_base(4,9,0))
#  if MIN_VERSION_base(4,7,0)
-- Data.Proxy
#   if defined(TRANSFORMERS_FOUR)
instance Eq1 Proxy where
    eq1 _ _ = True

instance Ord1 Proxy where
    compare1 _ _ = EQ

instance Show1 Proxy where
    showsPrec1 _ _ = showString "Proxy"

instance Read1 Proxy where
    readsPrec1 d =
        readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ])
#   elif MIN_VERSION_transformers(0,5,0)
instance Eq1 Proxy where
    liftEq _ _ _ = True

instance Ord1 Proxy where
    liftCompare _ _ _ = EQ

instance Show1 Proxy where
    liftShowsPrec _ _ _ _ = showString "Proxy"

instance Read1 Proxy where
    liftReadsPrec _ _ d =
        readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ])
#   endif
#  endif
# endif

# if !(MIN_VERSION_base(4,8,0))
-- Data.Functor.Identity
instance (Bits a) => Bits (Identity a) where
    Identity x .&. Identity y     = Identity (x .&. y)
    Identity x .|. Identity y     = Identity (x .|. y)
    xor (Identity x) (Identity y) = Identity (xor x y)
    complement   (Identity x)     = Identity (complement x)
    shift        (Identity x) i   = Identity (shift    x i)
    rotate       (Identity x) i   = Identity (rotate   x i)
    setBit       (Identity x) i   = Identity (setBit   x i)
    clearBit     (Identity x) i   = Identity (clearBit x i)
    shiftL       (Identity x) i   = Identity (shiftL   x i)
    shiftR       (Identity x) i   = Identity (shiftR   x i)
    rotateL      (Identity x) i   = Identity (rotateL  x i)
    rotateR      (Identity x) i   = Identity (rotateR  x i)
    testBit      (Identity x) i   = testBit x i
    bitSize      (Identity x)     = bitSize x
    isSigned     (Identity x)     = isSigned x
    bit i                         = Identity (bit i)
#  if MIN_VERSION_base(4,5,0)
    unsafeShiftL (Identity x) i   = Identity (unsafeShiftL x i)
    unsafeShiftR (Identity x) i   = Identity (unsafeShiftR x i)
    popCount     (Identity x)     = popCount x
#  endif
#  if MIN_VERSION_base(4,7,0)
    zeroBits                      = Identity zeroBits
    bitSizeMaybe (Identity x)     = bitSizeMaybe x
#  endif

#  if MIN_VERSION_base(4,7,0)
instance (FiniteBits a) => FiniteBits (Identity a) where
    finiteBitSize (Identity x) = finiteBitSize x
#  endif

instance (Floating a) => Floating (Identity a) where
    pi                                = Identity pi
    exp   (Identity x)                = Identity (exp x)
    log   (Identity x)                = Identity (log x)
    sqrt  (Identity x)                = Identity (sqrt x)
    sin   (Identity x)                = Identity (sin x)
    cos   (Identity x)                = Identity (cos x)
    tan   (Identity x)                = Identity (tan x)
    asin  (Identity x)                = Identity (asin x)
    acos  (Identity x)                = Identity (acos x)
    atan  (Identity x)                = Identity (atan x)
    sinh  (Identity x)                = Identity (sinh x)
    cosh  (Identity x)                = Identity (cosh x)
    tanh  (Identity x)                = Identity (tanh x)
    asinh (Identity x)                = Identity (asinh x)
    acosh (Identity x)                = Identity (acosh x)
    atanh (Identity x)                = Identity (atanh x)
    Identity x ** Identity y          = Identity (x ** y)
    logBase (Identity x) (Identity y) = Identity (logBase x y)

instance (Fractional a) => Fractional (Identity a) where
    Identity x / Identity y = Identity (x / y)
    recip (Identity x)      = Identity (recip x)
    fromRational r          = Identity (fromRational r)

instance (IsString a) => IsString (Identity a) where
    fromString s = Identity (fromString s)

instance (Integral a) => Integral (Identity a) where
    quot    (Identity x) (Identity y) = Identity (quot x y)
    rem     (Identity x) (Identity y) = Identity (rem  x y)
    div     (Identity x) (Identity y) = Identity (div  x y)
    mod     (Identity x) (Identity y) = Identity (mod  x y)
    quotRem (Identity x) (Identity y) = (Identity *** Identity) (quotRem x y)
    divMod  (Identity x) (Identity y) = (Identity *** Identity) (divMod  x y)
    toInteger (Identity x)            = toInteger x

instance (Num a) => Num (Identity a) where
    Identity x + Identity y = Identity (x + y)
    Identity x - Identity y = Identity (x - y)
    Identity x * Identity y = Identity (x * y)
    negate (Identity x)     = Identity (negate x)
    abs    (Identity x)     = Identity (abs    x)
    signum (Identity x)     = Identity (signum x)
    fromInteger n           = Identity (fromInteger n)

instance (Real a) => Real (Identity a) where
    toRational (Identity x) = toRational x

instance (RealFloat a) => RealFloat (Identity a) where
    floatRadix     (Identity x)     = floatRadix     x
    floatDigits    (Identity x)     = floatDigits    x
    floatRange     (Identity x)     = floatRange     x
    decodeFloat    (Identity x)     = decodeFloat    x
    exponent       (Identity x)     = exponent       x
    isNaN          (Identity x)     = isNaN          x
    isInfinite     (Identity x)     = isInfinite     x
    isDenormalized (Identity x)     = isDenormalized x
    isNegativeZero (Identity x)     = isNegativeZero x
    isIEEE         (Identity x)     = isIEEE         x
    significand    (Identity x)     = significand (Identity x)
    scaleFloat s   (Identity x)     = Identity (scaleFloat s x)
    encodeFloat m n                 = Identity (encodeFloat m n)
    atan2 (Identity x) (Identity y) = Identity (atan2 x y)

instance (RealFrac a) => RealFrac (Identity a) where
    properFraction (Identity x) = (id *** Identity) (properFraction x)
    truncate       (Identity x) = truncate x
    round          (Identity x) = round    x
    ceiling        (Identity x) = ceiling  x
    floor          (Identity x) = floor    x
# endif

# if MIN_VERSION_transformers(0,3,0)
-- Data.Functor.Reverse
instance (Monad m) => Monad (Reverse m) where
    return a = Reverse (return a)
    {-# INLINE return #-}
    m >>= f = Reverse (getReverse m >>= getReverse . f)
    {-# INLINE (>>=) #-}
    fail msg = Reverse (fail msg)
    {-# INLINE fail #-}

instance (Fail.MonadFail m) => Fail.MonadFail (Reverse m) where
    fail msg = Reverse (Fail.fail msg)
    {-# INLINE fail #-}

instance (MonadPlus m) => MonadPlus (Reverse m) where
    mzero = Reverse mzero
    {-# INLINE mzero #-}
    Reverse x `mplus` Reverse y = Reverse (x `mplus` y)
    {-# INLINE mplus #-}
# endif
#endif

#if !(MIN_VERSION_transformers(0,5,4))
# if MIN_VERSION_base(4,10,0)
instance Bifoldable Constant where
    bifoldMap f _ (Constant a) = f a
    {-# INLINE bifoldMap #-}

instance Bitraversable Constant where
    bitraverse f _ (Constant a) = Constant <$> f a
    {-# INLINE bitraverse #-}
# endif
#endif

#if !(MIN_VERSION_transformers(0,5,5))
# if MIN_VERSION_base(4,9,0)
instance (Semigroup.Semigroup a) => Semigroup.Semigroup (Constant a b) where
    Constant x <> Constant y = Constant (x Semigroup.<> y)
    {-# INLINE (<>) #-}
# endif

# if !(MIN_VERSION_transformers(0,6,0))
instance (MonadFix m) => MonadFix (ListT m) where
    mfix f = ListT $ mfix (runListT . f . head) >>= \ xs -> case xs of
        [] -> return []
        x:_ -> liftM (x:) (runListT (mfix (mapListT (liftM tail) . f)))
    {-# INLINE mfix #-}
# endif
#endif

-- Generic(1) instances
#ifndef HASKELL98
# if (!(MIN_VERSION_transformers(0,5,0)) && (__GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING))) \
    || (MIN_VERSION_transformers(0,5,0)  &&  __GLASGOW_HASKELL__ < 702  && defined(GENERIC_DERIVING))

#  if !(MIN_VERSION_base(4,8,0))
instance Generic (Identity a) where
    type Rep (Identity a) = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity (Rec0 a)))
    from (Identity x) = M1 (M1 (M1 (K1 x)))
    to (M1 (M1 (M1 (K1 x)))) = Identity x

instance Generic1 Identity where
    type Rep1 Identity = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity Par1))
    from1 (Identity x) = M1 (M1 (M1 (Par1 x)))
    to1 (M1 (M1 (M1 x))) = Identity (unPar1 x)

data MDIdentity
data MCIdentity
data MSIdentity

instance Datatype MDIdentity where
  datatypeName _ = "Identity"
  moduleName _ = "Data.Functor.Identity"
#   if __GLASGOW_HASKELL__ >= 708
  isNewtype _ = True
#   endif

instance Constructor MCIdentity where
  conName _ = "Identity"
  conIsRecord _ = True

instance Selector MSIdentity where
  selName _ = "runIdentity"
#  endif

#  if !(MIN_VERSION_base(4,9,0))
-- Generic(1) instances for Compose
instance Generic (Compose f g a) where
    type Rep (Compose f g a) =
      D1 MDCompose
        (C1 MCCompose
          (S1 MSCompose (Rec0 (f (g a)))))
    from (Compose x) = M1 (M1 (M1 (K1 x)))
    to (M1 (M1 (M1 (K1 x)))) = Compose x

instance Functor f => Generic1 (Compose f g) where
    type Rep1 (Compose f g) =
      D1 MDCompose
        (C1 MCCompose
          (S1 MSCompose (f :.: Rec1 g)))
    from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x))))
    to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x))

data MDCompose
data MCCompose
data MSCompose

instance Datatype MDCompose where
    datatypeName _ = "Compose"
    moduleName   _ = "Data.Functor.Compose"
#   if __GLASGOW_HASKELL__ >= 708
    isNewtype    _ = True
#   endif

instance Constructor MCCompose where
    conName     _ = "Compose"
    conIsRecord _ = True

instance Selector MSCompose where
    selName _ = "getCompose"

-- Generic(1) instances for Product
instance Generic (Product f g a) where
    type Rep (Product f g a) =
      D1 MDProduct
        (C1 MCPair
          (S1 NoSelector (Rec0 (f a)) :*: S1 NoSelector (Rec0 (g a))))
    from (Pair f g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))
    to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = Pair f g

instance Generic1 (Product f g) where
    type Rep1 (Product f g) =
      D1 MDProduct
        (C1 MCPair
          (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g)))
    from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g)))
    to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g)

data MDProduct
data MCPair

instance Datatype MDProduct where
    datatypeName _ = "Product"
    moduleName   _ = "Data.Functor.Product"

instance Constructor MCPair where
    conName _ = "Pair"

#   if MIN_VERSION_transformers(0,4,0)
-- Generic(1) instances for Sum
-- These are also present in Data.Functor.Sum in transformers-compat, but only
-- these are reachable if using @transformers-0.4.0.0@ or later
instance Generic (Sum f g a) where
    type Rep (Sum f g a) =
      D1 MDSum (C1 MCInL (S1 NoSelector (Rec0 (f a)))
            :+: C1 MCInR (S1 NoSelector (Rec0 (g a))))
    from (InL f) = M1 (L1 (M1 (M1 (K1 f))))
    from (InR g) = M1 (R1 (M1 (M1 (K1 g))))
    to (M1 (L1 (M1 (M1 (K1 f))))) = InL f
    to (M1 (R1 (M1 (M1 (K1 g))))) = InR g

instance Generic1 (Sum f g) where
    type Rep1 (Sum f g) =
      D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f))
            :+: C1 MCInR (S1 NoSelector (Rec1 g)))
    from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f))))
    from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g))))
    to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f)
    to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g)

data MDSum
data MCInL
data MCInR

instance Datatype MDSum where
    datatypeName _ = "Sum"
    moduleName   _ = "Data.Functor.Sum"

instance Constructor MCInL where
    conName _ = "InL"

instance Constructor MCInR where
    conName _ = "InR"
#   endif
#  endif

# endif

# if !(MIN_VERSION_transformers(0,6,0))
#  if __GLASGOW_HASKELL__ >= 708
-- If we wanted to be 100% faithful to the original Data instance in
-- transformers, we really ought to define an instance like:
--
--   instance (Data a, Typeable k, Typeable (b :: k)) => Data (Constant a b)
--
-- Unfortunately, this is not possible to do with a standalone-derived Data
-- instance (see https://gitlab.haskell.org/ghc/ghc/-/issues/13327).
-- For now, I've opted to just restrict the instance context slightly by using
-- a `Data b` constraint. I'll wait for someone to complain about this before
-- taking further action on it.
deriving instance (Data a, Data b) => Data (Constant a b)
#   if __GLASGOW_HASKELL__ < 710
deriving instance Typeable Constant
#   endif
#  endif

-- The use of GHC 8.0 in this CPP is a conservative lower bound for
-- determining the earliest version of GHC that can derive Generic(1)
-- instances for all data types without bugs. We might be able to pick
-- an earlier GHC version for certain data types, but it doesn't seem
-- worthwhile, given that we'll have to fall back on hand-written instances at
-- some point anyway.
#  if __GLASGOW_HASKELL__ >= 800

deriving instance Generic  (Constant a b)
deriving instance Generic1 (Constant a)

deriving instance Generic (ContT r m a)

deriving instance Generic  (IdentityT f a)
deriving instance Generic1 (IdentityT f)

deriving instance Generic (MaybeT m a)
deriving instance Functor m => Generic1 (MaybeT m)

deriving instance Generic (Lazy.RWST   r w s m a)
deriving instance Generic (Strict.RWST r w s m a)

deriving instance Generic  (ReaderT r m a)
deriving instance Generic1 (ReaderT r m)

deriving instance Generic (Lazy.StateT   s m a)
deriving instance Generic (Strict.StateT s m a)

deriving instance Generic (Lazy.WriterT   w m a)
deriving instance Generic (Strict.WriterT w m a)

#   if MIN_VERSION_transformers(0,3,0)
deriving instance Generic  (Backwards f a)
deriving instance Generic1 (Backwards f)

deriving instance Generic  (Lift f a)
deriving instance Generic1 (Lift f)

deriving instance Generic  (Reverse f a)
deriving instance Generic1 (Reverse f)
#   endif

#   if MIN_VERSION_transformers(0,4,0)
deriving instance Generic (ExceptT e m a)
deriving instance Functor m => Generic1 (ExceptT e m)
#   endif

#   if MIN_VERSION_transformers(0,5,3)
deriving instance Generic (AccumT  w m a)
deriving instance Generic (SelectT w m a)
#   endif

#  elif __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING)

instance Generic (Constant a b) where
  type Rep (Constant a b) = D1 D1'Constant (C1 C1_0'Constant (S1 S1_0_0'Constant (Rec0 a)))
  from (Constant x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = Constant x

instance Generic1 (Constant a) where
  type Rep1 (Constant a) = D1 D1'Constant (C1 C1_0'Constant (S1 S1_0_0'Constant (Rec0 a)))
  from1 (Constant x) = M1 (M1 (M1 (K1 x)))
  to1 (M1 (M1 (M1 x))) = Constant (unK1 x)

instance Datatype D1'Constant where
  datatypeName _ = "Constant"
  moduleName _ = "Data.Functor.Constant"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'Constant where
  conName _ = "Constant"
  conIsRecord _ = True

instance Selector S1_0_0'Constant where
  selName _ = "getConstant"

data D1'Constant
data C1_0'Constant
data S1_0_0'Constant

-----

instance Generic (ContT r m a) where
  type Rep (ContT r m a) = D1 D1'ContT (C1 C1_0'ContT (S1 S1_0_0'ContT (Rec0 ((a -> m r) -> m r))))
  from (ContT x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = ContT x

instance Datatype D1'ContT where
  datatypeName _ = "ContT"
  moduleName _ = "Control.Monad.Trans.Cont"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'ContT where
  conName _ = "ContT"
  conIsRecord _ = True

instance Selector S1_0_0'ContT where
  selName _ = "runContT"

data D1'ContT
data C1_0'ContT
data S1_0_0'ContT

-----

instance Generic (IdentityT f a) where
  type Rep (IdentityT f a) = D1 D1'IdentityT (C1 C1_0'IdentityT (S1 S1_0_0'IdentityT (Rec0 (f a))))
  from (IdentityT x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = IdentityT x

instance Generic1 (IdentityT f) where
  type Rep1 (IdentityT f) = D1 D1'IdentityT (C1 C1_0'IdentityT (S1 S1_0_0'IdentityT (Rec1 f)))
  from1 (IdentityT x) = M1 (M1 (M1 (Rec1 x)))
  to1 (M1 (M1 (M1 x))) = IdentityT (unRec1 x)

instance Datatype D1'IdentityT where
  datatypeName _ = "IdentityT"
  moduleName _ = "Control.Monad.Trans.Identity"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'IdentityT where
  conName _ = "IdentityT"
  conIsRecord _ = True

instance Selector S1_0_0'IdentityT where
  selName _ = "runIdentityT"

data D1'IdentityT
data C1_0'IdentityT
data S1_0_0'IdentityT

-----

instance Generic (MaybeT m a) where
  type Rep (MaybeT m a) = D1 D1'MaybeT (C1 C1_0'MaybeT (S1 S1_0_0'MaybeT (Rec0 (m (Maybe a)))))
  from (MaybeT x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = MaybeT x

instance Functor m => Generic1 (MaybeT m) where
  type Rep1 (MaybeT m) = D1 D1'MaybeT (C1 C1_0'MaybeT (S1 S1_0_0'MaybeT (m :.: Rec1 Maybe)))
  from1 (MaybeT x) = M1 (M1 (M1 ((.) Comp1 (fmap Rec1) x)))
  to1 (M1 (M1 (M1 x))) = MaybeT ((.) (fmap unRec1) unComp1 x)

instance Datatype D1'MaybeT where
  datatypeName _ = "MaybeT"
  moduleName _ = "Control.Monad.Trans.Maybe"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'MaybeT where
  conName _ = "MaybeT"
  conIsRecord _ = True

instance Selector S1_0_0'MaybeT where
  selName _ = "runMaybeT"

data D1'MaybeT
data C1_0'MaybeT
data S1_0_0'MaybeT

-----

instance Generic (Lazy.RWST r w s m a) where
  type Rep (Lazy.RWST r w s m a) = D1 D1'RWSTLazy (C1 C1_0'RWST (S1 S1_0_0'RWST (Rec0 (r -> s -> m (a, s, w)))))
  from (Lazy.RWST x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = Lazy.RWST x

instance Generic (Strict.RWST r w s m a) where
  type Rep (Strict.RWST r w s m a) = D1 D1'RWSTStrict (C1 C1_0'RWST (S1 S1_0_0'RWST (Rec0 (r -> s -> m (a, s, w)))))
  from (Strict.RWST x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = Strict.RWST x

instance Datatype D1'RWSTLazy where
  datatypeName _ = "RWST"
  moduleName _ = "Control.Monad.Trans.RWS.Lazy"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Datatype D1'RWSTStrict where
  datatypeName _ = "RWST"
  moduleName _ = "Control.Monad.Trans.RWS.Strict"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'RWST where
  conName _ = "RWST"
  conIsRecord _ = True

instance Selector S1_0_0'RWST where
  selName _ = "runRWST"

data D1'RWSTLazy
data D1'RWSTStrict
data C1_0'RWST
data S1_0_0'RWST

-----

instance Generic (ReaderT r m a) where
  type Rep (ReaderT r m a) = D1 D1'ReaderT (C1 C1_0'ReaderT (S1 S1_0_0'ReaderT (Rec0 (r -> m a))))
  from (ReaderT x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = ReaderT x

instance Datatype D1'ReaderT where
  datatypeName _ = "ReaderT"
  moduleName _ = "Control.Monad.Trans.Reader"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'ReaderT where
  conName _ = "ReaderT"
  conIsRecord _ = True

instance Selector S1_0_0'ReaderT where
  selName _ = "runReaderT"

data D1'ReaderT
data C1_0'ReaderT
data S1_0_0'ReaderT

-----

instance Generic (Lazy.StateT s m a) where
  type Rep (Lazy.StateT s m a) = D1 D1'StateTLazy (C1 C1_0'StateT (S1 S1_0_0'StateT (Rec0 (s -> m (a, s)))))
  from (Lazy.StateT x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = Lazy.StateT x

instance Generic (Strict.StateT s m a) where
  type Rep (Strict.StateT s m a) = D1 D1'StateTStrict (C1 C1_0'StateT (S1 S1_0_0'StateT (Rec0 (s -> m (a, s)))))
  from (Strict.StateT x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = Strict.StateT x

instance Datatype D1'StateTLazy where
  datatypeName _ = "StateT"
  moduleName _ = "Control.Monad.Trans.State.Lazy"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Datatype D1'StateTStrict where
  datatypeName _ = "StateT"
  moduleName _ = "Control.Monad.Trans.State.Strict"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'StateT where
  conName _ = "StateT"
  conIsRecord _ = True

instance Selector S1_0_0'StateT where
  selName _ = "runStateT"

data D1'StateTLazy
data D1'StateTStrict
data C1_0'StateT
data S1_0_0'StateT

-----

instance Generic (Lazy.WriterT w m a) where
  type Rep (Lazy.WriterT w m a) = D1 D1'WriterTLazy (C1 C1_0'WriterT (S1 S1_0_0'WriterT (Rec0 (m (a, w)))))
  from (Lazy.WriterT x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = Lazy.WriterT x

instance Generic (Strict.WriterT w m a) where
  type Rep (Strict.WriterT w m a) = D1 D1'WriterTStrict (C1 C1_0'WriterT (S1 S1_0_0'WriterT (Rec0 (m (a, w)))))
  from (Strict.WriterT x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = Strict.WriterT x

instance Datatype D1'WriterTLazy where
  datatypeName _ = "WriterT"
  moduleName _ = "Control.Monad.Trans.Writer.Lazy"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Datatype D1'WriterTStrict where
  datatypeName _ = "WriterT"
  moduleName _ = "Control.Monad.Trans.Writer.Strict"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'WriterT where
  conName _ = "WriterT"
  conIsRecord _ = True

instance Selector S1_0_0'WriterT where
  selName _ = "runWriterT"

data D1'WriterTLazy
data D1'WriterTStrict
data C1_0'WriterT
data S1_0_0'WriterT

#   if MIN_VERSION_transformers(0,3,0)
instance Generic (Backwards f a) where
  type Rep (Backwards f a) = D1 D1'Backwards (C1 C1_0'Backwards (S1 S1_0_0'Backwards (Rec0 (f a))))
  from (Backwards x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = Backwards x

instance Generic1 (Backwards f) where
  type Rep1 (Backwards f) = D1 D1'Backwards (C1 C1_0'Backwards (S1 S1_0_0'Backwards (Rec1 f)))
  from1 (Backwards x) = M1 (M1 (M1 (Rec1 x)))
  to1 (M1 (M1 (M1 x))) = Backwards (unRec1 x)

instance Datatype D1'Backwards where
  datatypeName _ = "Backwards"
  moduleName _ = "Control.Applicative.Backwards"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'Backwards where
  conName _ = "Backwards"
  conIsRecord _ = True

instance Selector S1_0_0'Backwards where
  selName _ = "forwards"

data D1'Backwards
data C1_0'Backwards
data S1_0_0'Backwards

-----

instance Generic (Reverse f a) where
  type Rep (Reverse f a) = D1 D1'Reverse (C1 C1_0'Reverse (S1 S1_0_0'Reverse (Rec0 (f a))))
  from (Reverse x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = Reverse x

instance Generic1 (Reverse f) where
  type Rep1 (Reverse f) = D1 D1'Reverse (C1 C1_0'Reverse (S1 S1_0_0'Reverse (Rec1 f)))
  from1 (Reverse x) = M1 (M1 (M1 (Rec1 x)))
  to1 (M1 (M1 (M1 x))) = Reverse (unRec1 x)

instance Datatype D1'Reverse where
  datatypeName _ = "Reverse"
  moduleName _ = "Data.Functor.Reverse"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'Reverse where
  conName _ = "Reverse"
  conIsRecord _ = True

instance Selector S1_0_0'Reverse where
  selName _ = "getReverse"

data D1'Reverse
data C1_0'Reverse
data S1_0_0'Reverse

-----

instance Generic (Lift f a) where
  type Rep (Lift f a) = D1 D1'Lift (C1 C1_0'Lift (S1 NoSelector (Rec0 a)) :+: C1 C1_1'Lift (S1 NoSelector (Rec0 (f a))))
  from (Pure x) = M1 (L1 (M1 (M1 (K1 x))))
  from (Other x) = M1 (R1 (M1 (M1 (K1 x))))
  to (M1 (L1 (M1 (M1 (K1 x))))) = Pure x
  to (M1 (R1 (M1 (M1 (K1 x))))) = Other x

instance Generic1 (Lift f) where
  type Rep1 (Lift f) = D1 D1'Lift (C1 C1_0'Lift (S1 NoSelector Par1) :+: C1 C1_1'Lift (S1 NoSelector (Rec1 f)))
  from1 (Pure x) = M1 (L1 (M1 (M1 (Par1 x))))
  from1 (Other x) = M1 (R1 (M1 (M1 (Rec1 x))))
  to1 (M1 (L1 (M1 (M1 x)))) = Pure (unPar1 x)
  to1 (M1 (R1 (M1 (M1 x)))) = Other (unRec1 x)

instance Datatype D1'Lift where
  datatypeName _ = "Lift"
  moduleName _ = "Control.Applicative.Lift"

instance Constructor C1_0'Lift where
  conName _ = "Pure"

instance Constructor C1_1'Lift where
  conName _ = "Other"

data D1'Lift
data C1_0'Lift
data C1_1'Lift
#   endif

#   if MIN_VERSION_transformers(0,4,0)
instance Generic (ExceptT e m a) where
  type Rep (ExceptT e m a) = D1 D1'ExceptT (C1 C1_0'ExceptT (S1 NoSelector (Rec0 (m (Either e a)))))
  from (ExceptT x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = ExceptT x

instance Functor m => Generic1 (ExceptT e m) where
  type Rep1 (ExceptT e m) = D1 D1'ExceptT (C1 C1_0'ExceptT (S1 NoSelector (m :.: Rec1 (Either e))))
  from1 (ExceptT x) = M1 (M1 (M1 ((.) Comp1 (fmap Rec1) x)))
  to1 (M1 (M1 (M1 x))) = ExceptT ((.) (fmap unRec1) unComp1 x)

instance Datatype D1'ExceptT where
  datatypeName _ = "ExceptT"
  moduleName _ = "Control.Monad.Trans.Except"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'ExceptT where
  conName _ = "ExceptT"

data D1'ExceptT
data C1_0'ExceptT
#   endif

#   if MIN_VERSION_transformers(0,5,3)
instance Generic (AccumT w m a) where
  type Rep (AccumT w m a) = D1 D1'AccumT (C1 C1_0'AccumT (S1 NoSelector (Rec0 (w -> m (a, w)))))
  from (AccumT x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = AccumT x

instance Datatype D1'AccumT where
  datatypeName _ = "AccumT"
  moduleName _ = "Control.Monad.Trans.Accum"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'AccumT where
  conName _ = "AccumT"

data D1'AccumT
data C1_0'AccumT

-----

instance Generic (SelectT r m a) where
  type Rep (SelectT r m a) = D1 D1'SelectT (C1 C1_0'SelectT (S1 NoSelector (Rec0 ((a -> m r) -> m a))))
  from (SelectT x) = M1 (M1 (M1 (K1 x)))
  to (M1 (M1 (M1 (K1 x)))) = SelectT x

instance Datatype D1'SelectT where
  datatypeName _ = "SelectT"
  moduleName _ = "Control.Monad.Trans.Select"
#    if MIN_VERSION_base(4,7,0)
  isNewtype _ = True
#    endif

instance Constructor C1_0'SelectT where
  conName _ = "SelectT"

data D1'SelectT
data C1_0'SelectT
#   endif

#  endif
# endif
#endif

#if !(MIN_VERSION_base(4,9,0))
# if defined(TRANSFORMERS_FOUR)

#  if MIN_VERSION_base(4,4,0)
instance Eq1 Complex where eq1 = (==)
instance Read1 Complex where readsPrec1 = readsPrec
instance Show1 Complex where showsPrec1 = showsPrec
#  endif

instance (Eq a, Eq b) => Eq1 ((,,) a b) where eq1 = (==)
instance (Ord a, Ord b) => Ord1 ((,,) a b) where compare1 = compare
instance (Read a, Read b) => Read1 ((,,) a b) where readsPrec1 = readsPrec
instance (Show a, Show b) => Show1 ((,,) a b) where showsPrec1 = showsPrec

instance (Eq a, Eq b, Eq c) => Eq1 ((,,,) a b c) where eq1 = (==)
instance (Ord a, Ord b, Ord c) => Ord1 ((,,,) a b c) where compare1 = compare
instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where readsPrec1 = readsPrec
instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where showsPrec1 = showsPrec
# elif MIN_VERSION_transformers(0,5,0)

#  if MIN_VERSION_base(4,4,0)
instance Eq1 Complex where
    liftEq eq (x :+ y) (u :+ v) = eq x u && eq y v

instance Read1 Complex where
    liftReadsPrec rdP _ p s = readParen (p > complexPrec) (\s' -> do
      (x, s'')     <- rdP (complexPrec+1) s'
      (":+", s''') <- lex s''
      (y, s'''')   <- rdP (complexPrec+1) s'''
      return (x :+ y, s'''')) s
      where
        complexPrec = 6

instance Show1 Complex where
    liftShowsPrec sp _ d (x :+ y) = showParen (d > complexPrec) $
        sp (complexPrec+1) x . showString " :+ " . sp (complexPrec+1) y
      where
        complexPrec = 6
#  endif

instance Eq a => Eq2 ((,,) a) where
    liftEq2 e1 e2 (u1, x1, y1) (v1, x2, y2) =
        u1 == v1 &&
        e1 x1 x2 && e2 y1 y2

instance Ord a => Ord2 ((,,) a) where
    liftCompare2 comp1 comp2 (u1, x1, y1) (v1, x2, y2) =
        compare u1 v1 `mappend`
        comp1 x1 x2 `mappend` comp2 y1 y2

instance Read a => Read2 ((,,) a) where
    liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->
        [((e1,e2,e3), y) | ("(",s) <- lex r,
                           (e1,t)  <- readsPrec 0 s,
                           (",",u) <- lex t,
                           (e2,v)  <- rp1 0 u,
                           (",",w) <- lex v,
                           (e3,x)  <- rp2 0 w,
                           (")",y) <- lex x]

instance Show a => Show2 ((,,) a) where
    liftShowsPrec2 sp1 _ sp2 _ _ (x1,y1,y2)
        = showChar '(' . showsPrec 0 x1
        . showChar ',' . sp1 0 y1
        . showChar ',' . sp2 0 y2
        . showChar ')'

instance (Eq a, Eq b) => Eq1 ((,,) a b) where
    liftEq = liftEq2 (==)

instance (Ord a, Ord b) => Ord1 ((,,) a b) where
    liftCompare = liftCompare2 compare

instance (Read a, Read b) => Read1 ((,,) a b) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList

instance (Show a, Show b) => Show1 ((,,) a b) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

instance (Eq a, Eq b) => Eq2 ((,,,) a b) where
    liftEq2 e1 e2 (u1, u2, x1, y1) (v1, v2, x2, y2) =
        u1 == v1 &&
        u2 == v2 &&
        e1 x1 x2 && e2 y1 y2

instance (Ord a, Ord b) => Ord2 ((,,,) a b) where
    liftCompare2 comp1 comp2 (u1, u2, x1, y1) (v1, v2, x2, y2) =
        compare u1 v1 `mappend`
        compare u2 v2 `mappend`
        comp1 x1 x2 `mappend` comp2 y1 y2

instance (Read a, Read b) => Read2 ((,,,) a b) where
    liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->
        [((e1,e2,e3,e4), s9) | ("(",s1) <- lex r,
                               (e1,s2)  <- readsPrec 0 s1,
                               (",",s3) <- lex s2,
                               (e2,s4)  <- readsPrec 0 s3,
                               (",",s5) <- lex s4,
                               (e3,s6)  <- rp1 0 s5,
                               (",",s7) <- lex s6,
                               (e4,s8)  <- rp2 0 s7,
                               (")",s9) <- lex s8]

instance (Show a, Show b) => Show2 ((,,,) a b) where
    liftShowsPrec2 sp1 _ sp2 _ _ (x1,x2,y1,y2)
        = showChar '(' . showsPrec 0 x1
        . showChar ',' . showsPrec 0 x2
        . showChar ',' . sp1 0 y1
        . showChar ',' . sp2 0 y2
        . showChar ')'

instance (Eq a, Eq b, Eq c) => Eq1 ((,,,) a b c) where
    liftEq = liftEq2 (==)

instance (Ord a, Ord b, Ord c) => Ord1 ((,,,) a b c) where
    liftCompare = liftCompare2 compare

instance (Read a, Read b, Read c) => Read1 ((,,,) a b c) where
    liftReadsPrec = liftReadsPrec2 readsPrec readList

instance (Show a, Show b, Show c) => Show1 ((,,,) a b c) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

# endif
#endif


{-# LANGUAGE Haskell2010 #-}
{-# LINE 1 "Control/DeepSeq.hs" #-}

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE PolyKinds #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.DeepSeq
-- Copyright   :  (c) The University of Glasgow 2001-2009
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  stable
-- Portability :  portable
--
-- This module provides an overloaded function, 'deepseq', for fully
-- evaluating data structures (that is, evaluating to \"Normal Form\").
--
-- A typical use is to prevent resource leaks in lazy IO programs, by
-- forcing all characters from a file to be read. For example:
--
-- > import System.IO
-- > import Control.DeepSeq
-- >
-- > main = do
-- >     h <- openFile "f" ReadMode
-- >     s <- hGetContents h
-- >     s `deepseq` hClose h
-- >     return s
--
-- 'deepseq' differs from 'seq' as it traverses data structures deeply,
-- for example, 'seq' will evaluate only to the first constructor in
-- the list:
--
-- > > [1,2,undefined] `seq` 3
-- > 3
--
-- While 'deepseq' will force evaluation of all the list elements:
--
-- > > [1,2,undefined] `deepseq` 3
-- > *** Exception: Prelude.undefined
--
-- Another common use is to ensure any exceptions hidden within lazy
-- fields of a data structure do not leak outside the scope of the
-- exception handler, or to force evaluation of a data structure in one
-- thread, before passing to another thread (preventing work moving to
-- the wrong threads).
--
-- @since 1.1.0.0
module Control.DeepSeq (
     deepseq, ($!!), force,
     NFData(..),
  ) where

import Control.Applicative
import Control.Concurrent ( ThreadId, MVar )
import Data.IORef
import Data.STRef
import Data.Int
import Data.Word
import Data.Ratio
import Data.Complex
import Data.Array
import Data.Fixed
import Data.Version
import Data.Monoid as Mon
import Data.Unique ( Unique )
import Foreign.Ptr
import Foreign.C.Types
import System.Exit ( ExitCode(..) )
import System.Mem.StableName ( StableName )

import Data.Ord ( Down(Down) )

import Data.Proxy ( Proxy(Proxy) )

import Data.Functor.Identity ( Identity(..) )
import Data.Typeable ( TypeRep, TyCon, rnfTypeRep, rnfTyCon )
import Data.Void ( Void, absurd )
import Numeric.Natural ( Natural )

import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Semigroup as Semi

import GHC.Stack.Types ( CallStack(..), SrcLoc(..) )

import GHC.Fingerprint.Type ( Fingerprint(..) )
import GHC.Generics

-- | Hidden internal type-class
class GNFData f where
  grnf :: f a -> ()

instance GNFData V1 where
  grnf = error "Control.DeepSeq.rnf: uninhabited type"

instance GNFData U1 where
  grnf U1 = ()

instance NFData a => GNFData (K1 i a) where
  grnf = rnf . unK1
  {-# INLINEABLE grnf #-}

instance GNFData a => GNFData (M1 i c a) where
  grnf = grnf . unM1
  {-# INLINEABLE grnf #-}

instance (GNFData a, GNFData b) => GNFData (a :*: b) where
  grnf (x :*: y) = grnf x `seq` grnf y
  {-# INLINEABLE grnf #-}

instance (GNFData a, GNFData b) => GNFData (a :+: b) where
  grnf (L1 x) = grnf x
  grnf (R1 x) = grnf x
  {-# INLINEABLE grnf #-}

infixr 0 $!!

-- | 'deepseq': fully evaluates the first argument, before returning the
-- second.
--
-- The name 'deepseq' is used to illustrate the relationship to 'seq':
-- where 'seq' is shallow in the sense that it only evaluates the top
-- level of its argument, 'deepseq' traverses the entire data structure
-- evaluating it completely.
--
-- 'deepseq' can be useful for forcing pending exceptions,
-- eradicating space leaks, or forcing lazy I/O to happen.  It is
-- also useful in conjunction with parallel Strategies (see the
-- @parallel@ package).
--
-- There is no guarantee about the ordering of evaluation.  The
-- implementation may evaluate the components of the structure in
-- any order or in parallel.  To impose an actual order on
-- evaluation, use 'pseq' from "Control.Parallel" in the
-- @parallel@ package.
--
-- @since 1.1.0.0
deepseq :: NFData a => a -> b -> b
deepseq a b = rnf a `seq` b

-- | the deep analogue of '$!'.  In the expression @f $!! x@, @x@ is
-- fully evaluated before the function @f@ is applied to it.
--
-- @since 1.2.0.0
($!!) :: (NFData a) => (a -> b) -> a -> b
f $!! x = x `deepseq` f x

-- | a variant of 'deepseq' that is useful in some circumstances:
--
-- > force x = x `deepseq` x
--
-- @force x@ fully evaluates @x@, and then returns it.  Note that
-- @force x@ only performs evaluation when the value of @force x@
-- itself is demanded, so essentially it turns shallow evaluation into
-- deep evaluation.
--
-- 'force' can be conveniently used in combination with @ViewPatterns@:
--
-- > {-# LANGUAGE BangPatterns, ViewPatterns #-}
-- > import Control.DeepSeq
-- >
-- > someFun :: ComplexData -> SomeResult
-- > someFun (force -> !arg) = {- 'arg' will be fully evaluated -}
--
-- Another useful application is to combine 'force' with
-- 'Control.Exception.evaluate' in order to force deep evaluation
-- relative to other 'IO' operations:
--
-- > import Control.Exception (evaluate)
-- > import Control.DeepSeq
-- >
-- > main = do
-- >   result <- evaluate $ force $ pureComputation
-- >   {- 'result' will be fully evaluated at this point -}
-- >   return ()
--
-- @since 1.2.0.0
force :: (NFData a) => a -> a
force x = x `deepseq` x

-- | A class of types that can be fully evaluated.
--
-- @since 1.1.0.0
class NFData a where
    -- | 'rnf' should reduce its argument to normal form (that is, fully
    -- evaluate all sub-components), and then return '()'.
    --
    -- === 'Generic' 'NFData' deriving
    --
    -- Starting with GHC 7.2, you can automatically derive instances
    -- for types possessing a 'Generic' instance.
    --
    -- > {-# LANGUAGE DeriveGeneric #-}
    -- >
    -- > import GHC.Generics (Generic)
    -- > import Control.DeepSeq
    -- >
    -- > data Foo a = Foo a String
    -- >              deriving (Eq, Generic)
    -- >
    -- > instance NFData a => NFData (Foo a)
    -- >
    -- > data Colour = Red | Green | Blue
    -- >               deriving Generic
    -- >
    -- > instance NFData Colour
    --
    -- Starting with GHC 7.10, the example above can be written more
    -- concisely by enabling the new @DeriveAnyClass@ extension:
    --
    -- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
    -- >
    -- > import GHC.Generics (Generic)
    -- > import Control.DeepSeq
    -- >
    -- > data Foo a = Foo a String
    -- >              deriving (Eq, Generic, NFData)
    -- >
    -- > data Colour = Red | Green | Blue
    -- >               deriving (Generic, NFData)
    -- >
    --
    -- === Compatibility with previous @deepseq@ versions
    --
    -- Prior to version 1.4.0.0, the default implementation of the 'rnf'
    -- method was defined as
    --
    -- @'rnf' a = 'seq' a ()@
    --
    -- However, starting with @deepseq-1.4.0.0@, the default
    -- implementation is based on @DefaultSignatures@ allowing for
    -- more accurate auto-derived 'NFData' instances. If you need the
    -- previously used exact default 'rnf' method implementation
    -- semantics, use
    --
    -- > instance NFData Colour where rnf x = seq x ()
    --
    -- or alternatively
    --
    -- > {-# LANGUAGE BangPatterns #-}
    -- > instance NFData Colour where rnf !_ = ()
    --
    rnf :: a -> ()

    default rnf :: (Generic a, GNFData (Rep a)) => a -> ()
    rnf = grnf . from

instance NFData Int      where rnf !_ = ()
instance NFData Word     where rnf !_ = ()
instance NFData Integer  where rnf !_ = ()
instance NFData Float    where rnf !_ = ()
instance NFData Double   where rnf !_ = ()

instance NFData Char     where rnf !_ = ()
instance NFData Bool     where rnf !_ = ()
instance NFData ()       where rnf !_ = ()

instance NFData Int8     where rnf !_ = ()
instance NFData Int16    where rnf !_ = ()
instance NFData Int32    where rnf !_ = ()
instance NFData Int64    where rnf !_ = ()

instance NFData Word8    where rnf !_ = ()
instance NFData Word16   where rnf !_ = ()
instance NFData Word32   where rnf !_ = ()
instance NFData Word64   where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData (Proxy a) where rnf Proxy = ()

-- |@since 1.4.0.0
instance NFData a => NFData (Identity a) where
    rnf = rnf . runIdentity

-- | Defined as @'rnf' = 'absurd'@.
--
-- @since 1.4.0.0
instance NFData Void where
    rnf = absurd

-- |@since 1.4.0.0
instance NFData Natural  where rnf !_ = ()

-- |@since 1.3.0.0
instance NFData (Fixed a) where rnf !_ = ()

-- |This instance is for convenience and consistency with 'seq'.
-- This assumes that WHNF is equivalent to NF for functions.
--
-- @since 1.3.0.0
instance NFData (a -> b) where rnf !_ = ()

--Rational and complex numbers.

instance NFData a => NFData (Ratio a) where
  rnf x = rnf (numerator x, denominator x)

instance (NFData a) => NFData (Complex a) where
  rnf (x:+y) = rnf x `seq`
               rnf y `seq`
               ()

instance NFData a => NFData (Maybe a) where
    rnf Nothing  = ()
    rnf (Just x) = rnf x

instance (NFData a, NFData b) => NFData (Either a b) where
    rnf (Left x)  = rnf x
    rnf (Right y) = rnf y

-- |@since 1.3.0.0
instance NFData Data.Version.Version where
    rnf (Data.Version.Version branch tags) = rnf branch `seq` rnf tags

instance NFData a => NFData [a] where
    rnf [] = ()
    rnf (x:xs) = rnf x `seq` rnf xs

-- |@since 1.4.0.0
instance NFData a => NFData (ZipList a) where
    rnf = rnf . getZipList

-- |@since 1.4.0.0
instance NFData a => NFData (Const a b) where
    rnf = rnf . getConst

instance (NFData a, NFData b) => NFData (Array a b) where
    rnf x = rnf (bounds x, Data.Array.elems x)

-- |@since 1.4.0.0
instance NFData a => NFData (Down a) where
    rnf (Down x) = rnf x

-- |@since 1.4.0.0
instance NFData a => NFData (Dual a) where
    rnf = rnf . getDual

-- |@since 1.4.0.0
instance NFData a => NFData (Mon.First a) where
    rnf = rnf . Mon.getFirst

-- |@since 1.4.0.0
instance NFData a => NFData (Mon.Last a) where
    rnf = rnf . Mon.getLast

-- |@since 1.4.0.0
instance NFData Any where rnf = rnf . getAny

-- |@since 1.4.0.0
instance NFData All where rnf = rnf . getAll

-- |@since 1.4.0.0
instance NFData a => NFData (Sum a) where
    rnf = rnf . getSum

-- |@since 1.4.0.0
instance NFData a => NFData (Product a) where
    rnf = rnf . getProduct

-- |@since 1.4.0.0
instance NFData (StableName a) where
    rnf !_ = () -- assumes `data StableName a = StableName (StableName# a)`

-- |@since 1.4.0.0
instance NFData ThreadId where
    rnf !_ = () -- assumes `data ThreadId = ThreadId ThreadId#`

-- |@since 1.4.0.0
instance NFData Unique where
    rnf !_ = () -- assumes `newtype Unique = Unique Integer`

-- | __NOTE__: Only defined for @base-4.8.0.0@ and later
--
-- @since 1.4.0.0
instance NFData TypeRep where
    rnf tyrep = rnfTypeRep tyrep

-- | __NOTE__: Only defined for @base-4.8.0.0@ and later
--
-- @since 1.4.0.0
instance NFData TyCon where
    rnf tycon = rnfTyCon tycon

-- | __NOTE__: Only strict in the reference and not the referenced value.
--
-- @since 1.4.2.0
instance NFData (IORef a) where
  rnf !_ = ()

-- | __NOTE__: Only strict in the reference and not the referenced value.
--
-- @since 1.4.2.0
instance NFData (STRef s a) where
  rnf !_ = ()

-- | __NOTE__: Only strict in the reference and not the referenced value.
--
-- @since 1.4.2.0
instance NFData (MVar a) where
  rnf !_ = ()

----------------------------------------------------------------------------
-- GHC Specifics

-- |@since 1.4.0.0
instance NFData Fingerprint where
    rnf (Fingerprint _ _) = ()

----------------------------------------------------------------------------
-- Foreign.Ptr

-- |@since 1.4.2.0
instance NFData (Ptr a) where rnf !_ = ()

-- |@since 1.4.2.0
instance NFData (FunPtr a) where rnf !_ = ()

----------------------------------------------------------------------------
-- Foreign.C.Types

-- |@since 1.4.0.0
instance NFData CChar where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CSChar where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUChar where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CShort where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUShort where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CInt where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUInt where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CLong where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CULong where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CPtrdiff where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CSize where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CWchar where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CSigAtomic where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CLLong where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CULLong where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CIntPtr where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUIntPtr where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CIntMax where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUIntMax where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CClock where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CTime where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CUSeconds where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CSUSeconds where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CFloat where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CDouble where rnf !_ = ()

-- NOTE: The types `CFile`, `CFPos`, and `CJmpBuf` below are not
-- newtype wrappers rather defined as field-less single-constructor
-- types.

-- |@since 1.4.0.0
instance NFData CFile where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CFpos where rnf !_ = ()

-- |@since 1.4.0.0
instance NFData CJmpBuf where rnf !_ = ()

----------------------------------------------------------------------------
-- System.Exit

-- |@since 1.4.2.0
instance NFData ExitCode where
  rnf (ExitFailure n) = rnf n
  rnf ExitSuccess     = ()

----------------------------------------------------------------------------
-- instances previously provided by semigroups package

-- |@since 1.4.2.0
instance NFData a => NFData (NonEmpty a) where
  rnf (x :| xs) = rnf x `seq` rnf xs

-- |@since 1.4.2.0
instance NFData a => NFData (Min a) where
  rnf (Min a) = rnf a

-- |@since 1.4.2.0
instance NFData a => NFData (Max a) where
  rnf (Max a) = rnf a

-- |@since 1.4.2.0
instance (NFData a, NFData b) => NFData (Arg a b) where
  rnf (Arg a b) = rnf a `seq` rnf b `seq` ()

-- |@since 1.4.2.0
instance NFData a => NFData (Semi.First a) where
  rnf (Semi.First a) = rnf a

-- |@since 1.4.2.0
instance NFData a => NFData (Semi.Last a) where
  rnf (Semi.Last a) = rnf a

-- |@since 1.4.2.0
instance NFData m => NFData (WrappedMonoid m) where
  rnf (WrapMonoid a) = rnf a

-- |@since 1.4.2.0
instance NFData a => NFData (Option a) where
  rnf (Option a) = rnf a

----------------------------------------------------------------------------
-- GHC.Stack

-- |@since 1.4.2.0
instance NFData SrcLoc where
  rnf (SrcLoc a b c d e f g) = rnf a `seq` rnf b `seq` rnf c `seq`
                               rnf d `seq` rnf e `seq` rnf f `seq` rnf g

-- |@since 1.4.2.0
instance NFData CallStack where
  rnf EmptyCallStack = ()
  rnf (PushCallStack a b c) = rnf a `seq` rnf b `seq` rnf c
  rnf (FreezeCallStack a)   = rnf a

----------------------------------------------------------------------------
-- Tuples

instance (NFData a, NFData b) => NFData (a,b) where
  rnf (x,y) = rnf x `seq` rnf y

instance (NFData a, NFData b, NFData c) => NFData (a,b,c) where
  rnf (x,y,z) = rnf x `seq` rnf y `seq` rnf z

instance (NFData a, NFData b, NFData c, NFData d) => NFData (a,b,c,d) where
  rnf (x1,x2,x3,x4) = rnf x1 `seq`
                      rnf x2 `seq`
                      rnf x3 `seq`
                      rnf x4

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) =>
         NFData (a1, a2, a3, a4, a5) where
  rnf (x1, x2, x3, x4, x5) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) =>
         NFData (a1, a2, a3, a4, a5, a6) where
  rnf (x1, x2, x3, x4, x5, x6) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) =>
         NFData (a1, a2, a3, a4, a5, a6, a7) where
  rnf (x1, x2, x3, x4, x5, x6, x7) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8, x9) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8 `seq`
                  rnf x9


{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module: Chainweb.Test.SPV
-- Copyright: Copyright © 2018 - 2020 Kadena LLC.
-- License: MIT
-- Maintainer: Lars Kuhtz <lars@kadena.io>
-- Stability: experimental
--
-- TODO
--
module Chainweb.Test.SPV
( tests
, spvTransactionRoundtripTest
, spvTransactionOutputRoundtripTest
, apiTests
) where

import Control.Lens (view, (^?!))
import Control.Monad.Catch
import Control.Monad.IO.Class

import Data.Aeson
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.CAS
import Data.Foldable
import Data.Functor.Of
import qualified Data.List as L
import Data.LogMessage
import qualified Data.Vector.Unboxed as V

import Numeric.Natural

import Servant.Client

import Statistics.Regression

import qualified Streaming.Prelude as S

import Test.QuickCheck
import Test.Tasty
import Test.Tasty.HUnit

-- internal modules

import Chainweb.BlockHeader
import Chainweb.ChainId
import Chainweb.Cut
import Chainweb.CutDB
import Chainweb.Graph
import Chainweb.Mempool.Mempool (MockTx)
import Chainweb.Payload
import Chainweb.Payload.PayloadStore
import Chainweb.SPV
import Chainweb.SPV.CreateProof
import Chainweb.SPV.RestAPI.Client
import Chainweb.SPV.VerifyProof
import Chainweb.Test.CutDB
import Chainweb.Test.Utils
import Chainweb.TreeDB
import Chainweb.Utils
import Chainweb.Version

import Data.CAS.RocksDB

-- -------------------------------------------------------------------------- --
-- Test Tree

-- FIXME: These tests is randomized, and should either be rewritten using
-- quickCheck instead of HUnit or should be derandomized.
--
tests :: RocksDb -> TestTree
tests rdb = testGroup "SPV tests"
    [ testCaseStepsN "SPV transaction proof" 10 (spvTransactionRoundtripTest rdb version)
    , testCaseStepsN "SPV transaction output proof" 10 (spvTransactionOutputRoundtripTest rdb version)
    , apiTests rdb version
    , testCaseSteps "SPV transaction proof test" (spvTest rdb version)
    ]
  where
    version = Test petersonChainGraph

-- -------------------------------------------------------------------------- --
-- Utils

type Step = String -> IO ()

testCaseStepsN :: String -> Natural -> (Step -> Assertion) -> TestTree
testCaseStepsN name n test = testGroup name $ flip map [1..n] $ \i ->
    testCaseSteps ("Run test number " <> sshow i) test

-- Find a reachable target chain
--
targetChain :: Cut -> BlockHeader -> IO ChainId
targetChain c srcBlock = do
    cids <- generate (shuffle $ toList $ chainIds c)
    go cids
  where
    graph = _chainGraph c

    go [] = error
        $ "SPV proof test failed to find a reachable target chain. This is a bug in the test code"
        <> ". source block: " <> sshow srcBlock
        <> ". current cut: " <> sshow c
    go (h:t) = if isReachable h then return h else go t

    chainHeight trgChain = _blockHeight (c ^?! ixg trgChain)

    isReachable trgChain
        = _blockHeight srcBlock <= chainHeight trgChain - distance trgChain

    distance x = len $ shortestPath (_chainId srcBlock) x graph

-- -------------------------------------------------------------------------- --
-- Comprehensive SPV test for transaction proofs

-- | Creates a test chainweb instance and exhaustively creates SPV transaction
-- output proofs for each transaction on each chain.
--
-- Also checks that the size of the created proofs meets the expectations.
--
spvTest :: RocksDb -> ChainwebVersion -> Step -> IO ()
spvTest rdb v step = do
    withTestCutDbWithoutPact rdb v 100 logg $ \cutDb -> do
        curCut <- _cutMap <$> _cut cutDb

        -- for each blockheader h in cut
        samples <- S.each (toList curCut)
            -- for each ancestor ah of h
            & flip S.for (\h -> ancestors (cutDb ^?! cutDbBlockHeaderDb h) (_blockHash h))
            -- for each transaction in ah
            & flip S.for (\h -> getPayloads cutDb h)
            -- for each target chain c
            & flip S.for (\(a,b,c,d) -> S.each $ (a,b,c,d,) <$> toList (chainIds cutDb))
            -- Create and verify transaction output proof
            & S.mapM (go cutDb)
            -- Ingore all cases where a proof couldn't be created
            & S.concat
            & S.toList_

        -- Confirm size of proofs
        let (coef, r2) = regress samples
        step $ show r2
        step $ show coef
        assertBool
            ("proof size is not constant in the block height: r-value " <> sshow r2 <> " is < 0.8")
            (r2 > 0.8)
  where
    logg :: LogFunction
    -- logg _ msg = step $ T.unpack $ logText msg
    logg _ _ = return ()

    -- Stream of all transactions in a block. Each returned item is
    -- - block header
    -- - block size (tx count)
    -- - tx index
    -- - tx
    --
    getPayloads
        :: PayloadCasLookup cas
        => CutDb cas
        -> BlockHeader
        -> S.Stream (Of (BlockHeader, Int, Int, TransactionOutput)) IO ()
    getPayloads cutDb h = do
        pay <- liftIO $ casLookupM (view cutDbPayloadCas cutDb) (_blockPayloadHash h)
        let n = length $ _payloadWithOutputsTransactions pay
        S.each (zip [0..] $ fmap snd $ toList $ _payloadWithOutputsTransactions pay)
            & S.map (\(b,c) -> (h,n,b,c))

    -- Given
    -- - block header,
    -- - tx count of block,
    -- - tx index,
    -- - tx, and
    -- - target chain,
    --
    -- creates and verifies SPV proofs and returns list of
    -- - tx proof length
    -- - block size (tx count)
    -- - block height difference
    -- - distance between source chain and target chain
    -- - size of tx
    --
    go
        :: PayloadCasLookup cas
        => CutDb cas
        -> (BlockHeader, Int, Int, TransactionOutput, ChainId)
        -> IO (Maybe [Double])
    go cutDb (h, n, txIx, txOut, trgChain) = do

        let inner = do
                -- create inclusion proof for transaction
                proof <- createTransactionOutputProof cutDb trgChain
                    (_chainId h) -- source chain
                    (_blockHeight h) -- source block height
                    txIx -- transaction index
                subj <- verifyTransactionOutputProof cutDb proof
                assertEqual "transaction output proof subject matches transaction" txOut subj

                -- return (proof size, block size, height, distance, tx size)
                return
                    [ int $ BL.length $ encode proof
                    , int n
                    , int $ _blockHeight h
                    , int $ distance cutDb h trgChain
                    , int $ B.length (_transactionOutputBytes txOut)
                    ]

        isReachable <- reachable cutDb h trgChain
        try inner >>= \case
            Right x -> do
                let msg = "SPV proof creation succeeded although target chain is not reachable ("
                        <> "source height: " <> sshow (_blockHeight h)
                        <> ", distance: " <> sshow (distance cutDb h trgChain)
                        <> ")"
                assertBool msg isReachable
                return (Just x)
            Left SpvExceptionTargetNotReachable{} -> do
                let msg = "SPV proof creation failed although target chain is reachable ("
                        <> "source height: " <> sshow (_blockHeight h)
                        <> ", distance: " <> sshow (distance cutDb h trgChain)
                        <> ")"
                assertBool msg (not isReachable)
                return Nothing
            Left e -> throwM e

    -- Distance between source chain an target chain
    --
    distance cutDb h trgChain = length
        $ shortestPath (_chainId h) trgChain
        $ _chainGraph cutDb

    -- Check whether target chain is reachable from the source block
    --
    reachable :: CutDb as -> BlockHeader -> ChainId -> IO Bool
    reachable cutDb h trgChain = do
        m <- maxRank $ cutDb ^?! cutDbBlockHeaderDb trgChain
        return $ (int m - int (_blockHeight h)) >= distance cutDb h trgChain

    -- regression model with @createTransactionOutputProof@. Proof size doesn't
    -- depend on target height.
    --
    -- (This proof size is logarithmic in the block size and linear in the
    -- distance and transation size)
    --
    regress r
        | [proofSize, blockSize, _heightDiff, chainDist, txSize] <- V.fromList <$> L.transpose r
            = olsRegress [V.map (logBase 2) blockSize, chainDist, txSize] proofSize
        | otherwise = error "Chainweb.Test.SPV.spvTest.regress: fail to match regressor list. This is a bug in the test code."

    -- regression model for @createTransactionOutputProof'@. Proof size depends
    -- on target height.
    --
    -- regressWithHeightDiff r
    --     | [proofSize, blockSize, heightDiff, chainDist, txSize] <- V.fromList <$> L.transpose r
    --         = olsRegress [V.map (logBase 2) blockSize, heightDiff, chainDist, txSize] proofSize
    --     | otherwise = error "Chainweb.Test.SPV.spvTest.regress: fail to match regressor list. This is a bug in the test code."

-- -------------------------------------------------------------------------- --
-- SPV Tests

spvTransactionRoundtripTest :: RocksDb -> ChainwebVersion -> Step -> IO ()
spvTransactionRoundtripTest rdb v step = do
    step "setup cut db"
    withTestCutDbWithoutPact rdb v 100 (\_ _ -> return ()) $ \cutDb -> do
        step "pick random transaction"
        (h, txIx, tx, _) <- randomTransaction cutDb

        step "pick a reachable target chain"
        curCut <- _cut cutDb
        trgChain <- targetChain curCut h

        step "create inclusion proof for transaction"
        proof <- createTransactionProof
            cutDb
                -- CutDb
            trgChain
                -- target chain
            (_chainId h)
                -- source chain
            (_blockHeight h)
                -- source block height
            txIx
                -- transaction index

        step "json encoding roundtrip of proof"
        assertEqual "decode proof equals original proof"
            (Right proof)
            (eitherDecode (encode proof))

        step "verify proof"
        subj <- verifyTransactionProof cutDb proof

        step "confirm that proof subject matches transaction"
        assertEqual "proof subject matches transaction" tx subj

spvTransactionOutputRoundtripTest :: RocksDb -> ChainwebVersion -> Step -> IO ()
spvTransactionOutputRoundtripTest rdb v step = do
    step "setup cut db"
    withTestCutDbWithoutPact rdb v 100 (\_ _ -> return ()) $ \cutDb -> do

        step "pick random transaction output"
        (h, outIx, _, out) <- randomTransaction cutDb

        step "pick a reachable target chain"
        curCut <- _cut cutDb
        trgChain <- targetChain curCut h

        step "create inclusion proof for transaction output"
        proof <- createTransactionOutputProof
            cutDb
                -- CutDb
            trgChain
                -- target chain
            (_chainId h)
                -- source chain
            (_blockHeight h)
                -- source block height
            outIx
                -- transaction index

        step "json encoding roundtrip of proof"
        assertEqual "decode proof equals original proof"
            (Right proof)
            (eitherDecode (encode proof))

        step "verify proof"
        subj <- verifyTransactionOutputProof cutDb proof

        step "confirm that proof subject matches transaction output"
        assertEqual "proof subject matches transaction output" out subj

-- -------------------------------------------------------------------------- --
-- REST API

type TestClientEnv_ cas = TestClientEnv MockTx cas

apiTests :: RocksDb -> ChainwebVersion -> TestTree
apiTests rdb v = withTestPayloadResource rdb v 100 (\_ _ -> return ()) $ \dbIO ->
    testGroup "SPV API tests"
        [ withPayloadServer False v dbIO (payloadDbs . view cutDbPayloadCas <$> dbIO) $ \env ->
            testCaseStepsN "spv api tests (without tls)" 10 (txApiTests env)
        , withPayloadServer True v dbIO (payloadDbs . view cutDbPayloadCas <$> dbIO) $ \env ->
            testCaseStepsN "spv api tests (with tls)" 10 (txApiTests env)
        ]
  where
    cids = toList $ chainIds v

    payloadDbs :: PayloadCasLookup cas' => PayloadDb cas' -> [(ChainId, PayloadDb cas')]
    payloadDbs db = (, db) <$> cids

txApiTests :: PayloadCasLookup cas => IO (TestClientEnv_ cas) -> Step -> IO ()
txApiTests envIO step = do
    PayloadTestClientEnv env cutDb _payloadDbs v <- envIO
    step "pick random transaction"
    (h, txIx, tx, out) <- randomTransaction cutDb

    step $ "picked random transaction, height: " <> sshow (_blockHeight h) <> ", ix: " <> sshow txIx

    curCut <- _cut cutDb
    trgChain <- targetChain curCut h
    step $ "picked a reachable target chain, chain id: " <> sshow trgChain

    -- Transaction Proof:

    step "request transaction proof"
    txProof <- flip runClientM env $
        spvGetTransactionProofClient v trgChain (_chainId h) (_blockHeight h) (int txIx)

    case txProof of

        Left err ->
            assertFailure $ "request for transaction proof failed: " <> sshow err

        Right proof -> do
            step "verify transaction proof"
            subj <- verifyTransactionProof cutDb proof

            step "confirm that transaction proof subject matches transaction"
            assertEqual "proof subject matches transaction" tx subj

    -- Transaction Output Proof:

    step "request transaction output proof"
    outProof <- flip runClientM env $
        spvGetTransactionOutputProofClient v trgChain (_chainId h) (_blockHeight h) (int txIx)

    case outProof of

        Left err ->
            assertFailure $ "request for transaction output proof failed: " <> sshow err

        Right proof -> do
            step "verify transaction output proof"
            subj <- verifyTransactionOutputProof cutDb proof

            step "confirm that transaction output proof subject matches transaction output"
            assertEqual "proof subject matches transaction output" out subj