diff --git a/impls/purs/Makefile b/impls/purs/Makefile index b9e70357..91fb77c2 100644 --- a/impls/purs/Makefile +++ b/impls/purs/Makefile @@ -10,3 +10,4 @@ step2_eval.purs = Mal.Step2 step3_env.purs = Mal.Step3 step4_if_fn_do.purs = Mal.Step4 step5_tco.purs = Mal.Step5 +step6_file.purs = Mal.Step6 diff --git a/impls/purs/src/step5_tco.purs b/impls/purs/src/step5_tco.purs index 38a0b8f6..18d20093 100644 --- a/impls/purs/src/step5_tco.purs +++ b/impls/purs/src/step5_tco.purs @@ -26,8 +26,7 @@ import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toVector) -- TYPES -type Eval a = SafeT Effect a -type SafeT = FreeT Identity +type Eval a = FreeT Identity Effect a @@ -57,13 +56,14 @@ eval env (MalList _ ast) = case ast of 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' + newEnv <- liftEffect $ Env.newEnv env' + _ <- liftEffect $ Env.sets newEnv params' args + eval newEnv ast' _ -> throw "invalid function" eval env ast = evalAst env ast -evalAst :: RefEnv -> MalExpr -> SafeT Effect MalExpr +evalAst :: RefEnv -> MalExpr -> Eval MalExpr evalAst env (MalSymbol s) = do result <- liftEffect $ Env.get env s case result of @@ -105,16 +105,16 @@ letBind env (MalSymbol ky : e : es) = do letBind _ _ = throw "invalid let*" -evalIf :: RefEnv -> List MalExpr -> SafeT Effect MalExpr +evalIf :: RefEnv -> List MalExpr -> Eval MalExpr evalIf env (b:t:e:Nil) = do cond <- evalAst env b - evalAst env case cond of + pure case cond of MalNil -> e MalBoolean false -> e _ -> t evalIf env (b:t:Nil) = do cond <- evalAst env b - evalAst env case cond of + pure case cond of MalNil -> MalNil MalBoolean false -> MalNil _ -> t @@ -148,7 +148,7 @@ evalFn env params body = do fnEnv <- Env.newEnv env ok <- Env.sets fnEnv params' args if ok - then runSafeT $ evalAst fnEnv body' + then runEval $ evalAst fnEnv body' else throw "actual parameters do not match signature " unwrapSymbol :: MalExpr -> Eval String @@ -166,7 +166,7 @@ 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) + Right ast -> print =<< (runEval $ eval env ast) loop :: RefEnv -> Effect Unit @@ -212,8 +212,8 @@ print = printStr -- Utils -runSafeT :: ∀ m a. MonadRec m => SafeT m a -> m a -runSafeT = runFreeT $ pure <<< runIdentity +runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a +runEval = runFreeT $ pure <<< runIdentity runIdentity :: ∀ a. Identity a -> a diff --git a/impls/purs/src/step6_file.purs b/impls/purs/src/step6_file.purs new file mode 100644 index 00000000..18b7ee30 --- /dev/null +++ b/impls/purs/src/step6_file.purs @@ -0,0 +1,237 @@ +module Mal.Step6 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.Identity (Identity(..)) +import Data.List (List(..), foldM, (:)) +import Data.Maybe (Maybe(..)) +import Data.Traversable (traverse, 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 (args, readLine) +import Types (MalExpr(..), MalFn, RefEnv, toHashMap, toList, toVector) + + +-- TYPES + +type Eval a = FreeT Identity Effect a + + + +-- MAIN + +main :: Effect Unit +main = do + let as = args + env <- Env.newEnv Nil + traverse_ (setFn env) Core.ns + setFn env (Tuple "eval" $ setEval env) + rep_ env "(def! not (fn* (a) (if a false true)))" + rep_ env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + case as of + Nil -> do + Env.set env "*ARGV*" $ toList Nil + loop env + script:args -> do + Env.set env "*ARGV*" $ toList $ MalString <$> args + rep_ env $ "(load-file \"" <> script <> "\")" + + + +-- 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 =<< (runEval $ 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 + } + + +setEval :: RefEnv -> MalFn +setEval env (ast:Nil) = runEval $ eval env ast +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 >>= 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 + newEnv <- liftEffect $ Env.newEnv env' + _ <- liftEffect $ Env.sets newEnv params' args + eval newEnv ast' + _ -> throw "invalid function" +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 -> 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 -> Eval MalExpr +evalIf env (b:t:e:Nil) = do + cond <- evalAst env b + pure case cond of + MalNil -> e + MalBoolean false -> e + _ -> t +evalIf env (b:t:Nil) = do + cond <- evalAst env b + pure 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 runEval $ 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" + + + +-- READ + +read :: String -> Either String MalExpr +read = readStr + + + +-- PRINT + +print :: MalExpr -> Effect String +print = printStr + + + +-- Utils + +runEval :: ∀ m a. MonadRec m => FreeT Identity m a -> m a +runEval = 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