State monad

src/Lish/Core.hs

@@ -51,5 +51,6 @@ evalReduced x = putStrLn (show x)
 
 eval :: Either ParseError SExp -> InputT IO ()
 eval parsed = case parsed of
-  Right sexpr -> liftIO (reduceLambda (EnvSExp sexpr []) >>= evalReduced .sexp)
+  Right sexpr -> liftIO $
+    runStateT (reduceLambda sexpr) [] >>= evalReduced . fst
   Left err   -> outputStrLn (show err)

src/Lish/Eval.hs

@@ -6,30 +6,51 @@ module Lish.Eval
   )
   where
 
-import qualified Control.Exception        as Exception
+import qualified Control.Exception     as Exception
+import qualified Prelude               as Prelude
 import           Protolude
-import           System.Process hiding (env)
-import           Prelude                  (lookup)
+import           System.Process        hiding (env)
 
-import           Lish.Types hiding (show)
-import Lish.InternalCommands
+import           Lish.InternalCommands (toArg)
+import qualified Lish.InternalCommands as InternalCommands
+import           Lish.Types            hiding (show)
 
 -- | The main evaluation function
 -- TODO: its real type should be something isomorphic to
 -- (SExp,Environment) -> IO (SExp, Environment)
-reduceLambda :: EnvSExp -> IO EnvSExp
-reduceLambda (EnvSExp { sexp = (Lambda exprs)
-                      , env = environment
-                      }) = do
-  reduced <- mapM reduceLambda (map (\sexpr -> EnvSExp sexpr environment) exprs)
+reduceLambda :: SExp -> StateT Env IO SExp
+reduceLambda (Lambda exprs) = do
+  reduced <- mapM reduceLambda exprs
   case reduced of
-    (EnvSExp { sexp = Atom f, env = cmdenv}:args)
-      -> case lookup f internalCommands of
-           Just fn -> fn args
-           _       -> executeShell (Lambda (map sexp reduced)) >>= \s -> return $ EnvSExp { sexp = s, env = cmdenv }
-    _ ->  executeShell (Lambda (map sexp reduced)) >>= \s -> return $ EnvSExp { sexp = s, env = environment }
+    (Atom f:args) -> do
+      resultInternal <- tryInternalCommand f args
+      case resultInternal of
+        Just x -> return x
+        Nothing -> do
+          resultEnv <- tryEnvCommand f args
+          case resultEnv of
+            Just x  -> return x
+            Nothing -> lift (executeShell (Lambda reduced))
+    _             ->  lift (executeShell (Lambda reduced))
 reduceLambda x          = return x
 
+apply :: SExp -> Command
+apply = undefined
+
+tryEnvCommand :: Text -> [SExp] -> StateT Env IO (Maybe SExp)
+tryEnvCommand f args = do
+  envcmd <- get
+  case Prelude.lookup f envcmd of
+    Just fn -> Just <$> (apply fn args)
+    _       -> return Nothing
+
+
+tryInternalCommand :: Text -> [SExp] -> StateT Env IO (Maybe SExp)
+tryInternalCommand f args =
+  case InternalCommands.lookup f of
+    Just fn -> Just <$> fn args
+    _       -> return Nothing
+
 -- | take a SExp
 toStdIn :: SExp -> Maybe Handle
 toStdIn (WaitingStream h) = h

src/Lish/InternalCommands.hs

@@ -2,11 +2,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 -- | Lish internal commands
 module Lish.InternalCommands
-  ( internalCommands
+  ( lookup
   , toArg
   )
   where
 
+import qualified Prelude as Prelude
 import           GHC.IO.Handle            (hGetContents)
 import qualified Data.Text  as Text
 import           Lish.Types
@@ -20,39 +21,29 @@ toArg _                 = return $ Nothing
 
 prn :: Command
 prn args = do
-  strs <- catMaybes <$> (mapM (toArg . sexp) args)
-  putText $ (Text.intercalate " " strs) <> "\n"
-  return EnvSExp { sexp = Void
-                 , env = (mconcat (map env args))
-                 }
+  strs <- catMaybes <$> liftIO (mapM toArg args)
+  putStrLn $ (Text.intercalate " " strs)
+  return Void
 
 pr :: Command
 pr args = do
-  strs <- catMaybes <$> (mapM (toArg . sexp) args)
-  putText (Text.intercalate " " strs)
-  return EnvSExp { sexp = Void
-                 , env = (mconcat (map env args))
-                 }
+  strs <- catMaybes <$> liftIO (mapM toArg args)
+  putStr (Text.intercalate " " strs)
+  return Void
 
-evalErr :: Text -> IO EnvSExp
+evalErr :: Text -> StateT Env IO SExp
 evalErr errmsg = do
   putText $ "EvalError: " <> errmsg
-  return (EnvSExp Void empty)
+  return Void
 
 replace :: Command
-replace args@((EnvSExp { sexp = (Str old)}) :
-              (EnvSExp { sexp = (Str new)}) :
-              (EnvSExp { sexp = (Str str)}) :
-              []) =
-  return $ EnvSExp { sexp =  Str $ Text.replace old new str
-                   , env = (mconcat (map env args))}
+replace ((Str old) : (Str new) : (Str str) : []) =
+  return $ Str $ Text.replace old new str
 replace _ = evalErr "replace should take 3 String arguments"
 
 toWaitingStream :: Command
-toWaitingStream (EnvSExp { sexp = Stream (Just h)
-                         , env = environment     }:[]) =
-  return $ EnvSExp (WaitingStream (Just h)) environment
-toWaitingStream _                      = return (EnvSExp Void empty)
+toWaitingStream (Stream (Just h) :[]) = return (WaitingStream (Just h))
+toWaitingStream _                     = return Void
 
 internalCommands :: [(Text,Command)]
 internalCommands = [ ("prn", prn)
@@ -60,3 +51,6 @@ internalCommands = [ ("prn", prn)
                    , (">", toWaitingStream)
                    , ("replace", replace)
                    ]
+
+lookup :: Text -> Maybe Command
+lookup = flip Prelude.lookup internalCommands

src/Lish/Types.hs

@@ -3,8 +3,8 @@
 -- | Lish types
 module Lish.Types
   ( SExp(..)
-  , EnvSExp(..)
   , show
+  , Env
   , CmdStream
   , Command
   )
@@ -38,5 +38,4 @@ repr (WaitingStream _) = "<w-stream>"
 
 type CmdStream = Maybe Handle
 type Env = [(Text,SExp)]
-data EnvSExp = EnvSExp { sexp :: SExp , env :: Env}
-type Command = [EnvSExp] -> IO EnvSExp
+type Command = [SExp] -> StateT Env IO SExp