add initial support for variable definition

9 files changed, 133 insertions, 48 deletions

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