diff --git a/src/Lish/Core.hs b/src/Lish/Core.hs index 75af335..774639e 100644 --- a/src/Lish/Core.hs +++ b/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) diff --git a/src/Lish/Eval.hs b/src/Lish/Eval.hs index 05170b8..367c954 100644 --- a/src/Lish/Eval.hs +++ b/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 diff --git a/src/Lish/InternalCommands.hs b/src/Lish/InternalCommands.hs index 2e41f4d..f672743 100644 --- a/src/Lish/InternalCommands.hs +++ b/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 diff --git a/src/Lish/Types.hs b/src/Lish/Types.hs index 71c2ccf..7a70f10 100644 --- a/src/Lish/Types.hs +++ b/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 _) = "" 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