原文。
https://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours/Evaluation,_Part_2
更多操作：部分應用
既然現在我們可以來處理類型和參數之類的錯誤了，我們來重新整理下primitive列表并讓它能夠處理一些計算以外的事情。我們會添加一些布爾操作符，條件語句和一些基本的字符串操作。
從給primitives列表添加以下內容開始：
("=", numBoolBinop (==)),
("<", numBoolBinop (<)),
(">", numBoolBinop (>)),
("/=", numBoolBinop (/=)),
(">=", numBoolBinop (>=)),
("<=", numBoolBinop (<=)),
("&&", boolBoolBinop (&&)),
("||", boolBoolBinop (||)),
("string=?", strBoolBinop (==)),
("string<?", strBoolBinop (<)),
("string>?", strBoolBinop (>)),
("string<=?", strBoolBinop (<=)),
("string>=?", strBoolBinop (>=)),
這里會用到一些我們還沒有開始寫的輔助函數：numBoolBinop，boolBoolBinop和strBoolBinop。與之前那些讀取一些數字參數并返回一個整型的函數不同，這些函數都會讀取兩個參數并且返回一個布爾值。并且事實上它們僅僅是期望的參數類型不同而已，因此這里我們將邏輯整理成一個通用的boolBinop函數并傳入一個會對參數進行處理的解包函數：
boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args = if length args /= 2
then throwError $ NumArgs 2 args
else do left <- unpacker $ args !! 0
right <- unpacker $ args !! 1
return $ Bool $ left `op` right
由于每個參數都有可能會拋出一個類型不匹配的錯誤，因此我們必須為了Error Monad而在一個do代碼塊中將它們依次分解。然后再將操作符運用在兩個參數上并且將結果用Bool構造器封裝起來。任何一個函數都能夠通過一對反引號將它變成一個中綴操作符。
同時我們也來看下類型簽名。boolBinop函數讀取兩個函數作為它的前兩個參數：第一個用來將參數從LispVal類型解包成原生的Haskell類型，而第二個則是實際進行的操作。通過將部分的行為參數化，代碼的重用性變得更好了。
現在來根據不同情況下的解包函數來通過boolBinop定義三個函數：
numBoolBinop = boolBinop unpackNum
strBoolBinop = boolBinop unpackStr
boolBoolBinop = boolBinop unpackBool
現在我們還沒告訴Haskell如何從LispVal類型的值中解包出字符串。這其實和unpackNum函數類似，我們只需要對目標值進行模式匹配并且在失敗時拋出錯誤就行了。同樣，如果傳入的是一個可以被解釋成字符串的其他基本類型（數字或者布爾值）我們也會同樣默默將它轉換成對應的字符串表達形式。
unpackStr :: LispVal -> ThrowsError String
unpackStr (String s) = return s
unpackStr (Number s) = return $ show s
unpackStr (Bool s) = return $ show s
unpackStr notString = throwError $ TypeMismatch "string" notString
使用類似的代碼來對布爾值解包：
unpackBool :: LispVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
在進入下一步之前，先編譯并運行幾個例子來看看它是否正確：
$ ghc -package parsec -o simple_parser [../code/listing6.1.hs listing6.1.hs]
$ ./simple_parser "(< 2 3)"
#t
$ ./simple_parser "(> 2 3)"
#f
$ ./simple_parser "(>= 3 3)"
#t
$ ./simple_parser "(string=? \"test\" \"test\")"
#t
$ ./simple_parser "(string<? \"abc\" \"bba\")"
#t
條件：模式匹配
現在，我們繼續將if語句添加到我們的求值器中。根據Scheme標準，我們這里會認為除了#f以外的其他所有值都是True：
eval (List [Atom "if", pred, conseq, alt]) =
do result <- eval pred
case result of
Bool False -> eval alt
otherwise -> eval conseq
由于函數定義是會被依次進行計算的，這部分記得需要放在eval (List (Atom func : args)) = mapM eval args >>= apply funcq前面不然它會拋出一個Unrecognized primitive function args: "if"錯誤。
這又是一個嵌套模式匹配的例子。這里，我們要匹配一個四元素的列表。其他第一元素元素必須是Atom類型的if，其他則可能是任意的Scheme類型。我們求出pred的值，如果它是False的，則函數返回alt的值，否則的話，我們計算并返回conseq的值。
編譯并運行程序，你就能嘗試使用條件分支了：
$ ghc -package parsec -o simple_parser [../code/listing6.2.hs listing6.2.hs]
$ ./simple_parser "(if (> 2 3) \"no\" \"yes\")"
"yes"
$ ./simple_parser "(if (= 3 3) (+ 2 3 (- 5 1)) \"unequal\")"
9
列表操作：car cdr和cons
接下來我們將一些基本的列表操作添加到primitives中。由于我們已經選擇了使用Haskell的代數類型而不是Pair類型來表達列表了，因此這里的定義就反而可能比在大部分Lisp里更加復雜一點。通過打印出來得S表達式也許你能夠更加容易的理解它們的效果：
- (car '(a b c)) = a
- (car '(a)) = a
- (car '(a b . c)) = a
- (car 'a) = error – not a list
- (car 'a 'b) = error – car only takes one argument
我們可以直接將它們翻譯成對應的模式匹配子句，記得(x:xs)會將一個列表分割成第一個元素以及接下來的其他部分：
car :: [LispVal] -> ThrowsError LispVal
car [List (x : xs)] = return x
car [DottedList (x : xs) _] = return x
car [badArg] = throwError $ TypeMismatch "pair" badArg
car badArgList = throwError $ NumArgs 1 badArgList
cdr函數也是同樣：
- (cdr '(a b c)) = (b c)
- (cdr '(a b)) = (b)
- (cdr '(a)) = NIL
- (cdr '(a . b)) = b
- (cdr '(a b . c)) = (b . c)
- (cdr 'a) = error – not a list
- (cdr 'a 'b) = error – too many arguments
我們可以用一個子句來代表前三種情況。我們的解析器將'()認為是一個空列表[]，并且當你使用(x:xs)來對[x]進行匹配時，xs會綁定到一個空列表[]。其他的情況我們都用單獨的子句來表示：
cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (x : xs)] = return $ List xs
cdr [DottedList [_] x] = return x
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [badArg] = throwError $ TypeMismatch "pair" badArg
cdr badArgList = throwError $ NumArgs 1 badArgList
cons函數會有一點棘手，所以我們還是來一個個看下各種可能發生的情況吧。如果你將任何一個值和空列表（Nil）通過cons結合，那么你就會得到一個單元素的列表，Nil會充當一個終止符：
cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []] = return $ List [x1]
如果你將任意值和一個列表通過cons結合，這就像是就那個值插進列表的最前面：
cons [x, List xs] = return $ List $ x : xs
然后，如果你處理的是一個DottedList，那你需要考慮不正確的尾元素的情況并讓它保持還是一個合法的DottedList：
cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast
如果你把兩個都不是列表的對象通過cons組合，或者把列表作為第一個參數，那就會得到一個DottedList。這是因為這樣通過cons組合的部分不像其他普通列表那樣由一個Nil來終結的緣故。
cons [x1, x2] = return $ DottedList [x1] x2
最后，任意傳入大于或小于兩個參數的情況都會引起錯誤：
cons badArgList = throwError $ NumArgs 2 badArgList
我們的最后一步是實現一個eqv?函數。Scheme提供了三種不同程度的相等斷言：eq?，eqv?以及equal?。對我們來說，eq?和eqv?基本上是一樣的：如果兩個值打印出來的結果是一樣的，那它們就相等，雖然貌似這樣運行起來也許會比較慢。所以我們這里就為它們兩個提供一個實現并且將它注冊成eq?和eqv?。
eqv :: [LispVal] -> ThrowsError LispVal
eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) &&
(all eqvPair $ zip arg1 arg2)
where eqvPair (x1, x2) = case eqv [x1, x2] of
Left err -> False
Right (Bool val) -> val
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList
除了處理兩個List值的部分，其他子句大多都是自解釋的。這里，在檢查確認了兩個列表是相等的長度之后，使用zip函數將列表配對并一一進行對比。eqvPair函數式一個局部定義的例子：它用where關鍵詞來定義，除了它的作用域僅僅是eqv函數的一個子句，其他都和普通的函數一樣。這里由于我們已經知道eqv函數只會在傳遞給它的不是兩個參數的時候才會拋出一個錯誤，因此Left err -> False這行其實是永遠也不會被執行的。
equal?和弱類型：異構列表
之前我們已經介紹過有關弱類型的概念了，因此這里我們嘗試創建一個equal?函數，它會忽視類型并僅僅判斷兩個值是否能被解釋成相同的結果。舉個栗子，(eqv? 2 "2") = #f，但我們希望能夠得到(equal? 2 "2") = #t。基本上，我們需要嘗試所有的解包方法，如果它們中的任何一個會讓對應的Haskell值相等，那就返回True。
一個顯而易見的方法就是把所有解包的函數都放進一個列表里然后通過mapM函數讓它們逐個執行。然而很不幸你沒法這么干，因為Haskell不允許你將不同類型的值放進同一個列表中。各式各樣的解包函數顯然會返回不同的類型，因此你沒法將它們存在一起。
我們這里需要使用一個GHC的擴展包--Existential Types，來使用異構列表，雖然它仍然需要受到類型類的約束。擴展在Haskell的使用當中是相當常見的：基本上你如果需要寫一些靠譜的大型程序都會或多或少用刀，它們也往往能互相兼容（Existential Types在Hugs和GHC里都運行良好并且很有希望被納入Haskell標準）。注意你需要使用一個特別的編譯參數來開啟這個功能：-fglasgow-exts。也可以添加-XExistentialQuantification或者是在程序的最開始加上這么一段注解{-# LANGUAGE ExistentialQuantification #-}。（總的來說，編譯時的參數位-Xfoo都可以被在源代碼中的{-# LANGUAGE foo #-}注解來替代。）
首先我們需要定義一個能夠表示LispVal -> something的函數的類型，只要這個something能夠支持判等：
data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
這里和其他普通的代數數據類型都是類似的，除了這里有一個類型限制。它表示“對于任意是Eq實例的類型，你可以定義一個讀取一個將LispVal轉換成那個類型并且有可能拋出錯誤的函數作為參數的Unpacker類型”。我們將這個函數通過AnyUnpacker構造器進行封裝，然后我們就可以創建一個Unpacker列表來實現我們之前想要的效果。
在equal?函數的定義之前，我們來首先來看一個讀取一個Unpacker類型然后判斷兩個LispVal值在解包后是否相等的的輔助函數：
unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals arg1 arg2 (AnyUnpacker unpacker) =
do unpacked1 <- unpacker arg1
unpacked2 <- unpacker arg2
return $ unpacked1 == unpacked2
`catchError` (const $ return False)
在通過模式匹配獲取實際的解包函數之后，我們進入了一個ThrowsError Monad的do代碼塊。這里我們獲取兩個LispVal值在Haskell中對應的值然后對它們進行比較。如果在解包的過程中發生了任何錯誤，就也會返回一個False，這里由于catchError函數需要我們傳遞一個函數用來處理錯誤值，我們就直接使用const函數就可以了。
最后，我們給出equal?函數的定義。
equal :: [LispVal] -> ThrowsError LispVal
equal [arg1, arg2] = do
primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
[AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
eqvEquals <- eqv [arg1, arg2]
return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList
這里第一步操作創建了一個異構列表[unpackNum, unpackStr, unpackBool]，然后將一個被部分應用的(unpackEquals arg1 arg2)映射到它上面。得到一個布爾值列表后，我們使用Prelude中的函數or，如果其中任意一個結果是True則為True。
第二部操作使用eqv?函數對兩個參數進行測試。因為我們希望equal?會比eqv?更加寬松的緣故。因此如果eqv?返回True的話，這里也應該直接返回True。這就讓我們能夠避免處理一些類似于列表或者DottedList的情況了。（事實上這里引入了一個bug；練習2會提到）
最后，將上面的值用or連接起來并且將結果封裝在一個Bool構造器里，從而返回一個LispVal。let (Bool x) = eqvEquals in x是一個便捷的從代數類型中分解值得方式：通過模式匹配將eqvEquals中包含的值取出然后返回。這個let表達式的結果即是關鍵詞in之后的部分。
將函數插入到primitives列表中好讓它們能夠被使用：
("car", car),
("cdr", cdr),
("cons", cons),
("eq?", eqv),
("eqv?", eqv),
("equal?", equal)]
你需要通過-fglasgow-exts參數來開啟GHC擴展功能來進行編譯這段代碼：
$ ghc -package parsec -fglasgow-exts -o parser [../code/listing6.4.hs listing6.4.hs]
$ ./parser "(cdr '(a simple test))"
(simple test)
$ ./parser "(car (cdr '(a simple test)))"
simple
$ ./parser "(car '((this is) a test))"
(this is)
$ ./parser "(cons '(this is) 'test)"
((this is) . test)
$ ./parser "(cons '(this is) '())"
((this is))
$ ./parser "(eqv? 1 3)"
#f
$ ./parser "(eqv? 3 3)"
#t
$ ./parser "(eqv? 'atom 'atom)"
#t
習題
- 改變if函數的定義讓它只接受Bool類型的值并在其他情況下拋出異常而不是把所有不是False的值都當做True。
-
equal?函數有一個bug由于在列表中的值都是通過eqv?而不是equal?來比較的。例如，(equal? '(1 "2") '(1 2))會得到一個False，而你也許會希望獲得True。修改equal?函數讓它在對列表進行遞歸計算的時候也會忽略類型。你可以模仿eqv?函數來顯示的定義它也可以將處理list的情況另外創建一個輔助函數來處理，并且將它判等時使用的函數進行參數化。 - 實現cond和case表達式
- 添加剩下的字符串函數。你現在可能還沒法實現一個自己的
string-set!，這在Haskell里有點難實現，不過在接下來的兩章之后你可能就能夠實現它了。
