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