{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RebindableSyntax #-}
{-# OPTIONS_GHC -Wall #-}

-- | A continuation type.
module Box.Cont
  ( Cont (..),
    runCont,
    (<$.>),
    (<*.>),
    Cont_ (..),
    runCont_,
  )
where

import NumHask.Prelude hiding (STM, atomically)

-- | A continuation similar to ` Control.Monad.ContT` but where the result type is swallowed by an existential
newtype Cont m a = Cont
  { Cont m a -> forall r. (a -> m r) -> m r
with :: forall r. (a -> m r) -> m r
  }

instance Functor (Cont m) where
  fmap :: (a -> b) -> Cont m a -> Cont m b
fmap a -> b
f Cont m a
mx = (forall r. (b -> m r) -> m r) -> Cont m b
forall (m :: * -> *) a. (forall r. (a -> m r) -> m r) -> Cont m a
Cont (\b -> m r
return_ -> Cont m a
mx Cont m a -> (a -> m r) -> m r
forall (m :: * -> *) a. Cont m a -> forall r. (a -> m r) -> m r
`with` \a
x -> b -> m r
return_ (a -> b
f a
x))

instance Applicative (Cont m) where
  pure :: a -> Cont m a
pure a
r = (forall r. (a -> m r) -> m r) -> Cont m a
forall (m :: * -> *) a. (forall r. (a -> m r) -> m r) -> Cont m a
Cont (\a -> m r
return_ -> a -> m r
return_ a
r)

  Cont m (a -> b)
mf <*> :: Cont m (a -> b) -> Cont m a -> Cont m b
<*> Cont m a
mx = (forall r. (b -> m r) -> m r) -> Cont m b
forall (m :: * -> *) a. (forall r. (a -> m r) -> m r) -> Cont m a
Cont (\b -> m r
return_ -> Cont m (a -> b)
mf Cont m (a -> b) -> ((a -> b) -> m r) -> m r
forall (m :: * -> *) a. Cont m a -> forall r. (a -> m r) -> m r
`with` \a -> b
f -> Cont m a
mx Cont m a -> (a -> m r) -> m r
forall (m :: * -> *) a. Cont m a -> forall r. (a -> m r) -> m r
`with` \a
x -> b -> m r
return_ (a -> b
f a
x))

instance Monad (Cont m) where
  return :: a -> Cont m a
return a
r = (forall r. (a -> m r) -> m r) -> Cont m a
forall (m :: * -> *) a. (forall r. (a -> m r) -> m r) -> Cont m a
Cont (\a -> m r
return_ -> a -> m r
return_ a
r)

  Cont m a
ma >>= :: Cont m a -> (a -> Cont m b) -> Cont m b
>>= a -> Cont m b
f = (forall r. (b -> m r) -> m r) -> Cont m b
forall (m :: * -> *) a. (forall r. (a -> m r) -> m r) -> Cont m a
Cont (\b -> m r
return_ -> Cont m a
ma Cont m a -> (a -> m r) -> m r
forall (m :: * -> *) a. Cont m a -> forall r. (a -> m r) -> m r
`with` \a
a -> a -> Cont m b
f a
a Cont m b -> (b -> m r) -> m r
forall (m :: * -> *) a. Cont m a -> forall r. (a -> m r) -> m r
`with` \b
b -> b -> m r
return_ b
b)

instance (MonadIO m) => MonadIO (Cont m) where
  liftIO :: IO a -> Cont m a
liftIO IO a
m =
    (forall r. (a -> m r) -> m r) -> Cont m a
forall (m :: * -> *) a. (forall r. (a -> m r) -> m r) -> Cont m a
Cont
      ( \a -> m r
return_ -> do
          a
a <- IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
m
          a -> m r
return_ a
a
      )

instance (Semigroup a) => Semigroup (Cont m a) where
  <> :: Cont m a -> Cont m a -> Cont m a
(<>) = (a -> a -> a) -> Cont m a -> Cont m a -> Cont m a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance (Functor m, Semigroup a, Monoid a) => Monoid (Cont m a) where
  mempty :: Cont m a
mempty = a -> Cont m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

  mappend :: Cont m a -> Cont m a -> Cont m a
mappend = Cont m a -> Cont m a -> Cont m a
forall a. Semigroup a => a -> a -> a
(<>)

-- | finally run a continuation
runCont :: Cont m (m r) -> m r
runCont :: Cont m (m r) -> m r
runCont Cont m (m r)
x = Cont m (m r) -> (m r -> m r) -> m r
forall (m :: * -> *) a. Cont m a -> forall r. (a -> m r) -> m r
with Cont m (m r)
x m r -> m r
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

-- | sometimes you have no choice but to void it up
newtype Cont_ m a = Cont_
  { Cont_ m a -> (a -> m ()) -> m ()
with_ :: (a -> m ()) -> m ()
  }

instance Functor (Cont_ m) where
  fmap :: (a -> b) -> Cont_ m a -> Cont_ m b
fmap a -> b
f Cont_ m a
mx = ((b -> m ()) -> m ()) -> Cont_ m b
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Cont_ m a
Cont_ (\b -> m ()
return_ -> Cont_ m a
mx Cont_ m a -> (a -> m ()) -> m ()
forall (m :: * -> *) a. Cont_ m a -> (a -> m ()) -> m ()
`with_` \a
x -> b -> m ()
return_ (a -> b
f a
x))

instance Applicative (Cont_ m) where
  pure :: a -> Cont_ m a
pure a
r = ((a -> m ()) -> m ()) -> Cont_ m a
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Cont_ m a
Cont_ (\a -> m ()
return_ -> a -> m ()
return_ a
r)

  Cont_ m (a -> b)
mf <*> :: Cont_ m (a -> b) -> Cont_ m a -> Cont_ m b
<*> Cont_ m a
mx = ((b -> m ()) -> m ()) -> Cont_ m b
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Cont_ m a
Cont_ (\b -> m ()
return_ -> Cont_ m (a -> b)
mf Cont_ m (a -> b) -> ((a -> b) -> m ()) -> m ()
forall (m :: * -> *) a. Cont_ m a -> (a -> m ()) -> m ()
`with_` \a -> b
f -> Cont_ m a
mx Cont_ m a -> (a -> m ()) -> m ()
forall (m :: * -> *) a. Cont_ m a -> (a -> m ()) -> m ()
`with_` \a
x -> b -> m ()
return_ (a -> b
f a
x))

instance Monad (Cont_ m) where
  return :: a -> Cont_ m a
return a
r = ((a -> m ()) -> m ()) -> Cont_ m a
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Cont_ m a
Cont_ (\a -> m ()
return_ -> a -> m ()
return_ a
r)

  Cont_ m a
ma >>= :: Cont_ m a -> (a -> Cont_ m b) -> Cont_ m b
>>= a -> Cont_ m b
f = ((b -> m ()) -> m ()) -> Cont_ m b
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Cont_ m a
Cont_ (\b -> m ()
return_ -> Cont_ m a
ma Cont_ m a -> (a -> m ()) -> m ()
forall (m :: * -> *) a. Cont_ m a -> (a -> m ()) -> m ()
`with_` \a
a -> a -> Cont_ m b
f a
a Cont_ m b -> (b -> m ()) -> m ()
forall (m :: * -> *) a. Cont_ m a -> (a -> m ()) -> m ()
`with_` \b
b -> b -> m ()
return_ b
b)

instance (MonadIO m) => MonadIO (Cont_ m) where
  liftIO :: IO a -> Cont_ m a
liftIO IO a
m =
    ((a -> m ()) -> m ()) -> Cont_ m a
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Cont_ m a
Cont_
      ( \a -> m ()
return_ -> do
          a
a <- IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
m
          a -> m ()
return_ a
a
      )

instance (Semigroup a) => Semigroup (Cont_ m a) where
  <> :: Cont_ m a -> Cont_ m a -> Cont_ m a
(<>) = (a -> a -> a) -> Cont_ m a -> Cont_ m a -> Cont_ m a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance (Functor m, Semigroup a, Monoid a) => Monoid (Cont_ m a) where
  mempty :: Cont_ m a
mempty = a -> Cont_ m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

  mappend :: Cont_ m a -> Cont_ m a -> Cont_ m a
mappend = Cont_ m a -> Cont_ m a -> Cont_ m a
forall a. Semigroup a => a -> a -> a
(<>)

-- | finally run a Cont_
runCont_ :: Cont_ m (m ()) -> m ()
runCont_ :: Cont_ m (m ()) -> m ()
runCont_ Cont_ m (m ())
x = Cont_ m (m ()) -> (m () -> m ()) -> m ()
forall (m :: * -> *) a. Cont_ m a -> (a -> m ()) -> m ()
with_ Cont_ m (m ())
x m () -> m ()
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

infixr 3 <$.>

-- | fmap over a continuation and then run the result.
--
-- The . position is towards the continuation
(<$.>) :: (a -> m r) -> Cont m a -> m r
<$.> :: (a -> m r) -> Cont m a -> m r
(<$.>) a -> m r
f Cont m a
a = Cont m (m r) -> m r
forall (m :: * -> *) r. Cont m (m r) -> m r
runCont ((a -> m r) -> Cont m a -> Cont m (m r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m r
f Cont m a
a)

infixr 3 <*.>

-- | fmap over a continuation and then run the result.
--
-- The . position is towards the continuation
(<*.>) :: Cont m (a -> m r) -> Cont m a -> m r
<*.> :: Cont m (a -> m r) -> Cont m a -> m r
(<*.>) Cont m (a -> m r)
f Cont m a
a = Cont m (m r) -> m r
forall (m :: * -> *) r. Cont m (m r) -> m r
runCont (Cont m (a -> m r)
f Cont m (a -> m r) -> Cont m a -> Cont m (m r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cont m a
a)