Write Yourself a Scheme in 48 Ho

原文。
https://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours/Creating_IO_Primitives

目前我们的Scheme还没法和外部世界进行交流，所以如果我们能给它添加一点IO函数就好了。另外，每次都要打开解释器然后敲入函数定义也让我们有点厌烦了，现在我们就来给它添加读取并执行代码文件的功能。

同样还是从为LispVal类型添加构造器开始。目前的PrimitiveFuncs的类型签名并不包括IO Monad，所以它无法满足我们进行IO操作的需要。我们需要为这种进行IO操作的原生函数创建一个专用的构造器：

| IOFunc ([LispVal] -> IOThrowsError LispVal)

接着让我们为Scheme的port的类型也定义一个构造器。大部分IO函数都会需要用到某一个端口来进行读取和写入操作：

| Port Handle

Handle基本上就对应了Haskell里的端口概念：这是一个不透明类型，它会在你打开文件或者做出其他类似IO操作时返回，然后你可以对它进行读写操作。

出于程序完整性的考虑，我们还应该为新的数据类型添加对应的showVal方法：

showVal (Port _)   = "<IO port>"
showVal (IOFunc _) = "<IO primitive>"

这样子REPL函数就能够正常运行而不会在你使用一个返回端口的函数时崩溃掉了：

接着我们还需要更新apply函数让它可以处理IOFunc值：

apply (IOFunc func) args = func args

我们还需要对我们的解析器做出一些小小的改变从而让它能够支持载入操作。由于Scheme代码文件往往会包含若干个函数定义，我们需要添加一个解析器来通过空白符分割，识别并解析多个表达式。而且它也需要有自己的错误处理机制。我们目前大部分的基础架构都是可以重用的，是需要稍稍改变一下我们的readExpr函数让它能够读取一个具体的解析器作为参数：

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函数都可以当做新定义的readOrThrow函数的一种特殊情况。我们在REPL里通过readExpr来读取单个的表达式而在载入代码文件时使用readExprList函数。

接下来，就如同我们之前的原生函数列表一样，我们需要一个原生IO函数的列表：

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)]

这里唯一的区别就是类型签名。很不幸由于我们不能将类型不同的元素放在同一个列表里所以我们不能使用之前的primitive列表。此外我们还需要修改一下primitiveBindings函数的定义：

primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives
                                               ++ map (makeFunc PrimitiveFunc) primitives)
     where makeFunc constructor (var, func) = (var, constructor func)

我们对makeFunct函数也进行了通用化的改造，它现在会读取一个构造器作为参数，现在我们就会同时通过它来对ioPrimitives和之前的primitives列表进行初始化了。

那么现在我们来开始定义实际的函数了。applyProc是一个apply函数的轻量级封装，我们用它来对输入参数进行解构然后转换成apply函数需要的形式：

applyProc :: [LispVal] -> IOThrowsError LispVal
applyProc [func, List args] = apply func args
applyProc (func : args)     = apply func args

makePort函数则是对Haskell中的openFile函数的封装，同时将输入参数转换成了合适的类型并把返回值用Port构造器封装起来。这里函数通过了部分应用的方式来让它能够接受不同的模式并分别处理打开读取文件以及打开写入文件的情况：

makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode

同样closePort也一样是Haskell函数的封装而已，对应的是hClose函数：

closePort :: [LispVal] -> IOThrowsError LispVal
closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
closePort _           = return $ Bool False

readProc函数（避免和内置read函数有冲突所以改成了这个名字）封装了Haskell的hGetLine函数然后将返回结果传递给parseExpr，从而将输入转换为Scheme可以处理的LispVal类型：

readProc :: [LispVal] -> IOThrowsError LispVal
readProc []          = readProc [Port stdin]
readProc [Port port] = (liftIO $ hGetLine port) >>= liftThrows . readExpr

注意到hGetLine port的类型是IO String而readExpr函数的类型是String -> ThrowsError LispVal，所以我们需要分别将它们转换（通过liftIO和liftThrows）成IOThrowsError Monad。只有这样它们才能通过Monad绑定操作符串联在同一个管道里。

writeProc函数将一个LispVal值转换成一个字符串然后将它写到一个指定的端口：

writeProc :: [LispVal] -> IOThrowsError LispVal
writeProc [obj]            = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)

这里我们不需要显式的对我们想要打印的对象调用show函数，因为hPrint函数读取的是Show a类型的数据。它会自动的替我们呼叫show函数。这就是我们之前为什么试图将LispVal类型定义成一个Show的实例；不然的话，我们就不会能够在这里使用自动转换而需要自行调用我们的showVal函数了。很多其他的Haskell函数都会以Show的实例作为参数，所以如果将这个技巧展开到其他的IO原生函数中，这会让我们省下很多精力。

readContents函数将整个文件作为字符串读到内存当中。这是一个Haskell的readFile函数的轻量级封装，同样仅仅是将IO操作lift成一个IOThrowsError操作然后将它封装在一个String构造器里：

readContents :: [LispVal] -> IOThrowsError LispVal
readContents [String filename] = liftM String $ liftIO $ readFile filename

这里的辅助函数load和Scheme的load函数并不一样（之后我们再处理那部分）。实际上，它只是负责读取并解析一个满是表达式的文件。两个地方会需要用到它：readAll（load之后然后返回一个LispVal值组成的列表）以及load（将那些返回的值作为Scheme表达式求值）：

load :: String -> IOThrowsError [LispVal]
load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList

然后通过readAll函数将返回值通过一个列表构造器封装起来：

readAll :: [LispVal] -> IOThrowsError LispVal
readAll [String filename] = liftM List $ load filename

实现Scheme的load函数需要一点技巧，因为load函数会将新的绑定关系引入当前的环境。然而，apply函数并没有将环境作为变量所以我们是没有办法在一个原生函数（或者其他自定义函数）里做这个的。所以我们需要通过一个特殊的实现形式来搞定这个问题：

eval env (List [Atom "load", String filename]) = 
     load filename >>= liftM last . mapM (eval env)

最后我们还需要修改下runOne函数让它不仅仅是对单一的从命令行中获取的表达式求值。它会将一个文件名读入然后将整个文件作为程序执行。额外的命令行参数会作为args列表绑定到环境：

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

这里有点复杂所以我们来一步一步看一下。第一行首先获取了一开始的primitives绑定关系，然后将它传递给了bindVars函数，然后向其中添加了一个名叫args的变量，它包含了第一个命令行参数之后的所有部分（第一个参数是需要执行的文件名）。接下来，它模拟用户输入的方式创建了一个Scheme形式的load "arg1"，然后执行了这个语句。这里结果会通过liftM被转换成字符串的形式（记住我们需要在错误处理之前进行这一步，因为错误处理机制会将它们最终转换成字符串所以这里有一个类型匹配的问题）然后我们会执行整个的IOThrowsError操作并将结果打印到标准错误输出stderr。（传统的Unix系统规范规定了标准输出stdout只能被用作程序的正常输出，而其他错误消息应该被输出到stderr。这里实际程序的最后一句语句的结果也会被打印出来，虽然它基本上没有什么特别的意义。）

接着改变主函数让它使用我们全新的runOne函数。由于我们不再需要额外的子句来处理错误的命令行参数的情况了，我们把整个函数简化成一个if语句：

main :: IO ()
main = do args <- getArgs
          if null args then runRepl else runOne $ args