在 48 小时内编写自己的 Scheme/错误检查和异常

目前，代码中有很多地方我们要么忽略错误，要么静默地分配像 #f 或 0 这样的“默认”值，这些值毫无意义。一些语言——比如 Perl 和 PHP——很好地处理了这种方法。然而，这通常意味着错误会静默地传递到整个程序，直到它们变成大问题，这会导致程序员很不方便的调试过程。我们希望在错误发生时立即发出信号，并立即退出执行。

首先，我们需要导入 Control.Monad.Except 来访问 Haskell 内置的错误函数

import Control.Monad.Except

在基于 Debian 的系统上，这需要安装 libghc6-mtl-dev。

然后，我们应该定义一个数据类型来表示错误

data LispError = NumArgs Integer [LispVal]
               | TypeMismatch String LispVal
               | Parser ParseError
               | BadSpecialForm String LispVal
               | NotFunction String String
               | UnboundVar String String
               | Default String

这比我们目前需要的构造函数多一些，但我们不妨预测一下解释器中可能出现的其他错误。接下来，我们定义如何打印出各种类型的错误，并使 LispError 成为 Show 的实例

showError :: LispError -> String
showError (UnboundVar message varname)  = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func)    = message ++ ": " ++ show func
showError (NumArgs expected found)      = "Expected " ++ show expected 
                                       ++ " args; found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected
                                       ++ ", found " ++ show found
showError (Parser parseErr)             = "Parse error at " ++ show parseErr

instance Show LispError where show = showError

然后我们定义一个类型来表示可能抛出 LispError 或返回值的函数。请记住，parse 如何使用 Either 数据类型来表示异常？我们在这里采用相同的方法

type ThrowsError = Either LispError

类型构造函数就像函数一样是柯里化的，也可以部分应用。完整的类型将是 Either LispError Integer 或 Either LispError LispVal，但我们想说 ThrowsError LispVal 等等。我们只将 Either 部分应用于 LispError，创建了一个类型构造函数 ThrowsError，我们可以在任何数据类型上使用它。

Either 是单子的另一个实例。在这种情况下，在 Either 操作之间传递的“额外信息”是是否发生了错误。Bind 在 Either 操作持有正常值时应用其函数，或者在没有计算的情况下直接传递错误。这就是其他语言中异常的工作方式，但由于 Haskell 是惰性求值的，因此不需要单独的控制流结构。如果 bind 确定一个值已经是错误，那么函数将永远不会被调用。

Control.Monad.Except 库会自动为 Either 单子提供除标准单子函数之外的另外两个函数

1. throwError，它接受一个 Error 值并将其提升到 Either 的 Left（错误）构造函数中
2. catchError，它接受一个 Either 操作和一个将错误转换为另一个 Either 操作的函数。如果操作表示错误，它将应用该函数，您可以使用它来，例如，通过 return 将错误值转换为正常值或将其重新抛出为不同的错误。

在我们的程序中，我们将把所有错误转换为它们的字符串表示形式，并将其作为正常值返回。让我们创建一个辅助函数来为我们做到这一点

trapError action = catchError action (return . show)

调用 trapError 的结果是另一个 Either 操作，它将始终具有有效（Right）数据。我们仍然需要从 Either 单子中提取这些数据，以便可以将其传递到其他函数

extractValue :: ThrowsError a -> a
extractValue (Right val) = val

我们故意将 extractValue 对于 Left 构造函数保留为未定义，因为这代表程序员错误。我们打算仅在 catchError 之后使用 extractValue，因此快速失败比将错误值注入程序的其他部分更好。

现在我们拥有了所有基本的基础设施，是时候开始使用我们的错误处理函数了。还记得我们的解析器以前如何在发生错误时只返回一个字符串“无匹配”吗？让我们更改它，使其包装并抛出原始的 ParseError

readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
     Left err -> throwError $ Parser err
     Right val -> return val

在这里，我们首先使用 LispError 构造函数 Parser 包装原始 ParseError，然后使用内置函数 throwError 在我们的 ThrowsError 单子中返回它。由于 readExpr 现在返回一个单子值，我们还需要在另一个案例中包装一个 return 函数。

接下来，我们将 eval 的类型签名更改为返回一个单子值，相应地调整返回值，并添加一个子句，如果我们遇到不识别的模式，则抛出错误

eval :: LispVal -> ThrowsError LispVal
eval val@(String _) = return val
eval val@(Number _) = return val
eval val@(Bool _) = return val
eval (List [Atom "quote", val]) = return val
eval (List (Atom func : args)) = mapM eval args >>= apply func
eval badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm

由于函数应用子句递归调用 eval（它现在返回一个单子值），我们需要更改该子句。首先，我们必须将 map 更改为 mapM，它将一个单子函数映射到一个值的列表，使用 bind 将生成的动作按顺序排列在一起，然后返回一个包含内部结果的列表。在 Error 单子中，这种排序会顺序执行所有计算，但如果其中任何一个失败，则会抛出一个错误值——在成功时提供 Right [results]，在失败时提供 Left error。然后，我们使用单子“bind”操作将结果传递到部分应用的“apply func”，如果任一操作失败，同样也会返回一个错误。

接下来，我们更改 apply 本身，使其在不识别函数时抛出错误

apply :: String -> [LispVal] -> ThrowsError LispVal
apply func args = maybe (throwError $ NotFunction "Unrecognized primitive function args" func)
                        ($ args)
                        (lookup func primitives)

我们没有为函数应用 ($ args) 添加 return 语句。我们即将更改原语的类型，以便从查找中返回的函数返回 ThrowsError 操作

primitives :: [(String, [LispVal] -> ThrowsError LispVal)]

当然，我们需要更改实现这些原语的 numericBinop 函数，使其在只有一个参数时抛出错误

numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop op           []  = throwError $ NumArgs 2 []
numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params        = mapM unpackNum params >>= return . Number . foldl1 op

我们使用 at-pattern 来捕获单值情况，因为我们希望将传递的实际值包括在内以进行错误报告。在这里，我们正在寻找一个只有一个元素的列表，我们不关心该元素是什么。我们还需要使用 mapM 对 unpackNum 的结果进行排序，因为对 unpackNum 的每次单独调用都可能因 TypeMismatch 而失败

unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String n) = let parsed = reads n in 
                           if null parsed 
                             then throwError $ TypeMismatch "number" $ String n
                             else return $ fst $ parsed !! 0
unpackNum (List [n]) = unpackNum n
unpackNum notNum     = throwError $ TypeMismatch "number" notNum

最后，我们需要更改我们的主函数以使用整个大型错误单子。这可能会变得有点复杂，因为现在我们正在处理两个单子（Either（用于错误）和 IO）。因此，我们回到 do-notation，因为当一个单子的结果嵌套在另一个单子中时，几乎不可能使用无点风格

main :: IO ()
main = do
     args <- getArgs
     evaled <- return $ liftM show $ readExpr (args !! 0) >>= eval
     putStrLn $ extractValue $ trapError evaled

以下是这个新函数的功能

1. args 是命令行参数的列表。
2. evaled 是以下结果的组合：
   1. 获取第一个参数（args !! 0）；
   2. 解析它（readExpr）；
   3. 将其传递给 eval（>>= eval；bind 操作的优先级高于 $）；
   4. 在 Error 单子中调用 show。（还要注意，整个操作的类型为 IO (Either LispError String)，使 evaled 的类型为 Either LispError String。它必须是，因为我们的 trapError 函数只能将错误转换为 String，并且该类型必须与正常值的类型匹配。）
3. Caught 是以下结果的组合：
   1. 对 evaled 调用 trapError，将错误转换为它们的字符串表示形式；
   2. 调用 extractValue 从此 Either LispError String 操作中获取 String；
   3. 通过 putStrLn 打印结果。

编译并运行新的代码，并尝试抛出一些错误

$ ghc -package parsec -o errorcheck [../code/listing5.hs listing5.hs]
$ ./errorcheck "(+ 2 \"two\")"
Invalid type: expected number, found "two"
$ ./errorcheck "(+ 2)"
Expected 2 args; found values 2
$ ./errorcheck "(what? 2)"
Unrecognized primitive function args: "what?"

一些读者报告说，您需要添加一个 --make 标志来构建此示例，以及所有后续清单。这会告诉 GHC 构建一个完整的可执行文件，搜索导入语句中列出的所有依赖项。上面的命令在我的系统上有效，但如果它在您的系统上失败，请尝试使用 --make。