原文。
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))

$操作符減少了這里需要的括號(hào)。同樣你這里也可以寫作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

為了回答這個(gè)問(wèn)題，你需要做一點(diǎn)調(diào)查的工作！了解以下do表示法是有幫助的，有了這些信息，我們可以簡(jiǎn)單的將上面的答案轉(zhuǎn)化成這樣子：

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

可以簡(jiǎn)寫成以下形式：

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

Exercise 2

我們需要?jiǎng)?chuàng)建一個(gè)新的解析操作來(lái)處理斜杠后面緊跟著另一個(gè)斜杠或者雙引號(hào)的情況，這個(gè)操作需要將解析得到的第二個(gè)字符返回。

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

完成之后我們還需要修改下我們的parserString函數(shù)：

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函數(shù)的定義：

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

這意味著atom類型不再能夠以#符號(hào)開(kāi)始了。這讓我們需要換一種方法解析#t和#f。

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

這又要求我們繼續(xù)修改parseExpr函數(shù)：

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

同樣parseNumber函數(shù)需要如下修改：

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

然后再添加幾個(gè)需要的函數(shù)：

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

導(dǎo)入Numeric模塊來(lái)使用readOct和readHex函數(shù)。

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的組合保證了每次只有一個(gè)字符被讀入。

注意這里其實(shí)并沒(méi)有完全遵從標(biāo)準(zhǔn)：這里space和newline字符串都需要時(shí)小寫的，而標(biāo)準(zhǔn)里則強(qiáng)調(diào)它們其實(shí)是大小寫不敏感的。

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

一種浮點(diǎn)數(shù)的解決方案：

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

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

try parseFloat

并且添加對(duì)應(yīng)的數(shù)據(jù)類型到LispVal得定義。

| Float Double

Exercise 7

分?jǐn)?shù)，使用Haskell內(nèi)置的分?jǐn)?shù)類型：

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

需要額外導(dǎo)入Data.Ratio模塊，然后在parseExpr函數(shù)的parseNumber前添加以下內(nèi)容：

try parseRatio

同樣在LispVal中添加：

| Ratio Rational

實(shí)數(shù)在練習(xí)6中已經(jīng)定義過(guò)了。除非我搞錯(cuò)了。

復(fù)數(shù)部分會(huì)用到Haskell的復(fù)數(shù)類型：

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)

你需要預(yù)先導(dǎo)入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模塊中的數(shù)組，并使用列表到數(shù)組的轉(zhuǎn)換器來(lái)作為數(shù)組的構(gòu)造器：

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

導(dǎo)入Data.Array然后在LispVal類型中添加：

| Vector (Array Int LispVal)

在parseExpr中List和DottedList之前添加以下內(nèi)容：

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

Exercise 3

這里我們需要花點(diǎn)心思來(lái)操縱sepBy和endBy之類的函數(shù)。我首先嘗試通過(guò)(. degenerate)來(lái)對(duì)DottedList進(jìn)行匹配根據(jù)匹配的結(jié)果進(jìn)行判斷。而且這段代碼并不會(huì)受首尾出現(xiàn)的空格所影響。

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構(gòu)造器的解決方法用來(lái)更多Parsec庫(kù)的高級(jí)特性。這里spaces函數(shù)就是我們教程中定義的那個(gè)。

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

另一種沒(méi)有使用Nil的解決方案。spaces函數(shù)是Parsec庫(kù)自帶的，spaces1則是教程中定義的spaces函數(shù)。

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的轉(zhuǎn)換函數(shù)：

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

這里我們的錯(cuò)誤處理會(huì)有點(diǎn)問(wèn)題，不過(guò)別擔(dān)心，之后我們會(huì)修復(fù)這些問(wèn)題。

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

定義一個(gè)將equal或者eqv函數(shù)作為參數(shù)的輔助函數(shù)：

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

調(diào)整eqv中的部分：

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

然后再equal函數(shù)中添加List和DottedList對(duì)應(yīng)的部分：

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函數(shù)，我們需要在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

期待你的答案！