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