utils/ghc-pkg/Main.hs

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