Write Yourself a Scheme in 48 Hours/Parsing（四）

上一次，我们给出了原子（Atom）的解析器，其中已经把逻辑类型（#t/#f）的解析功能一并做进去了。

接下来是解析数值的组件：

Haskell语言: Parsing 代码片段九

parseNumber :: Parser LispVal
parseNumber = liftM (Number . read) $ many1 digit

这一段不难理解，主要是 $ 和 . 两个函数的运用。 many1 解析器匹配一个或多个参数，所以我们可以用来匹配一个或多个数字字符（0-9）。不过我们需要返回的是一个LispVal数值，所以还要把解析到的字符串 再转为数字。于是，我们用 . 组合 Number和read。它先将传入的参数作用于右值，再将得到的结果作用于左值。

many1返回的值实际上是 Parser String，而我们需要一个 String，还要返回一个 Parser LispVal。所以 Number . read 读不了它。liftM 起到析值的作用。也就是说，我们将many1 digit解析得到的 Parser String，传递给 $ （它等效于一对括号）的左值， liftM (Number . read)。

为了使用这个 Monad ，我们需要导入 Monad 模块：

import Monad

这种风格的编程－－重度依赖函数组合、应用、传递－－在 Haskell 代码中非常普遍。它通常可以使你在一行中写出非常复杂的算法。有时候你可能需要从右向左读Haskell代码（想想我们学过的那些数学公式）。

Barolo 号称意大利国酒－－要知道正是古罗马的军团将亚平宁半岛的葡萄酒文化带到了法国和整个地中海沿岸，至今意大利仍是世界第一大葡萄酒生产国－－但它的强劲却 令很多初尝葡萄酒的人退避三舍。很多初学者比较难接受Haskell浓烈粹的FP风格。我个人也仍处于努力学习的阶段。但是，也正是这种风格，是它的魅力 所在。

现在，我们可以编写一个 parserExpr 接受字符串、数值和原子语素了：

Haskell语言: Parsing 代码片段十

parseExpr :: Parser LispVal
parseExpr = parseAtom
       <|> parseString
       <|> parseNumber

然后修改 readExpr 以使其调用新的 parser：

Haskell语言: Parsing 代码片段十一

readExpr :: String -> String
readExpr input = case parse parseExpr "lisp" input of
   Left err -> "No match: " ++ show err
   Right _ -> "Found value"

最后，我要说的是，其实在这一章，我将代码文件分成了三份：BuildIn.hs，Parser.hs，Parsers.hs。其中 Parser.hs是主程序，其它两个文件定义为两个模块。但是多文件编译的话，学原文上的方法并不成功，可能是ubuntu默认的shell和 debian不同，不过更大的可能是高版本的ghc编译器参数变了，总之，我编译的时候用的是：

为了阅读方便，我完整给出三个文件的代码。

BuildIn.hs:

module BuildIn where

data LispVal = Atom String
            | List [LispVal]
            | DottedList [LispVal] LispVal
            | Number Integer
            | String String
            | Bool Bool

Parsers.hs：

module Parsers where

import Monad
import Text.ParserCombinators.Parsec hiding (spaces)
import BuildIn

symbol :: Parser Char
symbol = oneOf "!#$%&|*+-/:<=>?@^_~"

spaces :: Parser()
spaces = skipMany1 space

readExpr :: String -> String
readExpr input = case parse parseExpr "lisp" input of
                  Left err -> "No match: " ++ show err
                  Right val -> "Found value"

parseString :: Parser LispVal
parseString = do char '"'
                x <- many (noneOf "\"")
                char '"'
                return $ String x

parseAtom :: Parser LispVal
parseAtom = do first <- letter <|> symbol
              rest <- many (letter <|> digit <|> symbol)
              let atom = first:rest
              return $ case atom of
                         "#t" -> Bool True
                         "#f" -> Bool False
                         otherwise -> Atom atom

parseNumber :: Parser LispVal
parseNumber = liftM (Number . read) $ many1 digit

parseExpr :: Parser LispVal
parseExpr = parseAtom
           <|> parseString
           <|> parseNumber

Parser.hs

module Main where

import System.Environment
import Parsers

main :: IO ()
main = do args <- getArgs
         putStrLn (readExpr (args !! 0))

Write Yourself a Scheme in 48 Hours/Parsing（三）

上一节的时候我们讨论到了用附加的解释器组件扩展功能的方法。这一次我们再加些料。 首先，我们定义出Scheme语言中的一些类型：

Haskell语言: Parsing 代码片段六

data LispVal = Atom String
            | List [LispVal]
            | DottedList [LispVal] LispVal
            | Number Integer
            | String String
            | Bool Bool

事实上，Haskell里一切都可以看作是函数，data也不例外。千万不要拿这个东西去随便对应你以前见过的其它叫data的东西。事实上 Haskell里的Type、Class、Instance和Data跟OO语言里的概念都完全不是一回事儿。如果你有学过近世代数，可以去看看上节里推 荐的T1的那篇Monad教程。

这里，使用data，我们定义了 LispVal 可能的几种类型：

• Atom 是一个文本，它表示一个原子命名
• 若干 LispVal 的序列成为一个 List （注意 List 也是一种 data Lispval，所以这是一个递归的定义）
• . 联接列表和一个 LispVal 值，组成一个 DottedList
• Number 存储整数
• String 存储字符串
• Bool 存储逻辑值

因为Haskell的类型和构造器取自不同的命名空间，所以这里我们定义了与系统类型相同的String、Bool之类的类型，也不会靠成什么问题。类型和构造器都是PASCAL命名。

现在编写几个解释器函数。首先是字符串。字符串是一对双引号标记，包含若干文。

Haskell语言: Parsing 代码片段七

parseString :: Parser LispVal
parseString = do char '"'
                x <- many (noneOf "\"")
                char '"'
                return $ String x

这儿又出来一新的妖招：我们没用 >>，而是用了一个do。这是为了可以取到引号之间的值，这里我们用了char和many两个解析工具。按作者的解释，通常不需要取得 action返回值的时候（比如为了组合它们生成新的monad），使用>>，而需要取值并用于下一个action的时候，用 >>= 或 do-notation。

取值完成以后，我们将其 return 为一个 LispVal 。抽象数据类型中的每个构造器也同样可以看作是一个函数：返回一个该类型的值。函数进行参数的式匹配的时候，也可以根据data来匹配。

内置函数 return 可以把我们的 LispVal 提升为一个Parser monad。每一行do代码虽然都要求是同一个类型，但是但是我们的字符串解析函数只是返回了一个 LispVal，这时候就靠 return 帮我们搞定这个类型封装啦。这样，整个 parseString action 就成为了一个 Parser LispVal。

$只是括号的简写 return $ String x 等同于 return (String x)，这个在Haskell的语法教程中都会有介绍。不过这里有特别提出，$是一个操作符，所以你能对一个函数做什么，就能对它做什么，传递、局部化等 等。在这里，它相当于一个 apply。

Atom 就是一个原子语素，一个字母或符号，跟随若干数值或字母、符号之类的：

Haskell语言: Parsing 代码片段八

parseAtom :: Parser LispVal
parseAtom = do first <- letter <|> symbol
              rest <- many (letter <|> digit <|> symbol)
              let atom = first:rest
              return $ case atom of
                         "#t" -> Bool True
                         "#f" -> Bool False
                         otherwise -> Atom atom

这里出现了一个新的 Pasec combinator，选择运算符 <|>。它尝试第一个parser，失败就尝试第二个。哪个成功就返回哪个parser的值。

读取语素的第一个字符以及其余部分后，我们需要把它们合在一起。let语法定义了一个atom变量，我们使用联接符:把它们联起来。如果不用:，还可以用 [first] ++ rest。

case是基本语句，语法书都讲得很明白，这里不多讨论了。

发芽网挂了……明天再继续吧……

有一件挺让人无语的事儿就是你费事儿排的版它总不给显示，在Blogger的编辑器上编辑源码真不是人干的事儿，现在我改用Muse了……不过还是比较麻烦的……有些代码我想还是放到发芽上比较方便。

Write Yourself a Scheme in 48 Hours/Parsing（二）

囧然发现，代码的排版总是会丢失缩近。这个当然不能怪发芽网的服务不好，因为直接可以看到的是blogger的有些模板就有问题。这东西的可视化编辑器又慢，功能又不全。

我现在用gmail的内置编辑器，不过这东西也不能算好用，它没办法编辑HTML源码。网上有人贴过muse向blogger发布的代码。等这个坑填完我肯定是要再去弄muse的，到时候不妨拿来看看（话说，muse真是个好东西吖）。

上次讲到了如何利用 oneOf 函数提取代码中的符号。因为我们没有处理空格，如果符号前有多的空格，就会出错了。

作者的解释是，Parsec的spaces不符合他的要求，虽然另有一个lexeme可用，但是这里我们可以自己定做一个。

Haskell语言: Parsing 代码片段四

spaces :: Parser ()
spaces = skipMany1 space

这东西其实比我猜想的简单多了，还是直接拿了一个东西来用，跟oneOf换汤不换药嘛。

现在我们修改一下readExpr，把这个新组件串进去。

readExpr input = case parse (spaces >> symbol) "lisp" input of
    Left err -> "No match: " ++ show err
    Right val -> "Found value"

这里我没用发芽网的服务，主要是给大家看到红字标明的修改标记。如果没有心理准备，大概会被这个简单的用法小小震惊一下。>>符号是 Monad 的四个标准运算符之一，"bind"操作符。通过它，我们把skipMany1 space传入symbol中，组成一个新的parser Monad。这里作者特别有介绍，不同的Monad，它的bind行为可能完全不同。具体的情况一定要阅读文档来确定。在Parser Monad中，它就是尝试匹配第一个组件，不行再匹配第二个，直至匹配成功或最终返回错误。

Monad一个非常强大的地方就在于这种组合能力，这与OO中的继承或接口复用还是有很大不同的。等这个教程跟完，如果我觉得我对Monad有些了 解了，可能会写一些关于Monad的文章。其实关于Monad，国内已经有一篇非常强大的文章，来自Javaeye社区的Trustno1。简单介绍一下 背景，这大佬多年以前在程序员上以"恶魔吹着笛子来"为署名写了一系列Python教程，这几篇文章将我和很多程序员引入了Python领域。至于 Lee……不需要我多介绍了吧：）。

这一小节的完整代码：

Haskell语言: Parsing第二部分的完整代码

module Main where

import System.Environment
import Text.ParserCombinators.Parsec hiding (spaces)

symbol :: Parser Char
symbol = oneOf "!#$%&|*+-/:<=>?@^_~"

spaces :: Parser()
spaces = skipMany1 space

readExpr :: String -> String
readExpr input = case parse (spaces >> symbol) "lisp" input of
                  Left err -> "No match: " ++ show err
                  Right val -> "Found value"

main :: IO ()
main = do args <- getArgs
         putStrLn (readExpr (args !! 0)

Write Yourself a Scheme in 48 Hours/Parsing (一)

前一章其实标题本来是"编译与运行"。但是这两步反而难度不高，看了教程就很容易能明白，所以我没有讨论它。 上一章里重点介绍了开发工具，因为Haskell的语法决定，我们需要一个顺手的工具。 还重点介绍了Monad，主要是从我等下里巴人的角度解释一下怎么用它。 对于一个完全的新手，其实还应该学习一些关于Haskell基本数据结构和函数定义的知识，不过这方面的东西最好找专门的Haskell语言教程。

这一章，会继续练习Monad的使用。我们还会见到一些来自GHC标准库的强大武器。

这次我们 import 进来一个新的库

import Text.ParserCombinators.Parsec hiding (spaces)

Parsec库是Haskell中专门的解释器工具库。hiding关键字指出，我们导入这个库时，把 spaces 函数排除在外－－因为我们随后要自己实现一个不同的逻辑。

Haskell语言: Parsing 代码片段二

symbol :: Parser Char
symbol = oneOf "!#$%&|*+-/:<=>?@^_~"

上面是类型声明，也就是说给oneOf函数传这一串符号进去，它返回一个解释器类型。其接收代码文本，针对oneOf传入的符号串进行处理。类似oneOf的这些解释器Monad生成工具，在Parsec库里还有一些其它的解析工具，后面我们会用到一些。

OK，这个解释器（其实是个解释器零件）我们怎么使用它呢？现在我们写一个解析表达式的工具：

Haskell语言: Parsing 代码片段三

readExpr :: String -> String
readExpr input = case parse symbol "lisp" input of
   Left err -> "No match: " ++ show err
   Right val -> "Found value"

这个用法很简单，利用 Parsec 库的 parse，我们把定义好的 symbol 传给 parse （"lisp" 作为注册进来的 symbol 的命名），然后接收一个字符串，parse会返回一个 data ，其中 Left 是表示错误信息，err中有具体内容，Right val则是匹配正确后的结果，这里我们先不管它返回了什么，输出一个"Found value"。

这段程序可以看出，symbol 的作用比较简单，只要字符串里有任一个匹配oneOf的字符，解析器会把它做为一个词素提出来。而parse就处理这个解析结果。

这样，很简单的接收命令行参数然后传出解析结果。!!是haskell的列表索引操作符。也就是说，它只处理args的第一个元素。 编译以后执行试试吧，你会看到，它校验你输入的文本中，第一个字符是否在symbol注册的符号中。并返回相应的值。 解释器还很简单，但是后面我们会慢慢完善它。

这一章的重点，在于学会如何组合多个函数或Monad。具体的原理和定义，推荐一份已经被汉化出来的教程：函数式编程另类指南，其中的currying和Continuations知识，与我们在这里使用的组合技术相关。

事实上，如果那东西把你搞糊涂了，倒不如当那些名词和定理不存在，我们继续写程序吧XD。

今天的代码：

Haskell语言: Parsing的完整代码

module Main where

import System.Environment
import Text.ParserCombinators.Parsec hiding (spaces)

symbol :: Parser Char
symbol = oneOf "!#$%&|*+-/:<=>?@^_~"

readExpr :: String -&gt; String
readExpr input = case parse symbol "lisp" input of
                  Left err -&gt; "No match: " ++ show err
                  Right val -&gt; "Found value"

main :: IO ()
main = do args &lt;- getArgs
         putStrLn (readExpr (args !! 0))

柚子！

今天在超市看到一个小朋友，大概也就一岁多两岁。爷爷买了两个大柚子，他坐在车里抱着柚子玩。到收银台爷爷把柚子拿给收银员，小朋友哇的一声就哭了，一边哭还一边往收银台上爬，想把柚子抢回来。收银员赶紧刷完把柚子还给他。柚子一抱到怀里，小家伙立刻就安静了，脸上还挂着泪珠。安安静静的坐在购物车里。

Write Yourself a Scheme in 48 Hours/First Steps

本章原文地址： http://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours/First_Steps

第一章的内容不多，准备知识而已。这一章的名字就叫“First Step”。起点也很朴实：开发环境的准备。

前面说过，这份例子是以最主流的Haskell编译器ghc为工具的。当然，ghc本身有一个还不错的shell环境，ghci。不过我们是要跟着写代码，做项目的，不能关机就扔，所以得要有个正经的源码编辑器。

作者推荐Emacs，如果你在Windows上，可以试试ntemacs。Emacs有个相当中规中矩的haskell-mode。里面的功能说实话我还没好好挖掘过，不过值得向大家推荐一下，默认的设置就算挺好用了。

如果你用不惯Emacs，其实VIM也不错，我本人是Emacs党，不过有回也试了试用VIM写Haskell代码，对于我这类初级用户，感觉没太 大差别。本书作者认为，hskell不是一种用记事本能搞定的语言。确实，虽然它只是纯文本，但是数学化的灵魂还在（还记得数学里那些鬼画符一样的表达式 吧），如果记事本，缩进格式足够把人搞疯的。不需要什么很伟大的IDE，有个靠谱的文本编辑器还是有必要的。

其实作者也有交待，你要是真用不惯这些 “非”主流编辑器，Eclipse有个 Fucntion Programming，联想到Eclipse连支持个XML都JJYY，这个Haskell插件竟然已经到了0.9.x，haskell这个圈子水真深啊……）。甚至还有个 http://www.haskell.org/visualhaskell/ ，看截图应该是VS6的，不过这种小众语言能支持这玩意儿已经很雷人了）。

另外，我相信一个另小众的编辑器：yi肯定是支持Haskell的。因为，它是Haskell写成的！这东西我没用过，不过谣言频道有人刷屏说这是一款向 Emacs 致敬的作品。从截图看真的有点像Emacs。

本章的示例代码不多，写个简单的入门例程：

module Main where
import System.Environment

main :: IO ()
main = do
   args <- getArgs
   putStrLn ("Hello, " ++ args !! 0)

如果你对Haskell还不熟……嗯……

module Main这一行用来声明一个模块，这东西比较像Python的模块概念（如果你没学过Python，这句话请无视）。虽然写个小脚本的话你不加这个也能跑，不过养成好习惯总是好的。

import 显而易见，就是用来导入外部模块的。这东西跟Python里用法差不多（如果你没学过Python，这句话请无视）。

4-7行很短，但是对于有学过其它编程语言的人会是一种颠覆性的打击，就算你上一门学的是Python也一样（如果你没学过Python，这句话请无视）。

第 4行是函数类型声明，它指明了main函数的类型是IO单子，这就是它的返回值。这在Haskell语言里是不同寻常的一种类型。我们先把这个事儿放一 边。之前如果你学过其它编程语言，那么我想你还记得，有些语言一定要有类型声明，比如C++或Java；有些语言根本没有类型声明，比如Python（如 果你没学过Python，这句话请无视）。

然而Haskell这个变态，是可以有类型声明，也可以没有的。如果你不写，它会自己猜，然后选匹配的类型里最常用的来编译（这一点不同于 Javascript的动态类型）。以我的经验，只要你程序写得正确没有bug，几乎不会出现猜不出来的。然而，自己明确指定类型，可运用到更精准和丰富 的数据类型。显然，从可读性上讲也是有好处的。当然，C＃也有类似的匿名类型，Haskell学的C#也说不定。

如果你在知道Haskell是上世纪八十年代就有的语言以后还看不出上句话是一个冷笑话，还是不要学Haskell了……

顺便说一下，haskell对程序代码的排版规范要求非常严格，首先它的语法结构依赖缩进，这一点和Python一样（如果你没学过Python， 这句话请无视），子语句要缩进一级，这一点Haskell学的Python也说不定（参见上一段！）。其次，所有模块名都应该是PASCAL命名，所有函 数名都应该是驼峰命名，切记！

现在我们终于说到这个万恶的单子（Monad）了。作为一门纯函数语言，Haskell是相当数学化的，我个人觉得 Haskell根本就是一门代数语言。它的函数其实就是算法定义。所以要求必须是“确定的”。也就是说，函数内部除了返回值，不能影响到外部。函数本身输 入值固定的话，必须确定的返回固定的值。

但是这样的话，就没办法解决一些麻烦，比如程序运行过程中需要保存状态，程序本身需要输入输出（不然我们怎么看到结果呢？）。这些功能都是不符合确定性的。

所以，Monad就应运而生了。关于Monad的定义，Haskell有一套漂亮的表达。不过我现在不打算关注它。我们只要知道这个东西相当于可以传递和保存值的对象就可以了。现在我们的任务是，先学会用现有的Monad，比如本教程中提到的各种Monad。

Haskell的main函数相当于c的main函数，都是程序执行入口，所以没得说，这个肯定是一个Monad，事实上它必须是IO()。所以我们的程序代码也一定要匹配这个结果。

如果要返回一个Monad，有两种办法，一种是把返回值用return 函数封装（编译器会根据你的函数定义选择类型），术语称为lift，当然，被lift的值要匹配定义的Monad；另一种是组合多个Monad。

后者看起来麻烦，其实操作起来很简单。比如do操作，它后面可以带多行语句，每一行要么是一个action，要么是一个a<-action的 取值操作。这里的action，就是指Monand化的一个事物，可以理解为一个对象实例（那么一个Monad定义可看作是一个类定义）。

因为串化为一组Monad，do的子语句是按顺序执行的，do块相当于我们在普通的命令式语言中编写的代码片段。

想到这一点，或许你会初步体会到Haskell是一个多么与众不同的语言。

实际上do对每行代码有更细致的规定，它其实是一个语法糖，本原是一组Monad串行操作。如果原文你不能允分理解，没关系，后面我们还会大量运用Monad，我们会熟悉它的。

本章教程最后还讲解了运算符和例程的编译方法，这个没有太惊诧的东西，不多讨论了。

重点学习读取输入，打印字符到输出，基本编译指令。

以及，Haskell中字符串就是序列，它的联接用++，而不是单个加号。

48 小时编写 Scheme 解释器的学习笔记：写在最前面。

这份教程是本很有趣的书，它并不算长－－48学时能有多久呢？Perl有本很有名的24小时教程，可以翻倍类比一下－－但是内容比较丰富。在前言中，作者提出了一些需要注意的地方：

这本书为两种人准备：一是已经学会Lisp和Scheme，准备学Haskell的；一种是不会这些编程语言，但是有比较强的专业背景和知识的。原文是说 “familiar with computer”，不过相信我，这肯定不是电脑城招装高手的那个“熟悉计算机”。

所以，这不是一本入门手册，这是为有一定基础的读者准备的。考虑到Haskell目前是一门如此小众的语言，这样的设定倒也合情合理。

这个邪恶的家伙特别提到，如果你有过程化编程或面向对象的基础，比如学过C、JAVA、Python之类的，这里最好把它们都忘了，因为Haskell中的类型、函数、甚至return，跟你之前习惯的东西完全不是一码事。

哈哈！这正是我兴奋的地方，如果再学一个语言，还是跟以前的差不多，也就没有什么意思了。

差异启迪思想，我不是语言收集狂，我学新东西是想让自己变聪明一些。

这份教材使用的是ghc编译器。我有很久都以为ghc是GNU Haskell Compiler，但它其实是 Glasgow Haskell Compiler。ghc 是目前最受欢迎的Haskell编译器，据作者说 Hugs 可能也能跑这个教程的例子，但是他没有试过……

我的学习笔记不一定就按 48 学时，只是个坑而已，看情况啦。

钢笔的诱惑

周四早上要出门的时候，想起以后要参加早上的例会。得要做笔记了。于是翻出一个本子，再去找笔。结果发现桌上的一大袋笔只有一只圆珠笔，一只红色的细马克笔，两只粗白板笔，其它都是铅笔。心想家里总要留一只的吧（其实后来想起家里某处好像有一排没开封的圆珠笔）。于是关门下楼，直奔小超市。
小地方，店面不大，文具架只有可怜的一窄条。几只笔筒里插着各种各样的笔。
最里面的地方，我看到几支黑色的钢笔，静静的斜在那里。
伸手摸了过去。
不行，太贵了，三天不写几个字，不值得，放下。
又伸手过去拿起来，拔下笔帽，抚摸笔尖的感觉。沉重的黑色金属笔身，很舒适的手感，英雄，喜欢用这个牌子。
不行，快上班了，拿支一元的水笔吧。
走了两步，又转回头，看货架上的墨水。只有黑的，纯蓝的，问过售货员，没有蓝黑墨水。
死心了，以我这种写字量，用碳素墨水肯定会堵笔尖的。
拿了支长得很像钢笔的圆珠笔。也是金属外壳，沉重的手感。
我如此深爱那种粗重的笔杆，流暢的手感。尽管我的字迹如此糟糕，现在一天也只有几次写字的机会。
丢过很多笔，包括最喜欢的一支。
用坏过很多笔，我曾经总是忍不住要毁坏文具，大概那时候心理上有某种强迫症。
曾经被大人细心教导，如何握笔写字，却从未有学会过正确的姿势。
曾经被教育，要端端正正的写字，堂堂正正的作人，但是一直没有学会漂亮的笔迹。
曾经被教育，一定要用钢笔，才能练出漂亮的字。我一直喜欢钢笔，字迹还是那么糟。
曾经，我们期待和被期待着的成长，在时间中慢慢变成不可能的幻想。
只有一些痕迹留下来。

读了一遍《Write Yourself a Scheme in 48 Hours》

很惭愧，Lee同学几年前就向我推荐《Write Yourself a Scheme in 48 Hours》，而我到最近才把它真正过了一遍。
收获很大，谢谢Lee。
这本书以step by step的方式，教给读者如何在48学时编写出一个Scheme解释器。
这本书可以说是经典的“第二本”读物。通过快速原型，逐步迭代的方式，引入haskell语法的方方面面，特别是各种monad的运用。如果你和我一样读入门教材时被卡在monad进退不能，这本书会帮你解脱。
书中没有使用haskell系统库之外的程序资源，仅仅以414行代码完成一个实用的scheme解释器，充分展示了haskell的强大。
在粗读过后，我准备逐章重新精读这篇教程，把内容彻底消化。
最后，要感谢太太的支持。感谢发芽网提供了一个很好的服务，让我可以轻松的记录学习进度。我的代码记录在这里。

Haskell语言: 48 小时编写sheme解释器的学习笔记－SimpleParser.hs

001 module Main where
002 import Monad
003 import Control.Monad.Error
004 import System.Environment
005 import IO hiding (try)
006 import Data.IORef
007 import Text.ParserCombinators.Parsec hiding (spaces)
008
009 symbol :: Parser Char
010 symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
011
012 data LispVal = Atom String
013              | List [LispVal]
014              | DottedList [LispVal] LispVal
015              | Number Integer
016              | String String
017              | Bool Bool
018              | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
019              | Func {params :: [String], vararg :: (Maybe String),
020                     body :: [LispVal], closure :: Env}
021              | IOFunc ([LispVal] -> IOThrowsError LispVal)
022              | Port Handle
023
024 data LispError = NumArgs Integer [LispVal]
025                | TypeMismatch String LispVal
026                | Parser ParseError
027                | BadSpecialForm String LispVal
028                | NotFunction String String
029                | UnboundVar String String
030                | Default String
031
032 spaces :: Parser ()
033 spaces = skipMany1 space
034
035 parseString :: Parser LispVal
036 parseString = do char '"'
037                  x <- many (noneOf "\"")
038                  char '"'
039                  return $ String x
040
041 parseAtom :: Parser LispVal
042 parseAtom = do first <- letter <|> symbol
043                rest <- many (letter <|> digit <|> symbol)
044                let atom = first:rest
045                return $ case atom of
046                           "#t" -> Bool True
047                           "#f" -> Bool False
048                           otherwise -> Atom atom
049
050 parseNumber :: Parser LispVal
051 parseNumber = liftM (Number . read) $ many1 digit
052
053 parseExpr :: Parser LispVal
054 parseExpr = parseAtom
055            <|> parseString
056            <|> parseNumber
057            <|> parseQuoted
058            <|> do char '('
059                   x <- (try parseList) <|> parseDottedList
060                   char ')'
061                   return x
062
063 parseList :: Parser LispVal
064 parseList = liftM List $ sepBy parseExpr spaces
065
066 parseDottedList :: Parser LispVal
067 parseDottedList = do
068   head <- endBy parseExpr spaces
069   tail <- char '.' >> spaces >> parseExpr
070   return $ DottedList head tail
071
072 parseQuoted :: Parser LispVal
073 parseQuoted = do
074   char '\''
075   x <- parseExpr
076   return $ List [Atom "quote", x]
077
078 eval :: Env -> LispVal -> IOThrowsError LispVal
079 eval env val@(String _) = return val
080 eval env val@(Number _) = return val
081 eval env val@(Bool _) = return val
082 eval env (Atom id) = getVar env id
083 eval env (List [Atom "quote", val]) = return val
084 eval env (List [Atom "if", pred, conseq, alt]) =
085     do result <- eval env pred
086        case result of
087          Bool False -> eval env alt
088          otherwise -> eval env conseq
089 eval env (List [Atom "set!", Atom var, form]) =
090     eval env form >>= setVar env var
091 eval env (List [Atom "load", String filename]) =
092     load filename >>= liftM last . mapM (eval env)
093 eval env (List [Atom "define", Atom var, form]) =
094     eval env form >>= defineVar env var
095 eval env (List (Atom "define" : List (Atom var : params) : body)) =
096     makeNormalFunc env params body >>= defineVar env var
097 eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body)) =
098     makeVarargs varargs env params body >>= defineVar env var
099 eval env (List (Atom "lambda" : List params : body)) =
100     makeNormalFunc env params body
101 eval env (List (Atom "lambda" : DottedList params varargs : body)) =
102     makeVarargs varargs env [] body
103 eval env (List (function : args)) = do
104   func <- eval env function
105   argVals <- mapM (eval env) args
106   apply func argVals
107 eval env badForm = throwError $ BadSpecialForm "Unrecongnized special form" badForm
108
109 car :: [LispVal] -> ThrowsError LispVal
110 car [List (x : xs)] = return x
111 car [DottedList (x : xs) _] = return x
112 car [badArg] = throwError $ TypeMismatch "pair" badArg
113 car badArgList = throwError $ NumArgs 1 badArgList
114
115 cdr :: [LispVal] -> ThrowsError LispVal
116 cdr [List (x : xs)] = return $ List xs
117 cdr [DottedList [xs] x] = return x
118 cdr [DottedList (_ : xs) x] = return $ DottedList xs x
119 cdr [badArg] = throwError $ TypeMismatch "pair" badArg
120 cdr badArgList = throwError $ NumArgs 1 badArgList
121
122
123 cons :: [LispVal] -> ThrowsError LispVal
124 cons [x1, List []] = return $ List [x1]
125 cons [x, List xs] = return $ List $ [x] ++ xs
126 cons [x, DottedList xs xlast] = return $ DottedList ([x] ++ xs) xlast
127 cons [x1, x2] = return $ DottedList [x1] x2
128 cons badArgList = throwError $ NumArgs 2 badArgList
129
130 eqv :: [LispVal] -> ThrowsError LispVal
131 eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
132 eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
133 eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
134 eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
135 eqv [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) && (and $ map eqvPair $ zip arg1 arg2)
136                                  where eqvPair (x1, x2) = case eqv [x1, x2] of
137                                                             Left err -> False
138                                                             Right (Bool val) -> val
139 eqv [_, _] = return $ Bool False
140 eqv badArgList = throwError $ NumArgs 2 badArgList
141
142 data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
143
144 unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
145 unpackEquals arg1 arg2 (AnyUnpacker unpacker) = do unpacked1 <- unpacker arg1
146                                                    unpacked2 <- unpacker arg2
147                                                    return $ unpacked1 == unpacked2
148                                                 `catchError` (const $ return False)
149
150 equal :: [LispVal] -> ThrowsError LispVal
151 equal [arg1, arg2] = do
152   primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
153                      [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
154   eqvEquals <- eqv [arg1, arg2]
155   return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
156 equal badArgList = throwError $ NumArgs 2 badArgList
157
158 apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
159 apply (PrimitiveFunc func) args = liftThrows $ func args
160 apply (Func params varargs body closure) args =
161     if num params /= num args && varargs == Nothing
162        then throwError $ NumArgs (num params) args
163        else (liftIO $ bindVars closure $ zip params args) >>= bindVarArgs varargs >>= evalBody
164     where remainingArgs = drop (length params) args
165           num = toInteger . length
166           evalBody env = liftM last $ mapM (eval env) body
167           bindVarArgs arg env = case arg of
168                                   Just argName -> liftIO $ bindVars env [(argName, List $ remainingArgs)]
169                                   Nothing -> return env
170 apply (IOFunc func) args = func args
171
172 applyProc :: [LispVal] -> IOThrowsError LispVal
173 applyProc [func, List args] = apply func args
174 applyProc (func : args) = apply func args
175
176 makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
177 makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
178
179 closePort :: [LispVal] -> IOThrowsError LispVal
180 closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
181 closePort _ = return $ Bool False
182
183 readProc :: [LispVal] -> IOThrowsError LispVal
184 readProc [] = readProc [Port stdin]
185 readProc [Port port] = (liftIO $ hGetLine stdin) >>= liftThrows . readExpr
186
187 writeProc :: [LispVal] -> IOThrowsError LispVal
188 writeProc [obj] = writeProc [obj, Port stdout]
189 writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)
190
191 readContents :: [LispVal] -> IOThrowsError LispVal
192 readContents [String filename] = liftM String $ liftIO $ readFile filename
193
194 load :: String -> IOThrowsError [LispVal]
195 load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
196
197 readAll :: [LispVal] -> IOThrowsError LispVal
198 readAll [String filename] = liftM List $ load filename
199
200 primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
201 primitives = [("+", numericBinop (+)),
202               ("-", numericBinop (-)),
203               ("*", numericBinop (*)),
204               ("/", numericBinop (div)),
205               ("mod", numericBinop mod),
206               ("quotient", numericBinop quot),
207               ("remainder", numericBinop rem),
208               ("=", numBoolBinop (==)),
209               ("<", numBoolBinop (<)),
210               (">", numBoolBinop (>)),
211               ("/=", numBoolBinop (/=)),
212               (">=", numBoolBinop (>=)),
213               ("<=", numBoolBinop (<=)),
214               ("&&", boolBoolBinop (&&)),
215               ("||", boolBoolBinop (||)),
216               ("string=?", strBoolBinop (==)),
217               ("string<?", strBoolBinop (<)),
218               ("string>?", strBoolBinop (>)),
219               ("string<=?", strBoolBinop (<=)),
220               ("string>=?", strBoolBinop (>=)),
221               ("car", car),
222               ("cdr", cdr),
223               ("cons", cons),
224               ("eq?", eqv),
225               ("eqv?", eqv),
226               ("equal?", equal)]
227
228 ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
229 ioPrimitives = [("apply", applyProc),
230                 ("open-input-file", makePort ReadMode),
231                 ("open-output-file", makePort WriteMode),
232                 ("close-input-port", closePort),
233                 ("close-output-port", closePort),
234                 ("read", readProc),
235                 ("write", writeProc),
236                 ("read-contents", readContents),
237                 ("read-all", readAll)]
238
239 primitiveBindings :: IO Env
240 primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives
241                     ++ map (makeFunc PrimitiveFunc) primitives)
242                     where makeFunc constructor (var, func) = (var, constructor func)
243
244 numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
245 numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
246 numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
247
248 boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
249 boolBinop unpacker op args = if length args /= 2
250                              then throwError $ NumArgs 2 args
251                              else do left <- unpacker $ args !! 0
252                                      right <- unpacker $ args !! 1
253                                      return $ Bool $ left `op` right
254
255 numBoolBinop = boolBinop unpackNum
256 strBoolBinop = boolBinop unpackStr
257 boolBoolBinop = boolBinop unpackBool
258
259 unpackNum :: LispVal -> ThrowsError Integer
260 unpackNum (Number n) = return n
261 unpackNum (String n) = let parsed = reads n in
262                        if null parsed
263                           then throwError $ TypeMismatch "number" $ String n
264                           else return $ fst $ parsed !! 0
265 unpackNum (List [n]) = unpackNum n
266 unpackNum notNum = throwError $ TypeMismatch "number" notNum
267
268 unpackStr :: LispVal -> ThrowsError String
269 unpackStr (String s) = return s
270 unpackStr (Number s) = return $ show s
271 unpackStr (Bool s) = return $ show s
272 unpackStr notString = throwError $ TypeMismatch "string" notString
273
274 unpackBool :: LispVal -> ThrowsError Bool
275 unpackBool (Bool b) = return b
276 unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
277
278 readOrThrow :: Parser a -> String -> ThrowsError a
279 readOrThrow parser input = case parse parser "lisp" input of
280                              Left err -> throwError $ Parser err
281                              Right val -> return val
282
283 readExpr :: String -> ThrowsError LispVal
284 readExpr = readOrThrow parseExpr
285 readExprList = readOrThrow (endBy parseExpr spaces)
286
287 showVal :: LispVal -> String
288 showVal (String contents) = "\"" ++ contents ++ "\""
289 showVal (Atom name) = name
290 showVal (Number contents) = show contents
291 showVal (Bool True) = "#t"
292 showVal (Bool False) = "#f"
293 showVal (List contents) = "(" ++ unwordsList contents ++ ")"
294 showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
295 showVal (PrimitiveFunc _) = "<primitive>"
296 showVal (Func {params = args, vararg = varargs, body = body, closure = env}) =
297     "(lambda (" ++ unwords (map show args) ++
298                 (case varargs of
299                    Nothing -> ""
300                    Just arg -> " . " ++ arg) ++ ") ...)"
301 showVal (Port _) = "<IO port>"
302 showVal (IOFunc _) = "<IO primitive>"
303
304 showError :: LispError -> String
305 showError (UnboundVar message varname) = message ++ ": " ++ varname
306 showError (BadSpecialForm message form) = message ++ ": " ++ show form
307 showError (NotFunction message func) = message ++ ": " ++ show func
308 showError (NumArgs expected found) = "Expected " ++ show expected
309                                      ++ " args; found values " ++ unwordsList found
310 showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found
311 showError (Parser parseErr) = "Parse error at " ++ show parseErr
312
313 instance Show LispError where show = showError
314
315 instance Error LispError where
316     noMsg = Default "An error has occurred"
317     strMsg = Default
318
319 type ThrowsError = Either LispError
320
321 trapError action = catchError action (return . show)
322
323 extractValue :: ThrowsError a -> a
324 extractValue (Right val) = val
325
326 unwordsList :: [LispVal] -> String
327 unwordsList = unwords . map showVal
328
329 instance Show LispVal where show = showVal
330
331 type Env = IORef [(String, IORef LispVal)]
332
333 nullEnv :: IO Env
334 nullEnv = newIORef []
335
336 type IOThrowsError = ErrorT LispError IO
337 liftThrows :: ThrowsError a -> IOThrowsError a
338 liftThrows (Left err) = throwError err
339 liftThrows (Right val) = return val
340
341 runIOThrows :: IOThrowsError String -> IO String
342 runIOThrows action = runErrorT (trapError action) >>= return . extractValue
343
344 isBound :: Env -> String -> IO Bool
345 isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var
346
347 getVar :: Env -> String -> IOThrowsError LispVal
348 getVar envRef var = do env <- liftIO $ readIORef envRef
349                        maybe (throwError $ UnboundVar "Getting an unbound variable" var)
350                              (liftIO . readIORef)
351                              (lookup var env)
352
353 setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
354 setVar envRef var value = do env <- liftIO $ readIORef envRef
355                              maybe (throwError $ UnboundVar "Setting an unbound variable" var)
356                                    (liftIO . (flip writeIORef value))
357                                    (lookup var env)
358                              return value
359
360 defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
361 defineVar envRef var value = do
362   alreadyDefined <- liftIO $ isBound envRef var
363   if alreadyDefined
364      then setVar envRef var value >> return value
365      else liftIO $ do
366        valueRef <- newIORef value
367        env <- readIORef envRef
368        writeIORef envRef ((var, valueRef) : env)
369        return value
370
371 makeFunc varargs env params body = return $ Func (map showVal params) varargs body env
372
373 makeNormalFunc = makeFunc Nothing
374
375 makeVarargs = makeFunc . Just . showVal
376
377 bindVars :: Env -> [(String, LispVal)] -> IO Env
378 bindVars envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef
379                            where extendEnv bindings env = liftM (++ env) (mapM addBinding bindings)
380                                  addBinding (var, value) = do ref <- newIORef value
381                                                               return (var, ref)
382
383 flushStr :: String -> IO()
384 flushStr str = putStr str >> hFlush stdout
385
386 readPrompt :: String -> IO String
387 readPrompt prompt = flushStr prompt >> getLine
388
389 evalString :: Env -> String -> IO String
390 evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env
391
392 evalAndPrint :: Env -> String -> IO ()
393 evalAndPrint env expr = evalString env expr >>= putStrLn
394
395
396
397 until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m ()
398 until_ pred prompt action = do
399   result <- prompt
400   if pred result
401      then return ()
402      else action result >> until_ pred prompt action
403
404 runOne :: [String] -> IO ()
405 runOne args = do
406   env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 args)]
407   (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)]))
408               >>= hPutStrLn stderr
409
410 runRepl :: IO ()
411 runRepl = primitiveBindings >>= until_ (== "quit") (readPrompt "Lisp>>> ") . evalAndPrint
412
413 main :: IO()
414 main = do args <- getArgs
415           if null args then runRepl else runOne $ args

书中使用的Scheme标准库源码stdlib.scm:

Scheme语言: 48 小时编写sheme解释器的学习笔记－stdlib.scm

01 (define (caar pair) (car (car pair)))
02 (define (cadr pair) (car (cdr pair)))
03 (define (cdar pair) (cdr (car pair)))
04 (define (cddr pair) (cdr (cdr pair)))
05 (define (caaar pair) (car (car (car pair))))
06 (define (caadr pair) (car (car (cdr pair))))
07 (define (cadar pair) (car (cdr (car pair))))
08 (define (caddr pair) (car (cdr (cdr pair))))
09 (define (cdaar pair) (cdr (car (car pair))))
10 (define (cdadr pair) (cdr (car (cdr pair))))
11 (define (cddar pair) (cdr (cdr (car pair))))
12 (define (cdddr pair) (cdr (cdr (cdr pair))))
13 (define (caaaar pair) (car (car (car (car pair)))))
14 (define (caaadr pair) (car (car (car (cdr pair)))))
15 (define (caadar pair) (car (car (cdr (car pair)))))
16 (define (caaddr pair) (car (car (cdr (cdr pair)))))
17 (define (cadaar pair) (car (cdr (car (car pair)))))
18 (define (cadadr pair) (car (cdr (car (cdr pair)))))
19 (define (caddar pair) (car (cdr (cdr (car pair)))))
20 (define (cadddr pair) (car (cdr (cdr (cdr pair)))))
21 (define (cdaaar pair) (cdr (car (car (car pair)))))
22 (define (cdaadr pair) (cdr (car (car (cdr pair)))))
23 (define (cdadar pair) (cdr (car (cdr (car pair)))))
24 (define (cdaddr pair) (cdr (car (cdr (cdr pair)))))
25 (define (cddaar pair) (cdr (cdr (car (car pair)))))
26 (define (cddadr pair) (cdr (cdr (car (cdr pair)))))
27 (define (cdddar pair) (cdr (cdr (cdr (car pair)))))
28 (define (cddddr pair) (cdr (cdr (cdr (cdr pair)))))
29
30 (define (not x)            (if x #f #t))
31 (define (null? obj)        (if (eqv? obj '()) #t #f))
32 (define (id obj)           obj)
33 (define (flip func)        (lambda (arg1 arg2) (func arg2 arg1)))
34 (define (curry func arg1)  (lambda (arg) (func arg1 arg)))
35 (define (compose f g)      (lambda (arg) (f (g arg))))
36
37 (define (foldl func accum lst)
38   (if (null? lst)
39       accum
40       (foldl func (func accum (car lst)) (cdr lst))))
41
42 (define (foldr func accum lst)
43   (if (null? lst)
44       accum
45       (func (car lst) (foldr func accum (cdr lst)))))
46
47 (define (unfold func init pred)
48   (if (pred init)
49       (cons init '())
50       (cons init (unfold func (func init) pred))))
51
52 (define fold foldl)
53 (define reduce fold)
54
55 (define zero?              (curry = 0))
56 (define positive?          (curry < 0))
57 (define negative?          (curry > 0))
58 (define (odd? num)         (= (mod num 2) 1))
59 (define (even? num)        (= (mod num 2) 0))
60 (define (max x . num-list) (fold (lambda (y z) (if (> y z) y z)) x num-list))
61 (define (min x . num-list) (fold (lambda (y z) (if (< y z) y z)) x num-list))
62 (define (list . objs)       objs)
63 (define (length lst)        (fold (lambda (x y) (+ x 1)) 0 lst))
64 (define (append lst . lsts) (foldr (flip (curry foldr cons)) lst lsts))
65 (define (reverse lst)       (fold (flip cons) '() lst))
66 (define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
67 (define (memq obj lst)       (fold (mem-helper (curry eq? obj) id) #f lst))
68 (define (memv obj lst)       (fold (mem-helper (curry eqv? obj) id) #f lst))
69 (define (member obj lst)     (fold (mem-helper (curry equal? obj) id) #f lst))
70 (define (assq obj alist)     (fold (mem-helper (curry eq? obj) car) #f alist))
71 (define (assv obj alist)     (fold (mem-helper (curry eqv? obj) car) #f alist))
72 (define (assoc obj alist)    (fold (mem-helper (curry equal? obj) car) #f alist))
73
74 (define (map func lst)      (foldr (lambda (x y) (cons (func x) y)) '() lst))
75 (define (filter pred lst)   (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst))
76
77 (define (sum . lst)         (fold + 0 lst))
78 (define (product . lst)     (fold * 1 lst))
79 (define (and . lst)         (fold && #t lst))
80 (define (or . lst)          (fold || #f lst))
81 (define (any? pred . lst)   (apply or (map pred lst)))
82 (define (every? pred . lst) (apply and (map pred lst)))