diff --git a/hython.cabal b/hython.cabal index 4c0df39..eea630a 100644 --- a/hython.cabal +++ b/hython.cabal @@ -29,6 +29,7 @@ executable hython build-tools: happy other-modules: Language.Python.Lexer, Language.Python.Parser, + Language.Python, REPL, Hython.Interpreter, Hython.Statement, @@ -36,6 +37,8 @@ executable hython Hython.Types, Hython.Expression, Hython.Builtins, + Hython.Name, + Hython.ExceptionHandling Hython.ControlFlow, Hython.Call, Hython.Ref, diff --git a/src/Hython/Interpreter.hs b/src/Hython/Interpreter.hs index 83a6ef0..ea8802b 100644 --- a/src/Hython/Interpreter.hs +++ b/src/Hython/Interpreter.hs @@ -7,7 +7,7 @@ import Prelude hiding (readFile) import Control.Monad (filterM, forM_, unless, when) import Control.Monad.Cont.Class (MonadCont) -import Control.Monad.Cont (ContT, runContT) +import Control.Monad.Cont (ContT, runContT, callCC) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State.Strict (StateT, gets, modify, runStateT) import Data.List (find) @@ -15,7 +15,6 @@ import Data.Text (Text) import Data.Text.IO (readFile) import qualified Data.Text as T import System.Directory (canonicalizePath, doesFileExist, getDirectoryContents) -import System.Exit (exitFailure) import System.Environment.Executable (splitExecutablePath) import System.FilePath @@ -38,6 +37,7 @@ data InterpreterState = InterpreterState { stateEnv :: Env , stateFlow :: Flow Object Continuation , stateNew :: Bool + , stateErrorMsg :: Maybe String , stateCurModule :: ModuleInfo , stateModules :: [ModuleInfo] , stateResults :: [String] @@ -87,6 +87,7 @@ defaultInterpreterState path = do stateCurModule = main, stateModules = [main], stateNew = True, + stateErrorMsg = Nothing, stateResults = [] } where @@ -110,17 +111,13 @@ defaultContinueHandler _ = raise "SyntaxError" "'continue' not properly in loop" defaultExceptionHandler :: Object -> Interpreter () defaultExceptionHandler ex = do - case ex of + message <- case ex of Object info -> do + let cls = T.unpack . className . objectClass $ info msg <- toStr =<< invoke ex "__str__" [] - - liftIO $ do - putStr . T.unpack . className . objectClass $ info - putStr ": " - putStrLn msg - _ -> liftIO $ putStrLn "o_O: raised a non-object exception" - - liftIO exitFailure + return $ cls ++ ": " ++ msg + _ -> return "o_O: raised a non-object exception" + Interpreter $ modify (\s -> s { stateErrorMsg = Just message }) defaultReturnHandler :: Object -> Interpreter () defaultReturnHandler _ = raise "SyntaxError" "'return' outside function" @@ -149,13 +146,22 @@ runInterpreter state code = case parse code of let firstTime = stateNew state (_, newState) <- runStateT (runContT (unwrap $ run firstTime stmts) return) state - let results = stateResults newState - return (Right results, newState { stateNew = False, stateResults = [] }) + let results = case stateErrorMsg newState of + Just msg -> Left msg + Nothing -> Right $ stateResults newState + return (results, newState + { stateNew = False + , stateErrorMsg = Nothing + , stateResults = [] }) where run firstTime stmts = do when firstTime $ do loadBuiltinModules Environment.moveLocalsToBuiltins - evalBlock stmts - return None + callCC $ \done -> do + ControlFlow.setExceptionHandler (\ex -> do + defaultExceptionHandler ex + done ex) + evalBlock stmts + return None diff --git a/src/Language/Python/Parser.y b/src/Language/Python/Parser.y index a89ed0a..3b5621b 100644 --- a/src/Language/Python/Parser.y +++ b/src/Language/Python/Parser.y @@ -13,6 +13,7 @@ import qualified Language.Python.Lexer as L %tokentype {L.Token} %error { parseError } +%monad { Either String } { (>>=) } { return } %name parseTokens file_input %name parseLine single_input @@ -691,15 +692,15 @@ mkName s = Name . T.pack $ s parse :: Text -> Either String [Statement] parse code = do case L.lex code of - Right tokens -> Right $ parseTokens tokens - Left err -> Left $ show err + Right tokens -> parseTokens tokens + Left err -> Left $ "SyntaxError: " ++ show err parseRepl :: Text -> Either String [Statement] parseRepl code = do case L.lex code of - Right tokens -> Right $ parseLine tokens + Right tokens -> parseLine tokens Left err -> Left $ show err -parseError :: [L.Token] -> a -parseError t = error $ "Parse error: " ++ show t +parseError t = Left $ "SyntaxError: at " ++ show t + } diff --git a/src/Main.hs b/src/Main.hs index 265a4d3..8290e3e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -10,8 +10,8 @@ import Data.Text.IO (readFile) import System.Environment import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) import System.IO.Error -import Text.Printf import Hython.Interpreter (defaultInterpreterState, runInterpreter) import REPL (runREPL) @@ -23,7 +23,8 @@ main = do [] -> runREPL [filename] -> runScript filename _ -> do - putStrLn "Usage: hython " + progName <- getProgName + hPutStrLn stderr $ "Usage: " ++ progName ++ " [filename]" exitFailure runScript :: FilePath -> IO () @@ -33,12 +34,13 @@ runScript path = do (result, _) <- runInterpreter state code case result of - Left msg -> putStrLn msg + Left msg -> do + hPutStrLn stderr msg + exitFailure Right _ -> return () where errorHandler :: String -> IOError -> IO Text errorHandler _ err = do - putStrLn $ printf "Unable to open '%s': file %s" path (ioeGetErrorString err) - _ <- exitFailure - return "" + putStrLn $ "Unable to open '" ++ path ++ "': " ++ ioeGetErrorString err + exitFailure