在 48 小時內編寫自己的 Scheme
答案

第 1 章

練習 1

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

練習 2

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

$ 運算子減少了此處所需的括號數量。或者，您可以將函式應用編寫為 read (args!!0)。

練習 3

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

第 2 章

第 3 節 - 解析

練習 1

第一部分

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

第二部分

為了回答這個問題，您需要進行一些偵探工作！閱讀有關 do 符號的內容會很有幫助。使用那裡的資訊，我們可以機械地將上述答案轉換為以下內容。

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

這可以清理為以下內容

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

練習 2

我們需要建立一個新的解析器操作，該操作接受一個反斜槓，後跟另一個反斜槓或雙引號。此操作需要只返回第二個字元。

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

完成後，我們需要對 parseString 進行一些更改。

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

練習 3

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

練習 4

首先，有必要更改 symbol 的定義。

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

這意味著原子不再可以用雜湊字元開頭。這需要一種不同的解析 #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 = parseDecimal1 <|> parseDecimal2 <|> parseHex <|> parseOct <|> parseBin

並且需要新增以下新函式。

parseDecimal1 :: Parser LispVal
parseDecimal1 = many1 digit >>= (return . Number . read)

parseDecimal2 :: Parser LispVal
parseDecimal2 = 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 函式。

練習 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 的組合確保只讀取單個字元。

請注意，這實際上不符合標準；按照目前的做法，“空格”和“換行符”必須完全是小寫；標準指出它們應該不區分大小寫。

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

練習 6

浮點數的可能解決方案

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

此外，新增

 try parseFloat

在 parseExpr 中的 parseNumber 之前，以及以下行

 | Float Double

到 LispVal 型別。

練習 7

Ratio，使用 Haskell 的 Rational 型別

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

此外，匯入 Data.Ratio 模組，新增

 try parseRatio

在 parseExpr 中的 parseNumber 之前，以及以下行

 | Ratio Rational

到 LispVal 型別。

Real 已經用 Exercise 6 中的 Float 型別實現，除非我錯了。

Complex，使用 Haskell 的 Complex 型別

 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 模組，新增

 try parseComplex

在 parseExpr 中的 parseNumber 和 parseFloat 之前，以及以下行

  | Complex (Complex Double)

到 LispVal 型別。

第 4 節 - 遞迴解析器：新增列表、點狀列表和帶引號的資料

練習 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]

 parseUnQuoteSplicing :: Parser LispVal
 parseUnQuoteSplicing = do
     char ','
     char '@'
     x <- parseExpr
     return $ List [Atom "unquote-splicing", x]

還新增

       <|> parseQuasiQuoted
       <|> parseUnQuote
       <|> parseUnQuoteSplicing

到 parseExpr。

練習 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 中；在列表和點式列表的解析器之前。

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

練習 3

這需要花一些時間調整 sepBy、endBy 及其朋友。我從讓 (. degenerate) 點式列表工作開始，然後從那裡開始。這段程式碼可以容忍尾部和前導空格。

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

另一個使用 Parsec 庫中更高階函式的實現。spaces 是本教程中的一個。

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
               maybeDatum <- optionMaybe (char '.' >> spaces >> parseExpr)
               return $ case maybeDatum of
                  Nothing -> List list
                  Just datum  -> DottedList list datum

另一種解決方案。spaces 是來自 Parsec 的空格，spaces1 是本教程中的空格。

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

第三章

練習 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 False
listp   _          = Bool False

練習 2

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

練習 3

將 symbol->string 和 string->symbol 新增到基本函式列表中，然後

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

這不能很好地處理錯誤的輸入，這將在後面討論。

第五章

練習 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

練習 2

定義一個輔助函式，它將相等/等價函式作為引數。

 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 listPair@[List _, List _] = eqvList eqv listPair

並將列表和點式列表的子句新增到相等函式中

 equal :: [LispVal] -> ThrowsError LispVal
 equal listPair@[List _, List _] = eqvList equal listPair
 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

練習 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

另一種方法，利用已經實現的 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

另一種方法

 eval (List ((Atom "cond") : alts)) = cond alts

 cond :: [LispVal] -> ThrowsError LispVal
 cond ((List (Atom "else" : value : [])) : []) = eval value
 cond ((List (condition : value : [])) : alts) = do
     result <- eval condition
     boolResult :: Bool <- unpackBool result
     if boolResult then eval value
                   else cond alts
 cond ((List a) : _) = throwError $ NumArgs 2 a
 cond (a : _) = throwError $ NumArgs 2 [a]
 cond _ = throwError $ Default "Not viable alternative in cond"

case

此解決方案需要 LispVal 具有 deriving (Eq) 子句，以便使用 `elem` 函式。

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

練習 4

讓我們新增 string-length 和 string-ref

   primitives = [...
                 ("string-length", stringLen),                                     │
                 ("string-ref", stringRef),
                 ...]

   stringLen :: [LispVal] -> ThrowsError LispVal
   stringLen [(String s)] = Right $ Number $ fromIntegral $ length s
   stringLen [notString]  = throwError $ TypeMismatch "string" notString
   stringLen badArgList   = throwError $ NumArgs 1 badArgList

   stringRef :: [LispVal] -> ThrowsError LispVal
   stringRef [(String s), (Number k)]
       | length s < k' + 1 = throwError $ Default "Out of bound error"
       | otherwise         = Right $ String $ [s !! k']
       where k' = fromIntegral k
   stringRef [(String s), notNum] = throwError $ TypeMismatch "number" notNum
   stringRef [notString, _]       = throwError $ TypeMismatch "string" notString
   stringRef badArgList           = throwError $ NumArgs 2 badArgList

在 48 小時內編寫自己的 Scheme
← 結論	答案