在 48 小时内编写自己的 Scheme/创建 I/O 原语

在 48 小时内编写自己的 Scheme
← 定义 Scheme 函数	创建 I/O 原语	走向标准库 →

我们的 Scheme 现在还不能真正与外部世界通信，所以如果能给它一些 I/O 函数就好了。此外，每次启动解释器时都输入函数非常乏味，所以能加载代码文件并执行它们会很好。

首先我们需要一个新的 LispVal 构造函数。 PrimitiveFunc 具有特定的类型签名，不包含 IO 单子，因此它们不能执行任何 IO。我们希望有一个专门的构造函数用于执行 IO 的基本函数。

| IOFunc ([LispVal] -> IOThrowsError LispVal)

趁此机会，让我们也定义一个用于 Scheme 数据类型（即端口）的构造函数。我们的大多数 IO 函数都会使用其中一个进行读写。

| Port Handle

一个 Handle 基本上是 Haskell 的端口概念：它是一个不透明的数据类型，由 openFile 和类似的 IO 操作返回，你可以读写它。

为了完整性，我们应该为新的数据类型提供 showVal 方法。

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

这将使 REPL 函数正常运行，而不会在你使用返回端口的函数时崩溃。

我们还需要更新 apply，使其能够处理 IOFuncs。

apply (IOFunc func) args = func args

我们需要对解析器进行一些小的修改，以支持 load。由于 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 读取单个表达式；我们将在 load 内部使用 readExprList 读取程序。

接下来，我们需要一个新的 I/O 原语列表，其结构与现有的原语列表相同。

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

这里唯一的区别在于类型签名。不幸的是，我们不能使用现有的原语列表，因为列表不能包含不同类型的元素。我们还需要更改 primitiveBindings 的定义，以添加新的原语。

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

我们将 makeFunc 泛化为接受一个构造函数参数，现在除了普通的原语之外，还会在 ioPrimitives 列表上调用它。

现在我们开始定义实际的函数。 applyProc 是 apply 的一个非常薄的包装器，负责将参数列表分解为 apply 预期的形式。

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

makePort 包装了 Haskell 函数 openFile，将其转换为正确的类型并将返回值包装在 Port 构造函数中。它旨在部分应用于 IOMode，ReadMode 用于 open-input-file，WriteMode 用于 open-output-file。

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，因此它们都需要转换为 IOThrowsError 单子（分别使用 liftIO 和 liftThrows）。只有这样，它们才能与单子绑定运算符一起使用。

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 类型的 value。它正在自动调用 show。这就是我们费心将 LispVal 设置为 Show 的实例的原因；否则，我们将无法使用此自动转换，并且必须自己调用 showVal。许多其他 Haskell 函数也接受 Show 的实例，因此如果我们用其他 IO 原语扩展它，它可以为我们节省大量工作。

readContents 将整个文件读入内存中的字符串。它只是 Haskell 的 readFile 的一个薄包装器，同样只是将 IO 操作提升为 IOThrowsError 操作并将其包装在 String 构造函数中。

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

辅助函数 load 不执行 Scheme 的 load 所做的事情（我们将在后面处理它）。相反，它只负责读取和解析一个充满语句的文件。它在两个地方使用：readAll（它返回一个值列表）和 load（它将这些值作为 Scheme 表达式进行评估）。

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

readAll 然后只是用 List 构造函数包装返回值。

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

实现实际的 Scheme load 函数有点棘手，因为 load 可以将绑定引入本地环境。但是，apply 不接受环境参数，因此基本函数（或任何函数）都没有办法做到这一点。我们通过将 load 实现为特殊形式来解决这个问题。

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

最后，我们不妨更改 runOne 函数，使其不再评估来自命令行的单个表达式，而是接受要执行的文件的名称并将其作为程序运行。附加的命令行参数将绑定到 Scheme 程序中的 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

这有点复杂，让我们一步一步地进行。第一行接受原始基本绑定，将其传递到 bindVars，然后添加一个名为 args 的变量，该变量绑定到一个包含所有参数（第一个参数除外）的 String 版本的 List。（第一个参数是要执行的文件名。）然后，它创建一个 Scheme 形式 load "arg1"，就像用户在里面键入的一样，并对其进行评估。结果被转换为字符串（请记住，我们必须在捕获错误之前这样做，因为错误处理程序将它们转换为字符串，并且类型必须匹配），然后我们运行整个 IOThrowsError 操作。然后我们在 stderr 上打印结果。（传统的 UNIX 约定认为 stdout 应该只用于程序输出，任何错误消息都应该发送到 stderr。在这种情况下，我们还将打印程序中最后一个语句的返回值，该语句通常对任何事物都没有意义。）

然后我们更改 main，使其使用新的 runOne 函数。由于我们不再需要第三个子句来处理错误数量的命令行参数，因此我们可以将其简化为一个 if 语句。

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

在 48 小时内编写自己的 Scheme
← 定义 Scheme 函数	创建 I/O 原语	走向标准库 →