{-# LANGUAGE CPP #-}

{-# LANGUAGE MultiParamTypeClasses  #-} -- for 'Bind' class.
{-# LANGUAGE ConstraintKinds        #-} -- for 'Bind' class.
{-# LANGUAGE TypeFamilies           #-} -- for 'Bind' class.

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE UndecidableInstances #-}

{-# LANGUAGE TypeOperators #-} -- For ':*:' instance and others.

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
-- Some of the constraints may be unnecessary, but they are intentional.
-- This is especially true for the 'Fail' instances.
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif

-- | Definition of supermonads that support constrained monads.
module Control.Super.Monad.Constrained
  ( -- * Supermonads
    Bind(..), Return(..), Fail(..)
    -- * Super-Applicatives
  , Applicative(..), pure
  , Functor(..)
    -- * Conveniences
  , Monad
  ) where

import GHC.Exts ( Constraint )

import Prelude
  ( String, Maybe, Either
  , Ord
  , (.), ($), const
  )
import qualified Prelude as P

-- To define instances:
import Data.Functor.Identity ( Identity(..) )

import qualified Data.Monoid as Mon
import qualified Data.Proxy as Proxy
import qualified Data.Functor.Product as Product
import qualified Data.Functor.Compose as Compose
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
import qualified Data.Complex as Complex
import qualified Data.Semigroup as Semigroup
import qualified Data.List.NonEmpty as NonEmpty
#endif

import qualified Control.Arrow as Arrow
import qualified Control.Applicative as App
import qualified Control.Monad.ST as ST
import qualified Control.Monad.ST.Lazy as STL

import qualified Text.ParserCombinators.ReadP as Read
import qualified Text.ParserCombinators.ReadPrec as Read

import qualified GHC.Conc as STM
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
import qualified GHC.Generics as Generics
#endif

-- To defined constrained instances:
import qualified Data.Set as S

-- To define "transformers" instances:
import qualified Control.Monad.Trans.Cont     as Cont
import qualified Control.Monad.Trans.Except   as Except
import qualified Control.Monad.Trans.Identity as Identity
import qualified Control.Monad.Trans.Maybe    as Maybe
import qualified Control.Monad.Trans.RWS.Lazy      as RWSL
import qualified Control.Monad.Trans.RWS.Strict    as RWSS
import qualified Control.Monad.Trans.Reader        as Reader
import qualified Control.Monad.Trans.State.Lazy    as StateL
import qualified Control.Monad.Trans.State.Strict  as StateS
import qualified Control.Monad.Trans.Writer.Lazy   as WriterL
import qualified Control.Monad.Trans.Writer.Strict as WriterS

-- To define 'Bind' class:
import Control.Super.Monad.Constrained.Functor
  ( Functor(..) )

-- -----------------------------------------------------------------------------
-- Super-Applicative Type Class
-- -----------------------------------------------------------------------------

infixl 4 <*>, <*, *>

-- | TODO
class (Functor m, Functor n, Functor p) => Applicative m n p where
  type ApplicativeCts m n p (a :: *) (b :: *) :: Constraint
  type ApplicativeCts m n p a b = ()

  type ApplicativeCtsR m n p (a :: *) (b :: *) :: Constraint
  type ApplicativeCtsR m n p a b = ApplicativeCts m n p a b

  type ApplicativeCtsL m n p (a :: *) (b :: *) :: Constraint
  type ApplicativeCtsL m n p a b = ApplicativeCts m n p a b

  (<*>) :: (ApplicativeCts m n p a b) => m (a -> b) -> n a -> p b

  -- TODO: Cannot give standard instances, because they would require
  -- different constraints.
  (*>) :: (ApplicativeCtsR m n p a b) => m a -> n b -> p b
  --ma *> nb = (P.id <$ ma) <*> nb
  --ma *> nb = (pure P.id <*> ma) <*> nb

  (<*) :: (ApplicativeCtsL m n p a b) => m a -> n b -> p a
  --ma <* nb = fmap const ma <*> nb
  --ma <* nb = (pure const <*> ma) <*> nb

-- | 'pure' is defined in terms of return.
pure :: (Return f, ReturnCts f a) => a -> f a
pure = return

type family DefaultAppCtsR m n p a b :: Constraint where
  DefaultAppCtsR m n p a b = (ApplicativeCts m n p b b, FunctorCts m a (b -> b))

type family DefaultAppCtsL m n p a b :: Constraint where
  DefaultAppCtsL m n p a b = (ApplicativeCts m n p b a, FunctorCts m a (b -> a))

defaultAppR :: (Applicative m n p, DefaultAppCtsR m n p a b) => m a -> n b -> p b
defaultAppR ma nb = (P.id <$ ma) <*> nb

defaultAppL :: (Applicative m n p, DefaultAppCtsL m n p a b) => m a -> n b -> p a
defaultAppL ma nb = fmap const ma <*> nb

-- Standard Instances ----------------------------------------------------------

instance Applicative ((->) r) ((->) r) ((->) r) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Identity Identity Identity where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative [] [] [] where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Maybe Maybe Maybe where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative P.IO P.IO P.IO where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative (Either e) (Either e) (Either e) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

instance Applicative Mon.First Mon.First Mon.First where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Mon.Last Mon.Last Mon.Last where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Mon.Sum Mon.Sum Mon.Sum where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Mon.Product Mon.Product Mon.Product where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Mon.Dual Mon.Dual Mon.Dual where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#endif
instance (Applicative m n p) => Applicative (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) where
  type ApplicativeCts (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) a b = ApplicativeCts m n p a b
  type ApplicativeCtsR (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) a b = ApplicativeCtsR m n p a b
  type ApplicativeCtsL (Mon.Alt m) (Mon.Alt n) (Mon.Alt p) a b = ApplicativeCtsL m n p a b
  mf <*> na = Mon.Alt $ (Mon.getAlt mf) <*> (Mon.getAlt na)
  mf *> na = Mon.Alt $ (Mon.getAlt mf) *> (Mon.getAlt na)
  mf <* na = Mon.Alt $ (Mon.getAlt mf) <* (Mon.getAlt na)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Semigroup.Min Semigroup.Min Semigroup.Min where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.Max Semigroup.Max Semigroup.Max where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.Option Semigroup.Option Semigroup.Option where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.First Semigroup.First Semigroup.First where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Semigroup.Last Semigroup.Last Semigroup.Last where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#endif

instance Applicative Proxy.Proxy Proxy.Proxy Proxy.Proxy where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Complex.Complex Complex.Complex Complex.Complex where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative NonEmpty.NonEmpty NonEmpty.NonEmpty NonEmpty.NonEmpty where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
#endif

instance (Applicative m1 n1 p1, Applicative m2 n2 p2) => Applicative (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) where
  type ApplicativeCts (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) a b = (ApplicativeCts m1 n1 p1 a b, ApplicativeCts m2 n2 p2 a b)
  type ApplicativeCtsR (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) a b = (ApplicativeCtsR m1 n1 p1 a b, ApplicativeCtsR m2 n2 p2 a b)
  type ApplicativeCtsL (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) a b = (ApplicativeCtsL m1 n1 p1 a b, ApplicativeCtsL m2 n2 p2 a b)
  Product.Pair m1 m2 <*> Product.Pair n1 n2 = Product.Pair (m1 <*> n1) (m2 <*> n2)
  Product.Pair m1 m2  *> Product.Pair n1 n2 = Product.Pair (m1  *> n1) (m2  *> n2)
  Product.Pair m1 m2 <*  Product.Pair n1 n2 = Product.Pair (m1 <*  n1) (m2 <*  n2)

instance (Applicative f g h, Applicative f' g' h') => Applicative (Compose.Compose f f') (Compose.Compose g g') (Compose.Compose h h') where
  type ApplicativeCts  (Compose.Compose f f') (Compose.Compose g g') (Compose.Compose h h') a b = ( ApplicativeCts f g h (g' a) (h' b), ApplicativeCts  f' g' h' a b
                                                                                , FunctorCts f (f' (a -> b)) (g' a -> h' b) )
  type ApplicativeCtsL (Compose.Compose f f') (Compose.Compose g g') (Compose.Compose h h') a b = ( ApplicativeCts f g h (g' b) (h' a), ApplicativeCtsL f' g' h' a b
                                                                                , FunctorCts f (f' a) (g' b -> h' a) )
  type ApplicativeCtsR (Compose.Compose f f') (Compose.Compose g g') (Compose.Compose h h') a b = ( ApplicativeCts f g h (g' b) (h' b), ApplicativeCtsR f' g' h' a b
                                                                                , FunctorCts f (f' a) (g' b -> h' b) )
  Compose.Compose f <*> Compose.Compose x = Compose.Compose $ fmap (<*>) f <*> x
  Compose.Compose f  *> Compose.Compose x = Compose.Compose $ fmap ( *>) f <*> x
  Compose.Compose f <*  Compose.Compose x = Compose.Compose $ fmap (<* ) f <*> x

instance Applicative Read.ReadP Read.ReadP Read.ReadP where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative Read.ReadPrec Read.ReadPrec Read.ReadPrec where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

instance Applicative (ST.ST s) (ST.ST s) (ST.ST s) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance Applicative (STL.ST s) (STL.ST s) (STL.ST s) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

instance (Arrow.Arrow a, Arrow.ArrowApply a) => Applicative (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

instance (Applicative m n p) => Applicative (App.WrappedMonad m) (App.WrappedMonad n) (App.WrappedMonad p) where
  type ApplicativeCts (App.WrappedMonad m) (App.WrappedMonad n) (App.WrappedMonad p) a b = ApplicativeCts m n p a b
  type ApplicativeCtsR (App.WrappedMonad m) (App.WrappedMonad n) (App.WrappedMonad p) a b = ApplicativeCtsR m n p a b
  type ApplicativeCtsL (App.WrappedMonad m) (App.WrappedMonad n) (App.WrappedMonad p) a b = ApplicativeCtsL m n p a b
  mf <*> na = App.WrapMonad $ (App.unwrapMonad mf) <*> (App.unwrapMonad na)
  mf  *> na = App.WrapMonad $ (App.unwrapMonad mf)  *> (App.unwrapMonad na)
  mf <*  na = App.WrapMonad $ (App.unwrapMonad mf) <*  (App.unwrapMonad na)

instance Applicative STM.STM STM.STM STM.STM where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Applicative Generics.U1 Generics.U1 Generics.U1 where
  (<*>) = (P.<*>)
  (<*)  = (P.<*)
  (*>)  = (P.*>)
instance (Applicative f g h) => Applicative (Generics.Rec1 f) (Generics.Rec1 g) (Generics.Rec1 h) where
  type ApplicativeCts  (Generics.Rec1 f) (Generics.Rec1 g) (Generics.Rec1 h) a b = ApplicativeCts  f g h a b
  type ApplicativeCtsR (Generics.Rec1 f) (Generics.Rec1 g) (Generics.Rec1 h) a b = ApplicativeCtsR f g h a b
  type ApplicativeCtsL (Generics.Rec1 f) (Generics.Rec1 g) (Generics.Rec1 h) a b = ApplicativeCtsL f g h a b
  (Generics.Rec1 mf) <*> (Generics.Rec1 ma) = Generics.Rec1 $ mf <*> ma
  (Generics.Rec1 mf)  *> (Generics.Rec1 ma) = Generics.Rec1 $ mf  *> ma
  (Generics.Rec1 mf) <*  (Generics.Rec1 ma) = Generics.Rec1 $ mf <*  ma
instance (Applicative f g h, Applicative f' g' h') => Applicative (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') where
  type ApplicativeCts  (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') a b = (ApplicativeCts  f g h a b, ApplicativeCts  f' g' h' a b)
  type ApplicativeCtsL (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') a b = (ApplicativeCtsL f g h a b, ApplicativeCtsL f' g' h' a b)
  type ApplicativeCtsR (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') a b = (ApplicativeCtsR f g h a b, ApplicativeCtsR f' g' h' a b)
  (f Generics.:*: g) <*> (f' Generics.:*: g') = (f <*> f') Generics.:*: (g <*> g')
  (f Generics.:*: g)  *> (f' Generics.:*: g') = (f  *> f') Generics.:*: (g  *> g')
  (f Generics.:*: g) <*  (f' Generics.:*: g') = (f <*  f') Generics.:*: (g <*  g')
-- TODO: Is there a nicer way to implement this for ':.:'?
instance (Applicative f g h, Applicative f' g' h') => Applicative (f Generics.:.: f') (g Generics.:.: g') (h Generics.:.: h') where
  type ApplicativeCts  (f Generics.:.: f') (g Generics.:.: g') (h Generics.:.: h') a b = ( ApplicativeCts f g h (g' a) (h' b), ApplicativeCts  f' g' h' a b
                                                                                , FunctorCts f (f' (a -> b)) (g' a -> h' b) )
  type ApplicativeCtsL (f Generics.:.: f') (g Generics.:.: g') (h Generics.:.: h') a b = ( ApplicativeCts f g h (g' b) (h' a), ApplicativeCtsL f' g' h' a b
                                                                                , FunctorCts f (f' a) (g' b -> h' a) )
  type ApplicativeCtsR (f Generics.:.: f') (g Generics.:.: g') (h Generics.:.: h') a b = ( ApplicativeCts f g h (g' b) (h' b), ApplicativeCtsR f' g' h' a b
                                                                                , FunctorCts f (f' a) (g' b -> h' b) )
  (Generics.Comp1 mf) <*> (Generics.Comp1 ma) = Generics.Comp1 $ fmap (<*>) mf <*> ma
  (Generics.Comp1 ma)  *> (Generics.Comp1 mb) = Generics.Comp1 $ fmap ( *>) ma <*> mb
  (Generics.Comp1 ma) <*  (Generics.Comp1 mb) = Generics.Comp1 $ fmap (<* ) ma <*> mb
instance Applicative f g h => Applicative (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) where
  type ApplicativeCts  (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) a b = ApplicativeCts  f g h a b
  type ApplicativeCtsL (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) a b = ApplicativeCtsL f g h a b
  type ApplicativeCtsR (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) a b = ApplicativeCtsR f g h a b
  (Generics.M1 mf) <*> (Generics.M1 ma) = Generics.M1 $ mf <*> ma
  (Generics.M1 mf)  *> (Generics.M1 ma) = Generics.M1 $ mf  *> ma
  (Generics.M1 mf) <*  (Generics.M1 ma) = Generics.M1 $ mf <*  ma
#endif

-- Constrained Instances -------------------------------------------------------

instance Applicative S.Set S.Set S.Set where
  type ApplicativeCts S.Set S.Set S.Set a b = Ord b
  type ApplicativeCtsR S.Set S.Set S.Set a b = ()
  type ApplicativeCtsL S.Set S.Set S.Set a b = ()
  fs  <*> as = S.foldr (\f r -> S.map f as `S.union` r) S.empty fs
  as  <*  _bs = as
  _as *>  bs = bs

-- "transformers" package instances: -------------------------------------------

-- Continuations are so wierd...
-- | TODO / FIXME: Still need to figure out how and if we can generalize the continuation implementation.
instance Applicative (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) where
  type ApplicativeCts (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) a b = ()
  f <*> a = Cont.ContT $ \ c -> Cont.runContT f $ \ g -> Cont.runContT a (c . g)
  (<*) = defaultAppL
  (*>) = defaultAppR
  {-# INLINE (<*>) #-}

instance (Applicative m n p) => Applicative (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) where
  type ApplicativeCts (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) a b =
        ( ApplicativeCts m n p (Either e a) (Either e b)
        , FunctorCts m (Either e (a -> b)) (Either e a -> Either e b) )
  type ApplicativeCtsL (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) a b =
        (ApplicativeCtsL m n p (Either e a) (Either e b))
  type ApplicativeCtsR (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) a b =
        (ApplicativeCtsR m n p (Either e a) (Either e b))
  Except.ExceptT f <*> Except.ExceptT v = Except.ExceptT $ fmap (<*>) f <*> v
  Except.ExceptT a <*  Except.ExceptT b = Except.ExceptT $ a <* b
  Except.ExceptT a *>  Except.ExceptT b = Except.ExceptT $ a *> b
  {-# INLINEABLE (<*>) #-}

instance (Applicative m n p) => Applicative (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) where
  type ApplicativeCts  (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) a b = (ApplicativeCts m n p a b)
  type ApplicativeCtsR (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) a b = (ApplicativeCtsR m n p a b)
  type ApplicativeCtsL (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) a b = (ApplicativeCtsL m n p a b)
  Identity.IdentityT m <*> Identity.IdentityT k = Identity.IdentityT $ m <*> k
  Identity.IdentityT a <*  Identity.IdentityT b = Identity.IdentityT $ a <* b
  Identity.IdentityT a *>  Identity.IdentityT b = Identity.IdentityT $ a *> b
  {-# INLINE (<*>) #-}

instance (Applicative m n p) => Applicative (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) where
  type ApplicativeCts  (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) a b =
        ( ApplicativeCts m n p (Maybe a) (Maybe b)
        , FunctorCts m (Maybe (a -> b)) (Maybe a -> Maybe b) )
  type ApplicativeCtsR (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) a b =
        ( ApplicativeCtsR m n p (Maybe a) (Maybe b) )
  type ApplicativeCtsL (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) a b =
        ( ApplicativeCtsL m n p (Maybe a) (Maybe b) )
  Maybe.MaybeT f <*> Maybe.MaybeT x = Maybe.MaybeT $ fmap (<*>) f <*> x
  Maybe.MaybeT a <*  Maybe.MaybeT b = Maybe.MaybeT $ a <* b
  Maybe.MaybeT a *>  Maybe.MaybeT b = Maybe.MaybeT $ a *> b
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Bind m n p) => Applicative (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) where
  type ApplicativeCts (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) a b =
        ( BindCts m n p (a -> b, s, w) (b, s, w)
        , FunctorCts n (a, s, w) (b, s, w) )
  type ApplicativeCtsR (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) a b =
        (DefaultAppCtsR (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) a b)
  type ApplicativeCtsL (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) a b =
        (DefaultAppCtsL (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) a b)
  RWSL.RWST mf <*> RWSL.RWST ma  = RWSL.RWST $ \r s -> mf r s >>= \ ~(f, s', w) -> fmap (\ ~(a, s'', w') -> (f a, s'', P.mappend w w')) (ma r s')
  (<*) = defaultAppL
  (*>) = defaultAppR
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Bind m n p) => Applicative (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) where
  type ApplicativeCts (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) a b =
        ( BindCts m n p (a -> b, s, w) (b, s, w)
        , FunctorCts n (a, s, w) (b, s, w) )
  type ApplicativeCtsR (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) a b =
        (DefaultAppCtsR (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) a b)
  type ApplicativeCtsL (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) a b =
        (DefaultAppCtsL (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) a b)
  RWSS.RWST mf <*> RWSS.RWST ma = RWSS.RWST $ \r s -> mf r s >>= \ (f, s', w) -> fmap (\ (a, s'', w') -> (f a, s'', P.mappend w w')) (ma r s')
  (<*) = defaultAppL
  (*>) = defaultAppR
  {-# INLINE (<*>) #-}

instance (Applicative m n p) => Applicative (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) where
  type ApplicativeCts (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) a b = (ApplicativeCts m n p a b)
  type ApplicativeCtsR (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) a b =
        (DefaultAppCtsR (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) a b)
  type ApplicativeCtsL (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) a b =
        (DefaultAppCtsL (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) a b)
  Reader.ReaderT mf <*> Reader.ReaderT ma  = Reader.ReaderT $ \r -> mf r <*> ma r
  (<*) = defaultAppL
  (*>) = defaultAppR
  {-# INLINE (<*>) #-}

instance (Bind m n p) => Applicative (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) where
  type ApplicativeCts (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) a b =
        ( BindCts m n p (a -> b, s) (b, s)
        , FunctorCts n (a, s) (b, s) )
  type ApplicativeCtsR (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) a b =
        (DefaultAppCtsR (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) a b)
  type ApplicativeCtsL (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) a b =
        (DefaultAppCtsL (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) a b)
  StateL.StateT mf <*> StateL.StateT ma = StateL.StateT $ \s -> mf s >>= \ ~(f, s') -> fmap (\ ~(a, s'') -> (f a, s'')) (ma s')
  (<*) = defaultAppL
  (*>) = defaultAppR
  {-# INLINE (<*>) #-}

instance (Bind m n p) => Applicative (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) where
  type ApplicativeCts (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) a b =
        ( BindCts m n p (a -> b, s) (b, s)
        , FunctorCts n (a, s) (b, s) )
  type ApplicativeCtsR (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) a b =
        (DefaultAppCtsR (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) a b)
  type ApplicativeCtsL (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) a b =
        (DefaultAppCtsL (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) a b)
  StateS.StateT mf <*> StateS.StateT ma = StateS.StateT $ \s -> mf s >>= \ (f, s') -> fmap (\ (a, s'') -> (f a, s'')) (ma s')
  (<*) = defaultAppL
  (*>) = defaultAppR
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Applicative m n p) => Applicative (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) where
  type ApplicativeCts (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) a b =
        ( ApplicativeCts m n p (a, w) (b, w)
        , FunctorCts m (a -> b, w) ((a, w) -> (b, w)) )
  type ApplicativeCtsR (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) a b =
        (DefaultAppCtsR (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) a b)
  type ApplicativeCtsL (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) a b =
        (DefaultAppCtsL (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) a b)
  WriterL.WriterT mf <*> WriterL.WriterT ma = WriterL.WriterT $ fmap (\ ~(f, w) ~(a, w') -> (f a, P.mappend w w')) mf <*> ma
  (<*) = defaultAppL
  (*>) = defaultAppR
  {-# INLINE (<*>) #-}

instance (P.Monoid w, Applicative m n p) => Applicative (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) where
  type ApplicativeCts (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) a b =
        ( ApplicativeCts m n p (a, w) (b, w)
        , FunctorCts m (a -> b, w) ((a, w) -> (b, w)) )
  type ApplicativeCtsR (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) a b =
        (DefaultAppCtsR (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) a b)
  type ApplicativeCtsL (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) a b =
        (DefaultAppCtsL (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) a b)
  WriterS.WriterT mf <*> WriterS.WriterT ma = WriterS.WriterT $ fmap (\ (f, w) (a, w') -> (f a, P.mappend w w')) mf <*> ma
  (<*) = defaultAppL
  (*>) = defaultAppR
  {-# INLINE (<*>) #-}

-- -----------------------------------------------------------------------------
-- Supermonad Type Class
-- -----------------------------------------------------------------------------

infixl 1  >>, >>=

-- | See @Control.Supermonad.@'Control.Supermonad.Bind' for details on laws and requirements.
class (Functor m, Functor n, Functor p) => Bind m n p where
  type BindCts m n p (a :: *) (b :: *) :: Constraint
  type BindCts m n p a b = ()
  (>>=) :: (BindCts m n p a b) => m a -> (a -> n b) -> p b
  (>>)  :: (BindCts m n p a b) => m a -> n b -> p b
  ma >> mb = ma >>= const mb

instance Bind ((->) r) ((->) r) ((->) r) where
  (>>=) = (P.>>=)
instance Bind Identity Identity Identity where
  (>>=) = (P.>>=)
instance Bind [] [] [] where
  (>>=) = (P.>>=)
instance Bind P.Maybe P.Maybe P.Maybe where
  (>>=) = (P.>>=)
instance Bind P.IO P.IO P.IO where
  (>>=) = (P.>>=)
instance Bind (P.Either e) (P.Either e) (P.Either e) where
  (>>=) = (P.>>=)

instance Bind Mon.First Mon.First Mon.First where
  (>>=) = (P.>>=)
instance Bind Mon.Last Mon.Last Mon.Last where
  (>>=) = (P.>>=)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Mon.Sum Mon.Sum Mon.Sum where
  (>>=) = (P.>>=)
instance Bind Mon.Product Mon.Product Mon.Product where
  (>>=) = (P.>>=)
instance Bind Mon.Dual Mon.Dual Mon.Dual where
  (>>=) = (P.>>=)
#endif
instance (Bind f g h) => Bind (Mon.Alt f) (Mon.Alt g) (Mon.Alt h) where
  type BindCts (Mon.Alt f) (Mon.Alt g) (Mon.Alt h) a b = BindCts f g h a b
  (Mon.Alt m) >>= f = Mon.Alt $ m >>= (Mon.getAlt . f)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Semigroup.Min Semigroup.Min Semigroup.Min where
  (>>=) = (P.>>=)
instance Bind Semigroup.Max Semigroup.Max Semigroup.Max where
  (>>=) = (P.>>=)
instance Bind Semigroup.Option Semigroup.Option Semigroup.Option where
  (>>=) = (P.>>=)
instance Bind Semigroup.First Semigroup.First Semigroup.First where
  (>>=) = (P.>>=)
instance Bind Semigroup.Last Semigroup.Last Semigroup.Last where
  (>>=) = (P.>>=)
#endif

instance Bind Proxy.Proxy Proxy.Proxy Proxy.Proxy where
  (>>=) = (P.>>=)
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Complex.Complex Complex.Complex Complex.Complex where
  (>>=) = (P.>>=)
instance Bind NonEmpty.NonEmpty NonEmpty.NonEmpty NonEmpty.NonEmpty where
  (>>=) = (P.>>=)
#endif
instance (Bind m1 n1 p1, Bind m2 n2 p2) => Bind (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) where
  type BindCts (Product.Product m1 m2) (Product.Product n1 n2) (Product.Product p1 p2) a b = (BindCts m1 n1 p1 a b, BindCts m2 n2 p2 a b)
  Product.Pair m1 m2 >>= f = Product.Pair (m1 >>= (fstP . f)) (m2 >>= (sndP . f))
    where fstP (Product.Pair a _) = a
          sndP (Product.Pair _ b) = b

instance Bind Read.ReadP Read.ReadP Read.ReadP where
  (>>=) = (P.>>=)
instance Bind Read.ReadPrec Read.ReadPrec Read.ReadPrec where
  (>>=) = (P.>>=)

instance Bind (ST.ST s) (ST.ST s) (ST.ST s) where
  (>>=) = (P.>>=)
instance Bind (STL.ST s) (STL.ST s) (STL.ST s) where
  (>>=) = (P.>>=)
instance (Arrow.ArrowApply a) => Bind (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) (Arrow.ArrowMonad a) where
  (>>=) = (P.>>=)
instance (Bind m n p) => Bind (App.WrappedMonad m) (App.WrappedMonad n) (App.WrappedMonad p) where
  type BindCts (App.WrappedMonad m) (App.WrappedMonad n) (App.WrappedMonad p) a b = BindCts m n p a b
  m >>= f = App.WrapMonad $ (App.unwrapMonad m) >>= (App.unwrapMonad . f)

instance Bind STM.STM STM.STM STM.STM where
  (>>=) = (P.>>=)

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Bind Generics.U1 Generics.U1 Generics.U1 where
  (>>=) = (P.>>=)
instance (Bind m n p) => Bind (Generics.Rec1 m) (Generics.Rec1 n) (Generics.Rec1 p) where
  type BindCts (Generics.Rec1 m) (Generics.Rec1 n) (Generics.Rec1 p) a b = BindCts m n p a b
  (Generics.Rec1 mf) >>= f = Generics.Rec1 $ mf >>= (Generics.unRec1 . f)
instance (Bind f g h, Bind f' g' h') => Bind (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') where
  type BindCts (f Generics.:*: f') (g Generics.:*: g') (h Generics.:*: h') a b = (BindCts f g h a b, BindCts f' g' h' a b)
  (f Generics.:*: g) >>= m = (f >>= \a -> let (f' Generics.:*: _g') = m a in f') Generics.:*: (g >>= \a -> let (_f' Generics.:*: g') = m a in g')
instance Bind f g h => Bind (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) where
  type BindCts  (Generics.M1 i c f) (Generics.M1 i c g) (Generics.M1 i c h) a b = BindCts  f g h a b
  (Generics.M1 ma) >>= f = Generics.M1 $ ma >>= Generics.unM1 . f
#endif

-- Constrained Instances -------------------------------------------------------

instance Bind S.Set S.Set S.Set where
  type BindCts S.Set S.Set S.Set a b = Ord b
  s >>= f = S.foldr S.union S.empty $ S.map f s

-- "transformers" package instances: -------------------------------------------

-- Continuations are so wierd...
-- | TODO / FIXME: Still need to figure out how and if we can generalize the continuation implementation.
instance {- (Bind m n p) => -} Bind (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) where
  type BindCts (Cont.ContT r m) (Cont.ContT r m) (Cont.ContT r m) a b = () -- (BindCts m n p)
  m >>= k = Cont.ContT $ \ c -> Cont.runContT m (\ x -> Cont.runContT (k x) c)
  {-# INLINE (>>=) #-}

instance (Bind m n p, Return n) => Bind (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) where
  type BindCts (Except.ExceptT e m) (Except.ExceptT e n) (Except.ExceptT e p) a b = (BindCts m n p (P.Either e a) (P.Either e b), ReturnCts n (P.Either e b))
  m >>= k = Except.ExceptT $
      Except.runExceptT m >>=
      \ a -> case a of
          P.Left e -> return (P.Left e)
          P.Right x -> Except.runExceptT (k x)
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) where
  type BindCts (Identity.IdentityT m) (Identity.IdentityT n) (Identity.IdentityT p) a b = (BindCts m n p a b)
  m >>= k = Identity.IdentityT $ Identity.runIdentityT m >>= (Identity.runIdentityT . k)
  {-# INLINE (>>=) #-}

instance (Return n, Bind m n p) => Bind (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) where
  type BindCts (Maybe.MaybeT m) (Maybe.MaybeT n) (Maybe.MaybeT p) a b = (ReturnCts n (P.Maybe b), BindCts m n p (P.Maybe a) (P.Maybe b))
  x >>= f = Maybe.MaybeT $
    Maybe.runMaybeT x >>=
    \v -> case v of
      P.Nothing -> return P.Nothing
      P.Just y  -> Maybe.runMaybeT (f y)
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) where
  type BindCts (RWSL.RWST r w s m) (RWSL.RWST r w s n) (RWSL.RWST r w s p) a b = (BindCts m n p (a, s, w) (b, s, w), FunctorCts n (b, s, w) (b, s, w))
  m >>= k  = RWSL.RWST $
    \ r s -> RWSL.runRWST m r s >>=
    \ ~(a, s', w) -> fmap (\ ~(b, s'',w') -> (b, s'', w `P.mappend` w')) $ RWSL.runRWST (k a) r s'
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) where
  type BindCts (RWSS.RWST r w s m) (RWSS.RWST r w s n) (RWSS.RWST r w s p) a b = (BindCts m n p (a, s, w) (b, s, w), FunctorCts n (b, s, w) (b, s, w))
  m >>= k  = RWSS.RWST $
    \ r s -> RWSS.runRWST m r s >>=
    \ (a, s', w) -> fmap (\(b, s'',w') -> (b, s'', w `P.mappend` w')) $ RWSS.runRWST (k a) r s'
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) where
  type BindCts (Reader.ReaderT r m) (Reader.ReaderT r n) (Reader.ReaderT r p) a b = (BindCts m n p a b)
  m >>= k  = Reader.ReaderT $
      \ r -> Reader.runReaderT m r >>=
      \ a -> Reader.runReaderT (k a) r
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) where
  type BindCts (StateL.StateT s m) (StateL.StateT s n) (StateL.StateT s p) a b = (BindCts m n p (a, s) (b, s))
  m >>= k = StateL.StateT
          $ \ s -> StateL.runStateT m s >>=
            \ ~(a, s') -> StateL.runStateT (k a) s'
  {-# INLINE (>>=) #-}

instance (Bind m n p) => Bind (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) where
  type BindCts (StateS.StateT s m) (StateS.StateT s n) (StateS.StateT s p) a b = (BindCts m n p (a, s) (b, s))
  m >>= k = StateS.StateT
          $ \ s -> StateS.runStateT m s >>=
            \ (a, s') -> StateS.runStateT (k a) s'
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) where
  type BindCts (WriterL.WriterT w m) (WriterL.WriterT w n) (WriterL.WriterT w p) a b = (BindCts m n p (a, w) (b, w), FunctorCts n (b, w) (b, w))
  m >>= k  = WriterL.WriterT $
      WriterL.runWriterT m >>=
      \ ~(a, w) -> fmap (\ ~(b, w') -> (b, w `P.mappend` w')) $ WriterL.runWriterT (k a)
  {-# INLINE (>>=) #-}

instance (P.Monoid w, Bind m n p) => Bind (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) where
  type BindCts (WriterS.WriterT w m) (WriterS.WriterT w n) (WriterS.WriterT w p) a b = (BindCts m n p (a, w) (b, w), FunctorCts n (b, w) (b, w))
  m >>= k  = WriterS.WriterT $
      WriterS.runWriterT m >>=
      \ (a, w) -> fmap (\ (b, w') -> (b, w `P.mappend` w')) $ WriterS.runWriterT (k a)
  {-# INLINE (>>=) #-}

-- -----------------------------------------------------------------------------
-- Return Type Class
-- -----------------------------------------------------------------------------

-- | See 'Bind' for details on laws and requirements.
class (Functor m) => Return m where
  type ReturnCts m (a :: *) :: Constraint
  type ReturnCts m a = ()
  return :: (ReturnCts m a) => a -> m a

instance Return ((->) r) where
  return = P.return
instance Return Identity where
  return = P.return
instance Return [] where
  return = P.return
instance Return P.Maybe where
  return = P.return
instance Return P.IO where
  return = P.return
instance Return (P.Either e) where
  return = P.return

instance Return Mon.First where
  return = P.return
instance Return Mon.Last where
  return = P.return
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Mon.Sum where
  return = P.return
instance Return Mon.Product where
  return = P.return
instance Return Mon.Dual where
  return = P.return
#endif
instance (Return m) => Return (Mon.Alt m) where
  type ReturnCts (Mon.Alt m) a = ReturnCts m a
  return a = Mon.Alt $ return a

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Semigroup.Min where
  return = P.return
instance Return Semigroup.Max where
  return = P.return
instance Return Semigroup.Option where
  return = P.return
instance Return Semigroup.First where
  return = P.return
instance Return Semigroup.Last where
  return = P.return
#endif

instance Return Proxy.Proxy where
  return = P.return
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Complex.Complex where
  return = P.return
instance Return NonEmpty.NonEmpty where
  return = P.return
#endif

instance (Return m1, Return m2) => Return (Product.Product m1 m2) where
  type ReturnCts (Product.Product m1 m2) a = (ReturnCts m1 a, ReturnCts m2 a)
  return a = Product.Pair (return a) (return a)

instance (Return f, Return f') => Return (Compose.Compose f f') where
  type ReturnCts (Compose.Compose f f') a = (ReturnCts f (f' a), ReturnCts f' a)
  return = Compose.Compose . return . return

instance Return Read.ReadP where
  return = P.return
instance Return Read.ReadPrec where
  return = P.return

instance Return (ST.ST s) where
  return = P.return
instance Return (STL.ST s) where
  return = P.return
instance (Arrow.ArrowApply a) => Return (Arrow.ArrowMonad a) where
  return = P.return
instance (Return m) => Return (App.WrappedMonad m) where
  type ReturnCts (App.WrappedMonad m) a = ReturnCts m a
  return a = App.WrapMonad $ return a

instance Return STM.STM where
  return = P.return

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Return Generics.U1 where
  return = P.return
instance (Return m) => Return (Generics.Rec1 m) where
  type ReturnCts (Generics.Rec1 m) a = ReturnCts m a
  return = Generics.Rec1 . return
instance (Return f, Return g) => Return (f Generics.:*: g) where
  type ReturnCts (f Generics.:*: g) a = (ReturnCts f a, ReturnCts g a)
  return a = return a Generics.:*: return a
instance (Return f, Return g) => Return (f Generics.:.: g) where
  type ReturnCts (f Generics.:.: g) a = (ReturnCts f (g a), ReturnCts g a)
  return a = Generics.Comp1 $ return (return a)
instance Return f => Return (Generics.M1 i c f) where
  type ReturnCts (Generics.M1 i c f) a = ReturnCts f a
  return = Generics.M1 . return
#endif

-- Constrained Instances -------------------------------------------------------

instance Return S.Set where
  return = S.singleton

-- "transformers" package instances: -------------------------------------------

-- Continuations are so weird...
instance {- (Return m) => -} Return (Cont.ContT r m) where
  type ReturnCts (Cont.ContT r m) a = () -- ReturnCts m
  return x = Cont.ContT ($ x)
  {-# INLINE return #-}

instance (Return m) => Return (Except.ExceptT e m) where
  type ReturnCts (Except.ExceptT e m) a = ReturnCts m (P.Either e a)
  return = Except.ExceptT . return . P.Right
  {-# INLINE return #-}

instance (Return m) => Return (Identity.IdentityT m) where
  type ReturnCts (Identity.IdentityT m) a = ReturnCts m a
  return = (Identity.IdentityT) . return
  {-# INLINE return #-}

instance (Return m) => Return (Maybe.MaybeT m) where
  type ReturnCts (Maybe.MaybeT m) a = ReturnCts m (P.Maybe a)
  return = Maybe.MaybeT . return . P.Just
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (RWSL.RWST r w s m) where
  type ReturnCts (RWSL.RWST r w s m) a = ReturnCts m (a, s, w)
  return a = RWSL.RWST $ \ _ s -> return (a, s, P.mempty)
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (RWSS.RWST r w s m) where
  type ReturnCts (RWSS.RWST r w s m) a = ReturnCts m (a, s, w)
  return a = RWSS.RWST $ \ _ s -> return (a, s, P.mempty)
  {-# INLINE return #-}

instance (Return m) => Return (Reader.ReaderT r m) where
  type ReturnCts (Reader.ReaderT r m) a = ReturnCts m a
  return = Reader.ReaderT . const . return
  {-# INLINE return #-}

instance (Return m) => Return (StateL.StateT s m) where
  type ReturnCts (StateL.StateT s m) a = ReturnCts m (a, s)
  return x = StateL.StateT $ \s -> return (x, s)
  {-# INLINE return #-}

instance (Return m) => Return (StateS.StateT s m) where
  type ReturnCts (StateS.StateT s m) a = ReturnCts m (a, s)
  return x = StateS.StateT $ \s -> return (x, s)
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (WriterL.WriterT w m) where
  type ReturnCts (WriterL.WriterT w m) a = ReturnCts m (a, w)
  return a = WriterL.WriterT $ return (a, P.mempty)
  {-# INLINE return #-}

instance (P.Monoid w, Return m) => Return (WriterS.WriterT w m) where
  type ReturnCts (WriterS.WriterT w m) a = ReturnCts m (a, w)
  return a = WriterS.WriterT $ return (a, P.mempty)
  {-# INLINE return #-}

-- -----------------------------------------------------------------------------
-- Fail Type Class
-- -----------------------------------------------------------------------------

-- | See 'Bind' for details on laws and requirements.
class Fail m where
  type FailCts m (a :: *) :: Constraint
  type FailCts m a = ()
  fail :: (FailCts m a) => String -> m a

instance Fail ((->) r) where
  fail = P.fail
instance Fail Identity where
  fail = P.fail
instance Fail [] where
  fail = P.fail
instance Fail P.Maybe where
  fail = P.fail
instance Fail P.IO where
  fail = P.fail
instance Fail (P.Either e) where
  fail = P.fail

instance Fail Mon.First where
  fail = P.fail
instance Fail Mon.Last where
  fail = P.fail
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Mon.Sum where
  fail = P.fail
instance Fail Mon.Product where
  fail = P.fail
instance Fail Mon.Dual where
  fail = P.fail
#endif
instance (Fail m) => Fail (Mon.Alt m) where
  type FailCts (Mon.Alt m) a = FailCts m a
  fail a = Mon.Alt $ fail a

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Semigroup.Min where
  fail = P.fail
instance Fail Semigroup.Max where
  fail = P.fail
instance Fail Semigroup.Option where
  fail = P.fail
instance Fail Semigroup.First where
  fail = P.fail
instance Fail Semigroup.Last where
  fail = P.fail
#endif

instance Fail Proxy.Proxy where
  fail = P.fail
#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Complex.Complex where
  fail = P.fail
instance Fail NonEmpty.NonEmpty where
  fail = P.fail
#endif
instance (Fail m1, Fail m2) => Fail (Product.Product m1 m2) where
  type FailCts (Product.Product m1 m2) a = (FailCts m1 a, FailCts m2 a)
  fail a = Product.Pair (fail a) (fail a)

instance Fail Read.ReadP where
  fail = P.fail
instance Fail Read.ReadPrec where
  fail = P.fail

instance Fail (ST.ST s) where
  fail = P.fail
instance Fail (STL.ST s) where
  fail = P.fail
instance (Arrow.ArrowApply a) => Fail (Arrow.ArrowMonad a) where
  fail = P.fail
instance (Fail m) => Fail (App.WrappedMonad m) where
  type FailCts (App.WrappedMonad m) a = FailCts m a
  fail a = App.WrapMonad $ fail a

instance Fail STM.STM where
  fail = P.fail

#if MIN_VERSION_GLASGOW_HASKELL(8,0,0,0)
instance Fail Generics.U1 where
  fail = P.fail
instance (Fail m) => Fail (Generics.Rec1 m) where
  type FailCts (Generics.Rec1 m) a = FailCts m a
  fail = Generics.Rec1 . fail
instance (Fail f, Fail g) => Fail (f Generics.:*: g) where
  type FailCts (f Generics.:*: g) a = (FailCts f a, FailCts g a)
  fail a = fail a Generics.:*: fail a
instance Fail f => Fail (Generics.M1 i c f) where
  type FailCts (Generics.M1 i c f) a = FailCts f a
  fail = Generics.M1 . fail
#endif

-- Constrained Instances -------------------------------------------------------

instance Fail S.Set where
  fail _ = S.empty

-- "transformers" package instances: -------------------------------------------

instance (Fail m) => Fail (Cont.ContT r m) where
  type FailCts (Cont.ContT r m) a = (FailCts m r)
  fail = (Cont.ContT) . const . fail
  {-# INLINE fail #-}

-- Requires 'UndecidableInstances'.
instance (Fail m) => Fail (Except.ExceptT e m) where
  type FailCts (Except.ExceptT e m) a = (FailCts m (P.Either e a))
  fail = Except.ExceptT . fail
  {-# INLINE fail #-}

instance (Fail m) => Fail (Identity.IdentityT m) where
  type FailCts (Identity.IdentityT m) a = (FailCts m a)
  fail msg = Identity.IdentityT $ fail msg
  {-# INLINE fail #-}

-- Requires 'UndecidableInstances'.
instance (Return m) => Fail (Maybe.MaybeT m) where
  type FailCts (Maybe.MaybeT m) a = (ReturnCts m (P.Maybe a))
  fail _ = Maybe.MaybeT (return P.Nothing)
  {-# INLINE fail #-}

instance (P.Monoid w, Fail m) => Fail (RWSL.RWST r w s m) where
  type FailCts (RWSL.RWST r w s m) a = (FailCts m (a, s, w))
  fail msg = RWSL.RWST $ \ _ _ -> fail msg
  {-# INLINE fail #-}

instance (P.Monoid w, Fail m) => Fail (RWSS.RWST r w s m) where
  type FailCts (RWSS.RWST r w s m) a = (FailCts m (a, s, w))
  fail msg = RWSS.RWST $ \ _ _ -> fail msg
  {-# INLINE fail #-}

instance (Fail m) => Fail (Reader.ReaderT r m) where
  type FailCts (Reader.ReaderT r m) a = (FailCts m a)
  fail = Reader.ReaderT . const . fail
  {-# INLINE fail #-}

-- Requires 'UndecidableInstances'.
instance (Fail m) => Fail (StateL.StateT s m) where
  type FailCts (StateL.StateT s m) a = (FailCts m (a, s))
  fail = StateL.StateT . const . fail
  {-# INLINE fail #-}

-- Requires 'UndecidableInstances'.
instance (Fail m) => Fail (StateS.StateT s m) where
  type FailCts (StateS.StateT s m) a = (FailCts m (a, s))
  fail = StateS.StateT . const . fail
  {-# INLINE fail #-}

-- Requires 'UndecidableInstances'.
instance (P.Monoid w, Fail m) => Fail (WriterL.WriterT w m) where
  type FailCts (WriterL.WriterT w m) a = (FailCts m (a, w))
  fail msg = WriterL.WriterT $ fail msg
  {-# INLINE fail #-}

-- Requires 'UndecidableInstances'.
instance (P.Monoid w, Fail m) => Fail (WriterS.WriterT w m) where
  type FailCts (WriterS.WriterT w m) a = (FailCts m (a, w))
  fail msg = WriterS.WriterT $ fail msg
  {-# INLINE fail #-}

-- -----------------------------------------------------------------------------
-- Convenient type synonyms
-- -----------------------------------------------------------------------------

-- | A short-hand for writing polymorphic standard monad functions.
type family Monad m :: Constraint where
  Monad m = (Bind m m m, Return m, Fail m)


module CreateTerrain
where

import Data.Maybe
import Control.Monad.State
import System.Random

import Galaxy
import Math
import CreateGalaxy
import DataFunction
import Utils
import Statistics
import Good
import Terrain

nearsystems :: [String]
nearsystems = ["Alpha Centauri",
               "Barnard's Star",
               "Wolf 359",
               "Lalande 21185",
               "Sirius",
               "Lyuten 726-8",
               "Ross 154",
               "Ross 248",
               "Epsilon Eridani",
               "Lacaille 9352",
               "Ross 128",
               "EZ Aquarii",
               "Procyon",
               "61 Cygni",
               "Tau Ceti",
               "Fomalhaut",
               "Struve 2398",
               "Groombridge 34",
               "Epsilon Indi",
               "DX Cancri",
               "GJ 1061",
               "YZ Ceti",
               "Lyuten's Star",
               "Kapteyn's Star"
              ]

testGalaxy :: Galaxy Terrain
testGalaxy = testRandomGalaxy 20 16

testRandomGalaxy :: Int -> Int -> Galaxy Terrain
testRandomGalaxy v numsys =
  let r = mkStdGen v
  in evalState (createGalaxy (createTerrain stdGoods) "milky way" (take numsys $ nearsystems ++ map show [1..numsys])) r

createTerrain :: [Good] -> Planet () -> Rnd Terrain
createTerrain gs p =
  case planettype p of
    Planetoid         -> createRockyTerrain gs p
    NoAtmosphere      -> createRockyTerrain gs p
    RockyPlanet _     -> createRockyTerrain gs p
    SmallGasGiant     -> return (Terrain [] [])
    MediumGasGiant    -> return (Terrain [] [])
    LargeGasGiant     -> return (Terrain [] [])
    VeryLargeGasGiant -> return (Terrain [] [])

createRockyTerrain :: [Good] -> Planet () -> Rnd Terrain
createRockyTerrain gs p = do
  massmult <- randomRM (0, 1000 * planetMass p)
  gs' <- mapMaybeM (createNaturalGood massmult (planettype p)) gs
  return (Terrain gs' [])

createNaturalGood :: Flt -> PlanetType -> Good -> Rnd (Maybe (Resource, ResourceUnit))
createNaturalGood massmult pt g =
  case natural g of
    Nothing                       -> return Nothing
    Just (Natural atms _ initial) -> do
      let atmNeeded = not $ null atms
      let invAtm = if not atmNeeded
                     then False
                     else case pt of
                       RockyPlanet a -> a `notElem` atms
                       _             -> True
      if invAtm
        then return Nothing
        else do
          mult <- randomRM (0, initial)
          let v = floor $ mult * massmult
          return $ Just ((g, v), v)


module Fractal.Control.Controller(
  ApplicationType (UI_Application, Console_Application),
  mandelApplication,
  getApplicationType
)where

import  System.IO (BufferMode (NoBuffering), hSetBuffering, stdout)
import qualified Fractal.Parallel.Evaluator as P
import qualified Fractal.Gui.FractalWindow as W
import qualified Fractal.Utils.Field as F
import Fractal.Math.Mandelbrot (mandel, mandel')
import Data.Complex
import Fractal.Plot.Plotter (imageFractal)
import Data.DateTime

data ApplicationType = UI_Application | Console_Application | None | Empty
  deriving (Show, Eq)

type Point = Complex Double

mandelApplication :: ApplicationType -> IO ()
mandelApplication appType = case appType of
  UI_Application        -> uiApplication
  Console_Application   -> consoleApplication
  Empty                 -> readApplicationTypeFromInput
  None                  -> error "Cant use"

getApplicationType :: [String] -> ApplicationType
getApplicationType [] = Empty
getApplicationType (x:_) = case x of
  "UI_Application"      -> UI_Application
  "Console_Application" -> Console_Application
  _                     -> Empty

readApplicationTypeFromInput :: IO ()
readApplicationTypeFromInput = do
  hSetBuffering stdout NoBuffering
  putStr "Provide application type (UI_Application or Console_Application): "
  applicationType <- getLine
  let appType = getApplicationType [applicationType]
  if appType == Empty then mandelApplication None else mandelApplication appType

consoleApplication :: IO ()
consoleApplication = do
  putStrLn "Running in console mode..."
  input <- consoleReadInput
  coreComputation input
  return ()

coreComputation :: (Double, Int, Double, Point, Point, String) -> IO ()
coreComputation (limit, maxIter, stepSize, sPoint, ePoint, strat) = do
  --let field   = F.generateField sPoint ePoint stepSize
  --let field'  = concat field
  let field'  = F.generateRowField sPoint ePoint stepSize
  let res     = P.mandelEval (P.stringToStrat strat) (mandel' maxIter limit) field'
  let len     = F.getFieldLength sPoint ePoint stepSize
  dateTime    <- getCurrentTime
  let (year, month, day) = toGregorian' dateTime
  imageFractal len res ("./Mandel_" ++ (show year) ++ "_" ++ (show month) ++ "_" ++ (show day) ++ "_" ++ (show $ toSeconds dateTime))
  putStrLn "Image created!"
  return ()

uiApplication :: IO ()
uiApplication = do
  putStrLn "Running in ui mode"
  W.mainW coreComputation
  return ()

consoleReadInput :: IO (Double, Int, Double, Point, Point, String)
consoleReadInput = do
  hSetBuffering stdout NoBuffering
  putStr "Type in recursive limit: "
  fractalLimit <- getLine
  let limit = (read fractalLimit) :: Double
  putStr "Type in max number of iterations: "
  maxIter <- getLine
  let maxIt = (read maxIter) :: Int
  putStr "Type in stepsize: "
  stepSize <- getLine
  let step = (read stepSize) :: Double
  putStr "Type in starting point: "
  startPoint <- getLine
  let startP = (read startPoint) :: Point
  putStr "Type in end point: "
  endPoint <- getLine
  let endP = (read endPoint) :: Point
  putStr "Type in evaluation strategie: "
  evalStrat <- getLine
  return (limit, maxIt, step, startP, endP, evalStrat)


-- This program is intentionally poorly documented; fixing the
-- documentation and actually creating the program are left as exercises
-- for the reader.

import qualified Data.List as DL;
import qualified Data.Function as DF;
import qualified Numeric.FFT as FT;
import Data.Complex;

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

windowSize :: Int;
windowSize = 65536;

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

type Giraffe = [(Int, Pitch)];  -- LIST OF GRAPH COORDINATES
type Pitch = Double;
type Sample = Double;
type Frequency = Double;
type Multiplier = Double;
type FFTOutput = [Complex Double];
data X11Winda = ExerciseForTheReader;
data WaveType = Sin | Cos;

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

-- | createNewWinda creates a new X11 window and returns the tag of this
-- X11 window.
createNewWinda :: IO X11Winda;
createNewWinda = return ExerciseForTheReader;

fft :: [Sample] -> FFTOutput;
fft = FT.fft . map cis;

-- | For all FFT outputs k, fftToPitch equals the loudest pitch of k.
-- Implementing fftToPitch is left as an exercise for the reader.
-- Shut up and hack!
fftToPitch :: FFTOutput -> Pitch;
fftToPitch k = 0;

-- | readMicData is a stream of microphone samples.
-- Implementing readMicData is left as an exercise for the reader.
-- The author recommends using the SDL library or an operating system-
-- specific approach.
readMicData :: IO [Sample];
readMicData = return $ map (\a -> a * (sin a)) [1.0,1.1..];

-- | For all natural numbers n, readSamp n equals n microphone samples.
readSamp :: Int -> IO [Sample];
readSamp k = readMicData >>= return . take k;

-- | For all [Sample] n, seqToPitch n equals the output of the sequence-
-- to-pitch function on the input n.
seqToPitch :: [Sample] -> Pitch;
seqToPitch = fftToPitch . fft;

-- | genCoords yields the coordinates of the graph.
genCoords :: [Pitch] -> Giraffe;
genCoords x = zip [0..length x - 1] x;

-- | For all X11Winda k, for all Giraffe g, genGraph k g draws
-- g to k, returning the pitch/y values of g.
-- Implementing genGraph is left as an exercise for the reader.
-- The author recommends using Chart or creating a custom library.
genGraph :: X11Winda -> Giraffe -> IO [Pitch];
genGraph w k = putStrLn "TODO: IMPLEMENT GRAPHING." >> return (map snd k);

-- | mane is the main program loop.
mane :: X11Winda -> [Double] -> IO ();
mane w k = readSamp windowSize >>= doTheGraph w >>= loop w
  where
  doTheGraph a b = genGraph a (genCoords $ append k $ seqToPitch b)
  append a b = a ++ [b]
  loop a b = mane a (take 50 b);

-- | main is the program's entry point.  main initialises mane.
main :: IO ();
main = createNewWinda >>= \winda -> mane winda [];


-----------------------------------------------------------------------------
--
-- Module      :  Drool.Utils.RenderHelpers
-- Copyright   :  Tobias Fuchs
-- License     :  AllRightsReserved
--
-- Maintainer  :  twh.fuchs@gmail.com
-- Stability   :  experimental
-- Portability :  POSIX
--
-- |
--
-----------------------------------------------------------------------------

{-# OPTIONS -O2 -Wall #-}

module Drool.Utils.RenderHelpers (
    RenderSettings(..),
    applyGlobalRotation,
    applyPerspective,
    nextPerspective,
    useLight,
    applyBandRangeAmp,
    bandRangeAmpSamples,
    scaleSamples,

    vertexWithNormal,
    vertexWithNormalAndColor,
    normalsFromVertices,
    drawNormal,
    color3AddAlpha,
    color4MulAlpha,
    color3MulValue,
    color4MulValue,

    vertexToVector,
    vx4ToVx3,

    v3x,
    v3y,
    v3z,
    vx3x,
    vx3y,
    vx3z,
    vx4x,
    vx4y,
    vx4z,
    vx4w,

    getViewpointFromModelView,
    featuresToIntensity
) where

import Debug.Trace

-- Imports
-- {{{
import Data.IORef ( IORef )

import Data.Packed.Matrix as HM ( (><), Matrix )
import Numeric.LinearAlgebra.Algorithms as LA ( inv )
import Numeric.Container as NC ( vXm, fromList, toList )

import qualified Drool.Types as DT ( SignalList(..), RenderPerspective(..), RotationVector(..) )
import Drool.Utils.SigGen as SigGen ( SValue, TValue, SignalGenerator(..) )
import Drool.Utils.FeatureExtraction as FE (
    SignalFeatures(..), SignalFeaturesList(..),
    emptyFeatures,
    FeatureTarget(..), featureTargetFromIndex )
import Drool.Utils.Conversions as Conv ( interleaveArrays, aZip )
import Drool.ApplicationContext as AC ( ContextSettings(..), LightConfig(..) )
import Graphics.Rendering.OpenGL (
    Vector3 (..),
    Vertex3 (..),
    Vertex4 (..),
    Normal3 (..),
    Color3(..),
    Color4(..),
    Light(..),
    light,
    VertexComponent,
    renderPrimitive,
    PrimitiveMode(..),
    vertex, normal,
    color,
    materialEmission,
    materialAmbient,
    materialDiffuse,
    materialSpecular,
    materialShininess,
    translate,
    MatrixOrder(..),
    getMatrixComponents,
    GLmatrix,
    ($=),
    Face(..),
    Capability(..),
    polygonOffsetFill,
    polygonOffsetLine,
    ambient,
    diffuse,
    specular,
    rotate,
    translate,
    GLfloat )
import qualified Graphics.Rendering.FTGL as FTGL
import qualified Control.Concurrent.MVar as MV ( MVar )
import qualified Control.Concurrent.Chan as CC
-- }}}

-- Settings rendering independent from visual used:
data RenderSettings = RenderSettings { signalGenerator :: SignalGenerator,
                                       samplingSem :: MV.MVar Int,
                                       renderingSem :: MV.MVar Int,
                                       numNewSignalsChan :: CC.Chan Int,
                                       -- IORef to signal buffer:
                                       signalBuf :: IORef DT.SignalList,
                                       -- Position of light 0
                                       lightPos0 :: Vertex4 GLfloat,
                                       -- Position of light 1
                                       lightPos1 :: Vertex4 GLfloat,
                                       -- Containing one SignalFeatures component for every signal:
                                       featuresBuf :: IORef (FE.SignalFeaturesList),
                                       -- Current number of signals in signal buffer:
                                       numSignals :: Int,
                                       -- Number of samples in most recent signal:
                                       numSamples :: Int,
                                       -- Number of new signals since last render pass:
                                       numNewSignals :: Int,
                                       -- Whether to reverse the signal buffer:
                                       reverseBuffer :: Bool,
                                       -- Tick of rendering pass:
                                       tick :: Int }

applyPerspective :: DT.RenderPerspective -> IO ()
applyPerspective p = do
  case p of
    DT.Isometric -> do
      rotate (45::GLfloat) $ Vector3 1.0 0.0 0.0
      rotate (45::GLfloat) $ Vector3 0.0 1.0 0.0
    DT.Top -> do
      rotate (90::GLfloat) $ Vector3 1.0 0.0 0.0
    DT.Front -> do
      rotate (20.0::GLfloat) $ Vector3 1.0 0.0 0.0
    DT.Side -> do
      rotate (20.0::GLfloat) $ Vector3 1.0 0.0 0.0
      rotate (-90::GLfloat) $ Vector3 0.0 1.0 0.0

applyGlobalRotation :: DT.RotationVector -> DT.RotationVector -> IO ()
applyGlobalRotation fixedRotation incRotation = do
  rotate (DT.rotX fixedRotation) $ Vector3 1.0 0.0 0.0
  rotate (DT.rotX incRotation)   $ Vector3 1.0 0.0 0.0
  rotate (DT.rotY fixedRotation) $ Vector3 0.0 1.0 0.0
  rotate (DT.rotY incRotation)   $ Vector3 0.0 1.0 0.0
  rotate (DT.rotZ fixedRotation) $ Vector3 0.0 0.0 1.0
  rotate (DT.rotZ incRotation)   $ Vector3 0.0 0.0 1.0

nextPerspective :: DT.RenderPerspective -> DT.RenderPerspective
nextPerspective cur = case cur of
  DT.Isometric -> DT.Top
  DT.Top       -> DT.Front
  DT.Front     -> DT.Side
  DT.Side      -> DT.Isometric

useLight :: AC.LightConfig -> IO ()
useLight lightConfig = do
  let lightState = AC.lightState lightConfig
  let lightIdx   = fromIntegral $ AC.lightIndex lightConfig
  light (Light lightIdx) $= lightState
  let lighting state =
        if state == Enabled then do
          let intensity = AC.lightIntensity lightConfig
          ambient  (Light lightIdx) $= color4MulValue (AC.lightAmbient  lightConfig) intensity
          diffuse  (Light lightIdx) $= color4MulValue (AC.lightDiffuse  lightConfig) intensity
          specular (Light lightIdx) $= color4MulValue (AC.lightSpecular lightConfig) intensity
        else
          return ()
  lighting lightState

-- Expects a sample, t, number of samples in total, list of band range amplifiers, and returns amplified sample for t.
applyBandRangeAmp :: SValue -> TValue -> Int -> [Float] -> SValue
-- {{{
applyBandRangeAmp s t nSamples amps = s * ampValue
  where numRanges      = length amps
        rangeWidth     = nSamples `div` numRanges                            -- ...[-------]...
        rangePos       = t `mod` rangeWidth                                  -- ...|....x..|...
        activeRangeIdx = max 0 $ ((fromIntegral t)-rangePos) `div` rangeWidth :: Int -- [.|x|.|.|.]
        -- Amp value of active range
        amp_1          = if length amps > activeRangeIdx then realToFrac $ amps !! activeRangeIdx else 1.0
        -- Amp value of next range, use range n as next range of range n
        nextRangeIdx   = max 0 $ min (activeRangeIdx+1) (numRanges-1)
        amp_2          = if length amps > nextRangeIdx then realToFrac $ amps !! nextRangeIdx else 1.0
        ampValue       = amp_1 + ((amp_2-amp_1) * (fromIntegral (rangePos) / fromIntegral (rangeWidth-1)))
-- }}}

bandRangeAmpSamples :: [SValue] -> [Float] -> [SValue]
bandRangeAmpSamples samples amps = bandRangeAmpSamplesRec samples amps (length samples) 0

bandRangeAmpSamplesRec :: [SValue] -> [Float] -> Int -> TValue -> [SValue]
bandRangeAmpSamplesRec (x:xs) amps nSamples t = ampSample : (bandRangeAmpSamplesRec xs amps nSamples (t+1))
  where ampSample = (applyBandRangeAmp x t nSamples amps)
bandRangeAmpSamplesRec [] _ _ _ = []

scaleSamples :: (Fractional a) => [a] -> a -> [a]
scaleSamples samples a = map ( \s -> s * a ) samples

-- {{{

-- Resolve x component of a 3-dimensional Vector
v3x :: Vector3 a -> a
v3x (Vector3 x _ _) = x
-- Resolve y component of a 3-dimensional Vector
v3y :: Vector3 a -> a
v3y (Vector3 _ y _) = y
-- Resolve z component of a 3-dimensional Vector
v3z :: Vector3 a -> a
v3z (Vector3 _ _ z) = z

-- Resolve x component of a 3-dimensional Vertex
vx3x :: Vertex3 a -> a
vx3x (Vertex3 x _ _) = x
-- Resolve y component of a 3-dimensional Vertex
vx3y :: Vertex3 a -> a
vx3y (Vertex3 _ y _) = y
-- Resolve z component of a 3-dimensional Vertex
vx3z :: Vertex3 a -> a
vx3z (Vertex3 _ _ z) = z

-- Resolve x component of a 4-dimensional Vertex
vx4x :: Vertex4 a -> a
vx4x (Vertex4 x _ _ _) = x
-- Resolve y component of a 4-dimensional Vertex
vx4y :: Vertex4 a -> a
vx4y (Vertex4 _ y _ _) = y
-- Resolve z component of a 4-dimensional Vertex
vx4z :: Vertex4 a -> a
vx4z (Vertex4 _ _ z _) = z
-- Resolve w component of a 4-dimensional Vertex
vx4w :: Vertex4 a -> a
vx4w (Vertex4 _ _ _ w) = w

-- Resolve x component of a 3-dimensional Normal
n3x :: Normal3 a -> a
n3x (Normal3 x _ _) = x
-- Resolve y component of a 3-dimensional Normal
n3y :: Normal3 a -> a
n3y (Normal3 _ y _) = y
-- Resolve z component of a 3-dimensional Normal
n3z :: Normal3 a -> a
n3z (Normal3 _ _ z) = z

-- TODO: All these vector / matrix operations should be
--       outsourced to BLAS.

vx4ToVx3 :: Vertex4 a -> Vertex3 a
vx4ToVx3 (Vertex4 x y z _) = Vertex3 x y z

vertexToVector :: (Num a) => Vertex3 a -> Vector3 a
vertexToVector v = Vector3 (vx3x v) (vx3y v) (vx3z v)

-- Cross product of two vectors
v3cross :: (Num a) => Vector3 a -> Vector3 a -> Vector3 a
v3cross (Vector3 a1 a2 a3) (Vector3 b1 b2 b3) = Vector3 c1 c2 c3
  where c1 = a2 * b3 - a3 * b2
        c2 = a3 * b1 - a1 * b3
        c3 = a1 * b2 - a2 * b1

v3add :: (Num a) => Vector3 a -> Vector3 a -> Vector3 a
v3add a b = Vector3 x y z
  where x = v3x a + v3x b
        y = v3y a + v3y b
        z = v3z a + v3z b
v3sub :: (Num a) => Vector3 a -> Vector3 a -> Vector3 a
v3sub a b = Vector3 x y z
  where x = v3x a - v3x b
        y = v3y a - v3y b
        z = v3z a - v3z b
v3sum :: (Num a) => [Vector3 a] -> Vector3 a
v3sum vlist = foldl (\accum v -> v3add v accum) (Vector3 0 0 0) vlist

v3div :: (Fractional a, Num a) => Vector3 a -> Vector3 a -> Vector3 a
v3div a b = Vector3 x y z
  where x = v3x a / v3x b
        y = v3y a / v3y b
        z = v3z a / v3z b

vx3add :: (Num a) => Vertex3 a -> Vertex3 a -> Vertex3 a
vx3add a b = Vertex3 x y z
  where x = vx3x a + vx3x b
        y = vx3y a + vx3y b
        z = vx3z a + vx3z b

n3Invert :: Normal3 GLfloat -> Normal3 GLfloat
n3Invert n = Normal3 x y z
  where x = -(n3x n)
        y = -(n3y n)
        z = -(n3z n)

color3AddAlpha :: Color3 GLfloat -> GLfloat -> Color4 GLfloat
color3AddAlpha (Color3 r g b) a = Color4 r g b a

color4MulAlpha :: Color4 GLfloat -> GLfloat -> Color4 GLfloat
color4MulAlpha (Color4 r g b a) x = Color4 r g b (a*x)

color4MulValue :: Color4 GLfloat -> GLfloat -> Color4 GLfloat
color4MulValue (Color4 r g b a) x = Color4 (r*x) (g*x) (b*x) a

color3MulValue :: Color3 GLfloat -> GLfloat -> Color3 GLfloat
color3MulValue (Color3 r g b) x = Color3 (r*x) (g*x) (b*x)

-- }}}

-- Useful for mapping over a list containing tuples of (vertex, vertexNormal):
vertexWithNormal :: (Vertex3 GLfloat, Normal3 GLfloat) -> IO ()
vertexWithNormal (v,n) = do normal n
                            vertex v
                            return ()

vertexWithNormalAndColor :: (Vertex3 GLfloat, Normal3 GLfloat) -> Color4 GLfloat -> IO ()
vertexWithNormalAndColor (v,n) c = do color c
                                      normal n
                                      vertex v
                                      return ()

drawNormal :: (Fractional a, VertexComponent a) => ( Vertex3 a, Normal3 a ) -> IO ()
drawNormal (v,n) = do let from = v
                      let nx   = (n3x n) * 100.0
                      let ny   = (n3y n) * 100.0
                      let nz   = (n3z n) * 100.0
                      let to   = Vertex3 (nx + vx3x v) (ny + vx3y v) (nz + vx3z v)
                      color $ (Color4 1.0 1.0 1.0 1.0 :: Color4 GLfloat)
                      renderPrimitive Lines ( do vertex from
                                                 vertex to )

normalsFromVertices :: [[ Vertex3 GLfloat ]] -> [ Normal3 GLfloat ]
-- {{{
normalsFromVertices sigs = normalsFromVertices' sigs 0

normalsFromVertices' :: [[ Vertex3 GLfloat ]] -> Int -> [ Normal3 GLfloat ]
normalsFromVertices' sigs xIdx = case sigs of
  (sigPrev:sig:sigNext:[]) -> if nSamples > 0 && xIdx < nSamples then resultNormal : normalsFromVertices' sigs (xIdx+1) else []
    where nSamples = length sig
          boundx   = \a -> max 0 (min a (nSamples-1)) :: Int
          vertexC  = sig !! xIdx
          vertexR  = sig !! (boundx (xIdx+1))
          vertexL  = sig !! (boundx (xIdx-1))
          vertexT  = if length sigPrev > xIdx then sigPrev !! xIdx else vertexC
          vertexB  = if length sigNext > xIdx then sigNext !! xIdx else vertexC
          point    = vertexToVector vertexC
          pointR   = vertexToVector vertexR
          pointL   = vertexToVector vertexL
          pointT   = vertexToVector vertexT
          pointB   = vertexToVector vertexB
          vR = v3sub pointR point   --   n4  T  n1
          vT = v3sub pointT point   --       |
          vL = v3sub pointL point   --    L--C--R
          vB = v3sub pointB point   --       |
          n1 = v3cross vT vR        --   n3  B  n2
          n2 = v3cross vR vB
          n3 = v3cross vB vL
          n4 = v3cross vL vT
          -- no normalization here as GL.normalize is enabled
          n  = v3div (v3sum [ n1, n2, n3, n4 ]) (Vector3 4.0 4.0 (4.0 :: GLfloat))
          resultNormal = n3Invert $ Normal3 (v3x n) (v3y n) (v3z n)
  _ -> []
-- }}}

getViewpointFromModelView :: GLmatrix GLfloat -> IO ( Vector3 GLfloat )
-- {{{
getViewpointFromModelView mvMatrix = do
  mvMatrixRows <- getMatrixComponents ColumnMajor mvMatrix
  -- OpenGL float matrix to GSL double matrix:
  let mvMatrixGSL = (4 >< 4) $ map (\e -> realToFrac e :: Double) mvMatrixRows
  -- Invert GSL matrix:
  let mvMatrixGSLInv = LA.inv ( mvMatrixGSL :: HM.Matrix Double )
  -- 4th column vector is position of view point. First 3 columns are
  -- transformation elements.
  let viewPointProjection = NC.fromList [ 0.0, 0.0, 0.0, 1.0 ]
  let viewPointModelView = NC.toList $ NC.vXm viewPointProjection mvMatrixGSLInv
  let viewPoint = Vector3 (realToFrac $ viewPointModelView !! 0)
                          (realToFrac $ viewPointModelView !! 1)
                          (realToFrac $ viewPointModelView !! 2) :: Vector3 GLfloat
  return viewPoint
-- }}}

featuresToIntensity :: FE.SignalFeatures -> FE.FeatureTarget -> AC.ContextSettings -> (GLfloat,GLfloat)
featuresToIntensity features target cSettings = (lCoeff, bCoeff)
  where loudness     = realToFrac $ FE.totalEnergy features
        basslevel    = realToFrac $ FE.bassEnergy features
        lTarget      = FE.featureTargetFromIndex $ AC.featureSignalEnergyTargetIdx cSettings
        bTarget      = FE.featureTargetFromIndex $ AC.featureBassEnergyTargetIdx cSettings
        lCoeff       = if lTarget == target || lTarget == FE.GlobalAndLocalTarget then (
                          realToFrac $ (AC.featureSignalEnergySurfaceCoeff cSettings) * loudness )
                       else 0.0
        bCoeff       = if bTarget == target || bTarget == FE.GlobalAndLocalTarget then (
                          realToFrac $ (AC.featureBassEnergySurfaceCoeff cSettings) * basslevel )
                       else 0.0


{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#endif
#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
{-# LANGUAGE NullaryTypeClasses #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Constraint
-- Copyright   :  (C) 2011-2015 Edward Kmett,
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- @ConstraintKinds@ made type classes into types of a new kind, @Constraint@.
--
-- @
-- 'Eq' :: * -> 'Constraint'
-- 'Ord' :: * -> 'Constraint'
-- 'Monad' :: (* -> *) -> 'Constraint'
-- @
--
-- The need for this extension was first publicized in the paper
--
-- <http://research.microsoft.com/pubs/67439/gmap3.pdf Scrap your boilerplate with class: extensible generic functions>
--
-- by Ralf Lämmel and Simon Peyton Jones in 2005, which shoehorned all the
-- things they needed into a custom 'Sat' typeclass.
--
-- With @ConstraintKinds@ we can put into code a lot of tools for manipulating
-- these new types without such awkward workarounds.
----------------------------------------------------------------------------
module Data.Constraint
  (
  -- * The Kind of Constraints
    Constraint
  -- * Dictionary
  , Dict(Dict)
  , withDict
  -- * Entailment
  , (:-)(Sub)
  , (\\)
  , weaken1, weaken2, contract
  , strengthen1, strengthen2
  , (&&&), (***)
  , trans, refl
  , Bottom(no)
  , top, bottom
  -- * Dict is fully faithful
  , mapDict
  , unmapDict
  -- * Reflection
  , Class(..)
  , (:=>)(..)
  ) where
import Control.Applicative
import Control.Category
import Control.DeepSeq
import Control.Monad
import Data.Complex
import Data.Ratio
import Data.Semigroup
import Data.Data
import qualified GHC.Exts as Exts (Any)
import GHC.Exts (Constraint)
import Data.Bits (Bits)
import Data.Functor.Identity (Identity)
#if MIN_VERSION_base(4,8,0)
import Numeric.Natural (Natural)
#endif
#if !MIN_VERSION_base(4,8,0)
import Data.Word (Word)
#endif

-- | Values of type @'Dict' p@ capture a dictionary for a constraint of type @p@.
--
-- e.g.
--
-- @
-- 'Dict' :: 'Dict' ('Eq' 'Int')
-- @
--
-- captures a dictionary that proves we have an:
--
-- @
-- instance 'Eq' 'Int
-- @
--
-- Pattern matching on the 'Dict' constructor will bring this instance into scope.
--
data Dict :: Constraint -> * where
  Dict :: a => Dict a
  deriving Typeable

instance (Typeable p, p) => Data (Dict p) where
  gfoldl _ z Dict = z Dict
  toConstr _ = dictConstr
  gunfold _ z c = case constrIndex c of
    1 -> z Dict
    _ -> error "gunfold"
  dataTypeOf _ = dictDataType

dictConstr :: Constr
dictConstr = mkConstr dictDataType "Dict" [] Prefix

dictDataType :: DataType
dictDataType = mkDataType "Data.Constraint.Dict" [dictConstr]

deriving instance Eq (Dict a)
deriving instance Ord (Dict a)
deriving instance Show (Dict a)

instance NFData (Dict c) where
  rnf Dict = ()

-- | From a 'Dict', takes a value in an environment where the instance
-- witnessed by the 'Dict' is in scope, and evaluates it.
--
-- Essentially a deconstruction of a 'Dict' into its continuation-style
-- form.
--
withDict :: Dict a -> (a => r) -> r
withDict d r = case d of
                 Dict -> r

infixr 9 :-

-- | This is the type of entailment.
--
-- @a ':-' b@ is read as @a@ \"entails\" @b@.
--
-- With this we can actually build a category for 'Constraint' resolution.
--
-- e.g.
--
-- Because @'Eq' a@ is a superclass of @'Ord' a@, we can show that @'Ord' a@
-- entails @'Eq' a@.
--
-- Because @instance 'Ord' a => 'Ord' [a]@ exists, we can show that @'Ord' a@
-- entails @'Ord' [a]@ as well.
--
-- This relationship is captured in the ':-' entailment type here.
--
-- Since @p ':-' p@ and entailment composes, ':-' forms the arrows of a
-- 'Category' of constraints. However, 'Category' only became sufficiently
-- general to support this instance in GHC 7.8, so prior to 7.8 this instance
-- is unavailable.
--
-- But due to the coherence of instance resolution in Haskell, this 'Category'
-- has some very interesting properties. Notably, in the absence of
-- @IncoherentInstances@, this category is \"thin\", which is to say that
-- between any two objects (constraints) there is at most one distinguishable
-- arrow.
--
-- This means that for instance, even though there are two ways to derive
-- @'Ord' a ':-' 'Eq' [a]@, the answers from these two paths _must_ by
-- construction be equal. This is a property that Haskell offers that is
-- pretty much unique in the space of languages with things they call \"type
-- classes\".
--
-- What are the two ways?
--
-- Well, we can go from @'Ord' a ':-' 'Eq' a@ via the
-- superclass relationship, and then from @'Eq' a ':-' 'Eq' [a]@ via the
-- instance, or we can go from @'Ord' a ':-' 'Ord' [a]@ via the instance
-- then from @'Ord' [a] ':-' 'Eq' [a]@ through the superclass relationship
-- and this diagram by definition must \"commute\".
--
-- Diagrammatically,
--
-- >                    Ord a
-- >                ins /     \ cls
-- >                   v       v
-- >             Ord [a]     Eq a
-- >                cls \     / ins
-- >                     v   v
-- >                    Eq [a]
--
-- This safety net ensures that pretty much anything you can write with this
-- library is sensible and can't break any assumptions on the behalf of
-- library authors.
newtype a :- b = Sub (a => Dict b)
  deriving Typeable

type role (:-) nominal nominal

-- TODO: _proper_ Data for @(p ':-' q)@ requires @(:-)@ to be cartesian _closed_.
--
-- This is admissable, but not present by default

-- constraint should be instance (Typeable p, Typeable q, p |- q) => Data (p :- q)
instance (Typeable p, Typeable q, p, q) => Data (p :- q) where
  gfoldl _ z (Sub Dict) = z (Sub Dict)
  toConstr _ = subConstr
  gunfold _ z c = case constrIndex c of
    1 -> z (Sub Dict)
    _ -> error "gunfold"
  dataTypeOf _ = subDataType

subConstr :: Constr
subConstr = mkConstr dictDataType "Sub" [] Prefix

subDataType :: DataType
subDataType = mkDataType "Data.Constraint.:-" [subConstr]

-- | Possible since GHC 7.8, when 'Category' was made polykinded.
instance Category (:-) where
  id  = refl
  (.) = trans

-- | Assumes 'IncoherentInstances' doesn't exist.
instance Eq (a :- b) where
  _ == _ = True

-- | Assumes 'IncoherentInstances' doesn't exist.
instance Ord (a :- b) where
  compare _ _ = EQ

instance Show (a :- b) where
  showsPrec d _ = showParen (d > 10) $ showString "Sub Dict"

instance a => NFData (a :- b) where
  rnf (Sub Dict) = ()

infixl 1 \\ -- required comment

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

--------------------------------------------------------------------------------
-- Constraints form a Category
--------------------------------------------------------------------------------

-- | Transitivity of entailment
--
-- If we view @(':-')@ as a Constraint-indexed category, then this is @('.')@
trans :: (b :- c) -> (a :- b) -> a :- c
trans f g = Sub $ Dict \\ f \\ g

-- | Reflexivity of entailment
--
-- If we view @(':-')@ as a Constraint-indexed category, then this is 'id'
refl :: a :- a
refl = Sub Dict

--------------------------------------------------------------------------------
-- (,) is a Bifunctor
--------------------------------------------------------------------------------

-- | due to the hack for the kind of @(,)@ in the current version of GHC we can't actually
-- make instances for @(,) :: Constraint -> Constraint -> Constraint@, but @(,)@ is a
-- bifunctor on the category of constraints. This lets us map over both sides.
(***) :: (a :- b) -> (c :- d) -> (a, c) :- (b, d)
f *** g = Sub $ Dict \\ f \\ g

--------------------------------------------------------------------------------
-- Constraints are Cartesian
--------------------------------------------------------------------------------

-- | Weakening a constraint product
--
-- The category of constraints is Cartesian. We can forget information.
weaken1 :: (a, b) :- a
weaken1 = Sub Dict

-- | Weakening a constraint product
--
-- The category of constraints is Cartesian. We can forget information.
weaken2 :: (a, b) :- b
weaken2 = Sub Dict

strengthen1 :: Dict b -> a :- c -> a :- (b,c)
strengthen1 d e = unmapDict (const d) &&& e

strengthen2 :: Dict b -> a :- c -> a :- (c,b)
strengthen2 d e = e &&& unmapDict (const d)

-- | Contracting a constraint / diagonal morphism
--
-- The category of constraints is Cartesian. We can reuse information.
contract :: a :- (a, a)
contract = Sub Dict

-- | Constraint product
--
-- > trans weaken1 (f &&& g) = f
-- > trans weaken2 (f &&& g) = g
(&&&) :: (a :- b) -> (a :- c) -> a :- (b, c)
f &&& g = Sub $ Dict \\ f \\ g

--------------------------------------------------------------------------------
-- Initial and terminal morphisms
--------------------------------------------------------------------------------

-- | Every constraint implies truth
--
-- These are the terminal arrows of the category, and @()@ is the terminal object.
--
-- Given any constraint there is a unique entailment of the @()@ constraint from that constraint.
top :: a :- ()
top = Sub Dict

-- | 'Any' inhabits every kind, including 'Constraint' but is uninhabited, making it impossible to define an instance.
class Exts.Any => Bottom where
  no :: a

-- |
-- This demonstrates the law of classical logic <http://en.wikipedia.org/wiki/Principle_of_explosion "ex falso quodlibet">
bottom :: Bottom :- a
bottom = Sub no

--------------------------------------------------------------------------------
-- Dict is fully faithful
--------------------------------------------------------------------------------

-- | Apply an entailment to a dictionary.
--
-- From a category theoretic perspective 'Dict' is a functor that maps from the category
-- of constraints (with arrows in ':-') to the category Hask of Haskell data types.
mapDict :: (a :- b) -> Dict a -> Dict b
mapDict p Dict = case p of Sub q -> q

-- |
-- This functor is fully faithful, which is to say that given any function you can write
-- @Dict a -> Dict b@ there also exists an entailment @a :- b@ in the category of constraints
-- that you can build.
unmapDict :: (Dict a -> Dict b) -> a :- b
unmapDict f = Sub (f Dict)

type role Dict nominal

--------------------------------------------------------------------------------
-- Reflection
--------------------------------------------------------------------------------

-- | Reify the relationship between a class and its superclass constraints as a class
--
-- Given a definition such as
--
-- @
-- class Foo a => Bar a
-- @
--
-- you can capture the relationship between 'Bar a' and its superclass 'Foo a' with
--
-- @
-- instance 'Class' (Foo a) (Bar a) where 'cls' = 'Sub' 'Dict'
-- @
--
-- Now the user can use 'cls :: Bar a :- Foo a'
class Class b h | h -> b where
  cls :: h :- b

infixr 9 :=>
-- | Reify the relationship between an instance head and its body as a class
--
-- Given a definition such as
--
-- @
-- instance Foo a => Foo [a]
-- @
--
-- you can capture the relationship between the instance head and its body with
--
-- @
-- instance Foo a ':=>' Foo [a] where 'ins' = 'Sub' 'Dict'
-- @
class b :=> h | h -> b where
  ins :: b :- h

-- Bootstrapping

instance Class () (Class b a) where cls = Sub Dict
instance Class () (b :=> a) where cls = Sub Dict

instance Class b a => () :=> Class b a where ins = Sub Dict
instance (b :=> a) => () :=> (b :=> a) where ins = Sub Dict

instance Class () () where cls = Sub Dict
instance () :=> () where ins = Sub Dict

-- Local, Prelude, Applicative, C.M.I and Data.Monoid instances

-- Eq
instance Class () (Eq a) where cls = Sub Dict
instance () :=> Eq () where ins = Sub Dict
instance () :=> Eq Int where ins = Sub Dict
instance () :=> Eq Bool where ins = Sub Dict
instance () :=> Eq Integer where ins = Sub Dict
instance () :=> Eq Float where ins = Sub Dict
instance () :=> Eq Double where ins = Sub Dict
instance Eq a :=> Eq [a] where ins = Sub Dict
instance Eq a :=> Eq (Maybe a) where ins = Sub Dict
instance Eq a :=> Eq (Complex a) where ins = Sub Dict
instance Eq a :=> Eq (Ratio a) where ins = Sub Dict
instance (Eq a, Eq b) :=> Eq (a, b) where ins = Sub Dict
instance (Eq a, Eq b) :=> Eq (Either a b) where ins = Sub Dict
instance () :=> Eq (Dict a) where ins = Sub Dict
instance () :=> Eq (a :- b) where ins = Sub Dict
instance () :=> Eq Word where ins = Sub Dict
instance Eq a :=> Eq (Identity a) where ins = Sub Dict
#if MIN_VERSION_base(4,8,0)
instance Eq a :=> Eq (Const a b) where ins = Sub Dict
instance () :=> Eq Natural where ins = Sub Dict
#endif

-- Ord
instance Class (Eq a) (Ord a) where cls = Sub Dict
instance () :=> Ord () where ins = Sub Dict
instance () :=> Ord Bool where ins = Sub Dict
instance () :=> Ord Int where ins = Sub Dict
instance ():=> Ord Integer where ins = Sub Dict
instance () :=> Ord Float where ins = Sub Dict
instance ():=> Ord Double where ins = Sub Dict
instance () :=> Ord Char where ins = Sub Dict
instance Ord a :=> Ord (Maybe a) where ins = Sub Dict
instance Ord a :=> Ord [a] where ins = Sub Dict
instance (Ord a, Ord b) :=> Ord (a, b) where ins = Sub Dict
instance (Ord a, Ord b) :=> Ord (Either a b) where ins = Sub Dict
instance Integral a :=> Ord (Ratio a) where ins = Sub Dict
instance () :=> Ord (Dict a) where ins = Sub Dict
instance () :=> Ord (a :- b) where ins = Sub Dict
instance () :=> Ord Word where ins = Sub Dict
instance Ord a :=> Ord (Identity a) where ins = Sub Dict
#if MIN_VERSION_base(4,8,0)
instance Ord a :=> Ord (Const a b) where ins = Sub Dict
instance () :=> Ord Natural where ins = Sub Dict
#endif

-- Show
instance Class () (Show a) where cls = Sub Dict
instance () :=> Show () where ins = Sub Dict
instance () :=> Show Bool where ins = Sub Dict
instance () :=> Show Ordering where ins = Sub Dict
instance () :=> Show Char where ins = Sub Dict
instance () :=> Show Int where ins = Sub Dict
instance Show a :=> Show (Complex a) where ins = Sub Dict
instance Show a :=> Show [a] where ins = Sub Dict
instance Show a :=> Show (Maybe a) where ins = Sub Dict
instance (Show a, Show b) :=> Show (a, b) where ins = Sub Dict
instance (Show a, Show b) :=> Show (Either a b) where ins = Sub Dict
instance (Integral a, Show a) :=> Show (Ratio a) where ins = Sub Dict
instance () :=> Show (Dict a) where ins = Sub Dict
instance () :=> Show (a :- b) where ins = Sub Dict
instance () :=> Show Word where ins = Sub Dict
instance Show a :=> Show (Identity a) where ins = Sub Dict
#if MIN_VERSION_base(4,8,0)
instance Show a :=> Show (Const a b) where ins = Sub Dict
instance () :=> Show Natural where ins = Sub Dict
#endif

-- Read
instance Class () (Read a) where cls = Sub Dict
instance () :=> Read () where ins = Sub Dict
instance () :=> Read Bool where ins = Sub Dict
instance () :=> Read Ordering where ins = Sub Dict
instance () :=> Read Char where ins = Sub Dict
instance () :=> Read Int where ins = Sub Dict
instance Read a :=> Read (Complex a) where ins = Sub Dict
instance Read a :=> Read [a] where ins = Sub Dict
instance Read a :=> Read (Maybe a) where ins = Sub Dict
instance (Read a, Read b) :=> Read (a, b) where ins = Sub Dict
instance (Read a, Read b) :=> Read (Either a b) where ins = Sub Dict
instance (Integral a, Read a) :=> Read (Ratio a) where ins = Sub Dict
instance () :=> Read Word where ins = Sub Dict
instance Read a :=> Read (Identity a) where ins = Sub Dict
#if MIN_VERSION_base(4,8,0)
instance Read a :=> Read (Const a b) where ins = Sub Dict
instance () :=> Read Natural where ins = Sub Dict
#endif

-- Enum
instance Class () (Enum a) where cls = Sub Dict
instance () :=> Enum () where ins = Sub Dict
instance () :=> Enum Bool where ins = Sub Dict
instance () :=> Enum Ordering where ins = Sub Dict
instance () :=> Enum Char where ins = Sub Dict
instance () :=> Enum Int where ins = Sub Dict
instance () :=> Enum Integer where ins = Sub Dict
instance () :=> Enum Float where ins = Sub Dict
instance () :=> Enum Double where ins = Sub Dict
instance Integral a :=> Enum (Ratio a) where ins = Sub Dict
instance () :=> Enum Word where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance Enum a :=> Enum (Identity a) where ins = Sub Dict
instance Enum a :=> Enum (Const a b) where ins = Sub Dict
#endif
#if MIN_VERSION_base(4,8,0)
instance () :=> Enum Natural where ins = Sub Dict
#endif

-- Bounded
instance Class () (Bounded a) where cls = Sub Dict
instance () :=> Bounded () where ins = Sub Dict
instance () :=> Bounded Ordering where ins = Sub Dict
instance () :=> Bounded Bool where ins = Sub Dict
instance () :=> Bounded Int where ins = Sub Dict
instance () :=> Bounded Char where ins = Sub Dict
instance (Bounded a, Bounded b) :=> Bounded (a,b) where ins = Sub Dict
instance () :=> Bounded Word where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance Bounded a :=> Bounded (Identity a) where ins = Sub Dict
instance Bounded a :=> Bounded (Const a b) where ins = Sub Dict
#endif

-- Num
instance Class () (Num a) where cls = Sub Dict
instance () :=> Num Int where ins = Sub Dict
instance () :=> Num Integer where ins = Sub Dict
instance () :=> Num Float where ins = Sub Dict
instance () :=> Num Double where ins = Sub Dict
instance RealFloat a :=> Num (Complex a) where ins = Sub Dict
instance Integral a :=> Num (Ratio a) where ins = Sub Dict
instance () :=> Num Word where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance Num a :=> Num (Identity a) where ins = Sub Dict
instance Num a :=> Num (Const a b) where ins = Sub Dict
#endif
#if MIN_VERSION_base(4,8,0)
instance () :=> Num Natural where ins = Sub Dict
#endif

-- Real
instance Class (Num a, Ord a) (Real a) where cls = Sub Dict
instance () :=> Real Int where ins = Sub Dict
instance () :=> Real Integer where ins = Sub Dict
instance () :=> Real Float where ins = Sub Dict
instance () :=> Real Double where ins = Sub Dict
instance Integral a :=> Real (Ratio a) where ins = Sub Dict
instance () :=> Real Word where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance Real a :=> Real (Identity a) where ins = Sub Dict
instance Real a :=> Real (Const a b) where ins = Sub Dict
#endif
#if MIN_VERSION_base(4,8,0)
instance () :=> Real Natural where ins = Sub Dict
#endif

-- Integral
instance Class (Real a, Enum a) (Integral a) where cls = Sub Dict
instance () :=> Integral Int where ins = Sub Dict
instance () :=> Integral Integer where ins = Sub Dict
instance () :=> Integral Word where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance Integral a :=> Integral (Identity a) where ins = Sub Dict
instance Integral a :=> Integral (Const a b) where ins = Sub Dict
#endif
#if MIN_VERSION_base(4,8,0)
instance () :=> Integral Natural where ins = Sub Dict
#endif

-- Bits
instance Class (Eq a) (Bits a) where cls = Sub Dict
instance () :=> Bits Bool where ins = Sub Dict
instance () :=> Bits Int where ins = Sub Dict
instance () :=> Bits Integer where ins = Sub Dict
instance () :=> Bits Word where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance Bits a :=> Bits (Identity a) where ins = Sub Dict
instance Bits a :=> Bits (Const a b) where ins = Sub Dict
#endif
#if MIN_VERSION_base(4,8,0)
instance () :=> Bits Natural where ins = Sub Dict
#endif

-- Fractional
instance Class (Num a) (Fractional a) where cls = Sub Dict
instance () :=> Fractional Float where ins = Sub Dict
instance () :=> Fractional Double where ins = Sub Dict
instance RealFloat a :=> Fractional (Complex a) where ins = Sub Dict
instance Integral a :=> Fractional (Ratio a) where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance Fractional a :=> Fractional (Identity a) where ins = Sub Dict
instance Fractional a :=> Fractional (Const a b) where ins = Sub Dict
#endif

-- Floating
instance Class (Fractional a) (Floating a) where cls = Sub Dict
instance () :=> Floating Float where ins = Sub Dict
instance () :=> Floating Double where ins = Sub Dict
instance RealFloat a :=> Floating (Complex a) where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance Floating a :=> Floating (Identity a) where ins = Sub Dict
instance Floating a :=> Floating (Const a b) where ins = Sub Dict
#endif

-- RealFrac
instance Class (Real a, Fractional a) (RealFrac a) where cls = Sub Dict
instance () :=> RealFrac Float where ins = Sub Dict
instance () :=> RealFrac Double where ins = Sub Dict
instance Integral a :=> RealFrac (Ratio a) where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance RealFrac a :=> RealFrac (Identity a) where ins = Sub Dict
instance RealFrac a :=> RealFrac (Const a b) where ins = Sub Dict
#endif

-- RealFloat
instance Class (RealFrac a, Floating a) (RealFloat a) where cls = Sub Dict
instance () :=> RealFloat Float where ins = Sub Dict
instance () :=> RealFloat Double where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance RealFloat a :=> RealFloat (Identity a) where ins = Sub Dict
instance RealFloat a :=> RealFloat (Const a b) where ins = Sub Dict
#endif

-- Semigroup
instance Class () (Semigroup a) where cls = Sub Dict
instance () :=> Semigroup () where ins = Sub Dict
instance () :=> Semigroup Ordering where ins = Sub Dict
instance () :=> Semigroup [a] where ins = Sub Dict
instance Semigroup a :=> Semigroup (Maybe a) where ins = Sub Dict
instance (Semigroup a, Semigroup b) :=> Semigroup (a, b) where ins = Sub Dict
instance Semigroup a :=> Semigroup (Const a b) where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance Semigroup a :=> Semigroup (Identity a) where ins = Sub Dict
#endif
#if MIN_VERSION_base(4,10,0)
instance Semigroup a :=> Semigroup (IO a) where ins = Sub Dict
#endif

-- Monoid
#if MIN_VERSION_base(4,11,0)
instance Class (Semigroup a) (Monoid a) where cls = Sub Dict
#else
instance Class () (Monoid a) where cls = Sub Dict
#endif
instance () :=> Monoid () where ins = Sub Dict
instance () :=> Monoid Ordering where ins = Sub Dict
instance () :=> Monoid [a] where ins = Sub Dict
instance Monoid a :=> Monoid (Maybe a) where ins = Sub Dict
instance (Monoid a, Monoid b) :=> Monoid (a, b) where ins = Sub Dict
instance Monoid a :=> Monoid (Const a b) where ins = Sub Dict
#if MIN_VERSION_base(4,9,0)
instance Monoid a :=> Monoid (Identity a) where ins = Sub Dict
instance Monoid a :=> Monoid (IO a) where ins = Sub Dict
#endif

-- Functor
instance Class () (Functor f) where cls = Sub Dict
instance () :=> Functor [] where ins = Sub Dict
instance () :=> Functor Maybe where ins = Sub Dict
instance () :=> Functor (Either a) where ins = Sub Dict
instance () :=> Functor ((->) a) where ins = Sub Dict
instance () :=> Functor ((,) a) where ins = Sub Dict
instance () :=> Functor IO where ins = Sub Dict
instance Monad m :=> Functor (WrappedMonad m) where ins = Sub Dict
instance () :=> Functor Identity where ins = Sub Dict
instance () :=> Functor (Const a) where ins = Sub Dict

-- Applicative
instance Class (Functor f) (Applicative f) where cls = Sub Dict
instance () :=> Applicative [] where ins = Sub Dict
instance () :=> Applicative Maybe where ins = Sub Dict
instance () :=> Applicative (Either a) where ins = Sub Dict
instance () :=> Applicative ((->)a) where ins = Sub Dict
instance () :=> Applicative IO where ins = Sub Dict
instance Monoid a :=> Applicative ((,)a) where ins = Sub Dict
instance Monoid a :=> Applicative (Const a) where ins = Sub Dict
instance Monad m :=> Applicative (WrappedMonad m) where ins = Sub Dict

-- Alternative
instance Class (Applicative f) (Alternative f) where cls = Sub Dict
instance () :=> Alternative [] where ins = Sub Dict
instance () :=> Alternative Maybe where ins = Sub Dict
instance MonadPlus m :=> Alternative (WrappedMonad m) where ins = Sub Dict

-- Monad
#if MIN_VERSION_base(4,8,0)
instance Class (Applicative f) (Monad f) where cls = Sub Dict
#else
instance Class () (Monad f) where cls = Sub Dict
#endif
instance () :=> Monad [] where ins = Sub Dict
instance () :=> Monad ((->) a) where ins = Sub Dict
instance () :=> Monad (Either a) where ins = Sub Dict
instance () :=> Monad IO where ins = Sub Dict
instance () :=> Monad Identity where ins = Sub Dict

-- MonadPlus
#if MIN_VERSION_base(4,8,0)
instance Class (Monad f, Alternative f) (MonadPlus f) where cls = Sub Dict
#else
instance Class (Monad f) (MonadPlus f) where cls = Sub Dict
#endif
instance () :=> MonadPlus [] where ins = Sub Dict
instance () :=> MonadPlus Maybe where ins = Sub Dict

--------------------------------------------------------------------------------
-- UndecidableInstances
--------------------------------------------------------------------------------

instance a :=> Enum (Dict a) where ins = Sub Dict
instance a => Enum (Dict a) where
  toEnum _ = Dict
  fromEnum Dict = 0

instance a :=> Bounded (Dict a) where ins = Sub Dict
instance a => Bounded (Dict a) where
  minBound = Dict
  maxBound = Dict

instance a :=> Read (Dict a) where ins = Sub Dict
deriving instance a => Read (Dict a)

instance () :=> Semigroup (Dict a) where ins = Sub Dict
instance Semigroup (Dict a) where
  Dict <> Dict = Dict

instance a :=> Monoid (Dict a) where ins = Sub Dict
instance a => Monoid (Dict a) where
#if !(MIN_VERSION_base(4,11,0))
  mappend = (<>)
#endif
  mempty = Dict