Indexed Kan Extension

indexed-transformers.cabal

@@ -1,6 +1,6 @@
 cabal-version: 2.2
 
--- This file has been generated from package.yaml by hpack version 0.36.0.
+-- This file has been generated from package.yaml by hpack version 0.38.1.
 --
 -- see: https://github.com/sol/hpack
 
@@ -49,6 +49,7 @@ library
       LambdaCase
       MultiParamTypeClasses
       PolyKinds
+      QualifiedDo
       QuantifiedConstraints
       RankNTypes
       StandaloneKindSignatures

package.yaml

@@ -39,6 +39,7 @@ default-extensions:
 - LambdaCase
 - MultiParamTypeClasses
 - PolyKinds
+- QualifiedDo
 - QuantifiedConstraints
 - RankNTypes
 - StandaloneKindSignatures

src/Control/Monad/Trans/Indexed/Free.hs

@@ -12,7 +12,7 @@ The free indexed monad transformer.
 
 module Control.Monad.Trans.Indexed.Free
   ( IxMonadTransFree (liftFreeIx, hoistFreeIx, foldFreeIx), coerceFreeIx
-  , IxFunctor, IxMap (IxMap), liftFreerIx, hoistFreerIx, foldFreerIx
+  , IxFunctor, Ixer (Ixer), liftFreerIx, hoistFreerIx, foldFreerIx
   ) where
 
 import Control.Monad.Free
@@ -24,7 +24,7 @@ The free `IxMonadTrans` generated by an `IxFunctor`
 is characterized by the `IxMonadTransFree` class
 up to the isomorphism `coerceFreeIx`.
 
-`IxMonadTransFree` and `IxMap`, the free `IxMonadTrans` and
+`IxMonadTransFree` and `Ixer`, the free `IxMonadTrans` and
 the free `IxFunctor`, can be combined as a "freer" `IxMonadTrans`
 and used as a DSL generated by primitive commands like this
 [Conor McBride example]
@@ -46,14 +46,14 @@ data DVDCommand
 >>> :{
 insert
   :: (IxMonadTransFree freeIx, Monad m)
-  => DVD -> freeIx (IxMap DVDCommand) 'False 'True m ()
+  => DVD -> freeIx (Ixer DVDCommand) 'False 'True m ()
 insert dvd = liftFreerIx (Insert dvd)
 :}
 
 >>> :{
 eject
   :: (IxMonadTransFree freeIx, Monad m)
-  => freeIx (IxMap DVDCommand) 'True 'False m DVD
+  => freeIx (Ixer DVDCommand) 'True 'False m DVD
 eject = liftFreerIx Eject
 :}
 
@@ -62,7 +62,7 @@ eject = liftFreerIx Eject
 >>> :{
 swap
   :: (IxMonadTransFree freeIx, Monad m)
-  => DVD -> freeIx (IxMap DVDCommand) 'True 'True m DVD
+  => DVD -> freeIx (Ixer DVDCommand) 'True 'True m DVD
 swap dvd = Indexed.do
   dvd' <- eject
   insert dvd
@@ -71,7 +71,7 @@ swap dvd = Indexed.do
 
 >>> import Control.Monad.Trans
 >>> :{
-printDVD :: IxMonadTransFree freeIx => freeIx (IxMap DVDCommand) 'True 'True IO ()
+printDVD :: IxMonadTransFree freeIx => freeIx (Ixer DVDCommand) 'True 'True IO ()
 printDVD = Indexed.do
   dvd <- eject
   insert dvd
@@ -112,30 +112,30 @@ type IxFunctor
 type IxFunctor f = forall i j. Functor (f i j)
 
 {- |
-`IxMap` is the free `IxFunctor`. It's a left Kan extension.
-Combining `IxMonadTransFree` with `IxMap` as demonstrated in the above example,
+`Ixer` is the free `IxFunctor`.
+Combining `IxMonadTransFree` with `Ixer` as demonstrated in the above example,
 gives the "freer" `IxMonadTrans`, modeled on this
 [Oleg Kiselyov explanation]
 (https://okmij.org/ftp/Computation/free-monad.html#freer).
 -}
-data IxMap f i j x where
-  IxMap :: (x -> y) -> f i j x -> IxMap f i j y
-instance Functor (IxMap f i j) where
-  fmap g (IxMap f x) = IxMap (g . f) x
+data Ixer f i j x where
+  Ixer :: (x -> y) -> f i j x -> Ixer f i j y
+instance Functor (Ixer f i j) where
+  fmap g (Ixer f x) = Ixer (g . f) x
 
 liftFreerIx
   :: (IxMonadTransFree freeIx, Monad m)
-  => f i j x -> freeIx (IxMap f) i j m x
-liftFreerIx x = liftFreeIx (IxMap id x)
+  => f i j x -> freeIx (Ixer f) i j m x
+liftFreerIx x = liftFreeIx (Ixer id x)
 
 hoistFreerIx
   :: (IxMonadTransFree freeIx, Monad m)
   => (forall i j x. f i j x -> g i j x)
-  -> freeIx (IxMap f) i j m x -> freeIx (IxMap g) i j m x
-hoistFreerIx f = hoistFreeIx (\(IxMap g x) -> IxMap g (f x))
+  -> freeIx (Ixer f) i j m x -> freeIx (Ixer g) i j m x
+hoistFreerIx f = hoistFreeIx (\(Ixer g x) -> Ixer g (f x))
 
 foldFreerIx
   :: (IxMonadTransFree freeIx, IxMonadTrans t, Monad m)
   => (forall i j x. f i j x -> t i j m x)
-  -> freeIx (IxMap f) i j m x -> t i j m x
-foldFreerIx f x = foldFreeIx (\(IxMap g y) -> g <$> f y) x
+  -> freeIx (Ixer f) i j m x -> t i j m x
+foldFreerIx f x = foldFreeIx (\(Ixer g y) -> g <$> f y) x

src/Control/Monad/Trans/Indexed/Free/Wrap.hs

@@ -12,6 +12,7 @@ module Control.Monad.Trans.Indexed.Free.Wrap
   , WrapIx (..)
   ) where
 
+import Control.Applicative
 import Control.Monad.Free
 import Control.Monad.Trans
 import Control.Monad.Trans.Indexed
@@ -34,6 +35,10 @@ instance (IxFunctor f, i ~ j, Monad m)
   => Applicative (FreeIx f i j m) where
     pure = FreeIx . pure . Unwrap
     (<*>) = apIx
+instance (IxFunctor f, i ~ j, Monad m, Alternative m)
+  => Alternative (FreeIx f i j m) where
+    empty = FreeIx empty
+    FreeIx x <|> FreeIx y = FreeIx (x <|> y)
 instance (IxFunctor f, i ~ j, Monad m)
   => Monad (FreeIx f i j m) where
     return = pure

src/Control/Monad/Trans/Indexed/State.hs

@@ -8,19 +8,40 @@ The state indexed monad transformer.
 -}
 
 module Control.Monad.Trans.Indexed.State
-  ( StateIx (..)
+  ( -- * State
+    IxMonadTransState (..)
+  , StateIx (..)
   , evalStateIx
   , execStateIx
-  , modifyIx
-  , putIx
   , toStateT
   , fromStateT
+    -- * Reader
+  , IxMonadTransReader (..)
+  , ReaderIx
+  , runReaderIx
+  , evalReaderIx
+  , execReaderIx
+  , toReaderT
+  , fromReaderT
+  , AskIx (..)
+    -- * Codensity
+  , CodensityIx (..)
+  , liftCodensityIx
+  , lowerCodensityIx
+  , fromStateIx
+  , toStateIx
   ) where
 
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Reader
 import Control.Monad.State
 import Control.Monad.Trans.Indexed
+import qualified Control.Monad.Trans.Indexed.Do as Ix
+import Control.Monad.Trans.Indexed.Free
+import Control.Monad.Trans.Indexed.Free.Wrap
 
-newtype StateIx i j m x = StateIx { runStateIx :: i -> m (x, j)}
+newtype StateIx i j m x = StateIx {runStateIx :: i -> m (x, j)}
   deriving Functor
 instance IxMonadTrans StateIx where
   joinIx (StateIx f) = StateIx $ \i -> do
@@ -43,14 +64,117 @@ evalStateIx m i = fst <$> runStateIx m i
 execStateIx :: Monad m => StateIx i j m x -> i -> m j
 execStateIx m i = snd <$> runStateIx m i
 
-modifyIx :: Applicative m => (i -> j) -> StateIx i j m ()
-modifyIx f = StateIx $ \i -> pure ((), f i)
-
-putIx :: Applicative m => j -> StateIx i j m ()
-putIx j = modifyIx (\ _ -> j)
-
 toStateT :: StateIx i i m x -> StateT i m x
 toStateT (StateIx f) = StateT f
 
 fromStateT :: StateT i m x -> StateIx i i m x
 fromStateT (StateT f) = StateIx f
+
+class
+  ( IxMonadTrans t
+  , forall m s i j. (Monad m, s ~ i, i ~ j) => MonadState s (t i j m)
+  ) => IxMonadTransState t where
+  {-# MINIMAL putIx | stateIx #-}
+  putIx :: Monad m => j -> t i j m ()
+  putIx s = stateIx (\_ -> ((), s))
+  modifyIx :: Monad m => (i -> j) -> t i j m ()
+  modifyIx f = stateIx (\i -> ((), f i))
+  stateIx :: Monad m => (i -> (a,j)) -> t i j m a
+  stateIx f = Ix.do
+    s <- get
+    let ~(a, s') = f s
+    putIx s'
+    return a
+instance IxMonadTransState StateIx where
+  stateIx f = StateIx (return . f)
+
+newtype CodensityIx t i j m a = CodensityIx
+  { runCodensityIx :: forall b k. (a -> t j k m b) -> t i k m b }
+  deriving Functor
+
+lowerCodensityIx
+  :: (IxMonadTrans t, Monad m)
+  => CodensityIx t i j m a -> t i j m a
+lowerCodensityIx (CodensityIx f) = f return
+
+liftCodensityIx
+  :: (IxMonadTrans t, Monad m)
+  => t i j m a -> CodensityIx t i j m a
+liftCodensityIx m = CodensityIx $ \h -> bindIx h m
+
+fromStateIx :: Monad m => StateIx i j m x -> CodensityIx ReaderIx i j m x
+fromStateIx (StateIx f) = Ix.do
+  i <- get
+  (x,j) <- lift (f i)
+  putIx j
+  return x
+
+toStateIx :: Monad m => CodensityIx ReaderIx i j m x -> StateIx i j m x
+toStateIx = StateIx . runReaderIx . lowerCodensityIx
+
+class
+  ( IxMonadTrans t
+  , forall m r i j. (Monad m, r ~ i, i ~ j) => MonadReader r (t i j m)
+  ) => IxMonadTransReader t where
+  localIx :: Monad m => (i -> r) -> t r j m a -> t i j m a
+
+type ReaderIx = FreeIx (Ixer AskIx)
+
+data AskIx i j x where AskIx :: AskIx x x x
+
+runReaderIx :: Monad m => ReaderIx i j m x -> i -> m (x, j)
+runReaderIx (FreeIx m) i = do
+  wrapped <- m
+  case wrapped of
+    Unwrap x -> return (x,i)
+    Wrap (Ixer f AskIx) -> runReaderIx (f i) i
+
+evalReaderIx :: Monad m => ReaderIx i j m x -> i -> m x
+evalReaderIx m i = fst <$> runReaderIx m i
+
+execReaderIx :: Monad m => ReaderIx i j m x -> i -> m j
+execReaderIx m i = snd <$> runReaderIx m i
+
+toReaderT :: Monad m => ReaderIx i j m x -> ReaderT i m x
+toReaderT = ReaderT . evalReaderIx
+
+fromReaderT :: Monad m => ReaderT i m x -> ReaderIx i i m x
+fromReaderT (ReaderT f) = do
+  i <- ask
+  lift (f i)
+
+instance IxMonadTrans t => IxMonadTrans (CodensityIx t) where
+  joinIx (CodensityIx k) =
+    CodensityIx $ \f -> k $ \(CodensityIx g) -> g f
+instance i ~ j => Applicative (CodensityIx t i j m) where
+  pure x = CodensityIx $ \k -> k x
+  CodensityIx cf <*> CodensityIx cx =
+    CodensityIx $ \ k -> cf $ \ f -> cx (k . f)
+instance i ~ j => Monad (CodensityIx t i j m) where
+  return = pure
+  CodensityIx cx >>= k =
+    CodensityIx $ \ c -> cx (\ x -> runCodensityIx (k x) c)
+instance (IxMonadTrans t, i ~ j) => MonadTrans (CodensityIx t i j) where
+  lift m = CodensityIx (\k -> bindIx k (lift m))
+instance (i ~ j, Alternative (t i j m), IxMonadTrans t, Monad m)
+  => Alternative (CodensityIx t i j m) where
+    empty = liftCodensityIx empty
+    x <|> y = liftCodensityIx (lowerCodensityIx x <|> lowerCodensityIx y)
+instance (i ~ j, Alternative (t i j m), IxMonadTrans t, Monad m)
+  => MonadPlus (CodensityIx t i j m)
+instance (i ~ j, IxMonadTransReader t, Monad m)
+  => MonadState i (CodensityIx t i j m) where
+  get = liftCodensityIx ask
+  put = putIx
+instance IxMonadTransReader t => IxMonadTransState (CodensityIx t) where
+  putIx s = CodensityIx (localIx (const s) . ($ ()))
+instance (s ~ t, Monad m, IxMonadTransFree freeIx)
+  => MonadReader s (freeIx (Ixer AskIx) s t m) where
+    ask = liftFreerIx AskIx
+    local = localIx
+instance IxMonadTransFree freeIx
+  => IxMonadTransReader (freeIx (Ixer AskIx)) where
+    localIx f
+      = lowerCodensityIx
+      . (\m -> Ix.do {i <- get; putIx (f i); m})
+      . liftCodensityIx