refactor LispNumber into Base, improve numerical calculationsHEADmaster

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 @@
 module Base (Expr (..)
             , Env (..)
-            , Function (..)
+            , LispNumber (..)
             ) where
 
 import           Data.IORef
 
+data LispNumber = I Integer
+                | F Double
+                deriving (Eq, Ord)
+
+instance Num LispNumber where
+    -- addition
+    (I a) + (I b) = I $ a + b
+    (F a) + (F b) = F $ a + b
+    (F a) + (I b) = F $ a + fromIntegral b
+    (I a) + (F b) = F b + I a
+
+    -- subtraction
+    (I a) - (I b) = I $ a - b
+    (F a) - (F b) = F $ a - b
+    (F a) - (I b) = F $ a - fromIntegral b
+    (I a) - (F b) = F b - I a
+
+    -- multiplication
+    (I a) * (I b) = I $ a * b
+    (F a) * (F b) = F $ a * b
+    (F a) * (I b) = F $ a * fromIntegral b
+    (I a) * (F b) = F b * I a
+
+instance Fractional LispNumber where
+    (I a) / (I b) = F $ fromIntegral a / fromIntegral b
+    (F a) / (I b) = F $ a / fromIntegral b
+    (I a) / (F b) = recip $ F b / I a
+    (F a) / (F b) = F $ a / b
+    recip (F x) = F $ 1 / x
+    recip (I x) = F $ 1 / fromIntegral x
+
 -- TODO: use LispNumber (src/Operators.hs) here instead of IntLiteral and FloatLiteral
 -- TODO: add character literals: \#a \#b \#c \#space \#newline
 -- TODO: add support for complex numbers, oct and hex numbers
@@ -12,19 +43,15 @@ data Expr = List [Expr]
           | Vector [Expr]
           | DottedList [Expr] Expr
           | StringLiteral String
-          | IntLiteral Integer
-          | FloatLiteral Double
+          | Number LispNumber
           | BoolLiteral Bool
           | Id String
+          | Function { params      :: [String]
+                     , body        :: Expr
+                     , extendedEnv :: Env
+                     }
           deriving (Eq)
 
-data Function =
-    Function {
-    params        :: [String]
-    , body        :: Expr
-    , environment :: Env
-    }
-
 type Env = IORef [(String, IORef Expr)]
 
 showLispList :: [Expr] -> String
@@ -35,8 +62,8 @@ instance Show Expr where
     show (List xs)           = "(" ++ showLispList xs ++ ")"
     show (Vector xs)         = "#(" ++ showLispList xs ++ ")"
     show (StringLiteral s)   = "\"" ++ s ++ "\""
-    show (IntLiteral n)      = show n
-    show (FloatLiteral n)    = show n
+    show (Number (I n))      = show n
+    show (Number (F n))      = show n
     show (BoolLiteral True)  = "#t"
     show (BoolLiteral False) = "#f"
     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
 manyBindings :: Env -> [(String, Expr)] -> IO Env
 manyBindings env binds = do
     ptr <- readIORef env
-    extendedEnv <- (++ ptr) <$> mapM makeBind binds
-    newIORef extendedEnv
+    newIORef =<< (++ ptr) <$> mapM makeBind binds
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 (..),
                                                 unwrap)
 import           Operators
 import           Text.ParserCombinators.Parsec
+import qualified Data.Map as M
 
 apply :: String -> [Expr] -> LispResult Expr
 apply fn args = maybe
     (throwError $ UnknownFunction fn)
     ($ args)
-    (lookup fn primitives)
+    (M.lookup fn primitives)
 
 evalUnquoteSplicing :: Env -> Expr -> IOResult Expr
 evalUnquoteSplicing env (List xs) = List <$> mapM (eval env) xs
@@ -39,10 +40,8 @@ evalQuasiQuote env literal      = return literal -- just behave like quote other
 
 eval :: Env -> Expr -> IOResult Expr
 eval _ v@(StringLiteral s)                    = return v
-eval _ v@(IntLiteral i)                       = return v
-eval _ v@(BoolLiteral b)                      = return v
+eval _ v@(Number i)                           = return v
 eval env (Id l)                               = getVar env l
-eval _ v@(FloatLiteral f)                     = return v
 eval env v@(Vector xs)                        = Vector <$> mapM (eval env) xs
 eval env (List[Id "quote", val])              = return val
 eval env (List[Id "quasiquote", val])         = evalQuasiQuote env val
@@ -50,6 +49,7 @@ eval env v@(List[Id "unquote", val])          = throwError $ BadForm "Cannot use
 eval env v@(List[Id "unquote-splicing", val]) = throwError $ BadForm "Cannot use `unquote-splicing` outside quasiquote form" v
 eval env (List [Id "set!", Id var, val]) = eval env val >>= uncurry (*>) . (setVar env var &&& pure)
 eval env (List [Id "define", Id var, val]) = eval env val >>= uncurry (*>) . (defineVar env var &&& pure)
+-- eval env (List (Id "lambda":List params:body)) = evalLambda params body env
 eval env (List (Id fn : args))        = mapM (eval env) args >>= liftLispResult . apply fn
 
 -- handle bad forms
@@ -58,3 +58,7 @@ eval env invalidForm = throwError $ BadForm "lisk can't recognize this form" inv
 unwrapList :: Expr -> [Expr]
 unwrapList (List x) = x
 unwrapList literal  = [literal]
+
+-- evalLambda :: [Expr] -> Expr -> Env -> IOResult Expr
+-- evalLambda params body env = do
+--     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
               , parseComment
               ) where
 
-import           Base                          (Expr (..), Function)
+import           Base                          (Expr (..), LispNumber(..))
 import           Control.Applicative           ((<$>))
 import           Control.Monad                 (void)
 import           Text.Parsec.Char
@@ -34,7 +34,7 @@ parseInt :: Parser Expr
 parseInt = do
     sign <- parseSign
     val <- many1 digit
-    return $ (IntLiteral . read) $ maybe val (:val) sign
+    return $ (Number . I . read) $ maybe val (:val) sign
 
 parseFloat :: Parser Expr
 parseFloat = do
@@ -43,7 +43,7 @@ parseFloat = do
     char '.'
     mantissa <- many1 digit
     let fval = characteristic ++ "." ++ mantissa
-    return $ (FloatLiteral . read) $ maybe fval (:fval) sign
+    return $ (Number . F . read) $ maybe fval (:fval) sign
 
 parseVector :: Parser Expr
 parseVector = do
@@ -112,6 +112,4 @@ parseLispValue =
         optionalWhiteSpace >> char ')'
         return $ maybe (List x) (DottedList x) t
     <?> "lisp value";
-    -- try parseComment;
-    -- return pepe;