feat: purescript step5

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

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"
   ]

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

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

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
+read :: String -> Either String MalExpr
+read = readStr
+
+
+
+-- PRINT
+
+print :: MalExpr -> Effect String
+print = printStr

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
+read :: String -> Either String MalExpr
+read = readStr
+
+
+
+-- PRINT
+
+print :: MalExpr -> Effect String
+print = printStr

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
+read :: String -> Either String MalExpr
+read = readStr
+
+
+
+-- PRINT
+
+print :: MalExpr -> Effect String
+print = printStr

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
+read :: String -> Either String MalExpr
+read = readStr
+
+
+
+-- PRINT
+
+print :: MalExpr -> Effect String
+print = printStr

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