Improve error handling

hython.cabal

@@ -29,13 +29,16 @@ executable        hython
   build-tools:    happy
   other-modules:  Language.Python.Lexer,
                   Language.Python.Parser,
+                  Language.Python,
                   REPL,
                   Hython.Interpreter,
                   Hython.Statement,
                   Hython.Environment,
                   Hython.Types,
                   Hython.Expression,
                   Hython.Builtins,
+                  Hython.Name,
+                  Hython.ExceptionHandling
                   Hython.ControlFlow,
                   Hython.Call,
                   Hython.Ref,

src/Hython/Interpreter.hs

@@ -7,15 +7,14 @@ 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)
 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

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
+
 }

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 <filename>"
+            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