From d2ba02cdd9161056a8e0fc8086614c702ec0ab87 Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Thu, 6 Apr 2017 10:21:53 +0200 Subject: [PATCH] Strict functions fix --- lish.cabal | 10 +++--- package.yaml | 10 +++--- src/Lish/Core.hs | 2 +- src/Lish/Eval.hs | 67 +++++++++++++----------------------- src/Lish/InternalCommands.hs | 54 +++++++++++++++++------------ src/Lish/Types.hs | 18 +++++++--- 6 files changed, 81 insertions(+), 80 deletions(-) diff --git a/lish.cabal b/lish.cabal index ec8d8bc..5d93de0 100644 --- a/lish.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index 17263e6..43ed5ae 100644 --- a/package.yaml +++ b/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 diff --git a/src/Lish/Core.hs b/src/Lish/Core.hs index e76cf39..09c2475 100644 --- a/src/Lish/Core.hs +++ b/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 diff --git a/src/Lish/Eval.hs b/src/Lish/Eval.hs index 09cb1b5..28d0398 100644 --- a/src/Lish/Eval.hs +++ b/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 (Lambda (Fix expr:fexprs)) = do +_reduceLambda :: SExp -> StateT Env IO SExp +_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 - 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)) + Internal command -> (_commandFn command) reduceLambda exprs 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 (Atom x) = do +_reduceLambda command@(Internal _) = executeCommand command +_reduceLambda (Atom x) = do env <- get case Map.lookup x env of Just s -> return s - _ -> return $ Str x -reduceLambda x = return x + _ -> case InternalCommands.lookup x of + 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 diff --git a/src/Lish/InternalCommands.hs b/src/Lish/InternalCommands.hs index 1c31bde..468a9b2 100644 --- a/src/Lish/InternalCommands.hs +++ b/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 - reduced <- mapM reducer sexps - -- DEBUG -- liftIO $ putText "Reduced:" - -- DEBUG -- liftIO $ print reduced - -- DEBUG -- liftIO $ putText "----" - f reduced +toStrictCmd f reducer sexps = + f =<< mapM (deepReduce reducer) sexps -- | 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 = [ ("if",lishIf) - , ("def",def) - , ("fn",fn) - , ("do",doCommand) +unstrictCommands :: [(Text,InternalCommand)] +unstrictCommands = [ ("if", InternalCommand "if" lishIf) + , ("def", InternalCommand "def" def) + , ("fn", InternalCommand "fn" fn) + , ("do", InternalCommand "do" doCommand) ] -internalCommands :: Map.Map Text Command -internalCommands = (strictCommands & map (\(x,y) -> (x,toStrictCmd y))) +internalCommands :: Map.Map Text InternalCommand +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 diff --git a/src/Lish/Types.hs b/src/Lish/Types.hs index a397065..fb3ed30 100644 --- a/src/Lish/Types.hs +++ b/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 - , _cmdArgs :: [a]} + | Cmd { _cmdName :: 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 _) = "" repr (WaitingStream _) = "" @@ -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)