utils/ghc-pkg/Main.hs

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