utils/ghc-pkg/Main.hs

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