aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAkshay <[email protected]>2020-11-12 05:54:46 +0000
committerAkshay <[email protected]>2020-11-12 05:54:46 +0000
commit841e23f1f5036748e3d179e3f96eedd5bcfdb555 (patch)
tree88408ffaa869aae221586711f9c89c34859e7cb2
parent29d8f8ea04ca651616b4bdd8d3a61da9f0cfae29 (diff)
refactor LispNumber into Base, improve numerical calculationsHEADmaster
-rw-r--r--src/Base.hs51
-rw-r--r--src/Environment.hs3
-rw-r--r--src/Evaluator.hs12
-rw-r--r--src/Parser.hs8
4 files changed, 51 insertions, 23 deletions
diff --git a/src/Base.hs b/src/Base.hs
index 08131e8..422e534 100644
--- a/src/Base.hs
+++ b/src/Base.hs
@@ -1,10 +1,41 @@
1module Base (Expr (..) 1module Base (Expr (..)
2 , Env (..) 2 , Env (..)
3 , Function (..) 3 , LispNumber (..)
4 ) where 4 ) where
5 5
6import Data.IORef 6import Data.IORef
7 7
8data LispNumber = I Integer
9 | F Double
10 deriving (Eq, Ord)
11
12instance Num LispNumber where
13 -- addition
14 (I a) + (I b) = I $ a + b
15 (F a) + (F b) = F $ a + b
16 (F a) + (I b) = F $ a + fromIntegral b
17 (I a) + (F b) = F b + I a
18
19 -- subtraction
20 (I a) - (I b) = I $ a - b
21 (F a) - (F b) = F $ a - b
22 (F a) - (I b) = F $ a - fromIntegral b
23 (I a) - (F b) = F b - I a
24
25 -- multiplication
26 (I a) * (I b) = I $ a * b
27 (F a) * (F b) = F $ a * b
28 (F a) * (I b) = F $ a * fromIntegral b
29 (I a) * (F b) = F b * I a
30
31instance Fractional LispNumber where
32 (I a) / (I b) = F $ fromIntegral a / fromIntegral b
33 (F a) / (I b) = F $ a / fromIntegral b
34 (I a) / (F b) = recip $ F b / I a
35 (F a) / (F b) = F $ a / b
36 recip (F x) = F $ 1 / x
37 recip (I x) = F $ 1 / fromIntegral x
38
8-- TODO: use LispNumber (src/Operators.hs) here instead of IntLiteral and FloatLiteral 39-- TODO: use LispNumber (src/Operators.hs) here instead of IntLiteral and FloatLiteral
9-- TODO: add character literals: \#a \#b \#c \#space \#newline 40-- TODO: add character literals: \#a \#b \#c \#space \#newline
10-- TODO: add support for complex numbers, oct and hex numbers 41-- TODO: add support for complex numbers, oct and hex numbers
@@ -12,19 +43,15 @@ data Expr = List [Expr]
12 | Vector [Expr] 43 | Vector [Expr]
13 | DottedList [Expr] Expr 44 | DottedList [Expr] Expr
14 | StringLiteral String 45 | StringLiteral String
15 | IntLiteral Integer 46 | Number LispNumber
16 | FloatLiteral Double
17 | BoolLiteral Bool 47 | BoolLiteral Bool
18 | Id String 48 | Id String
49 | Function { params :: [String]
50 , body :: Expr
51 , extendedEnv :: Env
52 }
19 deriving (Eq) 53 deriving (Eq)
20 54
21data Function =
22 Function {
23 params :: [String]
24 , body :: Expr
25 , environment :: Env
26 }
27
28type Env = IORef [(String, IORef Expr)] 55type Env = IORef [(String, IORef Expr)]
29 56
30showLispList :: [Expr] -> String 57showLispList :: [Expr] -> String
@@ -35,8 +62,8 @@ instance Show Expr where
35 show (List xs) = "(" ++ showLispList xs ++ ")" 62 show (List xs) = "(" ++ showLispList xs ++ ")"
36 show (Vector xs) = "#(" ++ showLispList xs ++ ")" 63 show (Vector xs) = "#(" ++ showLispList xs ++ ")"
37 show (StringLiteral s) = "\"" ++ s ++ "\"" 64 show (StringLiteral s) = "\"" ++ s ++ "\""
38 show (IntLiteral n) = show n 65 show (Number (I n)) = show n
39 show (FloatLiteral n) = show n 66 show (Number (F n)) = show n
40 show (BoolLiteral True) = "#t" 67 show (BoolLiteral True) = "#t"
41 show (BoolLiteral False) = "#f" 68 show (BoolLiteral False) = "#f"
42 show (Id i) = i 69 show (Id i) = i
diff --git a/src/Environment.hs b/src/Environment.hs
index b7b7ee6..e38e36c 100644
--- a/src/Environment.hs
+++ b/src/Environment.hs
@@ -64,5 +64,4 @@ makeBind (var, val) = do
64manyBindings :: Env -> [(String, Expr)] -> IO Env 64manyBindings :: Env -> [(String, Expr)] -> IO Env
65manyBindings env binds = do 65manyBindings env binds = do
66 ptr <- readIORef env 66 ptr <- readIORef env
67 extendedEnv <- (++ ptr) <$> mapM makeBind binds 67 newIORef =<< (++ ptr) <$> mapM makeBind binds
68 newIORef extendedEnv
diff --git a/src/Evaluator.hs b/src/Evaluator.hs
index 3bc1e09..db56068 100644
--- a/src/Evaluator.hs
+++ b/src/Evaluator.hs
@@ -9,12 +9,13 @@ import Error.Base (LispError (..), LispResult (..),
9 unwrap) 9 unwrap)
10import Operators 10import Operators
11import Text.ParserCombinators.Parsec 11import Text.ParserCombinators.Parsec
12import qualified Data.Map as M
12 13
13apply :: String -> [Expr] -> LispResult Expr 14apply :: String -> [Expr] -> LispResult Expr
14apply fn args = maybe 15apply fn args = maybe
15 (throwError $ UnknownFunction fn) 16 (throwError $ UnknownFunction fn)
16 ($ args) 17 ($ args)
17 (lookup fn primitives) 18 (M.lookup fn primitives)
18 19
19evalUnquoteSplicing :: Env -> Expr -> IOResult Expr 20evalUnquoteSplicing :: Env -> Expr -> IOResult Expr
20evalUnquoteSplicing env (List xs) = List <$> mapM (eval env) xs 21evalUnquoteSplicing env (List xs) = List <$> mapM (eval env) xs
@@ -39,10 +40,8 @@ evalQuasiQuote env literal = return literal -- just behave like quote other
39 40
40eval :: Env -> Expr -> IOResult Expr 41eval :: Env -> Expr -> IOResult Expr
41eval _ v@(StringLiteral s) = return v 42eval _ v@(StringLiteral s) = return v
42eval _ v@(IntLiteral i) = return v 43eval _ v@(Number i) = return v
43eval _ v@(BoolLiteral b) = return v
44eval env (Id l) = getVar env l 44eval env (Id l) = getVar env l
45eval _ v@(FloatLiteral f) = return v
46eval env v@(Vector xs) = Vector <$> mapM (eval env) xs 45eval env v@(Vector xs) = Vector <$> mapM (eval env) xs
47eval env (List[Id "quote", val]) = return val 46eval env (List[Id "quote", val]) = return val
48eval env (List[Id "quasiquote", val]) = evalQuasiQuote env val 47eval env (List[Id "quasiquote", val]) = evalQuasiQuote env val
@@ -50,6 +49,7 @@ eval env v@(List[Id "unquote", val]) = throwError $ BadForm "Cannot use
50eval env v@(List[Id "unquote-splicing", val]) = throwError $ BadForm "Cannot use `unquote-splicing` outside quasiquote form" v 49eval env v@(List[Id "unquote-splicing", val]) = throwError $ BadForm "Cannot use `unquote-splicing` outside quasiquote form" v
51eval env (List [Id "set!", Id var, val]) = eval env val >>= uncurry (*>) . (setVar env var &&& pure) 50eval env (List [Id "set!", Id var, val]) = eval env val >>= uncurry (*>) . (setVar env var &&& pure)
52eval env (List [Id "define", Id var, val]) = eval env val >>= uncurry (*>) . (defineVar env var &&& pure) 51eval env (List [Id "define", Id var, val]) = eval env val >>= uncurry (*>) . (defineVar env var &&& pure)
52-- eval env (List (Id "lambda":List params:body)) = evalLambda params body env
53eval env (List (Id fn : args)) = mapM (eval env) args >>= liftLispResult . apply fn 53eval env (List (Id fn : args)) = mapM (eval env) args >>= liftLispResult . apply fn
54 54
55-- handle bad forms 55-- handle bad forms
@@ -58,3 +58,7 @@ eval env invalidForm = throwError $ BadForm "lisk can't recognize this form" inv
58unwrapList :: Expr -> [Expr] 58unwrapList :: Expr -> [Expr]
59unwrapList (List x) = x 59unwrapList (List x) = x
60unwrapList literal = [literal] 60unwrapList literal = [literal]
61
62-- evalLambda :: [Expr] -> Expr -> Env -> IOResult Expr
63-- evalLambda params body env = do
64-- extendedEnv <- manyBindings env
diff --git a/src/Parser.hs b/src/Parser.hs
index dfc3225..48dca0e 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -7,7 +7,7 @@ module Parser ( parseLispValue
7 , parseComment 7 , parseComment
8 ) where 8 ) where
9 9
10import Base (Expr (..), Function) 10import Base (Expr (..), LispNumber(..))
11import Control.Applicative ((<$>)) 11import Control.Applicative ((<$>))
12import Control.Monad (void) 12import Control.Monad (void)
13import Text.Parsec.Char 13import Text.Parsec.Char
@@ -34,7 +34,7 @@ parseInt :: Parser Expr
34parseInt = do 34parseInt = do
35 sign <- parseSign 35 sign <- parseSign
36 val <- many1 digit 36 val <- many1 digit
37 return $ (IntLiteral . read) $ maybe val (:val) sign 37 return $ (Number . I . read) $ maybe val (:val) sign
38 38
39parseFloat :: Parser Expr 39parseFloat :: Parser Expr
40parseFloat = do 40parseFloat = do
@@ -43,7 +43,7 @@ parseFloat = do
43 char '.' 43 char '.'
44 mantissa <- many1 digit 44 mantissa <- many1 digit
45 let fval = characteristic ++ "." ++ mantissa 45 let fval = characteristic ++ "." ++ mantissa
46 return $ (FloatLiteral . read) $ maybe fval (:fval) sign 46 return $ (Number . F . read) $ maybe fval (:fval) sign
47 47
48parseVector :: Parser Expr 48parseVector :: Parser Expr
49parseVector = do 49parseVector = do
@@ -112,6 +112,4 @@ parseLispValue =
112 optionalWhiteSpace >> char ')' 112 optionalWhiteSpace >> char ')'
113 return $ maybe (List x) (DottedList x) t 113 return $ maybe (List x) (DottedList x) t
114 <?> "lisp value"; 114 <?> "lisp value";
115 -- try parseComment;
116 -- return pepe;
117 115