utils/ghc-pkg/Main.hs

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