    {-# LANGUAGE CPP #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE FunctionalDependencies #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE UndecidableInstances #-}
    {-# OPTIONS_GHC -fno-warn-orphans #-}
    module System.Process.Common
        ( ProcessMaker(process, showProcessMakerForUser)
        , ListLikeProcessIO(forceOutput, readChunks)
        , ProcessText
        , ProcessResult(pidf, outf, errf, intf, codef)
        , readProcessWithExitCode
        , readCreateProcessWithExitCode
        , readCreateProcessStrict
        , readCreateProcessLazy
        , showCmdSpecForUser
        , showCreateProcessForUser
        ) where

    import Control.Concurrent
    import Control.Exception as E (SomeException, onException, catch, mask, throw)
    import Control.Monad
    import Data.ListLike as ListLike (ListLike, null)
    import Data.ListLike.IO (ListLikeIO, hGetContents, hPutStr)
    import Data.Monoid ((<>))
    import Data.String (IsString)
    import Generics.Deriving.Instances ()
    import GHC.IO.Exception (IOErrorType(ResourceVanished), IOException(ioe_type))
    import Prelude hiding (null)
    import System.Exit (ExitCode(..))
    import System.IO (Handle, hClose, hFlush, BufferMode, hSetBuffering)
    import System.IO.Unsafe (unsafeInterleaveIO)
    import System.Process (CmdSpec(..), CreateProcess(cmdspec, cwd, std_err, std_in, std_out), StdStream(CreatePipe), ProcessHandle, createProcess, proc, showCommandForUser, waitForProcess, terminateProcess)
    import Utils (forkWait)

    #if __GLASGOW_HASKELL__ <= 709
    import Control.Applicative ((<$>), (<*>))
    import Data.Monoid (Monoid(mempty, mappend))
    #endif

    #if !MIN_VERSION_deepseq(1,4,2)
    import Control.DeepSeq (NFData)
    -- | This instance lets us use DeepSeq's force function on a stream of Chunks.
    instance NFData ExitCode
    #endif

    class ProcessMaker a where
        process :: a -> IO (Handle, Handle, Handle, ProcessHandle)
        showProcessMakerForUser :: a -> String

    -- | This is the usual maker argument to 'readCreateProcessLazy'.
    instance ProcessMaker CreateProcess where
        process :: CreateProcess -> IO (Handle, Handle, Handle, ProcessHandle)
    process CreateProcess
    p = do
          (Just inh, Just outh, Just errh, pid) <- CreateProcess
    -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    createProcess CreateProcess
    p { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
          return (inh, outh, errh, pid)
        showProcessMakerForUser :: CreateProcess -> String
    showProcessMakerForUser = CreateProcess -> String
    showCreateProcessForUser

    -- | Passing this to 'readCreateProcessLazy' as the maker argument allows
    -- you to set the buffer mode of the process stdout and stderr handles
    -- just after the handles are created.  These are set to
    -- BlockBuffering by default, but for running console commands
    -- LineBuffering is probably what you want.
    instance ProcessMaker (CreateProcess, BufferMode, BufferMode) where
        process :: (CreateProcess, BufferMode, BufferMode)
    -> IO (Handle, Handle, Handle, ProcessHandle)
    process (CreateProcess
    p, BufferMode
    outmode, BufferMode
    errmode) = do
          (Just inh, Just outh, Just errh, pid) <- CreateProcess
    -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    createProcess CreateProcess
    p { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
          hSetBuffering outh outmode
          hSetBuffering errh errmode
          return (inh, outh, errh, pid)
        showProcessMakerForUser :: (CreateProcess, BufferMode, BufferMode) -> String
    showProcessMakerForUser (CreateProcess
    p, BufferMode
    outmode, BufferMode
    errmode) =
            CreateProcess -> String
    showCreateProcessForUser CreateProcess
    p String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " outmode=" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ BufferMode -> String
    forall a. Show a => a -> String
    show BufferMode
    outmode String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ", errmode=" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ BufferMode -> String
    forall a. Show a => a -> String
    show BufferMode
    errmode

    class (IsString text, Monoid text, ListLike text char) => ProcessText text char

    class Monoid result => ProcessResult text result | result -> text where
        pidf :: ProcessHandle -> result
        outf :: text -> result
        errf :: text -> result
        intf :: SomeException -> result
        codef :: ExitCode -> result

    instance ListLikeProcessIO text char => ProcessResult text (ExitCode, text, text) where
        pidf :: ProcessHandle -> (ExitCode, text, text)
    pidf ProcessHandle
    _ = (ExitCode, text, text)
    forall a. Monoid a => a
    mempty
        codef :: ExitCode -> (ExitCode, text, text)
    codef ExitCode
    c = (ExitCode
    c, text
    forall a. Monoid a => a
    mempty, text
    forall a. Monoid a => a
    mempty)
        outf :: text -> (ExitCode, text, text)
    outf text
    x = (ExitCode
    forall a. Monoid a => a
    mempty, text
    x, text
    forall a. Monoid a => a
    mempty)
        errf :: text -> (ExitCode, text, text)
    errf text
    x = (ExitCode
    forall a. Monoid a => a
    mempty, text
    forall a. Monoid a => a
    mempty, text
    x)
        intf :: SomeException -> (ExitCode, text, text)
    intf SomeException
    e = SomeException -> (ExitCode, text, text)
    forall a e. (HasCallStack, Exception e) => e -> a
    throw SomeException
    e

    -- | A process usually has one 'ExitCode' at the end of its output, this 'Monoid'
    -- instance lets us build the type returned by 'System.Process.readProcessWithExitCode'.
    instance Monoid ExitCode where
        mempty :: ExitCode
    mempty = Int -> ExitCode
    ExitFailure Int
    0
        mappend :: ExitCode -> ExitCode -> ExitCode
    mappend ExitCode
    x (ExitFailure Int
    0) = ExitCode
    x
        mappend ExitCode
    _ ExitCode
    x = ExitCode
    x

    #if MIN_VERSION_base(4,11,0)
    instance Semigroup ExitCode where
      <> :: ExitCode -> ExitCode -> ExitCode
    (<>) = ExitCode -> ExitCode -> ExitCode
    forall a. Monoid a => a -> a -> a
    mappend
    #endif

    -- | Process IO is based on the 'ListLikeIO' class from the ListLike
    -- package
    class ListLikeIO text char => ListLikeProcessIO text char where
        forceOutput :: text -> IO text
        readChunks :: Handle -> IO [text]
        -- ^ Read from a handle, returning a lazy list of the monoid a.

    -- | Like 'System.Process.readProcessWithExitCode', but with
    -- generalized input and output type.  Aside from the usual text-like
    -- types, the output can be a list of Chunk a.  This lets you process
    -- the chunks received from stdout and stderr lazil, in the order they
    -- are received, as well as the exit code.  Utilities to handle Chunks
    -- are provided in System.Process.ListLike.
    readProcessWithExitCode
        :: ListLikeProcessIO text char =>
           FilePath                 -- ^ command to run
        -> [String]                 -- ^ any arguments
        -> text               -- ^ standard input
        -> IO (ExitCode, text, text) -- ^ exitcode, stdout, stderr
    readProcessWithExitCode :: forall text char.
    ListLikeProcessIO text char =>
    String -> [String] -> text -> IO (ExitCode, text, text)
    readProcessWithExitCode String
    cmd [String]
    args text
    input = CreateProcess -> text -> IO (ExitCode, text, text)
    forall maker text char.
    (ProcessMaker maker, ListLikeProcessIO text char) =>
    maker -> text -> IO (ExitCode, text, text)
    readCreateProcessWithExitCode (String -> [String] -> CreateProcess
    proc String
    cmd [String]
    args) text
    input

    readCreateProcessWithExitCode
        :: (ProcessMaker maker, ListLikeProcessIO text char) =>
           maker                     -- ^ command and arguments to run
        -> text                      -- ^ standard input
        -> IO (ExitCode, text, text) -- ^ exitcode, stdout, stderr
    readCreateProcessWithExitCode :: forall maker text char.
    (ProcessMaker maker, ListLikeProcessIO text char) =>
    maker -> text -> IO (ExitCode, text, text)
    readCreateProcessWithExitCode = maker -> text -> IO (ExitCode, text, text)
    forall maker text result char.
    (ProcessMaker maker, ProcessResult text result,
     ListLikeProcessIO text char) =>
    maker -> text -> IO result
    readCreateProcessStrict

    readCreateProcessStrict :: (ProcessMaker maker, ProcessResult text result, ListLikeProcessIO text char) =>
                               maker -> text -> IO result
    readCreateProcessStrict :: forall maker text result char.
    (ProcessMaker maker, ProcessResult text result,
     ListLikeProcessIO text char) =>
    maker -> text -> IO result
    readCreateProcessStrict maker
    maker text
    input = ((forall a. IO a -> IO a) -> IO result) -> IO result
    forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
    mask (((forall a. IO a -> IO a) -> IO result) -> IO result)
    -> ((forall a. IO a -> IO a) -> IO result) -> IO result
    forall a b. (a -> b) -> a -> b
    $ \forall a. IO a -> IO a
    restore -> do
        (inh, outh, errh, pid) <- maker -> IO (Handle, Handle, Handle, ProcessHandle)
    forall a.
    ProcessMaker a =>
    a -> IO (Handle, Handle, Handle, ProcessHandle)
    process maker
    maker
        flip onException
          (do terminateProcess pid; hClose inh; hClose outh; hClose errh;
              waitForProcess pid) $ restore $ do

          -- fork off a thread to start consuming stdout
          waitOut <- forkWait $ outf <$> (hGetContents outh >>= forceOutput)

          -- fork off a thread to start consuming stderr
          waitErr <- forkWait $ errf <$> (hGetContents errh >>= forceOutput)

          -- now write and flush any input.
          writeInput inh input

          -- wait on the output
          out <- waitOut
          err <- waitErr

          hClose outh
          hClose errh

          -- wait on the process
          ex <- codef <$> waitForProcess pid

          return $ out <> err <> ex

    -- | Like readCreateProcessStrict, but the output is read lazily.
    readCreateProcessLazy :: (ProcessMaker maker, ProcessResult a b, ListLikeProcessIO a c) => maker -> a -> IO b
    readCreateProcessLazy :: forall maker text result char.
    (ProcessMaker maker, ProcessResult text result,
     ListLikeProcessIO text char) =>
    maker -> text -> IO result
    readCreateProcessLazy maker
    maker a
    input = ((forall a. IO a -> IO a) -> IO b) -> IO b
    forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
    mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
    -> ((forall a. IO a -> IO a) -> IO b) -> IO b
    forall a b. (a -> b) -> a -> b
    $ \forall a. IO a -> IO a
    restore -> do
        (inh, outh, errh, pid) <- maker -> IO (Handle, Handle, Handle, ProcessHandle)
    forall a.
    ProcessMaker a =>
    a -> IO (Handle, Handle, Handle, ProcessHandle)
    process maker
    maker
        onException
          (restore $
           do -- fork off a thread to start consuming stdout
              -- Without unsafeIntereleaveIO the pid messsage gets stuck
              -- until some additional output arrives from the process.
              waitOut <- forkWait $ (<>) <$> return (pidf pid)
                                         <*> unsafeInterleaveIO (readInterleaved [(outf, outh), (errf, errh)] (codef <$> waitForProcess pid))
              writeInput inh input
              waitOut)
          (do terminateProcess pid; hClose inh; hClose outh; hClose errh;
              waitForProcess pid)

    -- | Helper function for readCreateProcessLazy.
    readInterleaved :: (ListLikeProcessIO a c, ProcessResult a b) =>
                       [(a -> b, Handle)] -> IO b -> IO b
    readInterleaved :: forall a c b.
    (ListLikeProcessIO a c, ProcessResult a b) =>
    [(a -> b, Handle)] -> IO b -> IO b
    readInterleaved [(a -> b, Handle)]
    pairs IO b
    finish = IO (MVar (Either Handle b))
    forall a. IO (MVar a)
    newEmptyMVar IO (MVar (Either Handle b))
    -> (MVar (Either Handle b) -> IO b) -> IO b
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b
    forall a b c.
    (ListLikeProcessIO a c, ProcessResult a b) =>
    [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b
    readInterleaved' [(a -> b, Handle)]
    pairs IO b
    finish

    readInterleaved' :: forall a b c. (ListLikeProcessIO a c, ProcessResult a b) =>
                        [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b
    readInterleaved' :: forall a b c.
    (ListLikeProcessIO a c, ProcessResult a b) =>
    [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b
    readInterleaved' [(a -> b, Handle)]
    pairs IO b
    finish MVar (Either Handle b)
    res = do
      ((a -> b, Handle) -> IO ThreadId) -> [(a -> b, Handle)] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (IO () -> IO ThreadId
    forkIO (IO () -> IO ThreadId)
    -> ((a -> b, Handle) -> IO ()) -> (a -> b, Handle) -> IO ThreadId
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((a -> b) -> Handle -> IO ()) -> (a -> b, Handle) -> IO ()
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry (a -> b) -> Handle -> IO ()
    readHandle) [(a -> b, Handle)]
    pairs
      Int -> IO b
    takeChunks ([(a -> b, Handle)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(a -> b, Handle)]
    pairs)
        where
          -- Forked thread to read the input and send it to takeChunks via
          -- the MVar.
          readHandle :: (a -> b) -> Handle -> IO ()
          readHandle :: (a -> b) -> Handle -> IO ()
    readHandle a -> b
    f Handle
    h = do
            cs <- Handle -> IO [a]
    forall text char.
    ListLikeProcessIO text char =>
    Handle -> IO [text]
    readChunks Handle
    h
            -- If the type returned as stdout and stderr is lazy we need
            -- to force it here in the producer thread - I'm not exactly
            -- sure why.  And why is String lazy?
            -- when (lazy (undefined :: a)) (void cs)
            mapM_ (\ a
    c -> MVar (Either Handle b) -> Either Handle b -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar (Either Handle b)
    res (b -> Either Handle b
    forall a b. b -> Either a b
    Right (a -> b
    f a
    c))) cs
            hClose h
            putMVar res (Left h)
          takeChunks :: Int -> IO b
          takeChunks :: Int -> IO b
    takeChunks Int
    0 = IO b
    finish
          takeChunks Int
    openCount = IO (Either Handle b)
    takeChunk IO (Either Handle b) -> (Either Handle b -> IO b) -> IO b
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Int -> Either Handle b -> IO b
    takeMore Int
    openCount
          takeMore :: Int -> Either Handle b -> IO b
          takeMore :: Int -> Either Handle b -> IO b
    takeMore Int
    openCount (Left Handle
    h) = Handle -> IO ()
    hClose Handle
    h IO () -> IO b -> IO b
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Int -> IO b
    takeChunks (Int
    openCount Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1)
          takeMore Int
    openCount (Right b
    x) =
              do xs <- IO b -> IO b
    forall a. IO a -> IO a
    unsafeInterleaveIO (IO b -> IO b) -> IO b -> IO b
    forall a b. (a -> b) -> a -> b
    $ Int -> IO b
    takeChunks Int
    openCount
                 return (x <> xs)
          takeChunk :: IO (Either Handle b)
    takeChunk = MVar (Either Handle b) -> IO (Either Handle b)
    forall a. MVar a -> IO a
    takeMVar MVar (Either Handle b)
    res IO (Either Handle b)
    -> (SomeException -> IO (Either Handle b)) -> IO (Either Handle b)
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `E.catch` (\ (SomeException
    e :: SomeException) -> Either Handle b -> IO (Either Handle b)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Either Handle b -> IO (Either Handle b))
    -> Either Handle b -> IO (Either Handle b)
    forall a b. (a -> b) -> a -> b
    $ b -> Either Handle b
    forall a b. b -> Either a b
    Right (b -> Either Handle b) -> b -> Either Handle b
    forall a b. (a -> b) -> a -> b
    $ SomeException -> b
    forall text result.
    ProcessResult text result =>
    SomeException -> result
    intf SomeException
    e)

    -- | Write and flush process input, closing the handle when done.
    -- Catch and ignore Resource Vanished exceptions, they just mean the
    -- process exited before all of its output was read.
    writeInput :: ListLikeProcessIO a c => Handle -> a -> IO ()
    writeInput :: forall a c. ListLikeProcessIO a c => Handle -> a -> IO ()
    writeInput Handle
    inh a
    input =
        IO () -> IO ()
    ignoreResourceVanished (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
          Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (a -> Bool
    forall full item. ListLike full item => full -> Bool
    ListLike.null a
    input) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
            Handle -> a -> IO ()
    forall full item. ListLikeIO full item => Handle -> full -> IO ()
    hPutStr Handle
    inh a
    input
            Handle -> IO ()
    hFlush Handle
    inh
          Handle -> IO ()
    hClose Handle
    inh -- stdin has been fully written

    -- | Wrapper for a process that provides a handler for the
    -- ResourceVanished exception.  This is frequently an exception we
    -- wish to ignore, because many processes will deliberately exit
    -- before they have read all of their input.
    ignoreResourceVanished :: IO () -> IO ()
    ignoreResourceVanished :: IO () -> IO ()
    ignoreResourceVanished IO ()
    action =
        IO ()
    action IO () -> (IOException -> IO ()) -> IO ()
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `E.catch` (\IOException
    e -> if IOException -> IOErrorType
    ioe_type IOException
    e IOErrorType -> IOErrorType -> Bool
    forall a. Eq a => a -> a -> Bool
    == IOErrorType
    ResourceVanished then () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return () else IOException -> IO ()
    forall a. IOException -> IO a
    ioError IOException
    e)

    -- | System.Process utility functions.
    showCreateProcessForUser :: CreateProcess -> String
    showCreateProcessForUser :: CreateProcess -> String
    showCreateProcessForUser CreateProcess
    p =
        CmdSpec -> String
    showCmdSpecForUser (CreateProcess -> CmdSpec
    cmdspec CreateProcess
    p) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> (String -> String) -> Maybe String -> String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe String
    "" (\ String
    d -> String
    " (in " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    d String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")") (CreateProcess -> Maybe String
    cwd CreateProcess
    p)

    showCmdSpecForUser :: CmdSpec -> String
    showCmdSpecForUser :: CmdSpec -> String
    showCmdSpecForUser (ShellCommand String
    s) = String
    s
    showCmdSpecForUser (RawCommand String
    p [String]
    args) = String -> [String] -> String
    showCommandForUser String
    p [String]
    args