作者
Ivan Chien
始于
分类：Interpreter
Tags: [ Haskell Interpreter ]
始于
分类：Interpreter
Tags: [ Haskell Interpreter ]
Write Yourself a Scheme in 48 Hours Notes
Chapter 1. First Steps
hello.hs
module Main where
import System.Environment
main :: IO()
main = do args <- getArgs
putStrLn ("hello, " ++ args !! 0)
-
每一个 Haskell 程序都是从叫 Main 的 module 的一个叫 main 的 action 开始的
-
区分大小写，module 总是首字母大写，声明总是首字母小写
-
main :: IO()表示main这个 action 的类型为IO()，IO类型是一个 monad -
IO action 的递归定义：要么使用 return function 导出值，要么组合两个 IO actions
-
do-block 的缩进需要注意，块内的每一行需要保证其第一个非空白字符在 与 do 平齐的地方之后
-
++用于字符串连接，!!是索引 -
ghc的-o参数用于指定导出的可执行文件名称 -
下面给出一个
read和show函数的示例，这两个函数用于数与字符串的转换-- ex2.hs
ex1.hs
module Main where
import System.Environment
main :: IO()
main = do args <- getArgs
putStrLn ("Hello, " ++ args !! 0 ++ " and " ++ args !! 1)
ex2.hs
module Main where
import System.Environment
main :: IO()
main = do args <- getArgs
let a = read(args !! 0) :: Int
let b = read(args !! 1) :: Int
putStrLn (args !! 0 ++ " + " ++ args !! 1 ++ " = " ++ show(a + b))
ex3.hs
module Main where
main :: IO()
main = do name <- getLine
putStrLn $ "Hello, " ++ name
Chapter 2. Parsing
simpleparser1.hs
module Main where
import System.Environment
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO()
main = do args <- getArgs
putStrLn (readExpr (args !! 0))
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"
simpleparser2.hs
import System.Environment
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO()
main = do args <- getArgs
putStrLn (readExpr (args !! 0))
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> String
readExpr input = case parse (spaces >> symbol) "lisp" input of
Left err -> "No match: " ++ show err
Right val -> "Found value"
spaces :: Parser()
spaces = skipMany1 space
>>被叫做 operator bind
datatypeparser.hs
module Main where
import Control.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 "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> String
readExpr input = case parse parseExpr "lisp" input of
Left err -> "No match: " ++ show err
Right val -> "Found value"
spaces :: Parser()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
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
parseExpr :: Parser LispVal
parseExpr = parseAtom
<|> parseString
<|> parseNumber
- operator
<|>是 Parsec 的一个 combinator，用来选择 parser。短路原则。 (Number . read)表示 function composition，用于many1 digit提供的匹配变成 String 再变为 LispVal 的 Number，再用liftM函数可以把结果变为 parser。
ex.hs
module Main where
import Control.Monad
import System.Environment
import Numeric (readOct, readHex)
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO()
main = do args <- getArgs
putStrLn (readExpr (args !! 0))
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> String
readExpr input = case parse parseExpr "lisp" input of
Left err -> "No match: " ++ show err
Right val -> "Found value"
spaces :: Parser()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
| Char Char
parseChar :: Parser LispVal
parseChar = do char '\''
c <- noneOf "'"
char '\''
return $ Char c
parseString :: Parser LispVal
parseString = do char '"'
x <- many chars
char '"'
return $ String x
where chars = escaped <|> noneOf "\""
escaped = char '\\' >> choice (zipWith escapedChar codes replacements)
escapedChar :: Char -> Char -> Parser Char
escapedChar code replacement = char code >> return replacement
codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']
replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']
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
parseDec :: Parser LispVal
parseDec = do n <- many1 digit
return (Number (read n))
parseOct :: Parser LispVal
parseOct = do char '#'
char 'o'
rest <- many1 octDigit
return (Number (fst (readOct rest !! 0)))
parseHex :: Parser LispVal
parseHex = do char '#'
char 'x'
rest <- many1 hexDigit
return (Number (fst (readHex rest !! 0)))
parseNumber :: Parser LispVal
parseNumber = parseDec
<|> try parseOct
<|> try parseHex
parseExpr :: Parser LispVal
parseExpr = parseChar
<|> parseNumber
<|> parseString
<|> parseAtom
完成了部分。现在可以识别：
- 八进制和十六进制
- 转义字符
recursiveparser.hs
module Main where
import Control.Monad
import System.Environment
import Numeric (readOct, readHex)
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO()
main = do args <- getArgs
putStrLn (readExpr (args !! 0))
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> String
readExpr input = case parse parseExpr "lisp" input of
Left err -> "No match: " ++ show err
Right val -> "Found value"
spaces :: Parser ()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
| Char Char
parseChar :: Parser LispVal
parseChar = do char '\''
c <- noneOf "'"
char '\''
return $ Char c
parseString :: Parser LispVal
parseString = do char '"'
x <- many chars
char '"'
return $ String x
where chars = escaped <|> noneOf "\""
escaped = char '\\' >> choice (zipWith escapedChar codes replacements)
escapedChar :: Char -> Char -> Parser Char
escapedChar code replacement = char code >> return replacement
codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']
replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']
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
parseDec :: Parser LispVal
parseDec = do n <- many1 digit
return (Number (read n))
parseOct :: Parser LispVal
parseOct = do char '#'
char 'o'
rest <- many1 octDigit
return (Number (fst (readOct rest !! 0)))
parseHex :: Parser LispVal
parseHex = do char '#'
char 'x'
rest <- many1 hexDigit
return (Number (fst (readHex rest !! 0)))
parseNumber :: Parser LispVal
parseNumber = parseDec
<|> try parseOct
<|> try parseHex
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 = try parseChar
<|> parseNumber
<|> parseString
<|> parseAtom
<|> parseQuoted
<|> do char '('
x <- (try parseList) <|> parseDottedList
char ')'
return x
List 和 Dotted List 的 recursive parser。
这里实现的其实是一个非确定性自动机，Dotted List 的 . 会出现在中间，parser 并不知道到底是 List 还是 Dotted List。
Chapter 3. Evaluation, Part 1
evaluator1.hs
module Main where
import Control.Monad
import System.Environment
import Numeric (readOct, readHex)
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO()
main = do args <- getArgs
putStrLn (readExpr (args !! 0))
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> String
readExpr input = case parse parseExpr "lisp" input of
Left err -> "No match: " ++ show err
Right val -> "Found " ++ show val
spaces :: Parser ()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
| Char Char
parseChar :: Parser LispVal
parseChar = do char '\''
c <- noneOf "'"
char '\''
return $ Char c
parseString :: Parser LispVal
parseString = do char '"'
x <- many chars
char '"'
return $ String x
where chars = escaped <|> noneOf "\""
escaped = char '\\' >> choice (zipWith escapedChar codes replacements)
escapedChar :: Char -> Char -> Parser Char
escapedChar code replacement = char code >> return replacement
codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']
replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']
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
parseDec :: Parser LispVal
parseDec = do n <- many1 digit
return (Number (read n))
parseOct :: Parser LispVal
parseOct = do char '#'
char 'o'
rest <- many1 octDigit
return (Number (fst (readOct rest !! 0)))
parseHex :: Parser LispVal
parseHex = do char '#'
char 'x'
rest <- many1 hexDigit
return (Number (fst (readHex rest !! 0)))
parseNumber :: Parser LispVal
parseNumber = parseDec
<|> try parseOct
<|> try parseHex
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 = try parseChar
<|> parseNumber
<|> parseString
<|> parseAtom
<|> parseQuoted
<|> do char '('
x <- (try parseList) <|> parseDottedList
char ')'
return x
showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal
instance Show LispVal where show = showVal
加了输出。
evaluator2.hs
module Main where
import Control.Monad
import System.Environment
import Numeric (readOct, readHex)
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO()
main = getArgs >>= putStrLn . show . eval . readExpr . (!! 0)
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> LispVal
readExpr input = case parse parseExpr "lisp" input of
Left err -> String $ "No match: " ++ show err
Right val -> val
spaces :: Parser ()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
| Char Char
parseChar :: Parser LispVal
parseChar = do char '\''
c <- noneOf "'"
char '\''
return $ Char c
parseString :: Parser LispVal
parseString = do char '"'
x <- many chars
char '"'
return $ String x
where chars = escaped <|> noneOf "\""
escaped = char '\\' >> choice (zipWith escapedChar codes replacements)
escapedChar :: Char -> Char -> Parser Char
escapedChar code replacement = char code >> return replacement
codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']
replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']
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
parseDec :: Parser LispVal
parseDec = do n <- many1 digit
return (Number (read n))
parseOct :: Parser LispVal
parseOct = do char '#'
char 'o'
rest <- many1 octDigit
return (Number (fst (readOct rest !! 0)))
parseHex :: Parser LispVal
parseHex = do char '#'
char 'x'
rest <- many1 hexDigit
return (Number (fst (readHex rest !! 0)))
parseNumber :: Parser LispVal
parseNumber = parseDec
<|> try parseOct
<|> try parseHex
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 = try parseChar
<|> parseNumber
<|> parseString
<|> parseAtom
<|> parseQuoted
<|> do char '('
x <- (try parseList) <|> parseDottedList
char ')'
return x
showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal
instance Show LispVal where show = showVal
eval :: LispVal -> LispVal
eval val@(String _) = val
eval val@(Number _) = val
eval val@(Bool _) = val
eval (List [Atom "quote", val]) = val
增加了 eval 的逻辑。当前只支持直接输出 String、Number 和 Bool，还有使用 quote 修饰的无需求值的值。
evaluator3.hs
module Main where
import Control.Monad
import System.Environment
import Numeric (readOct, readHex)
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO()
main = getArgs >>= putStrLn . show . eval . readExpr . (!! 0)
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> LispVal
readExpr input = case parse parseExpr "lisp" input of
Left err -> String $ "No match: " ++ show err
Right val -> val
spaces :: Parser ()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
| Char Char
parseChar :: Parser LispVal
parseChar = do char '\''
c <- noneOf "'"
char '\''
return $ Char c
parseString :: Parser LispVal
parseString = do char '"'
x <- many chars
char '"'
return $ String x
where chars = escaped <|> noneOf "\""
escaped = char '\\' >> choice (zipWith escapedChar codes replacements)
escapedChar :: Char -> Char -> Parser Char
escapedChar code replacement = char code >> return replacement
codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']
replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']
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
parseDec :: Parser LispVal
parseDec = do n <- many1 digit
return (Number (read n))
parseOct :: Parser LispVal
parseOct = do char '#'
char 'o'
rest <- many1 octDigit
return (Number (fst (readOct rest !! 0)))
parseHex :: Parser LispVal
parseHex = do char '#'
char 'x'
rest <- many1 hexDigit
return (Number (fst (readHex rest !! 0)))
parseNumber :: Parser LispVal
parseNumber = parseDec
<|> try parseOct
<|> try parseHex
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 = try parseChar
<|> parseNumber
<|> parseString
<|> parseAtom
<|> parseQuoted
<|> do char '('
x <- (try parseList) <|> parseDottedList
char ')'
return x
showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal
instance Show LispVal where show = showVal
eval :: LispVal -> LispVal
eval val@(String _) = val
eval val@(Number _) = val
eval val@(Bool _) = val
eval (List [Atom "quote", val]) = val
eval (List (Atom func : args)) = apply func $ map eval args
apply :: String -> [LispVal] -> LispVal
apply func args = maybe (Bool False) ($ args) $ lookup func primitives
primitives :: [(String, [LispVal] -> LispVal)]
primitives = [("+", numericBinop (+)),
("-", numericBinop (-)),
("*", numericBinop (*)),
("/", numericBinop div),
("mod", numericBinop mod),
("quotient", numericBinop quot),
("remainder", numericBinop rem)]
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> LispVal
numericBinop op params = Number $ foldl1 op $ map unpackNum params
unpackNum :: LispVal -> Integer
unpackNum (Number n) = n
unpackNum (String n) = let parsed = reads n in
if null parsed
then 0
else fst $ parsed !! 0
unpackNum (List [n]) = unpackNum n
unpackNum _ = 0
为 Number 添加求值逻辑。fold1 的目的是为了让这些二元运算符能多个参数连续使用。
unpackNum 用来递归求值。这这个含数字有几个作用：
- 将 Number 型直接返回
- 将 String 型解析为 Number 型，如果解析不成就返回 0
- 将 List 型递归
unpackNum。其实涉及 List 的求值都需要递归。 - 其他类型直接为 0。
这里面包含 2 和 4 两种出错的情况这里直接作为 0 处理了。后面会使用 error handler。
Chapter 4. Error Checking and Exceptions
errorcheck.hs
module Main where
import Control.Monad
import System.Environment
import Control.Monad.Error
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO ()
main = do
args <- getArgs
evaled <- return $ liftM show $ readExpr (args !! 0) >>= eval
putStrLn $ extractValue $ trapError evaled
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
Left err -> throwError $ Parser err
Right val -> return val
spaces :: Parser ()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
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
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
showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal
instance Show LispVal where show = showVal
eval :: LispVal -> ThrowsError LispVal
eval val@(String _) = return val
eval val@(Number _) = return val
eval val@(Bool _) = return val
eval (List [Atom "quote", val]) = return val
eval (List (Atom func : args)) = mapM eval args >>= apply func
eval badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm
apply :: String -> [LispVal] -> ThrowsError LispVal
apply func args = maybe (throwError $ NotFunction "Unrecognized primitive function args" func)
($ args)
(lookup func primitives)
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numericBinop (+)),
("-", numericBinop (-)),
("*", numericBinop (*)),
("/", numericBinop div),
("mod", numericBinop mod),
("quotient", numericBinop quot),
("remainder", numericBinop rem)]
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String n) = let parsed = reads n in
if null parsed
then throwError $ TypeMismatch "number" $ String n
else return $ fst $ parsed !! 0
unpackNum (List [n]) = unpackNum n
unpackNum notNum = throwError $ TypeMismatch "number" notNum
data LispError = NumArgs Integer [LispVal]
| TypeMismatch String LispVal
| Parser ParseError
| BadSpecialForm String LispVal
| NotFunction String String
| UnboundVar String String
| Default String
showError :: LispError -> String
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
showError (NumArgs expected found) = "Expected " ++ show expected
++ " args: found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected
++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr
instance Show LispError where show = showError
instance Error LispError where
noMsg = Default "An error has occurred"
strMsg = Default
type ThrowsError = Either LispError
trapError action = catchError action (return . show)
extractValue :: ThrowsError a -> a
extractValue (Right val) = val
import Control.Monad.Error，使用 Haskell’s built-in error functions 去接管。这个做法跟LispVal相同。- 修改了
main和readExpr的行为让它们可以处理 error。 - 将所有函数的返回值
LispVal改为了ThrowsError LispVal。 - 需要处理的异常：
- binary operator 只接收到了单个参数
unpackNum接收的字符串不是数字unpackNum接收到不能解析的类型
apply本来应该会触发一个参数错误的，但是没有触发，不知道为什么。
Chapter 5. Evaluation, Part 2
operatorparser.hs
module Main where
import Control.Monad
import Control.Monad.Error
import System.Environment
import Numeric (readOct, readHex)
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO()
main = do
args <- getArgs
evaled <- return $ liftM show $ readExpr (args !! 0) >>= eval
putStrLn $ extractValue $ trapError evaled
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
Left err -> throwError $ Parser err
Right val -> return val
spaces :: Parser ()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
| Char Char
parseChar :: Parser LispVal
parseChar = do char '\''
c <- noneOf "'"
char '\''
return $ Char c
parseString :: Parser LispVal
parseString = do char '"'
x <- many chars
char '"'
return $ String x
where chars = escaped <|> noneOf "\""
escaped = char '\\' >> choice (zipWith escapedChar codes replacements)
escapedChar :: Char -> Char -> Parser Char
escapedChar code replacement = char code >> return replacement
codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']
replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']
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
parseDec :: Parser LispVal
parseDec = do n <- many1 digit
return (Number (read n))
parseOct :: Parser LispVal
parseOct = do char '#'
char 'o'
rest <- many1 octDigit
return (Number (fst (readOct rest !! 0)))
parseHex :: Parser LispVal
parseHex = do char '#'
char 'x'
rest <- many1 hexDigit
return (Number (fst (readHex rest !! 0)))
parseNumber :: Parser LispVal
parseNumber = parseDec
<|> try parseOct
<|> try parseHex
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 = try parseChar
<|> parseNumber
<|> parseString
<|> parseAtom
<|> parseQuoted
<|> do char '('
x <- (try parseList) <|> parseDottedList
char ')'
return x
showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal
instance Show LispVal where show = showVal
eval :: LispVal -> ThrowsError LispVal
eval val@(String _) = return val
eval val@(Number _) = return val
eval val@(Bool _) = return val
eval (List [Atom "quote", val]) = return val
eval (List (Atom func : args)) = mapM eval args >>= apply func
eval badForm = throwError $ BadSpecialForm "unrecognized special form" badForm
apply :: String -> [LispVal] -> ThrowsError LispVal
apply func args = maybe (throwError $ NotFunction "Unrecognized primitive function args" func)
($ args)
(lookup func primitives)
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numericBinop (+)),
("-", numericBinop (-)),
("*", numericBinop (*)),
("/", numericBinop div),
("mod", numericBinop mod),
("quotient", numericBinop quot),
("remainder", numericBinop rem),
("=", numBoolBinop (==)),
("<", numBoolBinop (<)),
(">", numBoolBinop (>)),
("/=", numBoolBinop (/=)),
(">=", numBoolBinop (>=)),
("<=", numBoolBinop (<=)),
("&&", boolBoolBinop (&&)),
("||", boolBoolBinop (||)),
("string=?", strBoolBinop (==)),
("string<?", strBoolBinop (<)),
("string>?", strBoolBinop (>)),
("string<=?", strBoolBinop (<=)),
("string>=?", strBoolBinop (>=))]
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args = if length args /= 2
then throwError $ NumArgs 2 args
else do left <- unpacker $ args !! 0
right <- unpacker $ args !! 1
return $ Bool $ left `op` right
numBoolBinop = boolBinop unpackNum
strBoolBinop = boolBinop unpackStr
boolBoolBinop = boolBinop unpackBool
unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String n) = let parsed = reads n in
if null parsed
then throwError $ TypeMismatch "number" $ String n
else return $ fst $ parsed !! 0
unpackNum (List [n]) = unpackNum n
unpackNum notNum = throwError $ TypeMismatch "number" notNum
unpackStr :: LispVal -> ThrowsError String
unpackStr (String s) = return s
unpackStr (Number s) = return $ show s
unpackStr (Bool s) = return $ show s
unpackStr notString = throwError $ TypeMismatch "string" notString
unpackBool :: LispVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
data LispError = NumArgs Integer [LispVal]
| TypeMismatch String LispVal
| Parser ParseError
| BadSpecialForm String LispVal
| NotFunction String String
| UnboundVar String String
| Default String
showError :: LispError -> String
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
showError (NumArgs expected found) = "Expected " ++ show expected ++ " args: found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr
instance Show LispError where show = showError
instance Error LispError where
noMsg = Default "An error has occurred"
strMsg = Default
type ThrowsError = Either LispError
trapError action = catchError action (return . show)
extractValue :: ThrowsError a -> a
extractValue (Right val) = val
没啥东西，加了一些新的返回 Bool 型的 binary operator，比如比较数字，比较字符串，甚至是比较布尔型之类的。
listparser.hs
module Main where
import Control.Monad
import Control.Monad.Error
import System.Environment
import Numeric (readOct, readHex)
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO()
main = do
args <- getArgs
evaled <- return $ liftM show $ readExpr (args !! 0) >>= eval
putStrLn $ extractValue $ trapError evaled
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
Left err -> throwError $ Parser err
Right val -> return val
spaces :: Parser ()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
| Char Char
parseChar :: Parser LispVal
parseChar = do char '\''
c <- noneOf "'"
char '\''
return $ Char c
parseString :: Parser LispVal
parseString = do char '"'
x <- many chars
char '"'
return $ String x
where chars = escaped <|> noneOf "\""
escaped = char '\\' >> choice (zipWith escapedChar codes replacements)
escapedChar :: Char -> Char -> Parser Char
escapedChar code replacement = char code >> return replacement
codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']
replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']
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
parseDec :: Parser LispVal
parseDec = do n <- many1 digit
return (Number (read n))
parseOct :: Parser LispVal
parseOct = do char '#'
char 'o'
rest <- many1 octDigit
return (Number (fst (readOct rest !! 0)))
parseHex :: Parser LispVal
parseHex = do char '#'
char 'x'
rest <- many1 hexDigit
return (Number (fst (readHex rest !! 0)))
parseNumber :: Parser LispVal
parseNumber = parseDec
<|> try parseOct
<|> try parseHex
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 = try parseChar
<|> parseNumber
<|> parseString
<|> parseAtom
<|> parseQuoted
<|> do char '('
x <- (try parseList) <|> parseDottedList
char ')'
return x
showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal
instance Show LispVal where show = showVal
eval :: LispVal -> ThrowsError LispVal
eval val@(String _) = return val
eval val@(Number _) = return val
eval val@(Bool _) = return val
eval (List [Atom "if", pred, conseq, alt]) =
do return <- eval pred
case return of
Bool False -> eval alt
otherwise -> eval conseq
eval (List [Atom "quote", val]) = return val
eval (List (Atom func : args)) = mapM eval args >>= apply func
eval badForm = throwError $ BadSpecialForm "unrecognized special form" badForm
apply :: String -> [LispVal] -> ThrowsError LispVal
apply func args = maybe (throwError $ NotFunction "Unrecognized primitive function args" func)
($ args)
(lookup func primitives)
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numericBinop (+)),
("-", numericBinop (-)),
("*", numericBinop (*)),
("/", numericBinop div),
("mod", numericBinop mod),
("quotient", numericBinop quot),
("remainder", numericBinop rem),
("=", numBoolBinop (==)),
("<", numBoolBinop (<)),
(">", numBoolBinop (>)),
("/=", numBoolBinop (/=)),
(">=", numBoolBinop (>=)),
("<=", numBoolBinop (<=)),
("&&", boolBoolBinop (&&)),
("||", boolBoolBinop (||)),
("string=?", strBoolBinop (==)),
("string<?", strBoolBinop (<)),
("string>?", strBoolBinop (>)),
("string<=?", strBoolBinop (<=)),
("string>=?", strBoolBinop (>=)),
("car", car),
("cdr", cdr),
("cons", cons),
("eq?", eqv),
("eqv?", eqv)]
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args = if length args /= 2
then throwError $ NumArgs 2 args
else do left <- unpacker $ args !! 0
right <- unpacker $ args !! 1
return $ Bool $ left `op` right
numBoolBinop = boolBinop unpackNum
strBoolBinop = boolBinop unpackStr
boolBoolBinop = boolBinop unpackBool
unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String n) = let parsed = reads n in
if null parsed
then throwError $ TypeMismatch "number" $ String n
else return $ fst $ parsed !! 0
unpackNum (List [n]) = unpackNum n
unpackNum notNum = throwError $ TypeMismatch "number" notNum
unpackStr :: LispVal -> ThrowsError String
unpackStr (String s) = return s
unpackStr (Number s) = return $ show s
unpackStr (Bool s) = return $ show s
unpackStr notString = throwError $ TypeMismatch "string" notString
unpackBool :: LispVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
car :: [LispVal] -> ThrowsError LispVal
car [List (x : xs)] = return x
car [DottedList (x : xs) _] = return x
car [badArg] = throwError $ TypeMismatch "pair" badArg
car badArgList = throwError $ NumArgs 1 badArgList
cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (x : xs)] = return $ List xs
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [DottedList [xs] x] = return x
cdr [badArg] = throwError $ TypeMismatch "pair" badArg
cdr badArgList = throwError $ NumArgs 1 badArgList
cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []] = return $ List [x1]
cons [x, List xs] = return $ List $ [x] ++ xs
cons [x, DottedList xs xlast] = return $ DottedList ([x] ++ xs) xlast
cons [x1, x2] = return $ DottedList [x1] x2
cons badArgList = throwError $ NumArgs 2 badArgList
eqv :: [LispVal] -> ThrowsError LispVal
eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) &&
(and $ map eqvPair $ zip arg1 arg2)
where eqvPair (x1, x2) = case eqv [x1, x2] of
Left err -> False
Right (Bool val) -> val
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList
data LispError = NumArgs Integer [LispVal]
| TypeMismatch String LispVal
| Parser ParseError
| BadSpecialForm String LispVal
| NotFunction String String
| UnboundVar String String
| Default String
showError :: LispError -> String
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
showError (NumArgs expected found) = "Expected " ++ show expected ++ " args: found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr
instance Show LispError where show = showError
instance Error LispError where
noMsg = Default "An error has occurred"
strMsg = Default
type ThrowsError = Either LispError
trapError action = catchError action (return . show)
extractValue :: ThrowsError a -> a
extractValue (Right val) = val
添加了 car、cdr、cons、eq?、eqv? 的支持。
equalparser.hs
module Main where
import Control.Monad
import System.Environment
import Control.Monad.Error
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO ()
main = do
args <- getArgs
evaled <- return $ liftM show $ readExpr (args !! 0) >>= eval
putStrLn $ extractValue $ trapError evaled
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
Left err -> throwError $ Parser err
Right val -> return val
spaces :: Parser ()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
parseString :: Parser LispVal
parseString = do char ;\textcolor{string}{\texttt{'"'}};
x <- many (noneOf "\"")
char ;\textcolor{string}{\texttt{'"'}};
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
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
showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal
instance Show LispVal where show = showVal
eval :: LispVal -> ThrowsError LispVal
eval val@(String _) = return val
eval val@(Number _) = return val
eval val@(Bool _) = return val
eval (List [Atom "quote", val]) = return val
eval (List [Atom "if", pred, conseq, alt]) =
do result <- eval pred
case result of
Bool False -> eval alt
otherwise -> eval conseq
eval (List (Atom func : args)) = mapM eval args >>= apply func
eval badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm
apply :: String -> [LispVal] -> ThrowsError LispVal
apply func args = maybe (throwError $ NotFunction "Unrecognized primitive function args" func)
($ args)
(lookup func primitives)
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numericBinop (+)),
("-", numericBinop (-)),
("*", numericBinop (*)),
("/", numericBinop div),
("mod", numericBinop mod),
("quotient", numericBinop quot),
("remainder", numericBinop rem),
("=", numBoolBinop (==)),
("<", numBoolBinop (<)),
(">", numBoolBinop (>)),
("/=", numBoolBinop (/=)),
(">=", numBoolBinop (>=)),
("<=", numBoolBinop (<=)),
("&&", boolBoolBinop (&&)),
("||", boolBoolBinop (||)),
("string=?", strBoolBinop (==)),
("string?", strBoolBinop (>)),
("string<=?", strBoolBinop (<=)),
("string>=?", strBoolBinop (>=)),
("car", car),
("cdr", cdr),
("cons", cons),
("eq?", eqv),
("eqv?", eqv),
("equal?", equal)]
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args = if length args /= 2
then throwError $ NumArgs 2 args
else do left <- unpacker $ args !! 0
right <- unpacker $ args !! 1
return $ Bool $ left `op` right
numBoolBinop = boolBinop unpackNum
strBoolBinop = boolBinop unpackStr
boolBoolBinop = boolBinop unpackBool
unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String n) = let parsed = reads n in
if null parsed
then throwError $ TypeMismatch "number" $ String n
else return $ fst $ parsed !! 0
unpackNum (List [n]) = unpackNum n
unpackNum notNum = throwError $ TypeMismatch "number" notNum
unpackStr :: LispVal -> ThrowsError String
unpackStr (String s) = return s
unpackStr (Number s) = return $ show s
unpackStr (Bool s) = return $ show s
unpackStr notString = throwError $ TypeMismatch "string" notString
unpackBool :: LispVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
car :: [LispVal] -> ThrowsError LispVal
car [List (x : xs)] = return x
car [DottedList (x : xs) _] = return x
car [badArg] = throwError $ TypeMismatch "pair" badArg
car badArgList = throwError $ NumArgs 1 badArgList
cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (x : xs)] = return $ List xs
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [DottedList [xs] x] = return x
cdr [badArg] = throwError $ TypeMismatch "pair" badArg
cdr badArgList = throwError $ NumArgs 1 badArgList
cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []] = return $ List [x1]
cons [x, List xs] = return $ List $ [x] ++ xs
cons [x, DottedList xs xlast] = return $ DottedList ([x] ++ xs) xlast
cons [x1, x2] = return $ DottedList [x1] x2
cons badArgList = throwError $ NumArgs 2 badArgList
eqv :: [LispVal] -> ThrowsError LispVal
eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) &&
(and $ map eqvPair $ zip arg1 arg2)
where eqvPair (x1, x2) = case eqv [x1, x2] of
Left err -> False
Right (Bool val) -> val
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList
data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals arg1 arg2 (AnyUnpacker unpacker) =
do unpacked1 <- unpacker arg1
unpacked2 <- unpacker arg2
return $ unpacked1 == unpacked2
`catchError` (const $ return False)
equal :: [LispVal] -> ThrowsError LispVal
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
data LispError = NumArgs Integer [LispVal]
| TypeMismatch String LispVal
| Parser ParseError
| BadSpecialForm String LispVal
| NotFunction String String
| UnboundVar String String
| Default String
showError :: LispError -> String
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
showError (NumArgs expected found) = "Expected " ++ show expected
++ " args: found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected
++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr
instance Show LispError where show = showError
instance Error LispError where
noMsg = Default "An error has occurred"
strMsg = Default
type ThrowsError = Either LispError
trapError action = catchError action (return . show)
extractValue :: ThrowsError a -> a
extractValue (Right val) = val
这段是使用 Haskell 的库实现弱类型判断，单纯复制了，没有学习。
编译时需要加 −fglasgow−exts。
Chapter 6. Building a REPL: Basic I/O
REPL 是 read-eval-print loop。
replparser.hs
module Main where
import Control.Monad
import Control.Monad.Error
import System.Environment
import Numeric (readOct, readHex)
import Text.ParserCombinators.Parsec hiding (spaces)
main :: IO ()
main = do args <- getArgs
case length args of
0 -> runRepl
1 -> evalAndPrint $ args !! 0
otherwise -> putStrLn "Program takes only 0 or 1 argument"
symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
Left err -> throwError $ Parser err
Right val -> return val
spaces :: Parser ()
spaces = skipMany1 space
data LispVal = Atom String
| List [LispVal]
| DottedList [LispVal] LispVal
| Number Integer
| String String
| Bool Bool
| Char Char
parseChar :: Parser LispVal
parseChar = do char '\''
c <- noneOf "'"
char '\''
return $ Char c
parseString :: Parser LispVal
parseString = do char '"'
x <- many chars
char '"'
return $ String x
where chars = escaped <|> noneOf "\""
escaped = char '\\' >> choice (zipWith escapedChar codes replacements)
escapedChar :: Char -> Char -> Parser Char
escapedChar code replacement = char code >> return replacement
codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']
replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']
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
parseDec :: Parser LispVal
parseDec = do n <- many1 digit
return (Number (read n))
parseOct :: Parser LispVal
parseOct = do char '#'
char 'o'
rest <- many1 octDigit
return (Number (fst (readOct rest !! 0)))
parseHex :: Parser LispVal
parseHex = do char '#'
char 'x'
rest <- many1 hexDigit
return (Number (fst (readHex rest !! 0)))
parseNumber :: Parser LispVal
parseNumber = parseDec
<|> try parseOct
<|> try parseHex
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 = try parseChar
<|> parseNumber
<|> parseString
<|> parseAtom
<|> parseQuoted
<|> do char '('
x <- (try parseList) <|> parseDottedList
char ')'
return x
showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal
instance Show LispVal where show = showVal
eval :: LispVal -> ThrowsError LispVal
eval val@(String _) = return val
eval val@(Number _) = return val
eval val@(Bool _) = return val
eval (List [Atom "if", pred, conseq, alt]) =
do return <- eval pred
case return of
Bool False -> eval alt
otherwise -> eval conseq
eval (List [Atom "quote", val]) = return val
eval (List (Atom func : args)) = mapM eval args >>= apply func
eval badForm = throwError $ BadSpecialForm "unrecognized special form" badForm
apply :: String -> [LispVal] -> ThrowsError LispVal
apply func args = maybe (throwError $ NotFunction "Unrecognized primitive function args" func)
($ args)
(lookup func primitives)
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numericBinop (+)),
("-", numericBinop (-)),
("*", numericBinop (*)),
("/", numericBinop div),
("mod", numericBinop mod),
("quotient", numericBinop quot),
("remainder", numericBinop rem),
("=", numBoolBinop (==)),
("<", numBoolBinop (<)),
(">", numBoolBinop (>)),
("/=", numBoolBinop (/=)),
(">=", numBoolBinop (>=)),
("<=", numBoolBinop (<=)),
("&&", boolBoolBinop (&&)),
("||", boolBoolBinop (||)),
("string=?", strBoolBinop (==)),
("string<?", strBoolBinop (<)),
("string>?", strBoolBinop (>)),
("string<=?", strBoolBinop (<=)),
("string>=?", strBoolBinop (>=)),
("car", car),
("cdr", cdr),
("cons", cons),
("eq?", eqv),
("eqv?", eqv)]
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args = if length args /= 2
then throwError $ NumArgs 2 args
else do left <- unpacker $ args !! 0
right <- unpacker $ args !! 1
return $ Bool $ left `op` right
numBoolBinop = boolBinop unpackNum
strBoolBinop = boolBinop unpackStr
boolBoolBinop = boolBinop unpackBool
unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String n) = let parsed = reads n in
if null parsed
then throwError $ TypeMismatch "number" $ String n
else return $ fst $ parsed !! 0
unpackNum (List [n]) = unpackNum n
unpackNum notNum = throwError $ TypeMismatch "number" notNum
unpackStr :: LispVal -> ThrowsError String
unpackStr (String s) = return s
unpackStr (Number s) = return $ show s
unpackStr (Bool s) = return $ show s
unpackStr notString = throwError $ TypeMismatch "string" notString
unpackBool :: LispVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
car :: [LispVal] -> ThrowsError LispVal
car [List (x : xs)] = return x
car [DottedList (x : xs) _] = return x
car [badArg] = throwError $ TypeMismatch "pair" badArg
car badArgList = throwError $ NumArgs 1 badArgList
cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (x : xs)] = return $ List xs
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [DottedList [xs] x] = return x
cdr [badArg] = throwError $ TypeMismatch "pair" badArg
cdr badArgList = throwError $ NumArgs 1 badArgList
cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []] = return $ List [x1]
cons [x, List xs] = return $ List $ [x] ++ xs
cons [x, DottedList xs xlast] = return $ DottedList ([x] ++ xs) xlast
cons [x1, x2] = return $ DottedList [x1] x2
cons badArgList = throwError $ NumArgs 2 badArgList
eqv :: [LispVal] -> ThrowsError LispVal
eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) &&
(and $ map eqvPair $ zip arg1 arg2)
where eqvPair (x1, x2) = case eqv [x1, x2] of
Left err -> False
Right (Bool val) -> val
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList
data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals arg1 arg2 (AnyUnpacker unpacker) =
do unpacked1 <- unpacker arg1
unpacked2 <- unpacker arg2
return $ unpacked1 == unpacked2
`catchError` (const $ return False)
equal :: [LispVal] -> ThrowsError LispVal
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
data LispError = NumArgs Integer [LispVal]
| TypeMismatch String LispVal
| Parser ParseError
| BadSpecialForm String LispVal
| NotFunction String String
| UnboundVar String String
| Default String
showError :: LispError -> String
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
showError (NumArgs expected found) = "Expected " ++ show expected ++ " args: found values " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr
instance Show LispError where show = showError
instance Error LispError where
noMsg = Default "An error has occurred"
strMsg = Default
type ThrowsError = Either LispError
trapError action = catchError action (return . show)
extractValue :: ThrowsError a -> a
extractValue (Right val) = val
这个代码运行不起来，接下来的代码就不运行了，转 C++ 了。