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