{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Description : Natural transformations that can lift control operations
-- Copyright   : Copyright 2022 Shea Levy.
-- License     : Apache-2.0
-- Maintainer  : shea@shealevy.com
--
-- Natural transformations can lift monadic actions from the source to the
-- target, but something stronger is needed to lift general higher-order control
-- operations like @catch@.
--
-- This module relates to [Control.Natural](https://hackage.haskell.org/package/natural-transformation/docs/Control-Natural.html)
-- in a similar way to how [Control.Monad.Trans.Control](https://hackage.haskell.org/package/monad-control/docs/Control-Monad-Trans-Control.html)
-- relates to "Control.Monad.Trans.Class".
module Control.Natural.Control where

import Data.Coerce
import Data.Functor.Compose
import Data.Functor.Identity

-- | A transformation from @m@ to @n@ that can lift control operations.
--
-- The @st@ functor is needed to track the higher monad's state
-- in the lower monad. See 'StatelessControlTransformation' for the case
-- where no state tracking is needed.
data ControlTransformation st m n = ControlTransformation
  { -- | Lift an action in @m@, defined in a context where @n@ actions
    -- can be lowered into @m@ with state tracking, into @n@.
    forall (st :: * -> *) (m :: * -> *) (n :: * -> *).
ControlTransformation st m n
-> forall a. ((forall x. n x -> Compose m st x) -> m a) -> n a
transWith :: !(forall a. ((forall x. n x -> Compose m st x) -> m a) -> n a),
    -- | Restore the state captured by 'transWith'
    forall (st :: * -> *) (m :: * -> *) (n :: * -> *).
ControlTransformation st m n -> forall a. st a -> n a
restoreState :: !(forall a. st a -> n a)
  }

-- | Extract a natural transformation from a 'ControlTransformation'
toNatural :: ControlTransformation st m n -> (forall x. m x -> n x)
toNatural :: forall (st :: * -> *) (m :: * -> *) (n :: * -> *).
ControlTransformation st m n -> forall x. m x -> n x
toNatural ControlTransformation st m n
ct m x
mx = forall (st :: * -> *) (m :: * -> *) (n :: * -> *).
ControlTransformation st m n
-> forall a. ((forall x. n x -> Compose m st x) -> m a) -> n a
transWith ControlTransformation st m n
ct forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const m x
mx

-- | A transformation from @m@ to @n@ that can lift control operations.
--
-- This type is only appropriate for the case where the higher monad
-- does not have any additional state that must be accounted for when
-- running within the lower monad. For the more general case, see
-- 'ControlTransformation'.
--
-- I'm told this is a right kan extension.
type StatelessControlTransformation = ControlTransformation Identity

-- | Create a 'StatelessControlTransformation'
statelessControlTransformation ::
  forall m n.
  (Functor m, Applicative n) =>
  -- | Lift an action in @m@, defined in a context where @n@
  -- actions can be lowered into @m@, into @n@.
  (forall a. ((forall x. n x -> m x) -> m a) -> n a) ->
  StatelessControlTransformation m n
statelessControlTransformation :: forall (m :: * -> *) (n :: * -> *).
(Functor m, Applicative n) =>
(forall a. ((forall x. n x -> m x) -> m a) -> n a)
-> StatelessControlTransformation m n
statelessControlTransformation forall a. ((forall x. n x -> m x) -> m a) -> n a
transWith' = ControlTransformation {forall a. Identity a -> n a
forall a. ((forall x. n x -> Compose m Identity x) -> m a) -> n a
restoreState :: forall a. Identity a -> n a
transWith :: forall a. ((forall x. n x -> Compose m Identity x) -> m a) -> n a
restoreState :: forall a. Identity a -> n a
transWith :: forall a. ((forall x. n x -> Compose m Identity x) -> m a) -> n a
..}
  where
    transWith :: forall a. ((forall x. n x -> Compose m Identity x) -> m a) -> n a
    transWith :: forall a. ((forall x. n x -> Compose m Identity x) -> m a) -> n a
transWith (forall x. n x -> Compose m Identity x) -> m a
useRunInM = forall a. ((forall x. n x -> m x) -> m a) -> n a
transWith' forall a b. (a -> b) -> a -> b
$ \forall x. n x -> m x
runInM -> (forall x. n x -> Compose m Identity x) -> m a
useRunInM (forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. n x -> m x
runInM)
    restoreState :: forall a. Identity a -> n a
    restoreState :: forall a. Identity a -> n a
restoreState = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce

-- | Lift an action in @m@, defined in a context where @n@
-- actions can be lowered into @m@, into @n@.
statelessTransWith ::
  (Functor m) =>
  StatelessControlTransformation m n ->
  (((forall x. n x -> m x) -> m a) -> n a)
statelessTransWith :: forall (m :: * -> *) (n :: * -> *) a.
Functor m =>
StatelessControlTransformation m n
-> ((forall x. n x -> m x) -> m a) -> n a
statelessTransWith (ControlTransformation {forall a. Identity a -> n a
forall a. ((forall x. n x -> Compose m Identity x) -> m a) -> n a
restoreState :: forall a. Identity a -> n a
transWith :: forall a. ((forall x. n x -> Compose m Identity x) -> m a) -> n a
restoreState :: forall (st :: * -> *) (m :: * -> *) (n :: * -> *).
ControlTransformation st m n -> forall a. st a -> n a
transWith :: forall (st :: * -> *) (m :: * -> *) (n :: * -> *).
ControlTransformation st m n
-> forall a. ((forall x. n x -> Compose m st x) -> m a) -> n a
..}) (forall x. n x -> m x) -> m a
useRunInM = forall a. ((forall x. n x -> Compose m Identity x) -> m a) -> n a
transWith forall a b. (a -> b) -> a -> b
$ \forall x. n x -> Compose m Identity x
runInM -> (forall x. n x -> m x) -> m a
useRunInM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. n x -> Compose m Identity x
runInM)