Codensity.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneKindSignatures #-}

module GHC.Utils.Monad.Codensity
  ( Codensity(..), toCodensity, fromCodensity )
  where

import Data.Kind ( Type )

import GHC.Prelude
import GHC.Exts ( oneShot )

import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Concurrent.MVar ( newEmptyMVar, readMVar, putMVar )
import Control.Exception
import GHC.IO.Exception
import GHC.IO.Unsafe ( unsafeDupableInterleaveIO )

--------------------------------------------------------------------------------

type Codensity :: (Type -> Type) -> Type -> Type
newtype Codensity m a = Codensity { runCodensity :: forall r. (a -> m r) -> m r }
instance Functor (Codensity k) where
  fmap f (Codensity m) = Codensity $ oneShot (\k -> m $ oneShot (\x -> k $ f x))
  {-# INLINE fmap #-}
instance Applicative (Codensity f) where
  pure x = Codensity $ oneShot (\k -> k x)
  {-# INLINE pure #-}
  Codensity f <*> Codensity g =
    Codensity $ oneShot (\bfr -> f $ oneShot (\ab -> g $ oneShot (\x -> bfr (ab x))))
  {-# INLINE (<*>) #-}
instance Monad (Codensity f) where
  return = pure
  {-# INLINE return #-}
  m >>= k =
    Codensity $ oneShot (\c -> runCodensity m $ oneShot (\a -> runCodensity (k a) c))
  {-# INLINE (>>=) #-}
instance MonadTrans Codensity where
  lift m = Codensity $ oneShot (m >>=)
  {-# INLINE lift #-}
instance MonadIO m => MonadIO (Codensity m) where
  liftIO = lift . liftIO
  {-# INLINE liftIO #-}
instance MonadIO m => MonadFix (Codensity m) where
  mfix f = Codensity $ oneShot $ \ k -> do
    promise <- liftIO $ newEmptyMVar
    ans     <- liftIO $ unsafeDupableInterleaveIO
                      $ readMVar promise
                          `catch`
                        (\ BlockedIndefinitelyOnMVar -> throwIO FixIOException)
    runCodensity (f ans) $ oneShot $ \ a -> do
      liftIO $ putMVar promise a
      k a
  {-# INLINE mfix #-}

toCodensity :: Monad m => m a -> Codensity m a
toCodensity m = Codensity $ oneShot (m >>=)
{-# INLINE toCodensity #-}

fromCodensity :: Monad m => Codensity m a -> m a
fromCodensity c = runCodensity c return
{-# INLINE fromCodensity #-}