From f50cecf2cb77cc073cb86a6016468a09d1c49fb0 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Sat, 23 Mar 2019 23:58:26 -0700 Subject: Add semi-working bs --- lore/Language/Bs/Eval.hs | 253 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 253 insertions(+) create mode 100644 lore/Language/Bs/Eval.hs (limited to 'lore/Language/Bs/Eval.hs') diff --git a/lore/Language/Bs/Eval.hs b/lore/Language/Bs/Eval.hs new file mode 100644 index 0000000..8246d7b --- /dev/null +++ b/lore/Language/Bs/Eval.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +module Language.Bs.Eval ( + evalText, + evalFile, + runParseTest, + safeExec, + runASTinEnv, + basicEnv, + fileToEvalForm, + textToEvalForm, + getFileContents +) where + +import Control.Exception +import Control.Monad.Reader +import Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Language.Bs.Expr +import Language.Bs.Parser +import Language.Bs.Primitives +import System.Directory +import Text.Parsec + +funcEnv :: Map.Map T.Text Expr +funcEnv = Map.fromList $ primEnv + <> [ ("read" , IFun $ IFunc $ unop readFn) + , ("parse", IFun $ IFunc $ unop parseFn) + , ("eval", IFun $ IFunc $ unop eval) + , ("show", IFun $ IFunc $ unop (return . Tape . ppexpr)) + ] + +basicEnv :: Env +basicEnv = Env Map.empty funcEnv + +readFn :: Expr -> Eval Expr +readFn (Tape txt) = lineToEvalForm txt +readFn val = throw $ TypeMismatch "read expects string, instead got:" val + +parseFn :: Expr -> Eval Expr +parseFn (Tape txt) = either (throw . ParseError . show) return $ readExpr txt +parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val + +safeExec :: IO a -> IO (Either String a) +safeExec m = do + result <- Control.Exception.try m + case result of + Left (eTop :: SomeException) -> + case fromException eTop of + Just (enclosed :: LispError) -> + return $ Left (show enclosed) + Nothing -> + return $ Left (show eTop) + Right val -> + return $ Right val + +runASTinEnv :: Env -> Eval b -> IO b +runASTinEnv code action = runReaderT (unEval action) code + +lineToEvalForm :: T.Text -> Eval Expr +lineToEvalForm input = either (throw . ParseError . show ) eval $ readExpr input + +evalFile :: FilePath -> T.Text -> IO () -- program file +evalFile filePath fileExpr = (runASTinEnv basicEnv $ fileToEvalForm filePath fileExpr) >>= print + +fileToEvalForm :: FilePath -> T.Text -> Eval Expr +fileToEvalForm filePath input = either (throw . ParseError . show ) evalBody $ readExprFile filePath input + +runParseTest :: T.Text -> T.Text -- for view AST +runParseTest input = either (T.pack . show) (T.pack . show) $ readExpr input + +sTDLIB :: FilePath +sTDLIB = "lore/core.scm" + +endOfList :: Expr -> Expr -> Expr +endOfList (List x) expr = List $ x ++ [expr] +endOfList n _ = throw $ TypeMismatch "failure to get variable: " n + +parseWithLib :: T.Text -> T.Text -> Either ParseError Expr +parseWithLib std inp = do + stdlib <- readExprFile sTDLIB std + expr <- readExpr inp + return $ endOfList stdlib expr + + +getFileContents :: FilePath -> IO T.Text +getFileContents fname = do + exists <- doesFileExist fname + if exists then TIO.readFile fname else return "File does not exist." + +textToEvalForm :: T.Text -> T.Text -> Eval Expr +textToEvalForm std input = either (throw . ParseError . show ) evalBody $ parseWithLib std input + +evalText :: T.Text -> IO () --REPL +evalText textExpr = do + stdlib <- getFileContents sTDLIB + res <- runASTinEnv basicEnv $ textToEvalForm stdlib textExpr + print res + +getVar :: Expr -> Eval Expr +getVar (Atom atom) = do + Env{..} <- ask + case Map.lookup atom (Map.union fenv env) of -- lookup, but prefer functions + Just x -> return x + Nothing -> throw $ UnboundVar atom +getVar n = throw $ TypeMismatch "failure to get variable: " n + +ensureAtom :: Expr -> Eval Expr +ensureAtom n@(Atom _) = return n +ensureAtom n@(List _) = throw $ TypeMismatch "got list" n +ensureAtom n = throw $ TypeMismatch "expected an atomic value" n + +extractVar :: Expr -> T.Text +extractVar (Atom atom) = atom +extractVar n = throw $ TypeMismatch "expected an atomic value" n + +getEven :: [t] -> [t] +getEven [] = [] +getEven (x:xs) = x : getOdd xs + +getOdd :: [t] -> [t] +getOdd [] = [] +getOdd (_:xs) = getEven xs + +applyFunc :: Expr -> [Expr] -> [Expr] -> Eval Expr +applyFunc expr params args = bindArgsEval params args expr + +bindArgsEval :: [Expr] -> [Expr] -> Expr -> Eval Expr +bindArgsEval params args expr = do + Env{..} <- ask + let newVars = zipWith (\a b -> (extractVar a,b)) params args + let (newEnv, newFenv) = Map.partition (not . isFunc) $ Map.fromList newVars + local (const $ Env (newEnv <> env) (newFenv <> fenv)) $ eval expr + +isFunc :: Expr -> Bool +isFunc (List ((Atom "lambda"):_)) = True +isFunc _ = False + +eval :: Expr -> Eval Expr +eval (List [Atom "dumpEnv", x]) = do + Env{..} <- ask + liftIO $ print $ toList env + liftIO $ print $ toList fenv + eval x +eval (Numb i) = return $ Numb i +eval (Tape s) = return $ Tape s +eval (Bool b) = return $ Bool b +eval (List []) = return Nil +eval Nil = return Nil +eval n@(Atom _) = getVar n + +eval (List [Atom "showSF", rest]) = return . Tape . T.pack $ show rest +eval (List ((:) (Atom "showSF") rest)) = return . Tape . T.pack . show $ List rest + +eval (List [Atom "quote", val]) = return val + +eval (List [Atom "if", pred_, then_, else_]) = do + ifRes <- eval pred_ + case ifRes of + (Bool True) -> eval then_ + (Bool False) -> eval else_ + _ -> + throw $ BadSpecialForm "if's first arg must eval into a boolean" +eval (List ( (:) (Atom "if") _)) = + throw $ BadSpecialForm "(if )" + +eval (List [Atom "begin", rest]) = evalBody rest +eval (List ((:) (Atom "begin") rest )) = evalBody $ List rest + +-- top-level define +-- TODO: how to make this eval correctly? +eval (List [Atom "define", List (name:args), body]) = do + Env{..} <- ask + _ <- eval body + bindArgsEval (name:args) [body] name + +eval (List [Atom "define", name, body]) = do + Env{..} <- ask + _ <- eval body + bindArgsEval [name] [body] name + +eval (List [Atom "let", List pairs, expr]) = do + Env{..} <- ask + atoms <- mapM ensureAtom $ getEven pairs + vals <- mapM eval $ getOdd pairs + bindArgsEval atoms vals expr + +eval (List (Atom "let":_) ) = + throw $ BadSpecialForm "let function expects list of parameters and S-Expression body\n(let )" + + +eval (List [Atom "lambda", List params, expr]) = do + ctx <- ask + return $ Func (IFunc $ applyFunc expr params) ctx +eval (List (Atom "lambda":_) ) = throw $ BadSpecialForm "lambda function expects list of parameters and S-Expression body\n(lambda )" + + +-- needed to get cadr, etc to work +eval (List [Atom "cdr", List [Atom "quote", List (_:xs)]]) = + return $ List xs +eval (List [Atom "cdr", arg@(List (x:xs))]) = + case x of + -- proxy for if the list can be evaluated + Atom _ -> do + val <- eval arg + eval $ List [Atom "cdr", val] + _ -> return $ List xs + + +eval (List [Atom "car", List [Atom "quote", List (x:_)]]) = + return $ x +eval (List [Atom "car", arg@(List (x:_))]) = + case x of + Atom _ -> do + val <- eval arg + eval $ List [Atom "car", val] + _ -> return $ x + + +eval (List ((:) x xs)) = do + Env{..} <- ask + funVar <- eval x + xVal <- mapM eval xs + case funVar of + (IFun (IFunc internalFn)) -> + internalFn xVal + + (Func (IFunc definedFn) (Env benv _)) -> + local (const $ Env benv fenv) $ definedFn xVal + + _ -> + throw $ NotFunction funVar + +updateEnv :: T.Text -> Expr -> Env -> Env +updateEnv var e@(IFun _) Env{..} = Env env $ Map.insert var e fenv +updateEnv var e@(Func _ _) Env{..} = Env env $ Map.insert var e fenv +updateEnv var e Env{..} = Env (Map.insert var e env) fenv + +evalBody :: Expr -> Eval Expr +evalBody (List [List ((:) (Atom "define") [Atom var, defExpr]), rest]) = do + evalVal <- eval defExpr + ctx <- ask + local (const $ updateEnv var evalVal ctx) $ eval rest + +evalBody (List ((:) (List ((:) (Atom "define") [Atom var, defExpr])) rest)) = do + evalVal <- eval defExpr + ctx <- ask + local (const $ updateEnv var evalVal ctx) $ evalBody $ List rest + +evalBody x = eval x -- cgit v1.2.3