zoriya/HAL
1
0
Fork 0
mirror of https://github.com/zoriya/HAL.git synced 2025-12-06 06:36:09 +00:00
Code Issues Packages Projects Releases Wiki Activity

Reworking procedures

Browse Source
This commit is contained in:
Zoe Roux
2021-11-09 15:32:12 +01:00
parent 7c1da5eef7
commit f82381c1bc
5 changed files with 88 additions and 125 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
app/Main.hs
View File

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

17
src/Evaluator.hs
View File

@@ -1,5 +1,6 @@
module Evaluator where module Evaluator where
import Expressions import Expressions
import Expressions (Atom(AProcedure))
eval :: Statement -> LispEnv -> Either String (Atom, LispEnv) eval :: Statement -> LispEnv -> Either String (Atom, LispEnv)
eval (Expr expr) env = evalS expr env 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 "define")):xs)) env = evalDefine xs env
evalS (SExpr ((Atom (ASymbol "lambda")):xs)) env = evalLambda 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 "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 evalS (SExpr ((Atom (AProcedure n dArgs body)):args)) env = do
localEnv <- setupLocalVars dArgs args env localEnv <- setupLocalVars dArgs args env
evalS body localEnv 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 ((Atom (ASymbol name)):xs)) env = evalSymbol name xs env
evalS (SExpr (Expr nested:args)) env = do evalS (SExpr (Expr nested:args)) env = do
(atom, nEnv) <- evalS nested env (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 :: String -> [Statement] -> LispEnv -> Either String (Atom, LispEnv)
evalSymbol name args env = evalSymbol name args env =
case getSymbolValue name env of 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 (Just (AProcedure n dArgs body)) -> do
nEnv <- setupLocalVars dArgs args env nEnv <- setupLocalVars dArgs args env
evalS body nEnv evalS body nEnv
@@ -101,4 +103,13 @@ evalLet [Expr (SExpr vars), Expr body] env = do
return ((name, atom):rest) return ((name, atom):rest)
evaluateVars [] env = Right env evaluateVars [] env = Right env
evaluateVars (x:_) env = Left $ "**Error: invalid variable definition" ++ show x ++ " in let.**" 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.**"

4
src/Expressions.hs
View File

@@ -1,5 +1,7 @@
module Expressions where module Expressions where
type ProcedureFunc = [Atom] -> LispEnv -> Either String (Atom, LispEnv)
data Atom = data Atom =
AInt Int | AInt Int |
ASymbol String | ASymbol String |
@@ -9,7 +11,7 @@ data Atom =
ANil | ANil |
AQuote Atom | AQuote Atom |
AProcedure String [String] SExpr | AProcedure String [String] SExpr |
ABuiltin String ([Statement] -> LispEnv -> Either String (Atom, LispEnv)) | ABuiltin String ProcedureFunc |
ATrue | ATrue |
AFalse | AFalse |
ANothing ANothing

87
src/LispEnv.hs
View File

@@ -10,72 +10,41 @@ defaultEnv = [
("car", ABuiltin "car" evalCar), ("car", ABuiltin "car" evalCar),
("cdr", ABuiltin "cdr" evalCdr), ("cdr", ABuiltin "cdr" evalCdr),
("eq?", ABuiltin "eq?" evalEq), ("eq?", ABuiltin "eq?" evalEq),
("atom?", ABuiltin "atom?" evalAtom), ("atom?", ABuiltin "atom?" evalAtom)
("cond", ABuiltin "cond" evalCond)
] ++ mathEnv ] ++ mathEnv
evalCons :: [Statement] -> LispEnv -> Either String (Atom, LispEnv) evalCons :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
evalCons [first, second] env = do evalCons [first, second] env = Right (ACons first second, env)
(fAtom, fEnv) <- eval first env
(sAtom, sEnv) <- eval second fEnv
return (ACons fAtom sAtom, sEnv)
evalCons args _ = Left $ "**Error: cons expect 2 arguments. " ++ show (length args) ++ " where found.**" evalCons args _ = Left $ "**Error: cons expect 2 arguments. " ++ show (length args) ++ " where found.**"
evalCar :: [Statement] -> LispEnv -> Either String (Atom, LispEnv) evalCar :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
evalCar [Atom (ACons f _)] env = Right (f, env) evalCar [ACons f _] env = Right (f, env)
evalCar [Expr expr] env = do evalCar [bad] _ = Left $ "**Error: " ++ show bad ++ " is not a pair.**"
(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 _ _ = Left "**Error: incorect argument count in car**" evalCar _ _ = Left "**Error: incorect argument count in car**"
evalCdr :: [Statement] -> LispEnv -> Either String (Atom, LispEnv) evalCdr :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
evalCdr [Atom (ACons _ s)] env = Right (s, env) evalCdr [ACons _ s] env = Right (s, env)
evalCdr [Expr expr] env = do evalCdr [bad] _ = Left $ "**Error: " ++ show bad ++ " is not a pair.**"
(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 _ _ = Left "**Error: incorect argument count in cdr**" evalCdr _ _ = Left "**Error: incorect argument count in cdr**"
evalEq :: [Statement] -> LispEnv -> Either String (Atom, LispEnv) evalEq :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
evalEq [Atom (AInt f), Atom (AInt s)] env = Right (_fromBool (f == s), env) evalEq [AInt f, AInt s] env = Right (_fromBool (f == s), env)
evalEq [Atom (ASymbol f), Atom (ASymbol s)] env = Right (_fromBool (f == s), env) evalEq [ASymbol f, 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 [AString f, 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 [AFloat f, AFloat s] env = Right (_fromBool(f == s), env)
evalEq [Atom (ACons _ _), _] env = Right (AFalse, env) evalEq [ACons _ _, _] env = Right (AFalse, env)
evalEq [Atom ANil, Atom ANil] env = Right (ATrue, env) evalEq [ANil, ANil] env = Right (ATrue, env)
evalEq [Atom (AProcedure f _ _), Atom (AProcedure s _ _)] env = Right (_fromBool (f == s), env) evalEq [AProcedure f _ _, AProcedure s _ _] env = Right (_fromBool (f == s), env)
evalEq [Atom (ABuiltin f _), Atom (ABuiltin s _)] env = Right (_fromBool (f == s), env) evalEq [ABuiltin f _, ABuiltin s _] env = Right (_fromBool (f == s), env)
evalEq [Atom ATrue, Atom ATrue] env = Right (ATrue, env) evalEq [ATrue, ATrue] env = Right (ATrue, env)
evalEq [Atom AFalse, Atom AFalse] env = Right (ATrue, env) evalEq [AFalse, AFalse] env = Right (ATrue, env)
evalEq [Expr exp, other] env = do evalEq [AQuote quoted, other] env = evalEq [quoted, other] env
(first, nEnv) <- evalS exp env evalEq [other, AQuote quoted] env = evalEq [other, quoted] env
evalEq [Atom first, other] nEnv evalEq [_, _] env = Right (AFalse, env)
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 _ _ = Left "**Error: Invalid arguments in eq?**" evalEq _ _ = Left "**Error: Invalid arguments in eq?**"
evalAtom :: [Statement] -> LispEnv -> Either String (Atom, LispEnv) evalAtom :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
evalAtom [Atom (ACons _ _)] env = Right (AFalse, env) evalAtom [ACons _ _] env = Right (AFalse, env)
evalAtom [Atom (AQuote quoted)] env = evalAtom [Atom quoted] env evalAtom [AQuote quoted] env = evalAtom [quoted] env
evalAtom [Expr expr] env = do evalAtom [_] env = Right (ATrue, env)
(atm, nEnv) <- evalS expr env evalAtom _ _ = Left "**Error: Invalid arguments in atom?**"
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.**"

95
src/Maths.hs
View File

@@ -12,78 +12,57 @@ mathEnv = [
("<", ABuiltin "<" evalLessThan) ("<", ABuiltin "<" evalLessThan)
] ]
evalPlus :: [Statement] -> LispEnv -> Either String (Atom, LispEnv) evalPlus :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
evalPlus (x:xs) env = do evalPlus (x:xs) env = do
(value, nEnv) <- eval x env (rest, nEnv) <- evalPlus xs env
(rest, nnEnv) <- evalPlus xs nEnv case (x, rest) of
case (value, rest) of (AInt f, AInt s) -> Right (AInt $ f + s, nEnv)
(AInt f, AInt s) -> Right (AInt $ f + s, nnEnv) (AFloat f, AFloat s) -> Right (AFloat $ f + s, nEnv)
(AFloat f, AFloat s) -> Right (AFloat $ f + s, nnEnv) (AFloat f, AInt s) -> Right (AFloat $ f + fromIntegral s, nEnv)
(AFloat f, AInt s) -> Right (AFloat $ f + fromIntegral s, nnEnv) (AInt f, AFloat s) -> Right (AFloat $ fromIntegral f + s, nEnv)
(AInt f, AFloat s) -> Right (AFloat $ fromIntegral f + s, nnEnv)
(value, _) -> Left $ "**Error: \"" ++ show value ++ "\" is not a number **" (value, _) -> Left $ "**Error: \"" ++ show value ++ "\" is not a number **"
evalPlus [] env = Right (AInt 0, env) 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 evalMinus (x:xs) env = do
(value, nEnv) <- eval x env (rest, nEnv) <- evalPlus xs env
(rest, nnEnv) <- evalPlus xs nEnv case (x, rest) of
case (value, rest) of (AInt f, AInt s) -> Right (AInt $ f - s, nEnv)
(AInt f, AInt s) -> Right (AInt $ f - s, nnEnv) (AFloat f, AFloat s) -> Right (AFloat $ f - s, nEnv)
(AFloat f, AFloat s) -> Right (AFloat $ f - s, nnEnv) (AFloat f, AInt s) -> Right (AFloat $ f - fromIntegral s, nEnv)
(AFloat f, AInt s) -> Right (AFloat $ f - fromIntegral s, nnEnv) (AInt f, AFloat s) -> Right (AFloat $ fromIntegral f - s, nEnv)
(AInt f, AFloat s) -> Right (AFloat $ fromIntegral f - s, nnEnv)
(value, _) -> Left $ "**Error: \"" ++ show value ++ "\" is not a number **" (value, _) -> Left $ "**Error: \"" ++ show value ++ "\" is not a number **"
evalMinus [] env = Right (AInt 0, env) 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 evalMult (x:xs) env = do
(value, nEnv) <- eval x env (rest, nEnv) <- evalPlus xs env
(rest, nnEnv) <- evalPlus xs nEnv case (x, rest) of
case (value, rest) of (AInt f, AInt s) -> Right (AInt $ f * s, nEnv)
(AInt f, AInt s) -> Right (AInt $ f * s, nnEnv) (AFloat f, AFloat s) -> Right (AFloat $ f * s, nEnv)
(AFloat f, AFloat s) -> Right (AFloat $ f * s, nnEnv) (AFloat f, AInt s) -> Right (AFloat $ f * fromIntegral s, nEnv)
(AFloat f, AInt s) -> Right (AFloat $ f * fromIntegral s, nnEnv) (AInt f, AFloat s) -> Right (AFloat $ fromIntegral f * s, nEnv)
(AInt f, AFloat s) -> Right (AFloat $ fromIntegral f * s, nnEnv)
(value, _) -> Left $ "**Error: \"" ++ show value ++ "\" is not a number **" (value, _) -> Left $ "**Error: \"" ++ show value ++ "\" is not a number **"
evalMult [] env = Right (AInt 1, env) evalMult [] env = Right (AInt 1, env)
evalDiv :: [Statement] -> LispEnv -> Either String (Atom, LispEnv) evalDiv :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
evalDiv [_, Atom (AInt 0)] env = Left "**Error: Division by 0 is undefined.**" evalDiv [_, AInt 0] env = Left "**Error: Division by 0 is undefined.**"
evalDiv [_, Atom (AFloat 0)] env = Left "**Error: Division by 0 is undefined.**" evalDiv [_, 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 [AInt f, AInt s] env = Right (AInt (f `quot` s), env)
evalDiv [Atom (AFloat f), Atom (AFloat s)] env = Right (AFloat (f / s), env) evalDiv [AFloat f, AFloat s] env = Right (AFloat (f / s), env)
evalDiv [Atom (AFloat f), Atom (AInt s)] env = Right (AFloat (f / fromIntegral s), env) evalDiv [AFloat f, AInt s] env = Right (AFloat (f / fromIntegral s), env)
evalDiv [Atom (AInt f), Atom (AFloat s)] env = Right (AFloat (fromIntegral f / s), env) evalDiv [AInt f, 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 _ _ = Left "**Error: Invalid arguments in div.**" evalDiv _ _ = Left "**Error: Invalid arguments in div.**"
evalMod :: [Statement] -> LispEnv -> Either String (Atom, LispEnv) evalMod :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
evalMod [_, Atom (AInt 0)] env = Left "**Error: mod by 0 is undefined.**" evalMod [_, AInt 0] env = Left "**Error: mod by 0 is undefined.**"
evalMod [_, Atom (AFloat 0)] env = Left "**Error: mod by 0 is undefined.**" evalMod [_, 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 [AInt f, 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 _ _ = Left "**Error: Invalid arguments in mod.**" evalMod _ _ = Left "**Error: Invalid arguments in mod.**"
evalLessThan :: [Statement] -> LispEnv -> Either String (Atom, LispEnv) evalLessThan :: [Atom] -> LispEnv -> Either String (Atom, LispEnv)
evalLessThan [Atom (AInt f), Atom (AInt s)] env = Right (_fromBool (f < s), env) evalLessThan [AInt f, AInt s] env = Right (_fromBool (f < s), env)
evalLessThan [Atom (AFloat f), Atom (AFloat s)] env = Right (_fromBool (f < s), env) evalLessThan [AFloat f, AFloat s] env = Right (_fromBool (f < s), env)
evalLessThan [Atom (AFloat f), Atom (AInt s)] env = Right (_fromBool (f < fromIntegral s), env) evalLessThan [AFloat f, AInt s] env = Right (_fromBool (f < fromIntegral s), env)
evalLessThan [Atom (AInt f), Atom (AFloat s)] env = Right (_fromBool (fromIntegral f < s), env) evalLessThan [AInt f, 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 _ _ = Left "**Error: Invalid arguments in <.**" evalLessThan _ _ = Left "**Error: Invalid arguments in <.**"