Put line-prefix'es on exceptions too

This commit is contained in:
Daniel Gröber 2015-08-14 05:57:33 +02:00
parent f998c63c73
commit 55bf578b87
4 changed files with 48 additions and 21 deletions

View File

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

View File

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

View File

@ -22,6 +22,8 @@ module Language.Haskell.GhcMod.Output (
, gmErrStr , gmErrStr
, gmPutStrLn , gmPutStrLn
, gmErrStrLn , gmErrStrLn
, gmUnsafePutStrLn
, gmUnsafeErrStrLn
, gmReadProcess , gmReadProcess
, stdoutGateway , stdoutGateway
) where ) where
@ -60,20 +62,29 @@ toGmLines "" = GmLines GmPartial ""
toGmLines s | isNewline (last s) = GmLines GmTerminated s toGmLines s | isNewline (last s) = GmLines GmTerminated s
toGmLines s = GmLines GmPartial 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 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) = (outPfx, errPfx) =
case linePrefix of case linePrefix of
Nothing -> ( id, id ) Nothing -> ( id, id )
Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) ) Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
in
return $ case gmOutput of case output of
GmOutputStdio -> GmOutputStdio ->
( liftIO . putStr . unGmLine . outPfx ( liftIO . putStr . unGmLine . outPfx
, liftIO . hPutStr stderr . unGmLine . errPfx) , liftIO . hPutStr stderr . unGmLine . errPfx)
@ -95,6 +106,12 @@ gmErrStr str = do
putErr <- snd `liftM` outputFns putErr <- snd `liftM` outputFns
putErr $ toGmLines str 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 :: GmEnv m => m (FilePath -> [String] -> String -> IO String)
gmReadProcess = do gmReadProcess = do
GhcModEnv {..} <- gmeAsk GhcModEnv {..} <- gmeAsk
@ -177,6 +194,6 @@ withForkWait async body = do
processFailedException :: String -> String -> [String] -> Int -> IO a processFailedException :: String -> String -> [String] -> Int -> IO a
processFailedException fn exe args rv = processFailedException fn exe args rv =
error $ concat [fn, ": ", exe, " " error $ concat [ fn, ": ", exe, " "
, intercalate " " (map show args) , intercalate " " (map show args)
, " (exit " ++ show rv ++ ")"] , " (exit " ++ show rv ++ ")"]

View File

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