在 48 小時內編寫自己的 Scheme/新增變數和賦值

最後，我們終於要接觸到真正的精華部分：變數。變數允許我們儲存表示式的結果，並在以後引用它。在 Scheme 中，變數也可以被重置為新值，因此它的值會隨著程式的執行而改變。這給 Haskell 帶來了一些複雜性，因為它的執行模型是建立在返回值的函式基礎上的，而這些函式永遠不會改變值。

儘管如此，在 Haskell 中模擬狀態的方法有很多，它們都涉及到單子。最簡單的可能就是 狀態單子，它允許你在單子中隱藏任意狀態，並在幕後傳遞它。你可以將狀態型別指定為單子的引數（例如，如果一個函式返回一個整數，但修改了一個字串對的列表，它的型別將為 State [(String, String)] Integer），並透過 get 和 put 函式訪問它，通常在 do 塊中。你可以透過 runState myStateAction initialList 指定初始狀態，它將返回一個包含返回值和最終狀態的元組。

不幸的是，狀態單子不適合我們，因為我們需要儲存的資料型別相當複雜。對於一個簡單的頂級環境，我們可以用 [(String, LispVal)] 來儲存變數名到值的對映。但是，當我們開始處理函式呼叫時，這些對映變成了一個任意深度的巢狀環境堆疊。當我們新增閉包時，環境可能會被儲存在一個任意的 Function 值中，並在整個程式中傳遞。事實上，它們可能被儲存在一個變數中，並完全從 runState 單子中傳遞出去，而我們不允許這樣做。

相反，我們使用一個稱為 *狀態執行緒* 的功能，讓 Haskell 為我們管理聚合狀態。這讓我們能夠像在任何其他程式語言中一樣對待可變變數，使用函式來獲取或設定變數。狀態執行緒有兩種形式：ST 單子 建立一個有狀態的計算，它可以作為一個單元執行，而狀態不會洩漏到程式的其餘部分。IORef 模組 允許你在 IO 單子中使用有狀態的變數。由於我們的狀態必須與 IO 交織在一起（它在 REPL 的行之間持久存在，並且我們最終會在語言本身中擁有 IO 函式），我們將使用 IORef。

我們可以先匯入 Data.IORef 併為我們的環境定義一個型別

import Data.IORef

type Env = IORef [(String, IORef LispVal)]

這將 Env 宣告為一個 IORef，它包含一個將 String 對映到可變 LispVal 的列表。我們需要 IORef 來表示列表本身和單個值，因為程式可以透過 *兩種* 方式來修改環境。它可以使用 set! 來改變單個變數的值，這種改變對於任何共享該環境的函式都是可見的（Scheme 允許巢狀作用域，因此外部作用域中的變數對於所有內部作用域都是可見的）。或者它可以使用 define 來新增一個新變數，該變數應該對所有後續語句可見。

由於 IORef 只能在 IO 單子中使用，因此我們需要一個輔助操作來建立一個空環境。我們不能直接使用空列表 []，因為對 IORef 的所有訪問都必須按順序進行，因此空環境的型別為 IO Env，而不是簡單的 Env

nullEnv :: IO Env
nullEnv = newIORef []

從這裡開始，事情變得更加複雜，因為我們將同時處理 *兩個* 單子。記住，我們還需要一個 Error 單子來處理未繫結變數等問題。需要 IO 功能的部分和可能丟擲異常的部分是交織在一起的，因此我們不能只捕獲所有異常，並將僅正常值返回給 IO 單子。

Haskell 提供了一種稱為 *單子轉換器* 的機制，它允許你組合多個單子的功能。我們將使用其中之一，ExceptT，它允許我們在 IO 單子的頂部新增錯誤處理功能。我們的第一步是為組合的單子建立一個類型別名

type IOThrowsError = ExceptT LispError IO

與 ThrowsError 相似，IOThrowsError 實際上是一個型別構造器：我們省略了最後一個引數，即函式的返回值型別。但是，ExceptT 比普通的 Either 多了一個引數：我們必須指定要在其上疊加錯誤處理功能的單子型別。我們建立了一個單子，它可能包含可能丟擲 LispError 的 IO 操作。

我們有一系列 ThrowsError 和 IOThrowsError 函式，但不同型別的操作不能包含在同一個 do 塊中，即使它們提供了基本上相同的功能。Haskell 已經提供了一種機制，提升，將較低型別（IO）的值帶入組合的單子中。不幸的是，沒有類似的支援將未轉換的較高型別的值帶入組合的單子中，因此我們需要自己編寫它

liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val

這將解構 Either 型別，要麼重新丟擲錯誤型別，要麼返回普通值。型別類中的方法根據表示式的型別來解析，因此 throwError 和 return（分別為 MonadError 和 Monad 的成員）將採用它們的 IOThrowsError 定義。順便說一下，這裡提供的型別簽名不是完全通用的：如果我們省略它，編譯器將推斷 liftThrows :: (MonadError m a) => Either e a -> m a。

我們還需要一個輔助函式來執行整個頂級 IOThrowsError 操作，並返回一個 IO 操作。我們無法從 IO 單子中逃逸，因為執行 IO 的函式會對外部世界產生影響，而你不希望在惰性求值的純函式中出現這種情況。但是你可以執行錯誤計算並捕獲錯誤。

runIOThrows :: IOThrowsError String -> IO String
runIOThrows action = runExceptT (trapError action) >>= return . extractValue

這使用我們之前定義的 trapError 函式來獲取任何錯誤值，並將它們轉換為它們的字串表示形式，然後透過 runExceptT 執行整個計算。結果被傳遞給 extractValue，並在 IO 單子中返回一個值。

現在我們可以回到環境處理了。我們將從一個函式開始，該函式用於確定給定變數是否已經繫結在環境中，這對於正確處理 define 是必要的

isBound :: Env -> String -> IO Bool
isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var

這首先透過 readIORef 從 IORef 中提取實際的環境值。然後我們將它傳遞給 lookup，以搜尋我們感興趣的特定變數。lookup 返回一個 Maybe 值，因此如果該值為 Nothing，我們將返回 False，否則返回 True（我們需要使用 const 函式，因為 maybe 期望一個用於對結果執行的函式，而不僅僅是一個值）。最後，我們使用 return 將該值提升到 IO 單子中。由於我們只對真/假值感興趣，因此我們不需要處理 lookup 返回的實際 IORef。

接下來，我們需要定義一個函式來檢索變數的當前值

getVar :: Env -> String -> IOThrowsError LispVal
getVar envRef var  =  do env <- liftIO $ readIORef envRef
                         maybe (throwError $ UnboundVar "Getting an unbound variable" var)
                               (liftIO . readIORef)
                               (lookup var env)

與前面的函式類似，這首先從 IORef 中檢索實際的環境。但是，getVar 使用 IOThrowsError 單子，因為它還需要執行一些錯誤處理。因此，我們需要使用 liftIO 函式將 readIORef 操作提升到組合的單子中。類似地，當我們返回該值時，我們使用 liftIO . readIORef 來生成一個 IOThrowsError 操作，它讀取返回的 IORef。但是，我們不需要使用 liftIO 來丟擲錯誤，因為 throwError 是為 MonadError 型別類 定義的，ExceptT 是該型別類的例項。

現在我們建立一個函式來設定值

setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
setVar envRef var value = do env <- liftIO $ readIORef envRef
                             maybe (throwError $ UnboundVar "Setting an unbound variable" var)
                                   (liftIO . (flip writeIORef value))
                                   (lookup var env)
                             return value

同樣，我們首先從 IORef 中讀取環境，並對其執行 lookup。但是這次，我們想要改變變數，而不是隻讀取它。writeIORef 操作提供了一種方法來實現這一點，但它以錯誤的順序獲取引數（ref -> value 而不是 value -> ref）。因此，我們使用內建函式 flip 來交換 writeIORef 的引數，然後將值傳遞給它。最後，為了方便起見，我們返回我們剛剛設定的值。

我們需要一個函式來處理 define 的特殊行為，它在變數已經繫結時設定它，或者在沒有繫結時建立一個新的變數。由於我們已經定義了一個函式來設定值，因此我們可以在前一種情況下使用它

defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
defineVar envRef var value = do
     alreadyDefined <- liftIO $ isBound envRef var
     if alreadyDefined
        then setVar envRef var value >> return value
        else liftIO $ do
             valueRef <- newIORef value
             env <- readIORef envRef
             writeIORef envRef ((var, valueRef) : env)
             return value

有趣的是後一種情況，即變數未繫結。我們建立一個 IO 操作（透過 do 符號），它建立一個新的 IORef 來儲存新變數，讀取環境的當前值，然後將一個新的列表寫回該變數，該列表由新增到列表前面的新（鍵，變數）對組成。然後，我們使用 liftIO 將整個 do 塊提升到 IOThrowsError 單子中。

還有一個有用的環境函式：能夠一次繫結多個變數，就像函式被呼叫時發生的那樣。我們不妨現在就構建這個功能，儘管我們直到下一節才會使用它

bindVars :: Env -> [(String, LispVal)] -> IO Env
bindVars envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef
     where extendEnv bindings env = liftM (++ env) (mapM addBinding bindings)
           addBinding (var, value) = do ref <- newIORef value
                                        return (var, ref)

這可能比其他函式更復雜，因為它使用了單子管道（而不是 do 語法）和一對輔助函式來完成工作。最好從輔助函式開始。`addBinding` 接收一個變數名和值，建立一個 `IORef` 來儲存新變數，然後返回名稱 - 值對。`extendEnv` 對 `bindings` 的每個成員呼叫 `addBinding`（mapM）以建立一個 `(String, IORef LispVal)` 對列表，然後將當前環境附加到該列表的末尾 (`++ env`)。最後，整個函式將這些函式連線在一個管道中，首先從其 `IORef` 中讀取現有環境，然後將結果傳遞給 `extendEnv`，然後返回一個包含擴充套件環境的新 `IORef`。

現在我們已經擁有了所有環境函式，我們需要開始在求值器中使用它們。由於 Haskell 沒有全域性變數，因此我們必須將環境作為引數傳遞給求值器。我們也可以在此新增 set! 和 define 特殊形式。

eval :: Env -> LispVal -> IOThrowsError LispVal
eval env val@(String _) = return val
eval env val@(Number _) = return val
eval env val@(Bool _) = return val
eval env (Atom id) = getVar env id
eval env (List [Atom "quote", val]) = return val
eval env (List [Atom "if", pred, conseq, alt]) =
     do result <- eval env pred
        case result of
             Bool False -> eval env alt
             otherwise -> eval env conseq
eval env (List [Atom "set!", Atom var, form]) =
     eval env form >>= setVar env var
eval env (List [Atom "define", Atom var, form]) =
     eval env form >>= defineVar env var
eval env (List (Atom func : args)) = mapM (eval env) args >>= liftThrows . apply func
eval env badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm

由於單個環境會貫穿整個互動式會話，因此我們需要更改一些 IO 函式以接受環境。

evalAndPrint :: Env -> String -> IO ()
evalAndPrint env expr =  evalString env expr >>= putStrLn

evalString :: Env -> String -> IO String
evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env

我們需要在 `evalString` 中使用 `runIOThrows`，因為單子的型別已從 `ThrowsError` 變為 `IOThrowsError`。同樣，我們需要一個 `liftThrows` 來將 `readExpr` 帶入 `IOThrowsError` 單子。

接下來，我們在啟動程式之前用一個空變數初始化環境。

runOne :: String -> IO ()
runOne expr = nullEnv >>= flip evalAndPrint expr

runRepl :: IO ()
runRepl = nullEnv >>= until_ (== "quit") (readPrompt "Lisp>>> ") . evalAndPrint

我們建立了一個額外的輔助函式 `runOne` 來處理單表示式情況，因為它現在比僅僅執行 `evalAndPrint` 更加複雜。對 `runRepl` 的更改更為細微：請注意我們在 `evalAndPrint` 之前添加了一個函式組合運算子。這是因為 `evalAndPrint` 現在接受一個額外的 `Env` 引數，該引數從 `nullEnv` 中提供。函式組合告訴 `until_`，它不應該將普通的 `evalAndPrint` 作為操作，而應該首先將其應用於透過單子管道傳下來的任何內容，在本例中是從 `nullEnv` 的結果。因此，應用於每行輸入的實際函式是 `(evalAndPrint env)`，正如我們所期望的那樣。

最後，我們需要更改主函式以呼叫 `runOne`，而不是直接評估 `evalAndPrint`。

main :: IO ()
main = do args <- getArgs
          case length args of
               0 -> runRepl
               1 -> runOne $ args !! 0
               otherwise -> putStrLn "Program takes only 0 or 1 argument"

我們可以編譯並測試我們的程式。

$ ghc -package parsec -o lisp [../code/listing8.hs listing8.hs]
$ ./lisp
Lisp>>> (define x 3)
3
Lisp>>> (+ x 2)
5
Lisp>>> (+ y 2)
Getting an unbound variable: y
Lisp>>> (define y 5)
5
Lisp>>> (+ x (- y 2))
6
Lisp>>> (define str "A string")
"A string"
Lisp>>> (< str "The string")
Invalid type: expected number, found "A string"
Lisp>>> (string<? str "The string")
#t