Eff中的多个IO效果（或其他可组合效果的方式）

Question

我想尽可能地限制程序中函数的效果 例如如果我有一个应该查询数据库的函数，我知道它不会 打印删除我的文件的东西。

作为一个具体的例子，假设我有一个带有“用户”表的数据库。

有些函数只读取此表，其中一些函数是读写的。

使用mtl和变形金刚我可以尝试这样的事情：

data User = User { username :: String }
  deriving (Show)

class Monad m => ReadDb m where
  getUsers      :: m [User]
  getUserByName :: String -> m (Maybe User)

class Monad m => WriteDb m where
  addUser    :: String -> m ()
  removeUser :: String -> m Bool

然而，如果不是不可能的话，实现我需要的实例是棘手的。成为 能够访问数据库我需要SqlBackend和IO：

data SqlBackend

instance (MonadReader SqlBackend m, MonadIO m, Monad m) => ReadDb m where
  getUsers = undefined
  getUserByName = undefined

instance (MonadReader SqlBackend m, MonadIO m, Monad m) => WriteDb m where
  addUser = undefined
  removeUser = undefined

使用UndecidableInstances这很好用。但是，让我说我也需要 记录，不，我不会收集[String]或类似的日志字符串 那。记录器应该有效地记录，并且记录消息应该出现在 实时。

所以我可能会这样做：

class Monad m => Log m where
  log :: String -> m ()

记录需要Logger，因此我可以定义一个像

这样的实例

data Logger

instance (MonadReader Logger m, MonadIO m, Monad m) => Log m where
  log = undefined

现在，读取数据库和日志的函数如下所示：

logUsers :: (ReadDb m, Log m) => m ()
logUsers = getUsers >>= log . show

但不幸的是我无法真正运行这个，因为我需要提供 MonadReader SqlBackend m和MonadReader Logger m，这是不可能的 因为功能依赖MonadReader r m | m -> r。

有一些解决方法（比如实现一个不同的类型类来获取 Logger和SqlBackend），但它们涉及太多样板。

作为替代方案，我想尝试Oleg的可扩展效果库（Eff monad，在这里实施http://okmij.org/ftp/Haskell/extensible/Eff.hs）。该 据我所知，麻烦是需要处理的多种效果 IO无法在Eff中以可组合的方式实现。例如，Trace 库中的效果是这样实现的：

data Trace

runTrace :: Eff (Trace :> Void) w -> IO w

Void部分是这里的问题。在我的例子中，我想处理读，写和 日志操作分开，功能应该可以 细粒度类型，允许这些效果的任何子集。

这里有一件事是Free，但我不确定如何定义仿函数 对于这些效果，然后组合它们，以便例如一个函数 日志将能够调用另一个不记录但具有其他功能的函数 同样的效果。

所以我的问题是：如何在我的程序中获得细粒度的效果类型 实际构成的效果处理程序。效果处理程序应该能够运行 IO。假设性能不是问题（所以Free等等都可以。）

Answer 1

我认为你的instance声明是错误的。

instance (MonadReader SqlBackend m, MonadIO m, Monad m) => ReadDb m

此实例将匹配所有类型构造函数m :: * -> *，如果相关的m不适合实例上下文，则稍后会失败。实例搜索中没有回溯。换句话说，您无法更改ReadDb的实例（例如，如果您需要在测试期间模拟数据库）。它还会导致重叠超类的问题。

最好像往常一样使用newtype将程序构造为monad变换器堆栈。所以我要写下一个自定义monad变换器：

data SqlConfig = SqlConfig { connectionString :: String }

newtype DbT m a = DbT (ReaderT SqlConfig m a) deriving (
    Functor,
    Applicative,
    Alternative,
    Monad,
    MonadTrans,
    MonadPlus,
    MonadFix,
    MonadIO,
    MonadWriter w,
    MonadState s,
    MonadError e,
    MonadCont
    )
runDbT :: DbT m a -> SqlConfig -> m a
runDbT (DbT m) = runReaderT m

我正在使用GeneralizedNewtypeDeriving派生mtl类，但MonadReader 除外。 （这些实例还需要UndecidableInstances，因为它们无法覆盖条件。）我不想将MonadReader实例从ReaderT内的DbT抬起，我想要将它从基地monad中抬起。 DbT不是ReaderT，恰好是使用ReaderT实现的。

mapDbT :: (m a -> n b) -> DbT m a -> DbT n b
mapDbT f (DbT m) = DbT $ mapReaderT f m
instance MonadReader r m => MonadReader r (DbT m) where
    ask = lift ask
    local = mapDbT . local

只要我们有权访问DbT，我就可以使用IO来实施您的课程：

instance MonadIO m => MonadReadDb (DbT m) where
    getUsers = DbT $ ask >>= (liftIO . query "select * from Users")
    getUserByName name = DbT $ ask >>= (liftIO . query "select * from Users where Name = @name")

instance MonadIO m => MonadWriteDb (DbT m) where
    addUser u = DbT $ ask >>= (liftIO . query "insert Users (Name) values @name")
    removeUser u = DbT $ ask >>= (liftIO . query "delete Users where Name = @name")

同样，我可以设置一个记录monad变换器：

data LoggingConfig = LoggingConfig { filePath :: String }

newtype LoggerT m a = LoggerT (ReaderT LoggingConfig m a) deriving (
    Functor,
    Applicative,
    Alternative,
    Monad,
    MonadTrans,
    MonadPlus,
    MonadFix,
    MonadIO,
    MonadWriter w,
    MonadState s,
    MonadError e,
    MonadCont
    )
runLoggerT :: LoggerT m a -> LoggingConfig -> m a
runLoggerT (LoggerT m) = runReaderT m

instance MonadIO m => MonadLogger (LoggerT m) where
    log msg = LoggerT $ do
        config <- ask
        liftIO $ writeFile (filePath config) msg

-- MonadReader instance omitted. It's identical to the DbT instance

恼人地 - 这是mtl方法的主要缺点 - 您必须编写O（n ^ 2）个实例才能使这些类型组合得很好。

instance MonadLogger m => MonadLogger (DbT m) where
    log = lift . log

instance MonadReadDb m => MonadReadDb (LoggerT m) where
    getUsers = lift getUsers
    getUserByName = lift . getUserByName

instance MonadWriteDb m => MonadWriteDb (LoggerT m) where
    addUser = lift . addUser
    removeUser = lift . removeUser

-- and a bunch of identical instances for all the types in transformers

您可以像往常一样使用三个类编写monadic程序：

myProgram :: (MonadLogger m, MonadReadDb m, MonadWriteDb m) => m ()
myProgram = do
    us <- getUsers
    log $ "removing " ++ show (length us) ++ " users"
    void $ traverse removeUser us

然后在程序的入口点，当您构建并运行monad变换器堆栈时，只需打开LoggerT和DbT个新类型并提供所需的配置。

runProgram :: LoggerT (DbT IO) a -> LoggingConfig -> SqlConfig -> IO a
runProgram m l s = runDbT (runLoggerT m l) s

ghci> :t runProgram myProgram
runProgram myProgram :: LoggingConfig -> SqlConfig -> IO ()

Answer 2

Benjamin的回答显示了如何使用mtl执行此操作，这很有用，但我实际上要求Eff解决方案，所以这里是：

（代码灵感来自freer问题跟踪器中给出的答案：https://gitlab.com/queertypes/freer/issues/7）

我们有4种效果：

• 将输出写入stdout
• 从stdin
读取输入
• 阅读数据库
• 登录句柄

以下是使用extensible-effects的解决方案：

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators         #-}

module GetlinePutline where

--------------------------------------------------------------------------------
import           Control.Eff
import           Control.Eff.Lift
import           Data.Typeable
import           Prelude          hiding (log)
--------------------------------------------------------------------------------

--------------------------------------------------------------------------------

data Getline v = Getline (String -> v)
  deriving (Typeable, Functor)

getline :: Member Getline r => Eff r String
getline = send (inj (Getline id))

runGetline :: (SetMember Lift (Lift IO) r) => Eff (Getline :> r) w -> Eff r w
runGetline = freeMap return (\u -> handleRelay u runGetline (\(Getline k) -> lift getLine >>= runGetline . k))

--------------------------------------------------------------------------------

data Putline v = Putline String (() -> v)
  deriving (Typeable, Functor)

putline :: Member Putline r => String -> Eff r ()
putline s = send (inj (Putline s id))

runPutline :: (SetMember Lift (Lift IO) r) => Eff (Putline :> r) w -> Eff r w
runPutline = freeMap return (\u -> handleRelay u runPutline (\(Putline s k) -> lift (putStrLn s) >>= runPutline . k))

--------------------------------------------------------------------------------

-- Similar to Putline, but we provide a logger when running

data Logger

defaultLogger :: Logger
defaultLogger = undefined

logToHandle :: Logger -> String -> IO ()
logToHandle _ s = putStrLn ("logging: " ++ show s)

-- Log using a logger
data Log v = Log String (() -> v)
  deriving (Typeable, Functor)

log :: Member Log r => String -> Eff r ()
log s = send (inj (Log s id))

runLog :: SetMember Lift (Lift IO) r => Logger -> Eff (Log :> r) w -> Eff r w
runLog logger = freeMap return (\u -> handleRelay u (runLog logger) (\(Log s k) -> lift (logToHandle logger s) >>= runLog logger . k))

--------------------------------------------------------------------------------

-- Database read

data User = User { username :: String }
  deriving (Show)

data ReadDb v
  = GetUsers ([User] -> v)
  | GetUserByUsername String (Maybe User -> v)
  deriving (Typeable, Functor)

getUsers :: Member ReadDb r => Eff r [User]
getUsers = send (inj (GetUsers id))

getUserByUsername :: Member ReadDb r => String -> Eff r (Maybe User)
getUserByUsername uname = send (inj (GetUserByUsername uname id))

data SqlBackend = SqlBackend

getUsers_db :: SqlBackend -> IO [User]
getUsers_db _ = return [User "user1"]

getUserByUsername_db :: SqlBackend -> String -> IO (Maybe User)
getUserByUsername_db _ uname = return (Just (User uname))

runReadDb :: SetMember Lift (Lift IO) r => SqlBackend -> Eff (ReadDb :> r) w -> Eff r w
runReadDb db = freeMap return (\u -> handleRelay u (runReadDb db) (\case GetUsers k -> lift (getUsers_db db) >>= runReadDb db . k
                                                                         GetUserByUsername s k -> lift (getUserByUsername_db db s) >>= runReadDb db . k))

--------------------------------------------------------------------------------

myEff :: (Member Log r, Member Putline r, Member Getline r, Member ReadDb r) => Eff r ()
myEff = do
  ln <- getline
  putline ln
  putline "done"
  log "logging stuff"
  putline "reading db"
  users <- getUsers
  log (show users)

main :: IO ()
main = runLift $ runLog defaultLogger $ runPutline $ runGetline $ runReadDb SqlBackend myEff

使用freer的解决方案：

-- originally posted to https://gitlab.com/queertypes/freer/issues/7
-- modified to remove IO from myEff

{-# OPTIONS_GHC -Wall #-}

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators         #-}

module GetlinePutline where

--------------------------------------------------------------------------------
import           Control.Monad.Freer
import           Control.Monad.Freer.Internal
import           Prelude                      hiding (log)
--------------------------------------------------------------------------------

doIO :: Member IO r => IO a -> Eff r a
doIO = send

--------------------------------------------------------------------------------

data Getline a where
  Getline :: Getline String

getline :: Member Getline r => Eff r String
getline = send Getline

runGetline :: Member IO r => Eff (Getline ': r) w -> Eff r w
runGetline (Val x) = return x
runGetline (E u q) = case decomp u of
  Right Getline -> doIO getLine >>= runGetline . qApp q
  Left u1       -> E u1 (tsingleton (runGetline . qApp q))

--------------------------------------------------------------------------------

data Putline a where
  Putline :: String -> Putline ()

runPutline :: Member IO r => Eff (Putline ': r) w -> Eff r w
runPutline (Val x) = return x
runPutline (E u q) = case decomp u of
  Right (Putline s) -> doIO (putStrLn s) >> runPutline (qApp q ())
  Left u1           -> E u1 (tsingleton (runPutline . qApp q))

putline :: Member Putline r => String -> Eff r ()
putline = send . Putline

--------------------------------------------------------------------------------

-- Similar to Putline, but we provide a logger when running

data Logger

defaultLogger :: Logger
defaultLogger = undefined

logToHandle :: Logger -> String -> IO ()
logToHandle _ s = putStrLn ("logging: " ++ show s)

-- Log using a logger
data Log a where
  Log :: String -> Log ()

log :: Member Log r => String -> Eff r ()
log = send . Log

runLog :: Member IO r => Logger -> Eff (Log ': r) w -> Eff r w
runLog _      (Val x) = return x
runLog logger (E u q) = case decomp u of
  Right (Log s) -> doIO (logToHandle logger s) >> runLog logger (qApp q ())
  Left u1       -> E u1 (tsingleton (runLog logger . qApp q))

--------------------------------------------------------------------------------

-- Database read

data User = User { username :: String }
  deriving (Show)

data ReadDb a where
  GetUsers          :: ReadDb [User]
  GetUserByUsername :: String -> ReadDb (Maybe User)

getUsers :: Member ReadDb r => Eff r [User]
getUsers = send GetUsers

getUserByUsername :: Member ReadDb r => String -> Eff r (Maybe User)
getUserByUsername = send . GetUserByUsername

data SqlBackend = SqlBackend

getUsers_db :: SqlBackend -> IO [User]
getUsers_db _ = return [User "user1"]

getUserByUsername_db :: SqlBackend -> String -> IO (Maybe User)
getUserByUsername_db _ uname = return (Just (User uname))

runReadDb :: Member IO r => SqlBackend -> Eff (ReadDb ': r) w -> Eff r w
runReadDb _  (Val x) = return x
runReadDb db (E u q) = case decomp u of
  Right GetUsers -> doIO (getUsers_db db) >>= runReadDb db . qApp q
  Right (GetUserByUsername uname) -> doIO (getUserByUsername_db db uname) >>= runReadDb db . qApp q
  Left u1 -> E u1 (tsingleton (runReadDb db . qApp q))

--------------------------------------------------------------------------------

myEff :: (Member Log r, Member Putline r, Member Getline r, Member ReadDb r) => Eff r ()
myEff = do
  ln <- getline
  putline ln
  putline "done"
  log "logging stuff"
  putline "reading db"
  users <- getUsers
  log (show users)

main :: IO ()
main = runM $ runLog defaultLogger $ runPutline $ runGetline $ runReadDb SqlBackend myEff