Scheme Interpreter in Haskell

scheme.hs

import Text.ParserCombinators.Parsec
import Text.Parsec.Char
import Data.List.Split (chunksOf)

data Exp = IntExp Integer
         | SymExp String
         | SExp [Exp]
         deriving (Show)

data Val = IntVal Integer
         | SymVal String
         | PrimVal ([Val] -> [(String, Val)] -> Val)
         | DefVal String Val
         | ExceptionVal String
         | TrueVal
         | NilVal
         | ConsVal [Val]
         | MacroVal ([Exp] -> [(String, Val)] -> Exp)

instance Eq Val where
  (IntVal i) == (IntVal j) = i == j
  (SymVal s) == (SymVal t) = s == t
  TrueVal    == TrueVal    = True
  NilVal     == NilVal     = True
  _ == _ = False

run x = parseTest x

-- Lexicals

adigit = oneOf ['0'..'9']
digits = many1 adigit

identifierCharacters = oneOf $  ['-', '*', '+', '/', ':', '?', '>', '<', '='] ++ ['a'..'z'] ++ ['A'..'Z']

leftParen = char '('
rightParen = char ')'

-- Grammaticals
anInt = do d <- digits <?> "a number"
           return $ IntExp (read d)

aVar  = do f <- identifierCharacters <?> "a variable"
           r <- many (identifierCharacters <|> adigit) <?> "a variable"
           return $ (SymExp (f:r))

aSExp = do exp <- between leftParen rightParen (many1 anExp) <?> "a sexp"
           return $ (SExp exp)

anAtom = anInt
     <|> aVar

expStartingWith c clazz = do char c
                             exp <- anExpWithNoWhitespace
                             return $ SExp [SymExp clazz, exp]
quotedExp = expStartingWith '\'' "quote"
quaziQuotedExp = expStartingWith '`' "quaziquote"
unquotedExp = expStartingWith ',' "unquote"

anExpWithNoWhitespace = anAtom
                    <|> aSExp
                    <|> quotedExp
                    <|> quaziQuotedExp
                    <|> unquotedExp

anExp = anExpWithNoWhitespace
    <|> do { many1 space; anExpWithNoWhitespace }

-- Evaluator

eval :: Exp -> [(String,Val)] -> Val
eval (IntExp i) env = IntVal i

eval (SymExp i) ((k,v):xs) = if i == k then v else eval (SymExp i) xs
eval (SymExp i) []         = error $ "Symbol " ++ i ++ " has no value"

eval (SExp [SymExp "def", SymExp name, value]) env = DefVal name (eval value env)

eval (SExp [SymExp "define", SymExp name, SExp vars, body]) env = DefVal name (PrimVal $ dynamicFunction vars body)

eval (SExp [SymExp "defmacro", SymExp name, SExp args, body]) env = DefVal name (MacroVal $ dynamicMacro args body)

eval (SExp [SymExp "lambda", SExp vars, body]) env = PrimVal $ dynamicLambda vars body env

eval (SExp ((SymExp "or"):terms)) env = firstNonNil terms env

eval (SExp ((SymExp "and"):terms)) env = firstNil terms env

eval (SExp [SymExp "cond", SExp terms]) env = doCond (chunksOf 2 terms) env

eval (SExp [SymExp "let", SExp terms, body]) env = doLet terms body env

eval (SExp [SymExp "quote", body]) env = quotify body

eval (SExp [SymExp "quaziquote", body]) env = quaziQuotify body env

eval (SExp (f:v)) env =
  let toExecute = eval f env
  in case toExecute of
    PrimVal function -> function values env
      where values = map (\x -> eval x env) v
    MacroVal macro   -> eval (macro v env) env


-- Functions
foldOverInts operator ((IntVal f):vals) env = IntVal $ foldl (\acc (IntVal x) -> (operator acc x)) f vals

functionAdd = foldOverInts (+)
functionSub = foldOverInts (-)
functionMul = foldOverInts (*)

functionNot (NilVal:xs) _ = TrueVal
functionNot (_:xs) _      = NilVal

intsInOrder operator ((IntVal f):xs) env = goThroughInts f xs
  where goThroughInts _ []              = TrueVal
        goThroughInts f ((IntVal s):xs) = if (operator f s) then goThroughInts s xs else NilVal

functionEq = intsInOrder (==)
functionLT = intsInOrder (<)
functionGT = intsInOrder (>)
functionLE = intsInOrder (<=)
functionGE = intsInOrder (>=)

functionCons [val, NilVal]       env = ConsVal [val]
functionCons [val, ConsVal list] env = ConsVal (val:list)
functionCons [val1, val2]        env = ConsVal [val1, val2]

functionCar [ConsVal (x:xs)] env = x
functionCar [ConsVal []]     env = NilVal

functionCdr [ConsVal (x:xs)] env = ConsVal xs
functionCdr [ConsVal []]     env = NilVal

functionMap [PrimVal f, ConsVal list] env = ConsVal $ map (\x -> f  [x] env) list

functionNth [IntVal n, ConsVal list] env = getNth n list
  where getNth 0 (x:xs) = x
        getNth _ []     = NilVal
        getNth n (x:xs) = getNth (n - 1) xs

functionApply [PrimVal function, ConsVal list] env = function list env

functionList values env = ConsVal values

functionEval [exp] env = eval (unquotify exp) env

runtime = [("+", (PrimVal functionAdd)),
           ("*", (PrimVal functionMul)),
           ("-", (PrimVal functionSub)),
           ("t", TrueVal),
           ("nil", NilVal),
           ("not", (PrimVal functionNot)),
           ("=", (PrimVal functionEq)),
           ("<", (PrimVal functionLT)),
           (">", (PrimVal functionGT)),
           ("<=", (PrimVal functionLE)),
           (">=", (PrimVal functionGE)),
           ("cons", (PrimVal functionCons)),
           ("car", (PrimVal functionCar)),
           ("cdr", (PrimVal functionCdr)),
           ("map", (PrimVal functionMap)),
           ("nth", (PrimVal functionNth)),
           ("apply", (PrimVal functionApply)),
           ("list", (PrimVal functionList)),
           ("eval", (PrimVal functionEval))
           ]

-- Special forms
-- Warning, the global binding leaks into the function. Must fix
dynamicFunction args body = function
  where function inputVars env = (eval body (newEnv ++ env))
          where newEnv = zipWith (\(SymExp x) y -> (x, y)) args inputVars

dynamicLambda args body env = theLambda
  where f = dynamicFunction args body
        theLambda inputVars _ = f inputVars env

-- This also leaks scope into the function
dynamicMacro args body = function
  where function inputParams macroEnv = newBody
          where newBody = unquotify $ eval body (argsEnv ++ macroEnv)
                argsEnv = zipWith (\(SymExp x) y -> (x, y)) args quotedInputParams
                quotedInputParams = map quotify inputParams

quotify (IntExp i) = IntVal i
quotify (SymExp name) = SymVal name
quotify (SExp terms) = ConsVal $ map quotify terms

quaziQuotify (SExp terms) env = ConsVal $ map maybeQuotify terms
  where maybeQuotify (SExp [SymExp "unquote", exp]) = eval exp env
        maybeQuotify (SExp terms)                   = ConsVal $ map maybeQuotify terms
        maybeQuotify term                           = quotify term
quaziQuotify exp          _   = quotify exp

unquotify (IntVal i)      = IntExp i
unquotify (SymVal name)   = SymExp name
unquotify (ConsVal terms) = SExp $ map unquotify terms

firstNonNil [x]    env = eval x env
firstNonNil (x:xs) env = let val = eval x env
                         in case val of
                           NilVal    -> firstNonNil xs env
                           otherwise -> val

firstNil [x]    env = eval x env
firstNil (x:xs) env = let val = eval x env
                      in case val of
                        NilVal    -> NilVal
                        otherwise -> firstNil xs env

doCond ([cond, exp]:rest) env = let val = eval cond env
                                  in case val of
                                    NilVal    -> doCond rest env
                                    otherwise -> eval exp env
doCond ([exp]:rest) env = eval exp env
doCond [] env           = NilVal

doLet terms body originalEnv = eval body newEnv
  where newEnv = foldl addToEnv originalEnv terms
        addToEnv env (SExp [SymExp name,body]) = (name, eval body originalEnv):env

-- Printer

instance Show Val where
  show (IntVal i) = show i
  show (SymVal name) = name
  show (ExceptionVal i) = error i
  show (DefVal name value) = name ++ " -> " ++  show value
  show (PrimVal _) = "fn"
  show NilVal = "nil"
  show TrueVal = "t"
  show (ConsVal values) = "(" ++ (foldl (\x y -> x ++ (show y) ++ " ") "" values) ++ ")"
  show (MacroVal _) = "mc"

evalString l defs = case exp of
  Right e -> ret $ eval e defs
  Left e  -> (ExceptionVal (show e), defs)
  where exp = parse anExp "Expression" l
        ret (DefVal e v) = (DefVal e v, (e,v):defs)
        ret ev           = (ev, defs)

repl defs =
  do putStr "> "
     l <- getLine
     (val, ndefs) <- return $ evalString l defs
     putStrLn (show val)
     repl ndefs

main = repl runtime