{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Internal.Action
-- Copyright   :  (C) 2012-2014 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  non-portable
--
----------------------------------------------------------------------------
module Control.Lens.Action.Internal
  (
  -- ** Actions
    Effective(..)
  , Effect(..)
  ) where

import Control.Applicative
import Control.Applicative.Backwards
import Control.Monad
import Data.Functor.Bind
import Data.Functor.Contravariant
import Data.Functor.Identity
import Data.Profunctor.Unsafe
import Data.Semigroup

import Control.Lens.Internal.Getter

-------------------------------------------------------------------------------
-- Programming with Effects
-------------------------------------------------------------------------------

-- | An 'Effective' 'Functor' ignores its argument and is isomorphic to a 'Monad' wrapped around a value.
--
-- That said, the 'Monad' is possibly rather unrelated to any 'Applicative' structure.
class (Monad m, Functor f, Contravariant f) => Effective m r f | f -> m r where
  effective :: m r -> f a
  ineffective :: f a -> m r

instance Effective m r f => Effective m (Dual r) (Backwards f) where
  effective :: m (Dual r) -> Backwards f a
effective = f a -> Backwards f a
forall k (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards (f a -> Backwards f a)
-> (m (Dual r) -> f a) -> m (Dual r) -> Backwards f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m r -> f a
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
m r -> f a
effective (m r -> f a) -> (m (Dual r) -> m r) -> m (Dual r) -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dual r -> r) -> m (Dual r) -> m r
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Dual r -> r
forall a. Dual a -> a
getDual
  {-# INLINE effective #-}
  ineffective :: Backwards f a -> m (Dual r)
ineffective = (r -> Dual r) -> m r -> m (Dual r)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM r -> Dual r
forall a. a -> Dual a
Dual (m r -> m (Dual r))
-> (Backwards f a -> m r) -> Backwards f a -> m (Dual r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> m r
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
f a -> m r
ineffective (f a -> m r) -> (Backwards f a -> f a) -> Backwards f a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Backwards f a -> f a
forall k (f :: k -> *) (a :: k). Backwards f a -> f a
forwards
  {-# INLINE ineffective #-}

instance Effective Identity r (Const r) where
  effective :: Identity r -> Const r a
effective = r -> Const r a
forall k a (b :: k). a -> Const a b
Const (r -> Const r a) -> (Identity r -> r) -> Identity r -> Const r a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Identity r -> r
forall a. Identity a -> a
runIdentity
  {-# INLINE effective #-}
  ineffective :: Const r a -> Identity r
ineffective = r -> Identity r
forall a. a -> Identity a
Identity (r -> Identity r) -> (Const r a -> r) -> Const r a -> Identity r
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Const r a -> r
forall a k (b :: k). Const a b -> a
getConst
  {-# INLINE ineffective #-}

instance Effective m r f => Effective m r (AlongsideLeft f b) where
  effective :: m r -> AlongsideLeft f b a
effective = f (a, b) -> AlongsideLeft f b a
forall (f :: * -> *) b a. f (a, b) -> AlongsideLeft f b a
AlongsideLeft (f (a, b) -> AlongsideLeft f b a)
-> (m r -> f (a, b)) -> m r -> AlongsideLeft f b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m r -> f (a, b)
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
m r -> f a
effective
  {-# INLINE effective #-}
  ineffective :: AlongsideLeft f b a -> m r
ineffective = f (a, b) -> m r
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
f a -> m r
ineffective (f (a, b) -> m r)
-> (AlongsideLeft f b a -> f (a, b)) -> AlongsideLeft f b a -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlongsideLeft f b a -> f (a, b)
forall (f :: * -> *) b a. AlongsideLeft f b a -> f (a, b)
getAlongsideLeft
  {-# INLINE ineffective #-}

instance Effective m r f => Effective m r (AlongsideRight f b) where
  effective :: m r -> AlongsideRight f b a
effective = f (b, a) -> AlongsideRight f b a
forall (f :: * -> *) a b. f (a, b) -> AlongsideRight f a b
AlongsideRight (f (b, a) -> AlongsideRight f b a)
-> (m r -> f (b, a)) -> m r -> AlongsideRight f b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m r -> f (b, a)
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
m r -> f a
effective
  {-# INLINE effective #-}
  ineffective :: AlongsideRight f b a -> m r
ineffective = f (b, a) -> m r
forall (m :: * -> *) r (f :: * -> *) a.
Effective m r f =>
f a -> m r
ineffective (f (b, a) -> m r)
-> (AlongsideRight f b a -> f (b, a))
-> AlongsideRight f b a
-> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlongsideRight f b a -> f (b, a)
forall (f :: * -> *) a b. AlongsideRight f a b -> f (a, b)
getAlongsideRight
  {-# INLINE ineffective #-}

------------------------------------------------------------------------------
-- Effect
------------------------------------------------------------------------------

-- | Wrap a monadic effect with a phantom type argument.
newtype Effect m r a = Effect { Effect m r a -> m r
getEffect :: m r }
-- type role Effect representational nominal phantom

instance Functor (Effect m r) where
  fmap :: (a -> b) -> Effect m r a -> Effect m r b
fmap a -> b
_ (Effect m r
m) = m r -> Effect m r b
forall (m :: * -> *) r a. m r -> Effect m r a
Effect m r
m
  {-# INLINE fmap #-}

instance Contravariant (Effect m r) where
  contramap :: (a -> b) -> Effect m r b -> Effect m r a
contramap a -> b
_ (Effect m r
m) = m r -> Effect m r a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect m r
m
  {-# INLINE contramap #-}

instance Monad m => Effective m r (Effect m r) where
  effective :: m r -> Effect m r a
effective = m r -> Effect m r a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect
  {-# INLINE effective #-}
  ineffective :: Effect m r a -> m r
ineffective = Effect m r a -> m r
forall (m :: * -> *) r a. Effect m r a -> m r
getEffect
  {-# INLINE ineffective #-}

instance (Apply m, Semigroup r) => Semigroup (Effect m r a) where
  Effect m r
ma <> :: Effect m r a -> Effect m r a -> Effect m r a
<> Effect m r
mb = m r -> Effect m r a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect ((r -> r -> r) -> m r -> m r -> m r
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2 r -> r -> r
forall a. Semigroup a => a -> a -> a
(<>) m r
ma m r
mb)
  {-# INLINE (<>) #-}

instance (Apply m, Monad m, Monoid r) => Monoid (Effect m r a) where
  mempty :: Effect m r a
mempty = m r -> Effect m r a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect (r -> m r
forall (m :: * -> *) a. Monad m => a -> m a
return r
forall a. Monoid a => a
mempty)
  {-# INLINE mempty #-}
#if !(MIN_VERSION_base(4,11,0))
  Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb)
  {-# INLINE mappend #-}
#endif

instance (Apply m, Semigroup r) => Apply (Effect m r) where
  Effect m r
ma <.> :: Effect m r (a -> b) -> Effect m r a -> Effect m r b
<.> Effect m r
mb = m r -> Effect m r b
forall (m :: * -> *) r a. m r -> Effect m r a
Effect ((r -> r -> r) -> m r -> m r -> m r
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2 r -> r -> r
forall a. Semigroup a => a -> a -> a
(<>) m r
ma m r
mb)
  {-# INLINE (<.>) #-}

instance (Monad m, Monoid r) => Applicative (Effect m r) where
  pure :: a -> Effect m r a
pure a
_ = m r -> Effect m r a
forall (m :: * -> *) r a. m r -> Effect m r a
Effect (r -> m r
forall (m :: * -> *) a. Monad m => a -> m a
return r
forall a. Monoid a => a
mempty)
  {-# INLINE pure #-}
  Effect m r
ma <*> :: Effect m r (a -> b) -> Effect m r a -> Effect m r b
<*> Effect m r
mb = m r -> Effect m r b
forall (m :: * -> *) r a. m r -> Effect m r a
Effect ((r -> r -> r) -> m r -> m r -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> r -> r
forall a. Monoid a => a -> a -> a
mappend m r
ma m r
mb)
  {-# INLINE (<*>) #-}