{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Extra Codensity operators.
module Box.Codensity
  ( close,
    process,
    (<$|>),
    (<*|>),
    module Control.Monad.Codensity,
  )
where

import Control.Applicative
import Control.Monad.Codensity
import Prelude

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Prelude
-- >>> import Box
-- >>> import Data.Bool

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

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

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

-- | close a continuation
--
-- >>> close $ glue showStdout <$> qList [1..3]
-- 1
-- 2
-- 3
close :: Codensity m (m r) -> m r
close :: forall (m :: * -> *) r. Codensity m (m r) -> m r
close Codensity m (m r)
x = forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity Codensity m (m r)
x forall a. a -> a
id

-- | fmap then close over a Codensity
--
-- >>> process (glue showStdout) (qList [1..3])
-- 1
-- 2
-- 3
process :: forall a m r. (a -> m r) -> Codensity m a -> m r
process :: forall a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
process a -> m r
f Codensity m a
k = forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity Codensity m a
k a -> m r
f

infixr 0 <$|>

-- | fmap then close over a Codensity
--
-- >>> glue showStdout <$|> qList [1..3]
-- 1
-- 2
-- 3
(<$|>) :: forall a m r. (a -> m r) -> Codensity m a -> m r
<$|> :: forall a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
(<$|>) = forall a (m :: * -> *) r. (a -> m r) -> Codensity m a -> m r
process

infixr 3 <*|>

-- | apply to a continuation and close.
--
-- >>> glue <$> (pure showStdout) <*|> qList [1..3]
-- 1
-- 2
-- 3
(<*|>) :: Codensity m (a -> m r) -> Codensity m a -> m r
<*|> :: forall (m :: * -> *) a r.
Codensity m (a -> m r) -> Codensity m a -> m r
(<*|>) Codensity m (a -> m r)
f Codensity m a
a = forall (m :: * -> *) r. Codensity m (m r) -> m r
close (Codensity m (a -> m r)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Codensity m a
a)