utils/ghc-pkg/Main.hs

   1 {-# OPTIONS -fglasgow-exts -cpp #-}
   2 -----------------------------------------------------------------------------
   3 --
   4 -- (c) The University of Glasgow 2004-2009.
   5 --
   6 -- Package management tool
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module Main (main) where
  11
  12 import Version ( version, targetOS, targetARCH )
  13 import Distribution.InstalledPackageInfo.Binary()
  14 import qualified Distribution.Simple.PackageIndex as PackageIndex
  15 import Distribution.ModuleName hiding (main)
  16 import Distribution.InstalledPackageInfo
  17 import Distribution.Compat.ReadP
  18 import Distribution.ParseUtils
  19 import Distribution.Package hiding (depends)
  20 import Distribution.Text
  21 import Distribution.Version
  22 import System.FilePath
  23 import System.Cmd       ( rawSystem )
  24 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
  25                           getModificationTime )
  26 import Text.Printf
  27
  28 import Prelude
  29
  30 #include "../../includes/ghcconfig.h"
  31
  32 import System.Console.GetOpt
  33 #if __GLASGOW_HASKELL__ >= 609
  34 import qualified Control.Exception as Exception
  35 #else
  36 import qualified Control.Exception.Extensible as Exception
  37 #endif
  38 import Data.Maybe
  39
  40 import Data.Char ( isSpace, toLower )
  41 import Control.Monad
  42 import System.Directory ( doesDirectoryExist, getDirectoryContents,
  43                           doesFileExist, renameFile, removeFile )
  44 import System.Exit ( exitWith, ExitCode(..) )
  45 import System.Environment ( getArgs, getProgName, getEnv )
  46 import System.IO
  47 import System.IO.Error (try)
  48 import Data.List
  49 import Control.Concurrent
  50
  51 import qualified Data.ByteString.Lazy as B
  52 import qualified Data.Binary as Bin
  53 import qualified Data.Binary.Get as Bin
  54
  55 #if __GLASGOW_HASKELL__ < 612 || defined(mingw32_HOST_OS)
  56 -- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
  57 import Foreign
  58 import Foreign.C
  59 #endif
  60
  61 #if __GLASGOW_HASKELL__ < 612
  62 import System.Posix.Internals
  63 #if __GLASGOW_HASKELL__ >= 611
  64 import GHC.IO.Handle.FD (fdToHandle)
  65 #else
  66 import GHC.Handle (fdToHandle)
  67 #endif
  68 #endif
  69
  70 #ifdef mingw32_HOST_OS
  71 import GHC.ConsoleHandler
  72 #else
  73 import System.Posix hiding (fdToHandle)
  74 #endif
  75
  76 import IO ( isPermissionError )
  77
  78 #if defined(GLOB)
  79 import System.Process(runInteractiveCommand)
  80 import qualified System.Info(os)
  81 #endif
  82
  83 #if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING)
  84 import System.Console.Terminfo as Terminfo
  85 #endif
  86
  87 -- -----------------------------------------------------------------------------
  88 -- Entry point
  89
  90 main :: IO ()
  91 main = do
  92   args <- getArgs
  93
  94   case getOpt Permute (flags ++ deprecFlags) args of
  95         (cli,_,[]) | FlagHelp `elem` cli -> do
  96            prog <- getProgramName
  97            bye (usageInfo (usageHeader prog) flags)
  98         (cli,_,[]) | FlagVersion `elem` cli ->
  99            bye ourCopyright
 100         (cli,nonopts,[]) ->
 101            case getVerbosity Normal cli of
 102            Right v -> runit v cli nonopts
 103            Left err -> die err
 104         (_,_,errors) -> do
 105            prog <- getProgramName
 106            die (concat errors ++ usageInfo (usageHeader prog) flags)
 107
 108 -- -----------------------------------------------------------------------------
 109 -- Command-line syntax
 110
 111 data Flag
 112   = FlagUser
 113   | FlagGlobal
 114   | FlagHelp
 115   | FlagVersion
 116   | FlagConfig FilePath
 117   | FlagGlobalConfig FilePath
 118   | FlagForce
 119   | FlagForceFiles
 120   | FlagAutoGHCiLibs
 121   | FlagSimpleOutput
 122   | FlagNamesOnly
 123   | FlagIgnoreCase
 124   | FlagNoUserDb
 125   | FlagVerbosity (Maybe String)
 126   deriving Eq
 127
 128 flags :: [OptDescr Flag]
 129 flags = [
 130   Option [] ["user"] (NoArg FlagUser)
 131         "use the current user's package database",
 132   Option [] ["global"] (NoArg FlagGlobal)
 133         "use the global package database",
 134   Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
 135         "use the specified package config file",
 136   Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
 137         "location of the global package config",
 138   Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
 139         "never read the user package database",
 140   Option [] ["force"] (NoArg FlagForce)
 141          "ignore missing dependencies, directories, and libraries",
 142   Option [] ["force-files"] (NoArg FlagForceFiles)
 143          "ignore missing directories and libraries only",
 144   Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
 145         "automatically build libs for GHCi (with register)",
 146   Option ['?'] ["help"] (NoArg FlagHelp)
 147         "display this help and exit",
 148   Option ['V'] ["version"] (NoArg FlagVersion)
 149         "output version information and exit",
 150   Option [] ["simple-output"] (NoArg FlagSimpleOutput)
 151         "print output in easy-to-parse format for some commands",
 152   Option [] ["names-only"] (NoArg FlagNamesOnly)
 153         "only print package names, not versions; can only be used with list --simple-output",
 154   Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
 155         "ignore case for substring matching",
 156   Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
 157         "verbosity level (0-2, default 1)"
 158   ]
 159
 160 data Verbosity = Silent | Normal | Verbose
 161     deriving (Show, Eq, Ord)
 162
 163 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
 164 getVerbosity v [] = Right v
 165 getVerbosity _ (FlagVerbosity Nothing    : fs) = getVerbosity Verbose fs
 166 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent  fs
 167 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal  fs
 168 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
 169 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
 170 getVerbosity v (_ : fs) = getVerbosity v fs
 171
 172 deprecFlags :: [OptDescr Flag]
 173 deprecFlags = [
 174         -- put deprecated flags here
 175   ]
 176
 177 ourCopyright :: String
 178 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
 179
 180 usageHeader :: String -> String
 181 usageHeader prog = substProg prog $
 182   "Usage:\n" ++
 183   "  $p init {path}\n" ++
 184   "    Create and initialise a package database at the location {path}.\n" ++
 185   "    Packages can be registered in the new database using the register\n" ++
 186   "    command with --package-conf={path}.  To use the new database with GHC,\n" ++
 187   "    use GHC's -package-conf flag.\n" ++
 188   "\n" ++
 189   "  $p register {filename | -}\n" ++
 190   "    Register the package using the specified installed package\n" ++
 191   "    description. The syntax for the latter is given in the $p\n" ++
 192   "    documentation.  The input file should be encoded in UTF-8.\n" ++
 193   "\n" ++
 194   "  $p update {filename | -}\n" ++
 195   "    Register the package, overwriting any other package with the\n" ++
 196   "    same name. The input file should be encoded in UTF-8.\n" ++
 197   "\n" ++
 198   "  $p unregister {pkg-id}\n" ++
 199   "    Unregister the specified package.\n" ++
 200   "\n" ++
 201   "  $p expose {pkg-id}\n" ++
 202   "    Expose the specified package.\n" ++
 203   "\n" ++
 204   "  $p hide {pkg-id}\n" ++
 205   "    Hide the specified package.\n" ++
 206   "\n" ++
 207   "  $p list [pkg]\n" ++
 208   "    List registered packages in the global database, and also the\n" ++
 209   "    user database if --user is given. If a package name is given\n" ++
 210   "    all the registered versions will be listed in ascending order.\n" ++
 211   "    Accepts the --simple-output flag.\n" ++
 212   "\n" ++
 213   "  $p dot\n" ++
 214   "    Generate a graph of the package dependencies in a form suitable\n" ++
 215   "    for input for the graphviz tools.  For example, to generate a PDF" ++
 216   "    of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
 217   "\n" ++
 218   "  $p find-module {module}\n" ++
 219   "    List registered packages exposing module {module} in the global\n" ++
 220   "    database, and also the user database if --user is given.\n" ++
 221   "    All the registered versions will be listed in ascending order.\n" ++
 222   "    Accepts the --simple-output flag.\n" ++
 223   "\n" ++
 224   "  $p latest {pkg-id}\n" ++
 225   "    Prints the highest registered version of a package.\n" ++
 226   "\n" ++
 227   "  $p check\n" ++
 228   "    Check the consistency of package depenencies and list broken packages.\n" ++
 229   "    Accepts the --simple-output flag.\n" ++
 230   "\n" ++
 231   "  $p describe {pkg}\n" ++
 232   "    Give the registered description for the specified package. The\n" ++
 233   "    description is returned in precisely the syntax required by $p\n" ++
 234   "    register.\n" ++
 235   "\n" ++
 236   "  $p field {pkg} {field}\n" ++
 237   "    Extract the specified field of the package description for the\n" ++
 238   "    specified package. Accepts comma-separated multiple fields.\n" ++
 239   "\n" ++
 240   "  $p dump\n" ++
 241   "    Dump the registered description for every package.  This is like\n" ++
 242   "    \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
 243   "    by tools that parse the results, rather than humans.  The output is\n" ++
 244   "    always encoded in UTF-8, regardless of the current locale.\n" ++
 245   "\n" ++
 246   "  $p recache\n" ++
 247   "    Regenerate the package database cache.  This command should only be\n" ++
 248   "    necessary if you added a package to the database by dropping a file\n" ++
 249   "    into the database directory manually.  By default, the global DB\n" ++
 250   "    is recached; to recache a different DB use --user or --package-conf\n" ++
 251   "    as appropriate.\n" ++
 252   "\n" ++
 253   " Substring matching is supported for {module} in find-module and\n" ++
 254   " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
 255   " open substring ends (prefix*, *suffix, *infix*).\n" ++
 256   "\n" ++
 257   "  When asked to modify a database (register, unregister, update,\n"++
 258   "  hide, expose, and also check), ghc-pkg modifies the global database by\n"++
 259   "  default.  Specifying --user causes it to act on the user database,\n"++
 260   "  or --package-conf can be used to act on another database\n"++
 261   "  entirely. When multiple of these options are given, the rightmost\n"++
 262   "  one is used as the database to act upon.\n"++
 263   "\n"++
 264   "  Commands that query the package database (list, tree, latest, describe,\n"++
 265   "  field) operate on the list of databases specified by the flags\n"++
 266   "  --user, --global, and --package-conf.  If none of these flags are\n"++
 267   "  given, the default is --global --user.\n"++
 268   "\n" ++
 269   " The following optional flags are also accepted:\n"
 270
 271 substProg :: String -> String -> String
 272 substProg _ [] = []
 273 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
 274 substProg prog (c:xs) = c : substProg prog xs
 275
 276 -- -----------------------------------------------------------------------------
 277 -- Do the business
 278
 279 data Force = NoForce | ForceFiles | ForceAll | CannotForce
 280   deriving (Eq,Ord)
 281
 282 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
 283
 284 runit :: Verbosity -> [Flag] -> [String] -> IO ()
 285 runit verbosity cli nonopts = do
 286   installSignalHandlers -- catch ^C and clean up
 287   prog <- getProgramName
 288   let
 289         force
 290           | FlagForce `elem` cli        = ForceAll
 291           | FlagForceFiles `elem` cli   = ForceFiles
 292           | otherwise                   = NoForce
 293         auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
 294         splitFields fields = unfoldr splitComma (',':fields)
 295           where splitComma "" = Nothing
 296                 splitComma fs = Just $ break (==',') (tail fs)
 297
 298         substringCheck :: String -> Maybe (String -> Bool)
 299         substringCheck ""    = Nothing
 300         substringCheck "*"   = Just (const True)
 301         substringCheck [_]   = Nothing
 302         substringCheck (h:t) =
 303           case (h, init t, last t) of
 304             ('*',s,'*') -> Just (isInfixOf (f s) . f)
 305             ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
 306             ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
 307             _           -> Nothing
 308           where f | FlagIgnoreCase `elem` cli = map toLower
 309                   | otherwise                 = id
 310 #if defined(GLOB)
 311         glob x | System.Info.os=="mingw32" = do
 312           -- glob echoes its argument, after win32 filename globbing
 313           (_,o,_,_) <- runInteractiveCommand ("glob "++x)
 314           txt <- hGetContents o
 315           return (read txt)
 316         glob x | otherwise = return [x]
 317 #endif
 318   --
 319   -- first, parse the command
 320   case nonopts of
 321 #if defined(GLOB)
 322     -- dummy command to demonstrate usage and permit testing
 323     -- without messing things up; use glob to selectively enable
 324     -- windows filename globbing for file parameters
 325     -- register, update, FlagGlobalConfig, FlagConfig; others?
 326     ["glob", filename] -> do
 327         print filename
 328         glob filename >>= print
 329 #endif
 330     ["init", filename] ->
 331         initPackageDB filename verbosity cli
 332     ["register", filename] ->
 333         registerPackage filename verbosity cli auto_ghci_libs False force
 334     ["update", filename] ->
 335         registerPackage filename verbosity cli auto_ghci_libs True force
 336     ["unregister", pkgid_str] -> do
 337         pkgid <- readGlobPkgId pkgid_str
 338         unregisterPackage pkgid verbosity cli force
 339     ["expose", pkgid_str] -> do
 340         pkgid <- readGlobPkgId pkgid_str
 341         exposePackage pkgid verbosity cli force
 342     ["hide",   pkgid_str] -> do
 343         pkgid <- readGlobPkgId pkgid_str
 344         hidePackage pkgid verbosity cli force
 345     ["list"] -> do
 346         listPackages verbosity cli Nothing Nothing
 347     ["list", pkgid_str] ->
 348         case substringCheck pkgid_str of
 349           Nothing -> do pkgid <- readGlobPkgId pkgid_str
 350                         listPackages verbosity cli (Just (Id pkgid)) Nothing
 351           Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
 352     ["dot"] -> do
 353         showPackageDot verbosity cli
 354     ["find-module", moduleName] -> do
 355         let match = maybe (==moduleName) id (substringCheck moduleName)
 356         listPackages verbosity cli Nothing (Just match)
 357     ["latest", pkgid_str] -> do
 358         pkgid <- readGlobPkgId pkgid_str
 359         latestPackage verbosity cli pkgid
 360     ["describe", pkgid_str] ->
 361         case substringCheck pkgid_str of
 362           Nothing -> do pkgid <- readGlobPkgId pkgid_str
 363                         describePackage verbosity cli (Id pkgid)
 364           Just m -> describePackage verbosity cli (Substring pkgid_str m)
 365     ["field", pkgid_str, fields] ->
 366         case substringCheck pkgid_str of
 367           Nothing -> do pkgid <- readGlobPkgId pkgid_str
 368                         describeField verbosity cli (Id pkgid)
 369                                       (splitFields fields)
 370           Just m -> describeField verbosity cli (Substring pkgid_str m)
 371                                       (splitFields fields)
 372     ["check"] -> do
 373         checkConsistency verbosity cli
 374
 375     ["dump"] -> do
 376         dumpPackages verbosity cli
 377
 378     ["recache"] -> do
 379         recache verbosity cli
 380
 381     [] -> do
 382         die ("missing command\n" ++
 383                 usageInfo (usageHeader prog) flags)
 384     (_cmd:_) -> do
 385         die ("command-line syntax error\n" ++
 386                 usageInfo (usageHeader prog) flags)
 387
 388 parseCheck :: ReadP a a -> String -> String -> IO a
 389 parseCheck parser str what =
 390   case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
 391     [x] -> return x
 392     _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
 393
 394 readGlobPkgId :: String -> IO PackageIdentifier
 395 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
 396
 397 parseGlobPackageId :: ReadP r PackageIdentifier
 398 parseGlobPackageId =
 399   parse
 400      +++
 401   (do n <- parse
 402       _ <- string "-*"
 403       return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
 404
 405 -- globVersion means "all versions"
 406 globVersion :: Version
 407 globVersion = Version{ versionBranch=[], versionTags=["*"] }
 408
 409 -- -----------------------------------------------------------------------------
 410 -- Package databases
 411
 412 -- Some commands operate on a single database:
 413 --      register, unregister, expose, hide
 414 -- however these commands also check the union of the available databases
 415 -- in order to check consistency.  For example, register will check that
 416 -- dependencies exist before registering a package.
 417 --
 418 -- Some commands operate  on multiple databases, with overlapping semantics:
 419 --      list, describe, field
 420
 421 data PackageDB
 422   = PackageDB { location :: FilePath,
 423                 packages :: [InstalledPackageInfo] }
 424
 425 type PackageDBStack = [PackageDB]
 426         -- A stack of package databases.  Convention: head is the topmost
 427         -- in the stack.
 428
 429 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
 430 allPackagesInStack = concatMap packages
 431
 432 getPkgDatabases :: Verbosity
 433                 -> Bool    -- we are modifying, not reading
 434                 -> Bool    -- read caches, if available
 435                 -> [Flag]
 436                 -> IO (PackageDBStack,
 437                           -- the real package DB stack: [global,user] ++
 438                           -- DBs specified on the command line with -f.
 439                        Maybe FilePath,
 440                           -- which one to modify, if any
 441                        PackageDBStack)
 442                           -- the package DBs specified on the command
 443                           -- line, or [global,user] otherwise.  This
 444                           -- is used as the list of package DBs for
 445                           -- commands that just read the DB, such as 'list'.
 446
 447 getPkgDatabases verbosity modify use_cache my_flags = do
 448   -- first we determine the location of the global package config.  On Windows,
 449   -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
 450   -- location is passed to the binary using the --global-config flag by the
 451   -- wrapper script.
 452   let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
 453   global_conf <-
 454      case [ f | FlagGlobalConfig f <- my_flags ] of
 455         [] -> do mb_dir <- getLibDir
 456                  case mb_dir of
 457                    Nothing  -> die err_msg
 458                    Just dir -> do
 459                      r <- lookForPackageDBIn dir
 460                      case r of
 461                        Nothing -> die ("Can't find package database in " ++ dir)
 462                        Just path -> return path
 463         fs -> return (last fs)
 464
 465   let no_user_db = FlagNoUserDb `elem` my_flags
 466
 467   -- get the location of the user package database, and create it if necessary
 468   -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
 469   e_appdir <- try $ getAppUserDataDirectory "ghc"
 470
 471   mb_user_conf <-
 472      if no_user_db then return Nothing else
 473      case e_appdir of
 474        Left _    -> return Nothing
 475        Right appdir -> do
 476          let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
 477              dir = appdir </> subdir
 478          r <- lookForPackageDBIn dir
 479          case r of
 480            Nothing -> return (Just (dir </> "package.conf.d", False))
 481            Just f  -> return (Just (f, True))
 482
 483   -- If the user database doesn't exist, and this command isn't a
 484   -- "modify" command, then we won't attempt to create or use it.
 485   let sys_databases
 486         | Just (user_conf,user_exists) <- mb_user_conf,
 487           modify || user_exists = [user_conf, global_conf]
 488         | otherwise             = [global_conf]
 489
 490   e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
 491   let env_stack =
 492         case e_pkg_path of
 493                 Left  _ -> sys_databases
 494                 Right path
 495                   | last cs == ""  -> init cs ++ sys_databases
 496                   | otherwise      -> cs
 497                   where cs = parseSearchPath path
 498
 499         -- The "global" database is always the one at the bottom of the stack.
 500         -- This is the database we modify by default.
 501       virt_global_conf = last env_stack
 502
 503   let db_flags = [ f | Just f <- map is_db_flag my_flags ]
 504          where is_db_flag FlagUser
 505                       | Just (user_conf, _user_exists) <- mb_user_conf
 506                       = Just user_conf
 507                is_db_flag FlagGlobal     = Just virt_global_conf
 508                is_db_flag (FlagConfig f) = Just f
 509                is_db_flag _              = Nothing
 510
 511   let flag_db_names | null db_flags = env_stack
 512                     | otherwise     = reverse (nub db_flags)
 513
 514   -- For a "modify" command, treat all the databases as
 515   -- a stack, where we are modifying the top one, but it
 516   -- can refer to packages in databases further down the
 517   -- stack.
 518
 519   -- -f flags on the command line add to the database
 520   -- stack, unless any of them are present in the stack
 521   -- already.
 522   let final_stack = filter (`notElem` env_stack)
 523                      [ f | FlagConfig f <- reverse my_flags ]
 524                      ++ env_stack
 525
 526   -- the database we actually modify is the one mentioned
 527   -- rightmost on the command-line.
 528   let to_modify
 529         | not modify    = Nothing
 530         | null db_flags = Just virt_global_conf
 531         | otherwise     = Just (last db_flags)
 532
 533   db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
 534
 535   let flag_db_stack = [ db | db_name <- flag_db_names,
 536                         db <- db_stack, location db == db_name ]
 537
 538   return (db_stack, to_modify, flag_db_stack)
 539
 540
 541 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
 542 lookForPackageDBIn dir = do
 543   let path_dir = dir </> "package.conf.d"
 544   exists_dir <- doesDirectoryExist path_dir
 545   if exists_dir then return (Just path_dir) else do
 546   let path_file = dir </> "package.conf"
 547   exists_file <- doesFileExist path_file
 548   if exists_file then return (Just path_file) else return Nothing
 549
 550 readParseDatabase :: Verbosity
 551                   -> Maybe (FilePath,Bool)
 552                   -> Bool -- use cache
 553                   -> FilePath
 554                   -> IO PackageDB
 555
 556 readParseDatabase verbosity mb_user_conf use_cache path
 557   -- the user database (only) is allowed to be non-existent
 558   | Just (user_conf,False) <- mb_user_conf, path == user_conf
 559   = return PackageDB { location = path, packages = [] }
 560   | otherwise
 561   = do e <- try $ getDirectoryContents path
 562        case e of
 563          Left _   -> do
 564               pkgs <- parseMultiPackageConf verbosity path
 565               return PackageDB{ location = path, packages = pkgs }
 566          Right fs
 567            | not use_cache -> ignore_cache
 568            | otherwise -> do
 569               let cache = path </> cachefilename
 570               tdir     <- getModificationTime path
 571               e_tcache <- try $ getModificationTime cache
 572               case e_tcache of
 573                 Left ex -> do
 574                      when (verbosity > Normal) $
 575                         warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
 576                      ignore_cache
 577                 Right tcache
 578                   | tcache >= tdir -> do
 579                      when (verbosity > Normal) $
 580                         putStrLn ("using cache: " ++ cache)
 581                      pkgs <- myReadBinPackageDB cache
 582                      let pkgs' = map convertPackageInfoIn pkgs
 583                      return PackageDB { location = path, packages = pkgs' }
 584                   | otherwise -> do
 585                      when (verbosity >= Normal) $ do
 586                         warn ("WARNING: cache is out of date: " ++ cache)
 587                         warn "  use 'ghc-pkg recache' to fix."
 588                      ignore_cache
 589             where
 590                  ignore_cache = do
 591                      let confs = filter (".conf" `isSuffixOf`) fs
 592                      pkgs <- mapM (parseSingletonPackageConf verbosity) $
 593                                    map (path </>) confs
 594                      return PackageDB { location = path, packages = pkgs }
 595
 596 -- read the package.cache file strictly, to work around a problem with
 597 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
 598 -- after it has been completely read, leading to a sharing violation
 599 -- later.
 600 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
 601 myReadBinPackageDB filepath = do
 602   h <- openBinaryFile filepath ReadMode
 603   sz <- hFileSize h
 604   b <- B.hGet h (fromIntegral sz)
 605   hClose h
 606   return $ Bin.runGet Bin.get b
 607
 608 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
 609 parseMultiPackageConf verbosity file = do
 610   when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
 611   str <- readUTF8File file
 612   let pkgs = map convertPackageInfoIn $ read str
 613   Exception.evaluate pkgs
 614     `catchError` \e->
 615        die ("error while parsing " ++ file ++ ": " ++ show e)
 616
 617 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
 618 parseSingletonPackageConf verbosity file = do
 619   when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
 620   readUTF8File file >>= parsePackageInfo
 621
 622 cachefilename :: FilePath
 623 cachefilename = "package.cache"
 624
 625 -- -----------------------------------------------------------------------------
 626 -- Creating a new package DB
 627
 628 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
 629 initPackageDB filename verbosity _flags = do
 630   let eexist = die ("cannot create: " ++ filename ++ " already exists")
 631   b1 <- doesFileExist filename
 632   when b1 eexist
 633   b2 <- doesDirectoryExist filename
 634   when b2 eexist
 635   changeDB verbosity [] PackageDB{ location = filename, packages = [] }
 636
 637 -- -----------------------------------------------------------------------------
 638 -- Registering
 639
 640 registerPackage :: FilePath
 641                 -> Verbosity
 642                 -> [Flag]
 643                 -> Bool              -- auto_ghci_libs
 644                 -> Bool              -- update
 645                 -> Force
 646                 -> IO ()
 647 registerPackage input verbosity my_flags auto_ghci_libs update force = do
 648   (db_stack, Just to_modify, _flag_dbs) <-
 649       getPkgDatabases verbosity True True my_flags
 650
 651   let
 652         db_to_operate_on = my_head "register" $
 653                            filter ((== to_modify).location) db_stack
 654   --
 655   s <-
 656     case input of
 657       "-" -> do
 658         when (verbosity >= Normal) $
 659             putStr "Reading package info from stdin ... "
 660 #if __GLASGOW_HASKELL__ >= 612
 661         -- fix the encoding to UTF-8, since this is an interchange format
 662         hSetEncoding stdin utf8
 663 #endif
 664         getContents
 665       f   -> do
 666         when (verbosity >= Normal) $
 667             putStr ("Reading package info from " ++ show f ++ " ... ")
 668         readUTF8File f
 669
 670   expanded <- expandEnvVars s force
 671
 672   pkg <- parsePackageInfo expanded
 673   when (verbosity >= Normal) $
 674       putStrLn "done."
 675
 676   let truncated_stack = dropWhile ((/= to_modify).location) db_stack
 677   -- truncate the stack for validation, because we don't allow
 678   -- packages lower in the stack to refer to those higher up.
 679   validatePackageConfig pkg truncated_stack auto_ghci_libs update force
 680   let
 681      removes = [ RemovePackage p
 682                | p <- packages db_to_operate_on,
 683                  sourcePackageId p == sourcePackageId pkg ]
 684   --
 685   changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
 686
 687 parsePackageInfo
 688         :: String
 689         -> IO InstalledPackageInfo
 690 parsePackageInfo str =
 691   case parseInstalledPackageInfo str of
 692     ParseOk _warns ok -> return ok
 693     ParseFailed err -> case locatedErrorMsg err of
 694                            (Nothing, s) -> die s
 695                            (Just l, s) -> die (show l ++ ": " ++ s)
 696
 697 -- -----------------------------------------------------------------------------
 698 -- Making changes to a package database
 699
 700 data DBOp = RemovePackage InstalledPackageInfo
 701           | AddPackage    InstalledPackageInfo
 702           | ModifyPackage InstalledPackageInfo
 703
 704 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
 705 changeDB verbosity cmds db = do
 706   let db' = updateInternalDB db cmds
 707   isfile <- doesFileExist (location db)
 708   if isfile
 709      then writeNewConfig verbosity (location db') (packages db')
 710      else do
 711        createDirectoryIfMissing True (location db)
 712        changeDBDir verbosity cmds db'
 713
 714 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
 715 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
 716  where
 717   do_cmd pkgs (RemovePackage p) =
 718     filter ((/= installedPackageId p) . installedPackageId) pkgs
 719   do_cmd pkgs (AddPackage p) = p : pkgs
 720   do_cmd pkgs (ModifyPackage p) =
 721     do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
 722
 723
 724 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
 725 changeDBDir verbosity cmds db = do
 726   mapM_ do_cmd cmds
 727   updateDBCache verbosity db
 728  where
 729   do_cmd (RemovePackage p) = do
 730     let file = location db </> display (installedPackageId p) <.> "conf"
 731     when (verbosity > Normal) $ putStrLn ("removing " ++ file)
 732     removeFile file
 733   do_cmd (AddPackage p) = do
 734     let file = location db </> display (installedPackageId p) <.> "conf"
 735     when (verbosity > Normal) $ putStrLn ("writing " ++ file)
 736     writeFileUtf8Atomic file (showInstalledPackageInfo p)
 737   do_cmd (ModifyPackage p) =
 738     do_cmd (AddPackage p)
 739
 740 updateDBCache :: Verbosity -> PackageDB -> IO ()
 741 updateDBCache verbosity db = do
 742   let filename = location db </> cachefilename
 743   when (verbosity > Normal) $
 744       putStrLn ("writing cache " ++ filename)
 745   writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
 746     `catch` \e ->
 747       if isPermissionError e
 748       then die (filename ++ ": you don't have permission to modify this file")
 749       else ioError e
 750
 751 -- -----------------------------------------------------------------------------
 752 -- Exposing, Hiding, Unregistering are all similar
 753
 754 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 755 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
 756
 757 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 758 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
 759
 760 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 761 unregisterPackage = modifyPackage RemovePackage
 762
 763 modifyPackage
 764   :: (InstalledPackageInfo -> DBOp)
 765   -> PackageIdentifier
 766   -> Verbosity
 767   -> [Flag]
 768   -> Force
 769   -> IO ()
 770 modifyPackage fn pkgid verbosity my_flags force = do
 771   (db_stack, Just _to_modify, _flag_dbs) <-
 772       getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
 773
 774   (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
 775   let
 776       db_name = location db
 777       pkgs    = packages db
 778
 779       pids = map sourcePackageId ps
 780
 781       cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
 782       new_db = updateInternalDB db cmds
 783
 784       old_broken = brokenPackages (allPackagesInStack db_stack)
 785       rest_of_stack = filter ((/= db_name) . location) db_stack
 786       new_stack = new_db : rest_of_stack
 787       new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
 788       newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
 789   --
 790   when (not (null newly_broken)) $
 791       dieOrForceAll force ("unregistering " ++ display pkgid ++
 792            " would break the following packages: "
 793               ++ unwords (map display newly_broken))
 794
 795   changeDB verbosity cmds db
 796
 797 recache :: Verbosity -> [Flag] -> IO ()
 798 recache verbosity my_flags = do
 799   (db_stack, Just to_modify, _flag_dbs) <-
 800      getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
 801   let
 802         db_to_operate_on = my_head "recache" $
 803                            filter ((== to_modify).location) db_stack
 804   --
 805   changeDB verbosity [] db_to_operate_on
 806
 807 -- -----------------------------------------------------------------------------
 808 -- Listing packages
 809
 810 listPackages ::  Verbosity -> [Flag] -> Maybe PackageArg
 811              -> Maybe (String->Bool)
 812              -> IO ()
 813 listPackages verbosity my_flags mPackageName mModuleName = do
 814   let simple_output = FlagSimpleOutput `elem` my_flags
 815   (db_stack, _, flag_db_stack) <-
 816      getPkgDatabases verbosity False True{-use cache-} my_flags
 817
 818   let db_stack_filtered -- if a package is given, filter out all other packages
 819         | Just this <- mPackageName =
 820             [ db{ packages = filter (this `matchesPkg`) (packages db) }
 821             | db <- flag_db_stack ]
 822         | Just match <- mModuleName = -- packages which expose mModuleName
 823             [ db{ packages = filter (match `exposedInPkg`) (packages db) }
 824             | db <- flag_db_stack ]
 825         | otherwise = flag_db_stack
 826
 827       db_stack_sorted
 828           = [ db{ packages = sort_pkgs (packages db) }
 829             | db <- db_stack_filtered ]
 830           where sort_pkgs = sortBy cmpPkgIds
 831                 cmpPkgIds pkg1 pkg2 =
 832                    case pkgName p1 `compare` pkgName p2 of
 833                         LT -> LT
 834                         GT -> GT
 835                         EQ -> pkgVersion p1 `compare` pkgVersion p2
 836                    where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
 837
 838       stack = reverse db_stack_sorted
 839
 840       match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
 841
 842       pkg_map = allPackagesInStack db_stack
 843       broken = map sourcePackageId (brokenPackages pkg_map)
 844
 845       show_normal PackageDB{ location = db_name, packages = pkg_confs } =
 846           hPutStrLn stdout $ unlines ((db_name ++ ":") : map ("    " ++) pp_pkgs)
 847            where
 848                  pp_pkgs = map pp_pkg pkg_confs
 849                  pp_pkg p
 850                    | sourcePackageId p `elem` broken = printf "{%s}" doc
 851                    | exposed p = doc
 852                    | otherwise = printf "(%s)" doc
 853                    where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
 854                              | otherwise            = pkg
 855                           where
 856                           InstalledPackageId ipid = installedPackageId p
 857                           pkg = display (sourcePackageId p)
 858
 859       show_simple = simplePackageList my_flags . allPackagesInStack
 860
 861   when (not (null broken) && not simple_output && verbosity /= Silent) $ do
 862      prog <- getProgramName
 863      warn ("WARNING: there are broken packages.  Run '" ++ prog ++ " check' for more details.")
 864
 865   if simple_output then show_simple stack else do
 866
 867 #if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING)
 868   mapM_ show_normal stack
 869 #else
 870   let
 871      show_colour withF db =
 872          mconcat $ map (<#> termText "\n") $
 873              (termText (location db) :
 874                 map (termText "   " <#>) (map pp_pkg (packages db)))
 875         where
 876                  pp_pkg p
 877                    | sourcePackageId p `elem` broken = withF Red  doc
 878                    | exposed p                       = doc
 879                    | otherwise                       = withF Blue doc
 880                    where doc | verbosity >= Verbose
 881                              = termText (printf "%s (%s)" pkg ipid)
 882                              | otherwise
 883                              = termText pkg
 884                           where
 885                           InstalledPackageId ipid = installedPackageId p
 886                           pkg = display (sourcePackageId p)
 887
 888   is_tty <- hIsTerminalDevice stdout
 889   if not is_tty
 890      then mapM_ show_normal stack
 891      else do tty <- Terminfo.setupTermFromEnv
 892              case Terminfo.getCapability tty withForegroundColor of
 893                  Nothing -> mapM_ show_normal stack
 894                  Just w  -> runTermOutput tty $ mconcat $
 895                                                 map (show_colour w) stack
 896 #endif
 897
 898 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
 899 simplePackageList my_flags pkgs = do
 900    let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
 901                                                   else display
 902        strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
 903    when (not (null pkgs)) $
 904       hPutStrLn stdout $ concat $ intersperse " " strs
 905
 906 showPackageDot :: Verbosity -> [Flag] -> IO ()
 907 showPackageDot verbosity myflags = do
 908   (_, _, flag_db_stack) <-
 909       getPkgDatabases verbosity False True{-use cache-} myflags
 910
 911   let all_pkgs = allPackagesInStack flag_db_stack
 912       ipix  = PackageIndex.fromList all_pkgs
 913
 914   putStrLn "digraph {"
 915   let quote s = '"':s ++ "\""
 916   mapM_ putStrLn [ quote from ++ " -> " ++ quote to
 917                  | p <- all_pkgs,
 918                    let from = display (sourcePackageId p),
 919                    depid <- depends p,
 920                    Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
 921                    let to = display (sourcePackageId dep)
 922                  ]
 923   putStrLn "}"
 924
 925 -- -----------------------------------------------------------------------------
 926 -- Prints the highest (hidden or exposed) version of a package
 927
 928 latestPackage ::  Verbosity -> [Flag] -> PackageIdentifier -> IO ()
 929 latestPackage verbosity my_flags pkgid = do
 930   (_, _, flag_db_stack) <-
 931      getPkgDatabases verbosity False True{-use cache-} my_flags
 932
 933   ps <- findPackages flag_db_stack (Id pkgid)
 934   show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
 935   where
 936     show_pkg [] = die "no matches"
 937     show_pkg pids = hPutStrLn stdout (display (last pids))
 938
 939 -- -----------------------------------------------------------------------------
 940 -- Describe
 941
 942 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
 943 describePackage verbosity my_flags pkgarg = do
 944   (_, _, flag_db_stack) <-
 945       getPkgDatabases verbosity False True{-use cache-} my_flags
 946   ps <- findPackages flag_db_stack pkgarg
 947   doDump ps
 948
 949 dumpPackages :: Verbosity -> [Flag] -> IO ()
 950 dumpPackages verbosity my_flags = do
 951   (_, _, flag_db_stack) <-
 952      getPkgDatabases verbosity False True{-use cache-} my_flags
 953   doDump (allPackagesInStack flag_db_stack)
 954
 955 doDump :: [InstalledPackageInfo] -> IO ()
 956 doDump pkgs = do
 957 #if __GLASGOW_HASKELL__ >= 612
 958   -- fix the encoding to UTF-8, since this is an interchange format
 959   hSetEncoding stdout utf8
 960 #endif
 961   mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
 962
 963 -- PackageId is can have globVersion for the version
 964 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
 965 findPackages db_stack pkgarg
 966   = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
 967
 968 findPackagesByDB :: PackageDBStack -> PackageArg
 969                  -> IO [(PackageDB, [InstalledPackageInfo])]
 970 findPackagesByDB db_stack pkgarg
 971   = case [ (db, matched)
 972          | db <- db_stack,
 973            let matched = filter (pkgarg `matchesPkg`) (packages db),
 974            not (null matched) ] of
 975         [] -> die ("cannot find package " ++ pkg_msg pkgarg)
 976         ps -> return ps
 977   where
 978         pkg_msg (Id pkgid)           = display pkgid
 979         pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
 980
 981 matches :: PackageIdentifier -> PackageIdentifier -> Bool
 982 pid `matches` pid'
 983   = (pkgName pid == pkgName pid')
 984     && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
 985
 986 realVersion :: PackageIdentifier -> Bool
 987 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
 988   -- when versionBranch == [], this is a glob
 989
 990 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
 991 (Id pid)        `matchesPkg` pkg = pid `matches` sourcePackageId pkg
 992 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
 993
 994 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
 995 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
 996
 997 -- -----------------------------------------------------------------------------
 998 -- Field
 999
1000 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
1001 describeField verbosity my_flags pkgarg fields = do
1002   (_, _, flag_db_stack) <-
1003       getPkgDatabases verbosity False True{-use cache-} my_flags
1004   fns <- toFields fields
1005   ps <- findPackages flag_db_stack pkgarg
1006   let top_dir = takeDirectory (location (last flag_db_stack))
1007   mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
1008   where toFields [] = return []
1009         toFields (f:fs) = case toField f of
1010             Nothing -> die ("unknown field: " ++ f)
1011             Just fn -> do fns <- toFields fs
1012                           return (fn:fns)
1013         selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1014
1015 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
1016 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
1017 -- with the current topdir (obtained from the -B option).
1018 mungePackagePaths top_dir ps = map munge_pkg ps
1019   where
1020   munge_pkg p = p{ importDirs        = munge_paths (importDirs p),
1021                    includeDirs       = munge_paths (includeDirs p),
1022                    libraryDirs       = munge_paths (libraryDirs p),
1023                    frameworkDirs     = munge_paths (frameworkDirs p),
1024                    haddockInterfaces = munge_paths (haddockInterfaces p),
1025                    haddockHTMLs      = munge_paths (haddockHTMLs p)
1026                  }
1027
1028   munge_paths = map munge_path
1029
1030   munge_path p
1031    | Just p' <- maybePrefixMatch "$topdir"     p =            top_dir ++ p'
1032    | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1033    | otherwise                               = p
1034
1035   toHttpPath p = "file:///" ++ p
1036
1037 maybePrefixMatch :: String -> String -> Maybe String
1038 maybePrefixMatch []    rest = Just rest
1039 maybePrefixMatch (_:_) []   = Nothing
1040 maybePrefixMatch (p:pat) (r:rest)
1041   | p == r    = maybePrefixMatch pat rest
1042   | otherwise = Nothing
1043
1044 toField :: String -> Maybe (InstalledPackageInfo -> String)
1045 -- backwards compatibility:
1046 toField "import_dirs"     = Just $ strList . importDirs
1047 toField "source_dirs"     = Just $ strList . importDirs
1048 toField "library_dirs"    = Just $ strList . libraryDirs
1049 toField "hs_libraries"    = Just $ strList . hsLibraries
1050 toField "extra_libraries" = Just $ strList . extraLibraries
1051 toField "include_dirs"    = Just $ strList . includeDirs
1052 toField "c_includes"      = Just $ strList . includes
1053 toField "package_deps"    = Just $ strList . map display. depends
1054 toField "extra_cc_opts"   = Just $ strList . ccOptions
1055 toField "extra_ld_opts"   = Just $ strList . ldOptions
1056 toField "framework_dirs"  = Just $ strList . frameworkDirs
1057 toField "extra_frameworks"= Just $ strList . frameworks
1058 toField s                 = showInstalledPackageInfoField s
1059
1060 strList :: [String] -> String
1061 strList = show
1062
1063
1064 -- -----------------------------------------------------------------------------
1065 -- Check: Check consistency of installed packages
1066
1067 checkConsistency :: Verbosity -> [Flag] -> IO ()
1068 checkConsistency verbosity my_flags = do
1069   (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1070          -- check behaves like modify for the purposes of deciding which
1071          -- databases to use, because ordering is important.
1072
1073   let simple_output = FlagSimpleOutput `elem` my_flags
1074
1075   let pkgs = allPackagesInStack db_stack
1076
1077       checkPackage p = do
1078          (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
1079          if null es
1080             then do when (not simple_output) $ do
1081                       _ <- reportValidateErrors [] ws "" Nothing
1082                       return ()
1083                     return []
1084             else do
1085               when (not simple_output) $ do
1086                   reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1087                   _ <- reportValidateErrors es ws "  " Nothing
1088                   return ()
1089               return [p]
1090
1091   broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1092
1093   let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1094         where not_in p = sourcePackageId p `notElem` all_ps
1095               all_ps = map sourcePackageId pkgs1
1096
1097   let not_broken_pkgs = filterOut broken_pkgs pkgs
1098       (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1099       all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1100
1101   when (not (null all_broken_pkgs)) $ do
1102     if simple_output
1103       then simplePackageList my_flags all_broken_pkgs
1104       else do
1105        reportError ("\nThe following packages are broken, either because they have a problem\n"++
1106                 "listed above, or because they depend on a broken package.")
1107        mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1108
1109   when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1110
1111
1112 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1113         -> ([InstalledPackageInfo], [InstalledPackageInfo])
1114 closure pkgs db_stack = go pkgs db_stack
1115  where
1116    go avail not_avail =
1117      case partition (depsAvailable avail) not_avail of
1118         ([],        not_avail') -> (avail, not_avail')
1119         (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1120
1121    depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1122                  -> Bool
1123    depsAvailable pkgs_ok pkg = null dangling
1124         where dangling = filter (`notElem` pids) (depends pkg)
1125               pids = map installedPackageId pkgs_ok
1126
1127         -- we want mutually recursive groups of package to show up
1128         -- as broken. (#1750)
1129
1130 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1131 brokenPackages pkgs = snd (closure [] pkgs)
1132
1133 -- -----------------------------------------------------------------------------
1134 -- Manipulating package.conf files
1135
1136 type InstalledPackageInfoString = InstalledPackageInfo_ String
1137
1138 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1139 convertPackageInfoOut
1140     (pkgconf@(InstalledPackageInfo { exposedModules = e,
1141                                      hiddenModules = h })) =
1142         pkgconf{ exposedModules = map display e,
1143                  hiddenModules  = map display h }
1144
1145 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1146 convertPackageInfoIn
1147     (pkgconf@(InstalledPackageInfo { exposedModules = e,
1148                                      hiddenModules = h })) =
1149         pkgconf{ exposedModules = map convert e,
1150                  hiddenModules  = map convert h }
1151     where convert = fromJust . simpleParse
1152
1153 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1154 writeNewConfig verbosity filename ipis = do
1155   when (verbosity >= Normal) $
1156       hPutStr stdout "Writing new package config file... "
1157   createDirectoryIfMissing True $ takeDirectory filename
1158   let shown = concat $ intersperse ",\n "
1159                      $ map (show . convertPackageInfoOut) ipis
1160       fileContents = "[" ++ shown ++ "\n]"
1161   writeFileUtf8Atomic filename fileContents
1162     `catch` \e ->
1163       if isPermissionError e
1164       then die (filename ++ ": you don't have permission to modify this file")
1165       else ioError e
1166   when (verbosity >= Normal) $
1167       hPutStrLn stdout "done."
1168
1169 -----------------------------------------------------------------------------
1170 -- Sanity-check a new package config, and automatically build GHCi libs
1171 -- if requested.
1172
1173 type ValidateError   = (Force,String)
1174 type ValidateWarning = String
1175
1176 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1177
1178 instance Monad Validate where
1179    return a = V $ return (a, [], [])
1180    m >>= k = V $ do
1181       (a, es, ws) <- runValidate m
1182       (b, es', ws') <- runValidate (k a)
1183       return (b,es++es',ws++ws')
1184
1185 verror :: Force -> String -> Validate ()
1186 verror f s = V (return ((),[(f,s)],[]))
1187
1188 vwarn :: String -> Validate ()
1189 vwarn s = V (return ((),[],["Warning: " ++ s]))
1190
1191 liftIO :: IO a -> Validate a
1192 liftIO k = V (k >>= \a -> return (a,[],[]))
1193
1194 -- returns False if we should die
1195 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1196                      -> String -> Maybe Force -> IO Bool
1197 reportValidateErrors es ws prefix mb_force = do
1198   mapM_ (warn . (prefix++)) ws
1199   oks <- mapM report es
1200   return (and oks)
1201   where
1202     report (f,s)
1203       | Just force <- mb_force
1204       = if (force >= f)
1205            then do reportError (prefix ++ s ++ " (ignoring)")
1206                    return True
1207            else if f < CannotForce
1208                    then do reportError (prefix ++ s ++ " (use --force to override)")
1209                            return False
1210                    else do reportError err
1211                            return False
1212       | otherwise = do reportError err
1213                        return False
1214       where
1215              err = prefix ++ s
1216
1217 validatePackageConfig :: InstalledPackageInfo
1218                       -> PackageDBStack
1219                       -> Bool   -- auto-ghc-libs
1220                       -> Bool   -- update, or check
1221                       -> Force
1222                       -> IO ()
1223 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1224   (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1225   ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1226   when (not ok) $ exitWith (ExitFailure 1)
1227
1228 checkPackageConfig :: InstalledPackageInfo
1229                       -> PackageDBStack
1230                       -> Bool   -- auto-ghc-libs
1231                       -> Bool   -- update, or check
1232                       -> Validate ()
1233 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1234   checkInstalledPackageId pkg db_stack update
1235   checkPackageId pkg
1236   checkDuplicates db_stack pkg update
1237   mapM_ (checkDep db_stack) (depends pkg)
1238   checkDuplicateDepends (depends pkg)
1239   mapM_ (checkDir False "import-dirs")  (importDirs pkg)
1240   mapM_ (checkDir True  "library-dirs") (libraryDirs pkg)
1241   mapM_ (checkDir True  "include-dirs") (includeDirs pkg)
1242   checkModules pkg
1243   mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1244   -- ToDo: check these somehow?
1245   --    extra_libraries :: [String],
1246   --    c_includes      :: [String],
1247
1248 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1249                         -> Validate ()
1250 checkInstalledPackageId ipi db_stack update = do
1251   let ipid@(InstalledPackageId str) = installedPackageId ipi
1252   when (null str) $ verror CannotForce "missing id field"
1253   let dups = [ p | p <- allPackagesInStack db_stack,
1254                    installedPackageId p == ipid ]
1255   when (not update && not (null dups)) $
1256     verror CannotForce $
1257         "package(s) with this id already exist: " ++
1258          unwords (map (display.packageId) dups)
1259
1260 -- When the package name and version are put together, sometimes we can
1261 -- end up with a package id that cannot be parsed.  This will lead to
1262 -- difficulties when the user wants to refer to the package later, so
1263 -- we check that the package id can be parsed properly here.
1264 checkPackageId :: InstalledPackageInfo -> Validate ()
1265 checkPackageId ipi =
1266   let str = display (sourcePackageId ipi) in
1267   case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1268     [_] -> return ()
1269     []  -> verror CannotForce ("invalid package identifier: " ++ str)
1270     _   -> verror CannotForce ("ambiguous package identifier: " ++ str)
1271
1272 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1273 checkDuplicates db_stack pkg update = do
1274   let
1275         pkgid = sourcePackageId pkg
1276         pkgs  = packages (head db_stack)
1277   --
1278   -- Check whether this package id already exists in this DB
1279   --
1280   when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1281        verror CannotForce $
1282           "package " ++ display pkgid ++ " is already installed"
1283
1284   let
1285         uncasep = map toLower . display
1286         dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1287
1288   when (not update && not (null dups)) $ verror ForceAll $
1289         "Package names may be treated case-insensitively in the future.\n"++
1290         "Package " ++ display pkgid ++
1291         " overlaps with: " ++ unwords (map display dups)
1292
1293
1294 checkDir :: Bool -> String -> String -> Validate ()
1295 checkDir warn_only thisfield d
1296  | "$topdir"     `isPrefixOf` d = return ()
1297  | "$httptopdir" `isPrefixOf` d = return ()
1298         -- can't check these, because we don't know what $(http)topdir is
1299  | isRelative d = verror ForceFiles $
1300                      thisfield ++ ": " ++ d ++ " is a relative path"
1301         -- relative paths don't make any sense; #4134
1302  | otherwise = do
1303    there <- liftIO $ doesDirectoryExist d
1304    when (not there) $
1305        let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
1306        in
1307        if warn_only
1308           then vwarn msg
1309           else verror ForceFiles msg
1310
1311 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1312 checkDep db_stack pkgid
1313   | pkgid `elem` pkgids = return ()
1314   | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1315                                  ++ "\" doesn't exist")
1316   where
1317         all_pkgs = allPackagesInStack db_stack
1318         pkgids = map installedPackageId all_pkgs
1319
1320 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1321 checkDuplicateDepends deps
1322   | null dups = return ()
1323   | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1324                                      unwords (map display dups))
1325   where
1326        dups = [ p | (p:_:_) <- group (sort deps) ]
1327
1328 checkHSLib :: [String] -> Bool -> String -> Validate ()
1329 checkHSLib dirs auto_ghci_libs lib = do
1330   let batch_lib_file = "lib" ++ lib ++ ".a"
1331   m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1332   case m of
1333     Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1334                                    " on library path")
1335     Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1336
1337 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1338 doesFileExistOnPath file path = go path
1339   where go []     = return Nothing
1340         go (p:ps) = do b <- doesFileExistIn file p
1341                        if b then return (Just p) else go ps
1342
1343 doesFileExistIn :: String -> String -> IO Bool
1344 doesFileExistIn lib d
1345  | "$topdir"     `isPrefixOf` d = return True
1346  | "$httptopdir" `isPrefixOf` d = return True
1347  | otherwise                = doesFileExist (d </> lib)
1348
1349 checkModules :: InstalledPackageInfo -> Validate ()
1350 checkModules pkg = do
1351   mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1352   where
1353     findModule modl = do
1354       -- there's no .hi file for GHC.Prim
1355       if modl == fromString "GHC.Prim" then return () else do
1356       let file = toFilePath modl <.> "hi"
1357       m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1358       when (isNothing m) $
1359          verror ForceFiles ("file " ++ file ++ " is missing")
1360
1361 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1362 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1363   | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1364   | otherwise  = do
1365       m <- doesFileExistOnPath ghci_lib_file dirs
1366       when (isNothing m && ghci_lib_file /= "HSrts.o") $
1367         warn ("warning: can't find GHCi lib " ++ ghci_lib_file)
1368  where
1369     ghci_lib_file = lib <.> "o"
1370
1371 -- automatically build the GHCi version of a batch lib,
1372 -- using ld --whole-archive.
1373
1374 autoBuildGHCiLib :: String -> String -> String -> IO ()
1375 autoBuildGHCiLib dir batch_file ghci_file = do
1376   let ghci_lib_file  = dir ++ '/':ghci_file
1377       batch_lib_file = dir ++ '/':batch_file
1378   hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1379 #if defined(darwin_HOST_OS)
1380   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1381 #elif defined(mingw32_HOST_OS)
1382   execDir <- getLibDir
1383   r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1384 #else
1385   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1386 #endif
1387   when (r /= ExitSuccess) $ exitWith r
1388   hPutStrLn stderr (" done.")
1389
1390 -- -----------------------------------------------------------------------------
1391 -- Searching for modules
1392
1393 #if not_yet
1394
1395 findModules :: [FilePath] -> IO [String]
1396 findModules paths =
1397   mms <- mapM searchDir paths
1398   return (concat mms)
1399
1400 searchDir path prefix = do
1401   fs <- getDirectoryEntries path `catch` \_ -> return []
1402   searchEntries path prefix fs
1403
1404 searchEntries path prefix [] = return []
1405 searchEntries path prefix (f:fs)
1406   | looks_like_a_module  =  do
1407         ms <- searchEntries path prefix fs
1408         return (prefix `joinModule` f : ms)
1409   | looks_like_a_component  =  do
1410         ms <- searchDir (path </> f) (prefix `joinModule` f)
1411         ms' <- searchEntries path prefix fs
1412         return (ms ++ ms')
1413   | otherwise
1414         searchEntries path prefix fs
1415
1416   where
1417         (base,suffix) = splitFileExt f
1418         looks_like_a_module =
1419                 suffix `elem` haskell_suffixes &&
1420                 all okInModuleName base
1421         looks_like_a_component =
1422                 null suffix && all okInModuleName base
1423
1424 okInModuleName c
1425
1426 #endif
1427
1428 -- ---------------------------------------------------------------------------
1429 -- expanding environment variables in the package configuration
1430
1431 expandEnvVars :: String -> Force -> IO String
1432 expandEnvVars str0 force = go str0 ""
1433  where
1434    go "" acc = return $! reverse acc
1435    go ('$':'{':str) acc | (var, '}':rest) <- break close str
1436         = do value <- lookupEnvVar var
1437              go rest (reverse value ++ acc)
1438         where close c = c == '}' || c == '\n' -- don't span newlines
1439    go (c:str) acc
1440         = go str (c:acc)
1441
1442    lookupEnvVar :: String -> IO String
1443    lookupEnvVar nm =
1444         catch (System.Environment.getEnv nm)
1445            (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1446                                         show nm)
1447                       return "")
1448
1449 -----------------------------------------------------------------------------
1450
1451 getProgramName :: IO String
1452 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1453    where str `withoutSuffix` suff
1454             | suff `isSuffixOf` str = take (length str - length suff) str
1455             | otherwise             = str
1456
1457 bye :: String -> IO a
1458 bye s = putStr s >> exitWith ExitSuccess
1459
1460 die :: String -> IO a
1461 die = dieWith 1
1462
1463 dieWith :: Int -> String -> IO a
1464 dieWith ec s = do
1465   hFlush stdout
1466   prog <- getProgramName
1467   hPutStrLn stderr (prog ++ ": " ++ s)
1468   exitWith (ExitFailure ec)
1469
1470 dieOrForceAll :: Force -> String -> IO ()
1471 dieOrForceAll ForceAll s = ignoreError s
1472 dieOrForceAll _other s   = dieForcible s
1473
1474 warn :: String -> IO ()
1475 warn = reportError
1476
1477 ignoreError :: String -> IO ()
1478 ignoreError s = reportError (s ++ " (ignoring)")
1479
1480 reportError :: String -> IO ()
1481 reportError s = do hFlush stdout; hPutStrLn stderr s
1482
1483 dieForcible :: String -> IO ()
1484 dieForcible s = die (s ++ " (use --force to override)")
1485
1486 my_head :: String -> [a] -> a
1487 my_head s []      = error s
1488 my_head _ (x : _) = x
1489
1490 -----------------------------------------
1491 -- Cut and pasted from ghc/compiler/main/SysTools
1492
1493 #if defined(mingw32_HOST_OS)
1494 subst :: Char -> Char -> String -> String
1495 subst a b ls = map (\ x -> if x == a then b else x) ls
1496
1497 unDosifyPath :: FilePath -> FilePath
1498 unDosifyPath xs = subst '\\' '/' xs
1499
1500 getLibDir :: IO (Maybe String)
1501 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1502
1503 -- (getExecDir cmd) returns the directory in which the current
1504 --                  executable, which should be called 'cmd', is running
1505 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1506 -- you'll get "/a/b/c" back as the result
1507 getExecDir :: String -> IO (Maybe String)
1508 getExecDir cmd =
1509     getExecPath >>= maybe (return Nothing) removeCmdSuffix
1510     where initN n = reverse . drop n . reverse
1511           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1512
1513 getExecPath :: IO (Maybe String)
1514 getExecPath =
1515      allocaArray len $ \buf -> do
1516          ret <- getModuleFileName nullPtr buf len
1517          if ret == 0 then return Nothing
1518                      else liftM Just $ peekCString buf
1519     where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1520
1521 foreign import stdcall unsafe "GetModuleFileNameA"
1522     getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1523
1524 #else
1525 getLibDir :: IO (Maybe String)
1526 getLibDir = return Nothing
1527 #endif
1528
1529 -----------------------------------------
1530 -- Adapted from ghc/compiler/utils/Panic
1531
1532 installSignalHandlers :: IO ()
1533 installSignalHandlers = do
1534   threadid <- myThreadId
1535   let
1536       interrupt = Exception.throwTo threadid
1537                                     (Exception.ErrorCall "interrupted")
1538   --
1539 #if !defined(mingw32_HOST_OS)
1540   _ <- installHandler sigQUIT (Catch interrupt) Nothing
1541   _ <- installHandler sigINT  (Catch interrupt) Nothing
1542   return ()
1543 #elif __GLASGOW_HASKELL__ >= 603
1544   -- GHC 6.3+ has support for console events on Windows
1545   -- NOTE: running GHCi under a bash shell for some reason requires
1546   -- you to press Ctrl-Break rather than Ctrl-C to provoke
1547   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
1548   -- why --SDM 17/12/2004
1549   let sig_handler ControlC = interrupt
1550       sig_handler Break    = interrupt
1551       sig_handler _        = return ()
1552
1553   _ <- installHandler (Catch sig_handler)
1554   return ()
1555 #else
1556   return () -- nothing
1557 #endif
1558
1559 #if __GLASGOW_HASKELL__ <= 604
1560 isInfixOf               :: (Eq a) => [a] -> [a] -> Bool
1561 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
1562 #endif
1563
1564 #if mingw32_HOST_OS || mingw32_TARGET_OS
1565 throwIOIO :: Exception.IOException -> IO a
1566 throwIOIO = Exception.throwIO
1567
1568 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1569 catchIO = Exception.catch
1570 #endif
1571
1572 catchError :: IO a -> (String -> IO a) -> IO a
1573 catchError io handler = io `Exception.catch` handler'
1574     where handler' (Exception.ErrorCall err) = handler err
1575
1576
1577 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1578 writeBinaryFileAtomic targetFile obj =
1579   withFileAtomic targetFile $ \h -> do
1580      hSetBinaryMode h True
1581      B.hPutStr h (Bin.encode obj)
1582
1583 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1584 writeFileUtf8Atomic targetFile content =
1585   withFileAtomic targetFile $ \h -> do
1586 #if __GLASGOW_HASKELL__ >= 612
1587      hSetEncoding h utf8
1588 #endif
1589      hPutStr h content
1590
1591 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1592 -- to use text files here, rather than binary files.
1593 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1594 withFileAtomic targetFile write_content = do
1595   (newFile, newHandle) <- openNewFile targetDir template
1596   do  write_content newHandle
1597       hClose newHandle
1598 #if mingw32_HOST_OS || mingw32_TARGET_OS
1599       renameFile newFile targetFile
1600         -- If the targetFile exists then renameFile will fail
1601         `catchIO` \err -> do
1602           exists <- doesFileExist targetFile
1603           if exists
1604             then do removeFile targetFile
1605                     -- Big fat hairy race condition
1606                     renameFile newFile targetFile
1607                     -- If the removeFile succeeds and the renameFile fails
1608                     -- then we've lost the atomic property.
1609             else throwIOIO err
1610 #else
1611       renameFile newFile targetFile
1612 #endif
1613    `Exception.onException` do hClose newHandle
1614                               removeFile newFile
1615   where
1616     template = targetName <.> "tmp"
1617     targetDir | null targetDir_ = "."
1618               | otherwise       = targetDir_
1619     --TODO: remove this when takeDirectory/splitFileName is fixed
1620     --      to always return a valid dir
1621     (targetDir_,targetName) = splitFileName targetFile
1622
1623 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1624 openNewFile dir template = do
1625 #if __GLASGOW_HASKELL__ >= 612
1626   -- this was added to System.IO in 6.12.1
1627   -- we must use this version because the version below opens the file
1628   -- in binary mode.
1629   openTempFileWithDefaultPermissions dir template
1630 #else
1631   -- Ugh, this is a copy/paste of code from the base library, but
1632   -- if uses 666 rather than 600 for the permissions.
1633   pid <- c_getpid
1634   findTempName pid
1635   where
1636     -- We split off the last extension, so we can use .foo.ext files
1637     -- for temporary files (hidden on Unix OSes). Unfortunately we're
1638     -- below filepath in the hierarchy here.
1639     (prefix,suffix) =
1640        case break (== '.') $ reverse template of
1641          -- First case: template contains no '.'s. Just re-reverse it.
1642          (rev_suffix, "")       -> (reverse rev_suffix, "")
1643          -- Second case: template contains at least one '.'. Strip the
1644          -- dot from the prefix and prepend it to the suffix (if we don't
1645          -- do this, the unique number will get added after the '.' and
1646          -- thus be part of the extension, which is wrong.)
1647          (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1648          -- Otherwise, something is wrong, because (break (== '.')) should
1649          -- always return a pair with either the empty string or a string
1650          -- beginning with '.' as the second component.
1651          _                      -> error "bug in System.IO.openTempFile"
1652
1653     oflags = rw_flags .|. o_EXCL
1654
1655 #if __GLASGOW_HASKELL__ < 611
1656     withFilePath = withCString
1657 #endif
1658
1659     findTempName x = do
1660       fd <- withFilePath filepath $ \ f ->
1661               c_open f oflags 0o666
1662       if fd < 0
1663        then do
1664          errno <- getErrno
1665          if errno == eEXIST
1666            then findTempName (x+1)
1667            else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1668        else do
1669          -- XXX We want to tell fdToHandle what the filepath is,
1670          -- as any exceptions etc will only be able to report the
1671          -- fd currently
1672          h <-
1673 #if __GLASGOW_HASKELL__ >= 609
1674               fdToHandle fd
1675 #else
1676               fdToHandle (fromIntegral fd)
1677 #endif
1678               `Exception.onException` c_close fd
1679          return (filepath, h)
1680       where
1681         filename        = prefix ++ show x ++ suffix
1682         filepath        = dir `combine` filename
1683
1684 -- XXX Copied from GHC.Handle
1685 std_flags, output_flags, rw_flags :: CInt
1686 std_flags    = o_NONBLOCK   .|. o_NOCTTY
1687 output_flags = std_flags    .|. o_CREAT
1688 rw_flags     = output_flags .|. o_RDWR
1689 #endif /* GLASGOW_HASKELL < 612 */
1690
1691 -- | The function splits the given string to substrings
1692 -- using 'isSearchPathSeparator'.
1693 parseSearchPath :: String -> [FilePath]
1694 parseSearchPath path = split path
1695   where
1696     split :: String -> [String]
1697     split s =
1698       case rest' of
1699         []     -> [chunk]
1700         _:rest -> chunk : split rest
1701       where
1702         chunk =
1703           case chunk' of
1704 #ifdef mingw32_HOST_OS
1705             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1706 #endif
1707             _                                 -> chunk'
1708
1709         (chunk', rest') = break isSearchPathSeparator s
1710
1711 readUTF8File :: FilePath -> IO String
1712 readUTF8File file = do
1713   h <- openFile file ReadMode
1714 #if __GLASGOW_HASKELL__ >= 612
1715   -- fix the encoding to UTF-8
1716   hSetEncoding h utf8
1717 #endif
1718   hGetContents h