用 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