From 511e0febaf41c5993eaa1ba39c6d970a6eff36b8 Mon Sep 17 00:00:00 2001 From: mrsekut Date: Thu, 22 Jul 2021 22:39:37 +0900 Subject: [PATCH] feat: purescript step5 --- impls/purs/Makefile | 1 + impls/purs/spago.dhall | 3 + impls/purs/src/Types.purs | 9 +- impls/purs/src/step0_repl.purs | 23 ++- impls/purs/src/step1_read_print.purs | 26 ++-- impls/purs/src/step2_eval.purs | 68 +++++--- impls/purs/src/step3_env.purs | 59 ++++--- impls/purs/src/step4_if_fn_do.purs | 53 ++++--- impls/purs/src/step5_tco.purs | 224 +++++++++++++++++++++++++++ 9 files changed, 376 insertions(+), 90 deletions(-) create mode 100644 impls/purs/src/step5_tco.purs diff --git a/impls/purs/Makefile b/impls/purs/Makefile index e2a71a46..b9e70357 100644 --- a/impls/purs/Makefile +++ b/impls/purs/Makefile @@ -9,3 +9,4 @@ step1_read_print.purs = Mal.Step1 step2_eval.purs = Mal.Step2 step3_env.purs = Mal.Step3 step4_if_fn_do.purs = Mal.Step4 +step5_tco.purs = Mal.Step5 diff --git a/impls/purs/spago.dhall b/impls/purs/spago.dhall index a84fe5ce..2334ad76 100644 --- a/impls/purs/spago.dhall +++ b/impls/purs/spago.dhall @@ -20,6 +20,8 @@ to generate this file without the comments in this block. , "either" , "exceptions" , "foldable-traversable" + , "freet" + , "identity" , "integers" , "lists" , "maybe" @@ -32,6 +34,7 @@ to generate this file without the comments in this block. , "psci-support" , "refs" , "strings" + , "tailrec" , "transformers" , "tuples" ] diff --git a/impls/purs/src/Types.purs b/impls/purs/src/Types.purs index 466aed24..7a890ce7 100644 --- a/impls/purs/src/Types.purs +++ b/impls/purs/src/Types.purs @@ -28,12 +28,15 @@ data MalExpr | MalList Meta (List MalExpr) | MalVector Meta (List MalExpr) | MalHashMap Meta (Map Key MalExpr) - | MalFunction { fn :: MalFn + | MalFunction { fn :: MalFn + , ast :: MalExpr + , env :: RefEnv , params :: List String - , macro :: Boolean - , meta :: MalExpr + , macro :: Boolean + , meta :: MalExpr } + instance Eq MalExpr where eq MalNil MalNil = true eq (MalBoolean a) (MalBoolean b) = a == b diff --git a/impls/purs/src/step0_repl.purs b/impls/purs/src/step0_repl.purs index 1f922a7f..b88d5407 100644 --- a/impls/purs/src/step0_repl.purs +++ b/impls/purs/src/step0_repl.purs @@ -6,11 +6,25 @@ import Effect.Console (log) import Readline (readLine) +-- MAIN main :: Effect Unit main = loop + +-- EVAL + +eval :: String -> String +eval s = s + + + +-- REPL + +rep :: String -> String +rep = read >>> eval >>> print + loop :: Effect Unit loop = do line <- readLine "user> " @@ -22,17 +36,16 @@ loop = do loop + +-- READ + read :: String -> String read s = s -eval :: String -> String -eval s = s +-- PRINT print :: String -> String print s = s - -rep :: String -> String -rep = read >>> eval >>> print \ No newline at end of file diff --git a/impls/purs/src/step1_read_print.purs b/impls/purs/src/step1_read_print.purs index 1fe3a3f7..5fb91199 100644 --- a/impls/purs/src/step1_read_print.purs +++ b/impls/purs/src/step1_read_print.purs @@ -11,10 +11,10 @@ import Readline (readLine) import Types (MalExpr) --- READ +-- MAIN -read :: String -> Either String MalExpr -read = readStr +main :: Effect Unit +main = loop @@ -25,13 +25,6 @@ eval s = s --- PRINT - -print :: MalExpr -> Effect String -print = printStr - - - -- REPL rep :: String -> Effect Unit @@ -52,7 +45,14 @@ loop = do --- +-- READ -main :: Effect Unit -main = loop \ No newline at end of file +read :: String -> Either String MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr \ No newline at end of file diff --git a/impls/purs/src/step2_eval.purs b/impls/purs/src/step2_eval.purs index a253eedf..02c68f27 100644 --- a/impls/purs/src/step2_eval.purs +++ b/impls/purs/src/step2_eval.purs @@ -12,17 +12,17 @@ import Data.Tuple (Tuple(..)) import Effect (Effect) import Effect.Console (error, log) import Effect.Exception (throw, try) +import Env as Env import Reader (readStr) import Printer (printStr) import Readline (readLine) import Types (MalExpr(..), MalFn, toHashMap, toList, toVector) +-- MAIN --- READ - -read :: String -> Either String MalExpr -read = readStr +main :: Effect Unit +main = loop @@ -49,28 +49,38 @@ evalAst _ ast = pure ast --- PRINT - -print :: MalExpr -> Effect String -print = printStr - - - -- ENV type ReplEnv = Map String MalExpr -replEnv :: ReplEnv -replEnv = Map.fromFoldable - [ (Tuple "+" (fn (+))) - , (Tuple "-" (fn (-))) - , (Tuple "*" (fn (*))) - , (Tuple "/" (fn (/))) - ] -fn :: (Int -> Int -> Int) -> MalExpr -fn op = MalFunction $ { fn : g op, params:Nil, macro:false, meta:MalNil } +replEnv :: Effect ReplEnv +replEnv = do + add <- fn (+) + sub <- fn (-) + mul <- fn (*) + div <- fn (/) + pure $ Map.fromFoldable + [ Tuple "+" add + , Tuple "-" sub + , Tuple "*" mul + , Tuple "/" div + ] + + +fn :: (Int -> Int -> Int) -> Effect MalExpr +fn op = do + newEnv <- Env.newEnv Nil + pure $ MalFunction + { fn : g op + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } where + g :: (Int -> Int -> Int) -> MalFn g op' ((MalInt n1) : (MalInt n2) : Nil) = pure $ MalInt $ op' n1 n2 g _ _ = throw "invalid operator" @@ -81,9 +91,10 @@ fn op = MalFunction $ { fn : g op, params:Nil, macro:false, meta:MalNil } rep :: String -> Effect Unit rep str = case read str of - Left _ -> error "EOF" + Left _ -> error "EOF" Right ast -> do - result <- try $ eval replEnv ast + env <- replEnv + result <- try $ eval env ast case result of Right exp -> print exp >>= log Left err -> error $ show err @@ -101,7 +112,14 @@ loop = do --- +-- READ -main :: Effect Unit -main = loop \ No newline at end of file +read :: String -> Either String MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr \ No newline at end of file diff --git a/impls/purs/src/step3_env.purs b/impls/purs/src/step3_env.purs index 6a44bf0e..2f5104d9 100644 --- a/impls/purs/src/step3_env.purs +++ b/impls/purs/src/step3_env.purs @@ -17,11 +17,13 @@ import Readline (readLine) import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector) +-- MAIN --- READ - -read :: String -> Either String MalExpr -read = readStr +main :: Effect Unit +main = do + re <- Env.newEnv Nil + setArithOp re + loop re @@ -35,8 +37,8 @@ eval env (MalList _ ast) = case ast of _ -> do es <- traverse (evalAst env) ast case es of - (MalFunction {fn:f} : args) -> f args - _ -> throw "invalid function" + MalFunction {fn:f} : args -> f args + _ -> throw "invalid function" eval env ast = evalAst env ast @@ -81,13 +83,6 @@ letBind _ _ = throw "invalid let*" --- PRINT - -print :: MalExpr -> Effect String -print = printStr - - - -- REPL rep :: RefEnv -> String -> Effect String @@ -111,25 +106,39 @@ loop env = do setArithOp :: RefEnv -> Effect Unit setArithOp env = do - Env.set env "+" $ fn (+) - Env.set env "-" $ fn (-) - Env.set env "*" $ fn (*) - Env.set env "/" $ fn (/) + Env.set env "+" =<< fn (+) + Env.set env "-" =<< fn (-) + Env.set env "*" =<< fn (*) + Env.set env "/" =<< fn (/) -fn :: (Int -> Int -> Int) -> MalExpr -fn op = MalFunction $ { fn : g op, params:Nil, macro:false, meta:MalNil } +fn :: (Int -> Int -> Int) -> Effect MalExpr +fn op = do + newEnv <- Env.newEnv Nil + pure $ MalFunction + { fn : g op + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } where + g :: (Int -> Int -> Int) -> MalFn g op' ((MalInt n1) : (MalInt n2) : Nil) = pure $ MalInt $ op' n1 n2 g _ _ = throw "invalid operator" --- +-- READ -main :: Effect Unit -main = do - re <- Env.newEnv Nil - setArithOp re - loop re \ No newline at end of file +read :: String -> Either String MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr \ No newline at end of file diff --git a/impls/purs/src/step4_if_fn_do.purs b/impls/purs/src/step4_if_fn_do.purs index 3c583051..5fbe5072 100644 --- a/impls/purs/src/step4_if_fn_do.purs +++ b/impls/purs/src/step4_if_fn_do.purs @@ -20,10 +20,14 @@ import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector) --- READ +-- MAIN -read :: String -> Either String MalExpr -read = readStr +main :: Effect Unit +main = do + re <- Env.newEnv Nil + _ <- traverse (setFn re) Core.ns + _ <- rep re "(def! not (fn* (a) (if a false true)))" + loop re @@ -115,7 +119,13 @@ evalFnMatch _ _ = throw "invalid fn*" evalFn :: RefEnv -> List MalExpr -> MalExpr -> Effect MalExpr evalFn env params body = do paramsStr <- traverse unwrapSymbol params - pure $ MalFunction { fn : fn paramsStr body, params:paramsStr, macro:false, meta:MalNil } + pure $ MalFunction { fn : fn paramsStr body + , ast : body + , env : env + , params : paramsStr + , macro : false + , meta : MalNil + } where fn :: List String -> MalExpr -> MalFn @@ -132,13 +142,6 @@ evalFn env params body = do --- PRINT - -print :: MalExpr -> Effect String -print = printStr - - - -- REPL rep :: RefEnv -> String -> Effect String @@ -161,15 +164,27 @@ loop env = do setFn :: RefEnv -> Tuple String MalFn -> Effect Unit -setFn env (Tuple sym f) = Env.set env sym $ MalFunction { fn:f, params:Nil, macro:false, meta:MalNil } +setFn env (Tuple sym f) = do + newEnv <- Env.newEnv Nil + Env.set env sym $ MalFunction + { fn : f + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } --- +-- READ -main :: Effect Unit -main = do - re <- Env.newEnv Nil - _ <- traverse (setFn re) Core.ns - _ <- rep re "(def! not (fn* (a) (if a false true)))" - loop re \ No newline at end of file +read :: String -> Either String MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr \ No newline at end of file diff --git a/impls/purs/src/step5_tco.purs b/impls/purs/src/step5_tco.purs new file mode 100644 index 00000000..38a0b8f6 --- /dev/null +++ b/impls/purs/src/step5_tco.purs @@ -0,0 +1,224 @@ +module Mal.Step5 where + +import Prelude + +import Control.Monad.Error.Class (try) +import Control.Monad.Free.Trans (FreeT, runFreeT) +import Control.Monad.Rec.Class (class MonadRec) +import Core as Core +import Data.Either (Either(..)) +import Data.Foldable (traverse_) +import Data.Identity (Identity(..)) +import Data.List (List(..), foldM, (:)) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Console (error, log) +import Effect.Exception as Ex +import Env as Env +import Printer (printStr) +import Reader (readStr) +import Readline (readLine) +import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector) + + +-- TYPES + +type Eval a = SafeT Effect a +type SafeT = FreeT Identity + + + +-- MAIN + +main :: Effect Unit +main = do + re <- Env.newEnv Nil + traverse_ (setFn re) Core.ns + rep_ re "(def! not (fn* (a) (if a false true)))" + loop re + + + +-- 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 >>= eval env + MalSymbol "do" : es -> evalDo env es + MalSymbol "fn*" : es -> evalFnMatch env es + _ -> 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 + _ <- liftEffect $ Env.sets env' params' args + eval env' ast' + _ -> throw "invalid function" +eval env ast = evalAst env ast + + +evalAst :: RefEnv -> MalExpr -> SafeT Effect MalExpr +evalAst env (MalSymbol s) = do + result <- liftEffect $ Env.get env s + case result of + Just k -> pure k + Nothing -> liftEffect $ 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 + + +evalDef :: RefEnv -> List MalExpr -> Eval MalExpr +evalDef env (MalSymbol v : e : Nil) = do + evd <- evalAst env e + liftEffect $ Env.set env v evd + pure evd +evalDef _ _ = throw "invalid def!" + + +evalLet :: RefEnv -> List MalExpr -> Eval MalExpr +evalLet env (MalList _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst letEnv e +evalLet env (MalVector _ ps : e : Nil) = do + letEnv <- liftEffect $ Env.newEnv env + letBind letEnv ps + evalAst 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 + liftEffect $ Env.set env ky ex + letBind env es +letBind _ _ = throw "invalid let*" + + +evalIf :: RefEnv -> List MalExpr -> SafeT Effect MalExpr +evalIf env (b:t:e:Nil) = do + cond <- evalAst env b + evalAst 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 + MalNil -> MalNil + MalBoolean false -> MalNil + _ -> t +evalIf _ _ = throw "invalid if" + + +evalDo :: RefEnv -> List MalExpr -> Eval MalExpr +evalDo env es = foldM (const $ evalAst env) MalNil es + + +evalFnMatch :: RefEnv -> List MalExpr -> Eval MalExpr +evalFnMatch env (MalList _ params : body : Nil) = evalFn env params body +evalFnMatch env (MalVector _ params : body : Nil) = evalFn env params body +evalFnMatch _ _ = throw "invalid fn*" + + +evalFn :: RefEnv -> List MalExpr -> MalExpr -> Eval MalExpr +evalFn env params body = do + paramsStr <- traverse unwrapSymbol params + pure $ MalFunction { fn : fn paramsStr body + , ast : body + , env : env + , params : paramsStr + , macro : false + , meta : MalNil + } + where + + fn :: List String -> MalExpr -> MalFn + fn params' body' = \args -> do + fnEnv <- Env.newEnv env + ok <- Env.sets fnEnv params' args + if ok + then runSafeT $ evalAst fnEnv body' + else throw "actual parameters do not match signature " + + unwrapSymbol :: MalExpr -> Eval String + unwrapSymbol (MalSymbol s) = pure s + unwrapSymbol _ = throw "fn* parameter must be symbols" + + + +-- REPL + +rep_ :: RefEnv -> String -> Effect Unit +rep_ env str = rep env str *> pure unit + + +rep :: RefEnv -> String -> Effect String +rep env str = case read str of + Left _ -> throw "EOF" + Right ast -> print =<< (runSafeT $ eval env ast) + + +loop :: RefEnv -> Effect Unit +loop env = do + line <- readLine "user> " + case line of + ":q" -> pure unit + _ -> do + result <- try $ rep env line + case result of + Right exp -> log exp + Left err -> error $ show err + loop env + + +setFn :: RefEnv -> Tuple String MalFn -> Effect Unit +setFn env (Tuple sym f) = do + newEnv <- Env.newEnv Nil + Env.set env sym $ MalFunction + { fn : f + , ast : MalNil + , env : newEnv + , params : Nil + , macro : false + , meta : MalNil + } + + + +-- READ + +read :: String -> Either String MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr + + + +-- Utils + +runSafeT :: ∀ m a. MonadRec m => SafeT m a -> m a +runSafeT = runFreeT $ pure <<< runIdentity + + +runIdentity :: ∀ a. Identity a -> a +runIdentity (Identity a) = a + + +throw :: forall m a. MonadEffect m => String -> m a +throw = liftEffect <<< Ex.throw \ No newline at end of file