1 files changed, 253 insertions, 0 deletions
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 <bool> <s-expr> <s-expr>)"
+
+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 <pairs> <s-expr>)"
+
+
+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 <params> <s-expr>)"
+
+
+-- 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