在Haskell中实现一个简单的解释器

以下是一个简单的Haskell解释器的实现，其中包括一个整数运算的解析器和一个将解析后的表达式求值的函数。使用例子展示了如何使用解释器来计算简单的表达式。

import Text.ParserCombinators.Parsec hiding (spaces)
import Control.Monad
import Control.Monad.Except

data LispVal = Atom String
             | List [LispVal]
             | DottedList [LispVal] LispVal
             | Number Integer
             | String String
             | Bool Bool

parseExpr :: Parser LispVal
parseExpr = parseAtom
          <|> parseString
          <|> parseNumber
          <|> parseQuoted
          <|> do char '('
                 x <- try parseList <|> parseDottedList
                 char ')'
                 return 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
                          _    -> Atom atom

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

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]

spaces :: Parser ()
spaces = skipMany1 space

readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
  Left err -> throwError $ Parser err
  Right val -> return val

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)) = apply func =<< mapM eval args

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 []  = throwError $ NumArgs 2 []
numericBinop op oneVal@[_] = throwError $ NumArgs 2 oneVal
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

instance Show LispVal where show = showVal

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

data LispError = Parser ParseError
               | NumArgs Integer [LispVal]
               | TypeMismatch String LispVal
               | NotFunction String String
               | UnboundVar String String
               | Default String

instance Show LispError where show = showError

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

type ThrowsError = Either LispError

-- Usage example
main :: IO ()
main = do
  putStrLn "Lisp>>> (+ 2 3)"
  putStrLn $ show $ evalString "(+ 2 3)"
  putStrLn "Lisp>>> (- 10 4)"
  putStrLn $ show $ evalString "(- 10 4)"
  putStrLn "Lisp>>> (* 3 5)"
  putStrLn $ show $ evalString "(* 3 5)"
  putStrLn "Lisp>>> (/ 6 2)"
  putStrLn $ show $ evalString "(/ 6 2)"
  putStrLn "Lisp>>> (mod 7 3)"
  putStrLn $ show $ evalString "(mod 7 3)"
  putStrLn "Lisp>>> (quotient 10 3)"
  putStrLn $ show $ evalString "(quotient 10 3)"
  putStrLn "Lisp>>> (remainder 10 3)"
  putStrLn $ show $ evalString "(remainder 10 3)"

evalString :: String -> ThrowsError LispVal
evalString expr = readExpr expr >>= eval

上面的解释器实现了一个简单的Lisp解释器，它可以解析并计算整数运算表达式。

使用例子展示了如何使用解释器来计算简单的表达式：

main :: IO ()
main = do
  putStrLn "Lisp>>> (+ 2 3)"
  putStrLn $ show $ evalString "(+ 2 3)"
  putStrLn "Lisp>>> (- 10 4)"
  putStrLn $ show $ evalString "(- 10 4)"
  putStrLn "Lisp>>> (* 3 5)"
  putStrLn $ show $ evalString "(* 3 5)"
  putStrLn "Lisp>>> (/ 6 2)"
  putStrLn $ show $ evalString "(/ 6 2)"
  putStrLn "Lisp>>> (mod 7 3)"
  putStrLn $ show $ evalString "(mod 7 3)"
  putStrLn "Lisp>>> (quotient 10 3)"
  putStrLn $ show $ evalString "(quotient 10 3)"
  putStrLn "Lisp>>> (remainder 10 3)"
  putStrLn $ show $ evalString "(remainder 10 3)"

上面的例子将使用解释器分别计算"+"、"-"、"*"、"/"、"mod"、"quotient"和"remainder"运算符的结果，并将结果输出到控制台。

请注意，上述实现提供了一些基本的错误处理，例如未定义的变量、错误的函数应用、不正确的参数数量等。可以根据需要进行扩展。