diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 45d4401..d1eecd8 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -61,6 +61,8 @@ module Language.Haskell.GhcMod ( , gmErrStr , gmPutStrLn , gmErrStrLn + , gmUnsafePutStrLn + , gmUnsafeErrStrLn ) where import Language.Haskell.GhcMod.Boot diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 143dc5f..ea480c8 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/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) diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs index fffb1c2..e96956a 100644 --- a/Language/Haskell/GhcMod/Output.hs +++ b/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 - let Options {..} = gmOptions + opts <- options + 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 - (outPfx, errPfx) = - case linePrefix of - Nothing -> ( id, id ) - Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) ) + pfx f = withLines f - return $ case gmOutput of + outPfx, errPfx :: GmLines String -> GmLines String + (outPfx, errPfx) = + case linePrefix of + Nothing -> ( id, id ) + Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) ) + in + 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 ++ ")"] diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 06156f9..7c738cc 100644 --- a/src/GHCMod.hs +++ b/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 = flip catches $ - [ Handler $ \(FatalError msg) -> exitError msg - , Handler $ \(InvalidCommandLine e) -> do +handler :: IOish m => GhcModT m a -> GhcModT m a +handler = flip gcatches $ + [ GHandler $ \(FatalError msg) -> exitError msg + , 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 msg = hPutStrLn stderr (dropWhileEnd (=='\n') msg) >> exitFailure +exitError :: IOish m => String -> GhcModT m a +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