path: root/lore/Language/Bs/Eval.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Bs.Eval (
  evalText
, evalFile
, runParseTest
, safeExec
, runASTinEnv
, basicEnv
, fileToEvalForm
, textToEvalForm
, getFileContents
) where

import Control.Exception
import Control.Monad.Reader
import qualified Data.Map as Map
import Data.String
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 Protolude
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