diff --git a/app/Main.hs b/app/Main.hs index f2f154e..3c0a319 100644 --- 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) \ No newline at end of file + parseArgs [] = ([], True) \ No newline at end of file diff --git a/src/Evaluator.hs b/src/Evaluator.hs index fe8e502..3308500 100644 --- 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.**" \ No newline at end of file +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.**" diff --git a/src/Expressions.hs b/src/Expressions.hs index c9a4ade..d57ec7d 100644 --- 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 diff --git a/src/LispEnv.hs b/src/LispEnv.hs index 37c62a1..2c33b9c 100644 --- 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.**" \ No newline at end of file +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?**" \ No newline at end of file diff --git a/src/Maths.hs b/src/Maths.hs index 0c2eb5c..d6ccba3 100644 --- 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 <.**" \ No newline at end of file