在 StateT 中组合多个状态

Question

我正在编写一个作为守护进程运行的程序。 要创建守护进程，用户需要提供一组 每个所需类的实现（其中一个是数据库） 所有这些类都有功能 StateT s IO a 形式的类型签名， 但是s 对于每个班级都是不同的。

假设每个类都遵循这种模式：

import Control.Monad (liftM)
import Control.Monad.State (StateT(..), get)

class Hammer h where
  driveNail :: StateT h IO ()

data ClawHammer = MkClawHammer Int -- the real implementation is more complex

instance Hammer ClawHammer where
  driveNail = return () -- the real implementation is more complex

-- Plus additional classes for wrenches, screwdrivers, etc.

现在我可以定义一个记录来表示由 每个“槽”的用户。

data MultiTool h = MultiTool {
    hammer :: h
    -- Plus additional fields for wrenches, screwdrivers, etc.
  }

守护进程在StateT (MultiTool h ...) IO () 中完成大部分工作 单子。

现在，由于多功能工具包含一把锤子，我可以在任何情况下使用它 需要锤子的地方。换句话说，MultiTool 类型 如果我编写这样的代码，可以实现它包含的任何类：

stateMap :: Monad m => (s -> t) -> (t -> s) -> StateT s m a -> StateT t m a
stateMap f g (StateT h) = StateT $ liftM (fmap f) . h . g

withHammer :: StateT h IO () -> StateT (MultiTool h) IO ()
withHammer runProgram = do
  t <- get
  stateMap (\h -> t {hammer=h}) hammer runProgram

instance Hammer h => Hammer (MultiTool h) where
  driveNail = withHammer driveNail

但是withHammer、withWrench、withScrewdriver等的实现 基本相同。能写点东西就好了 像这样……

--withMember accessor runProgram = do
--  u <- get
--  stateMap (\h -> u {accessor=h}) accessor runProgram

-- instance Hammer h => Hammer (MultiTool h) where
--   driveNail = withMember hammer driveNail

但这当然不会编译。

我怀疑我的解决方案过于面向对象。 有没有更好的办法？ 单子变压器，也许？ 提前感谢您的任何建议。

Answer 1

如果您想使用像您的情况这样的大型全局状态，那么您想要使用的是镜头，正如 Ben 所建议的那样。我也推荐 Edward Kmett 的 lens 库。但是，还有另一种可能更好的方法。

服务器具有程序连续运行并在状态空间上执行相同操作的属性。当您想要模块化服务器时，麻烦就开始了，在这种情况下，您需要的不仅仅是一些全局状态。您希望模块有自己的状态。

让我们将模块视为将请求转换为响应的东西：

Module :: (Request -> m Response) -> Module m

现在如果它有一些状态，那么这个状态就会变得引人注目，因为模块下次可能会给出不同的答案。有很多方法可以做到这一点，例如：

Module :: s -> ((Request, s) -> m (Response s)) -> Module m

但表达这一点的更好且等效的方式是以下构造函数（我们将很快围绕它构建一个类型）：

Module :: (Request -> m (Response, Module m)) -> Module m

此模块将请求映射到响应，但同时也会返回其自身的新版本。让我们更进一步，使请求和响应具有多态性：

Module :: (a -> m (b, Module m a b)) -> Module m a b

现在，如果一个模块的输出类型与另一个模块的输入类型匹配，那么您可以像常规函数一样组合它们。该组合是关联的并且具有多态身份。这听起来很像一个类别，事实上它是！它是一个类别、一个应用函子和一个箭头。

newtype Module m a b =
    Module (a -> m (b, Module m a b))

instance (Monad m) => Applicative (Module m a)
instance (Monad m) => Arrow (Module m)
instance (Monad m) => Category (Module m)
instance (Monad m) => Functor (Module m a)

我们现在可以组合两个具有各自本地状态的模块，甚至不知道它！但这还不够。我们想要更多。可以切换的模块怎么样？让我们扩展我们的小模块系统，使模块实际上可以选择 not 来给出答案：

newtype Module m a b =
    Module (a -> m (Maybe b, Module m a b))

这允许与(.) 正交的另一种组合形式：现在我们的类型也是Alternative 函子的家族：

instance (Monad m) => Alternative (Module m a)

现在一个模块可以选择是否响应请求，如果不响应，则尝试下一个模块。简单的。您刚刚重新发明了电线类别。 =)

当然，您不需要重新发明它。 Netwire 库实现了这种设计模式，并带有一个预定义“模块”（称为线）的大型库。有关教程，请参阅 Control.Wire 模块。

Answer 2

这是一个具体示例，说明如何像其他人所说的那样使用lens。在下面的代码示例中，Type1 是本地状态（即您的锤子），Type2 是全局状态（即您的多功能工具）。 lens 提供了 zoom 函数，让您可以运行局部状态计算，放大镜头定义的任何场：

import Control.Lens
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State

data Type1 = Type1 {
    _field1 :: Int   ,
    _field2 :: Double}

field1 :: SimpleLens Type1 Int
field1 = lens _field1 (\x a -> x { _field1 = a})

field2 :: SimpleLens Type1 Double
field2 = lens _field2 (\x a -> x { _field2 = a})

data Type2 = Type2 {
    _type1  :: Type1 ,
    _field3 :: String}

type1 :: SimpleLens Type2 Type1
type1 = lens _type1 (\x a -> x { _type1 = a})

field3 :: SimpleLens Type2 String
field3 = lens _field3 (\x a -> x { _field3 = a})

localCode :: StateT Type1 IO ()
localCode = do
    field1 += 3
    field2 .= 5.0
    lift $ putStrLn "Done!"

globalCode :: StateT Type2 IO ()
globalCode = do
    f1 <- zoom type1 $ do
        localCode
        use field1
    field3 %= (++ show f1)
    f3 <- use field3
    lift $ putStrLn f3

main = runStateT globalCode (Type2 (Type1 9 4.0) "Hello: ")

zoom 不限于一个类型的直接子字段。由于镜头是可组合的，因此您只需执行以下操作即可在一次操作中任意缩放：

zoom (field1a . field2c . field3b . field4j) $ do ...

Answer 3

这听起来很像镜头的应用。

镜头是某些数据的子字段的规范。这个想法是你有一些价值 toolLens 和函数 view 和 set 以便 view toolLens :: MultiTool h -> h 获取工具并且 set toolLens :: MultiTool h -> h -> MultiTool h 用新值替换它。然后您可以轻松地将您的withMember 定义为仅接受镜头的函数。

镜头技术最近取得了很大进步，现在它们的能力令人难以置信。在撰写本文时，最强大的库是 Edward Kmett 的 lens 库，它有点难以接受，但一旦找到所需的功能就非常简单。您还可以在 SO 上搜索有关镜头的更多问题，例如Functional lenses 链接到 lenses, fclabels, data-accessor - which library for structure access and mutation is better 或 lenses 标记。

Answer 4

我创建了一个名为 data-diverse-lens 的镜头可扩展记录库，它允许像这样 gist 组合多个 ReaderT（或 StateT）：

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}

module Main where

import Control.Lens
import Control.Monad.Reader
import Control.Monad.State
import Data.Diverse.Lens
import Data.Semigroup

foo :: (MonadReader r m, HasItem' Int r, HasItem' String r) => m (Int, String)
foo = do
    i <- view (item' @Int) -- explicitly specify type
    s <- view item' -- type can also be inferred
    pure (i + 10, s <> "bar")

bar :: (MonadState s m, HasItem' Int s, HasItem' String s) => m ()
bar = do
    (item' @Int) %= (+10) -- explicitly specify type
    item' %= (<> "bar") -- type can also be inferred
    pure ()

main :: IO ()
main = do
    -- example of running ReaderT with multiple items
    (i, s) <- runReaderT foo ((2 :: Int) ./ "foo" ./ nil)
    putStrLn $ show i <> s -- prints out "12foobar"
    -- example of running StateT with multiple items
    is <- execStateT bar ((2 :: Int) ./ "foo" ./ nil)
    putStrLn $ show (view (item @Int) is) <> (view (item @String) is) -- prints out "12foobar"

Data.Has 是一个更简单的库，它对元组做同样的事情。图书馆首页的示例：

 {-# LANGUAGE FlexibleContexts #-}

 -- in some library code
 ...
 logInAnyReaderHasLogger :: (Has Logger r, MonadReader r m) => LogString -> m ()
 logInAnyReaderHasLogger s = asks getter >>= logWithLogger s

 queryInAnyReaderHasSQL :: (Has SqlBackEnd r, MonadReader r m) => Query -> m a
 queryInAnyReaderHasSQL q = asks getter >>= queryWithSQL q
 ...

 -- now you want to use these effects together
 ...
 logger <- initLogger  ...
 sql <- initSqlBackEnd ...

 (`runReader` (logger, sql)) $ do
       ...
       logInAnyReaderHasLogger ...
       ...
       x <- queryInAnyReaderHasSQL ...
       ...