haskell - 如何将指定为自由单子(monad)的程序与预期指令的描述进行比较？

Question

所以我正在尝试做一些新颖的事情(我认为)，但我不是
对 Haskell 类型级编程有足够的经验，可以自己解决。

我有一个免费的 monad 描述了一些要执行的效果(一个 AST，如果那是
你滚动的方式)，我想根据一些描述来解释它
预期的效果。

到目前为止，这是我的代码::

{-# LANGUAGE DeriveFunctor, FlexibleInstances, GADTs, FlexibleContexts #-}
import Control.Monad.Free -- from package 'free'

data DSL next
    = Prompt String (String -> next)
    | Display String next
    deriving (Show, Functor)

prompt p = liftF (Prompt p id)
display o = liftF (Display o ())

-- |Just to make sure my stuff works interactively
runIO :: (Free DSL a) -> IO a
runIO (Free (Prompt p cont)) = do
    putStr p
    line <- getLine
    runIO (cont line)
runIO (Free (Display o cont)) = do putStrLn o; runIO cont
runIO (Pure x) = return x

这就是“核心”代码。这是一个示例程序:

greet :: (Free DSL ())
greet = do
    name <- prompt "Enter your name: "
    let greeting = "Why hello there, " ++ name ++ "."
    display greeting
    friendName <- prompt "And what is your friend's name? "
    display ("It's good to meet you too, " ++ friendName ++ ".")

为了测试这个程序，我想使用一个函数 runTest :: Free DSL a -> _ -> Maybe a ，它应该像这样模糊地采用一个程序和一些“预期效果”的规范:

expect = (
    (Prompt' "Enter your name:", "radix"),
    (Display' "Why hello there, radix.", ()),
    (Prompt' "And what is your friend's name?", "Bob"),
    (Display' "It's good to meet you too, Bob.", ()))

并通过将程序执行的每个效果与 expect 中的下一项相匹配来解释程序列表。然后关联的值(每对中的第二项)应作为该效果的结果返回给程序。如果所有效果都匹配，则程序的最终结果应返回为 Just .如果有什么不匹配， Nothing应该返回(稍后我将扩展它，以便它返回一条信息性错误消息)。

当然这个 expect tuple 没用，因为它的类型是一个巨大的东西，我不能写一个通用的 runTest功能结束。我遇到的主要问题是我应该如何表示这个预期的意图序列，以便我可以编写一个可以针对任何程序使用任何序列的函数 Free DSL a .

我隐约知道 Haskell 中的各种高级类型级功能，但我还没有经验知道应该尝试使用哪些东西。

我应该为我的 expected 使用 HList 还是什么？序列？

非常感谢任何有关事情的提示。

Answer 1

程序测试Free f a只是程序的解释器Free f a -> r产生一些结果r
您正在寻找的是一种为程序构建解释器的简单方法，该解释器断言程序的结果是您所期望的。解释器的每一步都将解开 Free f来自程序的指令或描述一些错误。他们会有那种类型

Free DSL a -> Either String (Free DSL a)
|                    |       ^ the remaining program after this step
|                    ^ a descriptive error
^ the remaining program before this step

我们将对 DSL 中的每个构造函数进行测试。 . prompt'预计 Prompt具有特定值并向函数提供响应值以查找下一步。

prompt' :: String -> String -> Free DSL a -> Either String (Free DSL a)
prompt' expected response f =
    case f of
        Free (Prompt p cont) | p == expected -> return (cont response)
        otherwise                            -> Left $ "Expected (Prompt " ++ show expected ++ " ...) but got " ++ abbreviate f

abbreviate :: Free DSL a -> String
abbreviate (Free (Prompt  p _)) = "(Free (Prompt "  ++ show p ++ " ...))"
abbreviate (Free (Display p _)) = "(Free (Display " ++ show p ++ " ...))"
abbreviate (Pure _)             = "(Pure ...)"

display'预计 Display具有特定值。

display' :: String -> Free DSL a -> Either String (Free DSL a)
display' expected f =
    case f of
        Free (Display p next) | p == expected -> return next
        otherwise                             -> Left $ "Expected (Display " ++ show expected ++ " ...) but got " ++ abbreviate f

pure'预计 Pure具有特定值

pure' :: (Eq a, Show a) => a -> Free DSL a -> Either String ()
pure' expected f = 
    case f of
        Pure a | a == expected -> return ()
        otherwise              -> Left $ "Expected " ++ abbreviate' (Pure expected) ++ " but got " ++ abbreviate' f

abbreviate' :: Show a => Free DSL a -> String
abbreviate' (Pure a) = "(Pure " ++ showsPrec 10 a ")"
abbreviate' f        = abbreviate f

与 prompt'和 display'我们可以轻松构建 expect 风格的解释器.

expect :: Free DSL a -> Either String (Free DSL a)
expect f = return f >>=
           prompt' "Enter your name:" "radix" >>=
           display' "Why hello there, radix." >>=
           prompt' "And what is your friend's name?" "Bob" >>=
           display' "It's good to meet you too, Bob."

运行这个测试

main = either putStrLn (putStrLn . const "Passed") $ expect greet

导致失败

Expected (Prompt "Enter your name:" ...) but got (Free (Prompt "Enter your name: " ...))

一旦我们将测试更改为在提示末尾有空格

expect :: Free DSL a -> Either String (Free DSL a)
expect f = return f >>=
           prompt' "Enter your name: " "radix" >>=
           display' "Why hello there, radix." >>=
           prompt' "And what is your friend's name? " "Bob" >>=
           display' "It's good to meet you too, Bob."

运行它会导致

Passed