{-# LANGUAGE CPP #-}

{-|
Some simple String wrappers of `readProcess`, `readProcessWithExitCode`,
`rawSystem` from the Haskell <https://hackage.haskell.org/package/process process> library.

Simplest is

@cmd_ :: String -> [String] -> IO ()@

which outputs to stdout. For example:

@cmd_ "git" ["clone", url]@

Then

@cmd :: String -> [String] -> IO String@

returns stdout as a @String@.

There are also @cmdBool@, @cmdMaybe@, @cmdLines@, @shell@, and others.

Other examples:

@grep_ pat file :: IO Bool@

@sudo c args :: IO ()@

-}

module SimpleCmd (
  cmd, cmd_,
  cmdBool,
  cmdIgnoreErr, {- badly named -}
  cmdLines,
  cmdMaybe,
  cmdFull,
  cmdLog_, cmdLog, cmdlog {-TODO: remove for 0.3 -},
  cmdN,
  cmdQuiet,
  cmdSilent,
  cmdStdIn,
  cmdStdErr,
  cmdTry_,
  cmdStderrToStdout,
  cmdStderrToStdoutIn,
  needProgram,
  error',
  warning,
  newline,
  logMsg,
  (+-+),
  removePrefix, removeStrictPrefix, removeSuffix,
  egrep_, grep, grep_,
  shell, shell_,
  shellBool,
#ifndef mingw32_HOST_OS
  sudo, sudo_, sudoLog, sudoInternal,
#endif
  PipeCommand,
  pipe, pipe_, pipeBool,
  pipe3, pipe3_, pipeFile_,
  ifM,
  whenM,
  filesWithExtension,
  fileWithExtension,
  timeIO
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Exception
import Control.Monad.Extra

import Data.List (
#if !MIN_VERSION_filepath(1,4,2)
  isSuffixOf,
#endif
  stripPrefix)
import Data.Maybe (isJust, isNothing, fromMaybe)
import Data.Time.Clock
#if MIN_VERSION_time(1,9,0)
import Data.Time.Format (formatTime, defaultTimeLocale)
#endif
import System.Directory (findExecutable, listDirectory)
import System.Exit (ExitCode (..))
import System.FilePath
import System.IO (hGetContents, hPutStr, hPutStrLn, IOMode(ReadMode),
                  stderr, stdout, withFile, Handle)
#ifndef mingw32_HOST_OS
import System.Posix.User (getEffectiveUserID)
#endif
import System.Process (createProcess, CreateProcess (cmdspec), proc,
                       ProcessHandle,
                       rawSystem, readProcess,
                       readProcessWithExitCode, runProcess, showCommandForUser,
                       std_err, std_in, std_out,
                       StdStream(CreatePipe, UseHandle),
                       waitForProcess, withCreateProcess)

removeTrailingNewline :: String -> String
removeTrailingNewline :: String -> String
removeTrailingNewline String
"" = String
""
removeTrailingNewline String
str =
  if String -> Char
forall a. HasCallStack => [a] -> a
last String
str Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'
  then String -> String
forall a. HasCallStack => [a] -> [a]
init String
str
  else String
str

quoteCmd :: String -> [String] -> String
quoteCmd :: String -> [String] -> String
quoteCmd = String -> [String] -> String
showCommandForUser

-- | Alias for errorWithoutStackTrace (for base >= 4.9)
--
-- @since 0.1.4
error' :: String -> a
#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,9,0))
error' :: forall a. String -> a
error' String
s = String -> a
forall a. String -> a
errorWithoutStackTrace (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$! String
s
#else
error' s = error $! s
#endif

-- | @cmd c args@ runs a command in a process and returns stdout
cmd :: String -- ^ command to run
    -> [String] -- ^ list of arguments
    -> IO String -- ^ stdout
cmd :: String -> [String] -> IO String
cmd String
c [String]
args = String -> [String] -> String -> IO String
cmdStdIn String
c [String]
args String
""

-- | @cmd_ c args@ runs command in a process, output goes to stdout and stderr
cmd_ :: String -> [String] -> IO ()
cmd_ :: String -> [String] -> IO ()
cmd_ String
c [String]
args = do
  ret <- String -> [String] -> IO ExitCode
rawSystem String
c [String]
args
  case ret of
    ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ExitFailure Int
n -> String -> IO ()
forall a. String -> a
error' (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
quoteCmd String
c [String]
args String -> String -> String
+-+ String
"failed with exit code" String -> String -> String
+-+ Int -> String
forall a. Show a => a -> String
show Int
n

boolWrapper :: IO ExitCode -> IO Bool
boolWrapper :: IO ExitCode -> IO Bool
boolWrapper IO ExitCode
pr = do
  ret <- IO ExitCode
pr
  case ret of
    ExitCode
ExitSuccess -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    ExitFailure Int
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | @cmdBool c args@ runs a command, and return Boolean status
cmdBool :: String -> [String] -> IO Bool
cmdBool :: String -> [String] -> IO Bool
cmdBool String
c [String]
args =
  IO ExitCode -> IO Bool
boolWrapper (String -> [String] -> IO ExitCode
rawSystem String
c [String]
args)

-- | @cmdMaybe c args@ runs a command, maybe returning output if it succeeds
cmdMaybe :: String -> [String] -> IO (Maybe String)
cmdMaybe :: String -> [String] -> IO (Maybe String)
cmdMaybe String
c [String]
args = do
  (ok, out, _err) <- String -> [String] -> String -> IO (Bool, String, String)
cmdFull String
c [String]
args String
""
  return $ if ok then Just out else Nothing

-- | @cmdLines c args@ runs a command, and returns list of stdout lines
--
-- @since 0.1.1
cmdLines :: String -> [String] -> IO [String]
cmdLines :: String -> [String] -> IO [String]
cmdLines String
c [String]
args = String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
cmd String
c [String]
args

-- | @cmdStdIn c args inp@ runs a command, passing input string as stdin, and returns stdout
cmdStdIn :: String -> [String] -> String -> IO String
cmdStdIn :: String -> [String] -> String -> IO String
cmdStdIn String
c [String]
args String
inp = String -> String
removeTrailingNewline (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
c [String]
args String
inp

-- | @shell cs@ runs a command string in a shell, and returns stdout
shell :: String -> IO String
shell :: String -> IO String
shell String
cs = String -> [String] -> IO String
cmd String
"sh" [String
"-c", String
cs]

-- | @shell_ cs@ runs a command string in a shell, output goes to stdout
shell_ :: String -> IO ()
shell_ :: String -> IO ()
shell_ String
cs = String -> [String] -> IO ()
cmd_ String
"sh" [String
"-c", String
cs]

-- | @shellBool cs@ runs a command string in a shell, output goes to stdout
--
-- @since 0.2.0
shellBool :: String -> IO Bool
shellBool :: String -> IO Bool
shellBool String
cs =
  IO ExitCode -> IO Bool
boolWrapper (String -> [String] -> IO ExitCode
rawSystem String
"sh" [String
"-c", String
cs])

-- | @cmdLog_ c args@ logs a command with a datestamp
--
-- @since 0.2.7
cmdLog_ :: String -> [String] -> IO ()
cmdLog_ :: String -> [String] -> IO ()
cmdLog_ String
c [String]
args = do
  String -> IO ()
logMsg (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args
  String -> [String] -> IO ()
cmd_ String
c [String]
args

-- FIXME change in 0.3
-- | deprecated, use @cmdLog_@ instead (will change type in 0.3)
--
-- @since 0.1.4
cmdLog :: String -> [String] -> IO ()
cmdLog :: String -> [String] -> IO ()
cmdLog = String -> [String] -> IO ()
cmdLog_

-- | @cmdlog@ deprecated alias for 'cmdLog_' (will be removed in 0.3)
cmdlog :: String -> [String] -> IO ()
cmdlog :: String -> [String] -> IO ()
cmdlog = String -> [String] -> IO ()
cmdLog_

-- | @logMsg msg@ outputs message with a timestamp
logMsg :: String -> IO ()
logMsg :: String -> IO ()
logMsg String
msg = do
  date <- String -> [String] -> IO String
cmd String
"date" [String
"+%T"]
  putStrLn $ date +-+ msg

-- | @cmdN c args@ dry-runs a command: prints command to stdout - more used for debugging
cmdN :: String -> [String] -> IO ()
cmdN :: String -> [String] -> IO ()
cmdN String
c [String]
args = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
c String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. Show a => a -> String
show [String]
args

-- | @cmdStdErr c args@ runs command in a process, returning stdout and stderr
cmdStdErr :: String -> [String] -> IO (String, String)
cmdStdErr :: String -> [String] -> IO (String, String)
cmdStdErr String
c [String]
args = do
  (_ok, out, err) <- String -> [String] -> String -> IO (Bool, String, String)
cmdFull String
c [String]
args String
""
  return (out, err)

-- -- | @cmdAssert msg c args@ runs command, if it fails output msg as error'.
-- cmdAssert :: String -> String -> [String] -> IO ()
-- cmdAssert msg c args = do
--   ret <- rawSystem c args
--   case ret of
--     ExitSuccess -> return ()
--     ExitFailure _ -> error' msg

-- | @cmdQuiet c args@ runs a command hiding stderr, if it succeeds returns stdout
cmdQuiet :: String -> [String] -> IO String
cmdQuiet :: String -> [String] -> IO String
cmdQuiet String
c [String]
args = do
  (ok, out, err) <- String -> [String] -> String -> IO (Bool, String, String)
cmdFull String
c [String]
args String
""
  return $ if ok
    then out
    else error' $ quoteCmd c args +-+ "failed with\n" ++ err

-- | @cmdSilent c args@ runs a command hiding stdout: stderr is only output if it fails.
cmdSilent :: String -> [String] -> IO ()
cmdSilent :: String -> [String] -> IO ()
cmdSilent String
c [String]
args = do
  (ret, _, err) <- String -> [String] -> String -> IO (Bool, String, String)
cmdFull String
c [String]
args String
""
  unless ret $
    error' $ quoteCmd c args +-+ "failed with\n" ++ err

-- -- | @cmdSilentIn c args inp@ is like @cmdSilent@ but additionally takes some stdin
-- cmdSilentIn :: String -> [String] -> String -> IO ()
-- cmdSilentIn c args inp = do
--   (ret, _, err) <- cmdFull c args inp
--   unless ret $
--     error' $ quoteCmd c args +-+ "failed with:\n" ++ err

-- | @cmdIgnoreErr c args inp@ runs a command with input, drops stderr, and return stdout
cmdIgnoreErr :: String -> [String] -> String -> IO String
cmdIgnoreErr :: String -> [String] -> String -> IO String
cmdIgnoreErr String
c [String]
args String
input = do
  (_ret, out, _err) <- String -> [String] -> String -> IO (Bool, String, String)
cmdFull String
c [String]
args String
input
  return out

-- | @cmdFull c args inp@ runs readProcessWithExitCode and converts the ExitCode to Bool
-- Removes the last newline from stdout and stderr (like the other functions)
cmdFull :: String -> [String] -> String -> IO (Bool, String, String)
cmdFull :: String -> [String] -> String -> IO (Bool, String, String)
cmdFull String
c [String]
args String
input = do
  (ret, out, err) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
c [String]
args String
input
  return (ret == ExitSuccess, removeTrailingNewline out, removeTrailingNewline err)

-- | @cmdTry_ c args@ runs the command if available
--
-- @since 0.2.1
cmdTry_ :: String -> [String] -> IO ()
cmdTry_ :: String -> [String] -> IO ()
cmdTry_ String
c [String]
args = do
  have <- String -> IO (Maybe String)
findExecutable String
c
  when (isJust have) $
    cmd_ c args

-- | Redirect stderr to stdout, ie with interleaved output
--
-- @since 0.2.2
cmdStderrToStdout :: String -> [String] -> IO (ExitCode, String)
cmdStderrToStdout :: String -> [String] -> IO (ExitCode, String)
cmdStderrToStdout String
c [String]
args = do
  (_ , Just hout, _, p) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess ((String -> [String] -> CreateProcess
proc String
c [String]
args)
                                          {std_out = CreatePipe,
                                           std_err = UseHandle stdout})
  ret <- waitForProcess p
  out <- hGetContents hout
  return (ret, removeTrailingNewline out)

-- | Redirect stderr to stdout, ie with interleaved output
--
-- @since 0.2.3
cmdStderrToStdoutIn :: String -> [String] -> String -> IO (Bool, String)
cmdStderrToStdoutIn :: String -> [String] -> String -> IO (Bool, String)
cmdStderrToStdoutIn String
c [String]
args String
inp = do
  (Just hin, Just hout, _, p) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess ((String -> [String] -> CreateProcess
proc String
c [String]
args)
                                          {std_in  = CreatePipe,
                                           std_out = CreatePipe,
                                           std_err = UseHandle stdout})
  hPutStr hin inp
  ret <- waitForProcess p
  out <- hGetContents hout
  return (ret == ExitSuccess, removeTrailingNewline out)

-- | @grep pat file@ greps pattern in file, and returns list of matches
--
-- @since 0.1.2 (fixed not to error in 0.2.2)
grep :: String -> FilePath -> IO [String]
grep :: String -> String -> IO [String]
grep String
pat String
file = do
  mres <- String -> [String] -> IO (Maybe String)
cmdMaybe String
"grep" [String
pat, String
file]
  return $ maybe [] lines mres

-- | @grep_ pat file@ greps pattern in file and returns Boolean status
grep_ :: String -- ^ pattern
      -> FilePath -- ^ file
      -> IO Bool -- ^ result
grep_ :: String -> String -> IO Bool
grep_ String
pat String
file =
  String -> [String] -> IO Bool
cmdBool String
"grep" [String
"-q", String
pat, String
file]

-- | @egrep_ pat file@ greps extended regexp in file, and returns Boolean status
egrep_ :: String -> FilePath -> IO Bool
egrep_ :: String -> String -> IO Bool
egrep_ String
pat String
file =
  String -> [String] -> IO Bool
cmdBool String
"grep" [String
"-q", String
"-e", String
pat, String
file]

#ifndef mingw32_HOST_OS
-- | @sudo c args@ runs a command as sudo returning stdout
--
-- Result type changed from IO () to IO String in 0.2.0
sudo :: String -- ^ command
     -> [String] -- ^ arguments
     -> IO String
sudo :: String -> [String] -> IO String
sudo = (String -> [String] -> IO String)
-> String -> [String] -> IO String
forall a.
(String -> [String] -> IO a) -> String -> [String] -> IO a
sudoInternal String -> [String] -> IO String
cmd

-- | @sudo_ c args@ runs a command as sudo
--
-- @since 0.2.0
-- @since 0.2.7 no longer logs (use sudoLog)
sudo_ :: String -- ^ command
     -> [String] -- ^ arguments
     -> IO ()
sudo_ :: String -> [String] -> IO ()
sudo_ = (String -> [String] -> IO ()) -> String -> [String] -> IO ()
forall a.
(String -> [String] -> IO a) -> String -> [String] -> IO a
sudoInternal String -> [String] -> IO ()
cmd_

-- | @sudo_ c args@ runs a command as sudo
--
-- @since 0.2.7
sudoLog :: String -- ^ command
     -> [String] -- ^ arguments
     -> IO ()
sudoLog :: String -> [String] -> IO ()
sudoLog = (String -> [String] -> IO ()) -> String -> [String] -> IO ()
forall a.
(String -> [String] -> IO a) -> String -> [String] -> IO a
sudoInternal String -> [String] -> IO ()
cmdLog_

-- | @sudoInternal@ converts a command runner to sudo
--
-- Uses sudo unless the effective uid is 0, otherwise errors if sudo not found.
--
-- @since 0.2.7
sudoInternal :: (String -> [String] -> IO a) -> String -> [String] -> IO a
sudoInternal :: forall a.
(String -> [String] -> IO a) -> String -> [String] -> IO a
sudoInternal String -> [String] -> IO a
exc String
c [String]
args = do
  uid <- IO UserID
getEffectiveUserID
  sd <- if uid == 0
    then return Nothing
    else findExecutable "sudo"
  let noSudo = Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
sd
  when (uid /= 0 && noSudo) $
    warning "'sudo' not found"
  exc (fromMaybe c sd) (if noSudo then args else c:args)
#endif

-- | Combine two strings with a single space
infixr 4 +-+
(+-+) :: String -> String -> String
String
"" +-+ :: String -> String -> String
+-+ String
s = String
s
String
s +-+ String
"" = String
s
String
s +-+ String
t | String -> Char
forall a. HasCallStack => [a] -> a
last String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t
        | String -> Char
forall a. HasCallStack => [a] -> a
head String
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t
String
s +-+ String
t = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t

-- singleLine :: String -> String
-- singleLine "" = ""
-- singleLine s = (head . lines) s

-- | @removePrefix prefix original@ removes prefix from string if present
removePrefix :: String -> String-> String
removePrefix :: String -> String -> String
removePrefix String
prefix String
orig =
  String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
orig (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix String
orig

-- | @removeStrictPrefix prefix original@ removes prefix, or fails with error'
removeStrictPrefix :: String -> String -> String
removeStrictPrefix :: String -> String -> String
removeStrictPrefix String
prefix String
orig =
  String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> String
forall a. String -> a
error' String
prefix String -> String -> String
+-+ String
"is not prefix of" String -> String -> String
+-+ String
orig) (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
prefix String
orig

-- | @removeSuffix suffix original@ removes suffix from string if present
removeSuffix :: String -> String -> String
removeSuffix :: String -> String -> String
removeSuffix String
suffix String
orig =
  String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
orig (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
suffix String
orig
  where
    stripSuffix :: [a] -> [a] -> Maybe [a]
stripSuffix [a]
sf [a]
str = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
sf) ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
str)

-- | @warning@ outputs to stderr
--
-- @since 0.2.0
warning :: String -> IO ()
warning :: String -> IO ()
warning String
s = Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$! String
s

-- | output a newline
--
-- @since 0.2.7
newline ::IO ()
newline :: IO ()
newline = String -> IO ()
putStrLn String
""

-- | Type alias for a command in a pipe
--
-- @since 0.2.0
type PipeCommand = (String,[String])

withCreateProcessOutput :: CreateProcess -> (Handle  -> ProcessHandle -> IO a) -> IO a
withCreateProcessOutput :: forall a.
CreateProcess -> (Handle -> ProcessHandle -> IO a) -> IO a
withCreateProcessOutput CreateProcess
p Handle -> ProcessHandle -> IO a
act =
  CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
p ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
 -> IO a)
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$
    \ Maybe Handle
_si Maybe Handle
mso Maybe Handle
_se ProcessHandle
p' ->
      case Maybe Handle
mso of
        Maybe Handle
Nothing -> String -> IO a
forall a. HasCallStack => String -> a
error (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"no stdout handle for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CmdSpec -> String
forall a. Show a => a -> String
show (CreateProcess -> CmdSpec
cmdspec CreateProcess
p)
        Just Handle
so -> Handle -> ProcessHandle -> IO a
act Handle
so ProcessHandle
p'

-- | Return stdout from piping the output of one process to another
--
-- @since 0.2.0
pipe :: PipeCommand -> PipeCommand -> IO String
pipe :: PipeCommand -> PipeCommand -> IO String
pipe (String
c1,[String]
args1) (String
c2,[String]
args2) =
  CreateProcess
-> (Handle -> ProcessHandle -> IO String) -> IO String
forall a.
CreateProcess -> (Handle -> ProcessHandle -> IO a) -> IO a
withCreateProcessOutput ((String -> [String] -> CreateProcess
proc String
c1 [String]
args1) { std_out = CreatePipe }) ((Handle -> ProcessHandle -> IO String) -> IO String)
-> (Handle -> ProcessHandle -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$
    \ Handle
ho1 ProcessHandle
p1 -> do
      (_, mho2, _, p2) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess ((String -> [String] -> CreateProcess
proc String
c2 [String]
args2) {std_in = UseHandle ho1, std_out = CreatePipe})
      case mho2 of
        Maybe Handle
Nothing -> String -> IO String
forall a. HasCallStack => String -> a
error (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"no stdout handle for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c2
        Just Handle
ho2 -> do
          out <- Handle -> IO String
hGetContents Handle
ho2
          void $ waitForProcess p1
          void $ waitForProcess p2
          return $ removeTrailingNewline out

-- | Pipe two commands without returning anything
--
-- @since 0.2.0
pipe_ :: PipeCommand -> PipeCommand -> IO ()
pipe_ :: PipeCommand -> PipeCommand -> IO ()
pipe_ (String
c1,[String]
args1) (String
c2,[String]
args2) =
  IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ PipeCommand -> PipeCommand -> IO Bool
pipeBool (String
c1,[String]
args1) (String
c2,[String]
args2)

-- | Bool result of piping of commands
-- @since 0.2.0
-- Returns False if either command fails (since 0.2.4).
pipeBool :: PipeCommand -> PipeCommand -> IO Bool
pipeBool :: PipeCommand -> PipeCommand -> IO Bool
pipeBool (String
c1,[String]
args1) (String
c2,[String]
args2) =
  -- nicer with process-typed:
  -- withProcess_ (setStdout createPipe proc1) $ \ p -> runProcess (setStdin (useHandleClose (getStdout p)) proc2)
  CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO Bool)
-> IO Bool
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess ((String -> [String] -> CreateProcess
proc String
c1 [String]
args1) { std_out = CreatePipe }) ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO Bool)
 -> IO Bool)
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO Bool)
-> IO Bool
forall a b. (a -> b) -> a -> b
$
    \ Maybe Handle
_si Maybe Handle
so Maybe Handle
_se ProcessHandle
p1 -> do
      p2 <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
c2 [String]
args2 Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
so Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing
      ok1 <- boolWrapper $ waitForProcess p1
      ok2 <- boolWrapper $ waitForProcess p2
      return $ ok1 && ok2

-- | Pipe 3 commands, returning stdout
--
-- @since 0.2.3
pipe3 :: PipeCommand -> PipeCommand -> PipeCommand -> IO String
pipe3 :: PipeCommand -> PipeCommand -> PipeCommand -> IO String
pipe3 (String
c1,[String]
a1) (String
c2,[String]
a2) (String
c3,[String]
a3) =
  CreateProcess
-> (Handle -> ProcessHandle -> IO String) -> IO String
forall a.
CreateProcess -> (Handle -> ProcessHandle -> IO a) -> IO a
withCreateProcessOutput ((String -> [String] -> CreateProcess
proc String
c1 [String]
a1) { std_out = CreatePipe }) ((Handle -> ProcessHandle -> IO String) -> IO String)
-> (Handle -> ProcessHandle -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$
  \ Handle
ho1 ProcessHandle
p1 ->
    CreateProcess
-> (Handle -> ProcessHandle -> IO String) -> IO String
forall a.
CreateProcess -> (Handle -> ProcessHandle -> IO a) -> IO a
withCreateProcessOutput ((String -> [String] -> CreateProcess
proc String
c2 [String]
a2) {std_in = UseHandle ho1, std_out = CreatePipe}) ((Handle -> ProcessHandle -> IO String) -> IO String)
-> (Handle -> ProcessHandle -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$
    \ Handle
ho2 ProcessHandle
p2 -> do
      (_, Just ho3, _, p3) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess ((String -> [String] -> CreateProcess
proc String
c3 [String]
a3) {std_in = UseHandle ho2, std_out = CreatePipe})
      out <- hGetContents ho3
      forM_ [p1,p2,p3] waitForProcess
      return $ removeTrailingNewline out

-- | Pipe 3 commands, not returning anything
--
-- @since 0.2.0
pipe3_ :: PipeCommand -> PipeCommand -> PipeCommand -> IO ()
pipe3_ :: PipeCommand -> PipeCommand -> PipeCommand -> IO ()
pipe3_ (String
c1,[String]
a1) (String
c2,[String]
a2) (String
c3,[String]
a3) =
  CreateProcess -> (Handle -> ProcessHandle -> IO ()) -> IO ()
forall a.
CreateProcess -> (Handle -> ProcessHandle -> IO a) -> IO a
withCreateProcessOutput ((String -> [String] -> CreateProcess
proc String
c1 [String]
a1) { std_out = CreatePipe }) ((Handle -> ProcessHandle -> IO ()) -> IO ())
-> (Handle -> ProcessHandle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
  \ Handle
ho1 ProcessHandle
p1 ->
    CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess ((String -> [String] -> CreateProcess
proc String
c2 [String]
a2) {std_in = UseHandle ho1, std_out = CreatePipe}) ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
 -> IO ())
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$
    \ Maybe Handle
_hi2 Maybe Handle
mho2 Maybe Handle
_he2 ProcessHandle
p2 -> do
      p3 <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
c3 [String]
a3 Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
mho2 Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing
      forM_ [p1,p2,p3] waitForProcess

-- | Pipe a file to the first of a pipe of commands
--
-- @since 0.2.0
pipeFile_ :: FilePath -> PipeCommand -> PipeCommand -> IO ()
pipeFile_ :: String -> PipeCommand -> PipeCommand -> IO ()
pipeFile_ String
infile (String
c1,[String]
a1) (String
c2,[String]
a2) =
  String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
infile IOMode
ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
  \ Handle
hin ->
    CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess ((String -> [String] -> CreateProcess
proc String
c1 [String]
a1) { std_in = UseHandle hin, std_out = CreatePipe }) ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
 -> IO ())
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$
    \ Maybe Handle
_si Maybe Handle
so Maybe Handle
_se ProcessHandle
p1 -> do
      p2 <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
c2 [String]
a2 Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
so Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing
      void $ waitForProcess p1
      void $ waitForProcess p2

-- | Assert program in PATH
--
-- @needProgram progname@
--
-- @since 0.2.1
needProgram :: String -> IO ()
needProgram :: String -> IO ()
needProgram String
prog = do
  mx <- String -> IO (Maybe String)
findExecutable String
prog
  unless (isJust mx) $ error' $ "missing program: " ++ prog

-- FIXME handle empty extension?
-- | returns the files with the give extension
filesWithExtension :: FilePath -- directory
                   -> String   -- file extension
                   -> IO [FilePath]
filesWithExtension :: String -> String -> IO [String]
filesWithExtension String
dir String
ext =
  (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
ext String -> String -> Bool
`isExtensionOf`) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
dir

-- looks in dir for a unique file with given extension
fileWithExtension :: FilePath -- directory
                  -> String   -- file extension
                  -> IO (Maybe FilePath)
fileWithExtension :: String -> String -> IO (Maybe String)
fileWithExtension String
dir String
ext = do
  files <- String -> String -> IO [String]
filesWithExtension String
dir String
ext
  case files of
       [String
file] -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
file
       [] -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
       [String]
_ -> String -> IO ()
putStrLn (String
"More than one " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ext String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" file found!") IO () -> IO (Maybe String) -> IO (Maybe String)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

#if !MIN_VERSION_filepath(1,4,2)
isExtensionOf :: String -> FilePath -> Bool
isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions
isExtensionOf ext         = isSuffixOf ('.':ext) . takeExtensions
#endif

-- | Run an IO action and then print how long it took
timeIO :: IO a -> IO a
timeIO :: forall a. IO a -> IO a
timeIO IO a
action = do
  IO UTCTime -> (UTCTime -> IO ()) -> (UTCTime -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    IO UTCTime
getCurrentTime
    (\UTCTime
start -> do
        end <- IO UTCTime
getCurrentTime
        let duration = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
end UTCTime
start
        putStrLn $ "took " ++ renderDuration duration)
    (IO a -> UTCTime -> IO a
forall a b. a -> b -> a
const IO a
action)
  where
#if MIN_VERSION_time(1,9,0)
    renderDuration :: t -> String
renderDuration t
dur =
      let fmtstr :: String
fmtstr
            | t
dur t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
60 = String
"%s sec"
            | t
dur t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
3600 = String
"%m min %S sec"
            | Bool
otherwise = String
"%h hours %M min"
      in TimeLocale -> String -> t -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
fmtstr t
dur
#else
    renderDuration = show
#endif