使用像 freer-simple 这样的库时如何合并效果解释器？

Question

我正在研究 freer-simple 并尝试找出如何组合效果。

我有一个代数来表示一个简单的文件系统和用户调用失败如下：

data FileSystem r where
  ReadFile :: Path a File -> FileSystem String
  WriteFile :: Path a File -> String -> FileSystem ()

readFile :: Member FileSystem effs => Path a File -> Eff effs String
readFile = send . ReadFile

writeFile :: Member FileSystem effs => Path a File -> String -> Eff effs ()
writeFile pth = send . WriteFile pth

data AppError r where
  Ensure :: Bool -> String -> AppError ()
  Fail :: String -> AppError ()

ensure :: Member AppError effs => Bool -> String -> Eff effs ()
ensure condition message = send $ Ensure condition message

fail :: Member AppError effs =>  String -> Eff effs ()
fail = send . Fail

在一个名为 interactor 的函数中有一个 "application" 如下：

data TestItem = Item {
  pre :: String,
  post :: String,
  path :: Path Abs File
}

data RunConfig = RunConfig {
  environment :: String,
  depth :: Integer,
  path :: Path Abs File
}

type FileSys r = (Member FileSystem r)
type AppFailure r = (Member AppError r)

interactor :: TestItem -> RunConfig -> (AppFailure r, FileSys r) => Eff r ApState
interactor item runConfig = do
                              let fullFilePath = path (runConfig :: RunConfig)
                              writeFile fullFilePath $ pre item  <> post item
                              fail "random error ~ its a glitch"
                              txt <- readFile [absfile|C:\Vids\SystemDesign\Wrong.txt|]
                              pure $ ApState fullFilePath txt

现阶段我只对记录步骤的愚蠢 "documentation" 解释器感兴趣，我什至不关心失败会在控制流方面做什么：

fileSystemDocInterpreter :: FileSystem ~> Eff '[Writer [String], effs]
fileSystemDocInterpreter = 
     let
        mockContents = "Mock File Contents"
      in
        \case
          ReadFile path -> tell ["readFile: " <> show path] $> mockContents
          WriteFile path str -> tell ["write file: " <>
                                        show path <>
                                        "\nContents:\n" <>
                                        str]

errorDocInterpreter :: AppError ~> Eff '[Writer [String]]
errorDocInterpreter = \case
                    Ensure condition errMsg -> tell [condition ? "Ensure Check Passed" $
                      "Ensure Check Failed ~ " <>  errMsg]
                    Fail errMsg -> tell ["Failure ~ " <>  errMsg]

组合解释器如下：

type FileSys r = (Member FileSystem r)
type AppFailure r = (Member AppError r)

executeDocumented :: forall a. Eff '[FileSystem, AppError] a -> ((a, [String]), [String])
executeDocumented app = run $ runWriter 
                            $ reinterpret errorDocInterpreter 
                            $ runWriter 
                            $ reinterpret fileSystemDocInterpreter app

当我运行使用示例配置时，我得到如下内容：

((ApState {
            filePath = "C:\Vids\SystemDesign\VidList.txt", 
            fileText = "Mock File Contents"
          },
          ["write file: \"C:\\Vids\\SystemDesign\\VidList.txt\
                        "\nContents: I do a test the test runs",
          "readFile: \"C:\\Vids\\SystemDesign\\Wrong.txt\""]
         ),
         ["Failure ~ random error ~ its a glitch"]
 )

我对上面的解释器有几个问题：

为了编译我必须按如下方式制作类型：
```
fileSystemDocInterpreter :: FileSystem ~> Eff '[Writer [String], effs] 

errorDocInterpreter :: AppError ~> Eff '[Writer [String]]
```
并在 fileSystemDocInterpreter 之后调用 errorDocInterpreter 因为 fileSystemDocInterpreter 有尾随效果而 errorDocInterpreter 没有。

有没有办法更改类型签名或调用它们，这样就没关系了父口译员首先需要哪个？
fileSystemDocInterpreter 和errorDocInterpreter 都使用了Writer [String] 效果。有没有办法结合这些所以运行Writer 只被调用一次所以失败和文件系统消息出现在一个日志中？

Answer 1

Eff 类型的文档指出

Normally, a concrete list of effects is not used to parameterize Eff. Instead, the Member or Members constraints are used to express constraints on the list of effects without coupling a computation to a concrete list of effects.

因此，为了最大限度地提高灵活性，我们可以将 fileSystemDocInterpreter 和 errorDocInterpreter 的签名更改为：

fileSystemDocInterpreter :: Member (Writer [String]) effs => FileSystem ~> Eff effs

errorDocInterpreter :: Member (Writer [String]) effs => AppError ~> Eff effs

我们并不真正关心 Writer [String] 在类型级别列表中的位置，也不关心列表中是否还有其他效果。我们只需要 Writer [String] 就可以了。此更改处理 (1)。

至于(2)，我们可以定义executeDocumented如下：

executeDocumented :: forall a. Eff '[FileSystem, AppError, Writer [String]] a 
                  -> (a, [String])
executeDocumented app = run $ runWriter
                            $ interpret errorDocInterpreter
                            $ interpret fileSystemDocInterpreter
                            $ app

在这里，我们在解释器中使用了我们在定义计算时获得的灵活性。我们在列表的末尾放一个Writer [String]，两个interprets 发送FileSystem 和AppErrors 效果给writer。无需单独的 Writer [String] 层！（也就是说，如果在其他情况下我们在列表的前面有两个相同类型的效果，我们可以使用 subsume 来删除重复。）

Answer 2

我尝试恢复源代码以观察它是如何工作的

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Data.Monoid
import Data.Functor
import Data.List
import Data.String
import Control.Natural (type (~>))
import Control.Monad.Freer.Writer (Writer, tell,runWriter)
import Control.Monad.Freer
  (
    Eff
  , LastMember
  , Member
  , interpret
  , interpretM
  , send
  , run
  , runM
  )

data FileSystem r where
  ReadFile :: FilePath  -> FileSystem String
  WriteFile :: FilePath -> String -> FileSystem ()

readFile :: Member FileSystem effs => FilePath -> Eff effs String
readFile = send . ReadFile

writeFile :: Member FileSystem effs => FilePath -> String -> Eff effs ()
writeFile pth = send . WriteFile pth

data AppError r where
  Ensure :: Bool -> String -> AppError ()
  Fail :: String -> AppError ()

ensure :: Member AppError effs => Bool -> String -> Eff effs ()
ensure condition message = send $ Ensure condition message

fail :: Member AppError effs =>  String -> Eff effs ()
fail = send . Fail

data ApState = ApState {filePath::String,fileText::String} deriving Show

data TestItem = Item {
  pre :: String,
  post :: String,
  pathTI :: FilePath
}

data RunConfig = RunConfig {
  environment :: String,
  depth :: Integer,
  pathRC :: FilePath
}

type FileSys r = (Member FileSystem r)
type AppFailure r = (Member AppError r)

interactor :: TestItem -> RunConfig -> (AppFailure r, FileSys r) => Eff r ApState
interactor item runConfig = do
                              let fullFilePath = pathRC (runConfig :: RunConfig)
                              Main.writeFile fullFilePath $ pre item  <> post item
                              Main.fail "random error ~ its a glitch"
                              txt <- Main.readFile "C:\Vids\SystemDesign\Wrong.txt"
                              pure $ ApState fullFilePath txt

fileSystemDocInterpreter :: Member (Writer [String]) effs => FileSystem ~> Eff effs
fileSystemDocInterpreter =
     let
        mockContents::String = "Mock File Contents"
      in
        \case
          ReadFile path -> tell ["readFile: " <> show path] $> mockContents
          WriteFile path str -> tell ["write file: " <>
                                        show path <>
                                        "\nContents:\n" <>
                                        str]

errorDocInterpreter :: Member (Writer [String]) effs => AppError ~> Eff effs
errorDocInterpreter = \case
       Ensure condition errMsg -> tell [if condition then "Ensure Check Passed" else ("Ensure Check Failed ~ " <>  errMsg) ]
       Fail errMsg -> tell ["Failure ~ " <>  errMsg]

executeDocumented :: forall a. Eff '[FileSystem, AppError, Writer [String]] a
                  -> (a, [String])
executeDocumented app = run $ runWriter
                            $ interpret errorDocInterpreter
                            $ interpret fileSystemDocInterpreter
                            $ app

main :: IO ()
main = do
   let ti = Item {pre="", post ="", pathTI =""}
   let rc = RunConfig {environment ="", depth =1, pathRC ="C:\Vids\SystemDesign\VidList.txt"}
   let (apst,messages) = executeDocumented $ interactor ti rc
   putStrLn $ show apst
   mapM_ (\x->putStrLn x) messages
   putStrLn "_"

使用像 freer-simple 这样的库时如何合并效果解释器？

How can I merge effect interpreters when using a library like freer-simple?

haskell

free-monad