{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Yi.Process (runProgCommand, runShellCommand, shellFileName,
                   createSubprocess, readAvailable, SubprocessInfo(..), SubprocessId) where

import           Control.Exc             (orException)
import qualified Data.ListLike as L      (empty)
import           Foreign.C.String        (peekCStringLen)
import           Foreign.Marshal.Alloc   (allocaBytes)
import           System.Directory        (findExecutable)
import           System.Environment      (getEnv)
import           System.Exit             (ExitCode (ExitFailure))
import           System.IO               (BufferMode (NoBuffering), Handle, hSetBuffering, hGetBufNonBlocking)
import           System.Process          (ProcessHandle, runProcess)
import           System.Process.ListLike (ListLikeProcessIO, readProcessWithExitCode)
import           Yi.Buffer.Basic         (BufferRef)
import           Yi.Monad                (repeatUntilM)

#ifdef mingw32_HOST_OS
import           System.Process          (runInteractiveProcess)
#else
import           System.Posix.IO         (createPipe, fdToHandle)
#endif

runProgCommand :: ListLikeProcessIO a c => String -> [String] -> IO (ExitCode, a, a)
runProgCommand :: String -> [String] -> IO (ExitCode, a, a)
runProgCommand String
prog [String]
args = do Maybe String
loc <- String -> IO (Maybe String)
findExecutable String
prog
                              case Maybe String
loc of
                                  Maybe String
Nothing -> (ExitCode, a, a) -> IO (ExitCode, a, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
1, a
forall full item. ListLike full item => full
L.empty, a
forall full item. ListLike full item => full
L.empty)
                                  Just String
fp -> String -> [String] -> a -> IO (ExitCode, a, a)
forall text char.
ListLikeProcessIO text char =>
String -> [String] -> text -> IO (ExitCode, text, text)
readProcessWithExitCode String
fp [String]
args a
forall full item. ListLike full item => full
L.empty

------------------------------------------------------------------------
-- | Run a command using the system shell, returning stdout, stderr and exit code

shellFileName :: IO String
shellFileName :: IO String
shellFileName = IO String -> IO String -> IO String
forall a. IO a -> IO a -> IO a
orException (String -> IO String
getEnv String
"SHELL") (String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"/bin/sh")

shellCommandSwitch :: String
shellCommandSwitch :: String
shellCommandSwitch = String
"-c"

runShellCommand :: ListLikeProcessIO a c => String -> IO (ExitCode, a, a)
runShellCommand :: String -> IO (ExitCode, a, a)
runShellCommand String
cmd = do
      String
sh <- IO String
shellFileName
      String -> [String] -> a -> IO (ExitCode, a, a)
forall text char.
ListLikeProcessIO text char =>
String -> [String] -> text -> IO (ExitCode, text, text)
readProcessWithExitCode String
sh [String
shellCommandSwitch, String
cmd] a
forall full item. ListLike full item => full
L.empty


--------------------------------------------------------------------------------
-- Subprocess support (ie. async processes whose output goes to a buffer)

type SubprocessId = Integer

data SubprocessInfo = SubprocessInfo {
      SubprocessInfo -> String
procCmd :: FilePath,
      SubprocessInfo -> [String]
procArgs :: [String],
      SubprocessInfo -> ProcessHandle
procHandle :: ProcessHandle,
      SubprocessInfo -> Handle
hIn  :: Handle,
      SubprocessInfo -> Handle
hOut :: Handle,
      SubprocessInfo -> Handle
hErr :: Handle,
      SubprocessInfo -> BufferRef
bufRef :: BufferRef,
      SubprocessInfo -> Bool
separateStdErr :: Bool
      }

{-
Simon Marlow said this:

 It turns out to be dead easy to bind stderr and stdout to the same pipe. After a couple of minor tweaks the following now works:

 createProcess (proc cmd args){ std_out = CreatePipe,
                                std_err = UseHandle stdout }

Therefore it should be possible to simplifiy the following greatly with the new process package.

-}
createSubprocess :: FilePath -> [String] -> BufferRef -> IO SubprocessInfo
createSubprocess :: String -> [String] -> BufferRef -> IO SubprocessInfo
createSubprocess String
cmd [String]
args BufferRef
bufref = do

#ifdef mingw32_HOST_OS
    (inp,out,err,handle) <- runInteractiveProcess cmd args Nothing Nothing
    let separate = True
#else
    (Fd
inpReadFd,Fd
inpWriteFd) <- IO (Fd, Fd)
System.Posix.IO.createPipe
    (Fd
outReadFd,Fd
outWriteFd) <- IO (Fd, Fd)
System.Posix.IO.createPipe
    [Handle
inpRead,Handle
inpWrite,Handle
outRead,Handle
outWrite] <- (Fd -> IO Handle) -> [Fd] -> IO [Handle]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Fd -> IO Handle
fdToHandle [Fd
inpReadFd,Fd
inpWriteFd,Fd
outReadFd,Fd
outWriteFd]

    ProcessHandle
handle <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
cmd [String]
args Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
inpRead) (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
outWrite) (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
outWrite)
    let inp :: Handle
inp = Handle
inpWrite
        out :: Handle
out = Handle
outRead
        err :: Handle
err = Handle
outRead
        separate :: Bool
separate = Bool
False
#endif
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
inp BufferMode
NoBuffering
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
out BufferMode
NoBuffering
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
err BufferMode
NoBuffering
    SubprocessInfo -> IO SubprocessInfo
forall (m :: * -> *) a. Monad m => a -> m a
return SubprocessInfo :: String
-> [String]
-> ProcessHandle
-> Handle
-> Handle
-> Handle
-> BufferRef
-> Bool
-> SubprocessInfo
SubprocessInfo { procCmd :: String
procCmd=String
cmd, procArgs :: [String]
procArgs=[String]
args, procHandle :: ProcessHandle
procHandle=ProcessHandle
handle, hIn :: Handle
hIn=Handle
inp, hOut :: Handle
hOut=Handle
out, hErr :: Handle
hErr=Handle
err, bufRef :: BufferRef
bufRef=BufferRef
bufref, separateStdErr :: Bool
separateStdErr=Bool
separate }


-- Read as much as possible from handle without blocking
readAvailable :: Handle -> IO String
readAvailable :: Handle -> IO String
readAvailable Handle
handle = ([String] -> String) -> IO [String] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [String] -> IO String) -> IO [String] -> IO String
forall a b. (a -> b) -> a -> b
$ IO (Bool, String) -> IO [String]
forall (m :: * -> *) a. Monad m => m (Bool, a) -> m [a]
repeatUntilM (IO (Bool, String) -> IO [String])
-> IO (Bool, String) -> IO [String]
forall a b. (a -> b) -> a -> b
$ Handle -> IO (Bool, String)
readChunk Handle
handle

-- Read a chunk from a handle, bool indicates if there is potentially more data available
readChunk :: Handle -> IO (Bool, String)
readChunk :: Handle -> IO (Bool, String)
readChunk Handle
handle = do
    let bufferSize :: Int
bufferSize = Int
1024
    Int -> (Ptr CChar -> IO (Bool, String)) -> IO (Bool, String)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
bufferSize ((Ptr CChar -> IO (Bool, String)) -> IO (Bool, String))
-> (Ptr CChar -> IO (Bool, String)) -> IO (Bool, String)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buffer -> do
                 Int
bytesRead <- Handle -> Ptr CChar -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBufNonBlocking Handle
handle Ptr CChar
buffer Int
bufferSize
                 String
s <- CStringLen -> IO String
peekCStringLen (Ptr CChar
buffer,Int
bytesRead)
                 let mightHaveMore :: Bool
mightHaveMore = Int
bytesRead Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
bufferSize
                 (Bool, String) -> IO (Bool, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
mightHaveMore, String
s)