{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Trustworthy #-}

{-# OPTIONS_GHC -Wno-orphans -Wno-warnings-deprecations #-}
-----------------------------------------------------------------------------

-- |

-- Module      :  Control.Lens.Internal.Zoom

-- Copyright   :  (C) 2012-2016 Edward Kmett

-- License     :  BSD-style (see the file LICENSE)

-- Maintainer  :  Edward Kmett <ekmett@gmail.com>

-- Stability   :  experimental

-- Portability :  non-portable

--

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

module Control.Lens.Internal.Zoom
  (
  -- * Zoom

    Focusing(..)
  , FocusingWith(..)
  , FocusingPlus(..)
  , FocusingOn(..)
  , FocusingMay(..), May(..)
  , FocusingErr(..), Err(..)
  , FocusingFree(..), Freed(..)
  -- * Magnify

  , Effect(..)
  , EffectRWS(..)
  ) where

import Prelude ()

import Control.Lens.Internal.Prelude
import Control.Monad
import Control.Monad.Trans.Free
import Data.Functor.Bind

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

-- Focusing

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


-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.State.StateT'.

newtype Focusing m s a = Focusing { forall (m :: * -> *) s a. Focusing m s a -> m (s, a)
unfocusing :: m (s, a) }

instance Monad m => Functor (Focusing m s) where
  fmap :: forall a b. (a -> b) -> Focusing m s a -> Focusing m s b
fmap a -> b
f (Focusing m (s, a)
m) = forall (m :: * -> *) s a. m (s, a) -> Focusing m s a
Focusing forall a b. (a -> b) -> a -> b
$ do
     (s
s, a
a) <- m (s, a)
m
     forall (m :: * -> *) a. Monad m => a -> m a
return (s
s, a -> b
f a
a)
  {-# INLINE fmap #-}

instance (Monad m, Semigroup s) => Apply (Focusing m s) where
  Focusing m (s, a -> b)
mf <.> :: forall a b.
Focusing m s (a -> b) -> Focusing m s a -> Focusing m s b
<.> Focusing m (s, a)
ma = forall (m :: * -> *) s a. m (s, a) -> Focusing m s a
Focusing forall a b. (a -> b) -> a -> b
$ do
    (s
s, a -> b
f) <- m (s, a -> b)
mf
    (s
s', a
a) <- m (s, a)
ma
    forall (m :: * -> *) a. Monad m => a -> m a
return (s
s forall a. Semigroup a => a -> a -> a
<> s
s', a -> b
f a
a)
  {-# INLINE (<.>) #-}

instance (Monad m, Monoid s) => Applicative (Focusing m s) where
  pure :: forall a. a -> Focusing m s a
pure a
a = forall (m :: * -> *) s a. m (s, a) -> Focusing m s a
Focusing (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, a
a))
  {-# INLINE pure #-}
  Focusing m (s, a -> b)
mf <*> :: forall a b.
Focusing m s (a -> b) -> Focusing m s a -> Focusing m s b
<*> Focusing m (s, a)
ma = forall (m :: * -> *) s a. m (s, a) -> Focusing m s a
Focusing forall a b. (a -> b) -> a -> b
$ do
    (s
s, a -> b
f) <- m (s, a -> b)
mf
    (s
s', a
a) <- m (s, a)
ma
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a -> a -> a
mappend s
s s
s', a -> b
f a
a)
  {-# INLINE (<*>) #-}

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

-- FocusingWith

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


-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.RWS.RWST'.

newtype FocusingWith w m s a = FocusingWith { forall w (m :: * -> *) s a. FocusingWith w m s a -> m (s, a, w)
unfocusingWith :: m (s, a, w) }

instance Monad m => Functor (FocusingWith w m s) where
  fmap :: forall a b.
(a -> b) -> FocusingWith w m s a -> FocusingWith w m s b
fmap a -> b
f (FocusingWith m (s, a, w)
m) = forall w (m :: * -> *) s a. m (s, a, w) -> FocusingWith w m s a
FocusingWith forall a b. (a -> b) -> a -> b
$ do
     (s
s, a
a, w
w) <- m (s, a, w)
m
     forall (m :: * -> *) a. Monad m => a -> m a
return (s
s, a -> b
f a
a, w
w)
  {-# INLINE fmap #-}

instance (Monad m, Semigroup s, Semigroup w) => Apply (FocusingWith w m s) where
  FocusingWith m (s, a -> b, w)
mf <.> :: forall a b.
FocusingWith w m s (a -> b)
-> FocusingWith w m s a -> FocusingWith w m s b
<.> FocusingWith m (s, a, w)
ma = forall w (m :: * -> *) s a. m (s, a, w) -> FocusingWith w m s a
FocusingWith forall a b. (a -> b) -> a -> b
$ do
    (s
s, a -> b
f, w
w) <- m (s, a -> b, w)
mf
    (s
s', a
a, w
w') <- m (s, a, w)
ma
    forall (m :: * -> *) a. Monad m => a -> m a
return (s
s forall a. Semigroup a => a -> a -> a
<> s
s', a -> b
f a
a, w
w forall a. Semigroup a => a -> a -> a
<> w
w')
  {-# INLINE (<.>) #-}

instance (Monad m, Monoid s, Monoid w) => Applicative (FocusingWith w m s) where
  pure :: forall a. a -> FocusingWith w m s a
pure a
a = forall w (m :: * -> *) s a. m (s, a, w) -> FocusingWith w m s a
FocusingWith (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, a
a, forall a. Monoid a => a
mempty))
  {-# INLINE pure #-}
  FocusingWith m (s, a -> b, w)
mf <*> :: forall a b.
FocusingWith w m s (a -> b)
-> FocusingWith w m s a -> FocusingWith w m s b
<*> FocusingWith m (s, a, w)
ma = forall w (m :: * -> *) s a. m (s, a, w) -> FocusingWith w m s a
FocusingWith forall a b. (a -> b) -> a -> b
$ do
    (s
s, a -> b
f, w
w) <- m (s, a -> b, w)
mf
    (s
s', a
a, w
w') <- m (s, a, w)
ma
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a -> a -> a
mappend s
s s
s', a -> b
f a
a, forall a. Monoid a => a -> a -> a
mappend w
w w
w')
  {-# INLINE (<*>) #-}

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

-- FocusingPlus

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


-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.Writer.WriterT'.

newtype FocusingPlus w k s a = FocusingPlus { forall w (k :: * -> * -> *) s a. FocusingPlus w k s a -> k (s, w) a
unfocusingPlus :: k (s, w) a }

instance Functor (k (s, w)) => Functor (FocusingPlus w k s) where
  fmap :: forall a b.
(a -> b) -> FocusingPlus w k s a -> FocusingPlus w k s b
fmap a -> b
f (FocusingPlus k (s, w) a
as) = forall w (k :: * -> * -> *) s a. k (s, w) a -> FocusingPlus w k s a
FocusingPlus (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f k (s, w) a
as)
  {-# INLINE fmap #-}

instance Apply (k (s, w)) => Apply (FocusingPlus w k s) where
  FocusingPlus k (s, w) (a -> b)
kf <.> :: forall a b.
FocusingPlus w k s (a -> b)
-> FocusingPlus w k s a -> FocusingPlus w k s b
<.> FocusingPlus k (s, w) a
ka = forall w (k :: * -> * -> *) s a. k (s, w) a -> FocusingPlus w k s a
FocusingPlus (k (s, w) (a -> b)
kf forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> k (s, w) a
ka)
  {-# INLINE (<.>) #-}

instance Applicative (k (s, w)) => Applicative (FocusingPlus w k s) where
  pure :: forall a. a -> FocusingPlus w k s a
pure = forall w (k :: * -> * -> *) s a. k (s, w) a -> FocusingPlus w k s a
FocusingPlus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  FocusingPlus k (s, w) (a -> b)
kf <*> :: forall a b.
FocusingPlus w k s (a -> b)
-> FocusingPlus w k s a -> FocusingPlus w k s b
<*> FocusingPlus k (s, w) a
ka = forall w (k :: * -> * -> *) s a. k (s, w) a -> FocusingPlus w k s a
FocusingPlus (k (s, w) (a -> b)
kf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> k (s, w) a
ka)
  {-# INLINE (<*>) #-}

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

-- FocusingOn

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


-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.Trans.Maybe.MaybeT' or 'Control.Monad.Trans.List.ListT'.

newtype FocusingOn f k s a = FocusingOn { forall (f :: * -> *) (k :: * -> * -> *) s a.
FocusingOn f k s a -> k (f s) a
unfocusingOn :: k (f s) a }

instance Functor (k (f s)) => Functor (FocusingOn f k s) where
  fmap :: forall a b. (a -> b) -> FocusingOn f k s a -> FocusingOn f k s b
fmap a -> b
f (FocusingOn k (f s) a
as) = forall (f :: * -> *) (k :: * -> * -> *) s a.
k (f s) a -> FocusingOn f k s a
FocusingOn (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f k (f s) a
as)
  {-# INLINE fmap #-}

instance Apply (k (f s)) => Apply (FocusingOn f k s) where
  FocusingOn k (f s) (a -> b)
kf <.> :: forall a b.
FocusingOn f k s (a -> b)
-> FocusingOn f k s a -> FocusingOn f k s b
<.> FocusingOn k (f s) a
ka = forall (f :: * -> *) (k :: * -> * -> *) s a.
k (f s) a -> FocusingOn f k s a
FocusingOn (k (f s) (a -> b)
kf forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> k (f s) a
ka)
  {-# INLINE (<.>) #-}

instance Applicative (k (f s)) => Applicative (FocusingOn f k s) where
  pure :: forall a. a -> FocusingOn f k s a
pure = forall (f :: * -> *) (k :: * -> * -> *) s a.
k (f s) a -> FocusingOn f k s a
FocusingOn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  FocusingOn k (f s) (a -> b)
kf <*> :: forall a b.
FocusingOn f k s (a -> b)
-> FocusingOn f k s a -> FocusingOn f k s b
<*> FocusingOn k (f s) a
ka = forall (f :: * -> *) (k :: * -> * -> *) s a.
k (f s) a -> FocusingOn f k s a
FocusingOn (k (f s) (a -> b)
kf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> k (f s) a
ka)
  {-# INLINE (<*>) #-}

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

-- May

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


-- | Make a 'Monoid' out of 'Maybe' for error handling.

newtype May a = May { forall a. May a -> Maybe a
getMay :: Maybe a }

instance Semigroup a => Semigroup (May a) where
  May Maybe a
Nothing <> :: May a -> May a -> May a
<> May a
_ = forall a. Maybe a -> May a
May forall a. Maybe a
Nothing
  May a
_ <> May Maybe a
Nothing = forall a. Maybe a -> May a
May forall a. Maybe a
Nothing
  May (Just a
a) <> May (Just a
b) = forall a. Maybe a -> May a
May (forall a. a -> Maybe a
Just (a
a forall a. Semigroup a => a -> a -> a
<> a
b))
  {-# INLINE (<>) #-}

instance Monoid a => Monoid (May a) where
  mempty :: May a
mempty = forall a. Maybe a -> May a
May (forall a. a -> Maybe a
Just forall a. Monoid a => a
mempty)
  {-# INLINE mempty #-}
#if !(MIN_VERSION_base(4,11,0))
  May Nothing `mappend` _ = May Nothing
  _ `mappend` May Nothing = May Nothing
  May (Just a) `mappend` May (Just b) = May (Just (mappend a b))
  {-# INLINE mappend #-}
#endif

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

-- FocusingMay

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


-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.Error.ErrorT'.

newtype FocusingMay k s a = FocusingMay { forall (k :: * -> * -> *) s a. FocusingMay k s a -> k (May s) a
unfocusingMay :: k (May s) a }

instance Functor (k (May s)) => Functor (FocusingMay k s) where
  fmap :: forall a b. (a -> b) -> FocusingMay k s a -> FocusingMay k s b
fmap a -> b
f (FocusingMay k (May s) a
as) = forall (k :: * -> * -> *) s a. k (May s) a -> FocusingMay k s a
FocusingMay (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f k (May s) a
as)
  {-# INLINE fmap #-}

instance Apply (k (May s)) => Apply (FocusingMay k s) where
  FocusingMay k (May s) (a -> b)
kf <.> :: forall a b.
FocusingMay k s (a -> b) -> FocusingMay k s a -> FocusingMay k s b
<.> FocusingMay k (May s) a
ka = forall (k :: * -> * -> *) s a. k (May s) a -> FocusingMay k s a
FocusingMay (k (May s) (a -> b)
kf forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> k (May s) a
ka)
  {-# INLINE (<.>) #-}

instance Applicative (k (May s)) => Applicative (FocusingMay k s) where
  pure :: forall a. a -> FocusingMay k s a
pure = forall (k :: * -> * -> *) s a. k (May s) a -> FocusingMay k s a
FocusingMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  FocusingMay k (May s) (a -> b)
kf <*> :: forall a b.
FocusingMay k s (a -> b) -> FocusingMay k s a -> FocusingMay k s b
<*> FocusingMay k (May s) a
ka = forall (k :: * -> * -> *) s a. k (May s) a -> FocusingMay k s a
FocusingMay (k (May s) (a -> b)
kf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> k (May s) a
ka)
  {-# INLINE (<*>) #-}

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

-- Err

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


-- | Make a 'Monoid' out of 'Either' for error handling.

newtype Err e a = Err { forall e a. Err e a -> Either e a
getErr :: Either e a }

instance Semigroup a => Semigroup (Err e a) where
  Err (Left e
e) <> :: Err e a -> Err e a -> Err e a
<> Err e a
_ = forall e a. Either e a -> Err e a
Err (forall a b. a -> Either a b
Left e
e)
  Err e a
_ <> Err (Left e
e) = forall e a. Either e a -> Err e a
Err (forall a b. a -> Either a b
Left e
e)
  Err (Right a
a) <> Err (Right a
b) = forall e a. Either e a -> Err e a
Err (forall a b. b -> Either a b
Right (a
a forall a. Semigroup a => a -> a -> a
<> a
b))
  {-# INLINE (<>) #-}

instance Monoid a => Monoid (Err e a) where
  mempty :: Err e a
mempty = forall e a. Either e a -> Err e a
Err (forall a b. b -> Either a b
Right forall a. Monoid a => a
mempty)
  {-# INLINE mempty #-}
#if !(MIN_VERSION_base(4,11,0))
  Err (Left e) `mappend` _ = Err (Left e)
  _ `mappend` Err (Left e) = Err (Left e)
  Err (Right a) `mappend` Err (Right b) = Err (Right (mappend a b))
  {-# INLINE mappend #-}
#endif

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

-- FocusingErr

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


-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.Error.ErrorT'.

newtype FocusingErr e k s a = FocusingErr { forall e (k :: * -> * -> *) s a.
FocusingErr e k s a -> k (Err e s) a
unfocusingErr :: k (Err e s) a }

instance Functor (k (Err e s)) => Functor (FocusingErr e k s) where
  fmap :: forall a b. (a -> b) -> FocusingErr e k s a -> FocusingErr e k s b
fmap a -> b
f (FocusingErr k (Err e s) a
as) = forall e (k :: * -> * -> *) s a.
k (Err e s) a -> FocusingErr e k s a
FocusingErr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f k (Err e s) a
as)
  {-# INLINE fmap #-}

instance Apply (k (Err e s)) => Apply (FocusingErr e k s) where
  FocusingErr k (Err e s) (a -> b)
kf <.> :: forall a b.
FocusingErr e k s (a -> b)
-> FocusingErr e k s a -> FocusingErr e k s b
<.> FocusingErr k (Err e s) a
ka = forall e (k :: * -> * -> *) s a.
k (Err e s) a -> FocusingErr e k s a
FocusingErr (k (Err e s) (a -> b)
kf forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> k (Err e s) a
ka)
  {-# INLINE (<.>) #-}

instance Applicative (k (Err e s)) => Applicative (FocusingErr e k s) where
  pure :: forall a. a -> FocusingErr e k s a
pure = forall e (k :: * -> * -> *) s a.
k (Err e s) a -> FocusingErr e k s a
FocusingErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  FocusingErr k (Err e s) (a -> b)
kf <*> :: forall a b.
FocusingErr e k s (a -> b)
-> FocusingErr e k s a -> FocusingErr e k s b
<*> FocusingErr k (Err e s) a
ka = forall e (k :: * -> * -> *) s a.
k (Err e s) a -> FocusingErr e k s a
FocusingErr (k (Err e s) (a -> b)
kf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> k (Err e s) a
ka)
  {-# INLINE (<*>) #-}

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

-- Freed

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


-- | Make a 'Monoid' out of 'FreeF' for result collection.


newtype Freed f m a = Freed { forall (f :: * -> *) (m :: * -> *) a.
Freed f m a -> FreeF f a (FreeT f m a)
getFreed :: FreeF f a (FreeT f m a) }

instance (Applicative f, Semigroup a, Monad m) => Semigroup (Freed f m a) where
  Freed (Pure a
a) <> :: Freed f m a -> Freed f m a -> Freed f m a
<> Freed (Pure a
b) = forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. a -> FreeF f a b
Pure forall a b. (a -> b) -> a -> b
$ a
a forall a. Semigroup a => a -> a -> a
<> a
b
  Freed (Pure a
a) <> Freed (Free f (FreeT f m a)
g) = forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Semigroup a => a -> a -> a
(<>)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return a
a) f (FreeT f m a)
g
  Freed (Free f (FreeT f m a)
f) <> Freed (Pure a
b) = forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Semigroup a => a -> a -> a
(<>)) f (FreeT f m a)
f (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return a
b)
  Freed (Free f (FreeT f m a)
f) <> Freed (Free f (FreeT f m a)
g) = forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Semigroup a => a -> a -> a
(<>)) f (FreeT f m a)
f f (FreeT f m a)
g

instance (Applicative f, Monoid a, Monad m) => Monoid (Freed f m a) where
  mempty :: Freed f m a
mempty = forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. a -> FreeF f a b
Pure forall a. Monoid a => a
mempty

#if !(MIN_VERSION_base(4,11,0))
  Freed (Pure a) `mappend` Freed (Pure b) = Freed $ Pure $ a `mappend` b
  Freed (Pure a) `mappend` Freed (Free g) = Freed $ Free $ liftA2 (liftM2 mappend) (pure $ return a) g
  Freed (Free f) `mappend` Freed (Pure b) = Freed $ Free $ liftA2 (liftM2 mappend) f (pure $ return b)
  Freed (Free f) `mappend` Freed (Free g) = Freed $ Free $ liftA2 (liftM2 mappend) f g
#endif

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

-- FocusingFree

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


-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into

-- 'Control.Monad.Trans.FreeT'

newtype FocusingFree f m k s a = FocusingFree { forall (f :: * -> *) (m :: * -> *) (k :: * -> * -> *) s a.
FocusingFree f m k s a -> k (Freed f m s) a
unfocusingFree :: k (Freed f m s) a }

instance Functor (k (Freed f m s)) => Functor (FocusingFree f m k s) where
  fmap :: forall a b.
(a -> b) -> FocusingFree f m k s a -> FocusingFree f m k s b
fmap a -> b
f (FocusingFree k (Freed f m s) a
as) = forall (f :: * -> *) (m :: * -> *) (k :: * -> * -> *) s a.
k (Freed f m s) a -> FocusingFree f m k s a
FocusingFree (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f k (Freed f m s) a
as)
  {-# INLINE fmap #-}

instance Apply (k (Freed f m s)) => Apply (FocusingFree f m k s) where
  FocusingFree k (Freed f m s) (a -> b)
kf <.> :: forall a b.
FocusingFree f m k s (a -> b)
-> FocusingFree f m k s a -> FocusingFree f m k s b
<.> FocusingFree k (Freed f m s) a
ka = forall (f :: * -> *) (m :: * -> *) (k :: * -> * -> *) s a.
k (Freed f m s) a -> FocusingFree f m k s a
FocusingFree (k (Freed f m s) (a -> b)
kf forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> k (Freed f m s) a
ka)
  {-# INLINE (<.>) #-}

instance Applicative (k (Freed f m s)) => Applicative (FocusingFree f m k s) where
  pure :: forall a. a -> FocusingFree f m k s a
pure = forall (f :: * -> *) (m :: * -> *) (k :: * -> * -> *) s a.
k (Freed f m s) a -> FocusingFree f m k s a
FocusingFree forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  FocusingFree k (Freed f m s) (a -> b)
kf <*> :: forall a b.
FocusingFree f m k s (a -> b)
-> FocusingFree f m k s a -> FocusingFree f m k s b
<*> FocusingFree k (Freed f m s) a
ka = forall (f :: * -> *) (m :: * -> *) (k :: * -> * -> *) s a.
k (Freed f m s) a -> FocusingFree f m k s a
FocusingFree (k (Freed f m s) (a -> b)
kf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> k (Freed f m s) a
ka)
  {-# INLINE (<*>) #-}

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

--- Effect

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


-- | Wrap a monadic effect with a phantom type argument.

newtype Effect m r a = Effect { forall (m :: * -> *) r a. Effect m r a -> m r
getEffect :: m r }
-- type role Effect representational nominal phantom


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

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

instance (Monad 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 = forall (m :: * -> *) r a. m r -> Effect m r a
Effect (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Semigroup a => a -> a -> a
(<>) m r
ma m r
mb)
  {-# INLINE (<>) #-}

instance (Monad m, Monoid r) => Monoid (Effect m r a) where
  mempty :: Effect m r a
mempty = forall (m :: * -> *) r a. m r -> Effect m r a
Effect (forall (m :: * -> *) a. Monad m => a -> m a
return 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 <.> :: forall a b. Effect m r (a -> b) -> Effect m r a -> Effect m r b
<.> Effect m r
mb = forall (m :: * -> *) r a. m r -> Effect m r a
Effect (forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2 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 :: forall a. a -> Effect m r a
pure a
_ = forall (m :: * -> *) r a. m r -> Effect m r a
Effect (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty)
  {-# INLINE pure #-}
  Effect m r
ma <*> :: forall a b. Effect m r (a -> b) -> Effect m r a -> Effect m r b
<*> Effect m r
mb = forall (m :: * -> *) r a. m r -> Effect m r a
Effect (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Monoid a => a -> a -> a
mappend m r
ma m r
mb)
  {-# INLINE (<*>) #-}

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

-- EffectRWS

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


-- | Wrap a monadic effect with a phantom type argument. Used when magnifying 'Control.Monad.RWS.RWST'.

newtype EffectRWS w st m s a = EffectRWS { forall w st (m :: * -> *) s a.
EffectRWS w st m s a -> st -> m (s, st, w)
getEffectRWS :: st -> m (s,st,w) }

instance Functor (EffectRWS w st m s) where
  fmap :: forall a b.
(a -> b) -> EffectRWS w st m s a -> EffectRWS w st m s b
fmap a -> b
_ (EffectRWS st -> m (s, st, w)
m) = forall w st (m :: * -> *) s a.
(st -> m (s, st, w)) -> EffectRWS w st m s a
EffectRWS st -> m (s, st, w)
m
  {-# INLINE fmap #-}

instance (Semigroup s, Semigroup w, Bind m) => Apply (EffectRWS w st m s) where
  EffectRWS st -> m (s, st, w)
m <.> :: forall a b.
EffectRWS w st m s (a -> b)
-> EffectRWS w st m s a -> EffectRWS w st m s b
<.> EffectRWS st -> m (s, st, w)
n = forall w st (m :: * -> *) s a.
(st -> m (s, st, w)) -> EffectRWS w st m s a
EffectRWS forall a b. (a -> b) -> a -> b
$ \st
st -> st -> m (s, st, w)
m st
st forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- \ (s
s,st
t,w
w) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(s
s',st
u,w
w') -> (s
s forall a. Semigroup a => a -> a -> a
<> s
s', st
u, w
w forall a. Semigroup a => a -> a -> a
<> w
w')) (st -> m (s, st, w)
n st
t)
  {-# INLINE (<.>) #-}

instance (Monoid s, Monoid w, Monad m) => Applicative (EffectRWS w st m s) where
  pure :: forall a. a -> EffectRWS w st m s a
pure a
_ = forall w st (m :: * -> *) s a.
(st -> m (s, st, w)) -> EffectRWS w st m s a
EffectRWS forall a b. (a -> b) -> a -> b
$ \st
st -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, st
st, forall a. Monoid a => a
mempty)
  {-# INLINE pure #-}
  EffectRWS st -> m (s, st, w)
m <*> :: forall a b.
EffectRWS w st m s (a -> b)
-> EffectRWS w st m s a -> EffectRWS w st m s b
<*> EffectRWS st -> m (s, st, w)
n = forall w st (m :: * -> *) s a.
(st -> m (s, st, w)) -> EffectRWS w st m s a
EffectRWS forall a b. (a -> b) -> a -> b
$ \st
st -> st -> m (s, st, w)
m st
st forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (s
s,st
t,w
w) -> st -> m (s, st, w)
n st
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (s
s',st
u,w
w') -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a -> a -> a
mappend s
s s
s', st
u, forall a. Monoid a => a -> a -> a
mappend w
w w
w')
  {-# INLINE (<*>) #-}

instance Contravariant (EffectRWS w st m s) where
  contramap :: forall a' a.
(a' -> a) -> EffectRWS w st m s a -> EffectRWS w st m s a'
contramap a' -> a
_ (EffectRWS st -> m (s, st, w)
m) = forall w st (m :: * -> *) s a.
(st -> m (s, st, w)) -> EffectRWS w st m s a
EffectRWS st -> m (s, st, w)
m
  {-# INLINE contramap #-}