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

Chapter 1

Exercise 1

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

Exercise 2

main :: IO ()
main = do args <- getArgs
          print ((read $ args!!0) + (read $ args!!1))

$操作符减少了这里需要的括号。同样你这里也可以写作read (args!!0)。

Exercise 3

main :: IO ()
main = do putStrLn "What do they call thee at home?"
          name <- getLine
          putStrLn ("Ey up " ++ name)

Chapter 2

Section 3

Exercise 1

Part 1

parseNumber :: Parser LispVal
parseNumber = do x <- many1 digit
                (return . Number . read) x

Part 2

为了回答这个问题，你需要做一点调查的工作！了解以下do表示法是有帮助的，有了这些信息，我们可以简单的将上面的答案转化成这样子：

parseNumber = many1 digit >>= \x -> (return . Number . read) x

可以简写成以下形式：

parseNumber = many1 digit >>= return . Number . read

Exercise 2

我们需要创建一个新的解析操作来处理斜杠后面紧跟着另一个斜杠或者双引号的情况，这个操作需要将解析得到的第二个字符返回。

escapedChars :: Parser Char
escapedChars = do char '\\' -- a backslash
                  x <- oneOf "\\\"" -- either backslash or doublequote
                  return x -- return the escaped character

完成之后我们还需要修改下我们的parserString函数：

parseString :: Parser LispVal
parseString = do char '"'
                 x <- many $ escapedChars <|> noneOf "\"\\"
                 char '"'
                 return $ String x

Exercise 3

escapedChars :: Parser Char
escapedChars = do char '\\' 
                  x <- oneOf "\\\"nrt" 
                  return $ case x of 
                    '\\' -> x
                    '"'  -> x
                    'n'  -> '\n'
                    'r'  -> '\r'
                    't'  -> '\t'

Exercise 4

首先我们需要修改symbol函数的定义：

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

这意味着atom类型不再能够以#符号开始了。这让我们需要换一种方法解析#t和#f。

parseBool :: Parser LispVal
parseBool = do
    char '#'
    (char 't' >> return (Bool True)) <|> (char 'f' >> return (Bool False))

这又要求我们继续修改parseExpr函数：

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

同样parseNumber函数需要如下修改：

parseNumber :: Parser LispVal
parseNumber = parseDigital1 <|> parseDigital2 <|> parseHex <|> parseOct <|> parseBin

然后再添加几个需要的函数：

parseDigital1 :: Parser LispVal
parseDigital1 = many1 digit >>= (return . Number . read)
parseDigital2 :: Parser LispVal
parseDigital2 = do try $ string "#d"
                   x <- many1 digit
                   (return . Number . read) x
parseHex :: Parser LispVal
parseHex = do try $ string "#x"
              x <- many1 hexDigit
              return $ Number (hex2dig x)
parseOct :: Parser LispVal
parseOct = do try $ string "#o"
              x <- many1 octDigit
              return $ Number (oct2dig x)
parseBin :: Parser LispVal
parseBin = do try $ string "#b"
              x <- many1 (oneOf "10")
              return $ Number (bin2dig x)
oct2dig x = fst $ readOct x !! 0
hex2dig x = fst $ readHex x !! 0
bin2dig  = bin2dig' 0
bin2dig' digint "" = digint
bin2dig' digint (x:xs) = let old = 2 * digint + (if x == '0' then 0 else 1) in
                         bin2dig' old xs

导入Numeric模块来使用readOct和readHex函数。

Exercise 5

data LispVal = Atom String
             | List [LispVal]
             | DottedList [LispVal] LispVal
             | Number Integer
             | String String
             | Bool Bool
             | Character Char
parseCharacter :: Parser LispVal
parseCharacter = do
 try $ string "#\\"
 value <- try (string "newline" <|> string "space") 
         <|> do { x <- anyChar; notFollowedBy alphaNum ; return [x] }
  return $ Character $ case value of
    "space" -> ' '
    "newline" -> '\n'
    otherwise -> (value !! 0)

anyChar和notFollowedBy的组合保证了每次只有一个字符被读入。

注意这里其实并没有完全遵从标准：这里space和newline字符串都需要时小写的，而标准里则强调它们其实是大小写不敏感的。

parseExpr :: Parser LispVal
parseExpr = parseAtom
        <|> parseString
        <|> try parseNumber -- we need the 'try' because 
        <|> try parseBool -- these can all start with the hash char
        <|> try parseCharacter

Exercise 6

一种浮点数的解决方案：

parseFloat :: Parser LispVal
parseFloat = do x <- many1 digit
               char '.'
               y <- many1 digit
               return $ Float (fst.head$readFloat (x++"."++y))

然后在parseExpr的parseNumber行之前添加：

try parseFloat

并且添加对应的数据类型到LispVal得定义。

| Float Double

Exercise 7

分数，使用Haskell内置的分数类型：

parseRatio :: Parser LispVal
parseRatio = do x <- many1 digit
               char '/'
               y <- many1 digit
               return $ Ratio ((read x) % (read y))

需要额外导入Data.Ratio模块，然后在parseExpr函数的parseNumber前添加以下内容：

try parseRatio

同样在LispVal中添加：

| Ratio Rational

实数在练习6中已经定义过了。除非我搞错了。

复数部分会用到Haskell的复数类型：

toDouble :: LispVal -> Double
toDouble(Float f) = realToFrac f
toDouble(Number n) = fromIntegral n
parseComplex :: Parser LispVal
parseComplex = do x <- (try parseFloat <|> parseDecimal)
                 char '+' 
                 y <- (try parseFloat <|> parseDecimal)
                 char 'i' 
                 return $ Complex (toDouble x :+ toDouble y)

你需要预先导入Data.Complex模块，然后再parseExpr的parseNumber和parseFloat之前添加：

try parseComplex

并在LispVal的定义中添加：

| Complex (Complex Double)

Section 4

Exercise 1

这两部分都和parseQuoted类似：

parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted = do
   char '`'
   x <- parseExpr
   return $ List [Atom "quasiquote", x]
parseUnQuote :: Parser LispVal
parseUnQuote = do
   char ','
   x <- parseExpr
   return $ List [Atom "unquote", x]

然后在parseExpr中添加：

<|> parseQuasiQuoted
<|> parseUnQuote

Exercise 2

我选择使用Data.Array模块中的数组，并使用列表到数组的转换器来作为数组的构造器：

parseVector :: Parser LispVal
parseVector = do arrayValues <- sepBy parseExpr spaces
                return $ Vector (listArray (0,(length arrayValues - 1)) arrayValues)

导入Data.Array然后在LispVal类型中添加：

| Vector (Array Int LispVal)

在parseExpr中List和DottedList之前添加以下内容：

<|> try (do string "#("
           x <- parseVector
           char ')'
           return x)

Exercise 3

这里我们需要花点心思来操纵sepBy和endBy之类的函数。我首先尝试通过(. degenerate)来对DottedList进行匹配根据匹配的结果进行判断。而且这段代码并不会受首尾出现的空格所影响。

parseAnyList :: Parser LispVal
parseAnyList = do
  P.char '('
  optionalSpaces
  head <- P.sepEndBy parseExpr spaces
  tail <- (P.char '.' >> spaces >> parseExpr) <|> return (Nil ())
  optionalSpaces
  P.char ')'
  return $ case tail of
    (Nil ()) -> List head
    otherwise -> DottedList head tail

另一种使用Nil构造器的解决方法用来更多Parsec库的高级特性。这里spaces函数就是我们教程中定义的那个。

data LispVal = Nil
            | Atom String
            | List [LispVal]
            | DottedList [LispVal] LispVal
            | Number Integer
            | String String
            | Bool Bool
            | Char Char
parseList :: Parser LispVal
parseList = between beg end parseList1
           where beg = (char '(' >> skipMany space)
                 end = (skipMany space >> char ')')
parseList1 :: Parser LispVal
parseList1 = do list <- sepEndBy parseExpr spaces
               datum <- option Nil (char '.' >> spaces >> parseExpr)
               return $ case datum of
                  Nil -> List list
                  val  -> DottedList list val

另一种没有使用Nil的解决方案。spaces函数是Parsec库自带的，spaces1则是教程中定义的spaces函数。

parseList :: Parser LispVal
parseList = do char '(' >> spaces
               head <- parseExpr `sepEndBy` spaces1
               do char '.' >> spaces1
                  tail <- parseExpr
                  spaces >> char ')'
                  return $ DottedList head tail
                <|> (spaces >> char ')' >> (return $ List head))

Chapter 3

Exercise 1

这里是其中的一部分：

primitives :: [(String , [LispVal] -> LispVal)]
primitives = [("+" , numericBinop (+)) ,
              ("-" , numericBinop (-)) ,
              ("*" , numericBinop (*)) ,
              ("/" , numericBinop div) ,
              ("mod" , numericBinop mod) ,
              ("quotient" , numericBinop quot) ,
              ("remainder" , numericBinop rem) ,
              ("symbol?" , unaryOp symbolp) ,
              ("string?" , unaryOp stringp) ,
              ("number?" , unaryOp numberp) ,
              ("bool?", unaryOp boolp) ,
              ("list?" , unaryOp listp)]
unaryOp :: (LispVal -> LispVal) -> [LispVal] -> LispVal
unaryOp f [v] = f v
symbolp, numberp, stringp, boolp, listp :: LispVal -> LispVal
symbolp (Atom _)   = Bool True
symbolp _          = Bool False
numberp (Number _) = Bool True
numberp _          = Bool False
stringp (String _) = Bool True
stringp _          = Bool False
boolp   (Bool _)   = Bool True
boolp   _          = Bool False
listp   (List _)   = Bool True
listp   (DottedList _ _) = Bool True
listp   _          = Bool False

Exercise 2

unpackNum :: LispVal -> Integer
unpackNum (Number n) = n
unpackNum _          = 0

Exercise 3

在primitives列表中添加symbol到字符串和字符串到symbol的转换函数：

symbol2string, string2symbol :: LispVal -> LispVal
symbol2string (Atom s)   = String s
symbol2string _          = String ""
string2symbol (String s) = Atom s
string2symbol _          = Atom ""

这里我们的错误处理会有点问题，不过别担心，之后我们会修复这些问题。

Chapter 5

Exercise 1

eval env (List [Atom "if", pred, conseq, alt]) = do 
   result <- eval env pred
   case result of
     Bool False -> eval env alt
     Bool True  -> eval env conseq
     _          -> throwError $ TypeMismatch "bool" pred

Exercise 2

定义一个将equal或者eqv函数作为参数的辅助函数：

eqvList :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal
eqvList eqvFunc [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) && 
                                                   (all eqvPair $ zip arg1 arg2)
     where eqvPair (x1, x2) = case eqvFunc [x1, x2] of
                                   Left err -> False
                                   Right (Bool val) -> val

调整eqv中的部分：

eqv [l1@(List arg1), l2@(List arg2)] = eqvList eqv [l1, l2]

然后再equal函数中添加List和DottedList对应的部分：

equal :: [LispVal] -> ThrowsError LispVal
equal [l1@(List arg1), l2@(List arg2)] = eqvList equal [l1, l2]
equal [(DottedList xs x), (DottedList ys y)] = equal [List $ xs ++ [x], List $ ys ++ [y]]
equal [arg1, arg2] = do
   primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
                      [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
   eqvEquals <- eqv [arg1, arg2]
   return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList

Exercise 3

cond
这里还有很多改善空间！

eval (List ((Atom "cond"):cs))              = do 
  b <- (liftM (take 1 . dropWhile f) $ mapM condClause cs) >>= cdr   
  car [b] >>= eval 
    where condClause (List [p,b]) = do q <- eval p
                                       case q of
                                         Bool _ -> return $ List [q,b]
                                         _      -> throwError $ TypeMismatch "bool" q 
          condClause v            = throwError $ TypeMismatch "(pred body)" v 
          f                       = \(List [p,b]) -> case p of 
                                                       (Bool False) -> True
                                                       _            -> False

另一种方法：

eval env (List (Atom "cond" : expr : rest)) = do
    eval' expr rest
    where eval' (List [cond, value]) (x : xs) = do
              result <- eval env cond
              case result of
                   Bool False -> eval' x xs
                   Bool True  -> eval env value
                   otherwise  -> throwError $ TypeMismatch "boolean" cond
          eval' (List [Atom "else", value]) [] = do
               eval env value
          eval' (List [cond, value]) [] = do
              result <- eval env cond
              case result of
                   Bool True  -> eval env value
                   otherwise  -> throwError $ TypeMismatch "boolean" cond

Yet another approach, piggy-backing off of the already-implemented if:

eval form@(List (Atom "cond" : clauses)) =
  if null clauses
  then throwError $ BadSpecialForm "no true clause in cond expression: " form
  else case head clauses of
    List [Atom "else", expr] -> eval expr
    List [test, expr]        -> eval $ List [Atom "if",
                                             test,
                                             expr,
                                             List (Atom "cond" : tail clauses)]
    _ -> throwError $ BadSpecialForm "ill-formed cond expression: " form

case
为了使用elem函数，我们需要在LispVal的定义中添加这么一句deriving (Eq)。

eval form@(List (Atom "case" : key : clauses)) =
  if null clauses
  then throwError $ BadSpecialForm "no true clause in case expression: " form
  else case head clauses of
    List (Atom "else" : exprs) -> mapM eval exprs >>= return . last
    List ((List datums) : exprs) -> do
      result <- eval key
      equality <- mapM (\x -> eqv [result, x]) datums
      if Boolean True `elem` equality
        then mapM eval exprs >>= return . last
        else eval $ List (Atom "case" : key : tail clauses)
    _                     -> throwError $ BadSpecialForm "ill-formed case expression: " form

Exercise 4

期待你的答案！