在 48 小時內編寫你自己的 Scheme/評估，第二部分

附加原語：部分應用

現在我們能夠處理型別錯誤、錯誤引數等等，我們將充實我們的基本列表，使其不僅能進行計算，還能做更多的事情。我們將添加布爾運算子、條件語句和一些基本字串操作。

首先將以下內容新增到基本列表中：

("=", 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

因為每個引數都可能丟擲型別不匹配異常，所以我們必須在 do 塊中（用於 Error 單子）按順序解包它們。然後，我們將操作應用於兩個引數，並將結果包裝在 Bool 建構函式中。任何函式都可以透過用反引號（`op`）將其包裝成中綴運算子。

另外，請檢視型別簽名。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

條件語句：模式匹配 2

現在，我們將繼續為我們的評估器新增一個 if 子句。與標準 Scheme 一樣，我們的評估器將 #f 視為假，將任何其他值視為真

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 func 之上，否則它將丟擲一個 Unrecognized primitive function args: "if" 錯誤。

這是巢狀模式匹配的另一個例子。這裡，我們正在尋找一個包含 4 個元素的列表。第一個元素必須是原子 if。其他元素可以是任何 Scheme 表示式。我們取第一個元素，進行評估，如果它是假，則評估備選方案。否則，我們評估結果。

編譯並執行它，你就可以嘗試條件語句了

$ 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

為了更好地衡量，我們還將新增基本列表處理原語。因為我們選擇將列表表示為 Haskell 代數資料型別而不是對，所以這些原語比許多 Lisp 中的定義要複雜一些。最容易理解它們的方式是根據它們對列印的 S 表示式的影響

1. (car '(a b c)) = a
2. (car '(a)) = a
3. (car '(a b . c)) = a
4. (car 'a) = error – 不是列表
5. (car 'a 'b) = error – car 只接受一個引數

我們可以相當直接地將它們翻譯成模式子句，回想起 (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 做同樣的事情

1. (cdr '(a b c)) = (b c)
2. (cdr '(a b)) = (b)
3. (cdr '(a)) = NIL
4. (cdr '(a . b)) = b
5. (cdr '(a b . c)) = (b . c)
6. (cdr 'a) = error – 不是列表
7. (cdr 'a 'b) = error – 太多引數了

我們可以用一個子句來表示前三個情況。我們的解析器將 '() 表示為 List []，當你將 (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 操作都是錯誤的

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

大多數這些子句是不言自明的，例外的是兩個 Lists 的子句。這在確保列表長度相等後，zip 了兩個對列表，然後使用函式 all 在 eqvPair 對任何一對返回 False 時返回 False。eqvPair 是區域性定義的例子：它是使用 where 關鍵字定義的，就像普通函式一樣，但只能在該特定 eqv 子句中使用。由於我們知道 eqv 只有在引數數量不為 2 時才會丟擲錯誤，因此行 Left err -> False 目前永遠不會執行。

equal? 和弱型別：異構列表

既然我們在上面引入了弱型別，我們也希望引入一個 equal? 函式，它會忽略型別標籤的差異，只測試兩個值是否可以解釋為相同的值。例如，(eqv? 2 "2") = #f，但我們希望 (equal? 2 "2") = #t。基本上，我們希望嘗試所有解包函式，如果其中任何一個導致 Haskell 值相等，則返回 True。

最顯而易見的方法是將解包函式儲存在一個列表中，並使用 mapM 按順序執行它們。不幸的是，這行不通，因為標準 Haskell 只能讓你將物件放在一個列表中 *如果它們型別相同*。各種解包函式返回不同的型別，因此你無法將它們儲存在同一個列表中。

我們將透過使用 GHC 擴充套件 - 存在量化型別 - 來解決這個問題，它允許我們建立一個異構列表，並受型別類約束。擴充套件在 Haskell 世界中相當普遍：它們基本上是建立任何合理的大型程式所必需的，而且它們在不同實現之間通常是相容的（存在量化型別在 Hugs 和 GHC 中都適用，並且是標準化的候選者）。請注意，你需要為此使用特殊的編譯器標誌：-fglasgow-exts 如以下所述；或者更新的 -XExistentialQuantification；或者將編譯指示 {-# LANGUAGE ExistentialQuantification #-} 新增到程式碼開頭（一般來說，編譯器標誌 -Xfoo 可以用程式碼檔案中的編譯指示 {-# LANGUAGE foo #-} 代替）。

我們需要做的第一件事是定義一個數據型別，它可以容納從 LispVal -> something 的任何函式，前提是該 something 支援相等性

data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)

這就像任何正常的代數資料型別，除了型別約束。它說，“對於任何是 `Eq` 例項的型別，你可以定義一個 `Unpacker`，它接受一個從 `LispVal` 到該型別的函式，並且可能丟擲錯誤”。我們必須用 `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` 單子的 do 塊。這將檢索兩個 `LispVal` 的 Haskell 值，然後測試它們是否相等。如果兩個解包器中的任何地方出現錯誤，它將返回 `False`，使用 `const` 函式，因為 `catchError` 期望一個函式來應用於錯誤值。

最後，我們可以根據這些輔助函式定義 `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。這也讓我們避免處理像列表或帶點的列表這樣的情況（儘管這引入了一個錯誤；請參閱本節中的練習 #2）。

最後，`equal?` 將這兩個值 `or` 起來，並將結果包裝在 `Bool` 建構函式中，返回一個 `LispVal`。`let (Bool x) = eqvEquals in x` 是一種從代數型別中提取值的方法：它將 `Bool x` 與 `eqvEquals` 值進行模式匹配，然後返回 `x`。let 表示式的結果是關鍵字 `in` 後的表示式。

要使用這些函式，請將它們插入我們的基本函式列表中。

("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` 值，並在任何其他值上丟擲錯誤。 equal? 存在一個錯誤，即使用 `eqv?` 而不是 `equal?` 來比較值列表。例如，` (equal? '(1 "2") '(1 2)) = #f`，而你希望它為 `#t`。更改 `equal?`，使其在遞迴進入列表結構時繼續忽略型別。你可以透過顯式地執行此操作，遵循 `eqv?` 中的示例，或者將列表子句分解為一個由相等性測試函式引數化的輔助函式。 實現 `cond` 和 `case` 表示式。 新增其餘的 字串函式。你現在還不知道如何做 `string-set!`；這在 Haskell 中很難實現，但你將在接下來的兩節中獲得足夠的資訊。