Re-namespacing

Moving away from the DNS-driven namespacing toward more condensed names,
mostly because I don't like typing so much.

1 files changed, 0 insertions, 241 deletions

diff --git a/Com/Simatime/Language/Bs/Eval.hs b/Com/Simatime/Language/Bs/Eval.hs
deleted file mode 100644
index 290170b..0000000
--- a/Com/Simatime/Language/Bs/Eval.hs
+++ /dev/null
@@ -1,241 +0,0 @@
-{-# 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
-
-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
-
-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 -> Eval Expr
-textToEvalForm input = either (throw . ParseError . show ) evalBody $ readExpr input
-
-evalText :: T.Text -> IO () --REPL
-evalText textExpr = do
-  res <- runASTinEnv basicEnv $ textToEvalForm 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