Cabal/src/Distribution/Simple/Utils.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE CPP #-}
   3 {-# LANGUAGE DataKinds #-}
   4 {-# LANGUAGE DeriveGeneric #-}
   5 {-# LANGUAGE FlexibleContexts #-}
   6 {-# LANGUAGE FlexibleInstances #-}
   7 {-# LANGUAGE GADTs #-}
   8 {-# LANGUAGE InstanceSigs #-}
   9 {-# LANGUAGE LambdaCase #-}
  10 {-# LANGUAGE RankNTypes #-}
  11 {-# LANGUAGE ScopedTypeVariables #-}
  12
  13 -----------------------------------------------------------------------------
  14
  15 -- |
  16 -- Module      :  Distribution.Simple.Utils
  17 -- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
  18 -- License     :  BSD3
  19 --                portions Copyright (c) 2007, Galois Inc.
  20 --
  21 -- Maintainer  :  cabal-devel@haskell.org
  22 -- Portability :  portable
  23 --
  24 -- A large and somewhat miscellaneous collection of utility functions used
  25 -- throughout the rest of the Cabal lib and in other tools that use the Cabal
  26 -- lib like @cabal-install@. It has a very simple set of logging actions. It
  27 -- has low level functions for running programs, a bunch of wrappers for
  28 -- various directory and file functions that do extra logging.
  29 module Distribution.Simple.Utils
  30   ( cabalVersion
  31
  32     -- * logging and errors
  33   , dieNoVerbosity
  34   , die'
  35   , dieWithException
  36   , dieWithLocation'
  37   , dieNoWrap
  38   , topHandler
  39   , topHandlerWith
  40   , warn
  41   , warnError
  42   , notice
  43   , noticeNoWrap
  44   , noticeDoc
  45   , setupMessage
  46   , info
  47   , infoNoWrap
  48   , debug
  49   , debugNoWrap
  50   , chattyTry
  51   , annotateIO
  52   , exceptionWithMetadata
  53   , withOutputMarker
  54
  55     -- * exceptions
  56   , handleDoesNotExist
  57   , ignoreSigPipe
  58
  59     -- * running programs
  60   , rawSystemExit
  61   , rawSystemExitCode
  62   , rawSystemProc
  63   , rawSystemProcAction
  64   , rawSystemExitWithEnv
  65   , rawSystemExitWithEnvCwd
  66   , rawSystemStdout
  67   , rawSystemStdInOut
  68   , rawSystemIOWithEnv
  69   , rawSystemIOWithEnvAndAction
  70   , fromCreatePipe
  71   , maybeExit
  72   , xargs
  73   , findProgramVersion
  74
  75     -- ** 'IOData' re-export
  76
  77   --
  78   -- These types are re-exported from
  79   -- "Distribution.Utils.IOData" for convenience as they're
  80   -- exposed in the API of 'rawSystemStdInOut'
  81   , IOData (..)
  82   , KnownIODataMode (..)
  83   , IODataMode (..)
  84   , VerboseException (..)
  85
  86     -- * copying files
  87   , createDirectoryIfMissingVerbose
  88   , copyFileVerbose
  89   , copyFiles
  90   , copyFileTo
  91   , copyFileToCwd
  92
  93     -- * installing files
  94   , installOrdinaryFile
  95   , installExecutableFile
  96   , installMaybeExecutableFile
  97   , installOrdinaryFiles
  98   , installExecutableFiles
  99   , installMaybeExecutableFiles
 100   , installDirectoryContents
 101   , copyDirectoryRecursive
 102
 103     -- * File permissions
 104   , doesExecutableExist
 105   , setFileOrdinary
 106   , setFileExecutable
 107
 108     -- * file names
 109   , shortRelativePath
 110   , dropExeExtension
 111   , exeExtensions
 112
 113     -- * finding files
 114   , findFileEx
 115   , findFileCwd
 116   , findFirstFile
 117   , Suffix (..)
 118   , findFileWithExtension
 119   , findFileCwdWithExtension
 120   , findFileWithExtension'
 121   , findFileCwdWithExtension'
 122   , findAllFilesWithExtension
 123   , findAllFilesCwdWithExtension
 124   , findModuleFileEx
 125   , findModuleFileCwd
 126   , findModuleFilesEx
 127   , findModuleFilesCwd
 128   , getDirectoryContentsRecursive
 129
 130     -- * environment variables
 131   , isInSearchPath
 132   , addLibraryPath
 133
 134     -- * modification time
 135   , moreRecentFile
 136   , existsAndIsMoreRecentThan
 137
 138     -- * temp files and dirs
 139   , TempFileOptions (..)
 140   , defaultTempFileOptions
 141   , withTempFile
 142   , withTempFileCwd
 143   , withTempFileEx
 144   , withTempDirectory
 145   , withTempDirectoryCwd
 146   , withTempDirectoryEx
 147   , withTempDirectoryCwdEx
 148   , createTempDirectory
 149
 150     -- * .cabal and .buildinfo files
 151   , defaultPackageDescCwd
 152   , findPackageDesc
 153   , tryFindPackageDesc
 154   , findHookedPackageDesc
 155
 156     -- * reading and writing files safely
 157   , withFileContents
 158   , writeFileAtomic
 159   , rewriteFileEx
 160   , rewriteFileLBS
 161
 162     -- * Unicode
 163   , fromUTF8BS
 164   , fromUTF8LBS
 165   , toUTF8BS
 166   , toUTF8LBS
 167   , readUTF8File
 168   , withUTF8FileContents
 169   , writeUTF8File
 170   , normaliseLineEndings
 171
 172     -- * BOM
 173   , ignoreBOM
 174
 175     -- * generic utils
 176   , dropWhileEndLE
 177   , takeWhileEndLE
 178   , equating
 179   , comparing
 180   , isInfixOf
 181   , intercalate
 182   , lowercase
 183   , listUnion
 184   , listUnionRight
 185   , ordNub
 186   , ordNubBy
 187   , ordNubRight
 188   , safeHead
 189   , safeTail
 190   , safeLast
 191   , safeInit
 192   , unintersperse
 193   , wrapText
 194   , wrapLine
 195
 196     -- * FilePath stuff
 197   , isAbsoluteOnAnyPlatform
 198   , isRelativeOnAnyPlatform
 199   , exceptionWithCallStackPrefix
 200   ) where
 201
 202 import Distribution.Compat.Async (waitCatch, withAsyncNF)
 203 import Distribution.Compat.CopyFile
 204 import Distribution.Compat.FilePath as FilePath
 205 import Distribution.Compat.Internal.TempFile
 206 import Distribution.Compat.Lens (Lens', over)
 207 import Distribution.Compat.Prelude
 208 import Distribution.Compat.Stack
 209 import Distribution.ModuleName as ModuleName
 210 import Distribution.Simple.Errors
 211 import Distribution.Simple.PreProcess.Types
 212 import Distribution.System
 213 import Distribution.Types.PackageId
 214 import Distribution.Utils.Generic
 215 import Distribution.Utils.IOData (IOData (..), IODataMode (..), KnownIODataMode (..))
 216 import qualified Distribution.Utils.IOData as IOData
 217 import Distribution.Utils.Path
 218 import Distribution.Verbosity
 219 import Distribution.Version
 220 import Prelude ()
 221
 222 #ifdef CURRENT_PACKAGE_KEY
 223 #define BOOTSTRAPPED_CABAL 1
 224 #endif
 225
 226 #ifdef BOOTSTRAPPED_CABAL
 227 import qualified Paths_Cabal (version)
 228 #endif
 229
 230 import Distribution.Parsec
 231 import Distribution.Pretty
 232
 233 import qualified Data.ByteString.Lazy as BS
 234 import Data.Typeable
 235   ( cast
 236   )
 237
 238 import qualified Control.Exception as Exception
 239 import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
 240 import Distribution.Compat.Process (proc)
 241 import Foreign.C.Error (Errno (..), ePIPE)
 242 import qualified GHC.IO.Exception as GHC
 243 import GHC.Stack (HasCallStack)
 244 import Numeric (showFFloat)
 245 import System.Directory
 246   ( Permissions (executable)
 247   , createDirectory
 248   , doesDirectoryExist
 249   , doesFileExist
 250   , getDirectoryContents
 251   , getModificationTime
 252   , getPermissions
 253   , removeDirectoryRecursive
 254   , removeFile
 255   )
 256 import System.Environment
 257   ( getProgName
 258   )
 259 import System.FilePath (takeFileName)
 260 import System.FilePath as FilePath
 261   ( getSearchPath
 262   , joinPath
 263   , normalise
 264   , searchPathSeparator
 265   , splitDirectories
 266   , splitExtension
 267   , takeDirectory
 268   )
 269 import System.IO
 270   ( BufferMode (..)
 271   , Handle
 272   , hClose
 273   , hFlush
 274   , hGetContents
 275   , hPutStr
 276   , hPutStrLn
 277   , hSetBinaryMode
 278   , hSetBuffering
 279   , stderr
 280   , stdout
 281   )
 282 import System.IO.Error
 283 import System.IO.Unsafe
 284   ( unsafeInterleaveIO
 285   )
 286 import qualified System.Process as Process
 287 import qualified Text.PrettyPrint as Disp
 288
 289 -- We only get our own version number when we're building with ourselves
 290 cabalVersion :: Version
 291 #if defined(BOOTSTRAPPED_CABAL)
 292 cabalVersion = mkVersion' Paths_Cabal.version
 293 #elif defined(CABAL_VERSION)
 294 cabalVersion = mkVersion [CABAL_VERSION]
 295 #else
 296 cabalVersion = mkVersion [3,0]  --used when bootstrapping
 297 #endif
 298
 299 -- ----------------------------------------------------------------------------
 300 -- Exception and logging utils
 301
 302 -- Cabal's logging infrastructure has a few constraints:
 303 --
 304 --  * We must make all logging formatting and emissions decisions based
 305 --    on the 'Verbosity' parameter, which is the only parameter that is
 306 --    plumbed to enough call-sites to actually be used for this matter.
 307 --    (One of Cabal's "big mistakes" is to have never have defined a
 308 --    monad of its own.)
 309 --
 310 --  * When we 'die', we must raise an IOError.  This a backwards
 311 --    compatibility consideration, because that's what we've raised
 312 --    previously, and if we change to any other exception type,
 313 --    exception handlers which match on IOError will no longer work.
 314 --    One case where it is known we rely on IOError being catchable
 315 --    is 'readPkgConfigDb' in cabal-install; there may be other
 316 --    user code that also assumes this.
 317 --
 318 --  * The 'topHandler' does not know what 'Verbosity' is, because
 319 --    it gets called before we've done command line parsing (where
 320 --    the 'Verbosity' parameter would come from).
 321 --
 322 -- This leads to two big architectural choices:
 323 --
 324 --  * Although naively we might imagine 'Verbosity' to be a simple
 325 --    enumeration type, actually it is a full-on abstract data type
 326 --    that may contain arbitrarily complex information.  At the
 327 --    moment, it is fully representable as a string, but we might
 328 --    eventually also use verbosity to let users register their
 329 --    own logging handler.
 330 --
 331 --  * When we call 'die', we perform all the formatting and addition
 332 --    of extra information we need, and then ship this in the IOError
 333 --    to the top-level handler.  Here are alternate designs that
 334 --    don't work:
 335 --
 336 --      a) Ship the unformatted info to the handler.  This doesn't
 337 --      work because at the point the handler gets the message,
 338 --      we've lost call stacks, and even if we did, we don't have access
 339 --      to 'Verbosity' to decide whether or not to render it.
 340 --
 341 --      b) Print the information at the 'die' site, then raise an
 342 --      error.  This means that if the exception is subsequently
 343 --      caught by a handler, we will still have emitted the output,
 344 --      which is not the correct behavior.
 345 --
 346 --    For the top-level handler to "know" that an error message
 347 --    contains one of these fully formatted packets, we set a sentinel
 348 --    in one of IOError's extra fields.  This is handled by
 349 --    'ioeSetVerbatim' and 'ioeGetVerbatim'.
 350 --
 351
 352 dieNoVerbosity :: String -> IO a
 353 dieNoVerbosity msg =
 354   ioError (userError msg)
 355   where
 356     _ = callStack -- TODO: Attach CallStack to exception
 357
 358 -- | Tag an 'IOError' whose error string should be output to the screen
 359 -- verbatim.
 360 ioeSetVerbatim :: IOError -> IOError
 361 ioeSetVerbatim e = ioeSetLocation e "dieVerbatim"
 362
 363 -- | Check if an 'IOError' should be output verbatim to screen.
 364 ioeGetVerbatim :: IOError -> Bool
 365 ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim"
 366
 367 -- | Create a 'userError' whose error text will be output verbatim
 368 verbatimUserError :: String -> IOError
 369 verbatimUserError = ioeSetVerbatim . userError
 370
 371 dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a
 372 dieWithLocation' verbosity filename mb_lineno msg =
 373   die' verbosity $
 374     filename
 375       ++ ( case mb_lineno of
 376             Just lineno -> ":" ++ show lineno
 377             Nothing -> ""
 378          )
 379       ++ ": "
 380       ++ msg
 381
 382 die' :: Verbosity -> String -> IO a
 383 die' verbosity msg = withFrozenCallStack $ do
 384   ioError . verbatimUserError
 385     =<< annotateErrorString verbosity
 386     =<< pure . wrapTextVerbosity verbosity
 387     =<< pure . addErrorPrefix
 388     =<< prefixWithProgName msg
 389
 390 -- Type which will be a wrapper for cabal -expections and cabal-install exceptions
 391 data VerboseException a = VerboseException CallStack POSIXTime Verbosity a
 392   deriving (Show, Typeable)
 393
 394 -- Function which will replace the existing die' call sites
 395 dieWithException :: (HasCallStack, Show a1, Typeable a1, Exception (VerboseException a1)) => Verbosity -> a1 -> IO a
 396 dieWithException verbosity exception = do
 397   ts <- getPOSIXTime
 398   throwIO $ VerboseException callStack ts verbosity exception
 399
 400 -- Instance for Cabal Exception which will display error code and error message with callStack info
 401 instance Exception (VerboseException CabalException) where
 402   displayException :: VerboseException CabalException -> [Char]
 403   displayException (VerboseException stack timestamp verb cabalexception) =
 404     withOutputMarker
 405       verb
 406       ( concat
 407           [ "Error: [Cabal-"
 408           , show (exceptionCode cabalexception)
 409           , "]\n"
 410           ]
 411       )
 412       ++ exceptionWithMetadata stack timestamp verb (exceptionMessage cabalexception)
 413
 414 dieNoWrap :: Verbosity -> String -> IO a
 415 dieNoWrap verbosity msg = withFrozenCallStack $ do
 416   -- TODO: should this have program name or not?
 417   ioError . verbatimUserError
 418     =<< annotateErrorString
 419       verbosity
 420       (addErrorPrefix msg)
 421
 422 -- | Prefixing a message to indicate that it is a fatal error,
 423 -- if the 'errorPrefix' is not already present.
 424 addErrorPrefix :: String -> String
 425 addErrorPrefix msg
 426   | errorPrefix `isPrefixOf` msg = msg
 427   -- Backpack prefixes its errors already with "Error:", see
 428   -- 'Distribution.Utils.LogProgress.dieProgress'.
 429   -- Taking it away there destroys the layout, so we rather
 430   -- check here whether the prefix is already present.
 431   | otherwise = unwords [errorPrefix, msg]
 432
 433 -- | A prefix indicating that a message is a fatal error.
 434 errorPrefix :: String
 435 errorPrefix = "Error:"
 436
 437 -- | Prefix an error string with program name from 'getProgName'
 438 prefixWithProgName :: String -> IO String
 439 prefixWithProgName msg = do
 440   pname <- getProgName
 441   return $ pname ++ ": " ++ msg
 442
 443 -- | Annotate an error string with timestamp and 'withMetadata'.
 444 annotateErrorString :: Verbosity -> String -> IO String
 445 annotateErrorString verbosity msg = do
 446   ts <- getPOSIXTime
 447   return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg
 448
 449 -- | Given a block of IO code that may raise an exception, annotate
 450 -- it with the metadata from the current scope.  Use this as close
 451 -- to external code that raises IO exceptions as possible, since
 452 -- this function unconditionally wraps the error message with a trace
 453 -- (so it is NOT idempotent.)
 454 annotateIO :: Verbosity -> IO a -> IO a
 455 annotateIO verbosity act = do
 456   ts <- getPOSIXTime
 457   flip modifyIOError act $
 458     ioeModifyErrorString $
 459       withMetadata ts NeverMark VerboseTrace verbosity
 460
 461 -- | A semantic editor for the error message inside an 'IOError'.
 462 ioeModifyErrorString :: (String -> String) -> IOError -> IOError
 463 ioeModifyErrorString = over ioeErrorString
 464
 465 -- | A lens for the error message inside an 'IOError'.
 466 ioeErrorString :: Lens' IOError String
 467 ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe)
 468
 469 {-# NOINLINE topHandlerWith #-}
 470 topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a
 471 topHandlerWith cont prog = do
 472   -- By default, stderr to a terminal device is NoBuffering. But this
 473   -- is *really slow*
 474   hSetBuffering stderr LineBuffering
 475   Exception.catches
 476     prog
 477     [ Exception.Handler rethrowAsyncExceptions
 478     , Exception.Handler rethrowExitStatus
 479     , Exception.Handler handle
 480     ]
 481   where
 482     -- Let async exceptions rise to the top for the default top-handler
 483     rethrowAsyncExceptions :: Exception.AsyncException -> IO a
 484     rethrowAsyncExceptions a = throwIO a
 485
 486     -- ExitCode gets thrown asynchronously too, and we don't want to print it
 487     rethrowExitStatus :: ExitCode -> IO a
 488     rethrowExitStatus = throwIO
 489
 490     -- Print all other exceptions
 491     handle :: Exception.SomeException -> IO a
 492     handle se = do
 493       hFlush stdout
 494       pname <- getProgName
 495       hPutStr stderr (message pname se)
 496       cont se
 497
 498     message :: String -> Exception.SomeException -> String
 499     message pname (Exception.SomeException se) =
 500       case cast se :: Maybe Exception.IOException of
 501         Just ioe
 502           | ioeGetVerbatim ioe ->
 503               -- Use the message verbatim
 504               ioeGetErrorString ioe ++ "\n"
 505           | isUserError ioe ->
 506               let file = case ioeGetFileName ioe of
 507                     Nothing -> ""
 508                     Just path -> path ++ location ++ ": "
 509                   location = case ioeGetLocation ioe of
 510                     l@(n : _) | isDigit n -> ':' : l
 511                     _ -> ""
 512                   detail = ioeGetErrorString ioe
 513                in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail
 514         _ ->
 515           displaySomeException se ++ "\n"
 516
 517 -- | BC wrapper around 'Exception.displayException'.
 518 displaySomeException :: Exception.Exception e => e -> String
 519 displaySomeException se = Exception.displayException se
 520
 521 topHandler :: IO a -> IO a
 522 topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog
 523
 524 -- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'.
 525 verbosityHandle :: Verbosity -> Handle
 526 verbosityHandle verbosity
 527   | isVerboseStderr verbosity = stderr
 528   | otherwise = stdout
 529
 530 -- | Non fatal conditions that may be indicative of an error or problem.
 531 --
 532 -- We display these at the 'normal' verbosity level.
 533 warn :: Verbosity -> String -> IO ()
 534 warn verbosity msg = warnMessage "Warning" verbosity msg
 535
 536 -- | Like 'warn', but prepend @Error: …@ instead of @Waring: …@ before the
 537 -- the message. Useful when you want to highlight the condition is an error
 538 -- but do not want to quit the program yet.
 539 warnError :: Verbosity -> String -> IO ()
 540 warnError verbosity message = warnMessage "Error" verbosity message
 541
 542 -- | Warning message, with a custom label.
 543 warnMessage :: String -> Verbosity -> String -> IO ()
 544 warnMessage l verbosity msg = withFrozenCallStack $ do
 545   when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do
 546     ts <- getPOSIXTime
 547     hFlush stdout
 548     hPutStr stderr
 549       . withMetadata ts NormalMark FlagTrace verbosity
 550       . wrapTextVerbosity verbosity
 551       $ l ++ ": " ++ msg
 552
 553 -- | Useful status messages.
 554 --
 555 -- We display these at the 'normal' verbosity level.
 556 --
 557 -- This is for the ordinary helpful status messages that users see. Just
 558 -- enough information to know that things are working but not floods of detail.
 559 notice :: Verbosity -> String -> IO ()
 560 notice verbosity msg = withFrozenCallStack $ do
 561   when (verbosity >= normal) $ do
 562     let h = verbosityHandle verbosity
 563     ts <- getPOSIXTime
 564     hPutStr h $
 565       withMetadata ts NormalMark FlagTrace verbosity $
 566         wrapTextVerbosity verbosity $
 567           msg
 568
 569 -- | Display a message at 'normal' verbosity level, but without
 570 -- wrapping.
 571 noticeNoWrap :: Verbosity -> String -> IO ()
 572 noticeNoWrap verbosity msg = withFrozenCallStack $ do
 573   when (verbosity >= normal) $ do
 574     let h = verbosityHandle verbosity
 575     ts <- getPOSIXTime
 576     hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg
 577
 578 -- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity
 579 -- level.  Use this if you need fancy formatting.
 580 noticeDoc :: Verbosity -> Disp.Doc -> IO ()
 581 noticeDoc verbosity msg = withFrozenCallStack $ do
 582   when (verbosity >= normal) $ do
 583     let h = verbosityHandle verbosity
 584     ts <- getPOSIXTime
 585     hPutStr h $
 586       withMetadata ts NormalMark FlagTrace verbosity $
 587         Disp.renderStyle defaultStyle $
 588           msg
 589
 590 -- | Display a "setup status message".  Prefer using setupMessage'
 591 -- if possible.
 592 setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
 593 setupMessage verbosity msg pkgid = withFrozenCallStack $ do
 594   noticeNoWrap verbosity (msg ++ ' ' : prettyShow pkgid ++ "...")
 595
 596 -- | More detail on the operation of some action.
 597 --
 598 -- We display these messages when the verbosity level is 'verbose'
 599 info :: Verbosity -> String -> IO ()
 600 info verbosity msg = withFrozenCallStack $
 601   when (verbosity >= verbose) $ do
 602     let h = verbosityHandle verbosity
 603     ts <- getPOSIXTime
 604     hPutStr h $
 605       withMetadata ts NeverMark FlagTrace verbosity $
 606         wrapTextVerbosity verbosity $
 607           msg
 608
 609 infoNoWrap :: Verbosity -> String -> IO ()
 610 infoNoWrap verbosity msg = withFrozenCallStack $
 611   when (verbosity >= verbose) $ do
 612     let h = verbosityHandle verbosity
 613     ts <- getPOSIXTime
 614     hPutStr h $
 615       withMetadata ts NeverMark FlagTrace verbosity $
 616         msg
 617
 618 -- | Detailed internal debugging information
 619 --
 620 -- We display these messages when the verbosity level is 'deafening'
 621 debug :: Verbosity -> String -> IO ()
 622 debug verbosity msg = withFrozenCallStack $
 623   when (verbosity >= deafening) $ do
 624     let h = verbosityHandle verbosity
 625     ts <- getPOSIXTime
 626     hPutStr h $
 627       withMetadata ts NeverMark FlagTrace verbosity $
 628         wrapTextVerbosity verbosity $
 629           msg
 630     -- ensure that we don't lose output if we segfault/infinite loop
 631     hFlush stdout
 632
 633 -- | A variant of 'debug' that doesn't perform the automatic line
 634 -- wrapping. Produces better output in some cases.
 635 debugNoWrap :: Verbosity -> String -> IO ()
 636 debugNoWrap verbosity msg = withFrozenCallStack $
 637   when (verbosity >= deafening) $ do
 638     let h = verbosityHandle verbosity
 639     ts <- getPOSIXTime
 640     hPutStr h $
 641       withMetadata ts NeverMark FlagTrace verbosity $
 642         msg
 643     -- ensure that we don't lose output if we segfault/infinite loop
 644     hFlush stdout
 645
 646 -- | Perform an IO action, catching any IO exceptions and printing an error
 647 --   if one occurs.
 648 chattyTry
 649   :: String
 650   -- ^ a description of the action we were attempting
 651   -> IO ()
 652   -- ^ the action itself
 653   -> IO ()
 654 chattyTry desc action =
 655   catchIO action $ \exception ->
 656     hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception
 657
 658 -- | Run an IO computation, returning @e@ if it raises a "file
 659 -- does not exist" error.
 660 handleDoesNotExist :: a -> IO a -> IO a
 661 handleDoesNotExist e =
 662   Exception.handleJust
 663     (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing)
 664     (\_ -> return e)
 665
 666 -- -----------------------------------------------------------------------------
 667 -- Helper functions
 668
 669 -- | Wraps text unless the @+nowrap@ verbosity flag is active
 670 wrapTextVerbosity :: Verbosity -> String -> String
 671 wrapTextVerbosity verb
 672   | isVerboseNoWrap verb = withTrailingNewline
 673   | otherwise = withTrailingNewline . wrapText
 674
 675 -- | Prepends a timestamp if @+timestamp@ verbosity flag is set
 676 --
 677 -- This is used by 'withMetadata'
 678 withTimestamp :: Verbosity -> POSIXTime -> String -> String
 679 withTimestamp v ts msg
 680   | isVerboseTimestamp v = msg'
 681   | otherwise = msg -- no-op
 682   where
 683     msg' = case lines msg of
 684       [] -> tsstr "\n"
 685       l1 : rest -> unlines (tsstr (' ' : l1) : map (contpfx ++) rest)
 686
 687     -- format timestamp to be prepended to first line with msec precision
 688     tsstr = showFFloat (Just 3) (realToFrac ts :: Double)
 689
 690     -- continuation prefix for subsequent lines of msg
 691     contpfx = replicate (length (tsstr " ")) ' '
 692
 693 -- | Wrap output with a marker if @+markoutput@ verbosity flag is set.
 694 --
 695 -- NB: Why is markoutput done with start/end markers, and not prefixes?
 696 -- Markers are more convenient to add (if we want to add prefixes,
 697 -- we have to 'lines' and then 'map'; here's it's just some
 698 -- concatenates).  Note that even in the prefix case, we can't
 699 -- guarantee that the markers are unambiguous, because some of
 700 -- Cabal's output comes straight from external programs, where
 701 -- we don't have the ability to interpose on the output.
 702 --
 703 -- This is used by 'withMetadata'
 704 withOutputMarker :: Verbosity -> String -> String
 705 withOutputMarker v xs | not (isVerboseMarkOutput v) = xs
 706 withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly
 707 withOutputMarker _ xs =
 708   "-----BEGIN CABAL OUTPUT-----\n"
 709     ++ withTrailingNewline xs
 710     ++ "-----END CABAL OUTPUT-----\n"
 711
 712 -- | Append a trailing newline to a string if it does not
 713 -- already have a trailing newline.
 714 withTrailingNewline :: String -> String
 715 withTrailingNewline "" = ""
 716 withTrailingNewline (x : xs) = x : go x xs
 717   where
 718     go _ (c : cs) = c : go c cs
 719     go '\n' "" = ""
 720     go _ "" = "\n"
 721
 722 -- | Prepend a call-site and/or call-stack based on Verbosity
 723 withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String)
 724 withCallStackPrefix tracer verbosity s =
 725   withFrozenCallStack $
 726     ( if isVerboseCallSite verbosity
 727         then
 728           parentSrcLocPrefix
 729             ++
 730             -- Hack: need a newline before starting output marker :(
 731             if isVerboseMarkOutput verbosity
 732               then "\n"
 733               else ""
 734         else ""
 735     )
 736       ++ ( case traceWhen verbosity tracer of
 737             Just pre -> pre ++ prettyCallStack callStack ++ "\n"
 738             Nothing -> ""
 739          )
 740       ++ s
 741
 742 -- | When should we emit the call stack?  We always emit
 743 -- for internal errors, emit the trace for errors when we
 744 -- are in verbose mode, and otherwise only emit it if
 745 -- explicitly asked for using the @+callstack@ verbosity
 746 -- flag.  (At the moment, 'AlwaysTrace' is not used.
 747 data TraceWhen
 748   = AlwaysTrace
 749   | VerboseTrace
 750   | FlagTrace
 751   deriving (Eq)
 752
 753 -- | Determine if we should emit a call stack.
 754 -- If we trace, it also emits any prefix we should append.
 755 traceWhen :: Verbosity -> TraceWhen -> Maybe String
 756 traceWhen _ AlwaysTrace = Just ""
 757 traceWhen v VerboseTrace | v >= verbose = Just ""
 758 traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n"
 759 traceWhen _ _ = Nothing
 760
 761 -- | When should we output the marker?  Things like 'die'
 762 -- always get marked, but a 'NormalMark' will only be
 763 -- output if we're not a quiet verbosity.
 764 data MarkWhen = AlwaysMark | NormalMark | NeverMark
 765
 766 -- | Add all necessary metadata to a logging message
 767 withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
 768 withMetadata ts marker tracer verbosity x =
 769   withFrozenCallStack
 770     $
 771     -- NB: order matters.  Output marker first because we
 772     -- don't want to capture call stacks.
 773     withTrailingNewline
 774       . withCallStackPrefix tracer verbosity
 775       . ( case marker of
 776             AlwaysMark -> withOutputMarker verbosity
 777             NormalMark
 778               | not (isVerboseQuiet verbosity) ->
 779                   withOutputMarker verbosity
 780               | otherwise ->
 781                   id
 782             NeverMark -> id
 783         )
 784       -- Clear out any existing markers
 785       . clearMarkers
 786       . withTimestamp verbosity ts
 787     $ x
 788
 789 -- | Add all necessary metadata to a logging message
 790 exceptionWithMetadata :: CallStack -> POSIXTime -> Verbosity -> String -> String
 791 exceptionWithMetadata stack ts verbosity x =
 792   withTrailingNewline
 793     . exceptionWithCallStackPrefix stack verbosity
 794     . withOutputMarker verbosity
 795     . clearMarkers
 796     . withTimestamp verbosity ts
 797     $ x
 798
 799 clearMarkers :: String -> String
 800 clearMarkers s = unlines . filter isMarker $ lines s
 801   where
 802     isMarker "-----BEGIN CABAL OUTPUT-----" = False
 803     isMarker "-----END CABAL OUTPUT-----" = False
 804     isMarker _ = True
 805
 806 -- | Append a call-site and/or call-stack based on Verbosity
 807 exceptionWithCallStackPrefix :: CallStack -> Verbosity -> String -> String
 808 exceptionWithCallStackPrefix stack verbosity s =
 809   s
 810     ++ withFrozenCallStack
 811       ( ( if isVerboseCallSite verbosity
 812             then
 813               parentSrcLocPrefix
 814                 ++
 815                 -- Hack: need a newline before starting output marker :(
 816                 if isVerboseMarkOutput verbosity
 817                   then "\n"
 818                   else ""
 819             else ""
 820         )
 821           ++ ( if verbosity >= verbose
 822                 then prettyCallStack stack ++ "\n"
 823                 else ""
 824              )
 825       )
 826
 827 -- -----------------------------------------------------------------------------
 828 -- rawSystem variants
 829 --
 830 -- These all use 'Distribution.Compat.Process.proc' to ensure we
 831 -- consistently use process jobs on Windows and Ctrl-C delegation
 832 -- on Unix.
 833 --
 834 -- Additionally, they take care of logging command execution.
 835 --
 836
 837 -- | Helper to use with one of the 'rawSystem' variants, and exit
 838 -- unless the command completes successfully.
 839 maybeExit :: IO ExitCode -> IO ()
 840 maybeExit cmd = do
 841   exitcode <- cmd
 842   unless (exitcode == ExitSuccess) $ exitWith exitcode
 843
 844 -- | Log a command execution (that's typically about to happen)
 845 -- at info level, and log working directory and environment overrides
 846 -- at debug level if specified.
 847 logCommand :: Verbosity -> Process.CreateProcess -> IO ()
 848 logCommand verbosity cp = do
 849   infoNoWrap verbosity $
 850     "Running: " <> case Process.cmdspec cp of
 851       Process.ShellCommand sh -> sh
 852       Process.RawCommand path args -> Process.showCommandForUser path args
 853   case Process.env cp of
 854     Just env -> debugNoWrap verbosity $ "with environment: " ++ show env
 855     Nothing -> return ()
 856   case Process.cwd cp of
 857     Just cwd -> debugNoWrap verbosity $ "with working directory: " ++ show cwd
 858     Nothing -> return ()
 859   hFlush stdout
 860
 861 -- | Execute the given command with the given arguments, exiting
 862 -- with the same exit code if the command fails.
 863 rawSystemExit :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> FilePath -> [String] -> IO ()
 864 rawSystemExit verbosity mbWorkDir path args =
 865   withFrozenCallStack $
 866     maybeExit $
 867       rawSystemExitCode verbosity mbWorkDir path args Nothing
 868
 869 -- | Execute the given command with the given arguments, returning
 870 -- the command's exit code.
 871 rawSystemExitCode
 872   :: Verbosity
 873   -> Maybe (SymbolicPath CWD (Dir Pkg))
 874   -> FilePath
 875   -> [String]
 876   -> Maybe [(String, String)]
 877   -> IO ExitCode
 878 rawSystemExitCode verbosity mbWorkDir path args menv =
 879   withFrozenCallStack $
 880     rawSystemProc verbosity $
 881       (proc path args)
 882         { Process.cwd = fmap getSymbolicPath mbWorkDir
 883         , Process.env = menv
 884         }
 885
 886 -- | Execute the given command with the given arguments, returning
 887 -- the command's exit code.
 888 --
 889 -- Create the process argument with 'Distribution.Compat.Process.proc'
 890 -- to ensure consistent options with other 'rawSystem' functions in this
 891 -- module.
 892 rawSystemProc :: Verbosity -> Process.CreateProcess -> IO ExitCode
 893 rawSystemProc verbosity cp = withFrozenCallStack $ do
 894   (exitcode, _) <- rawSystemProcAction verbosity cp $ \_ _ _ -> return ()
 895   return exitcode
 896
 897 -- | Execute the given command with the given arguments, returning
 898 -- the command's exit code. 'action' is executed while the command
 899 -- is running, and would typically be used to communicate with the
 900 -- process through pipes.
 901 --
 902 -- Create the process argument with 'Distribution.Compat.Process.proc'
 903 -- to ensure consistent options with other 'rawSystem' functions in this
 904 -- module.
 905 rawSystemProcAction
 906   :: Verbosity
 907   -> Process.CreateProcess
 908   -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
 909   -> IO (ExitCode, a)
 910 rawSystemProcAction verbosity cp action = withFrozenCallStack $ do
 911   logCommand verbosity cp
 912   (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do
 913     a <- action mStdin mStdout mStderr
 914     exitcode <- Process.waitForProcess p
 915     return (exitcode, a)
 916   unless (exitcode == ExitSuccess) $ do
 917     let cmd = case Process.cmdspec cp of
 918           Process.ShellCommand sh -> sh
 919           Process.RawCommand path _args -> path
 920     debug verbosity $ cmd ++ " returned " ++ show exitcode
 921   return (exitcode, a)
 922
 923 -- | fromJust for dealing with 'Maybe Handle' values as obtained via
 924 -- 'System.Process.CreatePipe'. Creating a pipe using 'CreatePipe' guarantees
 925 -- a 'Just' value for the corresponding handle.
 926 fromCreatePipe :: Maybe Handle -> Handle
 927 fromCreatePipe = maybe (error "fromCreatePipe: Nothing") id
 928
 929 -- | Execute the given command with the given arguments and
 930 -- environment, exiting with the same exit code if the command fails.
 931 rawSystemExitWithEnv
 932   :: Verbosity
 933   -> FilePath
 934   -> [String]
 935   -> [(String, String)]
 936   -> IO ()
 937 rawSystemExitWithEnv verbosity =
 938   rawSystemExitWithEnvCwd verbosity Nothing
 939
 940 -- | Like 'rawSystemExitWithEnv', but setting a working directory.
 941 rawSystemExitWithEnvCwd
 942   :: Verbosity
 943   -> Maybe (SymbolicPath CWD to)
 944   -> FilePath
 945   -> [String]
 946   -> [(String, String)]
 947   -> IO ()
 948 rawSystemExitWithEnvCwd verbosity mbWorkDir path args env =
 949   withFrozenCallStack $
 950     maybeExit $
 951       rawSystemProc verbosity $
 952         (proc path args)
 953           { Process.env = Just env
 954           , Process.cwd = getSymbolicPath <$> mbWorkDir
 955           }
 956
 957 -- | Execute the given command with the given arguments, returning
 958 -- the command's exit code.
 959 --
 960 -- Optional arguments allow setting working directory, environment
 961 -- and input and output handles.
 962 rawSystemIOWithEnv
 963   :: Verbosity
 964   -> FilePath
 965   -> [String]
 966   -> Maybe FilePath
 967   -- ^ New working dir or inherit
 968   -> Maybe [(String, String)]
 969   -- ^ New environment or inherit
 970   -> Maybe Handle
 971   -- ^ stdin
 972   -> Maybe Handle
 973   -- ^ stdout
 974   -> Maybe Handle
 975   -- ^ stderr
 976   -> IO ExitCode
 977 rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do
 978   (exitcode, _) <-
 979     rawSystemIOWithEnvAndAction
 980       verbosity
 981       path
 982       args
 983       mcwd
 984       menv
 985       action
 986       inp
 987       out
 988       err
 989   return exitcode
 990   where
 991     action = return ()
 992
 993 -- | Execute the given command with the given arguments, returning
 994 -- the command's exit code. 'action' is executed while the command
 995 -- is running, and would typically be used to communicate with the
 996 -- process through pipes.
 997 --
 998 -- Optional arguments allow setting working directory, environment
 999 -- and input and output handles.
1000 rawSystemIOWithEnvAndAction
1001   :: Verbosity
1002   -> FilePath
1003   -> [String]
1004   -> Maybe FilePath
1005   -- ^ New working dir or inherit
1006   -> Maybe [(String, String)]
1007   -- ^ New environment or inherit
1008   -> IO a
1009   -- ^ action to perform after process is created, but before 'waitForProcess'.
1010   -> Maybe Handle
1011   -- ^ stdin
1012   -> Maybe Handle
1013   -- ^ stdout
1014   -> Maybe Handle
1015   -- ^ stderr
1016   -> IO (ExitCode, a)
1017 rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do
1018   let cp =
1019         (proc path args)
1020           { Process.cwd = mcwd
1021           , Process.env = menv
1022           , Process.std_in = mbToStd inp
1023           , Process.std_out = mbToStd out
1024           , Process.std_err = mbToStd err
1025           }
1026   rawSystemProcAction verbosity cp (\_ _ _ -> action)
1027   where
1028     mbToStd :: Maybe Handle -> Process.StdStream
1029     mbToStd = maybe Process.Inherit Process.UseHandle
1030
1031 -- | Execute the given command with the given arguments, returning
1032 -- the command's output. Exits if the command exits with error.
1033 --
1034 -- Provides control over the binary/text mode of the output.
1035 rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode
1036 rawSystemStdout verbosity path args = withFrozenCallStack $ do
1037   (output, errors, exitCode) <-
1038     rawSystemStdInOut
1039       verbosity
1040       path
1041       args
1042       Nothing
1043       Nothing
1044       Nothing
1045       (IOData.iodataMode :: IODataMode mode)
1046   when (exitCode /= ExitSuccess) $
1047     dieWithException verbosity $
1048       RawSystemStdout errors
1049   return output
1050
1051 -- | Execute the given command with the given arguments, returning
1052 -- the command's output, errors and exit code.
1053 --
1054 -- Optional arguments allow setting working directory, environment
1055 -- and command input.
1056 --
1057 -- Provides control over the binary/text mode of the input and output.
1058 rawSystemStdInOut
1059   :: KnownIODataMode mode
1060   => Verbosity
1061   -> FilePath
1062   -- ^ Program location
1063   -> [String]
1064   -- ^ Arguments
1065   -> Maybe FilePath
1066   -- ^ New working dir or inherit
1067   -> Maybe [(String, String)]
1068   -- ^ New environment or inherit
1069   -> Maybe IOData
1070   -- ^ input text and binary mode
1071   -> IODataMode mode
1072   -- ^ iodata mode, acts as proxy
1073   -> IO (mode, String, ExitCode)
1074   -- ^ output, errors, exit
1075 rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do
1076   let cp =
1077         (proc path args)
1078           { Process.cwd = mcwd
1079           , Process.env = menv
1080           , Process.std_in = Process.CreatePipe
1081           , Process.std_out = Process.CreatePipe
1082           , Process.std_err = Process.CreatePipe
1083           }
1084
1085   (exitcode, (mberr1, mberr2)) <- rawSystemProcAction verbosity cp $ \mb_in mb_out mb_err -> do
1086     let (inh, outh, errh) = (fromCreatePipe mb_in, fromCreatePipe mb_out, fromCreatePipe mb_err)
1087     flip Exception.finally (hClose inh >> hClose outh >> hClose errh) $ do
1088       -- output mode depends on what the caller wants
1089       -- but the errors are always assumed to be text (in the current locale)
1090       hSetBinaryMode errh False
1091
1092       -- fork off a couple threads to pull on the stderr and stdout
1093       -- so if the process writes to stderr we do not block.
1094
1095       withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do
1096         -- push all the input, if any
1097         ignoreSigPipe $ case input of
1098           Nothing -> hClose inh
1099           Just inputData -> IOData.hPutContents inh inputData
1100
1101         -- wait for both to finish
1102         mberr1 <- waitCatch outA
1103         mberr2 <- waitCatch errA
1104         return (mberr1, mberr2)
1105
1106   -- get the stderr, so it can be added to error message
1107   err <- reportOutputIOError mberr2
1108
1109   unless (exitcode == ExitSuccess) $
1110     debug verbosity $
1111       path
1112         ++ " returned "
1113         ++ show exitcode
1114         ++ if null err
1115           then ""
1116           else
1117             " with error message:\n"
1118               ++ err
1119               ++ case input of
1120                 Nothing -> ""
1121                 Just d | IOData.null d -> ""
1122                 Just (IODataText inp) -> "\nstdin input:\n" ++ inp
1123                 Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp
1124
1125   -- Check if we hit an exception while consuming the output
1126   -- (e.g. a text decoding error)
1127   out <- reportOutputIOError mberr1
1128
1129   return (out, err, exitcode)
1130   where
1131     reportOutputIOError :: Either Exception.SomeException a -> IO a
1132     reportOutputIOError (Right x) = return x
1133     reportOutputIOError (Left exc) = case fromException exc of
1134       Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path))
1135       Nothing -> throwIO exc
1136
1137 -- | Ignore SIGPIPE in a subcomputation.
1138 ignoreSigPipe :: IO () -> IO ()
1139 ignoreSigPipe = Exception.handle $ \case
1140   GHC.IOError{GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe}
1141     | Errno ioe == ePIPE -> return ()
1142   e -> throwIO e
1143
1144 -- | Look for a program and try to find it's version number. It can accept
1145 -- either an absolute path or the name of a program binary, in which case we
1146 -- will look for the program on the path.
1147 findProgramVersion
1148   :: String
1149   -- ^ version args
1150   -> (String -> String)
1151   -- ^ function to select version
1152   --   number from program output
1153   -> Verbosity
1154   -> FilePath
1155   -- ^ location
1156   -> IO (Maybe Version)
1157 findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do
1158   str <-
1159     rawSystemStdout verbosity path [versionArg]
1160       `catchIO` (\_ -> return "")
1161       `catch` (\(_ :: VerboseException CabalException) -> return "")
1162       `catchExit` (\_ -> return "")
1163   let version :: Maybe Version
1164       version = simpleParsec (selectVersion str)
1165   case version of
1166     Nothing ->
1167       warn verbosity $
1168         "cannot determine version of "
1169           ++ path
1170           ++ " :\n"
1171           ++ show str
1172     Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v
1173   return version
1174
1175 -- | Like the Unix xargs program. Useful for when we've got very long command
1176 -- lines that might overflow an OS limit on command line length and so you
1177 -- need to invoke a command multiple times to get all the args in.
1178 --
1179 -- Use it with either of the rawSystem variants above. For example:
1180 --
1181 -- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs
1182 xargs
1183   :: Int
1184   -> ([String] -> IO ())
1185   -> [String]
1186   -> [String]
1187   -> IO ()
1188 xargs maxSize rawSystemFun fixedArgs bigArgs =
1189   let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
1190       chunkSize = maxSize - fixedArgSize
1191    in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)
1192   where
1193     chunks len = unfoldr $ \s ->
1194       if null s
1195         then Nothing
1196         else Just (chunk [] len s)
1197
1198     chunk acc _ [] = (reverse acc, [])
1199     chunk acc len (s : ss)
1200       | len' < len = chunk (s : acc) (len - len' - 1) ss
1201       | otherwise = (reverse acc, s : ss)
1202       where
1203         len' = length s
1204
1205 -- ------------------------------------------------------------
1206
1207 -- * File Utilities
1208
1209 -- ------------------------------------------------------------
1210
1211 ----------------
1212 -- Finding files
1213
1214 -- | Find a file by looking in a search path. The file path must match exactly.
1215 --
1216 -- @since 3.4.0.0
1217 findFileCwd
1218   :: forall searchDir allowAbsolute
1219    . Verbosity
1220   -> Maybe (SymbolicPath CWD (Dir Pkg))
1221   -- ^ working directory
1222   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1223   -- ^ search directories
1224   -> RelativePath searchDir File
1225   -- ^ File Name
1226   -> IO (SymbolicPathX allowAbsolute Pkg File)
1227 findFileCwd verbosity mbWorkDir searchPath fileName =
1228   findFirstFile
1229     (interpretSymbolicPath mbWorkDir)
1230     [ path </> fileName
1231     | path <- ordNub searchPath
1232     ]
1233     >>= maybe (dieWithException verbosity $ FindFile $ getSymbolicPath fileName) return
1234
1235 -- | Find a file by looking in a search path. The file path must match exactly.
1236 findFileEx
1237   :: forall searchDir allowAbsolute
1238    . Verbosity
1239   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1240   -- ^ search directories
1241   -> RelativePath searchDir File
1242   -- ^ File Name
1243   -> IO (SymbolicPathX allowAbsolute Pkg File)
1244 findFileEx v = findFileCwd v Nothing
1245
1246 -- | Find a file by looking in a search path with one of a list of possible
1247 -- file extensions. The file base name should be given and it will be tried
1248 -- with each of the extensions in each element of the search path.
1249 findFileWithExtension
1250   :: [Suffix]
1251   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1252   -> RelativePath searchDir File
1253   -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File))
1254 findFileWithExtension =
1255   findFileCwdWithExtension Nothing
1256
1257 -- | Find a file by looking in a search path with one of a list of possible
1258 -- file extensions.
1259 --
1260 -- @since 3.4.0.0
1261 findFileCwdWithExtension
1262   :: forall searchDir allowAbsolute
1263    . Maybe (SymbolicPath CWD (Dir Pkg))
1264   -> [Suffix]
1265   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1266   -> RelativePath searchDir File
1267   -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File))
1268 findFileCwdWithExtension cwd extensions searchPath baseName =
1269   fmap (uncurry (</>))
1270     <$> findFileCwdWithExtension' cwd extensions searchPath baseName
1271
1272 -- | @since 3.4.0.0
1273 findAllFilesCwdWithExtension
1274   :: forall searchDir allowAbsolute
1275    . Maybe (SymbolicPath CWD (Dir Pkg))
1276   -- ^ working directory
1277   -> [Suffix]
1278   -- ^ extensions
1279   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1280   -- ^ relative search locations
1281   -> RelativePath searchDir File
1282   -- ^ basename
1283   -> IO [SymbolicPathX allowAbsolute Pkg File]
1284 findAllFilesCwdWithExtension mbWorkDir extensions searchPath basename =
1285   findAllFiles
1286     (interpretSymbolicPath mbWorkDir)
1287     [ path </> basename <.> ext
1288     | path <- ordNub searchPath
1289     , Suffix ext <- ordNub extensions
1290     ]
1291
1292 findAllFilesWithExtension
1293   :: [Suffix]
1294   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1295   -> RelativePath searchDir File
1296   -> IO [SymbolicPathX allowAbsolute Pkg File]
1297 findAllFilesWithExtension =
1298   findAllFilesCwdWithExtension Nothing
1299
1300 -- | Like 'findFileWithExtension' but returns which element of the search path
1301 -- the file was found in, and the file path relative to that base directory.
1302 findFileWithExtension'
1303   :: [Suffix]
1304   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1305   -> RelativePath searchDir File
1306   -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File))
1307 findFileWithExtension' =
1308   findFileCwdWithExtension' Nothing
1309
1310 -- | Like 'findFileCwdWithExtension' but returns which element of the search path
1311 -- the file was found in, and the file path relative to that base directory.
1312 findFileCwdWithExtension'
1313   :: forall searchDir allowAbsolute
1314    . Maybe (SymbolicPath CWD (Dir Pkg))
1315   -> [Suffix]
1316   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1317   -> RelativePath searchDir File
1318   -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File))
1319 findFileCwdWithExtension' cwd extensions searchPath baseName =
1320   findFirstFile
1321     (uncurry mkPath)
1322     [ (path, baseName <.> ext)
1323     | path <- ordNub searchPath
1324     , Suffix ext <- ordNub extensions
1325     ]
1326   where
1327     mkPath :: SymbolicPathX allowAbsolute Pkg (Dir searchDir) -> RelativePath searchDir File -> FilePath
1328     mkPath base file =
1329       interpretSymbolicPath cwd (base </> file)
1330
1331 findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)
1332 findFirstFile file = findFirst
1333   where
1334     findFirst [] = return Nothing
1335     findFirst (x : xs) = do
1336       exists <- doesFileExist (file x)
1337       if exists
1338         then return (Just x)
1339         else findFirst xs
1340
1341 findAllFiles :: (a -> FilePath) -> [a] -> IO [a]
1342 findAllFiles file = filterM (doesFileExist . file)
1343
1344 -- | Finds the files corresponding to a list of Haskell module names.
1345 --
1346 -- As 'findModuleFile' but for a list of module names.
1347 findModuleFilesEx
1348   :: forall searchDir allowAbsolute
1349    . Verbosity
1350   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1351   -- ^ build prefix (location of objects)
1352   -> [Suffix]
1353   -- ^ search suffixes
1354   -> [ModuleName]
1355   -- ^ modules
1356   -> IO [(SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)]
1357 findModuleFilesEx verbosity searchPath extensions moduleNames =
1358   traverse (findModuleFileEx verbosity searchPath extensions) moduleNames
1359
1360 -- | Finds the files corresponding to a list of Haskell module names.
1361 --
1362 -- As 'findModuleFileCwd' but for a list of module names.
1363 findModuleFilesCwd
1364   :: forall searchDir allowAbsolute
1365    . Verbosity
1366   -> Maybe (SymbolicPath CWD (Dir Pkg))
1367   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1368   -- ^ build prefix (location of objects)
1369   -> [Suffix]
1370   -- ^ search suffixes
1371   -> [ModuleName]
1372   -- ^ modules
1373   -> IO [(SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)]
1374 findModuleFilesCwd verbosity cwd searchPath extensions moduleNames =
1375   traverse (findModuleFileCwd verbosity cwd searchPath extensions) moduleNames
1376
1377 -- | Find the file corresponding to a Haskell module name.
1378 --
1379 -- This is similar to 'findFileWithExtension'' but specialised to a module
1380 -- name. The function fails if the file corresponding to the module is missing.
1381 findModuleFileEx
1382   :: forall searchDir allowAbsolute
1383    . Verbosity
1384   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1385   -- ^ build prefix (location of objects)
1386   -> [Suffix]
1387   -- ^ search suffixes
1388   -> ModuleName
1389   -- ^ module
1390   -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)
1391 findModuleFileEx verbosity =
1392   findModuleFileCwd verbosity Nothing
1393
1394 -- | Find the file corresponding to a Haskell module name.
1395 --
1396 -- This is similar to 'findFileCwdWithExtension'' but specialised to a module
1397 -- name. The function fails if the file corresponding to the module is missing.
1398 findModuleFileCwd
1399   :: forall searchDir allowAbsolute
1400    . Verbosity
1401   -> Maybe (SymbolicPath CWD (Dir Pkg))
1402   -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
1403   -- ^ build prefix (location of objects)
1404   -> [Suffix]
1405   -- ^ search suffixes
1406   -> ModuleName
1407   -- ^ module
1408   -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)
1409 findModuleFileCwd verbosity cwd searchPath extensions mod_name = do
1410   mbRes <-
1411     findFileCwdWithExtension'
1412       cwd
1413       extensions
1414       searchPath
1415       (makeRelativePathEx $ ModuleName.toFilePath mod_name)
1416   case mbRes of
1417     Nothing ->
1418       dieWithException verbosity $
1419         FindModuleFileEx mod_name extensions (map getSymbolicPath searchPath)
1420     Just res -> return res
1421
1422 -- | List all the files in a directory and all subdirectories.
1423 --
1424 -- The order places files in sub-directories after all the files in their
1425 -- parent directories. The list is generated lazily so is not well defined if
1426 -- the source directory structure changes before the list is used.
1427 getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
1428 getDirectoryContentsRecursive topdir = recurseDirectories [""]
1429   where
1430     recurseDirectories :: [FilePath] -> IO [FilePath]
1431     recurseDirectories [] = return []
1432     recurseDirectories (dir : dirs) = unsafeInterleaveIO $ do
1433       (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
1434       files' <- recurseDirectories (dirs' ++ dirs)
1435       return (files ++ files')
1436       where
1437         collect files dirs' [] =
1438           return
1439             ( reverse files
1440             , reverse dirs'
1441             )
1442         collect files dirs' (entry : entries)
1443           | ignore entry =
1444               collect files dirs' entries
1445         collect files dirs' (entry : entries) = do
1446           let dirEntry = dir </> entry
1447           isDirectory <- doesDirectoryExist (topdir </> dirEntry)
1448           if isDirectory
1449             then collect files (dirEntry : dirs') entries
1450             else collect (dirEntry : files) dirs' entries
1451
1452         ignore ['.'] = True
1453         ignore ['.', '.'] = True
1454         ignore _ = False
1455
1456 ------------------------
1457 -- Environment variables
1458
1459 -- | Is this directory in the system search path?
1460 isInSearchPath :: FilePath -> IO Bool
1461 isInSearchPath path = fmap (elem path) getSearchPath
1462
1463 addLibraryPath
1464   :: OS
1465   -> [FilePath]
1466   -> [(String, String)]
1467   -> [(String, String)]
1468 addLibraryPath os paths = addEnv
1469   where
1470     pathsString = intercalate [searchPathSeparator] paths
1471     ldPath = case os of
1472       OSX -> "DYLD_LIBRARY_PATH"
1473       _ -> "LD_LIBRARY_PATH"
1474
1475     addEnv [] = [(ldPath, pathsString)]
1476     addEnv ((key, value) : xs)
1477       | key == ldPath =
1478           if null value
1479             then (key, pathsString) : xs
1480             else (key, value ++ (searchPathSeparator : pathsString)) : xs
1481       | otherwise = (key, value) : addEnv xs
1482
1483 --------------------
1484 -- Modification time
1485
1486 -- | Compare the modification times of two files to see if the first is newer
1487 -- than the second. The first file must exist but the second need not.
1488 -- The expected use case is when the second file is generated using the first.
1489 -- In this use case, if the result is True then the second file is out of date.
1490 moreRecentFile :: FilePath -> FilePath -> IO Bool
1491 moreRecentFile a b = do
1492   exists <- doesFileExist b
1493   if not exists
1494     then return True
1495     else do
1496       tb <- getModificationTime b
1497       ta <- getModificationTime a
1498       return (ta > tb)
1499
1500 -- | Like 'moreRecentFile', but also checks that the first file exists.
1501 existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool
1502 existsAndIsMoreRecentThan a b = do
1503   exists <- doesFileExist a
1504   if not exists
1505     then return False
1506     else a `moreRecentFile` b
1507
1508 ----------------------------------------
1509 -- Copying and installing files and dirs
1510
1511 -- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.
1512 createDirectoryIfMissingVerbose
1513   :: Verbosity
1514   -> Bool
1515   -- ^ Create its parents too?
1516   -> FilePath
1517   -> IO ()
1518 createDirectoryIfMissingVerbose verbosity create_parents path0
1519   | create_parents = withFrozenCallStack $ createDirs (parents path0)
1520   | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0))
1521   where
1522     parents = reverse . scanl1 (</>) . splitDirectories . normalise
1523
1524     createDirs [] = return ()
1525     createDirs (dir : []) = createDir dir throwIO
1526     createDirs (dir : dirs) =
1527       createDir dir $ \_ -> do
1528         createDirs dirs
1529         createDir dir throwIO
1530
1531     createDir :: FilePath -> (IOException -> IO ()) -> IO ()
1532     createDir dir notExistHandler = do
1533       r <- tryIO $ createDirectoryVerbose verbosity dir
1534       case (r :: Either IOException ()) of
1535         Right () -> return ()
1536         Left e
1537           | isDoesNotExistError e -> notExistHandler e
1538           -- createDirectory (and indeed POSIX mkdir) does not distinguish
1539           -- between a dir already existing and a file already existing. So we
1540           -- check for it here. Unfortunately there is a slight race condition
1541           -- here, but we think it is benign. It could report an exception in
1542           -- the case that the dir did exist but another process deletes the
1543           -- directory and creates a file in its place before we can check
1544           -- that the directory did indeed exist.
1545           | isAlreadyExistsError e ->
1546               ( do
1547                   isDir <- doesDirectoryExist dir
1548                   unless isDir $ throwIO e
1549               )
1550                 `catchIO` ((\_ -> return ()) :: IOException -> IO ())
1551           | otherwise -> throwIO e
1552
1553 createDirectoryVerbose :: Verbosity -> FilePath -> IO ()
1554 createDirectoryVerbose verbosity dir = withFrozenCallStack $ do
1555   info verbosity $ "creating " ++ dir
1556   createDirectory dir
1557   setDirOrdinary dir
1558
1559 -- | Copies a file without copying file permissions. The target file is created
1560 -- with default permissions. Any existing target file is replaced.
1561 --
1562 -- At higher verbosity levels it logs an info message.
1563 copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
1564 copyFileVerbose verbosity src dest = withFrozenCallStack $ do
1565   info verbosity ("copy " ++ src ++ " to " ++ dest)
1566   copyFile src dest
1567
1568 -- | Install an ordinary file. This is like a file copy but the permissions
1569 -- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\"
1570 -- while on Windows it uses the default permissions for the target directory.
1571 installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()
1572 installOrdinaryFile verbosity src dest = withFrozenCallStack $ do
1573   info verbosity ("Installing " ++ src ++ " to " ++ dest)
1574   copyOrdinaryFile src dest
1575
1576 -- | Install an executable file. This is like a file copy but the permissions
1577 -- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\"
1578 -- while on Windows it uses the default permissions for the target directory.
1579 installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
1580 installExecutableFile verbosity src dest = withFrozenCallStack $ do
1581   info verbosity ("Installing executable " ++ src ++ " to " ++ dest)
1582   copyExecutableFile src dest
1583
1584 -- | Install a file that may or not be executable, preserving permissions.
1585 installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
1586 installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do
1587   perms <- getPermissions src
1588   if (executable perms) -- only checks user x bit
1589     then installExecutableFile verbosity src dest
1590     else installOrdinaryFile verbosity src dest
1591
1592 -- | Given a relative path to a file, copy it to the given directory, preserving
1593 -- the relative path and creating the parent directories if needed.
1594 copyFileTo
1595   :: Verbosity
1596   -> FilePath
1597   -> FilePath
1598   -> IO ()
1599 copyFileTo verbosity dir file =
1600   withFrozenCallStack $
1601     copyFileToCwd
1602       verbosity
1603       Nothing
1604       (makeSymbolicPath dir)
1605       (makeRelativePathEx file)
1606
1607 -- | Given a relative path to a file, copy it to the given directory, preserving
1608 -- the relative path and creating the parent directories if needed.
1609 copyFileToCwd
1610   :: Verbosity
1611   -> Maybe (SymbolicPath CWD (Dir Pkg))
1612   -> SymbolicPath Pkg (Dir target)
1613   -> RelativePath Pkg File
1614   -> IO ()
1615 copyFileToCwd verbosity mbWorkDir dir file = withFrozenCallStack $ do
1616   let targetFile = i $ dir </> unsafeCoerceSymbolicPath file
1617   createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)
1618   installOrdinaryFile verbosity (i file) targetFile
1619   where
1620     i :: SymbolicPathX allowAbs Pkg to -> FilePath
1621     i = interpretSymbolicPath mbWorkDir
1622
1623 -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
1624 -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
1625 copyFilesWith
1626   :: (Verbosity -> FilePath -> FilePath -> IO ())
1627   -> Verbosity
1628   -> FilePath
1629   -> [(FilePath, FilePath)]
1630   -> IO ()
1631 copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do
1632   -- Create parent directories for everything
1633   let dirs = map (targetDir </>) . ordNub . map (takeDirectory . snd) $ srcFiles
1634   traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs
1635
1636   -- Copy all the files
1637   sequence_
1638     [ let src = srcBase </> srcFile
1639           dest = targetDir </> srcFile
1640        in doCopy verbosity src dest
1641     | (srcBase, srcFile) <- srcFiles
1642     ]
1643
1644 -- | Copies a bunch of files to a target directory, preserving the directory
1645 -- structure in the target location. The target directories are created if they
1646 -- do not exist.
1647 --
1648 -- The files are identified by a pair of base directory and a path relative to
1649 -- that base. It is only the relative part that is preserved in the
1650 -- destination.
1651 --
1652 -- For example:
1653 --
1654 -- > copyFiles normal "dist/src"
1655 -- >    [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")]
1656 --
1657 -- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and
1658 -- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\".
1659 --
1660 -- This operation is not atomic. Any IO failure during the copy (including any
1661 -- missing source files) leaves the target in an unknown state so it is best to
1662 -- use it with a freshly created directory so that it can be simply deleted if
1663 -- anything goes wrong.
1664 copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
1665 copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs)
1666
1667 -- | This is like 'copyFiles' but uses 'installOrdinaryFile'.
1668 installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
1669 installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs)
1670
1671 -- | This is like 'copyFiles' but uses 'installExecutableFile'.
1672 installExecutableFiles
1673   :: Verbosity
1674   -> FilePath
1675   -> [(FilePath, FilePath)]
1676   -> IO ()
1677 installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs)
1678
1679 -- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'.
1680 installMaybeExecutableFiles
1681   :: Verbosity
1682   -> FilePath
1683   -> [(FilePath, FilePath)]
1684   -> IO ()
1685 installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs)
1686
1687 -- | This installs all the files in a directory to a target location,
1688 -- preserving the directory layout. All the files are assumed to be ordinary
1689 -- rather than executable files.
1690 installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()
1691 installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do
1692   info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
1693   srcFiles <- getDirectoryContentsRecursive srcDir
1694   installOrdinaryFiles verbosity destDir [(srcDir, f) | f <- srcFiles]
1695
1696 -- | Recursively copy the contents of one directory to another path.
1697 copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO ()
1698 copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do
1699   info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
1700   srcFiles <- getDirectoryContentsRecursive srcDir
1701   copyFilesWith
1702     (const copyFile)
1703     verbosity
1704     destDir
1705     [ (srcDir, f)
1706     | f <- srcFiles
1707     ]
1708
1709 -------------------
1710 -- File permissions
1711
1712 -- | Like 'doesFileExist', but also checks that the file is executable.
1713 doesExecutableExist :: FilePath -> IO Bool
1714 doesExecutableExist f = do
1715   exists <- doesFileExist f
1716   if exists
1717     then do
1718       perms <- getPermissions f
1719       return (executable perms)
1720     else return False
1721
1722 ---------------------------
1723 -- Temporary files and dirs
1724
1725 -- | Advanced options for 'withTempFile' and 'withTempDirectory'.
1726 data TempFileOptions = TempFileOptions
1727   { optKeepTempFiles :: Bool
1728   -- ^ Keep temporary files?
1729   }
1730
1731 defaultTempFileOptions :: TempFileOptions
1732 defaultTempFileOptions = TempFileOptions{optKeepTempFiles = False}
1733
1734 -- | Use a temporary filename that doesn't already exist
1735 withTempFile
1736   :: FilePath
1737   -- ^ Temp dir to create the file in
1738   -> String
1739   -- ^ File name template. See 'openTempFile'.
1740   -> (FilePath -> Handle -> IO a)
1741   -> IO a
1742 withTempFile tmpDir template f = withFrozenCallStack $
1743   withTempFileCwd Nothing (makeSymbolicPath tmpDir) template $
1744     \fp h -> f (getSymbolicPath fp) h
1745
1746 -- | Use a temporary filename that doesn't already exist.
1747 withTempFileCwd
1748   :: Maybe (SymbolicPath CWD (Dir Pkg))
1749   -- ^ Working directory
1750   -> SymbolicPath Pkg (Dir tmpDir)
1751   -- ^ Temp dir to create the file in
1752   -> String
1753   -- ^ File name template. See 'openTempFile'.
1754   -> (SymbolicPath Pkg File -> Handle -> IO a)
1755   -> IO a
1756 withTempFileCwd = withFrozenCallStack $ withTempFileEx defaultTempFileOptions
1757
1758 -- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'
1759 -- argument.
1760 withTempFileEx
1761   :: forall a tmpDir
1762    . TempFileOptions
1763   -> Maybe (SymbolicPath CWD (Dir Pkg))
1764   -- ^ Working directory
1765   -> SymbolicPath Pkg (Dir tmpDir)
1766   -- ^ Temp dir to create the file in
1767   -> String
1768   -- ^ File name template. See 'openTempFile'.
1769   -> (SymbolicPath Pkg File -> Handle -> IO a)
1770   -> IO a
1771 withTempFileEx opts mbWorkDir tmpDir template action =
1772   withFrozenCallStack $
1773     Exception.bracket
1774       (openTempFile (i tmpDir) template)
1775       ( \(name, handle) -> do
1776           hClose handle
1777           unless (optKeepTempFiles opts) $
1778             handleDoesNotExist () $
1779               removeFile $
1780                 name
1781       )
1782       (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg fn) h))
1783   where
1784     i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path
1785     mkRelToPkg :: FilePath -> SymbolicPath Pkg File
1786     mkRelToPkg fp =
1787       tmpDir </> makeRelativePathEx (takeFileName fp)
1788
1789 -- 'openTempFile' returns a path of the form @i tmpDir </> fn@, but we
1790 -- want 'withTempFileEx' to return @tmpDir </> fn@. So we split off
1791 -- the filename and add back the (un-interpreted) directory.
1792 -- This assumes 'openTempFile' returns a filepath of the form
1793 -- @inputDir </> fn@, where @fn@ does not contain any path separators.
1794
1795 -- | Create and use a temporary directory.
1796 --
1797 -- Creates a new temporary directory inside the given directory, making use
1798 -- of the template. The temp directory is deleted after use. For example:
1799 --
1800 -- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ...
1801 --
1802 -- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
1803 -- @src/sdist.342@.
1804 withTempDirectory
1805   :: Verbosity
1806   -> FilePath
1807   -> String
1808   -> (FilePath -> IO a)
1809   -> IO a
1810 withTempDirectory verb targetDir template f =
1811   withFrozenCallStack $
1812     withTempDirectoryCwd
1813       verb
1814       Nothing
1815       (makeSymbolicPath targetDir)
1816       template
1817       (f . getSymbolicPath)
1818
1819 -- | Create and use a temporary directory.
1820 --
1821 -- Creates a new temporary directory inside the given directory, making use
1822 -- of the template. The temp directory is deleted after use. For example:
1823 --
1824 -- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ...
1825 --
1826 -- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
1827 -- @src/sdist.342@.
1828 withTempDirectoryCwd
1829   :: Verbosity
1830   -> Maybe (SymbolicPath CWD (Dir Pkg))
1831   -- ^ Working directory
1832   -> SymbolicPath Pkg (Dir tmpDir1)
1833   -> String
1834   -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a)
1835   -> IO a
1836 withTempDirectoryCwd verbosity mbWorkDir targetDir template f =
1837   withFrozenCallStack $
1838     withTempDirectoryCwdEx
1839       verbosity
1840       defaultTempFileOptions
1841       mbWorkDir
1842       targetDir
1843       template
1844       (withLexicalCallStack (\x -> f x))
1845
1846 -- | A version of 'withTempDirectory' that additionally takes a
1847 -- 'TempFileOptions' argument.
1848 withTempDirectoryEx
1849   :: Verbosity
1850   -> TempFileOptions
1851   -> FilePath
1852   -> String
1853   -> (FilePath -> IO a)
1854   -> IO a
1855 withTempDirectoryEx verbosity opts targetDir template f =
1856   withFrozenCallStack $
1857     withTempDirectoryCwdEx verbosity opts Nothing (makeSymbolicPath targetDir) template $
1858       \fp -> f (getSymbolicPath fp)
1859
1860 -- | A version of 'withTempDirectoryCwd' that additionally takes a
1861 -- 'TempFileOptions' argument.
1862 withTempDirectoryCwdEx
1863   :: forall a tmpDir1 tmpDir2
1864    . Verbosity
1865   -> TempFileOptions
1866   -> Maybe (SymbolicPath CWD (Dir Pkg))
1867   -- ^ Working directory
1868   -> SymbolicPath Pkg (Dir tmpDir1)
1869   -> String
1870   -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a)
1871   -> IO a
1872 withTempDirectoryCwdEx _verbosity opts mbWorkDir targetDir template f =
1873   withFrozenCallStack $
1874     Exception.bracket
1875       (createTempDirectory (i targetDir) template)
1876       ( \tmpDirRelPath ->
1877           unless (optKeepTempFiles opts) $
1878             handleDoesNotExist () $
1879               removeDirectoryRecursive (i targetDir </> tmpDirRelPath)
1880       )
1881       (withLexicalCallStack (\tmpDirRelPath -> f $ targetDir </> makeRelativePathEx tmpDirRelPath))
1882   where
1883     i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path
1884
1885 -----------------------------------
1886 -- Safely reading and writing files
1887
1888 -- | Write a file but only if it would have new content. If we would be writing
1889 -- the same as the existing content then leave the file as is so that we do not
1890 -- update the file's modification time.
1891 --
1892 -- NB: Before Cabal-3.0 the file content was assumed to be
1893 --     ASCII-representable. Since Cabal-3.0 the file is assumed to be
1894 --     UTF-8 encoded.
1895 rewriteFileEx :: Verbosity -> FilePath -> String -> IO ()
1896 rewriteFileEx verbosity path =
1897   rewriteFileLBS verbosity path . toUTF8LBS
1898
1899 -- | Same as `rewriteFileEx` but for 'ByteString's.
1900 rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO ()
1901 rewriteFileLBS verbosity path newContent =
1902   flip catchIO mightNotExist $ do
1903     existingContent <- annotateIO verbosity $ BS.readFile path
1904     _ <- evaluate (BS.length existingContent)
1905     unless (existingContent == newContent) $
1906       annotateIO verbosity $
1907         writeFileAtomic path newContent
1908   where
1909     mightNotExist e
1910       | isDoesNotExistError e =
1911           annotateIO verbosity $ writeFileAtomic path newContent
1912       | otherwise =
1913           ioError e
1914
1915 shortRelativePath :: FilePath -> FilePath -> FilePath
1916 shortRelativePath from to =
1917   case dropCommonPrefix (splitDirectories from) (splitDirectories to) of
1918     (stuff, path) -> joinPath (map (const "..") stuff ++ path)
1919   where
1920     dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a])
1921     dropCommonPrefix (x : xs) (y : ys)
1922       | x == y = dropCommonPrefix xs ys
1923     dropCommonPrefix xs ys = (xs, ys)
1924
1925 -- | Drop the extension if it's one of 'exeExtensions', or return the path
1926 -- unchanged.
1927 dropExeExtension :: FilePath -> FilePath
1928 dropExeExtension filepath =
1929   -- System.FilePath's extension handling functions are horribly
1930   -- inconsistent, consider:
1931   --
1932   --     isExtensionOf "" "foo"  == False but
1933   --     isExtensionOf "" "foo." == True.
1934   --
1935   -- On the other hand stripExtension doesn't remove the empty extension:
1936   --
1937   --    stripExtension "" "foo." == Just "foo."
1938   --
1939   -- Since by "" in exeExtensions we mean 'no extension' anyways we can
1940   -- just always ignore it here.
1941   let exts = [ext | ext <- exeExtensions, ext /= ""]
1942    in fromMaybe filepath $ do
1943         ext <- find (`FilePath.isExtensionOf` filepath) exts
1944         ext `FilePath.stripExtension` filepath
1945
1946 -- | List of possible executable file extensions on the current build
1947 -- platform.
1948 exeExtensions :: [String]
1949 exeExtensions = case (buildArch, buildOS) of
1950   -- Possible improvement: on Windows, read the list of extensions from the
1951   -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat;
1952   -- .cmd".
1953   (_, Windows) -> ["", "exe"]
1954   (_, Ghcjs) -> ["", "exe"]
1955   (Wasm32, _) -> ["", "wasm"]
1956   _ -> [""]
1957
1958 -- ------------------------------------------------------------
1959
1960 -- * Finding the description file
1961
1962 -- ------------------------------------------------------------
1963
1964 -- | Package description file (/pkgname/@.cabal@) in the current
1965 -- working directory.
1966 defaultPackageDescCwd :: Verbosity -> IO (RelativePath Pkg File)
1967 defaultPackageDescCwd verbosity = tryFindPackageDesc verbosity Nothing
1968
1969 -- | Find a package description file in the given directory.  Looks for
1970 --  @.cabal@ files.
1971 findPackageDesc
1972   :: Maybe (SymbolicPath CWD (Dir Pkg))
1973   -- ^ package directory
1974   -> IO (Either CabalException (RelativePath Pkg File))
1975 findPackageDesc mbPkgDir =
1976   do
1977     let pkgDir = maybe "." getSymbolicPath mbPkgDir
1978     files <- getDirectoryContents pkgDir
1979     -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
1980     -- file we filter to exclude dirs and null base file names:
1981     cabalFiles <-
1982       filterM
1983         (doesFileExist . uncurry (</>))
1984         [ (pkgDir, file)
1985         | file <- files
1986         , let (name, ext) = splitExtension file
1987         , not (null name) && ext == ".cabal"
1988         ]
1989     case map snd cabalFiles of
1990       [] -> return (Left NoDesc)
1991       [cabalFile] -> return (Right $ makeRelativePathEx cabalFile)
1992       multiple -> return (Left $ MultiDesc multiple)
1993
1994 -- | Like 'findPackageDesc', but calls 'die' in case of error.
1995 tryFindPackageDesc
1996   :: Verbosity
1997   -> Maybe (SymbolicPath CWD (Dir Pkg))
1998   -- ^ directory in which to look
1999   -> IO (RelativePath Pkg File)
2000 tryFindPackageDesc verbosity dir =
2001   either (dieWithException verbosity) return =<< findPackageDesc dir
2002
2003 -- | Find auxiliary package information in the given directory.
2004 --  Looks for @.buildinfo@ files.
2005 findHookedPackageDesc
2006   :: Verbosity
2007   -> Maybe (SymbolicPath CWD (Dir Pkg))
2008   -- ^ Working directory
2009   -> SymbolicPath Pkg (Dir Build)
2010   -- ^ Directory to search
2011   -> IO (Maybe (SymbolicPath Pkg File))
2012   -- ^ /dir/@\/@/pkgname/@.buildinfo@, if present
2013 findHookedPackageDesc verbosity mbWorkDir dir = do
2014   files <- getDirectoryContents $ interpretSymbolicPath mbWorkDir dir
2015   buildInfoFiles <-
2016     filterM
2017       (doesFileExist . interpretSymbolicPath mbWorkDir)
2018       [ dir </> makeRelativePathEx file
2019       | file <- files
2020       , let (name, ext) = splitExtension file
2021       , not (null name) && ext == buildInfoExt
2022       ]
2023   case buildInfoFiles of
2024     [] -> return Nothing
2025     [f] -> return (Just f)
2026     _ -> dieWithException verbosity $ MultipleFilesWithExtension buildInfoExt
2027
2028 buildInfoExt :: String
2029 buildInfoExt = ".buildinfo"