{-# 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 :: forall a c.
ListLikeProcessIO a c =>
String -> [String] -> IO (ExitCode, a, a)
runProgCommand String
prog [String]
args = do loc <- String -> IO (Maybe String)
findExecutable String
prog
                              case loc of
                                  Maybe String
Nothing -> (ExitCode, a, a) -> IO (ExitCode, a, a)
forall a. a -> IO 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 a. a -> IO a
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 :: forall a c. ListLikeProcessIO a c => String -> IO (ExitCode, a, a)
runShellCommand String
cmd = do
      sh <- IO String
shellFileName
      readProcessWithExitCode sh [shellCommandSwitch, cmd] 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 simplify 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
    (inpReadFd,inpWriteFd) <- IO (Fd, Fd)
System.Posix.IO.createPipe
    (outReadFd,outWriteFd) <- System.Posix.IO.createPipe
    [inpRead,inpWrite,outRead,outWrite] <- mapM fdToHandle [inpReadFd,inpWriteFd,outReadFd,outWriteFd]

    handle <- runProcess cmd args Nothing Nothing (Just inpRead) (Just outWrite) (Just outWrite)
    let inp = Handle
inpWrite
        out = Handle
outRead
        err = Handle
outRead
        separate = Bool
False
#endif
    hSetBuffering inp NoBuffering
    hSetBuffering out NoBuffering
    hSetBuffering err NoBuffering
    return SubprocessInfo { procCmd=cmd, procArgs=args, procHandle=handle, hIn=inp, hOut=out, hErr=err, bufRef=bufref, separateStdErr=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 a b. (a -> b) -> IO a -> IO b
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
                 bytesRead <- Handle -> Ptr CChar -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBufNonBlocking Handle
handle Ptr CChar
buffer Int
bufferSize
                 s <- peekCStringLen (buffer,bytesRead)
                 let mightHaveMore = Int
bytesRead Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
bufferSize
                 return (mightHaveMore, s)