原文颖杏。
https://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours/Defining_Scheme_Functions
現(xiàn)在既然可以定義變量了，我們就來把它擴(kuò)展到函數(shù)上來坛芽。在這章之后留储，你就能夠在你的Scheme里定義并使用你自己的函數(shù)了。我們的整個實現(xiàn)也就基本完成了咙轩。
讓我們從給LispVal定義新的構(gòu)造器開始：
| PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
| Func { params :: [String], vararg :: (Maybe String),
body :: [LispVal], closure :: Env }
我們?yōu)樵瘮?shù)添加了一個額外的構(gòu)造器获讳，因為我們會希望能夠?qū)?code>+,eqv?這樣的原生函數(shù)作為變量傳遞給其他函數(shù)。我們的PrimitiveFunc構(gòu)造器包含了一個讀入?yún)?shù)列表然后返回一個ThrowsError LispVal的函數(shù)活喊，就和我們在primitive列表里存儲的類型一樣丐膝。
我們還為用戶定義的函數(shù)添加了一個構(gòu)造器。我們會在其中存儲以下四種信息：
- 與函數(shù)體綁定的參數(shù)名稱钾菊；
- 函數(shù)是否接受可變長度的參數(shù)尤误，如果接受的話，參數(shù)綁定的變量是什么结缚；
- 一個表達(dá)式列表损晤，也就是函數(shù)體；
- 函數(shù)定義所在的環(huán)境红竭。
這是一個record類型的例子尤勋。Record在Haskell中看起來有點笨重，因此我們也只是在這里示范以下茵宪。然而在大規(guī)模的編程開發(fā)中最冰，他有著無可替代的價值。
接下來稀火，我們在show函數(shù)中添加新的類型：
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) ++ ") ...)"
我們這里對原生函數(shù)僅僅打印了<primitive>暖哨，對用戶自定義的函數(shù)則是打印出來頭部信息，而不是將整個函數(shù)體全部打印出來凰狞。這是一個對Record進(jìn)行模式匹配的例子：與普通的代數(shù)類型一樣篇裁，模式看起來和構(gòu)造器是一樣的。前面是字段名然后緊跟著的是會與值綁定的變量名稱赡若。
接下來达布，我們需要修改apply函數(shù)。和之前傳遞函數(shù)名不同的是逾冬，現(xiàn)在我們直接將代表函數(shù)的LispVal值傳遞給它黍聂。對于原生函數(shù)來說代碼變得更簡單了：我們將函數(shù)值從參數(shù)中讀出然后應(yīng)用就可以了躺苦。
apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
apply (PrimitiveFunc func) args = liftThrows $ func args
當(dāng)我們處理用戶自定義函數(shù)的時候，有趣的事情發(fā)生了产还。Record類型不僅允許你對字段名進(jìn)行匹配匹厘，你也可以通過位置來識別它們，我們來試試看：
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
這里第一步是確認(rèn)參數(shù)列表的長度脐区，判斷和期望的參數(shù)是否一致愈诚。如果不一致的話則會拋出一個錯誤。我們還定義了一個局部的num函數(shù)來增加代碼的可讀性并讓程序更短坡椒。
如果調(diào)用是合法的扰路，那我們就會在Monad管理進(jìn)行一系列操作，將參數(shù)綁定給新的環(huán)境倔叼，然后執(zhí)行函數(shù)體中的語句汗唱。我們做的第一件事就是將參數(shù)名稱的列表和已經(jīng)經(jīng)過計算的參數(shù)值列表通過zip函數(shù)拉成一個鍵值對的列表。然后我們用這個列表和函數(shù)的閉包（其實這并不是當(dāng)前的環(huán)境丈攒，而只是函數(shù)的靜態(tài)作用域）組成一個新的環(huán)境并且將函數(shù)在其中進(jìn)行求值哩罪。返回的結(jié)果是IO類型的，而整個函數(shù)的返回值是IOThrowsError類型巡验，因此我們需要使用liftIO來將它進(jìn)行轉(zhuǎn)換际插。
接下來，我們將剩余的參數(shù)通過局部函數(shù)bindVarArgs綁定給varArgs變量显设。如果函數(shù)不需要可變參數(shù)（Nothing子句）框弛，那我們就將現(xiàn)在的環(huán)境返回。不然的話捕捂，我們創(chuàng)建一個將變量名作為鍵瑟枫，輸入?yún)?shù)為值的列表然后把它傳給bindVars。方便起見我們定義它為局部變量remainingArgs指攒，并用內(nèi)置的drop函數(shù)來忽略之前已經(jīng)綁定過得參數(shù)慷妙。
最后一步是在新的環(huán)境中對函數(shù)體進(jìn)行求值。我們?yōu)榱诉@個定義了一個局部函數(shù)evalBody允悦。它將eval env這個Monad函數(shù)映射到了每一個函數(shù)體中的語句膝擂，然后講最后一個語句的值返回。
我們現(xiàn)在將原生函數(shù)存儲在普通的變量值里隙弛，讓我們來在程序開始的時候預(yù)先綁定它們：
primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip bindVars $ map makePrimitiveFunc primitives)
where makePrimitiveFunc (var, func) = (var, PrimitiveFunc func)
這里我們首先將最初的空環(huán)境讀入架馋，將封裝好的原生函數(shù)扎成一捆鍵值對，然后再將它們一起綁定成新的環(huán)境驶鹉。讓我們在runOne和runRepl里也替換成primitiveBindings函數(shù)：
runOne :: String -> IO ()
runOne expr = primitiveBindings >>= flip evalAndPrint expr
runRepl :: IO ()
runRepl = primitiveBindings >>= until_ (== "quit") (readPrompt "Lisp>>> ") . evalAndPrint
最后讓我們來修改求值器讓它來支持lambda函數(shù)以及define功能绩蜻。我們從幾個能在IOThrowsError中幫助我們創(chuàng)建函數(shù)對象的輔助函數(shù)開始：
makeFunc varargs env params body = return $ Func (map showVal params) varargs body env
makeNormalFunc = makeFunc Nothing
makeVarArgs = makeFunc . Just . showVal
這里makeNormalFunc和makeVarArgs函數(shù)只是MakeFunc函數(shù)的在普通情況和可變參數(shù)情況下的特殊形式而已。這是一個如何將函數(shù)看做一等公民然后簡化代碼的很好的例子室埋。
現(xiàn)在我們用它們來添加新的求值子句。我們在定義變量以及函數(shù)應(yīng)用的子句之間添加以下內(nèi)容：
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
之前的求值函數(shù)中的函數(shù)應(yīng)用部分的子句也需要替換掉：
eval env (List (function : args)) = do
func <- eval env function
argVals <- mapM (eval env) args
apply func argVals
正如你所見，這里我們用模式匹配來對輸入?yún)?shù)進(jìn)行解構(gòu)姚淆，然后調(diào)用適當(dāng)?shù)妮o助函數(shù)孕蝉。在定義define的時候，我們還需要將結(jié)果傳入到defineVar函數(shù)來將變量綁定到本地環(huán)境當(dāng)中腌逢。我們還需要將函數(shù)應(yīng)用部分的子句進(jìn)行修改降淮，因為現(xiàn)在apply函數(shù)能夠在IOThrowsError Monad中工作了，所以我們也不需要liftThrows函數(shù)了搏讶。
編譯并且運行程序佳鳖，現(xiàn)在我們可以用它來寫我們自己的程序了！
$ 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