Put line-prefix'es on exceptions too

Language/Haskell/GhcMod.hs

@@ -61,6 +61,8 @@ module Language.Haskell.GhcMod (
   , gmErrStr
   , gmPutStrLn
   , gmErrStrLn
+  , gmUnsafePutStrLn
+  , gmUnsafeErrStrLn
   ) where
 
 import Language.Haskell.GhcMod.Boot

Language/Haskell/GhcMod/Internal.hs

@@ -53,6 +53,9 @@ module Language.Haskell.GhcMod.Internal (
   , GmComponentType(..)
   , GmModuleGraph(..)
   , prepareCabalHelper
+  -- * Misc stuff
+  , GHandler(..)
+  , gcatches
   ) where
 
 import GHC.Paths (libdir)

Language/Haskell/GhcMod/Output.hs

@@ -22,6 +22,8 @@ module Language.Haskell.GhcMod.Output (
   , gmErrStr
   , gmPutStrLn
   , gmErrStrLn
+  , gmUnsafePutStrLn
+  , gmUnsafeErrStrLn
   , gmReadProcess
   , stdoutGateway
   ) where
@@ -60,20 +62,29 @@ toGmLines "" = GmLines GmPartial ""
 toGmLines s | isNewline (last s) = GmLines GmTerminated s
 toGmLines s = GmLines GmPartial s
 
-outputFns :: (GmEnv m, MonadIO m') => m (GmLines String -> m' (), GmLines String -> m' ())
+outputFns :: (GmEnv m, MonadIO m')
+          => m (GmLines String -> m' (), GmLines String -> m' ())
 outputFns = do
-  GhcModEnv {..} <- gmeAsk
+  opts <- options
-  let Options {..} = gmOptions
+  env <- gmeAsk
+  return $ outputFns' opts (gmOutput env)
 
-  let pfx f = withLines f
+outputFns' :: MonadIO m'
+           => Options
+           -> GmOutput
+           -> (GmLines String -> m' (), GmLines String -> m' ())
+outputFns' opts output  = let
+  Options {..} = opts
 
-  let outPfx, errPfx :: GmLines String -> GmLines String
+  pfx f = withLines f
+
+  outPfx, errPfx :: GmLines String -> GmLines String
   (outPfx, errPfx) =
       case linePrefix of
         Nothing -> ( id, id )
         Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
-
+ in
-  return $ case gmOutput of
+  case output of
     GmOutputStdio  ->
         ( liftIO . putStr         . unGmLine . outPfx
         , liftIO . hPutStr stderr . unGmLine . errPfx)
@@ -95,6 +106,12 @@ gmErrStr str = do
   putErr <- snd `liftM` outputFns
   putErr $ toGmLines str
 
+-- | Only use these when you're sure there are no other writers on stdout
+gmUnsafePutStrLn, gmUnsafeErrStrLn
+    :: MonadIO m => Options -> String -> m ()
+gmUnsafePutStrLn opts = (fst $ outputFns' opts GmOutputStdio) . toGmLines
+gmUnsafeErrStrLn opts = (snd $ outputFns' opts GmOutputStdio) . toGmLines
+
 gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String)
 gmReadProcess = do
   GhcModEnv {..} <- gmeAsk
@@ -177,6 +194,6 @@ withForkWait async body = do
 
 processFailedException :: String -> String -> [String] -> Int -> IO a
 processFailedException fn exe args rv =
-      error $ concat [fn, ": ", exe, " "
+      error $ concat [ fn, ": ", exe, " "
                      , intercalate " " (map show args)
                      , " (exit " ++ show rv ++ ")"]

src/GHCMod.hs

@@ -23,7 +23,7 @@ import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
                         removeDirectoryRecursive)
 import System.Environment (getArgs)
 import System.Exit (exitFailure)
-import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush)
+import System.IO (stdout, hSetEncoding, utf8, hFlush)
 import System.Exit (exitSuccess)
 import Text.PrettyPrint
 import Prelude
@@ -327,20 +327,21 @@ data InteractiveOptions = InteractiveOptions {
       ghcModExtensions :: Bool
     }
 
-handler :: IO a -> IO a
+handler :: IOish m => GhcModT m a -> GhcModT m a
-handler = flip catches $
+handler = flip gcatches $
-          [ Handler $ \(FatalError msg) -> exitError msg
+          [ GHandler $ \(FatalError msg) -> exitError msg
-          , Handler $ \(InvalidCommandLine e) -> do
+          , GHandler $ \(InvalidCommandLine e) -> do
                 case e of
                   Left cmd ->
                       exitError $ "Usage for `"++cmd++"' command:\n\n"
                                   ++ (cmdUsage cmd usage) ++ "\n"
                                   ++ "ghc-mod: Invalid command line form."
                   Right msg -> exitError $ "ghc-mod: " ++ msg
+          , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e
           ]
 
 main :: IO ()
-main = handler $ do
+main = do
     hSetEncoding stdout utf8
     args <- getArgs
     case parseGlobalArgs args of
@@ -348,7 +349,7 @@ main = handler $ do
       Right res -> progMain res
 
 progMain :: (Options,[String]) -> IO ()
-progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ do
+progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do
     case globalCommands cmdArgs of
       Just s -> gmPutStr s
       Nothing -> ghcCommands cmdArgs
@@ -359,7 +360,7 @@ progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ do
        Right _ ->
            return ()
        Left ed ->
-           exitError $ renderStyle ghcModStyle (gmeDoc ed)
+           exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed)
 
 globalCommands :: [String] -> Maybe String
 globalCommands (cmd:_)
@@ -471,8 +472,12 @@ newtype InvalidCommandLine = InvalidCommandLine (Either String String)
     deriving (Show, Typeable)
 instance Exception InvalidCommandLine
 
-exitError :: String -> IO a
+exitError :: IOish m => String -> GhcModT m a
-exitError msg = hPutStrLn stderr (dropWhileEnd (=='\n') msg) >> exitFailure
+exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
+
+exitError' :: Options -> String -> IO a
+exitError' opts msg =
+    gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
 
 fatalError :: String -> a
 fatalError s = throw $ FatalError $ "ghc-mod: " ++ s