11

所以我正在尝试做一些新颖的事情（我认为），但我对 Haskell 类型级编程的经验不足，无法自己解决。

我有一个免费的单子，描述了一些要执行的效果（一个 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元组是没有用的，因为它的类型是一个巨大的东西，我不能写一个通用runTest函数。我遇到的主要问题是我应该如何表示这个预期意图的序列，以便我可以编写一个函数，该函数适用于任何程序的任何序列Free DSL a。

  1. 我隐约知道 Haskell 中的各种高级类型级功能，但我还没有经验知道应该尝试使用哪些东西。
  2. 我应该为我的expected序列使用 HList 或其他东西吗？

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

4

1 回答 1

11

对程序的测试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'期望 aPure具有特定值

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
于 2015-09-20T17:48:58.267 回答