{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ConstraintKinds #-} module Control.Monad.Restricted ( -- * Auxiliary definitions Morph , MorphD (..) , Ext (..), lift', runExt , HasReadPart (..) , unliftIO, unliftIO' , SafeIO (..) , NewRef (..) , MonadMonoid (..) ) where import Data.Monoid --import Control.Monad.Layer hiding (MonadTrans, lift) --import qualified Control.Monad.Layer as L import Control.Applicative import Control.Monad.Base import Control.Monad.Trans.Control import Control.Concurrent import Control.Monad.State import Control.Monad.Reader import Control.Monad.RWS import Control.Monad.Trans.Identity import qualified System.Environment as Env import System.IO.Error (catchIOError, isDoesNotExistError) {- | Monad morphism. Think as @m@ is a submonad of @n@. -} type Morph m n = forall a . m a -> n a {- | The @MorphD@ type is needed only to avoid impredicative types. We use @MorphD@ instead of @Morph@ when the morphism is stored inside a data structure. -} newtype MorphD m n = MorphD { runMorphD :: Morph m n } -- | @m@ has a submonad @(ReadPart m)@ which is isomorphic to 'Reader'. class (Monad m, Monad (ReadPart m)) => HasReadPart m where {- | Law: @(ReadPart m)@ === @('Reader' x)@ for some @x@. Alternative laws which ensures this isomorphism (@r :: (ReadPart m a)@ is arbitrary): * @(r >> return ())@ === @return ()@ * @liftM2 (,) r r@ === @liftM (\a -> (a, a)) r@ See also -} type ReadPart m :: * -> * -- | @(ReadPart m)@ is a submonad of @m@ liftReadPart :: ReadPart m a -> m a -- | @ReadPart (StateT s m) = Reader s@ instance Monad m => HasReadPart (StateT s m) where type ReadPart (StateT s m) = Reader s liftReadPart = gets . runReader ------------------ newtype Ext n m a = Ext { unExt :: ReaderT (MorphD n m) m a } deriving (Monad, MonadIO, Functor, Applicative) instance MonadTrans (Ext n) where lift = Ext . lift deriving instance (MonadBase b m) => MonadBase b (Ext n m) {- instance MonadTransControl (Ext n) where data StT (Ext n) a = StTExt { unStTExt :: a } -- liftWith = defaultLiftWith Ext -- restoreT = defaultRestoreT unExt instance (MonadBaseControl b m) => MonadBaseControl b (Ext n m) where data StM (Ext n m) a = StMExt { unStMExt :: ComposeSt (Ext n) m a } liftBaseWith = defaultLiftBaseWith StMExt restoreM = defaultRestoreM unStMExt -} instance (MonadBase m m) => MonadBaseControl m (Ext n m) where data StM (Ext n m) a = StMExt { unStMExt :: a } liftBaseWith f = Ext $ do r <- ask lift $ f $ liftM StMExt . flip runReaderT r . unExt restoreM = return . unStMExt lift' :: Monad m => n a -> Ext n m a lift' m = Ext $ do r <- ask lift $ runMorphD r m unlift :: (MonadBase m m) => ((Ext n m a -> m a) -> m b) -> Ext n m b unlift f = liftBaseWith $ \m -> f (liftM (unStMExt) . m) runExt :: MorphD n m -> Ext n m a -> m a runExt v (Ext m) = runReaderT m v ------------------ --type MonadIO' m = (MonadIO m, MonadBaseControl IO m) unliftIO' :: MonadBaseControl n m => ((m () -> n ()) -> m a) -> m a unliftIO' f = liftBaseWith (\m -> m $ f $ void . m) >>= restoreM unliftIO :: MonadBaseControl n m => ((m () -> n ()) -> n a) -> m a unliftIO f = liftBaseWith (\m -> f $ void . m) ------------------- -- | Type class for effectless, synchronous @IO@ actions. class Monad m => SafeIO m where -- | The program's command line arguments (not including the program name). getArgs :: m [String] -- | The name of the program as it was invoked. getProgName :: m String -- | @(lookupEnv var)@ returns the value of the environment variable @var@. lookupEnv :: String -> m (Maybe String) -- | This instance is used in the implementation, the end users do not need it. instance SafeIO IO where getArgs = Env.getArgs getProgName = Env.getProgName -- lookupEnv = Env.lookupEnv -- does not work with Haskell Platform 2013.2.0.0 lookupEnv v = catchIOError (liftM Just $ Env.getEnv v) $ \e -> if isDoesNotExistError e then return Nothing else ioError e -- | This instance is used in the implementation, the end users do not need it. instance SafeIO m => SafeIO (Ext n m) where getArgs = lift getArgs getProgName = lift getProgName lookupEnv = lift . lookupEnv -- | This instance is used in the implementation, the end users do not need it. instance SafeIO m => SafeIO (IdentityT m) where getArgs = lift getArgs getProgName = lift getProgName lookupEnv = lift . lookupEnv -- | This instance is used in the implementation, the end users do not need it. instance (SafeIO m, Monoid w) => SafeIO (RWST r w s m) where getArgs = lift getArgs getProgName = lift getProgName lookupEnv = lift . lookupEnv ------------------- class (Monad m) => NewRef m where newRef' :: a -> m (MorphD (StateT a m) m) instance NewRef IO where newRef' x = do vx <- liftIO $ newMVar x return $ MorphD $ \m -> modifyMVar vx $ liftM swap . runStateT m where swap (a, b) = (b, a) instance (MonadBase m m, NewRef m) => NewRef (Ext n m) where newRef' = liftM (\m -> MorphD $ \k -> unlift $ runMorphD m . flip mapStateT k) . lift . newRef' ------------------- newtype MonadMonoid a = MonadMonoid { runMonadMonoid :: a () } instance Monad m => Monoid (MonadMonoid m) where mempty = MonadMonoid $ return () MonadMonoid a `mappend` MonadMonoid b = MonadMonoid $ a >> b