[ MIRROR ] An interpreter for a Lisp-like language git.ngill.net/nls.git
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187{-# LANGUAGE OverloadedStrings #-}
module Eval ( baseEnv, eval, evalProgram, )where
import qualified Builtin as Bimport qualified Data.Map as Mimport qualified Data.Text as Timport Typesimport Util
mapThunk :: [(String, NlsRunValue)] -> [(String, NlsThunk)]mapThunk = map (\(name, val) -> (name, Right val))
-- create a new base environment with builtinsbaseEnv :: EnvbaseEnv = extendEnv (Env (M.fromList $ mapThunk B.builtins) Nothing)
-- keywords map for predefined values-- this is separate from builtins, these cannot be shadowedkeywords :: M.Map String NlsRunValuekeywords = M.fromList [ ("true", RBool True), ("false", RBool False), ("nil", RList []) ]
-- META FUNCTIONS --
-- meta functions, like keywords, cannot be shadowedmetaFuncs :: M.Map String (Env -> [NlsAstValue] -> Eval (NlsRunValue, Env))metaFuncs = M.fromList [ ("define", defineFunc), ("undef", unDefFunc), ("lambda", lambdaFunc), ("if", ifFunc), ("eval", evalFunc), ("quote", quoteFunc), ("get", getFunc), ("import", importFunc) ]
defineFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)defineFunc env [ASymbol name, expr] = do -- keywords and meta-functions cannot be overriden case M.lookup name keywords of Just _ -> Left ("cannot shadow keyword: " <> T.pack name) Nothing -> case M.lookup name metaFuncs of Just _ -> Left ("cannot shadow meta-function: " <> T.pack name) Nothing -> let thunk :: NlsThunk thunk = do (val, _) <- eval env' expr pure val env' :: Env env' = defineUnchecked name thunk env in pureWithEnv (RUnit) env'defineFunc _ _ = Left "define expects a symbol and expression"
unDefFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)unDefFunc env [ASymbol name] = case undefine name env of Left err -> Left err Right env' -> pureWithEnv (RUnit) env'unDefFunc _ _ = Left "undef expects a symbol"
lambdaFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)lambdaFunc env (AList params : body) = do paramNames <- mapM extractParam params let fn = createLambda env paramNames body pureWithEnv fn envlambdaFunc _ _ = Left "lambda expects a parameter and body list"
ifFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)ifFunc env [_cond, _then, _else] = do (res, env') <- eval env _cond case res of (RBool True) -> eval env' _then (RBool False) -> eval env' _else (RList []) -> eval env' _else -- nil evaluates to false (RList _) -> eval env' _then -- yes this is C style (RNumber 0) -> eval env' _else (RNumber _) -> eval env _then _ -> Left "expected boolean condition"ifFunc _ _ = Left "if expects a condition, then, and else"
evalFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)evalFunc env [expr] = do (result, env') <- eval env expr case rToAValue result of Right ast -> eval env' ast Left err -> Left errevalFunc _ _ = Left "eval expects one argument"
quoteFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)quoteFunc env [expr] = pureWithEnv (aToRValue expr) envquoteFunc _ _ = Left "quote expects one argument"
getFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)getFunc env [mExpr, AString key] = do (mVal, _) <- eval env mExpr case mVal of RModule env' -> case lookupEnv key env' of Just thunk -> do val <- thunk pureWithEnv val env Nothing -> Left $ "module does not contain: " <> T.pack key _ -> Left "expected module"getFunc _ _ = Left "get expects a module and a string"
importFunc :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)importFunc _ _ = Left "cannot call raw import"
-- EVALUATION --
apply :: NlsRunValue -> [NlsRunValue] -> Env -> Eval (NlsRunValue, Env)apply (RFunction f) args env = do let env' = extendEnv env (val, env'') <- f args env' case reduceEnv env'' of Just oldEnv -> pureWithEnv val oldEnv Nothing -> Left "no environment to unwrap"apply _ _ _ = Left "attempted to call non-function"
-- create a RFunction from a lambda expressioncreateLambda :: Env -> [String] -> [NlsAstValue] -> NlsRunValuecreateLambda env params body = RFunction wrapper where wrapper :: [NlsRunValue] -> Env -> Eval (NlsRunValue, Env) wrapper args callEnv = do if length args /= length params then Left ( "expected " <> T.pack (show $ length params) <> " arguments, got " <> T.pack (show $ length args) ) else do let newFrame = M.fromList $ mapThunk $ zip params args let env' = mergeFrame newFrame env (val, _) <- evalProgram env' body pureWithEnv val callEnv
-- evaluate a single ast valueeval :: Env -> NlsAstValue -> Eval (NlsRunValue, Env)eval env (ANumber n) = pureWithEnv (RNumber n) enveval env (AString s) = pureWithEnv (RString s) enveval env (ASymbol key) = do case M.lookup key keywords of Just v -> pureWithEnv v env Nothing -> case lookupEnv key env of Just thunk -> do val <- thunk pureWithEnv val env Nothing -> Left (T.pack ("undefined symbol: " ++ key))eval env (AList []) = pureWithEnv (RList []) enveval env (AList (f : args)) = case f of ASymbol name -> case M.lookup name metaFuncs of Just mf -> mf env args Nothing -> do (func, env') <- eval env f (vals, env'') <- mapAccumM eval env' args apply func vals env'' _ -> do (func, env') <- eval env f (vals, env'') <- mapAccumM eval env' args apply func vals env''
-- evaluate a sequence of ast valuesevalProgram :: Env -> [NlsAstValue] -> Eval (NlsRunValue, Env)evalProgram env [] = pure (RUnit, env)evalProgram env [x] = eval env xevalProgram env (x : xs) = do (_, env') <- eval env x evalProgram env' xs