用 48 小时编写自己的 Scheme/定义 Scheme 函数

现在我们可以定义变量了，我们不妨扩展到函数。在本节之后，您将能够在 Scheme 中定义自己的函数，并从其他函数中使用它们。我们的实现几乎完成了。

让我们从定义新的 LispVal 构造函数开始

| PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
| Func { params :: [String], vararg :: (Maybe String),
         body :: [LispVal], closure :: Env }

我们为原语添加了一个单独的构造函数，因为我们希望能够将 +、eqv? 等存储在变量中并传递给函数。PrimitiveFunc 构造函数存储一个函数，该函数将参数列表作为 ThrowsError LispVal 传递，这与我们原始列表中存储的类型相同。

我们还希望有一个构造函数来存储用户定义的函数。我们存储四块信息

1. 参数名称，正如它们在函数体中绑定一样；
2. 函数是否接受可变长度的参数列表，如果是，则绑定到它的变量名称；
3. 函数体，作为表达式列表；
4. 创建函数的环境。

这是一个 记录 类型的示例。记录在 Haskell 中有点笨拙，因此我们只将它们用于演示目的。但是，它们在大型编程中是无价的。

接下来，我们将希望编辑我们的 show 函数以包含新类型

showVal (PrimitiveFunc _) = "<primitive>"
showVal (Func {params = args, vararg = varargs, body = body, closure = env}) =
   "(lambda (" ++ unwords (map show args) ++
      (case varargs of
         Nothing -> ""
         Just arg -> " . " ++ arg) ++ ") ...)"

我们没有显示完整的函数，而是为原语打印出 <primitive> 一词，为用户定义的函数打印出标题信息。这是一个模式匹配记录的示例：与普通的代数类型一样，模式看起来完全像构造函数调用。字段名位于首位，然后是将要绑定到它们的变量。

接下来，我们需要更改 apply。它不再接收函数的名称，而是接收一个表示实际函数的 LispVal。对于原语，这使得代码更简单：我们只需从值中读取函数并应用它。

apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
apply (PrimitiveFunc func) args = liftThrows $ func args

当我们遇到用户定义的函数时，会发生有趣的代码。记录允许您在字段名称（如上所示）或字段位置上进行模式匹配，因此我们将使用后一种形式

apply (Func params varargs body closure) args =
      if num params /= num args && varargs == Nothing
         then throwError $ NumArgs (num params) args
         else (liftIO $ bindVars closure $ zip params args) >>= bindVarArgs varargs >>= evalBody
      where remainingArgs = drop (length params) args
            num = toInteger . length
            evalBody env = liftM last $ mapM (eval env) body
            bindVarArgs arg env = case arg of
                Just argName -> liftIO $ bindVars env [(argName, List $ remainingArgs)]
                Nothing -> return env

此函数首先要做的事情是检查参数列表的长度是否与预期的参数数量匹配。如果它们不匹配，它将抛出一个错误。我们定义了一个局部函数 num 来提高可读性并使程序更短。

假设调用有效，我们在单子管道中完成调用的大部分工作，将参数绑定到一个新的环境并执行主体中的语句。我们首先要做的是将参数名称列表和（已经评估过的）参数值列表一起压缩成一个键值对列表。然后，我们取它和函数的闭包（不是当前环境 - 这给了我们词法范围），并使用它们创建一个新环境来评估函数。结果是 IO 类型，而整个函数是 IOThrowsError，因此我们需要将其 liftIO 到组合的单子中。

现在是时候将剩余的参数绑定到 varargs 变量，使用局部函数 bindVarArgs。如果函数不接受 varargs（Nothing 子句），那么我们只返回现有环境。否则，我们创建一个单例列表，该列表以变量名称作为键，剩余参数作为值，并将其传递给 bindVars。我们定义局部变量 remainingArgs 用于可读性，使用内置函数 drop 来忽略已经绑定到变量的所有参数。

最后阶段是在这个新环境中评估主体。为此，我们使用局部函数 evalBody，它将单子函数 eval env 映射到主体中的每个语句，然后返回最后一个语句的值。

由于我们现在将原语存储为变量中的常规值，因此我们必须在程序启动时绑定它们

primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip bindVars $ map makePrimitiveFunc primitives)
     where makePrimitiveFunc (var, func) = (var, PrimitiveFunc func)

这将接受初始空环境，创建许多由 PrimitiveFunc 包装器组成的名称/值对，然后将新的对绑定到新环境中。我们还希望将 runOne 和 runRepl 更改为 primitiveBindings

runOne :: String -> IO ()
runOne expr = primitiveBindings >>= flip evalAndPrint expr

runRepl :: IO ()
runRepl = primitiveBindings >>= until_ (== "quit") (readPrompt "Lisp>>> ") . evalAndPrint

最后，我们需要更改评估器以支持 lambda 和函数 define。我们将从创建一些辅助函数开始，以使在 IOThrowsError 单子中创建函数对象更容易

makeFunc varargs env params body = return $ Func (map showVal params) varargs body env
makeNormalFunc = makeFunc Nothing
makeVarArgs = makeFunc . Just . showVal

在这里，makeNormalFunc 和 makeVarArgs 应该被视为 makeFunc 的专门化，第一个参数针对普通函数和可变参数函数进行适当设置。这是一个很好的例子，说明如何使用一等函数来简化代码。

现在，我们可以使用它们来添加额外的 eval 子句。它们应该插入到定义变量子句之后，函数应用子句之前

eval env (List (Atom "define" : List (Atom var : params) : body)) =
     makeNormalFunc env params body >>= defineVar env var
eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body)) =
     makeVarArgs varargs env params body >>= defineVar env var
eval env (List (Atom "lambda" : List params : body)) =
     makeNormalFunc env params body
eval env (List (Atom "lambda" : DottedList params varargs : body)) =
     makeVarArgs varargs env params body
eval env (List (Atom "lambda" : varargs@(Atom _) : body)) =
     makeVarArgs varargs env [] body

以下需要替换先前的函数应用 eval 子句。

eval env (List (function : args)) = do
     func <- eval env function
     argVals <- mapM (eval env) args
     apply func argVals

如您所见，它们只是使用模式匹配来解构表单，然后调用相应的函数助手。在 define 的情况下，我们还将输出馈送到 defineVar 以在本地环境中绑定变量。我们还需要更改函数应用子句以删除 liftThrows 函数，因为 apply 现在在 IOThrowsError 单子中工作。

我们现在可以编译和运行我们的程序，并使用它来编写真正的程序！

$ ghc -package parsec -fglasgow-exts -o lisp [../code/listing9.hs listing9.hs]
$ ./lisp
Lisp>>> (define (f x y) (+ x y))
(lambda ("x" "y") ...)
Lisp>>> (f 1 2)
3
Lisp>>> (f 1 2 3)
Expected 2 args; found values 1 2 3
Lisp>>> (f 1)
Expected 2 args; found values 1
Lisp>>> (define (factorial x) (if (= x 1) 1 (* x (factorial (- x 1)))))
(lambda ("x") ...)
Lisp>>> (factorial 10)
3628800
Lisp>>> (define (counter inc) (lambda (x) (set! inc (+ x inc)) inc))
(lambda ("inc") ...)
Lisp>>> (define my-count (counter 5))
(lambda ("x") ...)
Lisp>>> (my-count 3)
8
Lisp>>> (my-count 6)
14
Lisp>>> (my-count 5)
19