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，但我不确定如何定义函子 对于这些效果，然后组合它们，例如一个函数 logs 将能够调用另一个不记录但有其他功能的函数 效果一样。

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

Answer 1

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

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

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

最好将您的程序构建为 monad 转换器堆栈，像往常一样使用 newtypes。所以我要写一个自定义的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，因为它们不符合覆盖条件。）我不想从ReaderT 中的DbT 中提升MonadReader 实例，我想从基础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

只要我们可以访问IO，我就可以使用DbT 实现你的类：

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")

同样，我可以设置一个日志单子转换器：

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

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

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

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

（受freer问题跟踪器中给出的答案启发的代码：https://gitlab.com/queertypes/freer/issues/7）

我们有 4 种效果：

• 将输出写入标准输出
• 从标准输入读取输入
• 读取数据库
• 记录到句柄

这是一个使用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