Strict functions fix

lish.cabal

@@ -26,7 +26,7 @@ source-repository head
 library
   hs-source-dirs:
       src
-  ghc-options: -Wall -Werror -O2
+  ghc-options: -Wall -O2
   build-depends:
       base >= 4.8 && < 5
     , containers
@@ -52,7 +52,7 @@ executable lish
   main-is: Main.hs
   hs-source-dirs:
       src-exe
-  ghc-options: -Wall -Werror -O2 -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >= 4.8 && < 5
     , containers
@@ -71,7 +71,7 @@ test-suite lish-benchmark
   main-is: Main.hs
   hs-source-dirs:
       src-benchmark
-  ghc-options: -Wall -Werror -O2 -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >= 4.8 && < 5
     , containers
@@ -92,7 +92,7 @@ test-suite lish-doctest
   main-is: Main.hs
   hs-source-dirs:
       src-doctest
-  ghc-options: -Wall -Werror -O2 -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >= 4.8 && < 5
     , containers
@@ -115,7 +115,7 @@ test-suite lish-test
   main-is: Main.hs
   hs-source-dirs:
       src-test
-  ghc-options: -Wall -Werror -O2 -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >= 4.8 && < 5
     , containers

package.yaml

@@ -10,7 +10,7 @@ extra-source-files:
   - README.md
   - stack.yaml
 
-ghc-options: -Wall -Werror -O2
+ghc-options: -Wall -O2
 
 dependencies:
   - base >= 4.8 && < 5
@@ -28,7 +28,7 @@ library:
 
 executables:
   lish:
-    ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
+    ghc-options: -threaded -rtsopts -with-rtsopts=-N
     main: Main.hs
     source-dirs: src-exe
     dependencies:
@@ -38,7 +38,7 @@ tests:
   lish-test:
     source-dirs: src-test
     main: Main.hs
-    ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
+    ghc-options: -threaded -rtsopts -with-rtsopts=-N
     dependencies:
       - lish
       - base >= 4.8 && < 5
@@ -50,7 +50,7 @@ tests:
   lish-doctest:
     source-dirs: src-doctest
     main: Main.hs
-    ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
+    ghc-options: -threaded -rtsopts -with-rtsopts=-N
     dependencies:
       - lish
       - base >= 4.8 && < 5
@@ -60,7 +60,7 @@ tests:
   lish-benchmark:
     source-dirs: src-benchmark
     main: Main.hs
-    ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N
+    ghc-options: -threaded -rtsopts -with-rtsopts=-N
     dependencies:
       - lish
       - base >= 4.8 && < 5

src/Lish/Core.hs

@@ -26,7 +26,7 @@ runLish :: IO ()
 runLish = do
   env <- toEnv <$> getEnvironment
   runInputT (defaultSettings { historyFile = Just ".lish-history" })
-    (mainLoop Nothing env "")
+    (mainLoop Nothing mempty "")
 
 -- | System Environment -> LISH Env
 toEnv :: [(String,String)] -> Env

src/Lish/Eval.hs

@@ -65,45 +65,40 @@ isReduced _ = True
 -- | The main evaluation function
 -- its real type should be something isomorphic to
 -- (SExp,Environment) -> IO (SExp, Environment)
-reduceLambda :: SExp -> StateT Env IO SExp
+_reduceLambda :: SExp -> StateT Env IO SExp
-reduceLambda (Lambda (Fix expr:fexprs)) = do
+_reduceLambda (Lambda (Fix expr:fexprs)) = do
   let exprs = map unFix fexprs
   reduced <- reduceLambda expr
   if isReduced reduced
     then 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
+        Internal command -> (_commandFn command) reduceLambda exprs
-          resultInternal <- tryInternalCommand f exprs
-          case resultInternal of
-            Just x -> return x
-            Nothing -> do
-              resultEnv <- tryEnvCommand f exprs
-              case resultEnv of
-                Just x  -> return x
-                Nothing -> do
-                  reducedArgs <- mapM reduceLambda exprs
-                  executeCommand (Command (Fix (Str f))
-                                          (map Fix reducedArgs))
         f@(Fn _ _ _ _) -> applyFn f exprs
         s  -> do
           reducedArgs <- mapM reduceLambda exprs
-          executeCommand $ Command (Fix s) (map Fix reducedArgs)
+          executeCommand (Cmd (Fix s) (map Fix reducedArgs))
     else reduceLambda (Lambda . map Fix $ (reduced:exprs))
-reduceLambda command@(Command _ _) = executeCommand command
+_reduceLambda command@(Internal  _) = executeCommand command
-reduceLambda (Atom x) = do
+_reduceLambda (Atom x) = do
   env <- get
   case Map.lookup x env of
     Just s -> return s
-    _      -> return $ Str x
+    _      -> case InternalCommands.lookup x of
-reduceLambda x          = return x
+      Just cmd -> return (Internal cmd)
+      _         -> return (Str x)
+_reduceLambda x          = return x
+
+reduceLambda :: SExp -> StateT Env IO SExp
+reduceLambda x = do
+  -- DEBUG --env <- get
+  -- DEBUG --liftIO $ do
+  -- DEBUG --    putText "------"
+  -- DEBUG --    putStr ("Env: " :: Text)
+  -- DEBUG --    print env
+  -- DEBUG --    putStr ("Arg: " :: Text)
+  -- DEBUG --    putStrLn $ pprint (Fix x)
+  _reduceLambda x
+
 
 applyFn :: SExp -> ReduceUnawareCommand
 applyFn (Fn par bod clos _) args =
@@ -114,25 +109,11 @@ applyFn (Fn par bod clos _) args =
       currentEnv <- get
       -- Run the function in its own closure
       fmap fst $ liftIO $
-        runStateT (reduceLambda (unFix bod)) (Map.union currentEnv localClosure)
+        runStateT (reduceLambda (unFix bod)) (Map.union localClosure currentEnv)
   where
     bindVars oldenv newvars = Map.union oldenv (Map.fromList newvars)
 applyFn x _ = return x
 
-tryEnvCommand :: Text -> [SExp] -> StateT Env IO (Maybe SExp)
-tryEnvCommand f args = do
-  envcmd <- get
-  case Map.lookup f envcmd of
-    Just fn@(Fn _ _ _ _) -> Just <$> (applyFn fn args)
-    _                    -> return Nothing
-
-
-tryInternalCommand :: Text -> [SExp] -> StateT Env IO (Maybe SExp)
-tryInternalCommand f args =
-  case InternalCommands.lookup f of
-    Just (fn) -> Just <$> fn reduceLambda args
-    _         -> return Nothing
-
 -- | take a SExp
 toStdIn :: SExp -> Maybe Handle
 toStdIn (WaitingStream h) = h
@@ -145,7 +126,7 @@ shellErr errmsg = do
 
 -- | Execute a shell command
 executeCommand :: SExp -> StateT Env IO SExp
-executeCommand (Command (Fix (Str cmdName)) args) = do
+executeCommand (Cmd (Fix (Str cmdName)) args) = do
   res <- (mapM toArg (map unFix args)) >>= return . catMaybes
   let argsHandle = (filter isJust (map toStdIn (map unFix args)))
       stdinhandle = case argsHandle of

src/Lish/InternalCommands.hs

@@ -7,20 +7,21 @@ module Lish.InternalCommands
   )
   where
 
-import Data.Fix
+import           Data.Fix
 import qualified Data.Map.Strict    as Map
 import qualified Data.Text          as Text
 import           GHC.IO.Handle      (hGetContents)
-import           Lish.Types
 import           Protolude          hiding (show)
 import           System.Environment (setEnv)
 
+import           Lish.Types
+
 toArg :: SExp -> StateT Env IO (Maybe Text)
 toArg (Atom x)          = do
   env <- get
   return $ Just $ case Map.lookup x env of
     Just (Str s) -> s
-    _ -> toS x
+    _            -> toS x
 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)
@@ -100,7 +101,7 @@ bbinop _ _ = evalErr "boolean binary operator need two booleans arguments"
 
 lnot :: ReduceUnawareCommand
 lnot ((Bool x):[]) = return ( Bool (not x))
-lnot _ = evalErr "not need a boolean"
+lnot _             = evalErr "not need a boolean"
 
 toWaitingStream :: ReduceUnawareCommand
 toWaitingStream (Stream (Just h) :[]) = return (WaitingStream (Just h))
@@ -108,19 +109,28 @@ toWaitingStream _                     = return Void
 
 equal :: ReduceUnawareCommand
 equal (x:y:[]) = return (Bool (x == y))
-equal args = evalErr $ "= need two args, got " <> (toS (show args))
+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))
 
+isReduced :: SExp -> Bool
+isReduced (Atom _) = False
+isReduced (Lambda _) = False
+isReduced _ = True
+
+deepReduce :: (Monad m) => (SExp -> m SExp) -> SExp -> m SExp
+deepReduce f x =
+  if isReduced x
+  then pure x
+  else do
+    reducedOnce <- f x
+    deepReduce f reducedOnce
+
 toStrictCmd :: ReduceUnawareCommand -> Command
-toStrictCmd f reducer sexps = do
+toStrictCmd f reducer sexps =
-  reduced <- mapM reducer sexps
+  f =<< mapM (deepReduce reducer) sexps
-  -- DEBUG -- liftIO $ putText "Reduced:"
-  -- DEBUG -- liftIO $ print reduced
-  -- DEBUG -- liftIO $ putText "----"
-  f reduced
 
 -- | fn to declare a lish function
 -- (fn [arg1 arg2] body1 body2)
@@ -140,7 +150,7 @@ fn reducer (p:bodies) = do
         else return Void
     _ -> return Void
   where fromAtom (Fix (Atom a)) = Just a
-        fromAtom _ = Nothing
+        fromAtom _              = Nothing
 fn _ _ = return Void
 
 strictCommands :: [(Text,ReduceUnawareCommand)]
@@ -189,22 +199,22 @@ lishIf :: Command
 lishIf reduceLambda (sexp:sexp1:sexp2:[]) = do
   reducedSexp <- reduceLambda sexp
   case reducedSexp of
-    Bool True -> reduceLambda sexp1
+    Bool True  -> reduceLambda sexp1
     Bool False -> reduceLambda sexp2
-    _ -> evalErr "first argument to if must be a Bool"
+    _          -> evalErr "first argument to if must be a Bool"
 lishIf _ _ = evalErr "if need a bool, a then body and an else one"
 
-unstrictCommands :: [(Text,Command)]
+unstrictCommands :: [(Text,InternalCommand)]
-unstrictCommands = [ ("if",lishIf)
+unstrictCommands = [ ("if", InternalCommand "if" lishIf)
-                   , ("def",def)
+                   , ("def", InternalCommand "def" def)
-                   , ("fn",fn)
+                   , ("fn", InternalCommand "fn" fn)
-                   , ("do",doCommand)
+                   , ("do", InternalCommand "do" doCommand)
                    ]
 
-internalCommands :: Map.Map Text Command
+internalCommands :: Map.Map Text InternalCommand
-internalCommands = (strictCommands & map (\(x,y) -> (x,toStrictCmd y)))
+internalCommands = (strictCommands & map (\(x,y) -> (x,InternalCommand x (toStrictCmd y))))
                    <> unstrictCommands
   & Map.fromList
 
-lookup :: Text -> Maybe Command
+lookup :: Text -> Maybe InternalCommand
 lookup = flip Map.lookup internalCommands

src/Lish/Types.hs

@@ -12,6 +12,7 @@ module Lish.Types
   , Env
   , CmdStream
   , Command
+  , InternalCommand (..)
   , ReduceUnawareCommand
   -- types
   , LishType(..)
@@ -34,16 +35,17 @@ data ExprF a = Atom Text
              | Lambda [a]
              | Void
               -- only exists during evaluation
+             | Internal InternalCommand
              | Fn { params  :: [Text]
                   , body    :: a
                   , closure :: Env
                   , types   :: ([LishType],LishType)
                   }
-             | Command { _cmdName :: a
+             | Cmd { _cmdName :: a
-                       , _cmdArgs :: [a]}
+                   , _cmdArgs :: [a]}
              | Stream CmdStream
              | WaitingStream CmdStream
-             deriving (Eq,Show,Functor)
+             deriving (Eq, Show, Functor)
 
 type Expr = Fix ExprF
 type SExp = ExprF Expr
@@ -61,13 +63,14 @@ type Context = Map Text LishType
 
 repr :: ExprF Text -> Text
 repr (Atom s)          = s
+repr (Internal (InternalCommand n _))    = n
 repr (Num n)           = toS $ show n
 repr (Bool b)          = if b then "true" else "false"
 repr (Str s)           = "\"" <> toS s <> "\""
 repr (List sexprs)     = "[" <> (Text.intercalate " " sexprs) <> "]"
 repr (Lambda sexprs)   = "(" <> (Text.intercalate " " sexprs) <> ")"
 repr Void              = "ε"
-repr (Command n args)  = "($ " <> n <> (Text.intercalate " " args) <> ")"
+repr (Cmd n args)  = "($ " <> n <> (Text.intercalate " " args) <> ")"
 repr (Fn p _ _ _)      = "(λ" <> (Text.intercalate "." p) <> ". ... )"
 repr (Stream _)        = "<stream>"
 repr (WaitingStream _) = "<w-stream>"
@@ -79,3 +82,10 @@ type CmdStream = Maybe Handle
 type Env = Map Text SExp
 type ReduceUnawareCommand = [SExp] -> StateT Env IO SExp
 type Command = (SExp -> StateT Env IO SExp) -> ReduceUnawareCommand
+data InternalCommand =
+  InternalCommand { _commandName :: Text
+                  , _commandFn :: Command }
+instance Show InternalCommand where
+  show x = toS (_commandName x)
+instance Eq InternalCommand where
+  (==) x y = (_commandName x) == (_commandName y)