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