aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--bin/Main.hs29
-rw-r--r--lisk.cabal1
-rw-r--r--src/Environment.hs69
-rw-r--r--src/Error/Base.hs24
-rw-r--r--src/Error/Pretty.hs9
-rw-r--r--src/Evaluator.hs38
-rw-r--r--src/Operators.hs4
-rw-r--r--src/Parser.hs2
-rw-r--r--tests/Properties.hs5
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 @@
1module Main where 1module Main where
2 2
3import Control.Monad (liftM) 3import Control.Monad (liftM)
4import Control.Monad.Except (throwError) 4import Control.Monad.Except (liftIO, runExceptT, throwError)
5import Environment
5import Error.Base (LispError (..), LispResult (..), 6import Error.Base (LispError (..), LispResult (..),
6 unwrap) 7 unwrap)
7import Error.Pretty (defaults, showError) 8import Error.Pretty (defaults, showError)
@@ -17,25 +18,31 @@ readExpr inp =
17 Left err -> throwError $ Parse err 18 Left err -> throwError $ Parse err
18 Right val -> return val 19 Right val -> return val
19 20
21evalExpr :: Env -> String -> IO (LispResult String)
22evalExpr env inp = runExceptT $ fmap show $
23 (liftLispResult $ readExpr inp) >>= eval env
20 24
21repl :: IO () 25repl :: Env -> IO ()
22repl = do 26repl env = do
23 -- \u2020 - obelisk 27 let pp = showError defaults "(lisk-repl)"
24 inp <- readline "† " 28 inp <- readline "† "
25 case inp of 29 case inp of
26 Nothing -> return () 30 Nothing -> return ()
27 Just ",q" -> return () 31 Just ",q" -> return ()
28 Just line -> do 32 Just i -> do
29 addHistory line 33 out <- evalExpr env i
30 let pp = showError defaults 34 either (putStrLn . pp) putStrLn out
31 either (putStrLn . pp line) print $ readExpr line >>= eval 35 repl env
32 repl 36
33 37
34main :: IO () 38main :: IO ()
35main = do 39main = do
36 args <- getArgs 40 args <- getArgs
41 initEnv <- newEnv
37 if null args 42 if null args
38 then do 43 then do
39 putStrLn ";;; Entering lisk repl ..." 44 putStrLn ";;; Entering lisk repl ..."
40 repl 45 repl initEnv
41 else print $ eval =<< readExpr (head args) 46 else do
47 let pp = showError defaults "(lisk-repl)"
48 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
29 Operators, 29 Operators,
30 Error.Base 30 Error.Base
31 Error.Pretty 31 Error.Pretty
32 Environment
32 33
33executable lisk 34executable lisk
34 default-language: Haskell2010 35 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 @@
1module Environment ( Env
2 , setVar
3 , getVar
4 , defineVar
5 , manyBindings
6 , newEnv
7 , liftLispResult
8 , IOResult
9 ) where
10
11import Control.Monad (liftM, mapM)
12import Control.Monad.Except
13import Data.IORef
14import Data.Maybe (isJust)
15import Error.Base (LispError (..), LispResult (..), unwrap)
16import Parser (Expr (..))
17
18type Env = IORef [(String, IORef Expr)]
19
20newEnv :: IO Env
21newEnv = newIORef []
22
23type IOResult = ExceptT LispError IO
24
25liftLispResult :: LispResult a -> IOResult a
26liftLispResult (Left err) = throwError err
27liftLispResult (Right val) = return val
28
29isBound :: Env -> String -> IO Bool
30isBound env var = do
31 ptr <- readIORef env
32 return $ isJust $ lookup var ptr
33
34-- env modifiers
35
36getVar :: Env -> String -> IOResult Expr
37getVar env var = do
38 ptr <- liftIO $ readIORef env
39 maybe (throwError $ UnboundVariable var)
40 (liftIO . readIORef)
41 $ lookup var ptr
42
43setVar :: Env -> String -> Expr -> IOResult ()
44setVar env var val = do
45 ptr <- liftIO $ readIORef env
46 maybe (throwError $ UnboundVariable var)
47 (liftIO . (flip writeIORef val))
48 $ lookup var ptr
49
50defineVar :: Env -> String -> Expr -> IOResult ()
51defineVar env var val = do
52 alreadyBound <- liftIO $ isBound env var
53 if alreadyBound
54 then setVar env var val
55 else liftIO $ do
56 newRef <- newIORef val
57 ptr <- readIORef env
58 writeIORef env $ (var, newRef):ptr
59
60makeBind :: (String, Expr) -> IO (String, IORef Expr)
61makeBind (var, val) = do
62 n <- newIORef val
63 return (var, n)
64
65manyBindings :: Env -> [(String, Expr)] -> IO Env
66manyBindings env binds = do
67 ptr <- readIORef env
68 extendedEnv <- liftM (++ ptr) $ mapM makeBind binds
69 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 @@
1module Error.Base ( 1module Error.Base ( LispError (..)
2 LispError (..) 2 , LispResult (..)
3 , LispResult (..) 3 , unwrap
4 , unwrap 4 ) where
5 ) where
6 5
7import Control.Monad.Except 6import Control.Monad.Except
8import Parser 7import Parser
@@ -15,19 +14,24 @@ data LispError = Parse ParseError
15 | ArgCount String Int [Expr] 14 | ArgCount String Int [Expr]
16 | UnknownFunction String 15 | UnknownFunction String
17 | TypeMismatch String Expr 16 | TypeMismatch String Expr
17 | UnboundVariable String
18 18
19unwordsList :: [Expr] -> String 19unwordsList :: [Expr] -> String
20unwordsList = unwords . map show 20unwordsList = unwords . map show
21 21
22literal :: String -> String
23literal v = "`" <> v <> "`"
24
22instance Show LispError where 25instance Show LispError where
23 show (Parse e) = "Parser Error: " ++ show e 26 show (Parse e) = "Parser Error: " ++ show e
24 show (BadForm s expr) = "Bad Form: " ++ s ++ ": " ++ show expr 27 show (BadForm s expr) = "Bad Form: " ++ literal s ++ ": " ++ show expr
25 -- TODO: clean this up 28 -- TODO: clean this up
26 show (ArgCount fn n es) 29 show (ArgCount fn n es)
27 | null es = "Invalid arity, `" ++ fn ++ "` expects " ++ show n ++ " or more expression(s)!" 30 | null es = "Invalid arity, " ++ literal fn ++ " expects " ++ show n ++ " or more expression(s)!"
28 | otherwise = "Invalid arity, `" ++ fn ++ "` expects " ++ show n ++ " or more expression(s), got value(s): " ++ unwordsList es 31 | otherwise = "Invalid arity, " ++ literal fn ++ " expects " ++ show n ++ " or more expression(s), got value(s): " ++ unwordsList es
29 show (UnknownFunction fn) = "Cannot apply function: " ++ fn 32 show (UnknownFunction fn) = "Cannot apply function: " ++ literal fn
30 show (TypeMismatch msg got) = "Type mismatch, expected " ++ msg ++ ", got: " ++ show got 33 show (TypeMismatch msg got) = "Type mismatch, expected " ++ literal msg ++ ", got: " ++ show got
34 show (UnboundVariable name) = "Possibly unbound variable: " ++ literal name
31 35
32type LispResult = Either LispError 36type LispResult = Either LispError
33 37
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 @@
1module Error.Pretty ( 1module Error.Pretty ( showError
2 showError 2 , Options (..)
3 , Options (..) 3 , defaults
4 , defaults 4 ) where
5 ) where
6 5
7import Data.List (intercalate, nub) 6import Data.List (intercalate, nub)
8import Error.Base (LispError (..)) 7import 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 @@
1module Evaluator ( 1module Evaluator (eval) where
2 eval
3 ) where
4 2
5import Control.Monad.Except 3import Control.Monad.Except
4import Environment
6import Error.Base (LispError (..), LispResult (..), 5import Error.Base (LispError (..), LispResult (..),
7 unwrap) 6 unwrap)
8import Operators 7import Operators
@@ -15,18 +14,27 @@ apply fn args = maybe
15 ($ args) 14 ($ args)
16 (lookup fn primitives) 15 (lookup fn primitives)
17 16
18eval :: Expr -> LispResult Expr 17eval :: Env -> Expr -> IOResult Expr
19eval v@(StringLiteral s) = return v 18eval _ v@(StringLiteral s) = return v
20eval v@(IntLiteral i) = return v 19eval _ v@(IntLiteral i) = return v
21eval v@(BoolLiteral b) = return v 20eval _ v@(BoolLiteral b) = return v
22eval v@(FloatLiteral f) = return v 21eval env (Id l) = getVar env l
23eval v@(Vector xs) = liftM Vector $ mapM eval xs 22eval _ v@(FloatLiteral f) = return v
24-- handle quotes as literals 23eval env v@(Vector xs) = liftM Vector $ mapM (eval env) xs
25eval (List[Id "quote", val]) = return val 24eval env (List[Id "quote", val]) = return val
26eval (List[Id "quasiquote", val]) = undefined 25eval env (List[Id "quasiquote", val]) = undefined
27eval (List[Id "unquote", val]) = undefined 26eval env (List[Id "unquote", val]) = eval env val
28eval (List (Id fn : args)) = mapM eval args >>= apply fn 27eval env (List [Id "set!", Id var, val]) = do
28 e <- eval env val
29 setVar env var e
30 return e
31eval env (List [Id "define", Id var, val]) = do
32 e <- eval env val
33 defineVar env var e
34 return e
35eval env (List (Id fn : args)) = mapM (eval env) args >>= liftLispResult . apply fn
36eval env NoReturn = throwError $ BadForm "Invalid usage of non-returning expression" NoReturn
29 37
30-- handle bad forms 38-- handle bad forms
31eval invalidForm = throwError $ BadForm "lisk can't recognize this form" invalidForm 39eval env invalidForm = throwError $ BadForm "lisk can't recognize this form" invalidForm
32 40
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 @@
1module Operators ( 1module Operators (primitives) where
2 primitives
3 ) where
4 2
5import Control.Monad.Except 3import Control.Monad.Except
6import Error.Base (LispError (..), LispResult (..)) 4import 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]
22 | FloatLiteral Double 22 | FloatLiteral Double
23 | BoolLiteral Bool 23 | BoolLiteral Bool
24 | Id String 24 | Id String
25 | NoReturn
25 deriving (Eq) 26 deriving (Eq)
26 27
27-- backslash double quote escapes a quote inside strings 28-- backslash double quote escapes a quote inside strings
@@ -127,3 +128,4 @@ instance Show Expr where
127 show (BoolLiteral True) = "#t" 128 show (BoolLiteral True) = "#t"
128 show (BoolLiteral False) = "#f" 129 show (BoolLiteral False) = "#f"
129 show (Id i) = i 130 show (Id i) = i
131 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 @@
1{-# LANGUAGE TemplateHaskell #-} 1{-# LANGUAGE TemplateHaskell #-}
2module Properties ( 2module Properties (runTests) where
3 runTests
4 ) where
5 3
6import Data.Maybe (fromJust) 4import Data.Maybe (fromJust)
7import Error.Base (unwrap) 5import Error.Base (unwrap)
@@ -10,7 +8,6 @@ import Operators (primitives)
10import Parser (Expr (..), parseLispValue, parseQuote) 8import Parser (Expr (..), parseLispValue, parseQuote)
11import Test.QuickCheck 9import Test.QuickCheck
12 10
13
14prop_commutativeAdd :: [Integer] -> Property 11prop_commutativeAdd :: [Integer] -> Property
15prop_commutativeAdd xs = 12prop_commutativeAdd xs =
16 not (null xs) ==> rhs == lhs 13 not (null xs) ==> rhs == lhs