From c05d37609e18b31caafa7273e7af87e557fd378a Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Thu, 20 Apr 2023 14:30:08 +0200 Subject: [PATCH 1/6] purs: merge evalAst into eval and add DEBUG-EVAL See #592 for context. --- impls/purs/src/step2_eval.purs | 24 +++--- impls/purs/src/step3_env.purs | 53 +++++++------ impls/purs/src/step4_if_fn_do.purs | 71 +++++++++-------- impls/purs/src/step5_tco.purs | 71 +++++++++-------- impls/purs/src/step6_file.purs | 71 +++++++++-------- impls/purs/src/step7_quote.purs | 83 ++++++++++--------- impls/purs/src/step8_macros.purs | 116 ++++++++++++--------------- impls/purs/src/step9_try.purs | 123 ++++++++++++----------------- impls/purs/src/stepA_mal.purs | 123 ++++++++++++----------------- 9 files changed, 347 insertions(+), 388 deletions(-) diff --git a/impls/purs/src/step2_eval.purs b/impls/purs/src/step2_eval.purs index 3eb2ad1a2f..fc77088349 100644 --- a/impls/purs/src/step2_eval.purs +++ b/impls/purs/src/step2_eval.purs @@ -15,7 +15,7 @@ import Effect.Exception (throw, try) import Reader (readStr) import Printer (printStr) import Readline (readLine) -import Types (MalExpr(..), MalFn, toHashMap, toList, toVector) +import Types (MalExpr(..), MalFn, toHashMap, toVector) -- MAIN @@ -27,24 +27,22 @@ main = loop -- EVAL -eval :: MalExpr -> Effect MalExpr -eval ast@(MalList _ Nil) = pure ast -eval (MalList _ ast) = do - es <- traverse evalAst ast +evalCallFn :: List MalExpr -> Effect MalExpr +evalCallFn ast = do + es <- traverse eval ast case es of MalFunction {fn:f}: args -> f args - _ -> pure $ toList es -eval ast = evalAst ast + _ -> throw $ "invalid function" -evalAst :: MalExpr -> Effect MalExpr -evalAst (MalSymbol s) = case lookup s replEnv of +eval :: MalExpr -> Effect MalExpr +eval (MalSymbol s) = case lookup s replEnv of Just f -> pure f Nothing -> throw "invalid function" -evalAst ast@(MalList _ _ ) = eval ast -evalAst (MalVector _ es) = toVector <$> (traverse eval es) -evalAst (MalHashMap _ es) = toHashMap <$> (traverse eval es) -evalAst ast = pure ast +eval (MalList _ es@(_ : _)) = evalCallFn es +eval (MalVector _ es) = toVector <$> (traverse eval es) +eval (MalHashMap _ es) = toHashMap <$> (traverse eval es) +eval ast = pure ast diff --git a/impls/purs/src/step3_env.purs b/impls/purs/src/step3_env.purs index 12851a5d15..68820b4739 100644 --- a/impls/purs/src/step3_env.purs +++ b/impls/purs/src/step3_env.purs @@ -29,34 +29,41 @@ main = do -- EVAL -eval :: RefEnv -> MalExpr -> Effect MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - _ -> do - es <- traverse (evalAst env) ast +evalCallFn :: RefEnv -> List MalExpr -> Effect MalExpr +evalCallFn env ast = do + es <- traverse (eval env) ast case es of MalFunction {fn:f} : args -> f args _ -> throw "invalid function" -eval env ast = evalAst env ast -evalAst :: RefEnv -> MalExpr -> Effect MalExpr -evalAst env (MalSymbol s) = do - result <- Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" -evalAst env ast@(MalList _ _) = eval env ast -evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs -evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs -evalAst _ ast = pure ast +eval :: RefEnv -> MalExpr -> Effect MalExpr +eval env ast = do + dbgeval <- Env.get env "DEBUG-EVAL" + case dbgeval of + Nothing -> pure unit + Just MalNil -> pure unit + Just (MalBoolean false) -> pure unit + _ -> do + image <- print ast + log ("EVAL: " <> image) + case ast of + MalSymbol s -> do + result <- Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" + MalList _ (MalSymbol "def!" : es) -> evalDef env es + MalList _ (MalSymbol "let*" : es) -> evalLet env es + MalList _ es@(_ : _) -> evalCallFn env es + MalVector _ es -> toVector <$> traverse (eval env) es + MalHashMap _ es -> toHashMap <$> traverse (eval env) es + _ -> pure ast evalDef :: RefEnv -> List MalExpr -> Effect MalExpr evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e + evd <- eval env e Env.set env v evd pure evd evalDef _ _ = throw "invalid def!" @@ -66,18 +73,18 @@ evalLet :: RefEnv -> List MalExpr -> Effect MalExpr evalLet env (MalList _ ps : e : Nil) = do letEnv <- Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet env (MalVector _ ps : e : Nil) = do letEnv <- Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet _ _ = throw "invalid let*" letBind :: RefEnv -> List MalExpr -> Effect Unit letBind _ Nil = pure unit letBind env (MalSymbol ky : e : es) = do - Env.set env ky =<< evalAst env e + Env.set env ky =<< eval env e letBind env es letBind _ _ = throw "invalid let*" @@ -86,7 +93,7 @@ letBind _ _ = throw "invalid let*" -- REPL rep :: RefEnv -> String -> Effect String -rep env str = print =<< evalAst env =<< read str +rep env str = print =<< eval env =<< read str loop :: RefEnv -> Effect Unit diff --git a/impls/purs/src/step4_if_fn_do.purs b/impls/purs/src/step4_if_fn_do.purs index f048881862..8a208f1a44 100644 --- a/impls/purs/src/step4_if_fn_do.purs +++ b/impls/purs/src/step4_if_fn_do.purs @@ -33,37 +33,44 @@ main = do -- EVAL -eval :: RefEnv -> MalExpr -> Effect MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - _ -> do - es <- traverse (evalAst env) ast +evalCallFn :: RefEnv -> List MalExpr -> Effect MalExpr +evalCallFn env ast = do + es <- traverse (eval env) ast case es of MalFunction {fn:f} : args -> f args _ -> throw "invalid function" -eval env ast = evalAst env ast -evalAst :: RefEnv -> MalExpr -> Effect MalExpr -evalAst env (MalSymbol s) = do - result <- Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" -evalAst env ast@(MalList _ _) = eval env ast -evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs -evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs -evalAst _ ast = pure ast +eval :: RefEnv -> MalExpr -> Effect MalExpr +eval env ast = do + dbgeval <- Env.get env "DEBUG-EVAL" + case dbgeval of + Nothing -> pure unit + Just MalNil -> pure unit + Just (MalBoolean false) -> pure unit + _ -> do + image <- print ast + log ("EVAL: " <> image) + case ast of + MalSymbol s -> do + result <- Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" + MalList _ (MalSymbol "def!" : es) -> evalDef env es + MalList _ (MalSymbol "let*" : es) -> evalLet env es + MalList _ (MalSymbol "if" : es) -> evalIf env es + MalList _ (MalSymbol "do" : es) -> evalDo env es + MalList _ (MalSymbol "fn*" : es) -> evalFnMatch env es + MalList _ es@(_ : _) -> evalCallFn env es + MalVector _ es -> toVector <$> traverse (eval env) es + MalHashMap _ es -> toHashMap <$> traverse (eval env) es + _ -> pure ast evalDef :: RefEnv -> List MalExpr -> Effect MalExpr evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e + evd <- eval env e Env.set env v evd pure evd evalDef _ _ = throw "invalid def!" @@ -73,11 +80,11 @@ evalLet :: RefEnv -> List MalExpr -> Effect MalExpr evalLet env (MalList _ ps : e : Nil) = do letEnv <- Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet env (MalVector _ ps : e : Nil) = do letEnv <- Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet _ _ = throw "invalid let*" @@ -85,21 +92,21 @@ evalLet _ _ = throw "invalid let*" letBind :: RefEnv -> List MalExpr -> Effect Unit letBind _ Nil = pure unit letBind env (MalSymbol ky : e : es) = do - Env.set env ky =<< evalAst env e + Env.set env ky =<< eval env e letBind env es letBind _ _ = throw "invalid let*" evalIf :: RefEnv -> List MalExpr -> Effect MalExpr evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> e MalBoolean false -> e _ -> t evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> MalNil MalBoolean false -> MalNil _ -> t @@ -107,7 +114,7 @@ evalIf _ _ = throw "invalid if" evalDo :: RefEnv -> List MalExpr -> Effect MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es +evalDo env es = foldM (const $ eval env) MalNil es evalFnMatch :: RefEnv -> List MalExpr -> Effect MalExpr @@ -133,7 +140,7 @@ evalFn env params body = do fnEnv <- Env.newEnv env ok <- Env.sets fnEnv params' args if ok - then evalAst fnEnv body' + then eval fnEnv body' else throw "actual parameters do not match signature " unwrapSymbol :: MalExpr -> Effect String @@ -145,7 +152,7 @@ evalFn env params body = do -- REPL rep :: RefEnv -> String -> Effect String -rep env str = print =<< evalAst env =<< read str +rep env str = print =<< eval env =<< read str loop :: RefEnv -> Effect Unit diff --git a/impls/purs/src/step5_tco.purs b/impls/purs/src/step5_tco.purs index dcf3880da7..14870f5fff 100644 --- a/impls/purs/src/step5_tco.purs +++ b/impls/purs/src/step5_tco.purs @@ -43,32 +43,35 @@ main = do -- EVAL eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env (MalSymbol s) = do - result <- liftEffect $ Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" -evalAst env ast@(MalList _ _) = eval env ast -evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs -evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs -evalAst _ ast = pure ast +eval env ast = do + dbgeval <- liftEffect (Env.get env "DEBUG-EVAL") + liftEffect case dbgeval of + Nothing -> pure unit + Just MalNil -> pure unit + Just (MalBoolean false) -> pure unit + _ -> do + image <- print ast + log ("EVAL: " <> image) + case ast of + MalSymbol s -> do + result <- liftEffect $ Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" + MalList _ (MalSymbol "def!" : es) -> evalDef env es + MalList _ (MalSymbol "let*" : es) -> evalLet env es + MalList _ (MalSymbol "if" : es) -> evalIf env es + MalList _ (MalSymbol "do" : es) -> evalDo env es + MalList _ (MalSymbol "fn*" : es) -> evalFnMatch env es + MalList _ es@(_ : _) -> evalCallFn env es + MalVector _ es -> toVector <$> traverse (eval env) es + MalHashMap _ es -> toHashMap <$> traverse (eval env) es + _ -> pure ast evalDef :: RefEnv -> List MalExpr -> Eval MalExpr evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e + evd <- eval env e liftEffect $ Env.set env v evd pure evd evalDef _ _ = throw "invalid def!" @@ -78,11 +81,11 @@ evalLet :: RefEnv -> List MalExpr -> Eval MalExpr evalLet env (MalList _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet env (MalVector _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet _ _ = throw "invalid let*" @@ -90,7 +93,7 @@ evalLet _ _ = throw "invalid let*" letBind :: RefEnv -> List MalExpr -> Eval Unit letBind _ Nil = pure unit letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e + ex <- eval env e liftEffect $ Env.set env ky ex letBind env es letBind _ _ = throw "invalid let*" @@ -98,14 +101,14 @@ letBind _ _ = throw "invalid let*" evalIf :: RefEnv -> List MalExpr -> Eval MalExpr evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> e MalBoolean false -> e _ -> t evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> MalNil MalBoolean false -> MalNil _ -> t @@ -113,7 +116,7 @@ evalIf _ _ = throw "invalid if" evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es +evalDo env es = foldM (const $ eval env) MalNil es evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr @@ -139,7 +142,7 @@ evalFn env params body = do fnEnv <- Env.newEnv env ok <- Env.sets fnEnv params' args if ok - then runEval $ evalAst fnEnv body' + then runEval $ eval fnEnv body' else throw "actual parameters do not match signature " unwrapSymbol :: MalExpr -> Eval String @@ -157,7 +160,7 @@ rep_ env str = rep env str *> pure unit rep :: RefEnv -> String -> Effect String rep env str = do ast <- read str - result <- runEval $ evalAst env ast + result <- runEval $ eval env ast print result @@ -193,13 +196,13 @@ setFn env (Tuple sym f) = do evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr evalCallFn env ast = do - es <- traverse (evalAst env) ast + es <- traverse (eval env) ast case es of MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args MalFunction {ast:ast', params:params', env:env'} : args -> do newEnv <- liftEffect $ Env.newEnv env' _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' + eval newEnv ast' _ -> throw "invalid function" diff --git a/impls/purs/src/step6_file.purs b/impls/purs/src/step6_file.purs index 09978fffe7..c612f5f47e 100644 --- a/impls/purs/src/step6_file.purs +++ b/impls/purs/src/step6_file.purs @@ -57,7 +57,7 @@ rep_ env str = rep env str *> pure unit rep :: RefEnv -> String -> Effect String rep env str = do ast <- read str - result <- runEval $ evalAst env ast + result <- runEval $ eval env ast print result @@ -97,32 +97,35 @@ setEval _ _ = throw "illegal call of eval" -- EVAL eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env (MalSymbol s) = do - result <- liftEffect $ Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" -evalAst env ast@(MalList _ _) = eval env ast -evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs -evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs -evalAst _ ast = pure ast +eval env ast = do + dbgeval <- liftEffect (Env.get env "DEBUG-EVAL") + liftEffect case dbgeval of + Nothing -> pure unit + Just MalNil -> pure unit + Just (MalBoolean false) -> pure unit + _ -> do + image <- print ast + log ("EVAL: " <> image) + case ast of + MalSymbol s -> do + result <- liftEffect $ Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" + MalList _ (MalSymbol "def!" : es) -> evalDef env es + MalList _ (MalSymbol "let*" : es) -> evalLet env es + MalList _ (MalSymbol "if" : es) -> evalIf env es + MalList _ (MalSymbol "do" : es) -> evalDo env es + MalList _ (MalSymbol "fn*" : es) -> evalFnMatch env es + MalList _ es@(_ : _) -> evalCallFn env es + MalVector _ es -> toVector <$> traverse (eval env) es + MalHashMap _ es -> toHashMap <$> traverse (eval env) es + _ -> pure ast evalDef :: RefEnv -> List MalExpr -> Eval MalExpr evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e + evd <- eval env e liftEffect $ Env.set env v evd pure evd evalDef _ _ = throw "invalid def!" @@ -132,11 +135,11 @@ evalLet :: RefEnv -> List MalExpr -> Eval MalExpr evalLet env (MalList _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet env (MalVector _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet _ _ = throw "invalid let*" @@ -144,7 +147,7 @@ evalLet _ _ = throw "invalid let*" letBind :: RefEnv -> List MalExpr -> Eval Unit letBind _ Nil = pure unit letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e + ex <- eval env e liftEffect $ Env.set env ky ex letBind env es letBind _ _ = throw "invalid let*" @@ -152,14 +155,14 @@ letBind _ _ = throw "invalid let*" evalIf :: RefEnv -> List MalExpr -> Eval MalExpr evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> e MalBoolean false -> e _ -> t evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> MalNil MalBoolean false -> MalNil _ -> t @@ -167,7 +170,7 @@ evalIf _ _ = throw "invalid if" evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es +evalDo env es = foldM (const $ eval env) MalNil es evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr @@ -193,7 +196,7 @@ evalFn env params body = do fnEnv <- Env.newEnv env ok <- Env.sets fnEnv params' args if ok - then runEval $ evalAst fnEnv body' + then runEval $ eval fnEnv body' else throw "actual parameters do not match signature " unwrapSymbol :: MalExpr -> Eval String @@ -206,13 +209,13 @@ evalFn env params body = do evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr evalCallFn env ast = do - es <- traverse (evalAst env) ast + es <- traverse (eval env) ast case es of MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args MalFunction {ast:ast', params:params', env:env'} : args -> do newEnv <- liftEffect $ Env.newEnv env' _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' + eval newEnv ast' _ -> throw "invalid function" diff --git a/impls/purs/src/step7_quote.purs b/impls/purs/src/step7_quote.purs index 8b4d90e16f..1cd938e710 100644 --- a/impls/purs/src/step7_quote.purs +++ b/impls/purs/src/step7_quote.purs @@ -56,7 +56,7 @@ rep_ env str = rep env str *> pure unit rep :: RefEnv -> String -> Effect String rep env str = do ast <- read str - result <- runEval $ evalAst env ast + result <- runEval $ eval env ast print result @@ -96,30 +96,32 @@ setEval _ _ = throw "illegal call of eval" -- EVAL eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - MalSymbol "quote" : es -> evalQuote env es - MalSymbol "quasiquote" : es -> evalQuasiquote env es - MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env (MalSymbol s) = do - result <- liftEffect $ Env.get env s - case result of - Just k -> pure k - Nothing -> throw $ "'" <> s <> "'" <> " not found" -evalAst env ast@(MalList _ _) = eval env ast -evalAst env (MalVector _ envs) = toVector <$> traverse (eval env) envs -evalAst env (MalHashMap _ envs) = toHashMap <$> traverse (eval env) envs -evalAst _ ast = pure ast +eval env ast = do + dbgeval <- liftEffect (Env.get env "DEBUG-EVAL") + liftEffect case dbgeval of + Nothing -> pure unit + Just MalNil -> pure unit + Just (MalBoolean false) -> pure unit + _ -> do + image <- print ast + log ("EVAL: " <> image) + case ast of + MalSymbol s -> do + result <- liftEffect $ Env.get env s + case result of + Just k -> pure k + Nothing -> throw $ "'" <> s <> "'" <> " not found" + MalList _ (MalSymbol "def!" : es) -> evalDef env es + MalList _ (MalSymbol "let*" : es) -> evalLet env es + MalList _ (MalSymbol "if" : es) -> evalIf env es + MalList _ (MalSymbol "do" : es) -> evalDo env es + MalList _ (MalSymbol "fn*" : es) -> evalFnMatch env es + MalList _ (MalSymbol "quote" : es) -> evalQuote env es + MalList _ (MalSymbol "quasiquote" : es) -> evalQuasiquote env es + MalList _ es@(_ : _) -> evalCallFn env es + MalVector _ es -> toVector <$> traverse (eval env) es + MalHashMap _ es -> toHashMap <$> traverse (eval env) es + _ -> pure ast @@ -127,7 +129,7 @@ evalAst _ ast = pure ast evalDef :: RefEnv -> List MalExpr -> Eval MalExpr evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e + evd <- eval env e liftEffect $ Env.set env v evd pure evd evalDef _ _ = throw "invalid def!" @@ -140,18 +142,18 @@ evalLet :: RefEnv -> List MalExpr -> Eval MalExpr evalLet env (MalList _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet env (MalVector _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet _ _ = throw "invalid let*" letBind :: RefEnv -> List MalExpr -> Eval Unit letBind _ Nil = pure unit letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e + ex <- eval env e liftEffect $ Env.set env ky ex letBind env es letBind _ _ = throw "invalid let*" @@ -162,14 +164,14 @@ letBind _ _ = throw "invalid let*" evalIf :: RefEnv -> List MalExpr -> Eval MalExpr evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> e MalBoolean false -> e _ -> t evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> MalNil MalBoolean false -> MalNil _ -> t @@ -180,7 +182,7 @@ evalIf _ _ = throw "invalid if" -- Do evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es +evalDo env es = foldM (const $ eval env) MalNil es @@ -209,7 +211,7 @@ evalFn env params body = do fnEnv <- Env.newEnv env ok <- Env.sets fnEnv params' args if ok - then runEval $ evalAst fnEnv body' + then runEval $ eval fnEnv body' else throw "actual parameters do not match signature " unwrapSymbol :: MalExpr -> Eval String @@ -226,15 +228,10 @@ evalQuote _ _ = throw "invalid quote" evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e +evalQuasiquote env (e:Nil) = eval env =<< quasiquote e evalQuasiquote _ _ = throw "invalid quasiquote" -evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr -evalQuasiquoteexpand (e:Nil) = quasiquote e -evalQuasiquoteexpand _ = throw "invalid quasiquote" - - quasiquote :: MalExpr -> Eval MalExpr quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" @@ -260,13 +257,13 @@ qqIter elt acc = do evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr evalCallFn env ast = do - es <- traverse (evalAst env) ast + es <- traverse (eval env) ast case es of MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args MalFunction {ast:ast', params:params', env:env'} : args -> do newEnv <- liftEffect $ Env.newEnv env' _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' + eval newEnv ast' _ -> throw "invalid function" diff --git a/impls/purs/src/step8_macros.purs b/impls/purs/src/step8_macros.purs index 3ffd77e392..1fbb214beb 100644 --- a/impls/purs/src/step8_macros.purs +++ b/impls/purs/src/step8_macros.purs @@ -57,7 +57,7 @@ rep_ env str = rep env str *> pure unit rep :: RefEnv -> String -> Effect String rep env str = do ast <- read str - result <- runEval $ evalAst env ast + result <- runEval $ eval env ast print result @@ -97,37 +97,33 @@ setEval _ _ = throw "illegal call of eval" -- EVAL eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - - MalSymbol "quote" : es -> evalQuote env es - MalSymbol "quasiquote" : es -> evalQuasiquote env es - MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es - - MalSymbol "defmacro!" : es -> evalDefmacro env es - MalSymbol "macroexpand" : es -> evalMacroexpand env es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env ast = do - newAst <- macroexpand env ast - case newAst of - MalSymbol s -> do +eval env ast = do + dbgeval <- liftEffect (Env.get env "DEBUG-EVAL") + liftEffect case dbgeval of + Nothing -> pure unit + Just MalNil -> pure unit + Just (MalBoolean false) -> pure unit + _ -> do + image <- print ast + log ("EVAL: " <> image) + case ast of + MalSymbol s -> do result <- liftEffect $ Env.get env s case result of Just k -> pure k Nothing -> throw $ "'" <> s <> "'" <> " not found" - l@(MalList _ _ ) -> eval env l - MalVector _ es -> toVector <$> traverse (evalAst env) es - MalHashMap _ es -> toHashMap <$> traverse (evalAst env) es - _ -> pure newAst + MalList _ (MalSymbol "def!" : es) -> evalDef env es + MalList _ (MalSymbol "let*" : es) -> evalLet env es + MalList _ (MalSymbol "if" : es) -> evalIf env es + MalList _ (MalSymbol "do" : es) -> evalDo env es + MalList _ (MalSymbol "fn*" : es) -> evalFnMatch env es + MalList _ (MalSymbol "quote" : es) -> evalQuote env es + MalList _ (MalSymbol "quasiquote" : es) -> evalQuasiquote env es + MalList _ (MalSymbol "defmacro!" : es) -> evalDefmacro env es + MalList _ (rawFunc : rawArgs) -> evalCallFn env rawFunc rawArgs + MalVector _ es -> toVector <$> traverse (eval env) es + MalHashMap _ es -> toHashMap <$> traverse (eval env) es + _ -> pure ast @@ -135,7 +131,7 @@ evalAst env ast = do evalDef :: RefEnv -> List MalExpr -> Eval MalExpr evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e + evd <- eval env e liftEffect $ Env.set env v evd pure evd evalDef _ _ = throw "invalid def!" @@ -148,18 +144,18 @@ evalLet :: RefEnv -> List MalExpr -> Eval MalExpr evalLet env (MalList _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet env (MalVector _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet _ _ = throw "invalid let*" letBind :: RefEnv -> List MalExpr -> Eval Unit letBind _ Nil = pure unit letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e + ex <- eval env e liftEffect $ Env.set env ky ex letBind env es letBind _ _ = throw "invalid let*" @@ -170,14 +166,14 @@ letBind _ _ = throw "invalid let*" evalIf :: RefEnv -> List MalExpr -> Eval MalExpr evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> e MalBoolean false -> e _ -> t evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> MalNil MalBoolean false -> MalNil _ -> t @@ -188,7 +184,7 @@ evalIf _ _ = throw "invalid if" -- DO evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es +evalDo env es = foldM (const $ eval env) MalNil es @@ -217,7 +213,7 @@ evalFn env params body = do fnEnv <- Env.newEnv env ok <- Env.sets fnEnv params' args if ok - then runEval $ evalAst fnEnv body' + then runEval $ eval fnEnv body' else throw "actual parameters do not match signature " unwrapSymbol :: MalExpr -> Eval String @@ -234,15 +230,10 @@ evalQuote _ _ = throw "invalid quote" evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e +evalQuasiquote env (e:Nil) = eval env =<< quasiquote e evalQuasiquote _ _ = throw "invalid quasiquote" -evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr -evalQuasiquoteexpand (e:Nil) = quasiquote e -evalQuasiquoteexpand _ = throw "invalid quasiquote" - - quasiquote :: MalExpr -> Eval MalExpr quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" @@ -268,7 +259,7 @@ qqIter elt acc = do evalDefmacro :: RefEnv -> List MalExpr -> Eval MalExpr evalDefmacro env (MalSymbol a : b : Nil) = do - f <- evalAst env b + f <- eval env b case f of MalFunction fn@{macro:false} -> do let m = MalFunction $ fn {macro = true} @@ -278,32 +269,23 @@ evalDefmacro env (MalSymbol a : b : Nil) = do evalDefmacro _ _ = throw "invalid defmacro!" -evalMacroexpand :: RefEnv -> List MalExpr -> Eval MalExpr -evalMacroexpand env (a:Nil) = macroexpand env a -evalMacroexpand _ _ = throw "invalid macroexpand" - - -macroexpand :: RefEnv -> MalExpr -> Eval MalExpr -macroexpand env ast@(MalList _ (MalSymbol a : args)) = do - maybeMacro <- liftEffect $ Env.get env a - case maybeMacro of - Just (MalFunction {fn:f, macro:true}) -> macroexpand env =<< (liftEffect $ f args) - _ -> pure ast -macroexpand _ ast = pure ast - - - -- CALL FUNCTION -evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr -evalCallFn env ast = do - es <- traverse (evalAst env) ast - case es of - MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args - MalFunction {ast:ast', params:params', env:env'} : args -> do +evalCallFn :: RefEnv -> MalExpr -> List MalExpr -> Eval MalExpr +evalCallFn env rawFunc rawArgs = do + func <- eval env rawFunc + case func of + MalFunction {fn:f, macro:true} -> do + newAst <- liftEffect $ f rawArgs + eval env newAst + MalFunction {fn:f, ast:MalNil} -> do + args <- traverse (eval env) rawArgs + liftEffect $ f args + MalFunction {ast:ast', params:params', env:env'} -> do + args <- traverse (eval env) rawArgs newEnv <- liftEffect $ Env.newEnv env' _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' + eval newEnv ast' _ -> throw "invalid function" diff --git a/impls/purs/src/step9_try.purs b/impls/purs/src/step9_try.purs index 2d34bd99ff..14f20911ed 100644 --- a/impls/purs/src/step9_try.purs +++ b/impls/purs/src/step9_try.purs @@ -59,7 +59,7 @@ rep_ env str = rep env str *> pure unit rep :: RefEnv -> String -> Effect String rep env str = do ast <- read str - result <- runEval $ evalAst env ast + result <- runEval $ eval env ast print result @@ -99,39 +99,34 @@ setEval _ _ = throw "illegal call of eval" -- EVAL eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - - MalSymbol "quote" : es -> evalQuote env es - MalSymbol "quasiquote" : es -> evalQuasiquote env es - MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es - - MalSymbol "defmacro!" : es -> evalDefmacro env es - MalSymbol "macroexpand" : es -> evalMacroexpand env es - - MalSymbol "try*" : es -> liftEffect $ evalTry env es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env ast = do - newAst <- macroexpand env ast - case newAst of +eval env ast = do + dbgeval <- liftEffect (Env.get env "DEBUG-EVAL") + liftEffect case dbgeval of + Nothing -> pure unit + Just MalNil -> pure unit + Just (MalBoolean false) -> pure unit + _ -> do + image <- print ast + log ("EVAL: " <> image) + case ast of MalSymbol s -> do result <- liftEffect $ Env.get env s case result of Just k -> pure k Nothing -> throw $ "'" <> s <> "'" <> " not found" - l@(MalList _ _ ) -> eval env l - MalVector _ es -> toVector <$> traverse (evalAst env) es - MalHashMap _ es -> toHashMap <$> traverse (evalAst env) es - _ -> pure newAst + MalList _ (MalSymbol "def!" : es) -> evalDef env es + MalList _ (MalSymbol "let*" : es) -> evalLet env es + MalList _ (MalSymbol "if" : es) -> evalIf env es + MalList _ (MalSymbol "do" : es) -> evalDo env es + MalList _ (MalSymbol "fn*" : es) -> evalFnMatch env es + MalList _ (MalSymbol "quote" : es) -> evalQuote env es + MalList _ (MalSymbol "quasiquote" : es) -> evalQuasiquote env es + MalList _ (MalSymbol "defmacro!" : es) -> evalDefmacro env es + MalList _ (MalSymbol "try*" : es) -> liftEffect $ evalTry env es + MalList _ (rawFunc : rawArgs) -> evalCallFn env rawFunc rawArgs + MalVector _ es -> toVector <$> traverse (eval env) es + MalHashMap _ es -> toHashMap <$> traverse (eval env) es + _ -> pure ast @@ -139,7 +134,7 @@ evalAst env ast = do evalDef :: RefEnv -> List MalExpr -> Eval MalExpr evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e + evd <- eval env e liftEffect $ Env.set env v evd pure evd evalDef _ _ = throw "invalid def!" @@ -152,18 +147,18 @@ evalLet :: RefEnv -> List MalExpr -> Eval MalExpr evalLet env (MalList _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet env (MalVector _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet _ _ = throw "invalid let*" letBind :: RefEnv -> List MalExpr -> Eval Unit letBind _ Nil = pure unit letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e + ex <- eval env e liftEffect $ Env.set env ky ex letBind env es letBind _ _ = throw "invalid let*" @@ -174,14 +169,14 @@ letBind _ _ = throw "invalid let*" evalIf :: RefEnv -> List MalExpr -> Eval MalExpr evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> e MalBoolean false -> e _ -> t evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> MalNil MalBoolean false -> MalNil _ -> t @@ -192,7 +187,7 @@ evalIf _ _ = throw "invalid if" -- Do evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es +evalDo env es = foldM (const $ eval env) MalNil es @@ -221,7 +216,7 @@ evalFn env params body = do fnEnv <- Env.newEnv env ok <- Env.sets fnEnv params' args if ok - then runEval $ evalAst fnEnv body' + then runEval $ eval fnEnv body' else throw "actual parameters do not match signature " unwrapSymbol :: MalExpr -> Eval String @@ -238,15 +233,10 @@ evalQuote _ _ = throw "invalid quote" evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e +evalQuasiquote env (e:Nil) = eval env =<< quasiquote e evalQuasiquote _ _ = throw "invalid quasiquote" -evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr -evalQuasiquoteexpand (e:Nil) = quasiquote e -evalQuasiquoteexpand _ = throw "invalid quasiquote" - - quasiquote :: MalExpr -> Eval MalExpr quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" @@ -272,7 +262,7 @@ qqIter elt acc = do evalDefmacro :: RefEnv -> List MalExpr -> Eval MalExpr evalDefmacro env (MalSymbol a : b : Nil) = do - f <- evalAst env b + f <- eval env b case f of MalFunction fn@{macro:false} -> do let m = MalFunction $ fn {macro = true} @@ -282,32 +272,17 @@ evalDefmacro env (MalSymbol a : b : Nil) = do evalDefmacro _ _ = throw "invalid defmacro!" -evalMacroexpand :: RefEnv -> List MalExpr -> Eval MalExpr -evalMacroexpand env (a:Nil) = macroexpand env a -evalMacroexpand _ _ = throw "invalid macroexpand" - - -macroexpand :: RefEnv -> MalExpr -> Eval MalExpr -macroexpand env ast@(MalList _ (MalSymbol a : args)) = do - maybeMacro <- liftEffect $ Env.get env a - case maybeMacro of - Just (MalFunction {fn:f, macro:true}) -> macroexpand env =<< (liftEffect $ f args) - _ -> pure ast -macroexpand _ ast = pure ast - - - -- Try evalTry :: RefEnv -> List MalExpr -> Effect MalExpr -evalTry env (a:Nil) = runEval $ evalAst env a +evalTry env (a:Nil) = runEval $ eval env a evalTry env (thw : MalList _ (MalSymbol "catch*" : MalSymbol e : b : Nil) : Nil) = do - res <- try $ runEval $ evalAst env thw + res <- try $ runEval $ eval env thw case res of Left err -> do tryEnv <- Env.newEnv env Env.set tryEnv e $ MalString $ Ex.message err -- FIXME: - runEval $ evalAst tryEnv b + runEval $ eval tryEnv b Right v -> pure v evalTry _ _ = Ex.throw "invalid try*" @@ -315,15 +290,21 @@ evalTry _ _ = Ex.throw "invalid try*" -- CALL FUNCTION -evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr -evalCallFn env ast = do - es <- traverse (evalAst env) ast - case es of - MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args - MalFunction {ast:ast', params:params', env:env'} : args -> do +evalCallFn :: RefEnv -> MalExpr -> List MalExpr -> Eval MalExpr +evalCallFn env rawFunc rawArgs = do + func <- eval env rawFunc + case func of + MalFunction {fn:f, macro:true} -> do + newAst <- liftEffect $ f rawArgs + eval env newAst + MalFunction {fn:f, ast:MalNil} -> do + args <- traverse (eval env) rawArgs + liftEffect $ f args + MalFunction {ast:ast', params:params', env:env'} -> do + args <- traverse (eval env) rawArgs newEnv <- liftEffect $ Env.newEnv env' _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' + eval newEnv ast' _ -> throw "invalid function" diff --git a/impls/purs/src/stepA_mal.purs b/impls/purs/src/stepA_mal.purs index e5fbbce002..9fded3caa7 100644 --- a/impls/purs/src/stepA_mal.purs +++ b/impls/purs/src/stepA_mal.purs @@ -62,7 +62,7 @@ rep_ env str = rep env str *> pure unit rep :: RefEnv -> String -> Effect String rep env str = do ast <- read str - result <- runEval $ evalAst env ast + result <- runEval $ eval env ast print result @@ -102,39 +102,34 @@ setEval _ _ = throw "illegal call of eval" -- EVAL eval :: RefEnv -> MalExpr -> Eval MalExpr -eval _ ast@(MalList _ Nil) = pure ast -eval env (MalList _ ast) = case ast of - MalSymbol "def!" : es -> evalDef env es - MalSymbol "let*" : es -> evalLet env es - MalSymbol "if" : es -> evalIf env es - MalSymbol "do" : es -> evalDo env es - MalSymbol "fn*" : es -> evalFnMatch env es - - MalSymbol "quote" : es -> evalQuote env es - MalSymbol "quasiquote" : es -> evalQuasiquote env es - MalSymbol "quasiquoteexpand" : es -> evalQuasiquoteexpand es - - MalSymbol "defmacro!" : es -> evalDefmacro env es - MalSymbol "macroexpand" : es -> evalMacroexpand env es - - MalSymbol "try*" : es -> liftEffect $ evalTry env es - _ -> evalCallFn env ast -eval env ast = evalAst env ast - - -evalAst :: RefEnv -> MalExpr -> Eval MalExpr -evalAst env ast = do - newAst <- macroexpand env ast - case newAst of +eval env ast = do + dbgeval <- liftEffect (Env.get env "DEBUG-EVAL") + liftEffect case dbgeval of + Nothing -> pure unit + Just MalNil -> pure unit + Just (MalBoolean false) -> pure unit + _ -> do + image <- print ast + log ("EVAL: " <> image) + case ast of MalSymbol s -> do result <- liftEffect $ Env.get env s case result of Just k -> pure k Nothing -> throw $ "'" <> s <> "'" <> " not found" - l@(MalList _ _ ) -> eval env l - MalVector _ es -> toVector <$> traverse (evalAst env) es - MalHashMap _ es -> toHashMap <$> traverse (evalAst env) es - _ -> pure newAst + MalList _ (MalSymbol "def!" : es) -> evalDef env es + MalList _ (MalSymbol "let*" : es) -> evalLet env es + MalList _ (MalSymbol "if" : es) -> evalIf env es + MalList _ (MalSymbol "do" : es) -> evalDo env es + MalList _ (MalSymbol "fn*" : es) -> evalFnMatch env es + MalList _ (MalSymbol "quote" : es) -> evalQuote env es + MalList _ (MalSymbol "quasiquote" : es) -> evalQuasiquote env es + MalList _ (MalSymbol "defmacro!" : es) -> evalDefmacro env es + MalList _ (MalSymbol "try*" : es) -> liftEffect $ evalTry env es + MalList _ (rawFunc : rawArgs) -> evalCallFn env rawFunc rawArgs + MalVector _ es -> toVector <$> traverse (eval env) es + MalHashMap _ es -> toHashMap <$> traverse (eval env) es + _ -> pure ast @@ -142,7 +137,7 @@ evalAst env ast = do evalDef :: RefEnv -> List MalExpr -> Eval MalExpr evalDef env (MalSymbol v : e : Nil) = do - evd <- evalAst env e + evd <- eval env e liftEffect $ Env.set env v evd pure evd evalDef _ _ = throw "invalid def!" @@ -155,18 +150,18 @@ evalLet :: RefEnv -> List MalExpr -> Eval MalExpr evalLet env (MalList _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet env (MalVector _ ps : e : Nil) = do letEnv <- liftEffect $ Env.newEnv env letBind letEnv ps - evalAst letEnv e + eval letEnv e evalLet _ _ = throw "invalid let*" letBind :: RefEnv -> List MalExpr -> Eval Unit letBind _ Nil = pure unit letBind env (MalSymbol ky : e : es) = do - ex <- evalAst env e + ex <- eval env e liftEffect $ Env.set env ky ex letBind env es letBind _ _ = throw "invalid let*" @@ -177,14 +172,14 @@ letBind _ _ = throw "invalid let*" evalIf :: RefEnv -> List MalExpr -> Eval MalExpr evalIf env (b:t:e:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> e MalBoolean false -> e _ -> t evalIf env (b:t:Nil) = do - cond <- evalAst env b - evalAst env case cond of + cond <- eval env b + eval env case cond of MalNil -> MalNil MalBoolean false -> MalNil _ -> t @@ -195,7 +190,7 @@ evalIf _ _ = throw "invalid if" -- Do evalDo :: RefEnv -> List MalExpr -> Eval MalExpr -evalDo env es = foldM (const $ evalAst env) MalNil es +evalDo env es = foldM (const $ eval env) MalNil es @@ -224,7 +219,7 @@ evalFn env params body = do fnEnv <- Env.newEnv env ok <- Env.sets fnEnv params' args if ok - then runEval $ evalAst fnEnv body' + then runEval $ eval fnEnv body' else throw "actual parameters do not match signature " unwrapSymbol :: MalExpr -> Eval String @@ -241,15 +236,10 @@ evalQuote _ _ = throw "invalid quote" evalQuasiquote :: RefEnv -> List MalExpr -> Eval MalExpr -evalQuasiquote env (e:Nil) = evalAst env =<< quasiquote e +evalQuasiquote env (e:Nil) = eval env =<< quasiquote e evalQuasiquote _ _ = throw "invalid quasiquote" -evalQuasiquoteexpand :: List MalExpr -> Eval MalExpr -evalQuasiquoteexpand (e:Nil) = quasiquote e -evalQuasiquoteexpand _ = throw "invalid quasiquote" - - quasiquote :: MalExpr -> Eval MalExpr quasiquote (MalList _ (MalSymbol "unquote" : x : Nil)) = pure x quasiquote (MalList _ (MalSymbol "unquote" : _)) = throw "invalid unquote" @@ -275,7 +265,7 @@ qqIter elt acc = do evalDefmacro :: RefEnv -> List MalExpr -> Eval MalExpr evalDefmacro env (MalSymbol a : b : Nil) = do - f <- evalAst env b + f <- eval env b case f of MalFunction fn@{macro:false} -> do let m = MalFunction $ fn {macro = true} @@ -285,32 +275,17 @@ evalDefmacro env (MalSymbol a : b : Nil) = do evalDefmacro _ _ = throw "invalid defmacro!" -evalMacroexpand :: RefEnv -> List MalExpr -> Eval MalExpr -evalMacroexpand env (a:Nil) = macroexpand env a -evalMacroexpand _ _ = throw "invalid macroexpand" - - -macroexpand :: RefEnv -> MalExpr -> Eval MalExpr -macroexpand env ast@(MalList _ (MalSymbol a : args)) = do - maybeMacro <- liftEffect $ Env.get env a - case maybeMacro of - Just (MalFunction {fn:f, macro:true}) -> macroexpand env =<< (liftEffect $ f args) - _ -> pure ast -macroexpand _ ast = pure ast - - - -- Try evalTry :: RefEnv -> List MalExpr -> Effect MalExpr -evalTry env (a:Nil) = runEval $ evalAst env a +evalTry env (a:Nil) = runEval $ eval env a evalTry env (thw : MalList _ (MalSymbol "catch*" : MalSymbol e : b : Nil) : Nil) = do - res <- try $ runEval $ evalAst env thw + res <- try $ runEval $ eval env thw case res of Left err -> do tryEnv <- Env.newEnv env Env.set tryEnv e $ MalString $ Ex.message err -- FIXME: - runEval $ evalAst tryEnv b + runEval $ eval tryEnv b Right v -> pure v evalTry _ _ = Ex.throw "invalid try*" @@ -318,15 +293,21 @@ evalTry _ _ = Ex.throw "invalid try*" -- CALL FUNCTION -evalCallFn :: RefEnv -> List MalExpr -> Eval MalExpr -evalCallFn env ast = do - es <- traverse (evalAst env) ast - case es of - MalFunction {fn:f, ast:MalNil} : args -> liftEffect $ f args - MalFunction {ast:ast', params:params', env:env'} : args -> do +evalCallFn :: RefEnv -> MalExpr -> List MalExpr -> Eval MalExpr +evalCallFn env rawFunc rawArgs = do + func <- eval env rawFunc + case func of + MalFunction {fn:f, macro:true} -> do + newAst <- liftEffect $ f rawArgs + eval env newAst + MalFunction {fn:f, ast:MalNil} -> do + args <- traverse (eval env) rawArgs + liftEffect $ f args + MalFunction {ast:ast', params:params', env:env'} -> do + args <- traverse (eval env) rawArgs newEnv <- liftEffect $ Env.newEnv env' _ <- liftEffect $ Env.sets newEnv params' args - evalAst newEnv ast' + eval newEnv ast' _ -> throw "invalid function" From 1717a2c5626971898f1c28f54da519d09f0b9735 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Thu, 20 Apr 2023 14:32:14 +0200 Subject: [PATCH 2/6] purs: update for purescript 0.15.8 --- impls/purs/packages.dhall | 3 ++- impls/purs/spago.dhall | 1 - impls/purs/src/Reader.purs | 9 +++++---- impls/purs/src/Readline.js | 6 +++--- 4 files changed, 10 insertions(+), 9 deletions(-) diff --git a/impls/purs/packages.dhall b/impls/purs/packages.dhall index 7b4147e645..db2ce72d6d 100644 --- a/impls/purs/packages.dhall +++ b/impls/purs/packages.dhall @@ -99,6 +99,7 @@ in upstream ------------------------------- -} let upstream = - https://github.com/purescript/package-sets/releases/download/psc-0.14.2-20210713/packages.dhall sha256:654c3148cb995f642c73b4508d987d9896e2ad3ea1d325a1e826c034c0d3cd7b + https://github.com/purescript/package-sets/releases/download/psc-0.15.8-20230420/packages.dhall + sha256:01f6ef030637be27a334e8f0977d563f9699543f596d60e8fb067e4f60d2e571 in upstream diff --git a/impls/purs/spago.dhall b/impls/purs/spago.dhall index 2334ad7617..c15e3a6bff 100644 --- a/impls/purs/spago.dhall +++ b/impls/purs/spago.dhall @@ -31,7 +31,6 @@ to generate this file without the comments in this block. , "ordered-collections" , "parsing" , "prelude" - , "psci-support" , "refs" , "strings" , "tailrec" diff --git a/impls/purs/src/Reader.purs b/impls/purs/src/Reader.purs index 03e4795553..a3cb212c9f 100644 --- a/impls/purs/src/Reader.purs +++ b/impls/purs/src/Reader.purs @@ -10,11 +10,12 @@ import Data.List (List(..), many, (:)) import Data.Maybe (Maybe(..), fromMaybe) import Effect (Effect) import Effect.Exception (throw) +import Parsing (Parser, fail, runParser) +import Parsing.Combinators (endBy, skipMany, skipMany1, try) +import Parsing.String (char, string) +import Parsing.String.Basic (noneOf, oneOf) +import Parsing.Token (digit, letter) import Printer (keyValuePairs) -import Text.Parsing.Parser (Parser, fail, runParser) -import Text.Parsing.Parser.Combinators (endBy, skipMany, skipMany1, try) -import Text.Parsing.Parser.String (char, noneOf, oneOf, string) -import Text.Parsing.Parser.Token (digit, letter) import Types (MalExpr(..), charListToString, listToMap, toHashMap, toList, toVector) diff --git a/impls/purs/src/Readline.js b/impls/purs/src/Readline.js index 34620123ed..c71692fe56 100644 --- a/impls/purs/src/Readline.js +++ b/impls/purs/src/Readline.js @@ -1,8 +1,8 @@ "use strict"; -var readlineSync = require('readline-sync') +import readlineSync from 'readline-sync' -exports.readLine = function (x) { +export const readLine = function (x) { return function () { const result = readlineSync.question(x); @@ -14,4 +14,4 @@ exports.readLine = function (x) { } -exports.argv = process.argv; \ No newline at end of file +export const argv = process.argv; From d036ee14f755174da979f25377a02c4b2ee433d1 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Thu, 8 Aug 2024 18:46:24 +0200 Subject: [PATCH 3/6] purs: update Dockerfile for purescript 0.15.8 --- impls/purs/Dockerfile | 23 +++++++---------------- 1 file changed, 7 insertions(+), 16 deletions(-) diff --git a/impls/purs/Dockerfile b/impls/purs/Dockerfile index 1eb013ea33..4c936d1655 100644 --- a/impls/purs/Dockerfile +++ b/impls/purs/Dockerfile @@ -1,4 +1,4 @@ -FROM ubuntu:21.10 +FROM ubuntu:24.04 ########################################################## # General requirements for testing or common across many @@ -8,10 +8,8 @@ FROM ubuntu:21.10 RUN apt-get -y update # Required for running tests -RUN apt-get -y install make python - -# Some typical implementation and test requirements -RUN apt-get -y install curl libreadline-dev libedit-dev +RUN apt-get -y install make python3 +RUN ln -fs /usr/bin/python3 /usr/local/bin/python RUN mkdir -p /mal WORKDIR /mal @@ -20,19 +18,12 @@ WORKDIR /mal # Specific implementation requirements ########################################################## -# For building node modules -RUN apt-get -y install g++ - -# Add nodesource apt repo config for 10.x stable -RUN apt-get -y install gnupg -RUN curl -sL https://deb.nodesource.com/setup_12.x | bash - - -# Install nodejs -RUN apt-get -y install nodejs +RUN DEBIAN_FRONTEND=noninteractive apt-get -y install g++ libreadline-dev nodej +s npm # Install purescript and deps -RUN apt-get install -y git libtinfo5 +RUN apt-get install -y git libtinfo6 RUN npm install -g --unsafe-perm purescript spago ENV NPM_CONFIG_CACHE /mal/.npm -ENV HOME /mal \ No newline at end of file +ENV HOME /mal From 416db4c211b4e2462f5220202f26cece1a06ca85 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Thu, 8 Aug 2024 18:55:14 +0200 Subject: [PATCH 4/6] purs: fix typo in Dockerfile --- impls/purs/Dockerfile | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/impls/purs/Dockerfile b/impls/purs/Dockerfile index 4c936d1655..b3bf624d4d 100644 --- a/impls/purs/Dockerfile +++ b/impls/purs/Dockerfile @@ -18,8 +18,7 @@ WORKDIR /mal # Specific implementation requirements ########################################################## -RUN DEBIAN_FRONTEND=noninteractive apt-get -y install g++ libreadline-dev nodej -s npm +RUN DEBIAN_FRONTEND=noninteractive apt-get -y install g++ libreadline-dev nodejs npm # Install purescript and deps RUN apt-get install -y git libtinfo6 From d63ffa1f21d8d5a17371504420405679888a0699 Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Thu, 8 Aug 2024 22:13:24 +0200 Subject: [PATCH 5/6] purs: install esbuild in the Dockerfile --- impls/purs/Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/impls/purs/Dockerfile b/impls/purs/Dockerfile index b3bf624d4d..5c87e9ee02 100644 --- a/impls/purs/Dockerfile +++ b/impls/purs/Dockerfile @@ -18,7 +18,7 @@ WORKDIR /mal # Specific implementation requirements ########################################################## -RUN DEBIAN_FRONTEND=noninteractive apt-get -y install g++ libreadline-dev nodejs npm +RUN DEBIAN_FRONTEND=noninteractive apt-get -y install g++ libreadline-dev nodejs npm esbuild # Install purescript and deps RUN apt-get install -y git libtinfo6 From 50cd78b2668f9c35b6cd46a6f7fe337da85ac7ab Mon Sep 17 00:00:00 2001 From: Nicolas Boulenguez Date: Thu, 8 Aug 2024 23:32:27 +0200 Subject: [PATCH 6/6] purs: select node platform --- impls/purs/Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/impls/purs/Makefile b/impls/purs/Makefile index 5de690be1b..469536ac63 100644 --- a/impls/purs/Makefile +++ b/impls/purs/Makefile @@ -9,7 +9,7 @@ OTHER_SRCS = src/Readline.js src/Readline.purs src/Types.purs src/Reader.purs \ all: $(BINS) $(BINS): %.js: src/%.purs $(OTHER_SRCS) node_modules/readline-sync - spago bundle-app --main $($(<:src/%=%)) --to $@ + spago bundle-app --platform=node --main $($(<:src/%=%)) --to $@ node_modules/readline-sync: @@ -32,4 +32,4 @@ stepA_mal.purs = Mal.StepA clean: - rm -rf step*.js output/* \ No newline at end of file + rm -rf step*.js output/*