text:
{-# 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)

max_stars_repo_name: jbracker/supermonad-plugin

max_issues_repo_name: jbracker/supermonad

max_forks_repo_name: jbracker/supermonad-plugin


text:
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeApplications #-}

module NQS.Internal.BLAS
  ( AXPY(..)
  , COPY(..)
  , DOTC(..)
  , DOTU(..)
  , NRM2(..)
  , SCAL(..)
  , GEMV(..)
  , HERK(..)
  , fill
  , testGemv
  ) where

import Control.Monad.Primitive
import Control.Exception (assert)
import Data.Complex (Complex)
import Data.Proxy
import Foreign.Storable
import Foreign.Ptr
-- import Foreign.Marshal.Alloc

import Data.Semigroup((<>))
import Numerical.HBLAS.BLAS.FFI ( CBLAS_ORDERT(..)
                                , CBLAS_UPLOT(..)
                                , CBLAS_TRANSPOSET(..)
                                )
import Numerical.HBLAS.BLAS.FFI.Level1
import Numerical.HBLAS.BLAS.FFI.Level2
import Numerical.HBLAS.BLAS.FFI.Level3
import Numerical.HBLAS.Constants
import Numerical.HBLAS.UtilsFFI

import Data.Vector.Storable (Vector, MVector)
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as MV

import Data.Singletons

import Lens.Micro((^.))

import NQS.Internal.Types
import NQS.Internal.FFI

instance ToNative Transpose CBLAS_TRANSPOSET where
  encode NoTranspose     = CBLAS_TransposeT 111
  encode Transpose       = CBLAS_TransposeT 112
  encode ConjTranspose   = CBLAS_TransposeT 113
  encode ConjNoTranspose = CBLAS_TransposeT 114

instance ToNative Orientation CBLAS_ORDERT where
  encode Row    = CBOInt 101
  encode Column = CBOInt 102

instance ToNative MatUpLo CBLAS_UPLOT where
  {-# INLINE encode #-}
  encode MatUpper = CBlasUPLO 121
  encode MatLower = CBlasUPLO 122

type ScalFun scale el m = scale -> MDenseVector 'Direct (PrimState m) el -> m ()

type AxpyFun el m = el -> MDenseVector 'Direct (PrimState m) el
                       -> MDenseVector 'Direct (PrimState m) el -> m ()

type DotFun el m res = MDenseVector 'Direct (PrimState m) el
                    -> MDenseVector 'Direct (PrimState m) el
                    -> m res

type CopyFun el m = MDenseVector 'Direct (PrimState m) el
                 -> MDenseVector 'Direct (PrimState m) el
                 -> m ()

type Nrm2Fun el m res = MDenseVector 'Direct (PrimState m) el -> m res

type GemvFun orient el m = Transpose
                        -> el -> MDenseMatrix orient (PrimState m) el
                        -> MDenseVector 'Direct (PrimState m) el
                        -> el -> MDenseVector 'Direct (PrimState m) el
                        -> m ()

type HerkFun scale el orient m
  = MatUpLo
 -> Transpose
 -> scale -> MDenseMatrix orient (PrimState m) el
 -> scale -> MDenseMatrix orient (PrimState m) el
 -> m ()

-- | Fills a vector with a given value.
fill ::
     (PrimMonad m, Storable el, COPY (MDenseVector 'Direct) el)
  => MDenseVector 'Direct (PrimState m) el -> el -> m ()
fill v x =
  V.unsafeThaw (V.singleton x) >>= \t -> copy (MDenseVector (v ^. dim)  0 t) v

{-
        SCAL
  ================
-}

class SCAL scale v el where
  scal :: PrimMonad m => scale -> v (PrimState m) el -> m ()

{-# SPECIALISE scal :: PrimMonad m => ScalFun Float Float m #-}
{-# SPECIALISE scal :: PrimMonad m => ScalFun Float (Complex Float) m #-}
{-# SPECIALISE scal :: PrimMonad m => ScalFun (Complex Float) (Complex Float) m #-}
{-# SPECIALISE scal :: PrimMonad m => ScalFun Double Double m #-}
{-# SPECIALISE scal :: PrimMonad m => ScalFun Double (Complex Double) m #-}
{-# SPECIALISE scal :: PrimMonad m => ScalFun (Complex Double) (Complex Double) m #-}

scalAbstraction ::
     (Storable el, PrimMonad m, Show el)
  => String
  -> ScalFunFFI scale el
  -> ScalFunFFI scale el
  -> (scaleplain -> (scale -> m ()) -> m ())
  -> ScalFun scaleplain el m
{-# NOINLINE scalAbstraction #-}
scalAbstraction scalName scalSafeFFI scalUnsafeFFI constHandler = doScal
  where
    shouldCallFast :: Int -> Bool
    shouldCallFast !n = flopsThreshold >= fromIntegral n
    doScal alpha (MDenseVector dim stride buffer)
      | not (isValidVector dim stride (MV.length buffer)) = error $!
          badVectorInfo scalName "X" dim stride (MV.length buffer)
      | otherwise =
        unsafeWithPrim buffer $ \xPtr ->
          constHandler alpha $ \alphaPtr -> do
            unsafePrimToPrim $!
              (if shouldCallFast dim
                 then scalUnsafeFFI
                 else scalSafeFFI)
                (fromIntegral dim)
                alphaPtr
                xPtr (fromIntegral stride)

instance SCAL Float (MDenseVector 'Direct) Float where
  scal = scalAbstraction "sscal" cblas_sscal_safe cblas_sscal_unsafe (\x f -> f x)

instance SCAL Float (MDenseVector 'Direct) (Complex Float) where
  scal = scalAbstraction "csscal" cblas_csscal_safe cblas_csscal_unsafe (\x f -> f x)

instance SCAL (Complex Float) (MDenseVector 'Direct) (Complex Float) where
  scal = scalAbstraction "cscal" cblas_cscal_safe cblas_cscal_unsafe withRStorable_

instance SCAL Double (MDenseVector 'Direct) Double where
  scal = scalAbstraction "dscal" cblas_dscal_safe cblas_dscal_unsafe (\x f -> f x)

instance SCAL Double (MDenseVector 'Direct) (Complex Double) where
  scal = scalAbstraction "zdscal" cblas_zdscal_safe cblas_zdscal_unsafe (\x f -> f x)

instance SCAL (Complex Double) (MDenseVector 'Direct) (Complex Double) where
  scal = scalAbstraction "zscal" cblas_zscal_safe cblas_zscal_unsafe withRStorable_

{-
        AXPY
  ================
-}

class AXPY v el where
  axpy :: PrimMonad m => el -> v (PrimState m) el -> v (PrimState m) el -> m ()

{-# SPECIALISE axpy :: PrimMonad m => AxpyFun Float m #-}
{-# SPECIALISE axpy :: PrimMonad m => AxpyFun (Complex Float) m #-}
{-# SPECIALISE axpy :: PrimMonad m => AxpyFun Double m #-}
{-# SPECIALISE axpy :: PrimMonad m => AxpyFun (Complex Double) m #-}

axpyAbstraction ::
     (PrimMonad m, Storable el, Show el)
  => String
  -> AxpyFunFFI scale el
  -> AxpyFunFFI scale el
  -> (el -> (scale -> m ()) -> m ())
  -> AxpyFun el m
{-# NOINLINE axpyAbstraction #-}
axpyAbstraction axpyName axpySafeFFI axpyUnsafeFFI constHandler = doAxpy
  where
    shouldCallFast :: Int -> Bool
    shouldCallFast !n = flopsThreshold >= 2 * (fromIntegral n) -- n for a*x, and n for +y
    doAxpy alpha (MDenseVector xDim xStride xBuff)
                 (MDenseVector yDim yStride yBuff)
      | not (isValidVector xDim xStride (MV.length xBuff)) = error $!
        badVectorInfo axpyName "X" xDim xStride (MV.length xBuff)
      | not (isValidVector yDim yStride (MV.length yBuff)) = error $!
        badVectorInfo axpyName "Y" yDim yStride (MV.length yBuff)
      | xDim /= yDim = error $! axpyName <> ": Inconsistent dimensions: " <>
                                show xDim <> " != " <> show yDim <> "."
      | otherwise =
        unsafeWithPrim xBuff $ \xPtr ->
          unsafeWithPrim yBuff $ \yPtr ->
            constHandler alpha $ \alphaPtr -> do
              unsafePrimToPrim $!
                (if shouldCallFast xDim
                   then axpyUnsafeFFI
                   else axpySafeFFI)
                  (fromIntegral xDim)
                  alphaPtr
                  xPtr (fromIntegral xStride)
                  yPtr (fromIntegral yStride)

instance AXPY (MDenseVector 'Direct) Float where
  axpy = axpyAbstraction "saxpy" cblas_saxpy_safe cblas_saxpy_unsafe (\x f -> f x)

instance AXPY (MDenseVector 'Direct) Double where
  axpy = axpyAbstraction "daxpy" cblas_daxpy_safe cblas_daxpy_unsafe (\x f -> f x)

instance AXPY (MDenseVector 'Direct) (Complex Float) where
  axpy = axpyAbstraction "caxpy" cblas_caxpy_safe cblas_caxpy_unsafe withRStorable_

instance AXPY (MDenseVector 'Direct) (Complex Double) where
  axpy = axpyAbstraction "zaxpy" cblas_zaxpy_safe cblas_zaxpy_unsafe withRStorable_

{-
        CDOT
  ================
-}

class DOTU v el res where
  dotu :: PrimMonad m => v (PrimState m) el -> v (PrimState m) el -> m res

{-# SPECIALISE dotu :: PrimMonad m => DotFun Float m Float #-}
{-# SPECIALISE dotu :: PrimMonad m => DotFun Float m Double #-}
{-# SPECIALISE dotu :: PrimMonad m => DotFun Double m Double #-}
{-# SPECIALISE dotu :: PrimMonad m => DotFun (Complex Float) m (Complex Float) #-}
{-# SPECIALISE dotu :: PrimMonad m => DotFun (Complex Double) m (Complex Double) #-}

class DOTC v el res where
  dotc :: PrimMonad m => v (PrimState m) el -> v (PrimState m) el -> m res

{-# SPECIALISE dotc :: PrimMonad m => DotFun Float m Float #-}
{-# SPECIALISE dotc :: PrimMonad m => DotFun Float m Double #-}
{-# SPECIALISE dotc :: PrimMonad m => DotFun Double m Double #-}
{-# SPECIALISE dotc :: PrimMonad m => DotFun (Complex Float) m (Complex Float) #-}
{-# SPECIALISE dotc :: PrimMonad m => DotFun (Complex Double) m (Complex Double) #-}

realDotAbstraction ::
     (PrimMonad m, Storable el, Num el, Show el)
  => String
  -> NoScalarDotFunFFI el res
  -> NoScalarDotFunFFI el res
  -> DotFun el m res
{-# NOINLINE realDotAbstraction #-}
realDotAbstraction dotName dotSafeFFI dotUnsafeFFI = doDot
  where
    shouldCallFast :: Int -> Bool
    shouldCallFast n = flopsThreshold >= fromIntegral n
    doDot (MDenseVector xDim xStride xBuff)
          (MDenseVector yDim yStride yBuff)
      | not (isValidVector xDim xStride (MV.length xBuff)) = error $!
        badVectorInfo dotName "X" xDim xStride (MV.length xBuff)
      | not (isValidVector yDim yStride (MV.length yBuff)) = error $!
        badVectorInfo dotName "Y" yDim yStride (MV.length yBuff)
      | xDim /= yDim = error $! dotName <> ": Inconsistent dimensions: " <>
                                show xDim <> " != " <> show yDim <> "."
      | otherwise =
        unsafeWithPrim xBuff $ \xPtr ->
          unsafeWithPrim yBuff $ \yPtr ->
            unsafePrimToPrim $!
              (if shouldCallFast xDim
                 then dotUnsafeFFI
                 else dotSafeFFI)
                (fromIntegral xDim)
                xPtr (fromIntegral xStride)
                yPtr (fromIntegral yStride)

complexDotAbstraction ::
     (PrimMonad m, Storable el, Num el, Show el)
  => String
  -> ComplexDotFunFFI el
  -> ComplexDotFunFFI el
  -> DotFun el m el
{-# NOINLINE complexDotAbstraction #-}
complexDotAbstraction dotName dotSafeFFI dotUnsafeFFI = doDot
  where
    shouldCallFast :: Int -> Bool
    shouldCallFast n = flopsThreshold >= fromIntegral n
    doDot (MDenseVector xDim xStride xBuff)
          (MDenseVector yDim yStride yBuff)
      | not (isValidVector xDim xStride (MV.length xBuff)) = error $!
        badVectorInfo dotName "X" xDim xStride (MV.length xBuff)
      | not (isValidVector yDim yStride (MV.length yBuff)) = error $!
        badVectorInfo dotName "Y" yDim yStride (MV.length yBuff)
      | xDim /= yDim = error $! dotName <> ": Inconsistent dimensions: " <>
                                show xDim <> " != " <> show yDim <> "."
      | otherwise =
        unsafeWithPrim xBuff $ \xPtr ->
          unsafeWithPrim yBuff $ \yPtr ->
            unsafePrimToPrim $!
              alloca $ \outPtr -> do
                poke outPtr 0
                (if shouldCallFast xDim
                   then dotUnsafeFFI
                   else dotSafeFFI)
                  (fromIntegral xDim)
                  xPtr (fromIntegral xStride)
                  yPtr (fromIntegral yStride)
                  outPtr
                peek outPtr

instance DOTC (MDenseVector 'Direct) Float Float where
  dotc = realDotAbstraction "sdot" cblas_sdot_safe cblas_sdot_unsafe

instance DOTC (MDenseVector 'Direct) Double Double where
  dotc = realDotAbstraction "ddot" cblas_ddot_safe cblas_ddot_unsafe

instance DOTC (MDenseVector 'Direct) Float Double where
  dotc = realDotAbstraction "dsdot" cblas_dsdot_safe cblas_dsdot_unsafe

instance DOTC (MDenseVector 'Direct) (Complex Float) (Complex Float) where
  dotc = complexDotAbstraction "cdotc" cblas_cdotc_safe cblas_cdotc_unsafe

instance DOTC (MDenseVector 'Direct) (Complex Double) (Complex Double) where
  dotc = complexDotAbstraction "zdotc" cblas_zdotc_safe cblas_zdotc_unsafe

instance DOTU (MDenseVector 'Direct) Float Float where
  dotu = realDotAbstraction "sdot" cblas_sdot_safe cblas_sdot_unsafe

instance DOTU (MDenseVector 'Direct) Double Double where
  dotu = realDotAbstraction "ddot" cblas_ddot_safe cblas_ddot_unsafe

instance DOTU (MDenseVector 'Direct) Float Double where
  dotu = realDotAbstraction "dsdot" cblas_dsdot_safe cblas_dsdot_unsafe

instance DOTU (MDenseVector 'Direct) (Complex Float) (Complex Float) where
  dotu = complexDotAbstraction "cdotu" cblas_cdotu_safe cblas_cdotu_unsafe

instance DOTU (MDenseVector 'Direct) (Complex Double) (Complex Double) where
  dotu = complexDotAbstraction "zdotu" cblas_zdotu_safe cblas_zdotu_unsafe

class COPY v el where
  copy :: PrimMonad m => v (PrimState m) el -> v (PrimState m) el -> m ()

{-# SPECIALISE copy :: PrimMonad m => CopyFun Float m #-}
{-# SPECIALISE copy :: PrimMonad m => CopyFun Double m #-}
{-# SPECIALISE copy :: PrimMonad m => CopyFun (Complex Float) m #-}
{-# SPECIALISE copy :: PrimMonad m => CopyFun (Complex Double) m #-}

copyAbstraction ::
     (PrimMonad m, Storable el, Num el, Show el)
  => String
  -> CopyFunFFI el
  -> CopyFunFFI el
  -> CopyFun el m
{-# NOINLINE copyAbstraction #-}
copyAbstraction copyName copySafeFFI copyUnsafeFFI = doCopy
  where
    shouldCallFast :: Int -> Bool
    shouldCallFast _ = True
    doCopy (MDenseVector xDim xStride xBuff)
           (MDenseVector yDim yStride yBuff)
      | not (isValidVector xDim xStride (MV.length xBuff)) = error $!
        badVectorInfo copyName "X" xDim xStride (MV.length xBuff)
      | not (isValidVector yDim yStride (MV.length yBuff)) = error $!
        badVectorInfo copyName "Y" yDim yStride (MV.length yBuff)
      | xDim /= yDim = error $! copyName <> ": Inconsistent dimensions: " <>
                                show xDim <> " != " <> show yDim <> "."
      | otherwise =
        unsafeWithPrim xBuff $ \xPtr ->
          unsafeWithPrim yBuff $ \yPtr ->
            unsafePrimToPrim $!
              (if shouldCallFast xDim
                 then copyUnsafeFFI
                 else copySafeFFI)
                (fromIntegral xDim)
                xPtr (fromIntegral xStride)
                yPtr (fromIntegral yStride)

instance COPY (MDenseVector 'Direct) Float where
  copy = copyAbstraction "scopy" cblas_scopy_safe cblas_scopy_unsafe

instance COPY (MDenseVector 'Direct) Double where
  copy = copyAbstraction "dcopy" cblas_dcopy_safe cblas_dcopy_unsafe

instance COPY (MDenseVector 'Direct) (Complex Float) where
  copy = copyAbstraction "ccopy" cblas_ccopy_safe cblas_ccopy_unsafe

instance COPY (MDenseVector 'Direct) (Complex Double) where
  copy = copyAbstraction "zcopy" cblas_zcopy_safe cblas_zcopy_unsafe

class NRM2 v el res | v el -> res where
  nrm2 :: PrimMonad m => v (PrimState m) el -> m res

{-# SPECIALISE nrm2 :: PrimMonad m => Nrm2Fun Float m Float #-}
{-# SPECIALISE nrm2 :: PrimMonad m => Nrm2Fun Double m Double #-}
{-# SPECIALISE nrm2 :: PrimMonad m => Nrm2Fun (Complex Float) m Float #-}
{-# SPECIALISE nrm2 :: PrimMonad m => Nrm2Fun (Complex Double) m Double #-}

nrm2Abstraction ::
     (PrimMonad m, Storable el, Num el, Show el)
  => String
  -> Nrm2FunFFI el res
  -> Nrm2FunFFI el res
  -> Nrm2Fun el m res
{-# NOINLINE nrm2Abstraction #-}
nrm2Abstraction nrm2Name nrm2SafeFFI nrm2UnsafeFFI = doNrm2
  where
    shouldCallFast :: Int -> Bool
    shouldCallFast n = fromIntegral n <= flopsThreshold
    doNrm2 (MDenseVector xDim xStride xBuff)
      | not (isValidVector xDim xStride (MV.length xBuff)) = error $!
        badVectorInfo nrm2Name "X" xDim xStride (MV.length xBuff)
      | otherwise =
        unsafeWithPrim xBuff $ \xPtr ->
            unsafePrimToPrim $!
              (if shouldCallFast xDim
                 then nrm2UnsafeFFI
                 else nrm2SafeFFI) (fromIntegral xDim) xPtr (fromIntegral xStride)

instance NRM2 (MDenseVector 'Direct) Float Float where
  nrm2 = nrm2Abstraction "snrm2" cblas_snrm2_safe cblas_snrm2_unsafe

instance NRM2 (MDenseVector 'Direct) Double Double where
  nrm2 = nrm2Abstraction "dnrm2" cblas_dnrm2_safe cblas_dnrm2_unsafe

instance NRM2 (MDenseVector 'Direct) (Complex Float) Float where
  nrm2 = nrm2Abstraction "scnrm2" cblas_scnrm2_safe cblas_scnrm2_unsafe

instance NRM2 (MDenseVector 'Direct) (Complex Double) Double where
  nrm2 = nrm2Abstraction "dznrm2" cblas_dznrm2_safe cblas_dznrm2_unsafe

class GEMV mat v el where
  gemv :: PrimMonad m
       => Transpose
       -> el -> mat (PrimState m) el -> v (PrimState m) el
       -> el -> v (PrimState m) el -> m ()

gemvAbstraction :: forall m el scale orient.
     (PrimMonad m, Storable el, Show el, SingI orient)
  => String
  -> GemvFunFFI scale el
  -> GemvFunFFI scale el
  -> (el -> (scale -> m ()) -> m ())
  -> GemvFun orient el m
{-# NOINLINE gemvAbstraction #-}
gemvAbstraction gemvName gemvSafeFFI gemvUnsafeFFI constHandler = doGemv
  where
    shouldCallFast :: Int -> Int -> Bool
    shouldCallFast !n !m = flopsThreshold >= (fromIntegral n) * (fromIntegral m)
    doGemv trans alpha a@(MDenseMatrix aRows aCols aStride aBuff)
                       x@(MDenseVector xDim xStride xBuff)
                  beta y@(MDenseVector yDim yStride yBuff) =
      assertValid gemvName "A" a $
      assertValid gemvName "X" x $
      assertValid gemvName "Y" y $
        unsafeWithPrim aBuff $ \aPtr ->
        unsafeWithPrim xBuff $ \xPtr ->
        unsafeWithPrim yBuff $ \yPtr ->
        constHandler alpha $ \alphaPtr ->
        constHandler beta $ \betaPtr ->
          do
            unsafePrimToPrim $!
              (if shouldCallFast xDim yDim then gemvUnsafeFFI else gemvSafeFFI)
                (encode (orientationOf a)) (encode trans)
                (fromIntegral aRows) (fromIntegral aCols)
                alphaPtr
                aPtr (fromIntegral aStride)
                xPtr (fromIntegral xStride)
                betaPtr
                yPtr (fromIntegral yStride)

instance SingI orient =>
  GEMV (Mutable (DenseMatrix orient)) (MDenseVector 'Direct) Float where
    gemv = gemvAbstraction "sgemv" cblas_sgemv_safe cblas_sgemv_unsafe (\x f -> f x)

instance SingI orient =>
  GEMV (Mutable (DenseMatrix orient)) (MDenseVector 'Direct) Double where
    gemv = gemvAbstraction "dgemv" cblas_dgemv_safe cblas_dgemv_unsafe (\x f -> f x)

instance SingI orient =>
  GEMV (Mutable (DenseMatrix orient)) (MDenseVector 'Direct) (Complex Float) where
    gemv = gemvAbstraction "cgemv" cblas_cgemv_safe cblas_cgemv_unsafe withRStorable_

instance SingI orient =>
  GEMV (Mutable (DenseMatrix orient)) (MDenseVector 'Direct) (Complex Double) where
    gemv = gemvAbstraction "zgemv" cblas_zgemv_safe cblas_zgemv_unsafe withRStorable_

testGemv :: IO ()
testGemv = do
  aBuff <- newVectorAligned 12 64 :: IO (MV.IOVector Double)
  V.copy aBuff (V.fromList [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12])
  let a = MDenseMatrix @'Row 4 3 3 aBuff
  print (orientationOf a)
  xBuff <- newVectorAligned 4 64 :: IO (MV.IOVector Double)
  V.copy xBuff (V.fromList [1, 2, 3, 4])
  let x = MDenseVector @'Direct 3 1 xBuff
  yBuff <- newVectorAligned 3 64 :: IO (MV.IOVector Double)
  -- V.copy yBuff (V.fromList [1, 2, 3])
  let y = MDenseVector @'Direct 3 1 yBuff
  gemv Transpose 1.0 a x 0.0 y
  print =<< V.unsafeFreeze yBuff

class HERK mat scale el where
  herk :: PrimMonad m
       => MatUpLo -> Transpose
       -> scale -> mat (PrimState m) el
       -> scale -> mat (PrimState m) el
       -> m ()

herkAbstraction
  :: forall m el scale scalePtr. (Storable el, PrimMonad m)
  => String
  -> HerkFunFFI scalePtr el
  -> HerkFunFFI scalePtr el
  -> (scale -> (scalePtr -> m ()) -> m ())
  -> (forall orient . SingI orient => HerkFun scale el orient m)
{-# NOINLINE herkAbstraction #-}
herkAbstraction herkName herkSafeFFI herkUnsafeFFI constHandler = doHerk
 where
  isBadHerk :: Transpose -> Int -> Int -> Int -> Int -> Bool
  isBadHerk NoTranspose   ax ay cx cy = (ax /= cx)
  isBadHerk ConjTranspose ax ay cx cy = (ay /= cx)
  isBadHerk trans _ _ _ _ =
    error $! herkName <> ": trans " <> show trans <> " is not supported."
  doHerk :: forall orient. (SingI orient) => HerkFun scale el orient m
  doHerk uplo trans alpha a@(MDenseMatrix ax ay astride abuff) beta c@(MDenseMatrix cx cy cstride cbuff)
    | cx /= cy = error $!
      herkName <> ": C must be a square matrix, but has dimensions " <> show (cx, cy) <> "."
    | isBadHerk trans ax ay cx cy = error $!
      herkName <> ": Incompatible dimensions: ax ay cx cy trans: " <> show [ax, ay, cx, cy]
               <> " " <> show trans
    | MV.overlaps abuff cbuff = error $! herkName <> ": Input and output buffers overlap."
    | otherwise =
      withMatrixFFI a $ \layout aRows aCols aPtr aStride ->
      withMatrixFFI c $ \_      cRows _     cPtr cStride ->
      constHandler alpha $ \alphaPtr ->
      constHandler beta $ \betaPtr ->
        let k = if (trans == NoTranspose) then aCols else aRows
        in  unsafePrimToPrim $!
          herkSafeFFI ((encode . fromSing) (sing :: Sing orient))
                      (encode uplo)
                      (encode trans)
                      cRows
                      k
                      alphaPtr
                      aPtr
                      aStride
                      betaPtr
                      cPtr
                      cStride

instance SingI orient => HERK (Mutable (DenseMatrix orient)) Float (Complex Float) where
  herk = herkAbstraction "cherk" cblas_cherk_safe cblas_cherk_unsafe (\x f -> f x)

instance SingI orient => HERK (Mutable (DenseMatrix orient)) Double (Complex Double) where
  herk = herkAbstraction "zherk" cblas_zherk_safe cblas_zherk_unsafe (\x f -> f x)

ext: hs

max_stars_repo_name: twesterhout/tcm-swarm

max_issues_repo_name: twesterhout/tcm-swarm

max_forks_repo_name: twesterhout/tcm-swarm


text:
{-# OPTIONS_GHC  -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-missing-signatures #-}
{-# LANGUAGE FlexibleInstances, ConstraintKinds, ExistentialQuantification, GADTs, RankNTypes, MultiParamTypeClasses   #-}
{-# LANGUAGE ImpredicativeTypes, RankNTypes, UndecidableInstances, FlexibleContexts, TypeSynonymInstances #-}

---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------
-- |
-- | Module : Count-Min Sketch
-- | Creator: Xiao Ling
-- | Created: 12/17/2015
-- |
---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

module CountMinSketch where

import Control.Monad.Random.Class
import Control.Monad.Random
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Identity

import Data.Matrix
import Data.Conduit
import qualified Data.Conduit.List as Cl
import qualified Data.Matrix as M

import Core
import Utils
import Statistics

import System.IO.Unsafe

{-----------------------------------------------------------------------------
  Types
------------------------------------------------------------------------------}

type W        = Int              -- * num cols
type D        = Int              -- * num rows
type P        = Int              -- * some prime   --> change this to Integer
type Event    = Int              -- * some input event from
                                 -- * universe: {1, .., i, .. n}

type Sketch   = Matrix Int       -- * D x W matrix  of counters
type ABs      = Matrix Int       -- * 2 x D matrix  of a_j and b_j for j = 1..d
type ColIdx   = [Int]            -- * indices of counters to increment
type Hash     = Event -> ColIdx  -- * Maps event to d x 1 list of column indices

-- * Algorithm State
type AState   = (Sketch,Hash,(D,W,P))

-- * the algorithm uses `some m` equipped with state and randomness
-- * also consider `some'` `a`
type Some m   = (MonadRandom m, MonadState AState m)

{-----------------------------------------------------------------------------
    Count Min Sketch
------------------------------------------------------------------------------}

sk :: Batch Event IO AState
sk = sketch' ed 50

sketch' :: EpsDelta -> Event -> Batch Event IO AState
sketch' t n = sketch t n `using` eval

sketch :: Some m => EpsDelta -> Event -> Streaming Event m ()
sketch t n = lift (initDwp t n) $= inits False $= update

-- * there should be a combinator for this
update :: Some m => Streaming Event m ()
update = do
    mi <- await
    case mi of
        Nothing -> return ()
        Just i  -> lift (update' i) >> update

-- * there should be a combinator that does this
inits :: Some m => Bool -> Conduit Event m Event
inits False = lift inits' >> inits True
inits _     = pass

---- * a concrete `eval`uation of Some `m`
-- * run with vacuous inital condition to be thrown away
eval :: StateT AState (Rand StdGen) () -> IO AState
eval m = evalRandIO $ execStateT m $ (ones 1 1, const [], (0,0,0))

{-----------------------------------------------------------------------------
   Effectful Subroutines
   tenative conclusion, it works fine in here
--------------------------------------------------------------------------------}

initDwp :: Some m => EpsDelta -> Event -> m ()
initDwp (ED e d) n = setParam $ (round $ log2(1/d), round $ 2/e, round $ 2^n -1)

-- * initalize algorithm with zero counters and hash function
inits' :: Some m => m ()
inits' = do
    t       <- askParam
    hash    <- newHash t
    let sketch = newSketch t
    setHash   hash
    setSketch sketch

-- * on event `i`, update the `sketch`
update' :: Some m => Event -> m ()
update' i = do
    pm      <- askParam
    sketch  <- getSketch
    hash    <- askHash
    let incr = toMask (hash i) pm
    setSketch $ incr .+. sketch

-- * sketch1 == sketch1
-- * IO (sketch1', hash', t')
m1 = evalRandIO $ execStateT (update' i1) (sketch0, hash, tup)
m2 = evalRandIO $ execStateT (update' i2) (sketch1, hash, tup)

-- * Estimate
--estimate :: Some m => Event -> m ()
--estimate = do
--    ()

-- * intialize random cofficients a_j, b_j, for d x 2 matrix:
-- * [ a_1 ... a_j ... a_d ]
-- * [ b_1 ... b_j ... b_d ]
newAbs :: MonadRandom m => (D,W,P) -> m ABs
newAbs (d,_,p) = (M.fromList 2 d . take (2*d)) <$> getRandomRs (1,p)

{-----------------------------------------------------------------------------
    Pure Subroutines
------------------------------------------------------------------------------}

newDwp :: EpsDelta -> Event -> (D,W,P)
newDwp (ED e d) n = (round $ log2(1/d), round $ 2/e, round $ 2^n -1)

-- * initalize the sketch
newSketch :: (D,W,P) -> Sketch
newSketch (d,w,_) = zeros d w

-- * h_j (i) = (a_j x i + b_j mod p) mod w
-- * sumRow-wise  [ a_1 ... a_j ... a_d ]  .*.  [ i_1 ...  i_d ]     mod p  mod w
-- *              [ b_1 ... b_j ... b_d ]       [ 1   ...  1   ]
-- * result:      [ idx_1, ..., idx_d   ]
-- *               where the indices start at 1
newHash :: MonadRandom m => (D,W,P) -> m Hash
newHash t = do
    ab  <- newAbs t
    return $ toHash' t ab

-- * Note `is` maps some `i` from event universe onto d x 2 matrix:
-- * [ i_1 ... i_2 ]
-- * [ 1   ...  1  ]
toHash' :: (D, W, P) -> ABs -> Hash
toHash' (d, w, p) ab i = go $ sumR (ab .*. is) ... (\v -> v `mod` p `mod` w)
    where go = fmap (+1) . toList
          is = (i .+ (zeros 1 d)) <-> ones 1 d

-- * given hash function, construct a binary mask of size `w` x `d`
-- * to increment sketch
toMask :: ColIdx -> (D,W,P) -> Sketch
toMask ks (d,w,p) = go w ks
    where
        go w ks = let vec c w = zeros 1 (c-1) <|> single 1 <|> zeros 1 (w - c) in
            case ks of
                c:[] -> vec c w
                c:cs -> vec c w <-> go w cs

{-----------------------------------------------------------------------------
    Ad hoc testing
------------------------------------------------------------------------------}

[i1,i2,i3] = [12,0,50]

tup@(d,w,p) = newDwp ed 50

hash      = unsafePerformIO . evalRandIO $ newHash tup
sketch0   = newSketch tup

-- * update it once
ks1       = hash i1
incr1     = toMask ks1 tup
sketch1   = incr1 .+. sketch0

-- * update again
ks2       = hash i2
incr2     = toMask ks2 tup
sketch2   = incr2 .+. sketch1

{-----------------------------------------------------------------------------
    Managing State
    TODO : redesign so this is not necessary
------------------------------------------------------------------------------}

askParam :: Some m => m (D,W,P)
askParam = get >>= \(_,_,p) -> return p

setParam :: Some m => (D,W,P) -> m ()
setParam t = get >>= \(s,h,_) -> put (s,h,t)

getSketch :: Some m => m Sketch
getSketch = get >>= \(s,_,_) -> return s

setSketch :: Some m => Sketch -> m ()
setSketch s = get >>= \(_,h,t) -> put (s,h,t)

askHash :: Some m => m Hash
askHash = get >>= \(_,h,_) -> return h

setHash :: Some m => Hash -> m ()
setHash h = get >>= \(s,_,t) -> put (s,h,t)

{-----------------------------------------------------------------------------
    Find a lib function for this:
------------------------------------------------------------------------------}

-- * identity conduit, why can't I find this in the library?
pass :: Monad m => Conduit i m i
pass  = do
    mx <- await
    case mx of
        Nothing -> return ()
        Just x  -> yield x >> pass


text:
-- file: Astro/Elements.hs
-- Orbital element calculations.

module Astro.Elements
	where

import Astro.Misc
import Astro.Kepler
import Numeric.LinearAlgebra

-- Standard orbital elements from position and velocity, with given
-- gravitational parameter
posvelToOrbelGp :: Vector Double -> Vector Double -> Double -> [Double]
	--(Monad m) => Vector Double -> Vector Double -> Double -> m [Double]
posvelToOrbelGp rv vv' gpar =
	{-
	if (vv'<.>vv')/2 - gpar / (norm rv) >= 0 then
		fail "Not an elliptic orbit"
	else
	-}
	let 	vv 	= scalar (1/sqrt gpar) * vv'
		r 	= norm rv
		alpha 	= 2/r - vv<.>vv
		eta 	= rv <.> vv
		zeta	= 1 - alpha * r
		hv	= cross rv vv
		h	= norm hv
		ev	= cross vv hv - scale (1/r) rv
		b	= sqrt $ (hv@>0)^2 + (hv@>1)^2
		m0	= atan2 (eta * sqrt alpha) zeta - eta * sqrt alpha
		inc	= atan2 b (hv@>2)
		ascnode = atan2 (hv@>0) (-hv@>1)
		argperi = atan2 ((ev@>2)*h) (ev@>1*hv@>0-ev@>0*hv@>1)
	in	[1/alpha, norm ev, inc, ascnode, argperi, m0]
		--return $ [1/alpha, norm ev, inc, ascnode, argperi, m0]
posvelToOrbel rv vv = posvelToOrbelGp rv vv 1

-- Position and velocity from orbital elements, with given gravitational
-- parameter
orbelToPosvelGp :: [Double] -> Double -> (Vector Double, Vector Double)
	--(Monad m) => [Double] -> Double -> m (Vector Double, Vector Double)
orbelToPosvelGp oe gpar =
	{-
	if (length oe < 6) then
		fail "Need 6 orbital elements"
	else
	-}
	let 	[a, ecc, inc, o, w, m0] = oe
		pv	= fromList [ cos w *cos o - sin w *sin o *cos inc
		 	    	   , cos w *sin o + sin w *cos o *cos inc
		 	    	   , sin w *sin inc ]
		qv	= fromList [ -sin w *cos o  - cos w *sin o *cos inc
		 	   	   , -sin w *sin o  + cos w *cos o *cos inc
		 	    	   ,  cos w *sin inc ]
		wv	= fromList [  sin o *sin inc
				   , -cos o *sin inc
				   ,  cos inc  ]
		ea	= solveEKepler ecc m0
		av	= scalar a * pv
		bv	= scalar (sqrt (1-ecc^2)) * cross wv av
		rv	= scalar (cos ea - ecc) * av
					+ scalar (sin ea) * bv
		vv	= scalar ((sqrt gpar)/(norm rv * sqrt a)) *
				( scalar (sin ea) * (-av)
					+ scalar (cos ea) * bv )
	in
		(rv, vv)
		--return $ (rv, vv)
orbelToPosvel oe = orbelToPosvelGp oe 1

max_stars_repo_name: sageh/AstroHaskell

max_issues_repo_name: sageh/AstroHaskell

max_forks_repo_name: sageh/AstroHaskell


text:
module Read (
  readExpr,
  readExprList
) where

import           Control.Monad
import           Control.Monad.Error
import           Data.Complex
import           Data.Ratio
import           Numeric
import           Text.ParserCombinators.Parsec
import           Types

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~"

escapedChar :: Parser Char
escapedChar = char '\\' >> oneOf "\\\"nrt"

parseString :: Parser LispVal
parseString = do
  char '"'
  x <- many $ escapedChar <|> noneOf "\"\\"
  char '"'
  return $ String x

parseBool :: Parser LispVal
parseBool = do
  string "#"
  x <- oneOf "tf"
  return $ case x of
    't' -> Bool True
    'f' -> Bool False

parseAtom :: Parser LispVal
parseAtom = do
  first <- letter <|> symbol
  rest <- many (letter <|> digit <|> symbol)
  return $ Atom $ first:rest

parseHex :: Parser LispVal
parseHex = do
  try $ string "#x"
  x <- many1 hexDigit
  return $ Number $ fst $ head $ readHex x

parseDigits :: Parser LispVal
parseDigits = do
  try $ char '#'
  second <- oneOf "odb"
  rest <- many1 digit
  return $ Number $ case second of
    'o' -> fst $ head $ readOct rest
    'd' -> read rest
    'b' -> parseBin 0 rest

parseBin :: Integer -> String -> Integer
parseBin acc ""     = acc
parseBin acc (x:xs) = parseBin (acc * 2 + (if x == '0' then 0 else 1)) xs

parseDecimal :: Parser LispVal
parseDecimal = (Number . read) <$> many1 digit

parseNumber :: Parser LispVal
parseNumber = try $ parseHex <|> parseDecimal <|> parseDigits
-- tryを外すと、 #t を解釈できずに落ちるので注意

parseCharacter :: Parser LispVal
parseCharacter = do
  try $ string "#\\"
  value <- try (string "newline" <|> string "space")
    <|> do
      x <- anyChar
      notFollowedBy alphaNum
      return [x]
  return $ Character $ case value of
    "newline" -> '\n'
    "space"   -> ' '
    _         -> head value

parseFloat :: Parser LispVal
parseFloat = do
  x <- many1 digit
  char '.'
  y <- many1 digit
  return $ Float $ fst . head $ readFloat (x ++ "." ++ y)

parseRatio :: Parser LispVal
parseRatio = do
  x <- many1 digit
  char '/'
  y <- many1 digit
  return $ Ratio $ read x % read y

parseComplex :: Parser LispVal
parseComplex = do
  x <- try parseFloat <|> parseDecimal
  char '+'
  y <- try parseFloat <|> parseDecimal
  char 'i'
  return $ Complex (toDouble x :+ toDouble y)

toDouble :: LispVal -> Double
toDouble(Float f)  = f
toDouble(Number n) = fromIntegral n

parseList ::Parser LispVal
parseList = List <$> sepBy parseExpr spaces

parseDottedList :: Parser LispVal
parseDottedList = do
  head <- endBy parseExpr spaces
  tail <- char '.' >> spaces >> parseExpr
  return $ DottedList head tail

parseQuoted :: Parser LispVal
parseQuoted = do
  char '\''
  x <- parseExpr
  return $ List [Atom "quote", x]

parseExpr :: Parser LispVal
parseExpr = parseAtom
  <|> parseString
  <|> try parseComplex
  <|> try parseFloat
  <|> try parseRatio
  <|> try parseNumber
  <|> parseQuoted
  <|> do
    char '('
    x <- try parseList <|> parseDottedList
    char ')'
    return x
  <|> try parseBool
  <|> try parseCharacter

readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
  Left err  -> throwError $ Parser err
  Right val -> return val

readExpr :: String -> ThrowsError LispVal
readExpr = readOrThrow parseExpr

readExprList :: String -> ThrowsError [LispVal]
readExprList = readOrThrow (endBy parseExpr spaces)


text:
{-# LANGUAGE  ForeignFunctionInterface #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Foreign.LAPACK.Zomplex
-- Copyright  : Copyright (c) 2010, Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--

module Foreign.LAPACK.Zomplex
    where

import Data.Complex( Complex )
import Foreign( Ptr )
import Foreign.BLAS.Types
import Foreign.LAPACK.Types

#include "f77_func-hsc.h"

foreign import ccall unsafe #f77_func zgeqrf
    zgeqrf :: Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double)
           -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double)
           -> Ptr LAInt -> Ptr LAInt -> IO ()

foreign import ccall unsafe #f77_func zgelqf
    zgelqf :: Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double)
           -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double)
           -> Ptr LAInt -> Ptr LAInt -> IO ()

foreign import ccall unsafe #f77_func zheevr
    zheevr :: LAEigJob -> LAEigRange -> BLASUplo -> Ptr LAInt
           -> Ptr (Complex Double) -> Ptr LAInt -> Ptr Double -> Ptr Double
           -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double
           -> Ptr (Complex Double) -> Ptr LAInt -> Ptr LAInt
           -> Ptr (Complex Double) -> Ptr LAInt -> Ptr Double -> Ptr LAInt
           -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> IO ()

foreign import ccall unsafe #f77_func zlarfg
    zlarfg :: Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double)
           -> Ptr LAInt -> Ptr (Complex Double) -> IO ()

foreign import ccall unsafe #f77_func zpotrf
    zpotrf :: BLASUplo -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt
           -> Ptr LAInt -> IO ()

foreign import ccall unsafe #f77_func zpotrs
    zpotrs :: BLASUplo -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double)
           -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr LAInt
           -> IO ()

foreign import ccall unsafe #f77_func zpptrf
    zpptrf :: BLASUplo -> Ptr LAInt -> Ptr (Complex Double)
           -> Ptr LAInt -> IO ()

foreign import ccall unsafe #f77_func zpptrs
    zpptrs :: BLASUplo -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double)
           -> Ptr (Complex Double) -> Ptr LAInt -> Ptr LAInt
           -> IO ()

foreign import ccall unsafe #f77_func zunmqr
    zunmqr :: BLASSide -> BLASTrans -> Ptr LAInt -> Ptr LAInt
           -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt
           -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt
           -> Ptr (Complex Double) -> Ptr LAInt -> Ptr LAInt
           -> IO ()

foreign import ccall unsafe #f77_func zunmlq
    zunmlq :: BLASSide -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt
           -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double)
           -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double)
           -> Ptr LAInt -> Ptr LAInt -> IO ()

ext: hsc

max_stars_repo_name: patperry/hs-linear-algebra

max_issues_repo_name: cartazio/hs-cblas

max_forks_repo_name: cartazio/hs-cblas


text:
module Stats.StockCovariance where

import Prelude

import Control.Monad
import Control.Concurrent
import Statistics.Sample
import Data.List
import qualified Data.Vector as V
import Data.UUID

import qualified Database.Redis as Redis (Connection, runRedis)
import qualified Database.PostgreSQL.Simple as Postgres (Connection)

import Types.Stock
import Types.Stock.Psql
import Types.Tick
import Types.Tick.Psql

import Types.StockPairCovariance
import Types.StockPairCovariance.Redis

import DB.Psql
import DB.Redis

-- https://hackage.haskell.org/package/statistics-0.14.0.2/docs/Statistics-Sample.html#v:correlation

confPath = "conf/stats.yaml"

-- TODO limit ticks to given number
--zip ticks by timestamp; pairwise timestamps should equal
pairCovariance :: RedisPool
               -> PostgresPool
               -> Stock
               -> Stock
               -> Int
               -> IO ()
pairCovariance redisPool psqlPool stockA stockB limit = do
  stockAClosingPrices <- V.fromList <$> getStockClose psqlPool (stockId stockA)
  stockBClosingPrices <- V.fromList <$> getStockClose psqlPool (stockId stockB)
  let
    closingZipped :: V.Vector (Double, Double)
    closingZipped = V.zip stockAClosingPrices stockBClosingPrices

    cov :: Double
    cov = covariance closingZipped

    pairCovariance = PairCovariance stockA stockB cov

  putStrLn $ (symbol stockA) ++ " - " ++ (symbol stockB) ++ " covariance: " ++ show cov

  runRedisPool redisPool (setPairCovariance pairCovariance)

  return ()

-- clearly abysmally slow
-- tickers are pulled out the DB too many times
pairCovarianceStocks :: RedisPool
                     -> PostgresPool
                     -> [Stock]
                     -> IO ()
pairCovarianceStocks redisConn psqlPool stocks = do
  stockPairs <- pure $ do -- list monad
    stockA <- stocks
    stockB <- stocks
    return (stockA, stockB)
  let stockPairs' = nub stockPairs
  putStrLn $ "pairs of stocks: " ++ show (length stockPairs)

  mapM_ (\(stockA, stockB) -> void $ pairCovariance redisConn psqlPool stockA stockB 100) stockPairs

  return ()

pairCovarianceNStocks :: RedisPool
                      -> PostgresPool
                      -> [Stock]
                      -> Int
                      -> IO ()
pairCovarianceNStocks redisPool psqlPool stocks limit =
  pairCovarianceStocks redisPool psqlPool (take limit stocks)

accelerateDiagnosticsUUID :: UUID
(Just accelerateDiagnosticsUUID) = fromString "a3b88460-d455-451a-92d1-c85109a9bfb1"

-- stockCovarianceExample = do
--   conn <- getPsqlConnection confPath
--   flowersPrices <- getStockClose conn flowersUUID
--   diagPrices <- getStockClose conn accelerateDiagnosticsUUID

--   putStrLn $ (show (length flowersPrices)) ++ " flowers ticks"
--   putStrLn $ (show (length diagPrices)) ++ " AccelerateDiagnostics ticks"

--   let
--     flowersV = V.fromList flowersPrices
--     diagV = V.fromList diagPrices
--     flowersDiagZipped = V.zip flowersV diagV

--     cov = covariance flowersDiagZipped
--     -- cov' = covariance flowersPrices diagPrices

--   putStrLn $ "covariance: " ++ (show cov)

--   putStrLn "done"

max_stars_repo_name: peterbecich/stock-stats

max_issues_repo_name: peterbecich/stock-stats

max_forks_repo_name: peterbecich/stock-stats


text:
-- |
-- Module      : BattleHack.Events
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental
-- Portability : POSIX

-- Created September 12 2015

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC pragmas
--------------------------------------------------------------------------------------------------------------------------------------------
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module BattleHack.Events where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Text.Printf
import Data.IORef
import Data.Complex
import Data.List
import Data.Maybe
import Data.Functor

-- import qualified Data.Aeson as JSON

import qualified Data.Text as T
import qualified Data.Map  as M
import qualified Data.Set  as S

import Control.Lens
import Control.Monad (liftM, forM, void, when, unless, liftM)
import Control.Applicative
import Control.Concurrent

import Graphics.UI.Gtk
import qualified Graphics.Rendering.Cairo as Cairo

import Sound.OpenAL

import BattleHack.Types
import BattleHack.Lenses
import BattleHack.Utilities.General
import BattleHack.Utilities.Vector
import BattleHack.Utilities.Math
import qualified BattleHack.Piano  as Piano
import qualified BattleHack.Audio  as Audio
import qualified BattleHack.Render as Render

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------
-- |
onanimate :: DrawingArea -> IORef AppState -> IO Bool
onanimate canvas stateref = do
  widgetQueueDraw canvas
  modifyIORef stateref (animation.frame %~ (+1)) -- Increment frame count
  return True

-- |
ondraw :: IORef AppState -> Cairo.Render ()
ondraw stateref = do
  appstate <- Cairo.liftIO $ readIORef stateref
  -- Render.overlay    $ appstate         --
  Render.claviature $ appstate-->piano --
  Render.debugHUD   $ appstate         --
  -- Render.radial     $ appstate         --
  -- Render.sinewave   $ appstate         -- Just for shits and giggles

-- |
ondelete :: IORef AppState -> EventM EAny Bool
ondelete stateref = Cairo.liftIO $ do
  putStrLn "Good bye"
  mainQuit
  return False

-- |
-- TODO: Capture mouse drag
onmousemotion :: IORef AppState -> EventM EMotion Bool
onmousemotion stateref = do
  mouse' <- liftM tovector eventCoordinates
  Cairo.liftIO $ do
    appstate <- readIORef stateref
    modifyIORef stateref (piano.active     .~ Piano.findKeyAt mouse' (appstate-->piano))
    modifyIORef stateref (inputstate.mouse .~ mouse')
  return False

-- |
-- Do yourself a favour and pretend you never saw this mess
onmousedown :: IORef AppState -> EventM EButton Bool
onmousedown stateref = do
  Cairo.liftIO $ do
    appstate <- readIORef stateref
    perhaps pass (appstate-->piano.active) $ \i -> do
      -- loopingMode (_source appstate) $= [OneShot, Looping] !! 1 -- Easy toggling
      -- void . forkIO $ Audio.note (_source appstate) (Piano.pitchFromKeyIndex ikey) 1.0 -- TODO: Do not hard code duration
      -- void $ Audio.playnote (appstate-->claviature) i
      modifyIORef stateref (piano.keys.ix i .~ True)
  return False

-- |
onmouseup :: IORef AppState -> EventM EButton Bool
onmouseup stateref = do
  -- TODO: Implement note press and release properly
  -- source <- Cairo.liftIO $ liftM _source $ readIORef stateref
  Cairo.liftIO $ do
    appstate <- readIORef stateref
    perhaps pass (appstate-->piano.active) $ \i -> do
      modifyIORef stateref (piano.keys.ix i .~ False)
      -- return expressionvoid $ Audio.stopnote (appstate-->claviature) i
  return False

-- |
onwheelscrool :: IORef AppState -> EventM EScroll Bool
onwheelscrool stateref = do
  direction <- eventScrollDirection
  Cairo.liftIO $ do
    modifyIORef stateref (piano.origin %~ panX direction)
  return False
  where
    panX ScrollUp   = (+ ((-5.0):+0.0))
    panX ScrollDown = (+ (( 5.0):+0.0))

-- |
-- TODO: Helpers for updating state, checking repeats
onkeydown :: IORef AppState -> EventM EKey Bool
onkeydown stateref = do
  key <- T.unpack <$> eventKeyName -- TODO: Use key val?

  Cairo.liftIO $ do
    -- Do yourself a favour and pretend you never saw this mess
    bindings <- liftM (-->bindings) . readIORef $ stateref
    appstate <- readIORef stateref

    -- Unless the key is already being pressed
    unless (S.member key $ appstate-->inputstate.keyboard) $ do
      modifyIORef stateref (inputstate.keyboard %~ S.insert key) -- Mark key as pressed
      fromMaybe pass (M.lookup key bindings)                     -- Invoke the command bound to this key (if any)

      perhaps pass (noteIndexFromKey key) $ \i -> do
        appstate <- readIORef stateref
        modifyIORef stateref (piano.keys.ix i .~ True)
        -- void $ Audio.playnote (appstate-->claviature) i

  return False

-- |
-- TODO: Implement note press and release properly
onkeyup :: IORef AppState -> EventM EKey Bool
onkeyup stateref = do
  key <- T.unpack <$> eventKeyName -- TODO: Use key val?
  Cairo.liftIO $ do
    appstate <- readIORef stateref
    modifyIORef stateref (inputstate.keyboard %~ S.delete key) -- Mark key as pressed
    perhaps pass (noteIndexFromKey key) $ \i -> do
      -- Audio.stopnote (appstate-->claviature) i
      modifyIORef stateref (piano.keys.ix i .~ False)

  return False

-- Utilities -------------------------------------------------------------------------------------------------------------------------------
-- |
-- TODO: Don't use 'head' (decapitations are dangerous)
-- TODO: Move out key bindings (eg. to JSON file)
-- TODO: Range should be a setting
noteIndexFromKey :: String -> Maybe Int
noteIndexFromKey key = M.lookup (head key) mapping -- TODO: Factor out
  where
    mapping = M.fromList $ zip "asdfghjklöä" Piano.allnaturals ++ zip "wetyupå"  Piano.allaccidentals


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

module Numeric.LinearAlgebra.Arnoldi
       ( Arpack, eig
         -- * Options
       , Options(..), Which(..)
         -- * Exceptions
       , MaxIterations(..)
       , NoShifts(..)
       , Reallocate(..)
       , XYAUPD(..)
       , XYEUPD(..)
       , Unimplemented(..)
       ) where

import Data.Vector.Storable (Vector)
import Data.Vector.Storable.Mutable (IOVector)
import Numeric.LinearAlgebra (Matrix)
import System.IO.Unsafe (unsafePerformIO)

import Arpack.Exceptions
import Arpack.Foreign
import Arpack.Options

eig :: Arpack t => Options t -> Int -> (IOVector t -> IOVector t -> IO ())
    -> (Vector t, Matrix t)
eig !options !dim !multiply = unsafePerformIO (arpack options dim multiply)

max_stars_repo_name: ttuegel/arpack

max_issues_repo_name: ttuegel/arpack

max_forks_repo_name: ttuegel/arpack


text:
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Feldspar.Algorithm.FFT.Push
  ( fft
  , butterfly
  , twid
  , itwids
  , twids
  ) where

import qualified Prelude as P
import qualified Data.Complex

import Feldspar
import Feldspar.Mutable
import Feldspar.Vector

import Feldspar.Algorithm.FFT.Utils
import Feldspar.Algorithm.FFT.Twids

import Test.QuickCheck

-- | Utilities that should go into Feldspar.Vector
chnk :: forall arr1 a b . (Pushy arr1, VecShape arr1 ~ DIM1, Syntax b)
      => Data Length          -- ^ Number of chunks
      -> Data Length          -- ^ Size of the chunks
      -> (Pull DIM1 a -> arr1 b) -- ^ Applied to every chunk
      -> Pull DIM1 a
      -> Push DIM1 b
chnk r c f v = Push loop $ extent v
  where loop :: PushK DIM1 b
        loop func = parFor r $ \i ->
                      let (Push k _) = toPush $ f (take c (drop (c*i) v))
                      in k (\(Z:.j) a -> func (Z:.(c*i + j)) a)

unhalve :: (Syntax a)
        => Pull DIM1 (a,a) -> Push DIM1 a
unhalve xs = unpairWith id (\(Z:.i) -> Z:.(i + length xs)) xs

stride :: Data Length -> Data Length
       -> (Data Index -> a -> M b)
       -> Data Index -> (a,a) -> M b
stride n k f ix (a1,a2) = f (n*ix) a1 >> f (n*ix+k) a2

-- | DFT2 for Decimation-In-Frequency
dft2 :: Num a => a -> (a, a) -> (a,a)
dft2 w (x0,x1) = (x0+x1, (x0-x1)*w)

butterfly :: (Syntax a, Num a)
          => (a -> (a,a) -> (a,a))
          -> Pull DIM1 a -> Pull DIM1 a -> Push DIM1 a
butterfly f ws = unhalve . zipWith f ws . uncurry zip . halve

-- | Cooley-Tukey Radix-2 Decimation In Frequency Fast Fourier Transfrom
fft :: (Syntax a, Num a)
    => Pull DIM1 a -> Pull DIM1 a -> Pull DIM1 a
fft ws vs = forLoop (ilog2 len) vs stage
  where
    len = length vs
    stage s = withLen len
            $ toPull
            . store
            . chnk (1 .<<. s) (len .>>. s) (butterfly dft2 (ixmap (.<<. s) ws))

max_stars_repo_name: pjonsson/feldspar-language

max_issues_repo_name: pjonsson/feldspar-language

max_forks_repo_name: pjonsson/feldspar-language


text:
module PatternRecogn.Lina(
	Matrix, Vector,
	MatrixOf, VectorOf,
	module Lina
) where

import Numeric.LinearAlgebra as Lina hiding( Matrix, Vector )
import qualified Numeric.LinearAlgebra as LinaIntern

type Matrix = LinaIntern.Matrix Double
type Vector = LinaIntern.Vector Double

type MatrixOf = LinaIntern.Matrix
type VectorOf = LinaIntern.Vector

max_stars_repo_name: EsGeh/pattern-recognition

max_issues_repo_name: EsGeh/pattern-recognition

max_forks_repo_name: EsGeh/pattern-recognition