From b19a4a35db4cd951c52e179f3340518c9e2dcc1e Mon Sep 17 00:00:00 2001 From: Akshay Date: Fri, 16 Oct 2020 18:54:46 +0530 Subject: add initial support for variable definition --- bin/Main.hs | 29 +++++++++++++--------- lisk.cabal | 1 + src/Environment.hs | 69 +++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Error/Base.hs | 24 +++++++++++-------- src/Error/Pretty.hs | 9 ++++--- src/Evaluator.hs | 38 +++++++++++++++++------------ src/Operators.hs | 4 +--- src/Parser.hs | 2 ++ tests/Properties.hs | 5 +--- 9 files changed, 133 insertions(+), 48 deletions(-) create mode 100644 src/Environment.hs diff --git a/bin/Main.hs b/bin/Main.hs index 54ed6b2..56ad0cd 100644 --- a/bin/Main.hs +++ b/bin/Main.hs @@ -1,7 +1,8 @@ module Main where import Control.Monad (liftM) -import Control.Monad.Except (throwError) +import Control.Monad.Except (liftIO, runExceptT, throwError) +import Environment import Error.Base (LispError (..), LispResult (..), unwrap) import Error.Pretty (defaults, showError) @@ -17,25 +18,31 @@ readExpr inp = Left err -> throwError $ Parse err Right val -> return val +evalExpr :: Env -> String -> IO (LispResult String) +evalExpr env inp = runExceptT $ fmap show $ + (liftLispResult $ readExpr inp) >>= eval env -repl :: IO () -repl = do - -- \u2020 † - obelisk +repl :: Env -> IO () +repl env = do + let pp = showError defaults "(lisk-repl)" inp <- readline "† " case inp of Nothing -> return () Just ",q" -> return () - Just line -> do - addHistory line - let pp = showError defaults - either (putStrLn . pp line) print $ readExpr line >>= eval - repl + Just i -> do + out <- evalExpr env i + either (putStrLn . pp) putStrLn out + repl env + main :: IO () main = do args <- getArgs + initEnv <- newEnv if null args then do putStrLn ";;; Entering lisk repl ..." - repl - else print $ eval =<< readExpr (head args) + repl initEnv + else do + let pp = showError defaults "(lisk-repl)" + evalExpr initEnv (head args) >>= (either (putStrLn . pp) print) diff --git a/lisk.cabal b/lisk.cabal index 8cdb413..6c2bdd4 100644 --- a/lisk.cabal +++ b/lisk.cabal @@ -29,6 +29,7 @@ library Operators, Error.Base Error.Pretty + Environment executable lisk default-language: Haskell2010 diff --git a/src/Environment.hs b/src/Environment.hs new file mode 100644 index 0000000..7b3f365 --- /dev/null +++ b/src/Environment.hs @@ -0,0 +1,69 @@ +module Environment ( Env + , setVar + , getVar + , defineVar + , manyBindings + , newEnv + , liftLispResult + , IOResult + ) where + +import Control.Monad (liftM, mapM) +import Control.Monad.Except +import Data.IORef +import Data.Maybe (isJust) +import Error.Base (LispError (..), LispResult (..), unwrap) +import Parser (Expr (..)) + +type Env = IORef [(String, IORef Expr)] + +newEnv :: IO Env +newEnv = newIORef [] + +type IOResult = ExceptT LispError IO + +liftLispResult :: LispResult a -> IOResult a +liftLispResult (Left err) = throwError err +liftLispResult (Right val) = return val + +isBound :: Env -> String -> IO Bool +isBound env var = do + ptr <- readIORef env + return $ isJust $ lookup var ptr + +-- env modifiers + +getVar :: Env -> String -> IOResult Expr +getVar env var = do + ptr <- liftIO $ readIORef env + maybe (throwError $ UnboundVariable var) + (liftIO . readIORef) + $ lookup var ptr + +setVar :: Env -> String -> Expr -> IOResult () +setVar env var val = do + ptr <- liftIO $ readIORef env + maybe (throwError $ UnboundVariable var) + (liftIO . (flip writeIORef val)) + $ lookup var ptr + +defineVar :: Env -> String -> Expr -> IOResult () +defineVar env var val = do + alreadyBound <- liftIO $ isBound env var + if alreadyBound + then setVar env var val + else liftIO $ do + newRef <- newIORef val + ptr <- readIORef env + writeIORef env $ (var, newRef):ptr + +makeBind :: (String, Expr) -> IO (String, IORef Expr) +makeBind (var, val) = do + n <- newIORef val + return (var, n) + +manyBindings :: Env -> [(String, Expr)] -> IO Env +manyBindings env binds = do + ptr <- readIORef env + extendedEnv <- liftM (++ ptr) $ mapM makeBind binds + newIORef extendedEnv diff --git a/src/Error/Base.hs b/src/Error/Base.hs index d7b685c..ef32d52 100644 --- a/src/Error/Base.hs +++ b/src/Error/Base.hs @@ -1,8 +1,7 @@ -module Error.Base ( - LispError (..) - , LispResult (..) - , unwrap - ) where +module Error.Base ( LispError (..) + , LispResult (..) + , unwrap + ) where import Control.Monad.Except import Parser @@ -15,19 +14,24 @@ data LispError = Parse ParseError | ArgCount String Int [Expr] | UnknownFunction String | TypeMismatch String Expr + | UnboundVariable String unwordsList :: [Expr] -> String unwordsList = unwords . map show +literal :: String -> String +literal v = "`" <> v <> "`" + instance Show LispError where show (Parse e) = "Parser Error: " ++ show e - show (BadForm s expr) = "Bad Form: " ++ s ++ ": " ++ show expr + show (BadForm s expr) = "Bad Form: " ++ literal s ++ ": " ++ show expr -- TODO: clean this up show (ArgCount fn n es) - | null es = "Invalid arity, `" ++ fn ++ "` expects " ++ show n ++ " or more expression(s)!" - | otherwise = "Invalid arity, `" ++ fn ++ "` expects " ++ show n ++ " or more expression(s), got value(s): " ++ unwordsList es - show (UnknownFunction fn) = "Cannot apply function: " ++ fn - show (TypeMismatch msg got) = "Type mismatch, expected " ++ msg ++ ", got: " ++ show got + | null es = "Invalid arity, " ++ literal fn ++ " expects " ++ show n ++ " or more expression(s)!" + | otherwise = "Invalid arity, " ++ literal fn ++ " expects " ++ show n ++ " or more expression(s), got value(s): " ++ unwordsList es + show (UnknownFunction fn) = "Cannot apply function: " ++ literal fn + show (TypeMismatch msg got) = "Type mismatch, expected " ++ literal msg ++ ", got: " ++ show got + show (UnboundVariable name) = "Possibly unbound variable: " ++ literal name type LispResult = Either LispError diff --git a/src/Error/Pretty.hs b/src/Error/Pretty.hs index 44601d6..a90131b 100644 --- a/src/Error/Pretty.hs +++ b/src/Error/Pretty.hs @@ -1,8 +1,7 @@ -module Error.Pretty ( - showError - , Options (..) - , defaults - ) where +module Error.Pretty ( showError + , Options (..) + , defaults + ) where import Data.List (intercalate, nub) import Error.Base (LispError (..)) diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 8a5274f..e3bf697 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -1,8 +1,7 @@ -module Evaluator ( - eval - ) where +module Evaluator (eval) where import Control.Monad.Except +import Environment import Error.Base (LispError (..), LispResult (..), unwrap) import Operators @@ -15,18 +14,27 @@ apply fn args = maybe ($ args) (lookup fn primitives) -eval :: Expr -> LispResult Expr -eval v@(StringLiteral s) = return v -eval v@(IntLiteral i) = return v -eval v@(BoolLiteral b) = return v -eval v@(FloatLiteral f) = return v -eval v@(Vector xs) = liftM Vector $ mapM eval xs --- handle quotes as literals -eval (List[Id "quote", val]) = return val -eval (List[Id "quasiquote", val]) = undefined -eval (List[Id "unquote", val]) = undefined -eval (List (Id fn : args)) = mapM eval args >>= apply fn +eval :: Env -> Expr -> IOResult Expr +eval _ v@(StringLiteral s) = return v +eval _ v@(IntLiteral i) = return v +eval _ v@(BoolLiteral b) = return v +eval env (Id l) = getVar env l +eval _ v@(FloatLiteral f) = return v +eval env v@(Vector xs) = liftM Vector $ mapM (eval env) xs +eval env (List[Id "quote", val]) = return val +eval env (List[Id "quasiquote", val]) = undefined +eval env (List[Id "unquote", val]) = eval env val +eval env (List [Id "set!", Id var, val]) = do + e <- eval env val + setVar env var e + return e +eval env (List [Id "define", Id var, val]) = do + e <- eval env val + defineVar env var e + return e +eval env (List (Id fn : args)) = mapM (eval env) args >>= liftLispResult . apply fn +eval env NoReturn = throwError $ BadForm "Invalid usage of non-returning expression" NoReturn -- handle bad forms -eval invalidForm = throwError $ BadForm "lisk can't recognize this form" invalidForm +eval env invalidForm = throwError $ BadForm "lisk can't recognize this form" invalidForm diff --git a/src/Operators.hs b/src/Operators.hs index c5812ea..fa39e23 100644 --- a/src/Operators.hs +++ b/src/Operators.hs @@ -1,6 +1,4 @@ -module Operators ( - primitives - ) where +module Operators (primitives) where import Control.Monad.Except import Error.Base (LispError (..), LispResult (..)) diff --git a/src/Parser.hs b/src/Parser.hs index 115203b..a7f5571 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -22,6 +22,7 @@ data Expr = List [Expr] | FloatLiteral Double | BoolLiteral Bool | Id String + | NoReturn deriving (Eq) -- backslash double quote escapes a quote inside strings @@ -127,3 +128,4 @@ instance Show Expr where show (BoolLiteral True) = "#t" show (BoolLiteral False) = "#f" show (Id i) = i + show NoReturn = ";;; environment extension" diff --git a/tests/Properties.hs b/tests/Properties.hs index 03a7e9a..867d0e9 100644 --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,7 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} -module Properties ( - runTests - ) where +module Properties (runTests) where import Data.Maybe (fromJust) import Error.Base (unwrap) @@ -10,7 +8,6 @@ import Operators (primitives) import Parser (Expr (..), parseLispValue, parseQuote) import Test.QuickCheck - prop_commutativeAdd :: [Integer] -> Property prop_commutativeAdd xs = not (null xs) ==> rhs == lhs -- cgit v1.2.3