From b18e5b2332eb8647195433dcfb2fa38f89d509f8 Mon Sep 17 00:00:00 2001 From: Douglas Wilson Date: Wed, 31 May 2017 10:28:18 +1200 Subject: [PATCH 1/2] Add MonadBase instance for FT and MonadBaseControl instances for FreeT and FT These MonadBaseControl instances are require the functor to have a traversable instance. The additional dependency of monad-control is added. A proof of the MonadTransControl laws is supplied as a comment with the instance for FreeT, I can modify or remove this as you see fit. --- free.cabal | 3 ++- src/Control/Monad/Trans/Free.hs | 36 ++++++++++++++++++++++++++ src/Control/Monad/Trans/Free/Church.hs | 20 ++++++++++++++ 3 files changed, 58 insertions(+), 1 deletion(-) diff --git a/free.cabal b/free.cabal index 4f627d8..7c46332 100644 --- a/free.cabal +++ b/free.cabal @@ -83,7 +83,8 @@ library transformers-compat >= 0.3 && < 1, template-haskell >= 2.7.0.0 && < 3, exceptions >= 0.6 && < 0.9, - containers < 0.6 + containers < 0.6, + monad-control >= 1 && < 1.1 exposed-modules: Control.Applicative.Free diff --git a/src/Control/Monad/Trans/Free.hs b/src/Control/Monad/Trans/Free.hs index 19cf606..c505d61 100644 --- a/src/Control/Monad/Trans/Free.hs +++ b/src/Control/Monad/Trans/Free.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif @@ -56,6 +57,8 @@ import Control.Monad (liftM, MonadPlus(..), ap, join) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Trans.Class +import Control.Monad.Trans.Control (MonadTransControl(..), MonadBaseControl(..), + ComposeSt, defaultLiftBaseWith, defaultRestoreM) import Control.Monad.Free.Class import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class @@ -321,6 +324,39 @@ instance (Functor f, MonadBase b m) => MonadBase b (FreeT f m) where liftBase = lift . liftBase {-# INLINE liftBase #-} +{- +This instance must satisfy: +* liftWith . const . return = return +liftWith . const . return $ x + = lift $ (const $ return x) joinFreeT + = lift (return x) + = return x + +* liftWith (const (m >>= f)) = liftWith (const m) >>= liftWith . const . f +liftWith (const m) >>= liftWith . const . f + = lift (const m (joinFreeT)) >>= \x -> lift $ const (f x) joinFreeT + = lift m >>= lift . f + = lift (m >>= f) + = lift (const (m >>= f) joinFreeT) + = liftWith (const (m >>= f) +* liftWith (\run -> run t) >>= restoreT . return = t +liftWith (\run -> run t) >>= restoreT . return + = lift (joinFreeT t) >>= lift return >>= hoistFreeT (return . runIdentity) + = lift (joinFreeT t) >>= hoistFreeT (return . runIdentity) + = t +-} +instance (Traversable f) => MonadTransControl (FreeT f) where + type StT (FreeT f) a = Free f a + liftWith mkFreeT = lift $ mkFreeT joinFreeT + {-# INLINE liftWith #-} + restoreT mstt = lift mstt >>= hoistFreeT (return . runIdentity) + {-# INLINE restoreT #-} + +instance (Traversable f, MonadBaseControl b m) => MonadBaseControl b (FreeT f m) where + type StM (FreeT f m) a = ComposeSt (FreeT f) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + instance (Functor f, MonadReader r m) => MonadReader r (FreeT f m) where ask = lift ask {-# INLINE ask #-} diff --git a/src/Control/Monad/Trans/Free/Church.hs b/src/Control/Monad/Trans/Free/Church.hs index 4cad02f..c8d6387 100644 --- a/src/Control/Monad/Trans/Free/Church.hs +++ b/src/Control/Monad/Trans/Free/Church.hs @@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} #include "free-common.h" ----------------------------------------------------------------------------- @@ -48,9 +49,12 @@ module Control.Monad.Trans.Free.Church import Control.Applicative import Control.Category ((<<<), (>>>)) import Control.Monad +import Control.Monad.Base (MonadBase(..)) import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) import Control.Monad.Identity import Control.Monad.Trans.Class +import Control.Monad.Trans.Control (MonadTransControl(..), MonadBaseControl(..), + ComposeSt, defaultLiftBaseWith, defaultRestoreM) import Control.Monad.IO.Class import Control.Monad.Reader.Class import Control.Monad.Writer.Class @@ -148,6 +152,22 @@ instance (MonadIO m) => MonadIO (FT f m) where liftIO = lift . liftIO {-# INLINE liftIO #-} +instance MonadBase b m => MonadBase b (FT f m) where + liftBase = lift . liftBase + {-# INLINE liftBase #-} + +instance (Traversable f) => MonadTransControl (FT f) where + type StT (FT f) a = F f a + liftWith mkFT = lift $ mkFT joinFT + {-# INLINE liftWith #-} + restoreT mstt = lift mstt >>= hoistFT (return . runIdentity) + {-# INLINE restoreT #-} + +instance (MonadBaseControl b m, Traversable f) => MonadBaseControl b (FT f m) where + type StM (FT f m) a = ComposeSt (FT f) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + instance (Functor f, MonadError e m) => MonadError e (FT f m) where throwError = lift . throwError {-# INLINE throwError #-} From 48cd86dd5fb2129f854961a2dd068fc032588682 Mon Sep 17 00:00:00 2001 From: Doug Wilson Date: Thu, 1 Jun 2017 07:16:12 +1200 Subject: [PATCH 2/2] Update Free.hs Some typos in the proof. --- src/Control/Monad/Trans/Free.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Monad/Trans/Free.hs b/src/Control/Monad/Trans/Free.hs index c505d61..0f523c7 100644 --- a/src/Control/Monad/Trans/Free.hs +++ b/src/Control/Monad/Trans/Free.hs @@ -338,10 +338,10 @@ liftWith (const m) >>= liftWith . const . f = lift m >>= lift . f = lift (m >>= f) = lift (const (m >>= f) joinFreeT) - = liftWith (const (m >>= f) + = liftWith (const (m >>= f)) * liftWith (\run -> run t) >>= restoreT . return = t liftWith (\run -> run t) >>= restoreT . return - = lift (joinFreeT t) >>= lift return >>= hoistFreeT (return . runIdentity) + = lift (joinFreeT t) >>= lift . return >>= hoistFreeT (return . runIdentity) = lift (joinFreeT t) >>= hoistFreeT (return . runIdentity) = t -}