Reworking procedures

2025-12-06 06:36:09 +00:00 · 2021-11-09 15:32:12 +01:00
parent 7c1da5eef7
commit f82381c1bc
5 changed files with 88 additions and 125 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -39,7 +39,7 @@ evalFiles [x] env = evalFile x env
 evalFiles (x:xs) env = do
    (ret, nEnv) <- evalFile x env
    evalFiles xs nEnv
-evalFiles [] env = undefined
+evalFiles [] env = Right (ANothing, env)

 evalFile :: String -> LispEnv -> Either String (Atom, LispEnv)
 evalFile file env =
@@ -60,8 +60,9 @@ main = do
    (args, repl) <- parseArgs <$> getArgs
    files <- catch (sequence $ readFile <$> args) handler
    case evalFiles files defaultEnv of
-         Right (ret, env) -> if repl then runRepl env else print ret
-         Left err         -> putStrLn err >> exitWith (ExitFailure 84)
+         Right (ANothing, env) -> if repl then runRepl env else exitSuccess
+         Right (ret, env)      -> if repl then runRepl env else print ret
+         Left err              -> putStrLn err >> exitWith (ExitFailure 84)
    where
        handler :: IOException -> IO [String]
        handler e = putStrLn ("Error: " ++ show e) >> exitWith (ExitFailure 84)
@@ -69,6 +70,7 @@ main = do
        parseArgs :: [String] -> ([String], Bool)
        parseArgs ("-i":xs) = let (files, _) = parseArgs xs
                              in (files, True)
+        parseArgs [x]       = ([x], False)
        parseArgs (x:xs)    = let (files, repl) = parseArgs xs
                              in (x:files, repl)
-        parseArgs []        = ([], False)
+        parseArgs []        = ([], True)
--- a/src/Evaluator.hs
+++ b/src/Evaluator.hs
@@ -1,5 +1,6 @@
 module Evaluator where
 import Expressions
+import Expressions (Atom(AProcedure))

 eval :: Statement -> LispEnv -> Either String (Atom, LispEnv)
 eval (Expr expr) env = evalS expr env
@@ -22,10 +23,11 @@ evalS (SExpr [Atom (ASymbol "type"), x]) env = do
 evalS (SExpr ((Atom (ASymbol "define")):xs)) env = evalDefine xs env
 evalS (SExpr ((Atom (ASymbol "lambda")):xs)) env = evalLambda xs env
 evalS (SExpr ((Atom (ASymbol "let")):xs)) env = evalLet xs env
+evalS (SExpr ((Atom (ASymbol "cond")):xs)) env = evalCond xs env
 evalS (SExpr ((Atom (AProcedure n dArgs body)):args)) env = do
    localEnv <- setupLocalVars dArgs args env
    evalS body localEnv
-evalS (SExpr ((Atom (ABuiltin n func)):args)) env = func args env
+evalS (SExpr ((Atom (ABuiltin n func)):args)) env = func (eval <$> args) env
 evalS (SExpr ((Atom (ASymbol name)):xs)) env = evalSymbol name xs env
 evalS (SExpr (Expr nested:args)) env = do
    (atom, nEnv) <- evalS nested env
@@ -35,7 +37,7 @@ evalS expr _ = Left $ "**Error: couldn't evaluate " ++ show expr ++ "**"
 evalSymbol :: String -> [Statement] -> LispEnv -> Either String (Atom, LispEnv)
 evalSymbol name args env = 
    case getSymbolValue name env of
-         (Just (ABuiltin n func)) -> func args env
+         (Just (ABuiltin n func)) -> evalBuiltin func args env
         (Just (AProcedure n dArgs body)) -> do
             nEnv <- setupLocalVars dArgs args env
             evalS body nEnv
@@ -101,4 +103,13 @@ evalLet [Expr (SExpr vars), Expr body] env = do
            return ((name, atom):rest)
        evaluateVars [] env = Right env
        evaluateVars (x:_) env = Left $ "**Error: invalid variable definition" ++ show x ++ " in let.**"
-evalLet _ _ = Left "**Error: invalid syntax for let.**"
+evalLet _ _ = Left "**Error: invalid syntax for let.**"
+
+evalCond :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
+evalCond (Expr (SExpr [cond, value]):xs) env = do
+    (res, nEnv) <- eval cond env
+    case res of
+         AFalse -> evalCond xs nEnv
+         _ -> eval value nEnv
+evalCond [] env = Right (ANothing, env)
+evalCond _ _ = Left "**Error: Invalid syntax for cond.**"
--- a/src/Expressions.hs
+++ b/src/Expressions.hs
@@ -1,5 +1,7 @@
 module Expressions where

+type ProcedureFunc = [Atom] -> LispEnv -> Either String (Atom, LispEnv)
+
 data Atom =
    AInt Int |
    ASymbol String |
@@ -9,7 +11,7 @@ data Atom =
    ANil |
    AQuote Atom |
    AProcedure String [String] SExpr |
-    ABuiltin String ([Statement] -> LispEnv -> Either String (Atom, LispEnv)) |
+    ABuiltin String ProcedureFunc |
    ATrue |
    AFalse |
    ANothing
--- a/src/LispEnv.hs
+++ b/src/LispEnv.hs
@@ -10,72 +10,41 @@ defaultEnv = [
        ("car", ABuiltin "car" evalCar),
        ("cdr", ABuiltin "cdr" evalCdr),
        ("eq?", ABuiltin "eq?" evalEq),
-        ("atom?", ABuiltin "atom?" evalAtom),
-        ("cond", ABuiltin "cond" evalCond)
+        ("atom?", ABuiltin "atom?" evalAtom)
    ] ++ mathEnv

-evalCons :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
-evalCons [first, second] env = do
-    (fAtom, fEnv) <- eval first env
-    (sAtom, sEnv) <- eval second fEnv
-    return (ACons fAtom sAtom, sEnv)
+evalCons :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
+evalCons [first, second] env = Right (ACons first second, env)
 evalCons args _ = Left $ "**Error: cons expect 2 arguments. " ++ show (length args) ++ " where found.**"

-evalCar :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
-evalCar [Atom (ACons f _)] env = Right (f, env)
-evalCar [Expr expr] env = do
-    (atom, nEnv) <- evalS expr env
-    case atom of
-        (ACons f _) -> return (f, nEnv)
-        atom        -> Left $ "**Error: " ++ show atom ++ " is not a pair.**"
-evalCar [Atom bad] _ = Left $ "**Error: " ++ show bad ++ " is not a pair.**"
+evalCar :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
+evalCar [ACons f _] env = Right (f, env)
+evalCar [bad] _ = Left $ "**Error: " ++ show bad ++ " is not a pair.**"
 evalCar _ _ = Left "**Error: incorect argument count in car**"

-evalCdr :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
-evalCdr [Atom (ACons _ s)] env = Right (s, env)
-evalCdr [Expr expr] env = do
-    (atom, nEnv) <- evalS expr env
-    case atom of
-        (ACons _ s) -> return (s, nEnv)
-        atom        -> Left $ "**Error: " ++ show atom ++ " is not a pair.**"
-evalCdr [Atom bad] _ = Left $ "**Error: " ++ show bad ++ " is not a pair.**"
+evalCdr :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
+evalCdr [ACons _ s] env = Right (s, env)
+evalCdr [bad] _ = Left $ "**Error: " ++ show bad ++ " is not a pair.**"
 evalCdr _ _ = Left "**Error: incorect argument count in cdr**"

-evalEq :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
-evalEq [Atom (AInt f), Atom (AInt s)] env = Right (_fromBool (f == s), env)
-evalEq [Atom (ASymbol f), Atom (ASymbol s)] env = Right (_fromBool (f == s), env)
-evalEq [Atom (AString f), Atom (AString s)] env = Right (AFalse, env) -- TODO Should do a reference equal
-evalEq [Atom (AFloat f), Atom (AFloat s)] env = Right (_fromBool(f == s), env)
-evalEq [Atom (ACons _ _), _] env = Right (AFalse, env)
-evalEq [Atom ANil, Atom ANil] env = Right (ATrue, env)
-evalEq [Atom (AProcedure f _ _), Atom (AProcedure s _ _)] env = Right (_fromBool (f == s), env)
-evalEq [Atom (ABuiltin f _), Atom (ABuiltin s _)] env = Right (_fromBool (f == s), env)
-evalEq [Atom ATrue, Atom ATrue] env = Right (ATrue, env)
-evalEq [Atom AFalse, Atom AFalse] env = Right (ATrue, env)
-evalEq [Expr exp, other] env = do
-    (first, nEnv) <- evalS exp env
-    evalEq [Atom first, other] nEnv
-evalEq [other, Expr exp] env = do
-    (first, nEnv) <- evalS exp env
-    evalEq [other, Atom first] nEnv
-evalEq [Atom (AQuote quoted), other] env = evalEq [Atom quoted, other] env
-evalEq [other, Atom (AQuote quoted)] env = evalEq [other, Atom quoted] env
+evalEq :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
+evalEq [AInt f, AInt s] env = Right (_fromBool (f == s), env)
+evalEq [ASymbol f, ASymbol s] env = Right (_fromBool (f == s), env)
+evalEq [AString f, AString s] env = Right (AFalse, env) -- TODO Should do a reference equal
+evalEq [AFloat f, AFloat s] env = Right (_fromBool(f == s), env)
+evalEq [ACons _ _, _] env = Right (AFalse, env)
+evalEq [ANil, ANil] env = Right (ATrue, env)
+evalEq [AProcedure f _ _, AProcedure s _ _] env = Right (_fromBool (f == s), env)
+evalEq [ABuiltin f _, ABuiltin s _] env = Right (_fromBool (f == s), env)
+evalEq [ATrue, ATrue] env = Right (ATrue, env)
+evalEq [AFalse, AFalse] env = Right (ATrue, env)
+evalEq [AQuote quoted, other] env = evalEq [quoted, other] env
+evalEq [other, AQuote quoted] env = evalEq [other, quoted] env
+evalEq [_, _] env = Right (AFalse, env)
 evalEq _ _ = Left "**Error: Invalid arguments in eq?**"

-evalAtom :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
-evalAtom [Atom (ACons _ _)] env = Right (AFalse, env)
-evalAtom [Atom (AQuote quoted)] env = evalAtom [Atom quoted] env
-evalAtom [Expr expr] env = do
-    (atm, nEnv) <- evalS expr env
-    evalAtom [Atom atm] nEnv
-evalAtom [Atom _] env = Right (ATrue, env)
-evalAtom _ _ = Left "**Error: Invalid arguments in atom?**"
-
-evalCond :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
-evalCond (Expr (SExpr [cond, value]):xs) env = do
-    (res, nEnv) <- eval cond env
-    case res of
-         AFalse -> evalCond xs nEnv
-         _ -> eval value nEnv
-evalCond [] env = Right (ANothing, env)
-evalCond _ _ = Left "**Error: Invalid syntax for cond.**"
+evalAtom :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
+evalAtom [ACons _ _] env = Right (AFalse, env)
+evalAtom [AQuote quoted] env = evalAtom [quoted] env
+evalAtom [_] env = Right (ATrue, env)
+evalAtom _ _ = Left "**Error: Invalid arguments in atom?**"
--- a/src/Maths.hs
+++ b/src/Maths.hs
@@ -12,78 +12,57 @@ mathEnv = [
        ("<", ABuiltin "<" evalLessThan)
    ]

-evalPlus :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
+evalPlus :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
 evalPlus (x:xs) env = do
-    (value, nEnv) <- eval x env
-    (rest, nnEnv) <- evalPlus xs nEnv
-    case (value, rest) of
-         (AInt f, AInt s) -> Right (AInt $ f + s, nnEnv)
-         (AFloat f, AFloat s) -> Right (AFloat $ f + s, nnEnv)
-         (AFloat f, AInt s) -> Right (AFloat $ f + fromIntegral s, nnEnv)
-         (AInt f, AFloat s) -> Right (AFloat $ fromIntegral f + s, nnEnv)
+    (rest, nEnv) <- evalPlus xs env
+    case (x, rest) of
+         (AInt f, AInt s) -> Right (AInt $ f + s, nEnv)
+         (AFloat f, AFloat s) -> Right (AFloat $ f + s, nEnv)
+         (AFloat f, AInt s) -> Right (AFloat $ f + fromIntegral s, nEnv)
+         (AInt f, AFloat s) -> Right (AFloat $ fromIntegral f + s, nEnv)
         (value, _) -> Left $ "**Error: \"" ++ show value ++ "\" is not a number **"
 evalPlus [] env = Right (AInt 0, env)

-evalMinus :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
+evalMinus :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
 evalMinus (x:xs) env = do
-    (value, nEnv) <- eval x env
-    (rest, nnEnv) <- evalPlus xs nEnv
-    case (value, rest) of
-         (AInt f, AInt s) -> Right (AInt $ f - s, nnEnv)
-         (AFloat f, AFloat s) -> Right (AFloat $ f - s, nnEnv)
-         (AFloat f, AInt s) -> Right (AFloat $ f - fromIntegral s, nnEnv)
-         (AInt f, AFloat s) -> Right (AFloat $ fromIntegral f - s, nnEnv)
+    (rest, nEnv) <- evalPlus xs env
+    case (x, rest) of
+         (AInt f, AInt s) -> Right (AInt $ f - s, nEnv)
+         (AFloat f, AFloat s) -> Right (AFloat $ f - s, nEnv)
+         (AFloat f, AInt s) -> Right (AFloat $ f - fromIntegral s, nEnv)
+         (AInt f, AFloat s) -> Right (AFloat $ fromIntegral f - s, nEnv)
         (value, _) -> Left $ "**Error: \"" ++ show value ++ "\" is not a number **"
 evalMinus [] env = Right (AInt 0, env)

-evalMult :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
+evalMult :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
 evalMult (x:xs) env = do
-    (value, nEnv) <- eval x env
-    (rest, nnEnv) <- evalPlus xs nEnv
-    case (value, rest) of
-         (AInt f, AInt s) -> Right (AInt $ f * s, nnEnv)
-         (AFloat f, AFloat s) -> Right (AFloat $ f * s, nnEnv)
-         (AFloat f, AInt s) -> Right (AFloat $ f * fromIntegral s, nnEnv)
-         (AInt f, AFloat s) -> Right (AFloat $ fromIntegral f * s, nnEnv)
+    (rest, nEnv) <- evalPlus xs env
+    case (x, rest) of
+         (AInt f, AInt s) -> Right (AInt $ f * s, nEnv)
+         (AFloat f, AFloat s) -> Right (AFloat $ f * s, nEnv)
+         (AFloat f, AInt s) -> Right (AFloat $ f * fromIntegral s, nEnv)
+         (AInt f, AFloat s) -> Right (AFloat $ fromIntegral f * s, nEnv)
         (value, _) -> Left $ "**Error: \"" ++ show value ++ "\" is not a number **"
 evalMult [] env = Right (AInt 1, env)

-evalDiv :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
-evalDiv [_, Atom (AInt 0)] env = Left "**Error: Division by 0 is undefined.**"
-evalDiv [_, Atom (AFloat 0)] env = Left "**Error: Division by 0 is undefined.**"
-evalDiv [Atom (AInt f), Atom (AInt s)] env = Right (AInt (f `quot` s), env)
-evalDiv [Atom (AFloat f), Atom (AFloat s)] env = Right (AFloat (f / s), env)
-evalDiv [Atom (AFloat f), Atom (AInt s)] env = Right (AFloat (f / fromIntegral s), env)
-evalDiv [Atom (AInt f), Atom (AFloat s)] env = Right (AFloat (fromIntegral f / s), env)
-evalDiv [Expr expr, other] env = do
-    (res, nEnv) <- evalS expr env
-    evalDiv [Atom res, other] nEnv
-evalDiv [other, Expr expr] env = do
-    (res, nEnv) <- evalS expr env
-    evalDiv [other, Atom res] nEnv
+evalDiv :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
+evalDiv [_, AInt 0] env = Left "**Error: Division by 0 is undefined.**"
+evalDiv [_, AFloat 0] env = Left "**Error: Division by 0 is undefined.**"
+evalDiv [AInt f, AInt s] env = Right (AInt (f `quot` s), env)
+evalDiv [AFloat f, AFloat s] env = Right (AFloat (f / s), env)
+evalDiv [AFloat f, AInt s] env = Right (AFloat (f / fromIntegral s), env)
+evalDiv [AInt f, AFloat s] env = Right (AFloat (fromIntegral f / s), env)
 evalDiv _ _ = Left "**Error: Invalid arguments in div.**"

-evalMod :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
-evalMod [_, Atom (AInt 0)] env = Left "**Error: mod by 0 is undefined.**"
-evalMod [_, Atom (AFloat 0)] env = Left "**Error: mod by 0 is undefined.**"
-evalMod [Atom (AInt f), Atom (AInt s)] env = Right (AInt (f `mod` s), env)
-evalMod [Expr expr, other] env = do
-    (res, nEnv) <- evalS expr env
-    evalMod [Atom res, other] nEnv
-evalMod [other, Expr expr] env = do
-    (res, nEnv) <- evalS expr env
-    evalMod [other, Atom res] nEnv
+evalMod :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
+evalMod [_, AInt 0] env = Left "**Error: mod by 0 is undefined.**"
+evalMod [_, AFloat 0] env = Left "**Error: mod by 0 is undefined.**"
+evalMod [AInt f, AInt s] env = Right (AInt (f `mod` s), env)
 evalMod _ _ = Left "**Error: Invalid arguments in mod.**"

-evalLessThan :: [Statement] -> LispEnv -> Either String (Atom, LispEnv)
-evalLessThan [Atom (AInt f), Atom (AInt s)] env = Right (_fromBool (f < s), env)
-evalLessThan [Atom (AFloat f), Atom (AFloat s)] env = Right (_fromBool (f < s), env)
-evalLessThan [Atom (AFloat f), Atom (AInt s)] env = Right (_fromBool (f < fromIntegral s), env)
-evalLessThan [Atom (AInt f), Atom (AFloat s)] env = Right (_fromBool (fromIntegral f < s), env)
-evalLessThan [Expr expr, other] env = do
-    (res, nEnv) <- evalS expr env
-    evalLessThan [Atom res, other] nEnv
-evalLessThan [other, Expr expr] env = do
-    (res, nEnv) <- evalS expr env
-    evalLessThan [other, Atom res] nEnv
+evalLessThan :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
+evalLessThan [AInt f, AInt s] env = Right (_fromBool (f < s), env)
+evalLessThan [AFloat f, AFloat s] env = Right (_fromBool (f < s), env)
+evalLessThan [AFloat f, AInt s] env = Right (_fromBool (f < fromIntegral s), env)
+evalLessThan [AInt f, AFloat s] env = Right (_fromBool (fromIntegral f < s), env)
 evalLessThan _ _ = Left "**Error: Invalid arguments in <.**"