fixed map

examples/higher-order.lsh

@@ -0,0 +1,5 @@
+def inc (fn [x] (+ x 1))
+def map (fn [f lst] (if (empty? lst) [] (cons (f (first lst)) (map f (rest lst)))))
+def test (fn [name expr] (if expr (prn (str name " OK")) (prn (str name " FAILED"))))
+test "map" (= [2 3 4] (map inc [1 2 3]))
+test "double map" (= [3 4 5] (map inc (map inc [1 2 3])))

src/Lish/Eval.hs

@@ -13,7 +13,6 @@ import           Data.Fix
 import qualified Data.Map.Strict       as Map
 import           Protolude
 import           System.Process        hiding (env)
-import Text.PrettyPrint (render)
 import qualified Text.Show.Pretty as Pr
 
 import           Lish.InternalCommands (toArg)
@@ -94,7 +93,7 @@ reduceLambda :: SExp -> StateT Env IO SExp
 reduceLambda x = do
   env <- get
   case (Map.lookup "LISH_DEBUG" env) of
-    Just _ -> liftIO $ do
+    Just (Str "true") -> liftIO $ do
       putText "------"
       putStr ("Env: " :: Text)
       putStrLn $ Pr.ppShow env

src/Lish/InternalCommands.hs

@@ -25,6 +25,9 @@ toArg (Atom x)          = do
 toArg (Str s)           = return $ Just $ toS s
 toArg (Num i) = return . Just . toS . show $ i
 toArg (Stream (Just h)) = lift $ fmap (Just . Text.strip .toS) (hGetContents h)
+toArg (List xs) = do
+  strs <- traverse toArg (map unFix xs)
+  return (Just ("["<> (Text.intercalate " " (catMaybes strs)) <> "]"))
 toArg _                 = return $ Nothing
 
 -- | Print with return line
@@ -53,14 +56,6 @@ undef ((Atom name):[]) = do
   return Void
 undef x = evalErr $ "undef wait an atom got" <> toS (show x)
 
--- | Export a var as Environment variable
-export :: ReduceUnawareCommand
-export ((Atom name):v@(Str s):[]) = do
-  liftIO $ setEnv (toS name) (toS s)
-  modify (Map.insert name v)
-  return v
-export _ = evalErr $ "eval need an atom and a string (eval foo \"foo\")"
-
 -- | retrieve the value of a var
 getenv :: ReduceUnawareCommand
 getenv ((Atom varname):[]) = do
@@ -107,10 +102,6 @@ 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))
-
 bintest :: (Integer -> Integer -> Bool) -> ReduceUnawareCommand
 bintest f ((Num x):(Num y):[]) = return $ Bool (f x y)
 bintest _ args = evalErr $ "bin test need two numbers got " <> (toS (show args))
@@ -153,61 +144,16 @@ fn reducer (p:bodies) = do
         fromAtom _              = Nothing
 fn _ _ = return Void
 
-emptyCmd :: Command
-emptyCmd _ ((List []):[]) = return (Bool True)
-emptyCmd _ ((List _):[]) = return (Bool False)
-emptyCmd r (x@(Atom _):[]) = do
-  val <- r x
-  emptyCmd r (val:[])
-emptyCmd r (x@(Lambda _):[]) = do
-  val <- r x
-  emptyCmd r (val:[])
-emptyCmd _ _ = return Void
-
-firstCmd :: Command
-firstCmd _ ((List (x:_)):[]) = return (unFix x)
-firstCmd _ ((List _):[]) = return Void
-firstCmd r (x@(Atom _):[]) = do
-  val <- r x
-  firstCmd r (val:[])
-firstCmd r (x@(Lambda _):[]) = do
-  val <- r x
-  firstCmd r (val:[])
-firstCmd _ _ = return Void
-
-restCmd :: Command
-restCmd _ ((List (_:xs)):[]) = return (List xs)
-restCmd _ ((List _):[]) = return Void
-restCmd r (x@(Atom _):[]) = do
-  val <- r x
-  restCmd r (val:[])
-restCmd r (x@(Lambda _):[]) = do
-  val <- r x
-  restCmd r (val:[])
-restCmd _ _ = return Void
-
-consCmd :: Command
-consCmd _ (x:(List ls):[]) = return (List (Fix x:ls))
-consCmd r (x:y@(Atom _):[]) = do
-  val <- r y
-  consCmd r (x:val:[])
-consCmd r (x:y@(Lambda _):[]) = do
-  val <- r y
-  consCmd r (x:val:[])
-consCmd _ _ = return Void
-
 strictCommands :: [(Text,ReduceUnawareCommand)]
 strictCommands = [ ("prn", prn)
                  , ("pr", pr)
                  , (">", toWaitingStream)
                  , ("replace", replace)
                  , ("undef",undef)
-                 , ("export",export)
                  , ("getenv",getenv)
                  , ("$",getenv)
                  , ("str",str)
                  , ("atom",atom)
-                 , ("=",equal)
                  -- binary operators
                  , ("+",binop (+))
                  , ("-",binop (-))
@@ -247,11 +193,80 @@ lishIf reduceLambda (sexp:sexp1:sexp2:[]) = do
     _          -> evalErr "first argument to if must be a Bool"
 lishIf _ _ = evalErr "if need a bool, a then body and an else one"
 
+emptyCmd :: Command
+emptyCmd _ ((List []):[]) = return (Bool True)
+emptyCmd _ ((List _):[]) = return (Bool False)
+emptyCmd r (x@(Atom _):[]) = do
+  val <- r x
+  emptyCmd r (val:[])
+emptyCmd r (x@(Lambda _):[]) = do
+  val <- r x
+  emptyCmd r (val:[])
+emptyCmd _ _ = return Void
+
+firstCmd :: Command
+firstCmd reducer ((List (x:_)):[]) = reducer (unFix x)
+firstCmd _ ((List _):[]) = return Void
+firstCmd r (x@(Atom _):[]) = do
+  val <- r x
+  firstCmd r (val:[])
+firstCmd r (x@(Lambda _):[]) = do
+  val <- r x
+  firstCmd r (val:[])
+firstCmd _ _ = return Void
+
+restCmd :: Command
+restCmd _ ((List (_:xs)):[]) = return (List xs)
+restCmd _ ((List _):[]) = return Void
+restCmd r (x@(Atom _):[]) = do
+  val <- r x
+  restCmd r (val:[])
+restCmd r (x@(Lambda _):[]) = do
+  val <- r x
+  restCmd r (val:[])
+restCmd _ _ = return Void
+
+consCmd :: Command
+consCmd r (x:(List ls):[]) = do
+  xreduced <- r x
+  return (List (Fix xreduced:ls))
+consCmd r (x:y@(Atom _):[]) = do
+  val <- r y
+  consCmd r (x:val:[])
+consCmd r (x:y@(Lambda _):[]) = do
+  val <- r y
+  consCmd r (x:val:[])
+consCmd _ _ = return Void
+
+equal :: Command
+equal r ((List xs):(List ys):[]) = do
+  reducedListX <- traverse r (map unFix xs)
+  reducedListY <- traverse r (map unFix ys)
+  return (Bool (reducedListX == reducedListY))
+equal r (x:y:[]) = do
+  reducedX <- r x
+  reducedY <- r y
+  return (Bool (reducedX == reducedY))
+equal _ args     = evalErr $ "= need two args, got " <> (toS (show args))
+
+-- | Export a var as Environment variable
+export :: Command
+export _ ((Atom name):v@(Str s):[]) = do
+  liftIO $ setEnv (toS name) (toS s)
+  modify (Map.insert name v)
+  return v
+export r (n:value:[]) = do
+  reducedVal <- r value
+  export r (n:reducedVal:[])
+export _ _ = evalErr $ "eval need an atom and a string (eval foo \"foo\")"
+
 unstrictCommands :: [(Text,InternalCommand)]
 unstrictCommands = [ ("if", InternalCommand "if" lishIf)
                    , ("def", InternalCommand "def" def)
                    , ("fn", InternalCommand "fn" fn)
                    , ("do", InternalCommand "do" doCommand)
+                   , ("=", InternalCommand "=" equal)
+                   , ("export", InternalCommand "export" export)
                    -- list ops
                    , ("empty?",InternalCommand "empty?" emptyCmd)
                    , ("first",InternalCommand "first" firstCmd)