-
Notifications
You must be signed in to change notification settings - Fork 118
/
Command.hs
763 lines (653 loc) · 34.8 KB
/
Command.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances, TypeOperators, ScopedTypeVariables, NamedFieldPuns #-}
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, DeriveDataTypeable, RecordWildCards #-}
-- | This module provides functions for calling command line programs, primarily
-- 'command' and 'cmd'. As a simple example:
--
-- @
-- 'command' [] \"gcc\" [\"-c\",myfile]
-- @
--
-- The functions from this module are now available directly from "Development.Shake".
-- You should only need to import this module if you are using the 'cmd' function in the 'IO' monad.
module Development.Shake.Command(
command, command_, cmd, cmd_, unit, CmdArgument(..), CmdArguments(..), IsCmdArgument(..), (:->),
Stdout(..), StdoutTrim(..), Stderr(..), Stdouterr(..), Exit(..), Process(..), CmdTime(..), CmdLine(..), FSATrace(..),
CmdResult, CmdString, CmdOption(..),
addPath, addEnv,
) where
import Data.Tuple.Extra
import Control.Monad.Extra
import Control.Monad.IO.Class
import Control.Exception.Extra
import Data.Char
import Data.Either.Extra
import Data.Foldable (toList)
import Data.List.Extra
import Data.List.NonEmpty (NonEmpty)
import qualified Data.HashSet as Set
import Data.Maybe
import Data.Data
import Data.Semigroup
import System.Directory
import qualified System.IO.Extra as IO
import System.Environment
import System.Exit
import System.IO.Extra hiding (withTempFile, withTempDir)
import System.Process
import System.Info.Extra
import System.Time.Extra
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.ByteString.UTF8 as UTF8
import General.Extra
import General.Process
import Prelude
import Development.Shake.Internal.CmdOption
import Development.Shake.Internal.Core.Action
import Development.Shake.Internal.Core.Types hiding (Result)
import Development.Shake.FilePath
import Development.Shake.Internal.Options
import Development.Shake.Internal.Rules.File
import Development.Shake.Internal.Derived
---------------------------------------------------------------------
-- ACTUAL EXECUTION
-- | /Deprecated:/ Use 'AddPath'. This function will be removed in a future version.
--
-- Add a prefix and suffix to the @$PATH@ environment variable. For example:
--
-- @
-- opt <- 'addPath' [\"\/usr\/special\"] []
-- 'cmd' opt \"userbinary --version\"
-- @
--
-- Would prepend @\/usr\/special@ to the current @$PATH@, and the command would pick
-- @\/usr\/special\/userbinary@, if it exists. To add other variables see 'addEnv'.
addPath :: MonadIO m => [String] -> [String] -> m CmdOption
addPath pre post = do
args <- liftIO getEnvironment
let (path,other) = partition ((== "PATH") . (if isWindows then upper else id) . fst) args
pure $ Env $
[("PATH",intercalate [searchPathSeparator] $ pre ++ post) | null path] ++
[(a,intercalate [searchPathSeparator] $ pre ++ [b | b /= ""] ++ post) | (a,b) <- path] ++
other
-- | /Deprecated:/ Use 'AddEnv'. This function will be removed in a future version.
--
-- Add a single variable to the environment. For example:
--
-- @
-- opt <- 'addEnv' [(\"CFLAGS\",\"-O2\")]
-- 'cmd' opt \"gcc -c main.c\"
-- @
--
-- Would add the environment variable @$CFLAGS@ with value @-O2@. If the variable @$CFLAGS@
-- was already defined it would be overwritten. If you wish to modify @$PATH@ see 'addPath'.
addEnv :: MonadIO m => [(String, String)] -> m CmdOption
addEnv extra = do
args <- liftIO getEnvironment
pure $ Env $ extra ++ filter (\(a,_) -> a `notElem` map fst extra) args
data Str = Str String | BS BS.ByteString | LBS LBS.ByteString | Unit deriving (Eq,Show)
strTrim :: Str -> Str
strTrim (Str x) = Str $ trim x
strTrim (BS x) = BS $ fst $ BS.spanEnd isSpace $ BS.dropWhile isSpace x
strTrim (LBS x) = LBS $ trimEnd $ LBS.dropWhile isSpace x
where
trimEnd x = case LBS.uncons x of
Just (c, x2) | isSpace c -> trimEnd x2
_ -> x
strTrim Unit = Unit
data Result
= ResultStdout Str
| ResultStderr Str
| ResultStdouterr Str
| ResultCode ExitCode
| ResultTime Double
| ResultLine String
| ResultProcess PID
| ResultFSATrace [FSATrace FilePath]
| ResultFSATraceBS [FSATrace BS.ByteString]
deriving (Eq,Show)
data PID = PID0 | PID ProcessHandle
instance Eq PID where _ == _ = True
instance Show PID where show PID0 = "PID0"; show _ = "PID"
data Params = Params
{funcName :: String
,opts :: [CmdOption]
,results :: [Result]
,prog :: String
,args :: [String]
} deriving Show
class MonadIO m => MonadTempDir m where
runWithTempDir :: (FilePath -> m a) -> m a
runWithTempFile :: (FilePath -> m a) -> m a
instance MonadTempDir IO where
runWithTempDir = IO.withTempDir
runWithTempFile = IO.withTempFile
instance MonadTempDir Action where
runWithTempDir = withTempDir
runWithTempFile = withTempFile
---------------------------------------------------------------------
-- DEAL WITH Shell
removeOptionShell
:: MonadTempDir m
=> Params -- ^ Given the parameter
-> (Params -> m a) -- ^ Call with the revised params, program name and command line
-> m a
removeOptionShell params@Params{..} call
| Shell `elem` opts = do
-- put our UserCommand first, as the last one wins, and ours is lowest priority
let userCmdline = unwords $ prog : args
params <- pure params{opts = UserCommand userCmdline : filter (/= Shell) opts}
prog <- liftIO $ if isFSATrace params then copyFSABinary prog else pure prog
let realCmdline = unwords $ prog : args
if not isWindows then
call params{prog = "/bin/sh", args = ["-c",realCmdline]}
else
-- On Windows the Haskell behaviour isn't that clean and is very fragile, so we try and do better.
runWithTempDir $ \dir -> do
let file = dir </> "s.bat"
writeFile' file realCmdline
call params{prog = "cmd.exe", args = ["/d/q/c",file]}
| otherwise = call params
---------------------------------------------------------------------
-- DEAL WITH FSATrace
isFSATrace :: Params -> Bool
isFSATrace Params{..} = any isResultFSATrace results || any isFSAOptions opts
-- Mac disables tracing on system binaries, so we copy them over, yurk
copyFSABinary :: FilePath -> IO FilePath
copyFSABinary prog
| not isMac = pure prog
| otherwise = do
progFull <- findExecutable prog
case progFull of
Just x | any (`isPrefixOf` x) ["/bin/","/usr/","/sbin/"] -> do
-- The file is one of the ones we can't trace, so we make a copy of it in $TMP and run that
-- We deliberately don't clean up this directory, since otherwise we spend all our time copying binaries over
tmpdir <- getTemporaryDirectory
let fake = tmpdir </> "fsatrace-fakes" ++ x -- x is absolute, so must use ++
unlessM (doesFileExist fake) $ do
createDirectoryRecursive $ takeDirectory fake
copyFile x fake
pure fake
_ -> pure prog
removeOptionFSATrace
:: MonadTempDir m
=> Params -- ^ Given the parameter
-> (Params -> m [Result]) -- ^ Call with the revised params, program name and command line
-> m [Result]
removeOptionFSATrace params@Params{..} call
| not $ isFSATrace params = call params
| ResultProcess PID0 `elem` results =
-- This is a bad state to get into, you could technically just ignore the tracing, but that's a bit dangerous
liftIO $ errorIO "Asyncronous process execution combined with FSATrace is not support"
| otherwise = runWithTempFile $ \file -> do
liftIO $ writeFile file "" -- ensures even if we fail before fsatrace opens the file, we can still read it
params <- liftIO $ fsaParams file params
res <- call params{opts = UserCommand (showCommandForUser2 prog args) : filter (not . isFSAOptions) opts}
fsaResBS <- liftIO $ parseFSA <$> BS.readFile file
let fsaRes = map (fmap UTF8.toString) fsaResBS
pure $ flip map res $ \case
ResultFSATrace [] -> ResultFSATrace fsaRes
ResultFSATraceBS [] -> ResultFSATraceBS fsaResBS
x -> x
where
fsaFlags = lastDef "rwmdqt" [x | FSAOptions x <- opts]
fsaParams file Params{..} = do
prog <- copyFSABinary prog
pure params{prog = "fsatrace", args = fsaFlags : file : "--" : prog : args }
isFSAOptions FSAOptions{} = True
isFSAOptions _ = False
isResultFSATrace ResultFSATrace{} = True
isResultFSATrace ResultFSATraceBS{} = True
isResultFSATrace _ = False
addFSAOptions :: String -> [CmdOption] -> [CmdOption]
addFSAOptions x opts | any isFSAOptions opts = map f opts
where f (FSAOptions y) = FSAOptions $ nubOrd $ y ++ x
f x = x
addFSAOptions x opts = FSAOptions x : opts
-- | The results produced by @fsatrace@. All files will be absolute paths.
-- You can get the results for a 'cmd' by requesting a value of type
-- @['FSATrace']@.
data FSATrace a
= -- | Writing to a file
FSAWrite a
| -- | Reading from a file
FSARead a
| -- | Deleting a file
FSADelete a
| -- | Moving, arguments destination, then source
FSAMove a a
| -- | Querying\/stat on a file
FSAQuery a
| -- | Touching a file
FSATouch a
deriving (Show,Eq,Ord,Data,Typeable,Functor)
-- | Parse the 'FSATrace' entries, ignoring anything you don't understand.
parseFSA :: BS.ByteString -> [FSATrace BS.ByteString]
parseFSA = mapMaybe (f . dropR) . BS.lines
where
-- deal with CRLF on Windows
dropR x = case BS.unsnoc x of
Just (x, '\r') -> x
_ -> x
f x
| Just (k, x) <- BS.uncons x
, Just ('|', x) <- BS.uncons x =
case k of
'w' -> Just $ FSAWrite x
'r' -> Just $ FSARead x
'd' -> Just $ FSADelete x
'm' | (xs, ys) <- BS.break (== '|') x, Just ('|',ys) <- BS.uncons ys ->
Just $ FSAMove xs ys
'q' -> Just $ FSAQuery x
't' -> Just $ FSATouch x
_ -> Nothing
| otherwise = Nothing
---------------------------------------------------------------------
-- ACTION EXPLICIT OPERATION
-- | Given explicit operations, apply the Action ones, like skip/trace/track/autodep
commandExplicitAction :: Partial => Params -> Action [Result]
commandExplicitAction oparams = do
ShakeOptions{shakeCommandOptions,shakeRunCommands,shakeLint,shakeLintInside} <- getShakeOptions
params@Params{..}<- pure $ oparams{opts = shakeCommandOptions ++ opts oparams}
let skipper act = if null results && not shakeRunCommands then pure [] else act
let verboser act = do
let cwd = listToMaybe $ reverse [x | Cwd x <- opts]
putVerbose $
maybe "" (\x -> "cd " ++ x ++ "; ") cwd ++
last (showCommandForUser2 prog args : [x | UserCommand x <- opts])
verb <- getVerbosity
-- run quietly to suppress the tracer (don't want to print twice)
(if verb >= Verbose then quietly else id) act
let tracer act = do
-- note: use the oparams - find a good tracing before munging it for shell stuff
let msg = lastDef (defaultTraced oparams) [x | Traced x <- opts]
if msg == "" then liftIO act else traced msg act
let async = ResultProcess PID0 `elem` results
let tracker act
| AutoDeps `elem` opts = if async then liftIO $ errorIO "Can't use AutoDeps and asyncronous execution" else autodeps act
| shakeLint == Just LintFSATrace && not async = fsalint act
| otherwise = act params
autodeps act = do
ResultFSATrace pxs : res <- act params{opts = addFSAOptions "rwm" opts, results = ResultFSATrace [] : results}
let written = Set.fromList $ [x | FSAMove x _ <- pxs] ++ [x | FSAWrite x <- pxs]
-- If something both reads and writes to a file, it isn't eligible to be an autodeps
xs <- liftIO $ filterM doesFileExist [x | FSARead x <- pxs, not $ x `Set.member` written]
cwd <- liftIO getCurrentDirectory
temp <- fixPaths cwd xs
unsafeAllowApply $ need temp
pure res
fixPaths cwd xs = liftIO $ do
xs<- pure $ map toStandard xs
xs<- pure $ filter (\x -> any (`isPrefixOf` x) shakeLintInside) xs
mapM (\x -> fromMaybe x <$> makeRelativeEx cwd x) xs
fsalint act = do
ResultFSATrace xs : res <- act params{opts = addFSAOptions "rwm" opts, results = ResultFSATrace [] : results}
let reader (FSARead x) = Just x; reader _ = Nothing
writer (FSAWrite x) = Just x; writer (FSAMove x _) = Just x; writer _ = Nothing
existing f = liftIO . filterM doesFileExist . nubOrd . mapMaybe f
cwd <- liftIO getCurrentDirectory
trackRead =<< fixPaths cwd =<< existing reader xs
trackWrite =<< fixPaths cwd =<< existing writer xs
pure res
skipper $ tracker $ \params -> verboser $ tracer $ commandExplicitIO params
defaultTraced :: Params -> String
defaultTraced Params{..} = takeBaseName $ if Shell `elem` opts then fst (word1 prog) else prog
---------------------------------------------------------------------
-- IO EXPLICIT OPERATION
-- | Given a very explicit set of CmdOption, translate them to a General.Process structure
commandExplicitIO :: Partial => Params -> IO [Result]
commandExplicitIO params = removeOptionShell params $ \params -> removeOptionFSATrace params $ \Params{..} -> do
let (grabStdout, grabStderr) = both or $ unzip $ flip map results $ \case
ResultStdout{} -> (True, False)
ResultStderr{} -> (False, True)
ResultStdouterr{} -> (True, True)
_ -> (False, False)
optEnv <- resolveEnv opts
let optCwd = mergeCwd [x | Cwd x <- opts]
let optStdin = flip mapMaybe opts $ \case
Stdin x -> Just $ SrcString x
StdinBS x -> Just $ SrcBytes x
FileStdin x -> Just $ SrcFile x
InheritStdin -> Just SrcInherit
_ -> Nothing
let optBinary = BinaryPipes `elem` opts
let optAsync = ResultProcess PID0 `elem` results
let optTimeout = listToMaybe $ reverse [x | Timeout x <- opts]
let optWithStdout = lastDef False [x | WithStdout x <- opts]
let optWithStderr = lastDef True [x | WithStderr x <- opts]
let optFileStdout = [x | FileStdout x <- opts]
let optFileStderr = [x | FileStderr x <- opts]
let optEchoStdout = lastDef (not grabStdout && null optFileStdout) [x | EchoStdout x <- opts]
let optEchoStderr = lastDef (not grabStderr && null optFileStderr) [x | EchoStderr x <- opts]
let optRealCommand = showCommandForUser2 prog args
let optUserCommand = lastDef optRealCommand [x | UserCommand x <- opts]
let optCloseFds = CloseFileHandles `elem` opts
let optProcessGroup = NoProcessGroup `notElem` opts
let bufLBS f = do (a,b) <- buf $ LBS LBS.empty; pure (a, (\(LBS x) -> f x) <$> b)
buf Str{} | optBinary = bufLBS (Str . LBS.unpack)
buf Str{} = do x <- newBuffer; pure ([DestString x | not optAsync], Str . concat <$> readBuffer x)
buf LBS{} = do x <- newBuffer; pure ([DestBytes x | not optAsync], LBS . LBS.fromChunks <$> readBuffer x)
buf BS {} = bufLBS (BS . BS.concat . LBS.toChunks)
buf Unit = pure ([], pure Unit)
(dStdout, dStderr, resultBuild) :: ([[Destination]], [[Destination]], [Double -> ProcessHandle -> ExitCode -> IO Result]) <-
fmap unzip3 $ forM results $ \case
ResultCode _ -> pure ([], [], \_ _ ex -> pure $ ResultCode ex)
ResultTime _ -> pure ([], [], \dur _ _ -> pure $ ResultTime dur)
ResultLine _ -> pure ([], [], \_ _ _ -> pure $ ResultLine optUserCommand)
ResultProcess _ -> pure ([], [], \_ pid _ -> pure $ ResultProcess $ PID pid)
ResultStdout s -> do (a,b) <- buf s; pure (a , [], \_ _ _ -> fmap ResultStdout b)
ResultStderr s -> do (a,b) <- buf s; pure ([], a , \_ _ _ -> fmap ResultStderr b)
ResultStdouterr s -> do (a,b) <- buf s; pure (a , a , \_ _ _ -> fmap ResultStdouterr b)
ResultFSATrace _ -> pure ([], [], \_ _ _ -> pure $ ResultFSATrace []) -- filled in elsewhere
ResultFSATraceBS _ -> pure ([], [], \_ _ _ -> pure $ ResultFSATraceBS []) -- filled in elsewhere
exceptionBuffer <- newBuffer
po <- resolvePath ProcessOpts
{poCommand = RawCommand prog args
,poCwd = optCwd, poEnv = optEnv, poTimeout = optTimeout
,poStdin = [SrcBytes LBS.empty | optBinary && not (null optStdin)] ++ optStdin
,poStdout = [DestEcho | optEchoStdout] ++ map DestFile optFileStdout ++ [DestString exceptionBuffer | optWithStdout && not optAsync] ++ concat dStdout
,poStderr = [DestEcho | optEchoStderr] ++ map DestFile optFileStderr ++ [DestString exceptionBuffer | optWithStderr && not optAsync] ++ concat dStderr
,poAsync = optAsync
,poCloseFds = optCloseFds
,poGroup = optProcessGroup
}
(dur,(pid,exit)) <- duration $ process po
if exit == ExitSuccess || ResultCode ExitSuccess `elem` results then
mapM (\f -> f dur pid exit) resultBuild
else do
exceptionBuffer <- readBuffer exceptionBuffer
let captured = ["Stderr" | optWithStderr] ++ ["Stdout" | optWithStdout]
cwd <- case optCwd of
Nothing -> pure ""
Just v -> do
v <- canonicalizePath v `catchIO` const (pure v)
pure $ "Current directory: " ++ v ++ "\n"
liftIO $ errorIO $
"Development.Shake." ++ funcName ++ ", system command failed\n" ++
"Command line: " ++ optRealCommand ++ "\n" ++
(if optRealCommand /= optUserCommand then "Original command line: " ++ optUserCommand ++ "\n" else "") ++
cwd ++
"Exit code: " ++ show (case exit of ExitFailure i -> i; _ -> 0) ++ "\n" ++
if null captured then "Stderr not captured because WithStderr False was used\n"
else if null exceptionBuffer then intercalate " and " captured ++ " " ++ (if length captured == 1 then "was" else "were") ++ " empty"
else intercalate " and " captured ++ ":\n" ++ unlines (dropWhile null $ lines $ concat exceptionBuffer)
mergeCwd :: [FilePath] -> Maybe FilePath
mergeCwd [] = Nothing
mergeCwd xs = Just $ foldl1 (</>) xs
-- | Apply all environment operations, to produce a new environment to use.
resolveEnv :: [CmdOption] -> IO (Maybe [(String, String)])
resolveEnv opts
| null env, null addEnv, null addPath, null remEnv = pure Nothing
| otherwise = Just . unique . tweakPath . (++ addEnv) . filter (flip notElem remEnv . fst) <$>
if null env then getEnvironment else pure (concat env)
where
env = [x | Env x <- opts]
addEnv = [(x,y) | AddEnv x y <- opts]
remEnv = [x | RemEnv x <- opts]
addPath = [(x,y) | AddPath x y <- opts]
newPath mid = intercalate [searchPathSeparator] $
concat (reverse $ map fst addPath) ++ [mid | mid /= ""] ++ concatMap snd addPath
isPath x = (if isWindows then upper else id) x == "PATH"
tweakPath xs | not $ any (isPath . fst) xs = ("PATH", newPath "") : xs
| otherwise = map (\(a,b) -> (a, if isPath a then newPath b else b)) xs
unique = reverse . nubOrdOn (if isWindows then upper . fst else fst) . reverse
-- | If the user specifies a custom $PATH, and not Shell, then try and resolve their prog ourselves.
-- Tricky, because on Windows it doesn't look in the $PATH first.
resolvePath :: ProcessOpts -> IO ProcessOpts
resolvePath po
| Just e <- poEnv po
, Just (_, path) <- find ((==) "PATH" . (if isWindows then upper else id) . fst) e
, RawCommand prog args <- poCommand po
= do
let progExe = if prog == prog -<.> exe then prog else prog <.> exe
-- use unsafeInterleaveIO to allow laziness to skip the queries we don't use
pathOld <- unsafeInterleaveIO $ fromMaybe "" <$> lookupEnv "PATH"
old <- unsafeInterleaveIO $ findExecutable prog
new <- unsafeInterleaveIO $ findExecutableWith (splitSearchPath path) progExe
old2 <- unsafeInterleaveIO $ findExecutableWith (splitSearchPath pathOld) progExe
switch<- pure $ case () of
_ | path == pathOld -> False -- The state I can see hasn't changed
| Nothing <- new -> False -- I have nothing to offer
| Nothing <- old -> True -- I failed last time, so this must be an improvement
| Just old <- old, Just new <- new, equalFilePath old new -> False -- no different
| Just old <- old, Just old2 <- old2, equalFilePath old old2 -> True -- I could predict last time
| otherwise -> False
pure $ case new of
Just new | switch -> po{poCommand = RawCommand new args}
_ -> po
resolvePath po = pure po
-- | Given a list of directories, and a file name, return the complete path if you can find it.
-- Like findExecutable, but with a custom PATH.
findExecutableWith :: [FilePath] -> String -> IO (Maybe FilePath)
findExecutableWith path x = flip firstJustM (map (</> x) path) $ \s ->
ifM (doesFileExist s) (pure $ Just s) (pure Nothing)
---------------------------------------------------------------------
-- FIXED ARGUMENT WRAPPER
-- | Collect the @stdout@ of the process.
-- If used, the @stdout@ will not be echoed to the terminal, unless you include 'EchoStdout'.
-- The value type may be either 'String', or either lazy or strict 'ByteString'.
--
-- Note that most programs end their output with a trailing newline, so calling
-- @ghc --numeric-version@ will result in 'Stdout' of @\"6.8.3\\n\"@. If you want to automatically
-- trim the resulting string, see 'StdoutTrim'.
newtype Stdout a = Stdout {fromStdout :: a}
-- | Like 'Stdout' but remove all leading and trailing whitespaces.
newtype StdoutTrim a = StdoutTrim {fromStdoutTrim :: a}
-- | Collect the @stderr@ of the process.
-- If used, the @stderr@ will not be echoed to the terminal, unless you include 'EchoStderr'.
-- The value type may be either 'String', or either lazy or strict 'ByteString'.
newtype Stderr a = Stderr {fromStderr :: a}
-- | Collect the @stdout@ and @stderr@ of the process.
-- If used, the @stderr@ and @stdout@ will not be echoed to the terminal, unless you include 'EchoStdout' and 'EchoStderr'.
-- The value type may be either 'String', or either lazy or strict 'ByteString'.
newtype Stdouterr a = Stdouterr {fromStdouterr :: a}
-- | Collect the 'ExitCode' of the process.
-- If you do not collect the exit code, any 'ExitFailure' will cause an exception.
newtype Exit = Exit {fromExit :: ExitCode}
-- | Collect the 'ProcessHandle' of the process.
-- If you do collect the process handle, the command will run asyncronously and the call to 'cmd' \/ 'command'
-- will return as soon as the process is spawned. Any 'Stdout' \/ 'Stderr' captures will return empty strings.
newtype Process = Process {fromProcess :: ProcessHandle}
-- | Collect the time taken to execute the process. Can be used in conjunction with 'CmdLine' to
-- write helper functions that print out the time of a result.
--
-- @
-- timer :: ('CmdResult' r, MonadIO m) => (forall r . 'CmdResult' r => m r) -> m r
-- timer act = do
-- ('CmdTime' t, 'CmdLine' x, r) <- act
-- liftIO $ putStrLn $ \"Command \" ++ x ++ \" took \" ++ show t ++ \" seconds\"
-- pure r
--
-- run :: IO ()
-- run = timer $ 'cmd' \"ghc --version\"
-- @
newtype CmdTime = CmdTime {fromCmdTime :: Double}
-- | Collect the command line used for the process. This command line will be approximate -
-- suitable for user diagnostics, but not for direct execution.
newtype CmdLine = CmdLine {fromCmdLine :: String}
-- | The allowable 'String'-like values that can be captured.
class CmdString a where cmdString :: (Str, Str -> a)
instance CmdString () where cmdString = (Unit, \Unit -> ())
instance CmdString String where cmdString = (Str "", \(Str x) -> x)
instance CmdString BS.ByteString where cmdString = (BS BS.empty, \(BS x) -> x)
instance CmdString LBS.ByteString where cmdString = (LBS LBS.empty, \(LBS x) -> x)
class Unit a
instance {-# OVERLAPPING #-} Unit b => Unit (a -> b)
instance {-# OVERLAPPABLE #-} a ~ () => Unit (m a)
-- | A class for specifying what results you want to collect from a process.
-- Values are formed of 'Stdout', 'Stderr', 'Exit' and tuples of those.
class CmdResult a where
-- Return a list of results (with the right type but dummy data)
-- and a function to transform a populated set of results into a value
cmdResult :: ([Result], [Result] -> a)
instance CmdResult Exit where
cmdResult = ([ResultCode ExitSuccess], \[ResultCode x] -> Exit x)
instance CmdResult ExitCode where
cmdResult = ([ResultCode ExitSuccess], \[ResultCode x] -> x)
instance CmdResult Process where
cmdResult = ([ResultProcess PID0], \[ResultProcess (PID x)] -> Process x)
instance CmdResult ProcessHandle where
cmdResult = ([ResultProcess PID0], \[ResultProcess (PID x)] -> x)
instance CmdResult CmdLine where
cmdResult = ([ResultLine ""], \[ResultLine x] -> CmdLine x)
instance CmdResult CmdTime where
cmdResult = ([ResultTime 0], \[ResultTime x] -> CmdTime x)
instance CmdResult [FSATrace FilePath] where
cmdResult = ([ResultFSATrace []], \[ResultFSATrace x] -> x)
instance CmdResult [FSATrace BS.ByteString] where
cmdResult = ([ResultFSATraceBS []], \[ResultFSATraceBS x] -> x)
instance CmdString a => CmdResult (Stdout a) where
cmdResult = let (a,b) = cmdString in ([ResultStdout a], \[ResultStdout x] -> Stdout $ b x)
instance CmdString a => CmdResult (StdoutTrim a) where
cmdResult = let (a,b) = cmdString in ([ResultStdout a], \[ResultStdout x] -> StdoutTrim $ b $ strTrim x)
instance CmdString a => CmdResult (Stderr a) where
cmdResult = let (a,b) = cmdString in ([ResultStderr a], \[ResultStderr x] -> Stderr $ b x)
instance CmdString a => CmdResult (Stdouterr a) where
cmdResult = let (a,b) = cmdString in ([ResultStdouterr a], \[ResultStdouterr x] -> Stdouterr $ b x)
instance CmdResult () where
cmdResult = ([], \[] -> ())
instance (CmdResult x1, CmdResult x2) => CmdResult (x1,x2) where
cmdResult = (a1++a2, \rs -> let (r1,r2) = splitAt (length a1) rs in (b1 r1, b2 r2))
where (a1,b1) = cmdResult
(a2,b2) = cmdResult
cmdResultWith :: forall b c. CmdResult b => (b -> c) -> ([Result], [Result] -> c)
cmdResultWith f = second (f .) cmdResult
instance (CmdResult x1, CmdResult x2, CmdResult x3) => CmdResult (x1,x2,x3) where
cmdResult = cmdResultWith $ \(a,(b,c)) -> (a,b,c)
instance (CmdResult x1, CmdResult x2, CmdResult x3, CmdResult x4) => CmdResult (x1,x2,x3,x4) where
cmdResult = cmdResultWith $ \(a,(b,c,d)) -> (a,b,c,d)
instance (CmdResult x1, CmdResult x2, CmdResult x3, CmdResult x4, CmdResult x5) => CmdResult (x1,x2,x3,x4,x5) where
cmdResult = cmdResultWith $ \(a,(b,c,d,e)) -> (a,b,c,d,e)
-- | Execute a system command. Before running 'command' make sure you 'Development.Shake.need' any files
-- that are used by the command.
--
-- This function takes a list of options (often just @[]@, see 'CmdOption' for the available
-- options), the name of the executable (either a full name, or a program on the @$PATH@) and
-- a list of arguments. The result is often @()@, but can be a tuple containg any of 'Stdout',
-- 'Stderr' and 'Exit'. Some examples:
--
-- @
-- 'command_' [] \"gcc\" [\"-c\",\"myfile.c\"] -- compile a file, throwing an exception on failure
-- 'Exit' c <- 'command' [] \"gcc\" [\"-c\",myfile] -- run a command, recording the exit code
-- ('Exit' c, 'Stderr' err) <- 'command' [] \"gcc\" [\"-c\",\"myfile.c\"] -- run a command, recording the exit code and error output
-- 'Stdout' out <- 'command' [] \"gcc\" [\"-MM\",\"myfile.c\"] -- run a command, recording the output
-- 'command_' ['Cwd' \"generated\"] \"gcc\" [\"-c\",myfile] -- run a command in a directory
-- @
--
-- Unless you retrieve the 'ExitCode' using 'Exit', any 'ExitFailure' will throw an error, including
-- the 'Stderr' in the exception message. If you capture the 'Stdout' or 'Stderr', that stream will not be echoed to the console,
-- unless you use the option 'EchoStdout' or 'EchoStderr'.
--
-- If you use 'command' inside a @do@ block and do not use the result, you may get a compile-time error about being
-- unable to deduce 'CmdResult'. To avoid this error, use 'command_'.
--
-- By default the @stderr@ stream will be captured for use in error messages, and also echoed. To only echo
-- pass @'WithStderr' 'False'@, which causes no streams to be captured by Shake, and certain programs (e.g. @gcc@)
-- to detect they are running in a terminal.
command :: (Partial, CmdResult r) => [CmdOption] -> String -> [String] -> Action r
command opts x xs = withFrozenCallStack $ b <$> commandExplicitAction (Params "command" opts a x xs)
where (a,b) = cmdResult
-- | A version of 'command' where you do not require any results, used to avoid errors about being unable
-- to deduce 'CmdResult'.
command_ :: Partial => [CmdOption] -> String -> [String] -> Action ()
command_ opts x xs = withFrozenCallStack $ void $ commandExplicitAction (Params "command_" opts [] x xs)
---------------------------------------------------------------------
-- VARIABLE ARGUMENT WRAPPER
-- | A type annotation, equivalent to the first argument, but in variable argument contexts,
-- gives a clue as to what return type is expected (not actually enforced).
type a :-> t = a
-- | Build or execute a system command. Before using 'cmd' to run a command, make sure you 'Development.Shake.need' any files
-- that are used by the command.
--
-- * @String@ arguments are treated as a list of whitespace separated arguments.
--
-- * @[String]@ arguments are treated as a list of literal arguments.
--
-- * 'CmdOption' arguments are used as options.
--
-- * 'CmdArgument' arguments, which can be built by 'cmd' itself, are spliced into the containing command.
--
-- Typically only string literals should be passed as @String@ arguments. When using variables
-- prefer @[myvar]@ so that if @myvar@ contains spaces they are properly escaped.
--
-- As some examples, here are some calls, and the resulting command string:
--
-- @
-- 'cmd_' \"git log --pretty=\" \"oneline\" -- git log --pretty= oneline
-- 'cmd_' \"git log --pretty=\" [\"oneline\"] -- git log --pretty= oneline
-- 'cmd_' \"git log\" (\"--pretty=\" ++ \"oneline\") -- git log --pretty=oneline
-- 'cmd_' \"git log\" (\"--pretty=\" ++ \"one line\") -- git log --pretty=one line
-- 'cmd_' \"git log\" [\"--pretty=\" ++ \"one line\"] -- git log "--pretty=one line"
-- @
--
-- More examples, including return values, see this translation of the examples given for the 'command' function:
--
-- @
-- 'cmd_' \"gcc -c myfile.c\" -- compile a file, throwing an exception on failure
-- 'Exit' c <- 'cmd' \"gcc -c\" [myfile] -- run a command, recording the exit code
-- ('Exit' c, 'Stderr' err) <- 'cmd' \"gcc -c myfile.c\" -- run a command, recording the exit code and error output
-- 'Stdout' out <- 'cmd' \"gcc -MM myfile.c\" -- run a command, recording the output
-- 'cmd' ('Cwd' \"generated\") \"gcc -c\" [myfile] :: 'Action' () -- run a command in a directory
--
-- let gccCommand = 'cmd' \"gcc -c\" :: 'CmdArgument' -- build a sub-command. 'cmd' can return 'CmdArgument' values as well as execute commands
-- cmd ('Cwd' \"generated\") gccCommand [myfile] -- splice that command into a greater command
-- @
--
-- If you use 'cmd' inside a @do@ block and do not use the result, you may get a compile-time error about being
-- unable to deduce 'CmdResult'. To avoid this error, use 'cmd_'. If you enable @OverloadedStrings@ or @OverloadedLists@
-- you may have to give type signatures to the arguments, or use the more constrained 'command' instead.
--
-- The 'cmd' function can also be run in the 'IO' monad, but then 'Traced' is ignored and command lines are not echoed.
-- As an example:
--
-- @
-- 'cmd' ('Cwd' \"generated\") 'Shell' \"gcc -c myfile.c\" :: IO ()
-- @
cmd :: (Partial, CmdArguments args) => args :-> Action r
cmd = withFrozenCallStack $ cmdArguments mempty
-- | See 'cmd'. Same as 'cmd' except with a unit result.
-- 'cmd' is to 'cmd_' as 'command' is to 'command_'.
cmd_ :: (Partial, CmdArguments args, Unit args) => args :-> Action ()
cmd_ = withFrozenCallStack cmd
-- | The arguments to 'cmd' - see 'cmd' for examples and semantics.
newtype CmdArgument = CmdArgument [Either CmdOption String]
deriving (Eq, Semigroup, Monoid, Show)
-- | The arguments to 'cmd' - see 'cmd' for examples and semantics.
class CmdArguments t where
-- | Arguments to cmd
cmdArguments :: Partial => CmdArgument -> t
instance (IsCmdArgument a, CmdArguments r) => CmdArguments (a -> r) where
cmdArguments xs x = cmdArguments $ xs `mappend` toCmdArgument x
instance CmdResult r => CmdArguments (Action r) where
cmdArguments (CmdArgument x) = case partitionEithers x of
(opts, x:xs) -> let (a,b) = cmdResult in b <$> commandExplicitAction (Params "cmd" opts a x xs)
_ -> error "Error, no executable or arguments given to Development.Shake.cmd"
instance CmdResult r => CmdArguments (IO r) where
cmdArguments (CmdArgument x) = case partitionEithers x of
(opts, x:xs) -> let (a,b) = cmdResult in b <$> commandExplicitIO (Params "cmd" opts a x xs)
_ -> error "Error, no executable or arguments given to Development.Shake.cmd"
instance CmdArguments CmdArgument where
cmdArguments = id
-- | Class to convert an a to a CmdArgument
class IsCmdArgument a where
-- | Conversion to a CmdArgument
toCmdArgument :: a -> CmdArgument
instance IsCmdArgument () where toCmdArgument = mempty
instance IsCmdArgument String where toCmdArgument = CmdArgument . map Right . words
instance IsCmdArgument [String] where toCmdArgument = CmdArgument . map Right
instance IsCmdArgument (NonEmpty String) where toCmdArgument = toCmdArgument . toList
instance IsCmdArgument CmdOption where toCmdArgument = CmdArgument . pure . Left
instance IsCmdArgument [CmdOption] where toCmdArgument = CmdArgument . map Left
instance IsCmdArgument CmdArgument where toCmdArgument = id
instance IsCmdArgument a => IsCmdArgument (Maybe a) where toCmdArgument = maybe mempty toCmdArgument
---------------------------------------------------------------------
-- UTILITIES
-- A better version of showCommandForUser, which doesn't escape so much on Windows
showCommandForUser2 :: FilePath -> [String] -> String
showCommandForUser2 cmd args = unwords $ map (\x -> if safe x then x else showCommandForUser x []) $ cmd : args
where
safe xs = xs /= "" && not (any bad xs)
bad x = isSpace x || (x == '\\' && not isWindows) || x `elem` ("\"\'" :: String)