utils/ghc-pkg/Main.hs

   1 {-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
   2 -----------------------------------------------------------------------------
   3 --
   4 -- (c) The University of Glasgow 2004-2009.
   5 --
   6 -- Package management tool
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module Main (main) where
  11
  12 import Version ( version, targetOS, targetARCH )
  13 import Distribution.InstalledPackageInfo.Binary()
  14 import qualified Distribution.Simple.PackageIndex as PackageIndex
  15 import Distribution.ModuleName hiding (main)
  16 import Distribution.InstalledPackageInfo
  17 import Distribution.Compat.ReadP
  18 import Distribution.ParseUtils
  19 import Distribution.Package hiding (depends)
  20 import Distribution.Text
  21 import Distribution.Version
  22 import System.FilePath
  23 import System.Cmd       ( rawSystem )
  24 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
  25                           getModificationTime )
  26 import Text.Printf
  27
  28 import Prelude
  29
  30 import System.Console.GetOpt
  31 import qualified Control.Exception as Exception
  32 import Data.Maybe
  33
  34 import Data.Char ( isSpace, toLower )
  35 import Control.Monad
  36 import System.Directory ( doesDirectoryExist, getDirectoryContents,
  37                           doesFileExist, renameFile, removeFile )
  38 import System.Exit ( exitWith, ExitCode(..) )
  39 import System.Environment ( getArgs, getProgName, getEnv )
  40 import System.IO
  41 import System.IO.Error
  42 import Data.List
  43 import Control.Concurrent
  44
  45 import qualified Data.ByteString.Lazy as B
  46 import qualified Data.Binary as Bin
  47 import qualified Data.Binary.Get as Bin
  48
  49 #if defined(mingw32_HOST_OS)
  50 -- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile
  51 import Foreign
  52 import Foreign.C
  53 #endif
  54
  55 #ifdef mingw32_HOST_OS
  56 import GHC.ConsoleHandler
  57 #else
  58 import System.Posix hiding (fdToHandle)
  59 #endif
  60
  61 #if defined(GLOB)
  62 import System.Process(runInteractiveCommand)
  63 import qualified System.Info(os)
  64 #endif
  65
  66 #if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)
  67 import System.Console.Terminfo as Terminfo
  68 #endif
  69
  70 -- -----------------------------------------------------------------------------
  71 -- Entry point
  72
  73 main :: IO ()
  74 main = do
  75   args <- getArgs
  76
  77   case getOpt Permute (flags ++ deprecFlags) args of
  78         (cli,_,[]) | FlagHelp `elem` cli -> do
  79            prog <- getProgramName
  80            bye (usageInfo (usageHeader prog) flags)
  81         (cli,_,[]) | FlagVersion `elem` cli ->
  82            bye ourCopyright
  83         (cli,nonopts,[]) ->
  84            case getVerbosity Normal cli of
  85            Right v -> runit v cli nonopts
  86            Left err -> die err
  87         (_,_,errors) -> do
  88            prog <- getProgramName
  89            die (concat errors ++ usageInfo (usageHeader prog) flags)
  90
  91 -- -----------------------------------------------------------------------------
  92 -- Command-line syntax
  93
  94 data Flag
  95   = FlagUser
  96   | FlagGlobal
  97   | FlagHelp
  98   | FlagVersion
  99   | FlagConfig FilePath
 100   | FlagGlobalConfig FilePath
 101   | FlagForce
 102   | FlagForceFiles
 103   | FlagAutoGHCiLibs
 104   | FlagExpandEnvVars
 105   | FlagSimpleOutput
 106   | FlagNamesOnly
 107   | FlagIgnoreCase
 108   | FlagNoUserDb
 109   | FlagVerbosity (Maybe String)
 110   deriving Eq
 111
 112 flags :: [OptDescr Flag]
 113 flags = [
 114   Option [] ["user"] (NoArg FlagUser)
 115         "use the current user's package database",
 116   Option [] ["global"] (NoArg FlagGlobal)
 117         "use the global package database",
 118   Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
 119         "use the specified package config file",
 120   Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
 121         "location of the global package config",
 122   Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
 123         "never read the user package database",
 124   Option [] ["force"] (NoArg FlagForce)
 125          "ignore missing dependencies, directories, and libraries",
 126   Option [] ["force-files"] (NoArg FlagForceFiles)
 127          "ignore missing directories and libraries only",
 128   Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
 129         "automatically build libs for GHCi (with register)",
 130   Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
 131         "expand environment variables (${name}-style) in input package descriptions",
 132   Option ['?'] ["help"] (NoArg FlagHelp)
 133         "display this help and exit",
 134   Option ['V'] ["version"] (NoArg FlagVersion)
 135         "output version information and exit",
 136   Option [] ["simple-output"] (NoArg FlagSimpleOutput)
 137         "print output in easy-to-parse format for some commands",
 138   Option [] ["names-only"] (NoArg FlagNamesOnly)
 139         "only print package names, not versions; can only be used with list --simple-output",
 140   Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
 141         "ignore case for substring matching",
 142   Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
 143         "verbosity level (0-2, default 1)"
 144   ]
 145
 146 data Verbosity = Silent | Normal | Verbose
 147     deriving (Show, Eq, Ord)
 148
 149 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
 150 getVerbosity v [] = Right v
 151 getVerbosity _ (FlagVerbosity Nothing    : fs) = getVerbosity Verbose fs
 152 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent  fs
 153 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal  fs
 154 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
 155 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
 156 getVerbosity v (_ : fs) = getVerbosity v fs
 157
 158 deprecFlags :: [OptDescr Flag]
 159 deprecFlags = [
 160         -- put deprecated flags here
 161   ]
 162
 163 ourCopyright :: String
 164 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
 165
 166 usageHeader :: String -> String
 167 usageHeader prog = substProg prog $
 168   "Usage:\n" ++
 169   "  $p init {path}\n" ++
 170   "    Create and initialise a package database at the location {path}.\n" ++
 171   "    Packages can be registered in the new database using the register\n" ++
 172   "    command with --package-conf={path}.  To use the new database with GHC,\n" ++
 173   "    use GHC's -package-conf flag.\n" ++
 174   "\n" ++
 175   "  $p register {filename | -}\n" ++
 176   "    Register the package using the specified installed package\n" ++
 177   "    description. The syntax for the latter is given in the $p\n" ++
 178   "    documentation.  The input file should be encoded in UTF-8.\n" ++
 179   "\n" ++
 180   "  $p update {filename | -}\n" ++
 181   "    Register the package, overwriting any other package with the\n" ++
 182   "    same name. The input file should be encoded in UTF-8.\n" ++
 183   "\n" ++
 184   "  $p unregister {pkg-id}\n" ++
 185   "    Unregister the specified package.\n" ++
 186   "\n" ++
 187   "  $p expose {pkg-id}\n" ++
 188   "    Expose the specified package.\n" ++
 189   "\n" ++
 190   "  $p hide {pkg-id}\n" ++
 191   "    Hide the specified package.\n" ++
 192   "\n" ++
 193   "  $p list [pkg]\n" ++
 194   "    List registered packages in the global database, and also the\n" ++
 195   "    user database if --user is given. If a package name is given\n" ++
 196   "    all the registered versions will be listed in ascending order.\n" ++
 197   "    Accepts the --simple-output flag.\n" ++
 198   "\n" ++
 199   "  $p dot\n" ++
 200   "    Generate a graph of the package dependencies in a form suitable\n" ++
 201   "    for input for the graphviz tools.  For example, to generate a PDF" ++
 202   "    of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
 203   "\n" ++
 204   "  $p find-module {module}\n" ++
 205   "    List registered packages exposing module {module} in the global\n" ++
 206   "    database, and also the user database if --user is given.\n" ++
 207   "    All the registered versions will be listed in ascending order.\n" ++
 208   "    Accepts the --simple-output flag.\n" ++
 209   "\n" ++
 210   "  $p latest {pkg-id}\n" ++
 211   "    Prints the highest registered version of a package.\n" ++
 212   "\n" ++
 213   "  $p check\n" ++
 214   "    Check the consistency of package depenencies and list broken packages.\n" ++
 215   "    Accepts the --simple-output flag.\n" ++
 216   "\n" ++
 217   "  $p describe {pkg}\n" ++
 218   "    Give the registered description for the specified package. The\n" ++
 219   "    description is returned in precisely the syntax required by $p\n" ++
 220   "    register.\n" ++
 221   "\n" ++
 222   "  $p field {pkg} {field}\n" ++
 223   "    Extract the specified field of the package description for the\n" ++
 224   "    specified package. Accepts comma-separated multiple fields.\n" ++
 225   "\n" ++
 226   "  $p dump\n" ++
 227   "    Dump the registered description for every package.  This is like\n" ++
 228   "    \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
 229   "    by tools that parse the results, rather than humans.  The output is\n" ++
 230   "    always encoded in UTF-8, regardless of the current locale.\n" ++
 231   "\n" ++
 232   "  $p recache\n" ++
 233   "    Regenerate the package database cache.  This command should only be\n" ++
 234   "    necessary if you added a package to the database by dropping a file\n" ++
 235   "    into the database directory manually.  By default, the global DB\n" ++
 236   "    is recached; to recache a different DB use --user or --package-conf\n" ++
 237   "    as appropriate.\n" ++
 238   "\n" ++
 239   " Substring matching is supported for {module} in find-module and\n" ++
 240   " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
 241   " open substring ends (prefix*, *suffix, *infix*).\n" ++
 242   "\n" ++
 243   "  When asked to modify a database (register, unregister, update,\n"++
 244   "  hide, expose, and also check), ghc-pkg modifies the global database by\n"++
 245   "  default.  Specifying --user causes it to act on the user database,\n"++
 246   "  or --package-conf can be used to act on another database\n"++
 247   "  entirely. When multiple of these options are given, the rightmost\n"++
 248   "  one is used as the database to act upon.\n"++
 249   "\n"++
 250   "  Commands that query the package database (list, tree, latest, describe,\n"++
 251   "  field) operate on the list of databases specified by the flags\n"++
 252   "  --user, --global, and --package-conf.  If none of these flags are\n"++
 253   "  given, the default is --global --user.\n"++
 254   "\n" ++
 255   " The following optional flags are also accepted:\n"
 256
 257 substProg :: String -> String -> String
 258 substProg _ [] = []
 259 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
 260 substProg prog (c:xs) = c : substProg prog xs
 261
 262 -- -----------------------------------------------------------------------------
 263 -- Do the business
 264
 265 data Force = NoForce | ForceFiles | ForceAll | CannotForce
 266   deriving (Eq,Ord)
 267
 268 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
 269
 270 runit :: Verbosity -> [Flag] -> [String] -> IO ()
 271 runit verbosity cli nonopts = do
 272   installSignalHandlers -- catch ^C and clean up
 273   prog <- getProgramName
 274   let
 275         force
 276           | FlagForce `elem` cli        = ForceAll
 277           | FlagForceFiles `elem` cli   = ForceFiles
 278           | otherwise                   = NoForce
 279         auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
 280         expand_env_vars= FlagExpandEnvVars `elem` cli
 281         splitFields fields = unfoldr splitComma (',':fields)
 282           where splitComma "" = Nothing
 283                 splitComma fs = Just $ break (==',') (tail fs)
 284
 285         substringCheck :: String -> Maybe (String -> Bool)
 286         substringCheck ""    = Nothing
 287         substringCheck "*"   = Just (const True)
 288         substringCheck [_]   = Nothing
 289         substringCheck (h:t) =
 290           case (h, init t, last t) of
 291             ('*',s,'*') -> Just (isInfixOf (f s) . f)
 292             ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
 293             ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
 294             _           -> Nothing
 295           where f | FlagIgnoreCase `elem` cli = map toLower
 296                   | otherwise                 = id
 297 #if defined(GLOB)
 298         glob x | System.Info.os=="mingw32" = do
 299           -- glob echoes its argument, after win32 filename globbing
 300           (_,o,_,_) <- runInteractiveCommand ("glob "++x)
 301           txt <- hGetContents o
 302           return (read txt)
 303         glob x | otherwise = return [x]
 304 #endif
 305   --
 306   -- first, parse the command
 307   case nonopts of
 308 #if defined(GLOB)
 309     -- dummy command to demonstrate usage and permit testing
 310     -- without messing things up; use glob to selectively enable
 311     -- windows filename globbing for file parameters
 312     -- register, update, FlagGlobalConfig, FlagConfig; others?
 313     ["glob", filename] -> do
 314         print filename
 315         glob filename >>= print
 316 #endif
 317     ["init", filename] ->
 318         initPackageDB filename verbosity cli
 319     ["register", filename] ->
 320         registerPackage filename verbosity cli
 321                         auto_ghci_libs expand_env_vars False force
 322     ["update", filename] ->
 323         registerPackage filename verbosity cli
 324                         auto_ghci_libs expand_env_vars True force
 325     ["unregister", pkgid_str] -> do
 326         pkgid <- readGlobPkgId pkgid_str
 327         unregisterPackage pkgid verbosity cli force
 328     ["expose", pkgid_str] -> do
 329         pkgid <- readGlobPkgId pkgid_str
 330         exposePackage pkgid verbosity cli force
 331     ["hide",   pkgid_str] -> do
 332         pkgid <- readGlobPkgId pkgid_str
 333         hidePackage pkgid verbosity cli force
 334     ["list"] -> do
 335         listPackages verbosity cli Nothing Nothing
 336     ["list", pkgid_str] ->
 337         case substringCheck pkgid_str of
 338           Nothing -> do pkgid <- readGlobPkgId pkgid_str
 339                         listPackages verbosity cli (Just (Id pkgid)) Nothing
 340           Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
 341     ["dot"] -> do
 342         showPackageDot verbosity cli
 343     ["find-module", moduleName] -> do
 344         let match = maybe (==moduleName) id (substringCheck moduleName)
 345         listPackages verbosity cli Nothing (Just match)
 346     ["latest", pkgid_str] -> do
 347         pkgid <- readGlobPkgId pkgid_str
 348         latestPackage verbosity cli pkgid
 349     ["describe", pkgid_str] ->
 350         case substringCheck pkgid_str of
 351           Nothing -> do pkgid <- readGlobPkgId pkgid_str
 352                         describePackage verbosity cli (Id pkgid)
 353           Just m -> describePackage verbosity cli (Substring pkgid_str m)
 354     ["field", pkgid_str, fields] ->
 355         case substringCheck pkgid_str of
 356           Nothing -> do pkgid <- readGlobPkgId pkgid_str
 357                         describeField verbosity cli (Id pkgid)
 358                                       (splitFields fields)
 359           Just m -> describeField verbosity cli (Substring pkgid_str m)
 360                                       (splitFields fields)
 361     ["check"] -> do
 362         checkConsistency verbosity cli
 363
 364     ["dump"] -> do
 365         dumpPackages verbosity cli
 366
 367     ["recache"] -> do
 368         recache verbosity cli
 369
 370     [] -> do
 371         die ("missing command\n" ++
 372                 usageInfo (usageHeader prog) flags)
 373     (_cmd:_) -> do
 374         die ("command-line syntax error\n" ++
 375                 usageInfo (usageHeader prog) flags)
 376
 377 parseCheck :: ReadP a a -> String -> String -> IO a
 378 parseCheck parser str what =
 379   case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
 380     [x] -> return x
 381     _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
 382
 383 readGlobPkgId :: String -> IO PackageIdentifier
 384 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
 385
 386 parseGlobPackageId :: ReadP r PackageIdentifier
 387 parseGlobPackageId =
 388   parse
 389      +++
 390   (do n <- parse
 391       _ <- string "-*"
 392       return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
 393
 394 -- globVersion means "all versions"
 395 globVersion :: Version
 396 globVersion = Version{ versionBranch=[], versionTags=["*"] }
 397
 398 -- -----------------------------------------------------------------------------
 399 -- Package databases
 400
 401 -- Some commands operate on a single database:
 402 --      register, unregister, expose, hide
 403 -- however these commands also check the union of the available databases
 404 -- in order to check consistency.  For example, register will check that
 405 -- dependencies exist before registering a package.
 406 --
 407 -- Some commands operate  on multiple databases, with overlapping semantics:
 408 --      list, describe, field
 409
 410 data PackageDB
 411   = PackageDB { location :: FilePath,
 412                 packages :: [InstalledPackageInfo] }
 413
 414 type PackageDBStack = [PackageDB]
 415         -- A stack of package databases.  Convention: head is the topmost
 416         -- in the stack.
 417
 418 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
 419 allPackagesInStack = concatMap packages
 420
 421 getPkgDatabases :: Verbosity
 422                 -> Bool    -- we are modifying, not reading
 423                 -> Bool    -- read caches, if available
 424                 -> [Flag]
 425                 -> IO (PackageDBStack,
 426                           -- the real package DB stack: [global,user] ++
 427                           -- DBs specified on the command line with -f.
 428                        Maybe FilePath,
 429                           -- which one to modify, if any
 430                        PackageDBStack)
 431                           -- the package DBs specified on the command
 432                           -- line, or [global,user] otherwise.  This
 433                           -- is used as the list of package DBs for
 434                           -- commands that just read the DB, such as 'list'.
 435
 436 getPkgDatabases verbosity modify use_cache my_flags = do
 437   -- first we determine the location of the global package config.  On Windows,
 438   -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
 439   -- location is passed to the binary using the --global-config flag by the
 440   -- wrapper script.
 441   let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
 442   global_conf <-
 443      case [ f | FlagGlobalConfig f <- my_flags ] of
 444         [] -> do mb_dir <- getLibDir
 445                  case mb_dir of
 446                    Nothing  -> die err_msg
 447                    Just dir -> do
 448                      r <- lookForPackageDBIn dir
 449                      case r of
 450                        Nothing -> die ("Can't find package database in " ++ dir)
 451                        Just path -> return path
 452         fs -> return (last fs)
 453
 454   let no_user_db = FlagNoUserDb `elem` my_flags
 455
 456   -- get the location of the user package database, and create it if necessary
 457   -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
 458   e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
 459
 460   mb_user_conf <-
 461      if no_user_db then return Nothing else
 462      case e_appdir of
 463        Left _    -> return Nothing
 464        Right appdir -> do
 465          let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
 466              dir = appdir </> subdir
 467          r <- lookForPackageDBIn dir
 468          case r of
 469            Nothing -> return (Just (dir </> "package.conf.d", False))
 470            Just f  -> return (Just (f, True))
 471
 472   -- If the user database doesn't exist, and this command isn't a
 473   -- "modify" command, then we won't attempt to create or use it.
 474   let sys_databases
 475         | Just (user_conf,user_exists) <- mb_user_conf,
 476           modify || user_exists = [user_conf, global_conf]
 477         | otherwise             = [global_conf]
 478
 479   e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
 480   let env_stack =
 481         case e_pkg_path of
 482                 Left  _ -> sys_databases
 483                 Right path
 484                   | last cs == ""  -> init cs ++ sys_databases
 485                   | otherwise      -> cs
 486                   where cs = parseSearchPath path
 487
 488         -- The "global" database is always the one at the bottom of the stack.
 489         -- This is the database we modify by default.
 490       virt_global_conf = last env_stack
 491
 492   let db_flags = [ f | Just f <- map is_db_flag my_flags ]
 493          where is_db_flag FlagUser
 494                       | Just (user_conf, _user_exists) <- mb_user_conf
 495                       = Just user_conf
 496                is_db_flag FlagGlobal     = Just virt_global_conf
 497                is_db_flag (FlagConfig f) = Just f
 498                is_db_flag _              = Nothing
 499
 500   let flag_db_names | null db_flags = env_stack
 501                     | otherwise     = reverse (nub db_flags)
 502
 503   -- For a "modify" command, treat all the databases as
 504   -- a stack, where we are modifying the top one, but it
 505   -- can refer to packages in databases further down the
 506   -- stack.
 507
 508   -- -f flags on the command line add to the database
 509   -- stack, unless any of them are present in the stack
 510   -- already.
 511   let final_stack = filter (`notElem` env_stack)
 512                      [ f | FlagConfig f <- reverse my_flags ]
 513                      ++ env_stack
 514
 515   -- the database we actually modify is the one mentioned
 516   -- rightmost on the command-line.
 517   let to_modify
 518         | not modify    = Nothing
 519         | null db_flags = Just virt_global_conf
 520         | otherwise     = Just (last db_flags)
 521
 522   db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
 523
 524   let flag_db_stack = [ db | db_name <- flag_db_names,
 525                         db <- db_stack, location db == db_name ]
 526
 527   return (db_stack, to_modify, flag_db_stack)
 528
 529
 530 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
 531 lookForPackageDBIn dir = do
 532   let path_dir = dir </> "package.conf.d"
 533   exists_dir <- doesDirectoryExist path_dir
 534   if exists_dir then return (Just path_dir) else do
 535   let path_file = dir </> "package.conf"
 536   exists_file <- doesFileExist path_file
 537   if exists_file then return (Just path_file) else return Nothing
 538
 539 readParseDatabase :: Verbosity
 540                   -> Maybe (FilePath,Bool)
 541                   -> Bool -- use cache
 542                   -> FilePath
 543                   -> IO PackageDB
 544
 545 readParseDatabase verbosity mb_user_conf use_cache path
 546   -- the user database (only) is allowed to be non-existent
 547   | Just (user_conf,False) <- mb_user_conf, path == user_conf
 548   = return PackageDB { location = path, packages = [] }
 549   | otherwise
 550   = do e <- tryIO $ getDirectoryContents path
 551        case e of
 552          Left _   -> do
 553               pkgs <- parseMultiPackageConf verbosity path
 554               return PackageDB{ location = path, packages = pkgs }
 555          Right fs
 556            | not use_cache -> ignore_cache
 557            | otherwise -> do
 558               let cache = path </> cachefilename
 559               tdir     <- getModificationTime path
 560               e_tcache <- tryIO $ getModificationTime cache
 561               case e_tcache of
 562                 Left ex -> do
 563                      when (verbosity > Normal) $
 564                         warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
 565                      ignore_cache
 566                 Right tcache
 567                   | tcache >= tdir -> do
 568                      when (verbosity > Normal) $
 569                         putStrLn ("using cache: " ++ cache)
 570                      pkgs <- myReadBinPackageDB cache
 571                      let pkgs' = map convertPackageInfoIn pkgs
 572                      return PackageDB { location = path, packages = pkgs' }
 573                   | otherwise -> do
 574                      when (verbosity >= Normal) $ do
 575                         warn ("WARNING: cache is out of date: " ++ cache)
 576                         warn "  use 'ghc-pkg recache' to fix."
 577                      ignore_cache
 578             where
 579                  ignore_cache = do
 580                      let confs = filter (".conf" `isSuffixOf`) fs
 581                      pkgs <- mapM (parseSingletonPackageConf verbosity) $
 582                                    map (path </>) confs
 583                      return PackageDB { location = path, packages = pkgs }
 584
 585 -- read the package.cache file strictly, to work around a problem with
 586 -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
 587 -- after it has been completely read, leading to a sharing violation
 588 -- later.
 589 myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
 590 myReadBinPackageDB filepath = do
 591   h <- openBinaryFile filepath ReadMode
 592   sz <- hFileSize h
 593   b <- B.hGet h (fromIntegral sz)
 594   hClose h
 595   return $ Bin.runGet Bin.get b
 596
 597 parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
 598 parseMultiPackageConf verbosity file = do
 599   when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
 600   str <- readUTF8File file
 601   let pkgs = map convertPackageInfoIn $ read str
 602   Exception.evaluate pkgs
 603     `catchError` \e->
 604        die ("error while parsing " ++ file ++ ": " ++ show e)
 605
 606 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
 607 parseSingletonPackageConf verbosity file = do
 608   when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
 609   readUTF8File file >>= parsePackageInfo
 610
 611 cachefilename :: FilePath
 612 cachefilename = "package.cache"
 613
 614 -- -----------------------------------------------------------------------------
 615 -- Creating a new package DB
 616
 617 initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
 618 initPackageDB filename verbosity _flags = do
 619   let eexist = die ("cannot create: " ++ filename ++ " already exists")
 620   b1 <- doesFileExist filename
 621   when b1 eexist
 622   b2 <- doesDirectoryExist filename
 623   when b2 eexist
 624   changeDB verbosity [] PackageDB{ location = filename, packages = [] }
 625
 626 -- -----------------------------------------------------------------------------
 627 -- Registering
 628
 629 registerPackage :: FilePath
 630                 -> Verbosity
 631                 -> [Flag]
 632                 -> Bool              -- auto_ghci_libs
 633                 -> Bool              -- expand_env_vars
 634                 -> Bool              -- update
 635                 -> Force
 636                 -> IO ()
 637 registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
 638   (db_stack, Just to_modify, _flag_dbs) <-
 639       getPkgDatabases verbosity True True my_flags
 640
 641   let
 642         db_to_operate_on = my_head "register" $
 643                            filter ((== to_modify).location) db_stack
 644   --
 645   when (auto_ghci_libs && verbosity >= Silent) $
 646     warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
 647   --
 648   s <-
 649     case input of
 650       "-" -> do
 651         when (verbosity >= Normal) $
 652             putStr "Reading package info from stdin ... "
 653         -- fix the encoding to UTF-8, since this is an interchange format
 654         hSetEncoding stdin utf8
 655         getContents
 656       f   -> do
 657         when (verbosity >= Normal) $
 658             putStr ("Reading package info from " ++ show f ++ " ... ")
 659         readUTF8File f
 660
 661   expanded <- if expand_env_vars then expandEnvVars s force
 662                                  else return s
 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     removeFileSafe 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     `catchIO` \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) || 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   -- fix the encoding to UTF-8, since this is an interchange format
 950   hSetEncoding stdout utf8
 951   mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
 952
 953 -- PackageId is can have globVersion for the version
 954 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
 955 findPackages db_stack pkgarg
 956   = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
 957
 958 findPackagesByDB :: PackageDBStack -> PackageArg
 959                  -> IO [(PackageDB, [InstalledPackageInfo])]
 960 findPackagesByDB db_stack pkgarg
 961   = case [ (db, matched)
 962          | db <- db_stack,
 963            let matched = filter (pkgarg `matchesPkg`) (packages db),
 964            not (null matched) ] of
 965         [] -> die ("cannot find package " ++ pkg_msg pkgarg)
 966         ps -> return ps
 967   where
 968         pkg_msg (Id pkgid)           = display pkgid
 969         pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
 970
 971 matches :: PackageIdentifier -> PackageIdentifier -> Bool
 972 pid `matches` pid'
 973   = (pkgName pid == pkgName pid')
 974     && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
 975
 976 realVersion :: PackageIdentifier -> Bool
 977 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
 978   -- when versionBranch == [], this is a glob
 979
 980 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
 981 (Id pid)        `matchesPkg` pkg = pid `matches` sourcePackageId pkg
 982 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
 983
 984 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
 985 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
 986
 987 -- -----------------------------------------------------------------------------
 988 -- Field
 989
 990 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
 991 describeField verbosity my_flags pkgarg fields = do
 992   (_, _, flag_db_stack) <-
 993       getPkgDatabases verbosity False True{-use cache-} my_flags
 994   fns <- toFields fields
 995   ps <- findPackages flag_db_stack pkgarg
 996   let top_dir = takeDirectory (location (last flag_db_stack))
 997   mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
 998   where toFields [] = return []
 999         toFields (f:fs) = case toField f of
1000             Nothing -> die ("unknown field: " ++ f)
1001             Just fn -> do fns <- toFields fs
1002                           return (fn:fns)
1003         selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1004
1005 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
1006 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
1007 -- with the current topdir (obtained from the -B option).
1008 mungePackagePaths top_dir ps = map munge_pkg ps
1009   where
1010   munge_pkg p = p{ importDirs        = munge_paths (importDirs p),
1011                    includeDirs       = munge_paths (includeDirs p),
1012                    libraryDirs       = munge_paths (libraryDirs p),
1013                    frameworkDirs     = munge_paths (frameworkDirs p),
1014                    haddockInterfaces = munge_paths (haddockInterfaces p),
1015                    haddockHTMLs      = munge_paths (haddockHTMLs p)
1016                  }
1017
1018   munge_paths = map munge_path
1019
1020   munge_path p
1021    | Just p' <- maybePrefixMatch "$topdir"     p =            top_dir ++ p'
1022    | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1023    | otherwise                               = p
1024
1025   toHttpPath p = "file:///" ++ p
1026
1027 maybePrefixMatch :: String -> String -> Maybe String
1028 maybePrefixMatch []    rest = Just rest
1029 maybePrefixMatch (_:_) []   = Nothing
1030 maybePrefixMatch (p:pat) (r:rest)
1031   | p == r    = maybePrefixMatch pat rest
1032   | otherwise = Nothing
1033
1034 toField :: String -> Maybe (InstalledPackageInfo -> String)
1035 -- backwards compatibility:
1036 toField "import_dirs"     = Just $ strList . importDirs
1037 toField "source_dirs"     = Just $ strList . importDirs
1038 toField "library_dirs"    = Just $ strList . libraryDirs
1039 toField "hs_libraries"    = Just $ strList . hsLibraries
1040 toField "extra_libraries" = Just $ strList . extraLibraries
1041 toField "include_dirs"    = Just $ strList . includeDirs
1042 toField "c_includes"      = Just $ strList . includes
1043 toField "package_deps"    = Just $ strList . map display. depends
1044 toField "extra_cc_opts"   = Just $ strList . ccOptions
1045 toField "extra_ld_opts"   = Just $ strList . ldOptions
1046 toField "framework_dirs"  = Just $ strList . frameworkDirs
1047 toField "extra_frameworks"= Just $ strList . frameworks
1048 toField s                 = showInstalledPackageInfoField s
1049
1050 strList :: [String] -> String
1051 strList = show
1052
1053
1054 -- -----------------------------------------------------------------------------
1055 -- Check: Check consistency of installed packages
1056
1057 checkConsistency :: Verbosity -> [Flag] -> IO ()
1058 checkConsistency verbosity my_flags = do
1059   (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1060          -- check behaves like modify for the purposes of deciding which
1061          -- databases to use, because ordering is important.
1062
1063   let simple_output = FlagSimpleOutput `elem` my_flags
1064
1065   let pkgs = allPackagesInStack db_stack
1066
1067       checkPackage p = do
1068          (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
1069          if null es
1070             then do when (not simple_output) $ do
1071                       _ <- reportValidateErrors [] ws "" Nothing
1072                       return ()
1073                     return []
1074             else do
1075               when (not simple_output) $ do
1076                   reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1077                   _ <- reportValidateErrors es ws "  " 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   writeFileUtf8Atomic filename fileContents
1152     `catchIO` \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 type ValidateWarning = String
1165
1166 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1167
1168 instance Monad Validate where
1169    return a = V $ return (a, [], [])
1170    m >>= k = V $ do
1171       (a, es, ws) <- runValidate m
1172       (b, es', ws') <- runValidate (k a)
1173       return (b,es++es',ws++ws')
1174
1175 verror :: Force -> String -> Validate ()
1176 verror f s = V (return ((),[(f,s)],[]))
1177
1178 vwarn :: String -> Validate ()
1179 vwarn s = V (return ((),[],["Warning: " ++ s]))
1180
1181 liftIO :: IO a -> Validate a
1182 liftIO k = V (k >>= \a -> return (a,[],[]))
1183
1184 -- returns False if we should die
1185 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1186                      -> String -> Maybe Force -> IO Bool
1187 reportValidateErrors es ws prefix mb_force = do
1188   mapM_ (warn . (prefix++)) ws
1189   oks <- mapM report es
1190   return (and oks)
1191   where
1192     report (f,s)
1193       | Just force <- mb_force
1194       = if (force >= f)
1195            then do reportError (prefix ++ s ++ " (ignoring)")
1196                    return True
1197            else if f < CannotForce
1198                    then do reportError (prefix ++ s ++ " (use --force to override)")
1199                            return False
1200                    else do reportError err
1201                            return False
1202       | otherwise = do reportError err
1203                        return False
1204       where
1205              err = prefix ++ s
1206
1207 validatePackageConfig :: InstalledPackageInfo
1208                       -> PackageDBStack
1209                       -> Bool   -- auto-ghc-libs
1210                       -> Bool   -- update, or check
1211                       -> Force
1212                       -> IO ()
1213 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1214   (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1215   ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1216   when (not ok) $ exitWith (ExitFailure 1)
1217
1218 checkPackageConfig :: InstalledPackageInfo
1219                       -> PackageDBStack
1220                       -> Bool   -- auto-ghc-libs
1221                       -> Bool   -- update, or check
1222                       -> Validate ()
1223 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1224   checkInstalledPackageId pkg db_stack update
1225   checkPackageId pkg
1226   checkDuplicates db_stack pkg update
1227   mapM_ (checkDep db_stack) (depends pkg)
1228   checkDuplicateDepends (depends pkg)
1229   mapM_ (checkDir False "import-dirs")  (importDirs pkg)
1230   mapM_ (checkDir True  "library-dirs") (libraryDirs pkg)
1231   mapM_ (checkDir True  "include-dirs") (includeDirs pkg)
1232   checkModules pkg
1233   mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1234   -- ToDo: check these somehow?
1235   --    extra_libraries :: [String],
1236   --    c_includes      :: [String],
1237
1238 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1239                         -> Validate ()
1240 checkInstalledPackageId ipi db_stack update = do
1241   let ipid@(InstalledPackageId str) = installedPackageId ipi
1242   when (null str) $ verror CannotForce "missing id field"
1243   let dups = [ p | p <- allPackagesInStack db_stack,
1244                    installedPackageId p == ipid ]
1245   when (not update && not (null dups)) $
1246     verror CannotForce $
1247         "package(s) with this id already exist: " ++
1248          unwords (map (display.packageId) dups)
1249
1250 -- When the package name and version are put together, sometimes we can
1251 -- end up with a package id that cannot be parsed.  This will lead to
1252 -- difficulties when the user wants to refer to the package later, so
1253 -- we check that the package id can be parsed properly here.
1254 checkPackageId :: InstalledPackageInfo -> Validate ()
1255 checkPackageId ipi =
1256   let str = display (sourcePackageId ipi) in
1257   case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1258     [_] -> return ()
1259     []  -> verror CannotForce ("invalid package identifier: " ++ str)
1260     _   -> verror CannotForce ("ambiguous package identifier: " ++ str)
1261
1262 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1263 checkDuplicates db_stack pkg update = do
1264   let
1265         pkgid = sourcePackageId pkg
1266         pkgs  = packages (head db_stack)
1267   --
1268   -- Check whether this package id already exists in this DB
1269   --
1270   when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1271        verror CannotForce $
1272           "package " ++ display pkgid ++ " is already installed"
1273
1274   let
1275         uncasep = map toLower . display
1276         dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1277
1278   when (not update && not (null dups)) $ verror ForceAll $
1279         "Package names may be treated case-insensitively in the future.\n"++
1280         "Package " ++ display pkgid ++
1281         " overlaps with: " ++ unwords (map display dups)
1282
1283
1284 checkDir :: Bool -> String -> String -> Validate ()
1285 checkDir warn_only thisfield d
1286  | "$topdir"     `isPrefixOf` d = return ()
1287  | "$httptopdir" `isPrefixOf` d = return ()
1288         -- can't check these, because we don't know what $(http)topdir is
1289  | isRelative d = verror ForceFiles $
1290                      thisfield ++ ": " ++ d ++ " is a relative path"
1291         -- relative paths don't make any sense; #4134
1292  | otherwise = do
1293    there <- liftIO $ doesDirectoryExist d
1294    when (not there) $
1295        let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
1296        in
1297        if warn_only
1298           then vwarn msg
1299           else verror ForceFiles msg
1300
1301 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1302 checkDep db_stack pkgid
1303   | pkgid `elem` pkgids = return ()
1304   | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1305                                  ++ "\" doesn't exist")
1306   where
1307         all_pkgs = allPackagesInStack db_stack
1308         pkgids = map installedPackageId all_pkgs
1309
1310 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1311 checkDuplicateDepends deps
1312   | null dups = return ()
1313   | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1314                                      unwords (map display dups))
1315   where
1316        dups = [ p | (p:_:_) <- group (sort deps) ]
1317
1318 checkHSLib :: [String] -> Bool -> String -> Validate ()
1319 checkHSLib dirs auto_ghci_libs lib = do
1320   let batch_lib_file = "lib" ++ lib ++ ".a"
1321   m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1322   case m of
1323     Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1324                                    " on library path")
1325     Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs
1326
1327 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1328 doesFileExistOnPath file path = go path
1329   where go []     = return Nothing
1330         go (p:ps) = do b <- doesFileExistIn file p
1331                        if b then return (Just p) else go ps
1332
1333 doesFileExistIn :: String -> String -> IO Bool
1334 doesFileExistIn lib d
1335  | "$topdir"     `isPrefixOf` d = return True
1336  | "$httptopdir" `isPrefixOf` d = return True
1337  | otherwise                = doesFileExist (d </> lib)
1338
1339 checkModules :: InstalledPackageInfo -> Validate ()
1340 checkModules pkg = do
1341   mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1342   where
1343     findModule modl = do
1344       -- there's no .hi file for GHC.Prim
1345       if modl == fromString "GHC.Prim" then return () else do
1346       let file = toFilePath modl <.> "hi"
1347       m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1348       when (isNothing m) $
1349          verror ForceFiles ("file " ++ file ++ " is missing")
1350
1351 checkGHCiLib :: String -> String -> String -> Bool -> IO ()
1352 checkGHCiLib batch_lib_dir batch_lib_file lib auto_build
1353   | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1354   | otherwise  = return ()
1355  where
1356     ghci_lib_file = lib <.> "o"
1357
1358 -- automatically build the GHCi version of a batch lib,
1359 -- using ld --whole-archive.
1360
1361 autoBuildGHCiLib :: String -> String -> String -> IO ()
1362 autoBuildGHCiLib dir batch_file ghci_file = do
1363   let ghci_lib_file  = dir ++ '/':ghci_file
1364       batch_lib_file = dir ++ '/':batch_file
1365   hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1366 #if defined(darwin_HOST_OS)
1367   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1368 #elif defined(mingw32_HOST_OS)
1369   execDir <- getLibDir
1370   r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1371 #else
1372   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1373 #endif
1374   when (r /= ExitSuccess) $ exitWith r
1375   hPutStrLn stderr (" done.")
1376
1377 -- -----------------------------------------------------------------------------
1378 -- Searching for modules
1379
1380 #if not_yet
1381
1382 findModules :: [FilePath] -> IO [String]
1383 findModules paths =
1384   mms <- mapM searchDir paths
1385   return (concat mms)
1386
1387 searchDir path prefix = do
1388   fs <- getDirectoryEntries path `catchIO` \_ -> return []
1389   searchEntries path prefix fs
1390
1391 searchEntries path prefix [] = return []
1392 searchEntries path prefix (f:fs)
1393   | looks_like_a_module  =  do
1394         ms <- searchEntries path prefix fs
1395         return (prefix `joinModule` f : ms)
1396   | looks_like_a_component  =  do
1397         ms <- searchDir (path </> f) (prefix `joinModule` f)
1398         ms' <- searchEntries path prefix fs
1399         return (ms ++ ms')
1400   | otherwise
1401         searchEntries path prefix fs
1402
1403   where
1404         (base,suffix) = splitFileExt f
1405         looks_like_a_module =
1406                 suffix `elem` haskell_suffixes &&
1407                 all okInModuleName base
1408         looks_like_a_component =
1409                 null suffix && all okInModuleName base
1410
1411 okInModuleName c
1412
1413 #endif
1414
1415 -- ---------------------------------------------------------------------------
1416 -- expanding environment variables in the package configuration
1417
1418 expandEnvVars :: String -> Force -> IO String
1419 expandEnvVars str0 force = go str0 ""
1420  where
1421    go "" acc = return $! reverse acc
1422    go ('$':'{':str) acc | (var, '}':rest) <- break close str
1423         = do value <- lookupEnvVar var
1424              go rest (reverse value ++ acc)
1425         where close c = c == '}' || c == '\n' -- don't span newlines
1426    go (c:str) acc
1427         = go str (c:acc)
1428
1429    lookupEnvVar :: String -> IO String
1430    lookupEnvVar nm =
1431         catchIO (System.Environment.getEnv nm)
1432            (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1433                                         show nm)
1434                       return "")
1435
1436 -----------------------------------------------------------------------------
1437
1438 getProgramName :: IO String
1439 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1440    where str `withoutSuffix` suff
1441             | suff `isSuffixOf` str = take (length str - length suff) str
1442             | otherwise             = str
1443
1444 bye :: String -> IO a
1445 bye s = putStr s >> exitWith ExitSuccess
1446
1447 die :: String -> IO a
1448 die = dieWith 1
1449
1450 dieWith :: Int -> String -> IO a
1451 dieWith ec s = do
1452   hFlush stdout
1453   prog <- getProgramName
1454   hPutStrLn stderr (prog ++ ": " ++ s)
1455   exitWith (ExitFailure ec)
1456
1457 dieOrForceAll :: Force -> String -> IO ()
1458 dieOrForceAll ForceAll s = ignoreError s
1459 dieOrForceAll _other s   = dieForcible s
1460
1461 warn :: String -> IO ()
1462 warn = reportError
1463
1464 ignoreError :: String -> IO ()
1465 ignoreError s = reportError (s ++ " (ignoring)")
1466
1467 reportError :: String -> IO ()
1468 reportError s = do hFlush stdout; hPutStrLn stderr s
1469
1470 dieForcible :: String -> IO ()
1471 dieForcible s = die (s ++ " (use --force to override)")
1472
1473 my_head :: String -> [a] -> a
1474 my_head s []      = error s
1475 my_head _ (x : _) = x
1476
1477 -----------------------------------------
1478 -- Cut and pasted from ghc/compiler/main/SysTools
1479
1480 #if defined(mingw32_HOST_OS)
1481 subst :: Char -> Char -> String -> String
1482 subst a b ls = map (\ x -> if x == a then b else x) ls
1483
1484 unDosifyPath :: FilePath -> FilePath
1485 unDosifyPath xs = subst '\\' '/' xs
1486
1487 getLibDir :: IO (Maybe String)
1488 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1489
1490 -- (getExecDir cmd) returns the directory in which the current
1491 --                  executable, which should be called 'cmd', is running
1492 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1493 -- you'll get "/a/b/c" back as the result
1494 getExecDir :: String -> IO (Maybe String)
1495 getExecDir cmd =
1496     getExecPath >>= maybe (return Nothing) removeCmdSuffix
1497     where initN n = reverse . drop n . reverse
1498           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1499
1500 getExecPath :: IO (Maybe String)
1501 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1502   where
1503     try_size size = allocaArray (fromIntegral size) $ \buf -> do
1504         ret <- c_GetModuleFileName nullPtr buf size
1505         case ret of
1506           0 -> return Nothing
1507           _ | ret < size -> fmap Just $ peekCWString buf
1508             | otherwise  -> try_size (size * 2)
1509
1510 foreign import stdcall unsafe "windows.h GetModuleFileNameW"
1511   c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1512 #else
1513 getLibDir :: IO (Maybe String)
1514 getLibDir = return Nothing
1515 #endif
1516
1517 -----------------------------------------
1518 -- Adapted from ghc/compiler/utils/Panic
1519
1520 installSignalHandlers :: IO ()
1521 installSignalHandlers = do
1522   threadid <- myThreadId
1523   let
1524       interrupt = Exception.throwTo threadid
1525                                     (Exception.ErrorCall "interrupted")
1526   --
1527 #if !defined(mingw32_HOST_OS)
1528   _ <- installHandler sigQUIT (Catch interrupt) Nothing
1529   _ <- installHandler sigINT  (Catch interrupt) Nothing
1530   return ()
1531 #else
1532   -- GHC 6.3+ has support for console events on Windows
1533   -- NOTE: running GHCi under a bash shell for some reason requires
1534   -- you to press Ctrl-Break rather than Ctrl-C to provoke
1535   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
1536   -- why --SDM 17/12/2004
1537   let sig_handler ControlC = interrupt
1538       sig_handler Break    = interrupt
1539       sig_handler _        = return ()
1540
1541   _ <- installHandler (Catch sig_handler)
1542   return ()
1543 #endif
1544
1545 #if mingw32_HOST_OS || mingw32_TARGET_OS
1546 throwIOIO :: Exception.IOException -> IO a
1547 throwIOIO = Exception.throwIO
1548 #endif
1549
1550 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1551 catchIO = Exception.catch
1552
1553 catchError :: IO a -> (String -> IO a) -> IO a
1554 catchError io handler = io `Exception.catch` handler'
1555     where handler' (Exception.ErrorCall err) = handler err
1556
1557 tryIO :: IO a -> IO (Either Exception.IOException a)
1558 tryIO = Exception.try
1559
1560 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1561 writeBinaryFileAtomic targetFile obj =
1562   withFileAtomic targetFile $ \h -> do
1563      hSetBinaryMode h True
1564      B.hPutStr h (Bin.encode obj)
1565
1566 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1567 writeFileUtf8Atomic targetFile content =
1568   withFileAtomic targetFile $ \h -> do
1569      hSetEncoding h utf8
1570      hPutStr h content
1571
1572 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1573 -- to use text files here, rather than binary files.
1574 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1575 withFileAtomic targetFile write_content = do
1576   (newFile, newHandle) <- openNewFile targetDir template
1577   do  write_content newHandle
1578       hClose newHandle
1579 #if mingw32_HOST_OS || mingw32_TARGET_OS
1580       renameFile newFile targetFile
1581         -- If the targetFile exists then renameFile will fail
1582         `catchIO` \err -> do
1583           exists <- doesFileExist targetFile
1584           if exists
1585             then do removeFileSafe targetFile
1586                     -- Big fat hairy race condition
1587                     renameFile newFile targetFile
1588                     -- If the removeFile succeeds and the renameFile fails
1589                     -- then we've lost the atomic property.
1590             else throwIOIO err
1591 #else
1592       renameFile newFile targetFile
1593 #endif
1594    `Exception.onException` do hClose newHandle
1595                               removeFileSafe newFile
1596   where
1597     template = targetName <.> "tmp"
1598     targetDir | null targetDir_ = "."
1599               | otherwise       = targetDir_
1600     --TODO: remove this when takeDirectory/splitFileName is fixed
1601     --      to always return a valid dir
1602     (targetDir_,targetName) = splitFileName targetFile
1603
1604 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1605 openNewFile dir template = do
1606   -- this was added to System.IO in 6.12.1
1607   -- we must use this version because the version below opens the file
1608   -- in binary mode.
1609   openTempFileWithDefaultPermissions dir template
1610
1611 -- | The function splits the given string to substrings
1612 -- using 'isSearchPathSeparator'.
1613 parseSearchPath :: String -> [FilePath]
1614 parseSearchPath path = split path
1615   where
1616     split :: String -> [String]
1617     split s =
1618       case rest' of
1619         []     -> [chunk]
1620         _:rest -> chunk : split rest
1621       where
1622         chunk =
1623           case chunk' of
1624 #ifdef mingw32_HOST_OS
1625             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1626 #endif
1627             _                                 -> chunk'
1628
1629         (chunk', rest') = break isSearchPathSeparator s
1630
1631 readUTF8File :: FilePath -> IO String
1632 readUTF8File file = do
1633   h <- openFile file ReadMode
1634   -- fix the encoding to UTF-8
1635   hSetEncoding h utf8
1636   hGetContents h
1637
1638 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1639 removeFileSafe :: FilePath -> IO ()
1640 removeFileSafe fn =
1641   removeFile fn `catchIO` \ e ->
1642     when (not $ isDoesNotExistError e) $ ioError e