Cabal/src/Distribution/Simple/Utils.hs

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