原文。
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 (>=)),
这里会用到一些我们还没有开始写的辅助函数：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条件：模式匹配
现在，我们继续将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里有点难实现，不过在接下来的两章之后你可能就能够实现它了。