读了一遍《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)))