cherry-lisp.cabal

@@ -22,7 +22,8 @@ executable cherry
                        Parser,
                        TokenType,
                        Lexer,
-                       Evaluator
+                       Evaluator,
+                       ParserUtils
 
   build-depends:       base >= 4.7 && < 5,
                        containers,

src/Evaluator.hs

@@ -14,11 +14,10 @@ base = M.fromList [
   ]
 
 eval :: Env -> Expr -> (Env, Expr)
-eval env i@(IntE x)      = (env, i)
+eval env (IntE x)      = (env, IntE x)
 eval env (VarE v)      = (M.insert v nExpr nEnv, nExpr)
   where (nEnv, nExpr) = eval env $ env M.! v
 eval env (SetE v expr) = (M.insert v expr env, NilE)
-eval env c@(ConsE _ _) = (env, c)
 eval env NilE          = (env, NilE)
 
 --apply :: Proc -> Args -> Expr

src/ExprType.hs

@@ -4,7 +4,6 @@ data Expr = IntE Integer
           | VarE String
           | ProcedureE String [Expr]
           | SetE String Expr
-          | ConsE Expr Expr
           | NilE deriving (Show)
 
 -- instance Show Expr where

src/Lexer.hs

@@ -1,6 +1,7 @@
 module Lexer where
 
 import Text.ParserCombinators.Parsec
+import ParserUtils
 import Data.Char
 import TokenType
 
@@ -12,7 +13,7 @@ parseTokens = do
     return tokns
 
 anyLispToken :: GenParser Char st Token
-anyLispToken = leftParenT <|> rightParenT <|> symbolT <|> intT
+anyLispToken = leftParenT <|> rightParenT <|> try nilT <|> try setT <|> varT <|> intT
 
 ------------------------------------------------------------
 
@@ -27,7 +28,13 @@ leftParenT = char '(' >> return LeftParenT
 rightParenT :: GenParser Char st Token
 rightParenT = char ')' >> return RightParenT
 
-symbolT :: GenParser Char st Token
-symbolT = do
-    var <- map toLower <$> many1 (letter <|> oneOf "+-*/\\!|@#$~%&/=<>")
-    return $ SymbolT var
+setT :: GenParser Char st Token
+setT = caseInsensitiveString "set!" >> return SetT
+
+nilT :: GenParser Char st Token
+nilT = caseInsensitiveString "nil" >> return NilT
+
+varT :: GenParser Char st Token
+varT = do
+    var <- map toLower <$> many1 (letter <|> oneOf "+-*/!|@#$~%&/=<>")
+    return $ VarT var

src/Parser.hs

@@ -20,7 +20,7 @@ expressionFromTokensEOF = do
 
 expressionFromTokens :: GenParser Token st Expr
 expressionFromTokens = do
-  expr <- intE <|> try setE <|> try nilE <|> try consE <|> varE <|> procedureE
+  expr <- intE <|> try defineE <|> try nilE <|> varE <|> procedureE
   return expr
 
 intE :: GenParser Token st Expr
@@ -31,23 +31,14 @@ intE = do
 procedureE :: GenParser Token st Expr
 procedureE = do
   _ <- parseLeftParenT
-  (SymbolT p) <- parseSymbolT
+  (VarT p) <- parseVarT
   args <- many expressionFromTokens
   _ <- parseRightParenT
   return $ ProcedureE p args
 
-consE :: GenParser Token st Expr
-consE = do
-  _ <- parseLeftParenT
-  _ <- parseConsT
-  expr1 <- expressionFromTokens
-  expr2 <- expressionFromTokens
-  _ <- parseRightParenT
-  return $ ConsE expr1 expr2
-
 varE :: GenParser Token st Expr
 varE = do
-  (SymbolT var) <- parseSymbolT
+  (VarT var) <- parseVarT
   return $ VarE var
 
 nilE :: GenParser Token st Expr
@@ -55,11 +46,11 @@ nilE = do
   _ <- parseNilT
   return NilE
 
-setE :: GenParser Token st Expr
-setE = do
+defineE :: GenParser Token st Expr
+defineE = do
   _ <- parseLeftParenT
   _ <- parseSetT
-  (SymbolT var) <- parseSymbolT
+  (VarT var) <- parseVarT
   expr <- expressionFromTokens
   _ <- parseRightParenT
   return $ SetE var expr
@@ -78,24 +69,15 @@ parseRightParenT :: GenParser Token st Token
 parseRightParenT = satisfyT (== RightParenT)
 
 parseSetT :: GenParser Token st Token
-parseSetT = satisfyT isSetT
-  where isSetT (SymbolT "set!") = True
-        isSetT _               = False
+parseSetT = satisfyT (== SetT)
 
 parseNilT :: GenParser Token st Token
-parseNilT = satisfyT isNilT
-  where isNilT (SymbolT "nil") = True
-        isNilT _               = False
+parseNilT = satisfyT (== NilT)
 
-parseConsT :: GenParser Token st Token
-parseConsT = satisfyT isConsT
-  where isConsT (SymbolT "cons") = True
-        isConsT _               = False
-
-parseSymbolT :: GenParser Token st Token
-parseSymbolT = satisfyT isSymbolT
-  where isSymbolT (SymbolT _) = True
-        isSymbolT _        = False
+parseVarT :: GenParser Token st Token
+parseVarT = satisfyT isVarT
+  where isVarT (VarT _) = True
+        isVarT _        = False
 
 parseIntT :: GenParser Token st Token
 parseIntT = satisfyT isIntT

src/ParserUtils.hs

@@ -1,4 +1,3 @@
--- UNUSED
 module ParserUtils where
 
 import Text.ParserCombinators.Parsec

src/TokenType.hs

@@ -2,6 +2,8 @@ module TokenType where
 
 data Token = LeftParenT
            | RightParenT
-           | SymbolT String
+           | SetT
+           | VarT String
            | IntT Integer
+           | NilT
            deriving (Show, Eq)