diff options
Diffstat (limited to 'Biz/Language/Bs/Eval.hs')
| -rw-r--r-- | Biz/Language/Bs/Eval.hs | 183 |
1 files changed, 83 insertions, 100 deletions
diff --git a/Biz/Language/Bs/Eval.hs b/Biz/Language/Bs/Eval.hs index 290170b..1198a3e 100644 --- a/Biz/Language/Bs/Eval.hs +++ b/Biz/Language/Bs/Eval.hs @@ -1,19 +1,21 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} -module Language.Bs.Eval ( - evalText -, evalFile -, runParseTest -, safeExec -, runASTinEnv -, basicEnv -, fileToEvalForm -, textToEvalForm -, getFileContents -) where + +module Language.Bs.Eval + ( evalText, + evalFile, + runParseTest, + safeExec, + runASTinEnv, + basicEnv, + fileToEvalForm, + textToEvalForm, + getFileContents, + ) +where import Control.Exception import Control.Monad.Reader @@ -28,23 +30,25 @@ 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)) - ] +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 +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 +parseFn val = throw $ TypeMismatch "parse expects string, instead got:" val safeExec :: IO a -> IO (Either String a) safeExec m = do @@ -63,13 +67,13 @@ 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 +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 +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 @@ -77,23 +81,23 @@ 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." + 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 +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 :: Expr -> Eval Expr getVar (Atom atom) = do - Env{..} <- ask + 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 + 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 @@ -106,136 +110,115 @@ extractVar n = throw $ TypeMismatch "expected an atomic value" n getEven :: [t] -> [t] getEven [] = [] -getEven (x:xs) = x : getOdd xs +getEven (x : xs) = x : getOdd xs getOdd :: [t] -> [t] getOdd [] = [] -getOdd (_:xs) = getEven xs +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 + 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 +isFunc (List ((Atom "lambda") : _)) = True +isFunc _ = False eval :: Expr -> Eval Expr eval (List [Atom "dumpEnv", x]) = do - Env{..} <- ask + 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 (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 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 True) -> eval then_ (Bool False) -> eval else_ _ -> throw $ BadSpecialForm "if's first arg must eval into a boolean" -eval (List ( (:) (Atom "if") _)) = +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 - +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 (List [Atom "define", List (name : args), body]) = do + Env {..} <- ask _ <- eval body - bindArgsEval (name:args) [body] name - + bindArgsEval (name : args) [body] name eval (List [Atom "define", name, body]) = do - Env{..} <- ask + Env {..} <- ask _ <- eval body bindArgsEval [name] [body] name - eval (List [Atom "let", List pairs, expr]) = do - Env{..} <- ask + Env {..} <- ask atoms <- mapM ensureAtom $ getEven pairs - vals <- mapM eval $ getOdd pairs + vals <- mapM eval $ getOdd pairs bindArgsEval atoms vals expr - -eval (List (Atom "let":_) ) = +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>)" - - + 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)]]) = +eval (List [Atom "cdr", List [Atom "quote", List (_ : xs)]]) = return $ List xs -eval (List [Atom "cdr", arg@(List (x: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:_))]) = + -- 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 - - + Atom _ -> do + val <- eval arg + eval $ List [Atom "car", val] + _ -> return $ x eval (List ((:) x xs)) = do - Env{..} <- ask + 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 + (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 +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 |