原文岳服。
https://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours/Creating_IO_Primitives
目前我們的Scheme還沒法和外部世界進(jìn)行交流司倚，所以如果我們能給它添加一點(diǎn)IO函數(shù)就好了。另外与境，每次都要打開解釋器然后敲入函數(shù)定義也讓我們有點(diǎn)厭煩了，現(xiàn)在我們就來(lái)給它添加讀取并執(zhí)行代碼文件的功能。
同樣還是從為L(zhǎng)ispVal類型添加構(gòu)造器開始营曼。目前的PrimitiveFuncs的類型簽名并不包括IO Monad，所以它無(wú)法滿足我們進(jìn)行IO操作的需要愚隧。我們需要為這種進(jìn)行IO操作的原生函數(shù)創(chuàng)建一個(gè)專用的構(gòu)造器：
| IOFunc ([LispVal] -> IOThrowsError LispVal)
接著讓我們?yōu)镾cheme的port的類型也定義一個(gè)構(gòu)造器蒂阱。大部分IO函數(shù)都會(huì)需要用到某一個(gè)端口來(lái)進(jìn)行讀取和寫入操作：
| Port Handle
Handle基本上就對(duì)應(yīng)了Haskell里的端口概念：這是一個(gè)不透明類型，它會(huì)在你打開文件或者做出其他類似IO操作時(shí)返回狂塘，然后你可以對(duì)它進(jìn)行讀寫操作录煤。
出于程序完整性的考慮，我們還應(yīng)該為新的數(shù)據(jù)類型添加對(duì)應(yīng)的showVal方法：
showVal (Port _) = "<IO port>"
showVal (IOFunc _) = "<IO primitive>"
這樣子REPL函數(shù)就能夠正常運(yùn)行而不會(huì)在你使用一個(gè)返回端口的函數(shù)時(shí)崩潰掉了：
接著我們還需要更新apply函數(shù)讓它可以處理IOFunc值：
apply (IOFunc func) args = func args
我們還需要對(duì)我們的解析器做出一些小小的改變從而讓它能夠支持載入操作荞胡。由于Scheme代碼文件往往會(huì)包含若干個(gè)函數(shù)定義妈踊，我們需要添加一個(gè)解析器來(lái)通過空白符分割，識(shí)別并解析多個(gè)表達(dá)式泪漂。而且它也需要有自己的錯(cuò)誤處理機(jī)制廊营。我們目前大部分的基礎(chǔ)架構(gòu)都是可以重用的歪泳，是需要稍稍改變一下我們的readExpr函數(shù)讓它能夠讀取一個(gè)具體的解析器作為參數(shù)：
readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
Left err -> throwError $ Parser err
Right val -> return val
readExpr = readOrThrow parseExpr
readExprList = readOrThrow (endBy parseExpr spaces)
同樣，我們將readExpr和readExprList函數(shù)都可以當(dāng)做新定義的readOrThrow函數(shù)的一種特殊情況露筒。我們?cè)赗EPL里通過readExpr來(lái)讀取單個(gè)的表達(dá)式而在載入代碼文件時(shí)使用readExprList函數(shù)呐伞。
接下來(lái)，就如同我們之前的原生函數(shù)列表一樣慎式，我們需要一個(gè)原生IO函數(shù)的列表：
ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
ioPrimitives = [("apply", applyProc),
("open-input-file", makePort ReadMode),
("open-output-file", makePort WriteMode),
("close-input-port", closePort),
("close-output-port", closePort),
("read", readProc),
("write", writeProc),
("read-contents", readContents),
("read-all", readAll)]
這里唯一的區(qū)別就是類型簽名伶氢。很不幸由于我們不能將類型不同的元素放在同一個(gè)列表里所以我們不能使用之前的primitive列表。此外我們還需要修改一下primitiveBindings函數(shù)的定義：
primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives
++ map (makeFunc PrimitiveFunc) primitives)
where makeFunc constructor (var, func) = (var, constructor func)
我們對(duì)makeFunct函數(shù)也進(jìn)行了通用化的改造瘪吏，它現(xiàn)在會(huì)讀取一個(gè)構(gòu)造器作為參數(shù)癣防，現(xiàn)在我們就會(huì)同時(shí)通過它來(lái)對(duì)ioPrimitives和之前的primitives列表進(jìn)行初始化了。
那么現(xiàn)在我們來(lái)開始定義實(shí)際的函數(shù)了掌眠。applyProc是一個(gè)apply函數(shù)的輕量級(jí)封裝劣砍，我們用它來(lái)對(duì)輸入?yún)?shù)進(jìn)行解構(gòu)然后轉(zhuǎn)換成apply函數(shù)需要的形式：
applyProc :: [LispVal] -> IOThrowsError LispVal
applyProc [func, List args] = apply func args
applyProc (func : args) = apply func args
makePort函數(shù)則是對(duì)Haskell中的openFile函數(shù)的封裝，同時(shí)將輸入?yún)?shù)轉(zhuǎn)換成了合適的類型并把返回值用Port構(gòu)造器封裝起來(lái)扇救。這里函數(shù)通過了部分應(yīng)用的方式來(lái)讓它能夠接受不同的模式并分別處理打開讀取文件以及打開寫入文件的情況：
makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
同樣closePort也一樣是Haskell函數(shù)的封裝而已刑枝，對(duì)應(yīng)的是hClose函數(shù)：
closePort :: [LispVal] -> IOThrowsError LispVal
closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
closePort _ = return $ Bool False
readProc函數(shù)（避免和內(nèi)置read函數(shù)有沖突所以改成了這個(gè)名字）封裝了Haskell的hGetLine函數(shù)然后將返回結(jié)果傳遞給parseExpr，從而將輸入轉(zhuǎn)換為Scheme可以處理的LispVal類型：
readProc :: [LispVal] -> IOThrowsError LispVal
readProc [] = readProc [Port stdin]
readProc [Port port] = (liftIO $ hGetLine port) >>= liftThrows . readExpr
注意到hGetLine port的類型是IO String而readExpr函數(shù)的類型是String -> ThrowsError LispVal迅腔，所以我們需要分別將它們轉(zhuǎn)換（通過liftIO和liftThrows）成IOThrowsError Monad装畅。只有這樣它們才能通過Monad綁定操作符串聯(lián)在同一個(gè)管道里。
writeProc函數(shù)將一個(gè)LispVal值轉(zhuǎn)換成一個(gè)字符串然后將它寫到一個(gè)指定的端口：
writeProc :: [LispVal] -> IOThrowsError LispVal
writeProc [obj] = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)
這里我們不需要顯式的對(duì)我們想要打印的對(duì)象調(diào)用show函數(shù)沧烈，因?yàn)閔Print函數(shù)讀取的是Show a類型的數(shù)據(jù)掠兄。它會(huì)自動(dòng)的替我們呼叫show函數(shù)。這就是我們之前為什么試圖將LispVal類型定義成一個(gè)Show的實(shí)例锌雀；不然的話蚂夕，我們就不會(huì)能夠在這里使用自動(dòng)轉(zhuǎn)換而需要自行調(diào)用我們的showVal函數(shù)了。很多其他的Haskell函數(shù)都會(huì)以Show的實(shí)例作為參數(shù)腋逆，所以如果將這個(gè)技巧展開到其他的IO原生函數(shù)中婿牍，這會(huì)讓我們省下很多精力。
readContents函數(shù)將整個(gè)文件作為字符串讀到內(nèi)存當(dāng)中惩歉。這是一個(gè)Haskell的readFile函數(shù)的輕量級(jí)封裝等脂，同樣僅僅是將IO操作lift成一個(gè)IOThrowsError操作然后將它封裝在一個(gè)String構(gòu)造器里：
readContents :: [LispVal] -> IOThrowsError LispVal
readContents [String filename] = liftM String $ liftIO $ readFile filename
這里的輔助函數(shù)load和Scheme的load函數(shù)并不一樣（之后我們?cè)偬幚砟遣糠郑?shí)際上撑蚌，它只是負(fù)責(zé)讀取并解析一個(gè)滿是表達(dá)式的文件上遥。兩個(gè)地方會(huì)需要用到它：readAll（load之后然后返回一個(gè)LispVal值組成的列表）以及l(fā)oad（將那些返回的值作為Scheme表達(dá)式求值）：
load :: String -> IOThrowsError [LispVal]
load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
然后通過readAll函數(shù)將返回值通過一個(gè)列表構(gòu)造器封裝起來(lái)：
readAll :: [LispVal] -> IOThrowsError LispVal
readAll [String filename] = liftM List $ load filename
實(shí)現(xiàn)Scheme的load函數(shù)需要一點(diǎn)技巧，因?yàn)閘oad函數(shù)會(huì)將新的綁定關(guān)系引入當(dāng)前的環(huán)境争涌。然而粉楚，apply函數(shù)并沒有將環(huán)境作為變量所以我們是沒有辦法在一個(gè)原生函數(shù)（或者其他自定義函數(shù)）里做這個(gè)的。所以我們需要通過一個(gè)特殊的實(shí)現(xiàn)形式來(lái)搞定這個(gè)問題：
eval env (List [Atom "load", String filename]) =
load filename >>= liftM last . mapM (eval env)
最后我們還需要修改下runOne函數(shù)讓它不僅僅是對(duì)單一的從命令行中獲取的表達(dá)式求值。它會(huì)將一個(gè)文件名讀入然后將整個(gè)文件作為程序執(zhí)行模软。額外的命令行參數(shù)會(huì)作為args列表綁定到環(huán)境：
runOne :: [String] -> IO ()
runOne args = do
env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 args)]
(runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)]))
>>= hPutStrLn stderr
這里有點(diǎn)復(fù)雜所以我們來(lái)一步一步看一下伟骨。第一行首先獲取了一開始的primitives綁定關(guān)系，然后將它傳遞給了bindVars函數(shù)撵摆，然后向其中添加了一個(gè)名叫args的變量，它包含了第一個(gè)命令行參數(shù)之后的所有部分（第一個(gè)參數(shù)是需要執(zhí)行的文件名）害晦。接下來(lái)特铝，它模擬用戶輸入的方式創(chuàng)建了一個(gè)Scheme形式的load "arg1"，然后執(zhí)行了這個(gè)語(yǔ)句壹瘟。這里結(jié)果會(huì)通過liftM被轉(zhuǎn)換成字符串的形式（記住我們需要在錯(cuò)誤處理之前進(jìn)行這一步鲫剿，因?yàn)殄e(cuò)誤處理機(jī)制會(huì)將它們最終轉(zhuǎn)換成字符串所以這里有一個(gè)類型匹配的問題）然后我們會(huì)執(zhí)行整個(gè)的IOThrowsError操作并將結(jié)果打印到標(biāo)準(zhǔn)錯(cuò)誤輸出stderr。（傳統(tǒng)的Unix系統(tǒng)規(guī)范規(guī)定了標(biāo)準(zhǔn)輸出stdout只能被用作程序的正常輸出稻轨，而其他錯(cuò)誤消息應(yīng)該被輸出到stderr灵莲。這里實(shí)際程序的最后一句語(yǔ)句的結(jié)果也會(huì)被打印出來(lái)，雖然它基本上沒有什么特別的意義殴俱。）
接著改變主函數(shù)讓它使用我們?nèi)碌膔unOne函數(shù)政冻。由于我們不再需要額外的子句來(lái)處理錯(cuò)誤的命令行參數(shù)的情況了，我們把整個(gè)函數(shù)簡(jiǎn)化成一個(gè)if語(yǔ)句：
main :: IO ()
main = do args <- getArgs
if null args then runRepl else runOne $ args