{-# 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
(<>) = (a -> a -> a) -> 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 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

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

  mappend :: Codensity m a -> Codensity m a -> Codensity m a
mappend = Codensity m a -> Codensity m a -> Codensity m a
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 :: Codensity m (m r) -> m r
close Codensity m (m r)
x = Codensity m (m r) -> (m r -> m r) -> m r
forall k (m :: k -> *) a.
Codensity m a -> forall (b :: k). (a -> m b) -> m b
runCodensity Codensity m (m r)
x m r -> m r
forall a. a -> a
id

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

infixr 3 <$|>

-- | fmap then close over a Codensity
--
-- >>> glue showStdout <$|> qList [1..3]
-- 1
-- 2
-- 3
(<$|>) :: (a -> m r) -> Codensity m a -> m r
<$|> :: (a -> m r) -> Codensity m 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
<*|> :: Codensity m (a -> m r) -> Codensity m a -> m r
(<*|>) Codensity m (a -> m r)
f Codensity m a
a = Codensity m (m r) -> m r
forall (m :: * -> *) r. Codensity m (m r) -> m r
close (Codensity m (a -> m r)
f Codensity m (a -> m r) -> Codensity m a -> Codensity m (m r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Codensity m a
a)