「Write Yourself a Scheme in 48 Hours」 を写経してみる。

Write Yourself a Scheme in 48 Hours」と言うHaskellSchemeを書くチュートリアルを見つけたので、理解出来るとこまで写経してみます。

1.First Steps: Compiling and running
2.Parsing
parsec によるパース

-- spaces を自分で定義しているので Parsec の spaces は隠している。
import Text.ParserCombinators.Parsec hiding (spaces)

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

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

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

symbolの文字にだけマッチして他は失敗。

 [1 of 1] Compiling Main             ( lisp1.hs, interpreted )
 Ok, modules loaded: Main.
 *Main> putStrLn $ readExpr "$"
 Loading package syb-0.1.0.2 ... linking ... done.
 Loading package base-3.0.3.2 ... linking ... done.
 Loading package parsec-2.1.0.1 ... linking ... done.
 Found value
 *Main>  putStrLn $ readExpr "<"
 Found value
 *Main>  putStrLn $ readExpr "a"
 No match: "lisp" (line 1, column 1):
 unexpected "a"
-- spaces 関数を追加
spaces :: Parser ()
spaces = skipMany1 space

-- readExpr 関数の適用する関数  symbol を (spaces >> symbol) に修正。
readExpr input = case parse (spaces >> symbol) "lisp" input of
    Left err -> "No match: " ++ show err
    Right val -> "Found value"

(spaces >> symbol) はパッと見た感じだと「">>" がモナドなので spaces を適用して結果を捨てて、symbolを適用しそう。

 *Main>  putStrLn $ readExpr "     *"
 Found value
 *Main>  putStrLn $ readExpr "       a"
 No match: "lisp" (line 1, column 8):
 unexpected "a"
 expecting space

スペースを読み飛ばしている。
パースした結果、数字は数字に、文字列は文字列として意味を持たせてリストに格納する必要があります。

module Main where

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

data LispVal = Atom String                  -- アトムは名前
             | List [LispVal]               -- リストはリスト
             | DottedList [LispVal] LispVal -- ドットリスト (a b . c)
             | Number Integer
             | String String
             | Bool Bool

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

spaces :: Parser ()
spaces = skipMany1 space

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

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

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

parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr spaces

parseDottedList :: Parser LispVal
parseDottedList = do
    head <- endBy parseExpr spaces
    tail <- char '.' >> spaces >> parseExpr
    return $ DottedList head tail

parseQuoted :: Parser LispVal
parseQuoted = do
    char '\''
    x <- parseExpr
    return $ List [Atom "quote", x]

parseExpr :: Parser LispVal
parseExpr = parseAtom
        <|> parseString
        <|> parseNumber
        <|> parseQuoted
        <|> do char '('
               x <- try parseList <|> parseDottedList
               char ')'
               return x

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

main :: IO ()
main = do args <- getArgs
          putStrLn (readExpr (args !! 0))
 *Main>  putStrLn $ readExpr "(a #t)"
 Found value
 *Main>  putStrLn $ readExpr "(a 123)"
 Found value
 *Main>  putStrLn $ readExpr "(12 123)"
 Found value
 *Main>  putStrLn $ readExpr "(a (nested) test)"
 Found value
 *Main>  putStrLn $ readExpr  "(a (dotted . list) test)"
 Found value
 *Main>  putStrLn $ readExpr  "(a '(quoted (dotted . list)) test)"
 Found value
-- http://jonathan.tang.name/files/scheme_in_48/code/listing3.4.hs
module Main where

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

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

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

spaces :: Parser ()
spaces = skipMany1 space

data LispVal = Atom String
             | List [LispVal]                -- List は LispVal のリスト。ネストしていても良い。
             | DottedList [LispVal] LispVal  -- (a b c . d) のようなリスト
             | Number Integer
             | String String
             | Bool Bool  deriving Show     -- 表示するために deriving Show を追加した。

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

parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr spaces

{- 
> parseTest parseList "(a b c . d)"
  --> List [DottedList [Atom "a",Atom "b",Atom "c"] (Atom "d")]
-}
parseDottedList :: Parser LispVal
parseDottedList = do
    head <- endBy parseExpr spaces
    tail <- char '.' >> spaces >> parseExpr
    return $ DottedList head tail

parseQuoted :: Parser LispVal
parseQuoted = do
    char '\''
    x <- parseExpr
    return $ List [Atom "quote", x]

parseExpr :: Parser LispVal
parseExpr = parseAtom
        <|> parseString
        <|> parseNumber
        <|> parseQuoted
        <|> do char '('
               x <- (try parseList) <|> parseDottedList
               char ')'
               return x
> parseTest parseString "\"hello\""   -- > String "hello"
> parseTest parseAtom "a"               -- > Atom "a"
> parseTest parseAtom "#f"              -- > Bool False
> parseTest parseAtom "#t"              -- > Bool True
> parseTest parseNumber "123"           -- > Number 123
> parseTest parseNumber "123.4"         -- > Number 123

> parseTest parseExpr  "(a (dotted . list) 123)"
-- > List [Atom "a",DottedList [Atom "dotted"] (Atom "list"),Number 123]

> parseTest parseExpr  "(a (dotted . list) '(abc (46 t)))"
-- > List [Atom "a",DottedList [Atom "dotted"] (Atom "list"),\
       \List [Atom "quote",List [Atom "abc",List [Number 46,Atom "t"]]]]

Parsing はここまで。
まとまったコードはこちらにあります。Index of /files/scheme_in_48/code