Skip to content

Instantly share code, notes, and snippets.

@amitdev
Created January 14, 2012 10:00
Show Gist options
  • Save amitdev/1610871 to your computer and use it in GitHub Desktop.
Save amitdev/1610871 to your computer and use it in GitHub Desktop.
A mini Scheme parser in Haskell (Just for fun)
import Text.ParserCombinators.Parsec
import Monad
data Exp = IntExp Integer
| SymExp String
| SExp [Exp]
deriving (Show)
data Val = IntVal Integer
| SymVal String
| PrimVal ([Val] -> Val)
| Closure [String] Exp [(String,Val)]
| DefVal String Val
| Macro [String] Exp [(String,Val)]
| Cons Val Val
run x = parseTest x
adigit = oneOf ['0'..'9']
digits = many1 adigit
symchars = oneOf "-*+/:'?><="
whitespace = skipMany1 space
anInt = do d <- digits
return $ IntExp (read d)
anAtom = anInt
aSymbol = do start <- symchars <|> letter
other <- many (symchars <|> letter <|> digit)
return $ SymExp (start : other)
aList = do char '('
skipMany space
res <- sepBy anExp whitespace
char ')'
return (SExp res)
quote c qtype = do char c
val <- anExp
return (SExp [SymExp qtype, val])
anExp = anAtom <|> aList <|> quote ',' "unquote" <|> quote '`' "quasiquote" <|> quote '\'' "quote" <|> aSymbol
--Util Functions
liftIntOp f a x = IntVal $ foldr f a $ map (\ (IntVal y) -> y) x
myfold f [] = True
myfold f (x:y:ys) = case ys of
[] -> f x y
_ -> f x y && myfold f (y:ys)
toBool (SymVal "t") = True
toBool (SymVal "nil") = False
liftBool True = (SymVal "t")
liftBool False = (SymVal "nil")
liftCompOp f x = liftBool (myfold f $ map (\ (IntVal y) -> y) x)
liftBoolOp f x = liftBool (foldr1 f $ map toBool x)
liftBoolUnaryOp f (x:[]) = liftBool $ f $ toBool x
liftBasicEqOp ((IntVal x):(IntVal y):[]) = liftBool $ x == y
liftBasicEqOp ((SymVal x):(SymVal y):[]) = liftBool $ x == y
liftBasicEqOp x = SymVal "nil"
liftEqOp ((Cons x1 y1):(Cons x2 y2):[]) | toBool $ liftEqOp (x1:x2:[]) = liftEqOp (y1:y2:[])
| otherwise = SymVal "nil"
liftEqOp x = liftBasicEqOp x
liftList (x:xs) = Cons x (liftList xs)
liftList [] = SymVal "nil"
toList (SymVal "nil") = []
toList (Cons x y) = x : toList y
apply fun args env = case lookup fun env of
Just (PrimVal fn) -> fn args
Just (Closure cargs exp cenv) -> eval exp (zip cargs args ++ cenv)
Nothing -> error ("Function " ++ fun ++ " not defined.")
quotify (IntExp i) = IntVal i
quotify (SymExp s) = SymVal s
quotify (SExp []) = SymVal "nil"
quotify (SExp (x:xs)) = Cons (quotify x) (quotify (SExp xs))
unquote (IntVal i) = IntExp i
unquote (SymVal "nil") = SExp []
unquote (SymVal s) = SymExp s
unquote (Cons a b) = SExp $ map unquote $ toList (Cons a b)
quasiquotify (SExp ((SExp ((SymExp "unquote"):x:[])):xs)) env = Cons (eval x env) (quasiquotify (SExp xs) env)
quasiquotify (SExp ((SymExp "unquote"):x:[])) env = eval x env
quasiquotify (SExp (x:xs)) env = Cons (quasiquotify x env) (quasiquotify (SExp xs) env)
quasiquotify x env = quotify x
evalfn (Closure cargs exp cenv) args env = eval exp (zip cargs (map (\a -> eval a env) args) ++ cenv)
-- Evaluator
runtime = [("+", PrimVal $ liftIntOp (+) 0),
("*", PrimVal $ liftIntOp (*) 1),
("-", PrimVal $ liftIntOp (-) 0),
(">", PrimVal $ liftCompOp (>)),
("<", PrimVal $ liftCompOp (<)),
("and", PrimVal $ liftBoolOp (&&)),
("or", PrimVal $ liftBoolOp (||)),
("not", PrimVal $ liftBoolUnaryOp not),
("eq?", PrimVal $ liftBasicEqOp),
("=", PrimVal $ liftEqOp),
("car", PrimVal $ (\ ((Cons x y):[]) -> x)),
("cdr", PrimVal $ (\ ((Cons x y):[]) -> y)),
("list", PrimVal $ liftList)]
eval (IntExp i) env = IntVal i
eval (SymExp s) env = case lookup s env of
Just x -> x
Nothing -> error ("Symbol " ++ s ++ " has no value.")
eval (SExp []) env = SymVal "nil"
eval (SExp ((SymExp "define"):(SymExp fn):(SExp args):body:[])) env = DefVal fn closure
where closure = (Closure (map (\(SymExp x) -> x) args) body nenv)
nenv = (fn, closure) : env
eval (SExp ((SymExp "defmacro"):(SymExp name):(SExp args):body:[])) env = DefVal name closure
where closure = (Macro (map (\(SymExp x) -> x) args) body env)
eval (SExp ((SymExp "lambda"):(SExp args):body:[])) env = Closure (map (\(SymExp x) -> x) args) body env
eval (SExp ((SymExp "def"):(SymExp var):body:[])) env = DefVal var (eval body env)
eval (SExp ((SymExp "quote"):body:[])) env = quotify body
eval (SExp ((SymExp "quasiquote"):body:[])) env = quasiquotify body env
eval (SExp ((SymExp "cond"):(SExp body):[])) env = evalcond body
where evalcond (a:b:rest) = case eval a env of
SymVal "nil" -> evalcond rest
_ -> eval b env
evalcond [] = SymVal "nil"
eval (SExp ((SymExp "let"):(SExp body):exp:[])) env = eval exp (letenv ++ env)
where letenv = map (\[(SymExp s),e] -> (s, eval e env)) defns
defns = map (\ (SExp x) -> x) body
eval (SExp ((SymExp "cons"):head:tail:[])) env = Cons (eval head env) (eval tail env)
eval (SExp ((SymExp "apply"):(SymExp fn):lst:[])) env = apply fn (toList (eval lst env)) env
eval (SExp ((SymExp "eval"):quoted:[])) env = eval (unquote $ eval quoted env) env
eval (SExp ((SymExp fn):args)) env = case lookup fn env of
Just (Macro cargs exp cenv) -> eval (unquote $ eval exp (zip cargs (toList $ quasiquotify (SExp args) env) ++ env)) env
Just x -> apply fn (map (\a -> eval a env) args) env
Nothing -> error ("Function " ++ fn ++ " not defined.")
eval (SExp (s:args)) env = evalfn (eval s env) args env
-- Printer
instance Show Val where
show (IntVal i) = show i
show (SymVal s) = s
show (Cons a b) = "(" ++ aux a b ++ ")"
where aux x (Cons y z) = show x ++ " " ++ aux y z
aux x (SymVal "nil") = show x
aux x y = show x ++ " . " ++ show y
show (DefVal s _) = s
show (Closure _ _ _) = "*closure*"
show (Macro a b _) = "Macro " ++ (show a) ++ " " ++ (show b)
repl defs =
do putStr "> "
l <- getLine
case parse anExp "Expression" l of
Right exp -> putStr (show x) >> putStrLn "" >> repl (modify x)
where x = (eval exp defs)
modify (DefVal s v) = (s, v) : defs
modify _ = defs
Left pe -> putStr (show pe) >> putStrLn "" >> repl defs
main = repl runtime
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment