From 2dace09a0d7810f5b8e94509eaeca7548098ab5a Mon Sep 17 00:00:00 2001
From: "Yann Esposito (Yogsototh)" <yann.esposito@gmail.com>
Date: Sat, 4 Mar 2017 20:39:27 +0100
Subject: [PATCH] added function evaluation + equal

---
 src/Lish/Eval.hs             | 48 +++++++++++++++++++++---------------
 src/Lish/InternalCommands.hs |  5 ++++
 2 files changed, 33 insertions(+), 20 deletions(-)

diff --git a/src/Lish/Eval.hs b/src/Lish/Eval.hs
index 389f026..894421f 100644
--- a/src/Lish/Eval.hs
+++ b/src/Lish/Eval.hs
@@ -17,31 +17,39 @@ import qualified Lish.InternalCommands as InternalCommands
 import           Lish.Types            hiding (show)
 
 -- | The main evaluation function
--- TODO: its real type should be something isomorphic to
+-- its real type should be something isomorphic to
 -- (SExp,Environment) -> IO (SExp, Environment)
 reduceLambda :: SExp -> StateT Env IO SExp
 reduceLambda (Lambda (expr:exprs)) = do
   reduced <- reduceLambda expr
-  env <- get
-  liftIO $ print env
-  liftIO $ print reduced
-  liftIO $ print exprs
-  case reduced of
-    Atom f -> do
-      resultInternal <- tryInternalCommand f exprs
-      case resultInternal of
-        Just x -> return x
-        Nothing -> do
-          resultEnv <- tryEnvCommand f exprs
-          case resultEnv of
-            Just x  -> return x
+  redred <- reduceLambda reduced
+  if redred /= reduced
+    then reduceLambda (Lambda (reduced:exprs))
+    else do
+      -- DEBUG --env <- get
+      -- DEBUG --liftIO $ do
+      -- DEBUG --  putText "Lambda:"
+      -- DEBUG --  print $ (expr:exprs)
+      -- DEBUG --  putText "Env:"
+      -- DEBUG --  print env
+      -- DEBUG --  putText "Reduced Head:"
+      -- DEBUG --  print reduced
+      case reduced of
+        Atom f -> do
+          resultInternal <- tryInternalCommand f exprs
+          case resultInternal of
+            Just x -> return x
             Nothing -> do
-              reducedArgs <- mapM reduceLambda exprs
-              executeShell (Lambda ((Atom f):reducedArgs))
-    f@(Fn _ _ _) -> applyFn f exprs
-    s  -> do
-      reducedArgs <- mapM reduceLambda exprs
-      executeShell (Lambda (s:reducedArgs))
+              resultEnv <- tryEnvCommand f exprs
+              case resultEnv of
+                Just x  -> return x
+                Nothing -> do
+                  reducedArgs <- mapM reduceLambda exprs
+                  executeShell (Lambda ((Atom f):reducedArgs))
+        f@(Fn _ _ _) -> applyFn f exprs
+        s  -> do
+          reducedArgs <- mapM reduceLambda exprs
+          executeShell (Lambda (s:reducedArgs))
 reduceLambda (Atom x) = do
   env <- get
   case Map.lookup x env of
diff --git a/src/Lish/InternalCommands.hs b/src/Lish/InternalCommands.hs
index 1df2b74..9a04293 100644
--- a/src/Lish/InternalCommands.hs
+++ b/src/Lish/InternalCommands.hs
@@ -101,6 +101,10 @@ toWaitingStream :: ReduceUnawareCommand
 toWaitingStream (Stream (Just h) :[]) = return (WaitingStream (Just h))
 toWaitingStream _                     = return Void
 
+equal :: ReduceUnawareCommand
+equal (x:y:[]) = return (Bool (x == y))
+equal args = evalErr $ "= need two args, got" <> (toS (show args))
+
 toStrictCmd :: ReduceUnawareCommand -> Command
 toStrictCmd f reducer sexps = do
   reduced <- mapM reducer sexps
@@ -140,6 +144,7 @@ strictCommands = [ ("prn", prn)
                  , ("$",getenv)
                  , ("str",str)
                  , ("atom",atom)
+                 , ("=",equal)
                  -- binary operators
                  , ("+",binop (+))
                  , ("-",binop (-))