如何将指定为免费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列表中下一个项目执行的每个效果来解释程序.然后应该将相关值(每对中的第二项)作为该效果的结果返回给程序.如果所有效果都匹配,则程序的最终结果应作为a返回Just.如果有什么不匹配,Nothing则应返回(稍后我将展开它以便它返回一条信息性错误消息).

当然这个expect元组是没用的,因为它的类型是一个巨大的东西,我无法编写泛型runTest函数.我遇到的主要问题是我应该如何表达这个预期意图序列,我可以编写一个函数,对任何程序使用任何序列Free DSL a.

1. 我隐约知道Haskell中的各种高级类型级功能,但我还不知道应该尝试使用哪些东西.
2. 我应该在我的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具有特定值的a并为函数提供响应值以查找下一个.

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具有特定值的a.

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具有特定值的a

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