evaluator3

ch3/Makefile

@@ -2,4 +2,4 @@
 	ghc --make -o $@ $<
 	hlint $<
 
-ALL: evaluator1.exe evaluator2.exe
+ALL: evaluator1.exe evaluator2.exe evaluator3.exe

ch3/evaluator3.hs

@@ -0,0 +1,118 @@
+import Text.ParserCombinators.Parsec hiding (spaces)
+import System.Environment (getArgs)
+import Control.Monad (liftM)
+
+data LispVal = Atom String
+             | List [LispVal]
+             | DottedList [LispVal] LispVal
+             | Number Integer
+             | String String
+             | Bool Bool
+
+instance Show LispVal where
+  show = showVal where
+    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
+
+parseExpr :: Parser LispVal
+parseExpr = parseAtom
+        <|> parseString
+        <|> parseNumber
+        <|> parseQuoted
+        <|> do char '('
+               x <- try parseList <|> parseDottedList
+               char ')'
+               return x
+  where
+
+    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]
+
+    symbol :: Parser Char
+    symbol = oneOf "!$%$}*+-/:<=?>@^_~#"
+
+    spaces :: Parser ()
+    spaces = skipMany1 space
+
+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
+  where
+    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 $ head parsed
+    unpackNum (List [n]) = unpackNum n
+    unpackNum _ = 0
+
+readExpr :: String -> LispVal
+readExpr input = case parse parseExpr "lisp" input of
+    Left err -> String $ "No match: " ++ show err
+    Right val -> val
+
+main :: IO ()
+main =
+    getArgs >>= print . eval . readExpr . head