diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index c4386a1..45d4401 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -56,6 +56,11 @@ module Language.Haskell.GhcMod ( -- * SymbolDb , loadSymbolDb , isOutdated + -- * Output + , gmPutStr + , gmErrStr + , gmPutStrLn + , gmErrStrLn ) where import Language.Haskell.GhcMod.Boot @@ -76,3 +81,4 @@ import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Target +import Language.Haskell.GhcMod.Output diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index e434abb..9193ba8 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -39,6 +39,7 @@ import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Logging +import Language.Haskell.GhcMod.Stderr import System.FilePath import Prelude hiding ((.)) diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs index 2c0219f..d074a17 100644 --- a/Language/Haskell/GhcMod/Caching.hs +++ b/Language/Haskell/GhcMod/Caching.hs @@ -22,7 +22,7 @@ import Language.Haskell.GhcMod.Caching.Types import Language.Haskell.GhcMod.Logging -- | Cache a MonadIO action with proper invalidation. -cached :: forall m a d. (MonadIO m, GmLog m, GmState m, Serialize a, Eq d, Serialize d, Show d) +cached :: forall m a d. (Gm m, MonadIO m, Serialize a, Eq d, Serialize d, Show d) => FilePath -- ^ Directory to prepend to 'cacheFile' -> Cached m GhcModState d a -- ^ Cache descriptor -> d diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs index 7c1c7fa..a7a1bea 100644 --- a/Language/Haskell/GhcMod/Logging.hs +++ b/Language/Haskell/GhcMod/Logging.hs @@ -39,6 +39,7 @@ import Prelude import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Pretty +import Language.Haskell.GhcMod.Output gmSetLogLevel :: GmLog m => GmLogLevel -> m () gmSetLogLevel level = @@ -64,7 +65,7 @@ decreaseLogLevel l = pred l -- True -- >>> Just GmDebug <= Just GmException -- False -gmLog :: (MonadIO m, GmLog m) => GmLogLevel -> String -> Doc -> m () +gmLog :: (MonadIO m, GmLog m, GmEnv m) => GmLogLevel -> String -> Doc -> m () gmLog level loc' doc = do GhcModLog { gmLogLevel = Just level' } <- gmlHistory @@ -73,7 +74,7 @@ gmLog level loc' doc = do msgDoc = gmLogLevelDoc level <+>: sep [loc, doc] msg = dropWhileEnd isSpace $ gmRenderDoc msgDoc - when (level <= level') $ liftIO $ hPutStrLn stderr msg + when (level <= level') $ gmErrStrLn msg gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)]) diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 0d74b5d..0b392c9 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -35,10 +35,13 @@ import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Target +import Language.Haskell.GhcMod.Stderr import Control.Arrow (first) import Control.Applicative +import Control.Concurrent + import Control.Monad.Reader (runReaderT) import Control.Monad.State.Strict (runStateT) import Control.Monad.Trans.Journal (runJournalT) @@ -58,11 +61,21 @@ withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f) withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a withGhcModEnv' opt f crdl = do olddir <- liftIO getCurrentDirectory - gbracket_ (liftIO $ setCurrentDirectory $ cradleRootDir crdl) - (liftIO $ setCurrentDirectory olddir) - (f $ GhcModEnv opt crdl) + c <- liftIO newChan + let outp = case linePrefix opt of + Just _ -> GmOutputChan c + Nothing -> GmOutputStdio + gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opt crdl outp) where - gbracket_ ma mb mc = gbracket ma (const mb) (const mc) + setup c = liftIO $ do + setCurrentDirectory $ cradleRootDir crdl + forkIO $ stdoutGateway c + + teardown olddir tid = liftIO $ do + setCurrentDirectory olddir + killThread tid + + gbracket_ ma mb mc = gbracket ma mb (const mc) -- | Run a @GhcModT m@ computation. runGhcModT :: IOish m diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 0074ec3..5204c35 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -39,6 +39,7 @@ module Language.Haskell.GhcMod.Monad.Types ( , GmLogLevel(..) , GhcModLog(..) , GhcModError(..) + , Gm , GmEnv(..) , GmState(..) , GmLog(..) @@ -198,6 +199,8 @@ class Monad m => GmEnv m where gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-} +type Gm m = (GmEnv m, GmState m, GmLog m) + instance Monad m => GmEnv (GhcModT m) where gmeAsk = GhcModT ask gmeReader = GhcModT . reader diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs new file mode 100644 index 0000000..1ca9ee7 --- /dev/null +++ b/Language/Haskell/GhcMod/Output.hs @@ -0,0 +1,54 @@ +module Language.Haskell.GhcMod.Output ( + gmPutStr + , gmErrStr + , gmPutStrLn + , gmErrStrLn + ) where + +import Data.Char +import System.IO +import Control.Monad +import Control.Concurrent + +import Language.Haskell.GhcMod.Types hiding (LineSeparator) +import Language.Haskell.GhcMod.Monad.Types + +withLines :: (String -> String) -> String -> String +withLines f s = let + res = unlines $ map f $ lines s + in + case s of + [] -> res + _ | generalCategory (last s) /= LineSeparator -> + reverse $ drop 1 $ reverse res + _ -> res + +outputFns :: (GmEnv m, MonadIO m') => m (String -> m' (), String -> m' ()) +outputFns = do + GhcModEnv {..} <- gmeAsk + let Options {..} = gmOptions + + let pfx f = withLines f + let (outPfx, errPfx) = case linePrefix of + Nothing -> ( id, id ) + Just (op, ep) -> ( pfx (op++), pfx (ep++) ) + + return $ case gmOutput of + GmOutputStdio -> + (liftIO . putStr . outPfx , liftIO . hPutStr stderr . errPfx) + GmOutputChan c -> + (liftIO . writeChan c . outPfx, liftIO . writeChan c . errPfx) + +gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn + :: (MonadIO m, GmEnv m) => String -> m () + +gmPutStr str = do + putOut <- fst `liftM` outputFns + putOut str + +gmPutStrLn = gmPutStr . (++"\n") +gmErrStrLn = gmErrStr . (++"\n") + +gmErrStr str = do + putErr <- snd `liftM` outputFns + putErr str diff --git a/Language/Haskell/GhcMod/Stderr.hs b/Language/Haskell/GhcMod/Stderr.hs new file mode 100644 index 0000000..198f062 --- /dev/null +++ b/Language/Haskell/GhcMod/Stderr.hs @@ -0,0 +1,88 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . + +-- Derived from process:System.Process +-- Copyright (c) The University of Glasgow 2004-2008 + +module Language.Haskell.GhcMod.Stderr where + +import Data.List +import System.IO +import System.Exit +import System.Process +import Control.Monad +import Control.DeepSeq +import Control.Exception +import Control.Concurrent + +stdoutGateway :: Chan String -> IO () +stdoutGateway chan = do + l <- readChan chan + putStrLn l + stdoutGateway chan + +readProcessStderrChan :: + Chan String -> FilePath -> [String] -> String -> IO String +readProcessStderrChan cout exe args input = do + let cp = (proc exe args) { + std_out = CreatePipe + , std_err = CreatePipe + , std_in = CreatePipe + } + (Just i, Just o, Just e, h) <- createProcess cp + + _ <- forkIO $ reader e + + output <- hGetContents o + withForkWait (evaluate $ rnf output) $ \waitOut -> do + + -- now write any input + unless (null input) $ + ignoreSEx $ hPutStr i input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + ignoreSEx $ hClose i + + -- wait on the output + waitOut + hClose o + + res <- waitForProcess h + case res of + ExitFailure rv -> + processFailedException "readProcessStderrChan" exe args rv + ExitSuccess -> + return output + + where + ignoreSEx = handle (\(SomeException _) -> return ()) + reader h = ignoreSEx $ do + l <- hGetLine h + writeChan cout l + reader h + +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async body = do + waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) + mask $ \restore -> do + tid <- forkIO $ try (restore async) >>= putMVar waitVar + let wait = takeMVar waitVar >>= either throwIO return + restore (body wait) `onException` killThread tid + +processFailedException :: String -> String -> [String] -> Int -> IO a +processFailedException fn exe args rv = + error $ concat [fn, ": ", exe, " " + , intercalate " " (map show args) + , " (exit " ++ show rv ++ ")"] diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 66bb80f..6c61f9e 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -334,7 +334,7 @@ resolveGmComponent mums c@GmComponent {..} = do [ "-optP-include", "-optP" ++ macrosHeaderPath ] ] -resolveEntrypoint :: (IOish m, GmLog m) +resolveEntrypoint :: (IOish m, GmEnv m, GmLog m) => Cradle -> GmComponent 'GMCRaw ChEntrypoint -> m (GmComponent 'GMCRaw (Set ModulePath)) @@ -366,7 +366,7 @@ resolveChEntrypoints srcDir ChSetupEntrypoint = do chModToMod :: ChModuleName -> ModuleName chModToMod (ChModuleName mn) = mkModuleName mn -resolveModule :: (MonadIO m, GmLog m) => +resolveModule :: (MonadIO m, GmEnv m, GmLog m) => HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath) resolveModule env _srcDirs (Right mn) = liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 9156425..934d148 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -13,6 +13,7 @@ import Control.Monad.Error (Error(..)) import qualified Control.Monad.IO.Class as MTL import Control.Exception (Exception) import Control.Applicative +import Control.Concurrent import Control.Monad import Data.Serialize import Data.Version @@ -72,6 +73,9 @@ data Options = Options { outputStyle :: OutputStyle -- | Line separator string. , lineSeparator :: LineSeparator + -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout, + -- @snd@ is stderr prefix. + , linePrefix :: Maybe (String, String) -- | Verbosity , logLevel :: GmLogLevel -- | @ghc@ program name. @@ -96,6 +100,7 @@ defaultOptions :: Options defaultOptions = Options { outputStyle = PlainStyle , lineSeparator = LineSeparator "\0" + , linePrefix = Nothing , logLevel = GmWarning , ghcProgram = "ghc" , ghcPkgProgram = "ghc-pkg" @@ -125,9 +130,13 @@ data Cradle = Cradle { , cradleCabalFile :: Maybe FilePath } deriving (Eq, Show) +data GmOutput = GmOutputStdio + | GmOutputChan (Chan String) + data GhcModEnv = GhcModEnv { gmOptions :: Options , gmCradle :: Cradle + , gmOutput :: GmOutput } data GhcModLog = GhcModLog { diff --git a/ghc-mod.cabal b/ghc-mod.cabal index b935bd0..381cee0 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -119,11 +119,13 @@ Library Language.Haskell.GhcMod.Modules Language.Haskell.GhcMod.Monad Language.Haskell.GhcMod.Monad.Types + Language.Haskell.GhcMod.Output Language.Haskell.GhcMod.PathsAndFiles Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.Pretty Language.Haskell.GhcMod.Read Language.Haskell.GhcMod.SrcUtils + Language.Haskell.GhcMod.Stderr Language.Haskell.GhcMod.Target Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Utils diff --git a/src/GHCMod.hs b/src/GHCMod.hs index a81f938..8e94ab7 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -74,10 +74,10 @@ usage = \\n" ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++ "*Commands*\n\ - \ - version | --version\n\ + \ - version\n\ \ Print the version of the program.\n\ \\n\ - \ - help | --help\n\ + \ - help\n\ \ Print this help message.\n\ \\n\ \ - list [FLAGS...] | modules [FLAGS...]\n\ @@ -259,8 +259,12 @@ globalArgSpec = , option "l" ["tolisp"] "Format output as an S-Expression" $ NoArg $ \o -> Right $ o { outputStyle = LispStyle } - , option "b" ["boundary"] "Output line separator"$ + , option "b" ["boundary", "line-seperator"] "Output line separator"$ reqArg "SEP" $ \s o -> Right $ o { lineSeparator = LineSeparator s } + , option "" ["line-prefix"] "Output line separator"$ + reqArg "OUT,ERR" $ \s o -> let + [out, err] = splitOn "," s + in Right $ o { linePrefix = Just (out, err) } , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $ reqArg "OPT" $ \g o -> Right $ @@ -339,25 +343,29 @@ main :: IO () main = handler $ do hSetEncoding stdout utf8 args <- getArgs - - -- This doesn't handle --help and --version being given after any global - -- options. To do that we'd have to fiddle with getOpt. case parseGlobalArgs args of - Left e -> case globalCommands args of - Just s -> putStr s - Nothing -> throw e - - Right res@(_,cmdArgs) -> - case globalCommands cmdArgs of - Just s -> putStr s - Nothing -> progMain res + Left e -> throw e + Right res -> progMain res progMain :: (Options,[String]) -> IO () -progMain (globalOptions,cmdArgs) = do - (res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs - case res of - Right () -> return () - Left e -> exitError $ renderStyle ghcModStyle (gmeDoc e) +progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ do + case globalCommands cmdArgs of + Just s -> gmPutStr s + Nothing -> ghcCommands cmdArgs + where + hndle action = do + (e, _l) <- action + case e of + Right _ -> + return () + Left ed -> + exitError $ renderStyle ghcModStyle (gmeDoc ed) + +globalCommands :: [String] -> Maybe String +globalCommands (cmd:_) + | cmd == "help" = Just usage + | cmd == "version" = Just ghcModVersion +globalCommands _ = Nothing -- ghc-modi legacyInteractive :: IOish m => GhcModT m () @@ -367,10 +375,10 @@ legacyInteractive = do world <- getCurrentWorld legacyInteractiveLoop symdbreq world -bug :: String -> IO () +bug :: IOish m => String -> GhcModT m () bug msg = do - putStrLn $ notGood $ "BUG: " ++ msg - exitFailure + gmPutStrLn $ notGood $ "BUG: " ++ msg + liftIO exitFailure notGood :: String -> String notGood msg = "NG " ++ escapeNewlines msg @@ -422,20 +430,13 @@ legacyInteractiveLoop symdbreq world = do "" -> liftIO $ exitSuccess _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" - liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout + gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) legacyInteractiveLoop symdbreq world -globalCommands :: [String] -> Maybe String -globalCommands [] = Nothing -globalCommands (cmd:_) = case cmd of - _ | cmd == "help" -> Just usage - _ | cmd == "version" -> Just ghcModVersion - _ -> Nothing - ghcCommands :: IOish m => [String] -> GhcModT m () ghcCommands [] = fatalError "No command given (try --help)" ghcCommands (cmd:args) = do - liftIO . putStr =<< action args + gmPutStr =<< action args where action = case cmd of _ | cmd == "list" || cmd == "modules" -> modulesCmd