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