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

{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-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 { Focusing m s a -> m (s, a)
unfocusing :: m (s, a) }

instance Monad m => Functor (Focusing m s) where
  fmap :: (a -> b) -> Focusing m s a -> Focusing m s b
fmap a -> b
f (Focusing m (s, a)
m) = m (s, b) -> Focusing m s b
forall (m :: * -> *) s a. m (s, a) -> Focusing m s a
Focusing (m (s, b) -> Focusing m s b) -> m (s, b) -> Focusing m s b
forall a b. (a -> b) -> a -> b
$ do
     (s
s, a
a) <- m (s, a)
m
     (s, b) -> m (s, b)
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 <.> :: Focusing m s (a -> b) -> Focusing m s a -> Focusing m s b
<.> Focusing m (s, a)
ma = m (s, b) -> Focusing m s b
forall (m :: * -> *) s a. m (s, a) -> Focusing m s a
Focusing (m (s, b) -> Focusing m s b) -> m (s, b) -> Focusing m s b
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
    (s, b) -> m (s, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
s s -> 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 :: a -> Focusing m s a
pure a
a = m (s, a) -> Focusing m s a
forall (m :: * -> *) s a. m (s, a) -> Focusing m s a
Focusing ((s, a) -> m (s, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
forall a. Monoid a => a
mempty, a
a))
  {-# INLINE pure #-}
  Focusing m (s, a -> b)
mf <*> :: Focusing m s (a -> b) -> Focusing m s a -> Focusing m s b
<*> Focusing m (s, a)
ma = m (s, b) -> Focusing m s b
forall (m :: * -> *) s a. m (s, a) -> Focusing m s a
Focusing (m (s, b) -> Focusing m s b) -> m (s, b) -> Focusing m s b
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
    (s, b) -> m (s, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> s -> s
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 { FocusingWith w m s a -> m (s, a, w)
unfocusingWith :: m (s, a, w) }

instance Monad m => Functor (FocusingWith w m s) where
  fmap :: (a -> b) -> FocusingWith w m s a -> FocusingWith w m s b
fmap a -> b
f (FocusingWith m (s, a, w)
m) = m (s, b, w) -> FocusingWith w m s b
forall w (m :: * -> *) s a. m (s, a, w) -> FocusingWith w m s a
FocusingWith (m (s, b, w) -> FocusingWith w m s b)
-> m (s, b, w) -> FocusingWith w m s b
forall a b. (a -> b) -> a -> b
$ do
     (s
s, a
a, w
w) <- m (s, a, w)
m
     (s, b, w) -> m (s, b, w)
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 <.> :: FocusingWith w m s (a -> b)
-> FocusingWith w m s a -> FocusingWith w m s b
<.> FocusingWith m (s, a, w)
ma = m (s, b, w) -> FocusingWith w m s b
forall w (m :: * -> *) s a. m (s, a, w) -> FocusingWith w m s a
FocusingWith (m (s, b, w) -> FocusingWith w m s b)
-> m (s, b, w) -> FocusingWith w m s b
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
    (s, b, w) -> m (s, b, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
s s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
s', a -> b
f a
a, w
w w -> 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 :: a -> FocusingWith w m s a
pure a
a = m (s, a, w) -> FocusingWith w m s a
forall w (m :: * -> *) s a. m (s, a, w) -> FocusingWith w m s a
FocusingWith ((s, a, w) -> m (s, a, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
forall a. Monoid a => a
mempty, a
a, w
forall a. Monoid a => a
mempty))
  {-# INLINE pure #-}
  FocusingWith m (s, a -> b, w)
mf <*> :: FocusingWith w m s (a -> b)
-> FocusingWith w m s a -> FocusingWith w m s b
<*> FocusingWith m (s, a, w)
ma = m (s, b, w) -> FocusingWith w m s b
forall w (m :: * -> *) s a. m (s, a, w) -> FocusingWith w m s a
FocusingWith (m (s, b, w) -> FocusingWith w m s b)
-> m (s, b, w) -> FocusingWith w m s b
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
    (s, b, w) -> m (s, b, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> s -> s
forall a. Monoid a => a -> a -> a
mappend s
s s
s', a -> b
f a
a, w -> w -> w
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 { 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 :: (a -> b) -> FocusingPlus w k s a -> FocusingPlus w k s b
fmap a -> b
f (FocusingPlus k (s, w) a
as) = k (s, w) b -> FocusingPlus w k s b
forall w (k :: * -> * -> *) s a. k (s, w) a -> FocusingPlus w k s a
FocusingPlus ((a -> b) -> k (s, w) a -> k (s, w) b
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 <.> :: FocusingPlus w k s (a -> b)
-> FocusingPlus w k s a -> FocusingPlus w k s b
<.> FocusingPlus k (s, w) a
ka = k (s, w) b -> FocusingPlus w k s b
forall w (k :: * -> * -> *) s a. k (s, w) a -> FocusingPlus w k s a
FocusingPlus (k (s, w) (a -> b)
kf k (s, w) (a -> b) -> k (s, w) a -> k (s, w) b
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 :: a -> FocusingPlus w k s a
pure = k (s, w) a -> FocusingPlus w k s a
forall w (k :: * -> * -> *) s a. k (s, w) a -> FocusingPlus w k s a
FocusingPlus (k (s, w) a -> FocusingPlus w k s a)
-> (a -> k (s, w) a) -> a -> FocusingPlus w k s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> k (s, w) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  FocusingPlus k (s, w) (a -> b)
kf <*> :: FocusingPlus w k s (a -> b)
-> FocusingPlus w k s a -> FocusingPlus w k s b
<*> FocusingPlus k (s, w) a
ka = k (s, w) b -> FocusingPlus w k s b
forall w (k :: * -> * -> *) s a. k (s, w) a -> FocusingPlus w k s a
FocusingPlus (k (s, w) (a -> b)
kf k (s, w) (a -> b) -> k (s, w) a -> k (s, w) b
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 { 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 :: (a -> b) -> FocusingOn f k s a -> FocusingOn f k s b
fmap a -> b
f (FocusingOn k (f s) a
as) = k (f s) b -> FocusingOn f k s b
forall (f :: * -> *) (k :: * -> * -> *) s a.
k (f s) a -> FocusingOn f k s a
FocusingOn ((a -> b) -> k (f s) a -> k (f s) b
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 <.> :: FocusingOn f k s (a -> b)
-> FocusingOn f k s a -> FocusingOn f k s b
<.> FocusingOn k (f s) a
ka = k (f s) b -> FocusingOn f k s b
forall (f :: * -> *) (k :: * -> * -> *) s a.
k (f s) a -> FocusingOn f k s a
FocusingOn (k (f s) (a -> b)
kf k (f s) (a -> b) -> k (f s) a -> k (f s) b
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 :: a -> FocusingOn f k s a
pure = k (f s) a -> FocusingOn f k s a
forall (f :: * -> *) (k :: * -> * -> *) s a.
k (f s) a -> FocusingOn f k s a
FocusingOn (k (f s) a -> FocusingOn f k s a)
-> (a -> k (f s) a) -> a -> FocusingOn f k s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> k (f s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  FocusingOn k (f s) (a -> b)
kf <*> :: FocusingOn f k s (a -> b)
-> FocusingOn f k s a -> FocusingOn f k s b
<*> FocusingOn k (f s) a
ka = k (f s) b -> FocusingOn f k s b
forall (f :: * -> *) (k :: * -> * -> *) s a.
k (f s) a -> FocusingOn f k s a
FocusingOn (k (f s) (a -> b)
kf k (f s) (a -> b) -> k (f s) a -> k (f s) b
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 { 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
_ = Maybe a -> May a
forall a. Maybe a -> May a
May Maybe a
forall a. Maybe a
Nothing
  May a
_ <> May Maybe a
Nothing = Maybe a -> May a
forall a. Maybe a -> May a
May Maybe a
forall a. Maybe a
Nothing
  May (Just a
a) <> May (Just a
b) = Maybe a -> May a
forall a. Maybe a -> May a
May (a -> Maybe a
forall a. a -> Maybe a
Just (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b))
  {-# INLINE (<>) #-}

instance Monoid a => Monoid (May a) where
  mempty :: May a
mempty = Maybe a -> May a
forall a. Maybe a -> May a
May (a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. Monoid a => a
mempty)
  {-# INLINE mempty #-}
  May Maybe a
Nothing mappend :: May a -> May a -> May a
`mappend` May a
_ = Maybe a -> May a
forall a. Maybe a -> May a
May Maybe a
forall a. Maybe a
Nothing
  May a
_ `mappend` May Maybe a
Nothing = Maybe a -> May a
forall a. Maybe a -> May a
May Maybe a
forall a. Maybe a
Nothing
  May (Just a
a) `mappend` May (Just a
b) = Maybe a -> May a
forall a. Maybe a -> May a
May (a -> Maybe a
forall a. a -> Maybe a
Just (a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a a
b))
  {-# INLINE mappend #-}

------------------------------------------------------------------------------
-- FocusingMay
------------------------------------------------------------------------------

-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.Error.ErrorT'.
newtype FocusingMay k s a = FocusingMay { FocusingMay k s a -> k (May s) a
unfocusingMay :: k (May s) a }

instance Functor (k (May s)) => Functor (FocusingMay k s) where
  fmap :: (a -> b) -> FocusingMay k s a -> FocusingMay k s b
fmap a -> b
f (FocusingMay k (May s) a
as) = k (May s) b -> FocusingMay k s b
forall (k :: * -> * -> *) s a. k (May s) a -> FocusingMay k s a
FocusingMay ((a -> b) -> k (May s) a -> k (May s) b
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 <.> :: FocusingMay k s (a -> b) -> FocusingMay k s a -> FocusingMay k s b
<.> FocusingMay k (May s) a
ka = k (May s) b -> FocusingMay k s b
forall (k :: * -> * -> *) s a. k (May s) a -> FocusingMay k s a
FocusingMay (k (May s) (a -> b)
kf k (May s) (a -> b) -> k (May s) a -> k (May s) b
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 :: a -> FocusingMay k s a
pure = k (May s) a -> FocusingMay k s a
forall (k :: * -> * -> *) s a. k (May s) a -> FocusingMay k s a
FocusingMay (k (May s) a -> FocusingMay k s a)
-> (a -> k (May s) a) -> a -> FocusingMay k s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> k (May s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  FocusingMay k (May s) (a -> b)
kf <*> :: FocusingMay k s (a -> b) -> FocusingMay k s a -> FocusingMay k s b
<*> FocusingMay k (May s) a
ka = k (May s) b -> FocusingMay k s b
forall (k :: * -> * -> *) s a. k (May s) a -> FocusingMay k s a
FocusingMay (k (May s) (a -> b)
kf k (May s) (a -> b) -> k (May s) a -> k (May s) b
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 { 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
_ = Either e a -> Err e a
forall e a. Either e a -> Err e a
Err (e -> Either e a
forall a b. a -> Either a b
Left e
e)
  Err e a
_ <> Err (Left e
e) = Either e a -> Err e a
forall e a. Either e a -> Err e a
Err (e -> Either e a
forall a b. a -> Either a b
Left e
e)
  Err (Right a
a) <> Err (Right a
b) = Either e a -> Err e a
forall e a. Either e a -> Err e a
Err (a -> Either e a
forall a b. b -> Either a b
Right (a
a a -> 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 = Either e a -> Err e a
forall e a. Either e a -> Err e a
Err (a -> Either e a
forall a b. b -> Either a b
Right a
forall a. Monoid a => a
mempty)
  {-# INLINE mempty #-}
  Err (Left e
e) mappend :: Err e a -> Err e a -> Err e a
`mappend` Err e a
_ = Either e a -> Err e a
forall e a. Either e a -> Err e a
Err (e -> Either e a
forall a b. a -> Either a b
Left e
e)
  Err e a
_ `mappend` Err (Left e
e) = Either e a -> Err e a
forall e a. Either e a -> Err e a
Err (e -> Either e a
forall a b. a -> Either a b
Left e
e)
  Err (Right a
a) `mappend` Err (Right a
b) = Either e a -> Err e a
forall e a. Either e a -> Err e a
Err (a -> Either e a
forall a b. b -> Either a b
Right (a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a a
b))
  {-# INLINE mappend #-}

------------------------------------------------------------------------------
-- FocusingErr
------------------------------------------------------------------------------

-- | Used by 'Control.Lens.Zoom.Zoom' to 'Control.Lens.Zoom.zoom' into 'Control.Monad.Error.ErrorT'.
newtype FocusingErr e k s a = FocusingErr { 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 :: (a -> b) -> FocusingErr e k s a -> FocusingErr e k s b
fmap a -> b
f (FocusingErr k (Err e s) a
as) = k (Err e s) b -> FocusingErr e k s b
forall e (k :: * -> * -> *) s a.
k (Err e s) a -> FocusingErr e k s a
FocusingErr ((a -> b) -> k (Err e s) a -> k (Err e s) b
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 <.> :: FocusingErr e k s (a -> b)
-> FocusingErr e k s a -> FocusingErr e k s b
<.> FocusingErr k (Err e s) a
ka = k (Err e s) b -> FocusingErr e k s b
forall e (k :: * -> * -> *) s a.
k (Err e s) a -> FocusingErr e k s a
FocusingErr (k (Err e s) (a -> b)
kf k (Err e s) (a -> b) -> k (Err e s) a -> k (Err e s) b
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 :: a -> FocusingErr e k s a
pure = k (Err e s) a -> FocusingErr e k s a
forall e (k :: * -> * -> *) s a.
k (Err e s) a -> FocusingErr e k s a
FocusingErr (k (Err e s) a -> FocusingErr e k s a)
-> (a -> k (Err e s) a) -> a -> FocusingErr e k s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> k (Err e s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  FocusingErr k (Err e s) (a -> b)
kf <*> :: FocusingErr e k s (a -> b)
-> FocusingErr e k s a -> FocusingErr e k s b
<*> FocusingErr k (Err e s) a
ka = k (Err e s) b -> FocusingErr e k s b
forall e (k :: * -> * -> *) s a.
k (Err e s) a -> FocusingErr e k s a
FocusingErr (k (Err e s) (a -> b)
kf k (Err e s) (a -> b) -> k (Err e s) a -> k (Err e s) b
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 { 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) = FreeF f a (FreeT f m a) -> Freed f m a
forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed (FreeF f a (FreeT f m a) -> Freed f m a)
-> FreeF f a (FreeT f m a) -> Freed f m a
forall a b. (a -> b) -> a -> b
$ a -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure (a -> FreeF f a (FreeT f m a)) -> a -> FreeF f a (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b
  Freed (Pure a
a) <> Freed (Free f (FreeT f m a)
g) = FreeF f a (FreeT f m a) -> Freed f m a
forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed (FreeF f a (FreeT f m a) -> Freed f m a)
-> FreeF f a (FreeT f m a) -> Freed f m a
forall a b. (a -> b) -> a -> b
$ f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f m a) -> FreeF f a (FreeT f m a))
-> f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ (FreeT f m a -> FreeT f m a -> FreeT f m a)
-> f (FreeT f m a) -> f (FreeT f m a) -> f (FreeT f m a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((a -> a -> a) -> FreeT f m a -> FreeT f m a -> FreeT f m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)) (FreeT f m a -> f (FreeT f m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FreeT f m a -> f (FreeT f m a)) -> FreeT f m a -> f (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ a -> FreeT f m a
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) = FreeF f a (FreeT f m a) -> Freed f m a
forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed (FreeF f a (FreeT f m a) -> Freed f m a)
-> FreeF f a (FreeT f m a) -> Freed f m a
forall a b. (a -> b) -> a -> b
$ f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f m a) -> FreeF f a (FreeT f m a))
-> f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ (FreeT f m a -> FreeT f m a -> FreeT f m a)
-> f (FreeT f m a) -> f (FreeT f m a) -> f (FreeT f m a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((a -> a -> a) -> FreeT f m a -> FreeT f m a -> FreeT f m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)) f (FreeT f m a)
f (FreeT f m a -> f (FreeT f m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FreeT f m a -> f (FreeT f m a)) -> FreeT f m a -> f (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ a -> FreeT f m a
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) = FreeF f a (FreeT f m a) -> Freed f m a
forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed (FreeF f a (FreeT f m a) -> Freed f m a)
-> FreeF f a (FreeT f m a) -> Freed f m a
forall a b. (a -> b) -> a -> b
$ f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f m a) -> FreeF f a (FreeT f m a))
-> f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ (FreeT f m a -> FreeT f m a -> FreeT f m a)
-> f (FreeT f m a) -> f (FreeT f m a) -> f (FreeT f m a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((a -> a -> a) -> FreeT f m a -> FreeT f m a -> FreeT f m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
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 = FreeF f a (FreeT f m a) -> Freed f m a
forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed (FreeF f a (FreeT f m a) -> Freed f m a)
-> FreeF f a (FreeT f m a) -> Freed f m a
forall a b. (a -> b) -> a -> b
$ a -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure a
forall a. Monoid a => a
mempty

  Freed (Pure a
a) mappend :: Freed f m a -> Freed f m a -> Freed f m a
`mappend` Freed (Pure a
b) = FreeF f a (FreeT f m a) -> Freed f m a
forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed (FreeF f a (FreeT f m a) -> Freed f m a)
-> FreeF f a (FreeT f m a) -> Freed f m a
forall a b. (a -> b) -> a -> b
$ a -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. a -> FreeF f a b
Pure (a -> FreeF f a (FreeT f m a)) -> a -> FreeF f a (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ a
a a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
b
  Freed (Pure a
a) `mappend` Freed (Free f (FreeT f m a)
g) = FreeF f a (FreeT f m a) -> Freed f m a
forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed (FreeF f a (FreeT f m a) -> Freed f m a)
-> FreeF f a (FreeT f m a) -> Freed f m a
forall a b. (a -> b) -> a -> b
$ f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f m a) -> FreeF f a (FreeT f m a))
-> f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ (FreeT f m a -> FreeT f m a -> FreeT f m a)
-> f (FreeT f m a) -> f (FreeT f m a) -> f (FreeT f m a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((a -> a -> a) -> FreeT f m a -> FreeT f m a -> FreeT f m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend) (FreeT f m a -> f (FreeT f m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FreeT f m a -> f (FreeT f m a)) -> FreeT f m a -> f (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ a -> FreeT f m a
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) `mappend` Freed (Pure a
b) = FreeF f a (FreeT f m a) -> Freed f m a
forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed (FreeF f a (FreeT f m a) -> Freed f m a)
-> FreeF f a (FreeT f m a) -> Freed f m a
forall a b. (a -> b) -> a -> b
$ f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f m a) -> FreeF f a (FreeT f m a))
-> f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ (FreeT f m a -> FreeT f m a -> FreeT f m a)
-> f (FreeT f m a) -> f (FreeT f m a) -> f (FreeT f m a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((a -> a -> a) -> FreeT f m a -> FreeT f m a -> FreeT f m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend) f (FreeT f m a)
f (FreeT f m a -> f (FreeT f m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FreeT f m a -> f (FreeT f m a)) -> FreeT f m a -> f (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ a -> FreeT f m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b)
  Freed (Free f (FreeT f m a)
f) `mappend` Freed (Free f (FreeT f m a)
g) = FreeF f a (FreeT f m a) -> Freed f m a
forall (f :: * -> *) (m :: * -> *) a.
FreeF f a (FreeT f m a) -> Freed f m a
Freed (FreeF f a (FreeT f m a) -> Freed f m a)
-> FreeF f a (FreeT f m a) -> Freed f m a
forall a b. (a -> b) -> a -> b
$ f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (f (FreeT f m a) -> FreeF f a (FreeT f m a))
-> f (FreeT f m a) -> FreeF f a (FreeT f m a)
forall a b. (a -> b) -> a -> b
$ (FreeT f m a -> FreeT f m a -> FreeT f m a)
-> f (FreeT f m a) -> f (FreeT f m a) -> f (FreeT f m a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((a -> a -> a) -> FreeT f m a -> FreeT f m a -> FreeT f m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend) f (FreeT f m a)
f f (FreeT f m a)
g

------------------------------------------------------------------------------
-- 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 { 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 :: (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) = k (Freed f m s) b -> FocusingFree f m k s b
forall (f :: * -> *) (m :: * -> *) (k :: * -> * -> *) s a.
k (Freed f m s) a -> FocusingFree f m k s a
FocusingFree ((a -> b) -> k (Freed f m s) a -> k (Freed f m s) b
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 <.> :: 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 = k (Freed f m s) b -> FocusingFree f m k s b
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 k (Freed f m s) (a -> b) -> k (Freed f m s) a -> k (Freed f m s) b
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 :: a -> FocusingFree f m k s a
pure = k (Freed f m s) a -> FocusingFree f m k s a
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 -> FocusingFree f m k s a)
-> (a -> k (Freed f m s) a) -> a -> FocusingFree f m k s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> k (Freed f m s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}
  FocusingFree k (Freed f m s) (a -> b)
kf <*> :: 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 = k (Freed f m s) b -> FocusingFree f m k s b
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 k (Freed f m s) (a -> b) -> k (Freed f m s) a -> k (Freed f m s) b
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 { 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, 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 (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> r -> r
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 = 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 #-}
  Effect m r
ma mappend :: Effect m r a -> Effect m r a -> Effect m r a
`mappend` 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 (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 mappend #-}

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 (<*>) #-}

------------------------------------------------------------------------------
-- 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 { 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 :: (a -> b) -> EffectRWS w st m s a -> EffectRWS w st m s b
fmap a -> b
_ (EffectRWS st -> m (s, st, w)
m) = (st -> m (s, st, w)) -> EffectRWS w st m s b
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 <.> :: 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 = (st -> m (s, st, w)) -> EffectRWS w st m s b
forall w st (m :: * -> *) s a.
(st -> m (s, st, w)) -> EffectRWS w st m s a
EffectRWS ((st -> m (s, st, w)) -> EffectRWS w st m s b)
-> (st -> m (s, st, w)) -> EffectRWS w st m s b
forall a b. (a -> b) -> a -> b
$ \st
st -> st -> m (s, st, w)
m st
st m (s, st, w) -> ((s, st, w) -> m (s, st, w)) -> m (s, st, w)
forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- \ (s
s,st
t,w
w) -> ((s, st, w) -> (s, st, w)) -> m (s, st, w) -> m (s, st, w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(s
s',st
u,w
w') -> (s
s s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
s', st
u, w
w w -> 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 :: a -> EffectRWS w st m s a
pure a
_ = (st -> m (s, st, w)) -> EffectRWS w st m s a
forall w st (m :: * -> *) s a.
(st -> m (s, st, w)) -> EffectRWS w st m s a
EffectRWS ((st -> m (s, st, w)) -> EffectRWS w st m s a)
-> (st -> m (s, st, w)) -> EffectRWS w st m s a
forall a b. (a -> b) -> a -> b
$ \st
st -> (s, st, w) -> m (s, st, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
forall a. Monoid a => a
mempty, st
st, w
forall a. Monoid a => a
mempty)
  {-# INLINE pure #-}
  EffectRWS st -> m (s, st, w)
m <*> :: 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 = (st -> m (s, st, w)) -> EffectRWS w st m s b
forall w st (m :: * -> *) s a.
(st -> m (s, st, w)) -> EffectRWS w st m s a
EffectRWS ((st -> m (s, st, w)) -> EffectRWS w st m s b)
-> (st -> m (s, st, w)) -> EffectRWS w st m s b
forall a b. (a -> b) -> a -> b
$ \st
st -> st -> m (s, st, w)
m st
st m (s, st, w) -> ((s, st, w) -> m (s, st, w)) -> m (s, st, w)
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 m (s, st, w) -> ((s, st, w) -> m (s, st, w)) -> m (s, st, w)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (s
s',st
u,w
w') -> (s, st, w) -> m (s, st, w)
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> s -> s
forall a. Monoid a => a -> a -> a
mappend s
s s
s', st
u, w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
w w
w')
  {-# INLINE (<*>) #-}

instance Contravariant (EffectRWS w st m s) where
  contramap :: (a -> b) -> EffectRWS w st m s b -> EffectRWS w st m s a
contramap a -> b
_ (EffectRWS st -> m (s, st, w)
m) = (st -> m (s, st, w)) -> EffectRWS w st m s a
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 #-}