Start implementing line-prefix stuff

readProcess wrapper still missing from CabalHelper

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

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 ((.))
 

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

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)])
 

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)
+    c <- liftIO newChan
-              (liftIO $ setCurrentDirectory olddir)
+    let outp = case linePrefix opt of
-              (f $ GhcModEnv opt crdl)
+                 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

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

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

Language/Haskell/GhcMod/Stderr.hs

@@ -0,0 +1,88 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- 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 <http://www.gnu.org/licenses/>.
+
+-- 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 ++ ")"]

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

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 {

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

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
+      Left e -> throw e
-                  Just s -> putStr s
+      Right res -> progMain res
-                  Nothing -> throw e
-
-      Right res@(_,cmdArgs) ->
-          case globalCommands cmdArgs of
-            Just s -> putStr s
-            Nothing -> progMain res
 
 progMain :: (Options,[String]) -> IO ()
-progMain (globalOptions,cmdArgs) = do
+progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ do
-    (res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs
+    case globalCommands cmdArgs of
-    case res of
+      Just s -> gmPutStr s
-      Right () -> return ()
+      Nothing -> ghcCommands cmdArgs
-      Left e -> exitError $ renderStyle ghcModStyle (gmeDoc e)
+ 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
+  gmPutStrLn $ notGood $ "BUG: " ++ msg
-  exitFailure
+  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