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