1{-# LANGUAGE CPP #-} 2{-# LANGUAGE RankNTypes #-} 3{-# LANGUAGE FlexibleInstances #-} 4{-# LANGUAGE UndecidableInstances #-} 5{-# LANGUAGE MultiParamTypeClasses #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7#if __GLASGOW_HASKELL__ >= 706 8{-# LANGUAGE PolyKinds #-} 9#endif 10#if __GLASGOW_HASKELL__ >= 702 11{-# LANGUAGE Trustworthy #-} 12#endif 13#if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 802) 14{-# LANGUAGE DeriveDataTypeable #-} 15#endif 16#if __GLASGOW_HASKELL__ >= 802 17{-# LANGUAGE TypeInType #-} 18#endif 19 20----------------------------------------------------------------------------- 21-- | 22-- Module : Control.Monad.Codensity 23-- Copyright : (C) 2008-2016 Edward Kmett 24-- License : BSD-style (see the file LICENSE) 25-- 26-- Maintainer : Edward Kmett <ekmett@gmail.com> 27-- Stability : provisional 28-- Portability : non-portable (rank-2 polymorphism) 29-- 30---------------------------------------------------------------------------- 31module Control.Monad.Codensity 32 ( Codensity(..) 33 , lowerCodensity 34 , codensityToAdjunction, adjunctionToCodensity 35 , codensityToRan, ranToCodensity 36 , codensityToComposedRep, composedRepToCodensity 37 , wrapCodensity 38 , improve 39 ) where 40 41import Control.Applicative 42import Control.Monad (MonadPlus(..)) 43import qualified Control.Monad.Fail as Fail 44import Control.Monad.Free 45import Control.Monad.IO.Class 46import Control.Monad.Reader.Class 47import Control.Monad.State.Class 48import Control.Monad.Trans.Class 49import Data.Functor.Adjunction 50import Data.Functor.Apply 51import Data.Functor.Kan.Ran 52import Data.Functor.Plus 53import Data.Functor.Rep 54#if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 800) 55import Data.Typeable 56#endif 57#if __GLASGOW_HASKELL__ >= 802 58import GHC.Exts (TYPE) 59#endif 60 61-- | 62-- @'Codensity' f@ is the Monad generated by taking the right Kan extension 63-- of any 'Functor' @f@ along itself (@Ran f f@). 64-- 65-- This can often be more \"efficient\" to construct than @f@ itself using 66-- repeated applications of @(>>=)@. 67-- 68-- See \"Asymptotic Improvement of Computations over Free Monads\" by Janis 69-- Voigtländer for more information about this type. 70-- 71-- <https://www.janis-voigtlaender.eu/papers/AsymptoticImprovementOfComputationsOverFreeMonads.pdf> 72#if __GLASGOW_HASKELL__ >= 802 73newtype Codensity (m :: k -> TYPE rep) a = Codensity 74-- Note: we *could* generalize @a@ to @TYPE repa@, but the 'Functor' 75-- instance wouldn't carry that, so it doesn't really seem worth 76-- the complication. 77#else 78newtype Codensity m a = Codensity 79#endif 80 { runCodensity :: forall b. (a -> m b) -> m b 81 } 82#if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 800) 83 deriving Typeable 84#endif 85 86#if __GLASGOW_HASKELL__ >= 802 87instance Functor (Codensity (k :: j -> TYPE rep)) where 88#else 89instance Functor (Codensity k) where 90#endif 91 fmap f (Codensity m) = Codensity (\k -> m (\x -> k (f x))) 92 {-# INLINE fmap #-} 93 94#if __GLASGOW_HASKELL__ >= 802 95instance Apply (Codensity (f :: k -> TYPE rep)) where 96#else 97instance Apply (Codensity f) where 98#endif 99 (<.>) = (<*>) 100 {-# INLINE (<.>) #-} 101 102#if __GLASGOW_HASKELL__ >= 802 103instance Applicative (Codensity (f :: k -> TYPE rep)) where 104#else 105instance Applicative (Codensity f) where 106#endif 107 pure x = Codensity (\k -> k x) 108 {-# INLINE pure #-} 109 Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (\x -> bfr (ab x)))) 110 {-# INLINE (<*>) #-} 111 112#if __GLASGOW_HASKELL__ >= 802 113instance Monad (Codensity (f :: k -> TYPE rep)) where 114#else 115instance Monad (Codensity f) where 116#endif 117 return = pure 118 {-# INLINE return #-} 119 m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c)) 120 {-# INLINE (>>=) #-} 121 122instance Fail.MonadFail f => Fail.MonadFail (Codensity f) where 123 fail msg = Codensity $ \ _ -> Fail.fail msg 124 {-# INLINE fail #-} 125 126instance MonadIO m => MonadIO (Codensity m) where 127 liftIO = lift . liftIO 128 {-# INLINE liftIO #-} 129 130instance MonadTrans Codensity where 131 lift m = Codensity (m >>=) 132 {-# INLINE lift #-} 133 134instance Alt v => Alt (Codensity v) where 135 Codensity m <!> Codensity n = Codensity (\k -> m k <!> n k) 136 {-# INLINE (<!>) #-} 137 138instance Plus v => Plus (Codensity v) where 139 zero = Codensity (const zero) 140 {-# INLINE zero #-} 141 142{- 143instance Plus v => Alternative (Codensity v) where 144 empty = zero 145 (<|>) = (<!>) 146 147instance Plus v => MonadPlus (Codensity v) where 148 mzero = zero 149 mplus = (<!>) 150-} 151 152instance Alternative v => Alternative (Codensity v) where 153 empty = Codensity (\_ -> empty) 154 {-# INLINE empty #-} 155 Codensity m <|> Codensity n = Codensity (\k -> m k <|> n k) 156 {-# INLINE (<|>) #-} 157 158#if __GLASGOW_HASKELL__ >= 710 159instance Alternative v => MonadPlus (Codensity v) 160#else 161instance MonadPlus v => MonadPlus (Codensity v) where 162 mzero = Codensity (\_ -> mzero) 163 {-# INLINE mzero #-} 164 Codensity m `mplus` Codensity n = Codensity (\k -> m k `mplus` n k) 165 {-# INLINE mplus #-} 166#endif 167 168-- | 169-- This serves as the *left*-inverse (retraction) of 'lift'. 170-- 171-- 172-- @ 173-- 'lowerCodensity' . 'lift' ≡ 'id' 174-- @ 175-- 176-- In general this is not a full 2-sided inverse, merely a retraction, as 177-- @'Codensity' m@ is often considerably "larger" than @m@. 178-- 179-- e.g. @'Codensity' ((->) s)) a ~ forall r. (a -> s -> r) -> s -> r@ 180-- could support a full complement of @'MonadState' s@ actions, while @(->) s@ 181-- is limited to @'MonadReader' s@ actions. 182#if __GLASGOW_HASKELL__ >= 710 183lowerCodensity :: Applicative f => Codensity f a -> f a 184lowerCodensity a = runCodensity a pure 185#else 186lowerCodensity :: Monad m => Codensity m a -> m a 187lowerCodensity a = runCodensity a return 188#endif 189{-# INLINE lowerCodensity #-} 190 191-- | The 'Codensity' monad of a right adjoint is isomorphic to the 192-- monad obtained from the 'Adjunction'. 193-- 194-- @ 195-- 'codensityToAdjunction' . 'adjunctionToCodensity' ≡ 'id' 196-- 'adjunctionToCodensity' . 'codensityToAdjunction' ≡ 'id' 197-- @ 198codensityToAdjunction :: Adjunction f g => Codensity g a -> g (f a) 199codensityToAdjunction r = runCodensity r unit 200{-# INLINE codensityToAdjunction #-} 201 202adjunctionToCodensity :: Adjunction f g => g (f a) -> Codensity g a 203adjunctionToCodensity f = Codensity (\a -> fmap (rightAdjunct a) f) 204{-# INLINE adjunctionToCodensity #-} 205 206-- | The 'Codensity' monad of a representable 'Functor' is isomorphic to the 207-- monad obtained from the 'Adjunction' for which that 'Functor' is the right 208-- adjoint. 209-- 210-- @ 211-- 'codensityToComposedRep' . 'composedRepToCodensity' ≡ 'id' 212-- 'composedRepToCodensity' . 'codensityToComposedRep' ≡ 'id' 213-- @ 214-- 215-- @ 216-- codensityToComposedRep = 'ranToComposedRep' . 'codensityToRan' 217-- @ 218 219codensityToComposedRep :: Representable u => Codensity u a -> u (Rep u, a) 220codensityToComposedRep (Codensity f) = f (\a -> tabulate $ \e -> (e, a)) 221{-# INLINE codensityToComposedRep #-} 222 223-- | 224-- 225-- @ 226-- 'composedRepToCodensity' = 'ranToCodensity' . 'composedRepToRan' 227-- @ 228composedRepToCodensity :: Representable u => u (Rep u, a) -> Codensity u a 229composedRepToCodensity hfa = Codensity $ \k -> fmap (\(e, a) -> index (k a) e) hfa 230{-# INLINE composedRepToCodensity #-} 231 232-- | The 'Codensity' 'Monad' of a 'Functor' @g@ is the right Kan extension ('Ran') 233-- of @g@ along itself. 234-- 235-- @ 236-- 'codensityToRan' . 'ranToCodensity' ≡ 'id' 237-- 'ranToCodensity' . 'codensityToRan' ≡ 'id' 238-- @ 239codensityToRan :: Codensity g a -> Ran g g a 240codensityToRan (Codensity m) = Ran m 241{-# INLINE codensityToRan #-} 242 243ranToCodensity :: Ran g g a -> Codensity g a 244ranToCodensity (Ran m) = Codensity m 245{-# INLINE ranToCodensity #-} 246 247instance (Functor f, MonadFree f m) => MonadFree f (Codensity m) where 248 wrap t = Codensity (\h -> wrap (fmap (\p -> runCodensity p h) t)) 249 {-# INLINE wrap #-} 250 251instance MonadReader r m => MonadState r (Codensity m) where 252 get = Codensity (ask >>=) 253 {-# INLINE get #-} 254 put s = Codensity (\k -> local (const s) (k ())) 255 {-# INLINE put #-} 256 257instance MonadReader r m => MonadReader r (Codensity m) where 258 ask = Codensity (ask >>=) 259 {-# INLINE ask #-} 260 local f m = Codensity $ \c -> ask >>= \r -> local f . runCodensity m $ local (const r) . c 261 {-# INLINE local #-} 262 263-- | Right associate all binds in a computation that generates a free monad 264-- 265-- This can improve the asymptotic efficiency of the result, while preserving 266-- semantics. 267-- 268-- See \"Asymptotic Improvement of Computations over Free Monads\" by Janis 269-- Voightländer for more information about this combinator. 270-- 271-- <http://www.iai.uni-bonn.de/~jv/mpc08.pdf> 272improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a 273improve m = lowerCodensity m 274{-# INLINE improve #-} 275 276 277-- | Wrap the remainder of the 'Codensity' action using the given 278-- function. 279-- 280-- This function can be used to register cleanup actions that will be 281-- executed at the end. Example: 282-- 283-- > wrapCodensity (`finally` putStrLn "Done.") 284wrapCodensity :: (forall a. m a -> m a) -> Codensity m () 285wrapCodensity f = Codensity (\k -> f (k ())) 286