diff --git a/indexed-transformers.cabal b/indexed-transformers.cabal index 0bd88b1..b673bf1 100644 --- a/indexed-transformers.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index e78950d..09a5a70 100644 --- a/package.yaml +++ b/package.yaml @@ -39,6 +39,7 @@ default-extensions: - LambdaCase - MultiParamTypeClasses - PolyKinds +- QualifiedDo - QuantifiedConstraints - RankNTypes - StandaloneKindSignatures diff --git a/src/Control/Monad/Trans/Indexed/Free.hs b/src/Control/Monad/Trans/Indexed/Free.hs index 2d9a011..c2907c4 100644 --- a/src/Control/Monad/Trans/Indexed/Free.hs +++ b/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 diff --git a/src/Control/Monad/Trans/Indexed/Free/Wrap.hs b/src/Control/Monad/Trans/Indexed/Free/Wrap.hs index 7a4f61f..9c08486 100644 --- a/src/Control/Monad/Trans/Indexed/Free/Wrap.hs +++ b/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 diff --git a/src/Control/Monad/Trans/Indexed/State.hs b/src/Control/Monad/Trans/Indexed/State.hs index c2af5ea..d973fd0 100644 --- a/src/Control/Monad/Trans/Indexed/State.hs +++ b/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