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   s <-
 646     case input of
 647       "-" -> do
 648         when (verbosity >= Normal) $
 649             putStr "Reading package info from stdin ... "
 650         -- fix the encoding to UTF-8, since this is an interchange format
 651         hSetEncoding stdin utf8
 652         getContents
 653       f   -> do
 654         when (verbosity >= Normal) $
 655             putStr ("Reading package info from " ++ show f ++ " ... ")
 656         readUTF8File f
 657
 658   expanded <- if expand_env_vars then expandEnvVars s force
 659                                  else return s
 660
 661   pkg <- parsePackageInfo expanded
 662   when (verbosity >= Normal) $
 663       putStrLn "done."
 664
 665   let truncated_stack = dropWhile ((/= to_modify).location) db_stack
 666   -- truncate the stack for validation, because we don't allow
 667   -- packages lower in the stack to refer to those higher up.
 668   validatePackageConfig pkg truncated_stack auto_ghci_libs update force
 669   let
 670      removes = [ RemovePackage p
 671                | p <- packages db_to_operate_on,
 672                  sourcePackageId p == sourcePackageId pkg ]
 673   --
 674   changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
 675
 676 parsePackageInfo
 677         :: String
 678         -> IO InstalledPackageInfo
 679 parsePackageInfo str =
 680   case parseInstalledPackageInfo str of
 681     ParseOk _warns ok -> return ok
 682     ParseFailed err -> case locatedErrorMsg err of
 683                            (Nothing, s) -> die s
 684                            (Just l, s) -> die (show l ++ ": " ++ s)
 685
 686 -- -----------------------------------------------------------------------------
 687 -- Making changes to a package database
 688
 689 data DBOp = RemovePackage InstalledPackageInfo
 690           | AddPackage    InstalledPackageInfo
 691           | ModifyPackage InstalledPackageInfo
 692
 693 changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
 694 changeDB verbosity cmds db = do
 695   let db' = updateInternalDB db cmds
 696   isfile <- doesFileExist (location db)
 697   if isfile
 698      then writeNewConfig verbosity (location db') (packages db')
 699      else do
 700        createDirectoryIfMissing True (location db)
 701        changeDBDir verbosity cmds db'
 702
 703 updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
 704 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
 705  where
 706   do_cmd pkgs (RemovePackage p) =
 707     filter ((/= installedPackageId p) . installedPackageId) pkgs
 708   do_cmd pkgs (AddPackage p) = p : pkgs
 709   do_cmd pkgs (ModifyPackage p) =
 710     do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
 711
 712
 713 changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
 714 changeDBDir verbosity cmds db = do
 715   mapM_ do_cmd cmds
 716   updateDBCache verbosity db
 717  where
 718   do_cmd (RemovePackage p) = do
 719     let file = location db </> display (installedPackageId p) <.> "conf"
 720     when (verbosity > Normal) $ putStrLn ("removing " ++ file)
 721     removeFileSafe file
 722   do_cmd (AddPackage p) = do
 723     let file = location db </> display (installedPackageId p) <.> "conf"
 724     when (verbosity > Normal) $ putStrLn ("writing " ++ file)
 725     writeFileUtf8Atomic file (showInstalledPackageInfo p)
 726   do_cmd (ModifyPackage p) =
 727     do_cmd (AddPackage p)
 728
 729 updateDBCache :: Verbosity -> PackageDB -> IO ()
 730 updateDBCache verbosity db = do
 731   let filename = location db </> cachefilename
 732   when (verbosity > Normal) $
 733       putStrLn ("writing cache " ++ filename)
 734   writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
 735     `catchIO` \e ->
 736       if isPermissionError e
 737       then die (filename ++ ": you don't have permission to modify this file")
 738       else ioError e
 739
 740 -- -----------------------------------------------------------------------------
 741 -- Exposing, Hiding, Unregistering are all similar
 742
 743 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 744 exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
 745
 746 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 747 hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
 748
 749 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 750 unregisterPackage = modifyPackage RemovePackage
 751
 752 modifyPackage
 753   :: (InstalledPackageInfo -> DBOp)
 754   -> PackageIdentifier
 755   -> Verbosity
 756   -> [Flag]
 757   -> Force
 758   -> IO ()
 759 modifyPackage fn pkgid verbosity my_flags force = do
 760   (db_stack, Just _to_modify, _flag_dbs) <-
 761       getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
 762
 763   (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
 764   let
 765       db_name = location db
 766       pkgs    = packages db
 767
 768       pids = map sourcePackageId ps
 769
 770       cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
 771       new_db = updateInternalDB db cmds
 772
 773       old_broken = brokenPackages (allPackagesInStack db_stack)
 774       rest_of_stack = filter ((/= db_name) . location) db_stack
 775       new_stack = new_db : rest_of_stack
 776       new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
 777       newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
 778   --
 779   when (not (null newly_broken)) $
 780       dieOrForceAll force ("unregistering " ++ display pkgid ++
 781            " would break the following packages: "
 782               ++ unwords (map display newly_broken))
 783
 784   changeDB verbosity cmds db
 785
 786 recache :: Verbosity -> [Flag] -> IO ()
 787 recache verbosity my_flags = do
 788   (db_stack, Just to_modify, _flag_dbs) <-
 789      getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
 790   let
 791         db_to_operate_on = my_head "recache" $
 792                            filter ((== to_modify).location) db_stack
 793   --
 794   changeDB verbosity [] db_to_operate_on
 795
 796 -- -----------------------------------------------------------------------------
 797 -- Listing packages
 798
 799 listPackages ::  Verbosity -> [Flag] -> Maybe PackageArg
 800              -> Maybe (String->Bool)
 801              -> IO ()
 802 listPackages verbosity my_flags mPackageName mModuleName = do
 803   let simple_output = FlagSimpleOutput `elem` my_flags
 804   (db_stack, _, flag_db_stack) <-
 805      getPkgDatabases verbosity False True{-use cache-} my_flags
 806
 807   let db_stack_filtered -- if a package is given, filter out all other packages
 808         | Just this <- mPackageName =
 809             [ db{ packages = filter (this `matchesPkg`) (packages db) }
 810             | db <- flag_db_stack ]
 811         | Just match <- mModuleName = -- packages which expose mModuleName
 812             [ db{ packages = filter (match `exposedInPkg`) (packages db) }
 813             | db <- flag_db_stack ]
 814         | otherwise = flag_db_stack
 815
 816       db_stack_sorted
 817           = [ db{ packages = sort_pkgs (packages db) }
 818             | db <- db_stack_filtered ]
 819           where sort_pkgs = sortBy cmpPkgIds
 820                 cmpPkgIds pkg1 pkg2 =
 821                    case pkgName p1 `compare` pkgName p2 of
 822                         LT -> LT
 823                         GT -> GT
 824                         EQ -> pkgVersion p1 `compare` pkgVersion p2
 825                    where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
 826
 827       stack = reverse db_stack_sorted
 828
 829       match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
 830
 831       pkg_map = allPackagesInStack db_stack
 832       broken = map sourcePackageId (brokenPackages pkg_map)
 833
 834       show_normal PackageDB{ location = db_name, packages = pkg_confs } =
 835           hPutStrLn stdout $ unlines ((db_name ++ ":") : map ("    " ++) pp_pkgs)
 836            where
 837                  pp_pkgs = map pp_pkg pkg_confs
 838                  pp_pkg p
 839                    | sourcePackageId p `elem` broken = printf "{%s}" doc
 840                    | exposed p = doc
 841                    | otherwise = printf "(%s)" doc
 842                    where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
 843                              | otherwise            = pkg
 844                           where
 845                           InstalledPackageId ipid = installedPackageId p
 846                           pkg = display (sourcePackageId p)
 847
 848       show_simple = simplePackageList my_flags . allPackagesInStack
 849
 850   when (not (null broken) && not simple_output && verbosity /= Silent) $ do
 851      prog <- getProgramName
 852      warn ("WARNING: there are broken packages.  Run '" ++ prog ++ " check' for more details.")
 853
 854   if simple_output then show_simple stack else do
 855
 856 #if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
 857   mapM_ show_normal stack
 858 #else
 859   let
 860      show_colour withF db =
 861          mconcat $ map (<#> termText "\n") $
 862              (termText (location db) :
 863                 map (termText "   " <#>) (map pp_pkg (packages db)))
 864         where
 865                  pp_pkg p
 866                    | sourcePackageId p `elem` broken = withF Red  doc
 867                    | exposed p                       = doc
 868                    | otherwise                       = withF Blue doc
 869                    where doc | verbosity >= Verbose
 870                              = termText (printf "%s (%s)" pkg ipid)
 871                              | otherwise
 872                              = termText pkg
 873                           where
 874                           InstalledPackageId ipid = installedPackageId p
 875                           pkg = display (sourcePackageId p)
 876
 877   is_tty <- hIsTerminalDevice stdout
 878   if not is_tty
 879      then mapM_ show_normal stack
 880      else do tty <- Terminfo.setupTermFromEnv
 881              case Terminfo.getCapability tty withForegroundColor of
 882                  Nothing -> mapM_ show_normal stack
 883                  Just w  -> runTermOutput tty $ mconcat $
 884                                                 map (show_colour w) stack
 885 #endif
 886
 887 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
 888 simplePackageList my_flags pkgs = do
 889    let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
 890                                                   else display
 891        strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
 892    when (not (null pkgs)) $
 893       hPutStrLn stdout $ concat $ intersperse " " strs
 894
 895 showPackageDot :: Verbosity -> [Flag] -> IO ()
 896 showPackageDot verbosity myflags = do
 897   (_, _, flag_db_stack) <-
 898       getPkgDatabases verbosity False True{-use cache-} myflags
 899
 900   let all_pkgs = allPackagesInStack flag_db_stack
 901       ipix  = PackageIndex.fromList all_pkgs
 902
 903   putStrLn "digraph {"
 904   let quote s = '"':s ++ "\""
 905   mapM_ putStrLn [ quote from ++ " -> " ++ quote to
 906                  | p <- all_pkgs,
 907                    let from = display (sourcePackageId p),
 908                    depid <- depends p,
 909                    Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
 910                    let to = display (sourcePackageId dep)
 911                  ]
 912   putStrLn "}"
 913
 914 -- -----------------------------------------------------------------------------
 915 -- Prints the highest (hidden or exposed) version of a package
 916
 917 latestPackage ::  Verbosity -> [Flag] -> PackageIdentifier -> IO ()
 918 latestPackage verbosity my_flags pkgid = do
 919   (_, _, flag_db_stack) <-
 920      getPkgDatabases verbosity False True{-use cache-} my_flags
 921
 922   ps <- findPackages flag_db_stack (Id pkgid)
 923   show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
 924   where
 925     show_pkg [] = die "no matches"
 926     show_pkg pids = hPutStrLn stdout (display (last pids))
 927
 928 -- -----------------------------------------------------------------------------
 929 -- Describe
 930
 931 describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
 932 describePackage verbosity my_flags pkgarg = do
 933   (_, _, flag_db_stack) <-
 934       getPkgDatabases verbosity False True{-use cache-} my_flags
 935   ps <- findPackages flag_db_stack pkgarg
 936   doDump ps
 937
 938 dumpPackages :: Verbosity -> [Flag] -> IO ()
 939 dumpPackages verbosity my_flags = do
 940   (_, _, flag_db_stack) <-
 941      getPkgDatabases verbosity False True{-use cache-} my_flags
 942   doDump (allPackagesInStack flag_db_stack)
 943
 944 doDump :: [InstalledPackageInfo] -> IO ()
 945 doDump pkgs = do
 946   -- fix the encoding to UTF-8, since this is an interchange format
 947   hSetEncoding stdout utf8
 948   mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
 949
 950 -- PackageId is can have globVersion for the version
 951 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
 952 findPackages db_stack pkgarg
 953   = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
 954
 955 findPackagesByDB :: PackageDBStack -> PackageArg
 956                  -> IO [(PackageDB, [InstalledPackageInfo])]
 957 findPackagesByDB db_stack pkgarg
 958   = case [ (db, matched)
 959          | db <- db_stack,
 960            let matched = filter (pkgarg `matchesPkg`) (packages db),
 961            not (null matched) ] of
 962         [] -> die ("cannot find package " ++ pkg_msg pkgarg)
 963         ps -> return ps
 964   where
 965         pkg_msg (Id pkgid)           = display pkgid
 966         pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
 967
 968 matches :: PackageIdentifier -> PackageIdentifier -> Bool
 969 pid `matches` pid'
 970   = (pkgName pid == pkgName pid')
 971     && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
 972
 973 realVersion :: PackageIdentifier -> Bool
 974 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
 975   -- when versionBranch == [], this is a glob
 976
 977 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
 978 (Id pid)        `matchesPkg` pkg = pid `matches` sourcePackageId pkg
 979 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
 980
 981 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
 982 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
 983
 984 -- -----------------------------------------------------------------------------
 985 -- Field
 986
 987 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
 988 describeField verbosity my_flags pkgarg fields = do
 989   (_, _, flag_db_stack) <-
 990       getPkgDatabases verbosity False True{-use cache-} my_flags
 991   fns <- toFields fields
 992   ps <- findPackages flag_db_stack pkgarg
 993   let top_dir = takeDirectory (location (last flag_db_stack))
 994   mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
 995   where toFields [] = return []
 996         toFields (f:fs) = case toField f of
 997             Nothing -> die ("unknown field: " ++ f)
 998             Just fn -> do fns <- toFields fs
 999                           return (fn:fns)
1000         selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
1001
1002 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
1003 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
1004 -- with the current topdir (obtained from the -B option).
1005 mungePackagePaths top_dir ps = map munge_pkg ps
1006   where
1007   munge_pkg p = p{ importDirs        = munge_paths (importDirs p),
1008                    includeDirs       = munge_paths (includeDirs p),
1009                    libraryDirs       = munge_paths (libraryDirs p),
1010                    frameworkDirs     = munge_paths (frameworkDirs p),
1011                    haddockInterfaces = munge_paths (haddockInterfaces p),
1012                    haddockHTMLs      = munge_paths (haddockHTMLs p)
1013                  }
1014
1015   munge_paths = map munge_path
1016
1017   munge_path p
1018    | Just p' <- maybePrefixMatch "$topdir"     p =            top_dir ++ p'
1019    | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
1020    | otherwise                               = p
1021
1022   toHttpPath p = "file:///" ++ p
1023
1024 maybePrefixMatch :: String -> String -> Maybe String
1025 maybePrefixMatch []    rest = Just rest
1026 maybePrefixMatch (_:_) []   = Nothing
1027 maybePrefixMatch (p:pat) (r:rest)
1028   | p == r    = maybePrefixMatch pat rest
1029   | otherwise = Nothing
1030
1031 toField :: String -> Maybe (InstalledPackageInfo -> String)
1032 -- backwards compatibility:
1033 toField "import_dirs"     = Just $ strList . importDirs
1034 toField "source_dirs"     = Just $ strList . importDirs
1035 toField "library_dirs"    = Just $ strList . libraryDirs
1036 toField "hs_libraries"    = Just $ strList . hsLibraries
1037 toField "extra_libraries" = Just $ strList . extraLibraries
1038 toField "include_dirs"    = Just $ strList . includeDirs
1039 toField "c_includes"      = Just $ strList . includes
1040 toField "package_deps"    = Just $ strList . map display. depends
1041 toField "extra_cc_opts"   = Just $ strList . ccOptions
1042 toField "extra_ld_opts"   = Just $ strList . ldOptions
1043 toField "framework_dirs"  = Just $ strList . frameworkDirs
1044 toField "extra_frameworks"= Just $ strList . frameworks
1045 toField s                 = showInstalledPackageInfoField s
1046
1047 strList :: [String] -> String
1048 strList = show
1049
1050
1051 -- -----------------------------------------------------------------------------
1052 -- Check: Check consistency of installed packages
1053
1054 checkConsistency :: Verbosity -> [Flag] -> IO ()
1055 checkConsistency verbosity my_flags = do
1056   (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
1057          -- check behaves like modify for the purposes of deciding which
1058          -- databases to use, because ordering is important.
1059
1060   let simple_output = FlagSimpleOutput `elem` my_flags
1061
1062   let pkgs = allPackagesInStack db_stack
1063
1064       checkPackage p = do
1065          (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True
1066          if null es
1067             then do when (not simple_output) $ do
1068                       _ <- reportValidateErrors [] ws "" Nothing
1069                       return ()
1070                     return []
1071             else do
1072               when (not simple_output) $ do
1073                   reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
1074                   _ <- reportValidateErrors es ws "  " Nothing
1075                   return ()
1076               return [p]
1077
1078   broken_pkgs <- concat `fmap` mapM checkPackage pkgs
1079
1080   let filterOut pkgs1 pkgs2 = filter not_in pkgs2
1081         where not_in p = sourcePackageId p `notElem` all_ps
1082               all_ps = map sourcePackageId pkgs1
1083
1084   let not_broken_pkgs = filterOut broken_pkgs pkgs
1085       (_, trans_broken_pkgs) = closure [] not_broken_pkgs
1086       all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
1087
1088   when (not (null all_broken_pkgs)) $ do
1089     if simple_output
1090       then simplePackageList my_flags all_broken_pkgs
1091       else do
1092        reportError ("\nThe following packages are broken, either because they have a problem\n"++
1093                 "listed above, or because they depend on a broken package.")
1094        mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
1095
1096   when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
1097
1098
1099 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1100         -> ([InstalledPackageInfo], [InstalledPackageInfo])
1101 closure pkgs db_stack = go pkgs db_stack
1102  where
1103    go avail not_avail =
1104      case partition (depsAvailable avail) not_avail of
1105         ([],        not_avail') -> (avail, not_avail')
1106         (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
1107
1108    depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
1109                  -> Bool
1110    depsAvailable pkgs_ok pkg = null dangling
1111         where dangling = filter (`notElem` pids) (depends pkg)
1112               pids = map installedPackageId pkgs_ok
1113
1114         -- we want mutually recursive groups of package to show up
1115         -- as broken. (#1750)
1116
1117 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
1118 brokenPackages pkgs = snd (closure [] pkgs)
1119
1120 -- -----------------------------------------------------------------------------
1121 -- Manipulating package.conf files
1122
1123 type InstalledPackageInfoString = InstalledPackageInfo_ String
1124
1125 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
1126 convertPackageInfoOut
1127     (pkgconf@(InstalledPackageInfo { exposedModules = e,
1128                                      hiddenModules = h })) =
1129         pkgconf{ exposedModules = map display e,
1130                  hiddenModules  = map display h }
1131
1132 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
1133 convertPackageInfoIn
1134     (pkgconf@(InstalledPackageInfo { exposedModules = e,
1135                                      hiddenModules = h })) =
1136         pkgconf{ exposedModules = map convert e,
1137                  hiddenModules  = map convert h }
1138     where convert = fromJust . simpleParse
1139
1140 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
1141 writeNewConfig verbosity filename ipis = do
1142   when (verbosity >= Normal) $
1143       hPutStr stdout "Writing new package config file... "
1144   createDirectoryIfMissing True $ takeDirectory filename
1145   let shown = concat $ intersperse ",\n "
1146                      $ map (show . convertPackageInfoOut) ipis
1147       fileContents = "[" ++ shown ++ "\n]"
1148   writeFileUtf8Atomic filename fileContents
1149     `catchIO` \e ->
1150       if isPermissionError e
1151       then die (filename ++ ": you don't have permission to modify this file")
1152       else ioError e
1153   when (verbosity >= Normal) $
1154       hPutStrLn stdout "done."
1155
1156 -----------------------------------------------------------------------------
1157 -- Sanity-check a new package config, and automatically build GHCi libs
1158 -- if requested.
1159
1160 type ValidateError   = (Force,String)
1161 type ValidateWarning = String
1162
1163 newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
1164
1165 instance Monad Validate where
1166    return a = V $ return (a, [], [])
1167    m >>= k = V $ do
1168       (a, es, ws) <- runValidate m
1169       (b, es', ws') <- runValidate (k a)
1170       return (b,es++es',ws++ws')
1171
1172 verror :: Force -> String -> Validate ()
1173 verror f s = V (return ((),[(f,s)],[]))
1174
1175 vwarn :: String -> Validate ()
1176 vwarn s = V (return ((),[],["Warning: " ++ s]))
1177
1178 liftIO :: IO a -> Validate a
1179 liftIO k = V (k >>= \a -> return (a,[],[]))
1180
1181 -- returns False if we should die
1182 reportValidateErrors :: [ValidateError] -> [ValidateWarning]
1183                      -> String -> Maybe Force -> IO Bool
1184 reportValidateErrors es ws prefix mb_force = do
1185   mapM_ (warn . (prefix++)) ws
1186   oks <- mapM report es
1187   return (and oks)
1188   where
1189     report (f,s)
1190       | Just force <- mb_force
1191       = if (force >= f)
1192            then do reportError (prefix ++ s ++ " (ignoring)")
1193                    return True
1194            else if f < CannotForce
1195                    then do reportError (prefix ++ s ++ " (use --force to override)")
1196                            return False
1197                    else do reportError err
1198                            return False
1199       | otherwise = do reportError err
1200                        return False
1201       where
1202              err = prefix ++ s
1203
1204 validatePackageConfig :: InstalledPackageInfo
1205                       -> PackageDBStack
1206                       -> Bool   -- auto-ghc-libs
1207                       -> Bool   -- update, or check
1208                       -> Force
1209                       -> IO ()
1210 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
1211   (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
1212   ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
1213   when (not ok) $ exitWith (ExitFailure 1)
1214
1215 checkPackageConfig :: InstalledPackageInfo
1216                       -> PackageDBStack
1217                       -> Bool   -- auto-ghc-libs
1218                       -> Bool   -- update, or check
1219                       -> Validate ()
1220 checkPackageConfig pkg db_stack auto_ghci_libs update = do
1221   checkInstalledPackageId pkg db_stack update
1222   checkPackageId pkg
1223   checkDuplicates db_stack pkg update
1224   mapM_ (checkDep db_stack) (depends pkg)
1225   checkDuplicateDepends (depends pkg)
1226   mapM_ (checkDir False "import-dirs")  (importDirs pkg)
1227   mapM_ (checkDir True  "library-dirs") (libraryDirs pkg)
1228   mapM_ (checkDir True  "include-dirs") (includeDirs pkg)
1229   checkModules pkg
1230   mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
1231   -- ToDo: check these somehow?
1232   --    extra_libraries :: [String],
1233   --    c_includes      :: [String],
1234
1235 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1236                         -> Validate ()
1237 checkInstalledPackageId ipi db_stack update = do
1238   let ipid@(InstalledPackageId str) = installedPackageId ipi
1239   when (null str) $ verror CannotForce "missing id field"
1240   let dups = [ p | p <- allPackagesInStack db_stack,
1241                    installedPackageId p == ipid ]
1242   when (not update && not (null dups)) $
1243     verror CannotForce $
1244         "package(s) with this id already exist: " ++
1245          unwords (map (display.packageId) dups)
1246
1247 -- When the package name and version are put together, sometimes we can
1248 -- end up with a package id that cannot be parsed.  This will lead to
1249 -- difficulties when the user wants to refer to the package later, so
1250 -- we check that the package id can be parsed properly here.
1251 checkPackageId :: InstalledPackageInfo -> Validate ()
1252 checkPackageId ipi =
1253   let str = display (sourcePackageId ipi) in
1254   case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1255     [_] -> return ()
1256     []  -> verror CannotForce ("invalid package identifier: " ++ str)
1257     _   -> verror CannotForce ("ambiguous package identifier: " ++ str)
1258
1259 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1260 checkDuplicates db_stack pkg update = do
1261   let
1262         pkgid = sourcePackageId pkg
1263         pkgs  = packages (head db_stack)
1264   --
1265   -- Check whether this package id already exists in this DB
1266   --
1267   when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1268        verror CannotForce $
1269           "package " ++ display pkgid ++ " is already installed"
1270
1271   let
1272         uncasep = map toLower . display
1273         dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1274
1275   when (not update && not (null dups)) $ verror ForceAll $
1276         "Package names may be treated case-insensitively in the future.\n"++
1277         "Package " ++ display pkgid ++
1278         " overlaps with: " ++ unwords (map display dups)
1279
1280
1281 checkDir :: Bool -> String -> String -> Validate ()
1282 checkDir warn_only thisfield d
1283  | "$topdir"     `isPrefixOf` d = return ()
1284  | "$httptopdir" `isPrefixOf` d = return ()
1285         -- can't check these, because we don't know what $(http)topdir is
1286  | isRelative d = verror ForceFiles $
1287                      thisfield ++ ": " ++ d ++ " is a relative path"
1288         -- relative paths don't make any sense; #4134
1289  | otherwise = do
1290    there <- liftIO $ doesDirectoryExist d
1291    when (not there) $
1292        let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
1293        in
1294        if warn_only
1295           then vwarn msg
1296           else verror ForceFiles msg
1297
1298 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1299 checkDep db_stack pkgid
1300   | pkgid `elem` pkgids = return ()
1301   | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1302                                  ++ "\" doesn't exist")
1303   where
1304         all_pkgs = allPackagesInStack db_stack
1305         pkgids = map installedPackageId all_pkgs
1306
1307 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1308 checkDuplicateDepends deps
1309   | null dups = return ()
1310   | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1311                                      unwords (map display dups))
1312   where
1313        dups = [ p | (p:_:_) <- group (sort deps) ]
1314
1315 checkHSLib :: [String] -> Bool -> String -> Validate ()
1316 checkHSLib dirs auto_ghci_libs lib = do
1317   let batch_lib_file = "lib" ++ lib ++ ".a"
1318   m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1319   case m of
1320     Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1321                                    " on library path")
1322     Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs
1323
1324 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1325 doesFileExistOnPath file path = go path
1326   where go []     = return Nothing
1327         go (p:ps) = do b <- doesFileExistIn file p
1328                        if b then return (Just p) else go ps
1329
1330 doesFileExistIn :: String -> String -> IO Bool
1331 doesFileExistIn lib d
1332  | "$topdir"     `isPrefixOf` d = return True
1333  | "$httptopdir" `isPrefixOf` d = return True
1334  | otherwise                = doesFileExist (d </> lib)
1335
1336 checkModules :: InstalledPackageInfo -> Validate ()
1337 checkModules pkg = do
1338   mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1339   where
1340     findModule modl = do
1341       -- there's no .hi file for GHC.Prim
1342       if modl == fromString "GHC.Prim" then return () else do
1343       let file = toFilePath modl <.> "hi"
1344       m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1345       when (isNothing m) $
1346          verror ForceFiles ("file " ++ file ++ " is missing")
1347
1348 checkGHCiLib :: String -> String -> String -> Bool -> IO ()
1349 checkGHCiLib batch_lib_dir batch_lib_file lib auto_build
1350   | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1351   | otherwise  = return ()
1352  where
1353     ghci_lib_file = lib <.> "o"
1354
1355 -- automatically build the GHCi version of a batch lib,
1356 -- using ld --whole-archive.
1357
1358 autoBuildGHCiLib :: String -> String -> String -> IO ()
1359 autoBuildGHCiLib dir batch_file ghci_file = do
1360   let ghci_lib_file  = dir ++ '/':ghci_file
1361       batch_lib_file = dir ++ '/':batch_file
1362   hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1363 #if defined(darwin_HOST_OS)
1364   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1365 #elif defined(mingw32_HOST_OS)
1366   execDir <- getLibDir
1367   r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1368 #else
1369   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1370 #endif
1371   when (r /= ExitSuccess) $ exitWith r
1372   hPutStrLn stderr (" done.")
1373
1374 -- -----------------------------------------------------------------------------
1375 -- Searching for modules
1376
1377 #if not_yet
1378
1379 findModules :: [FilePath] -> IO [String]
1380 findModules paths =
1381   mms <- mapM searchDir paths
1382   return (concat mms)
1383
1384 searchDir path prefix = do
1385   fs <- getDirectoryEntries path `catchIO` \_ -> return []
1386   searchEntries path prefix fs
1387
1388 searchEntries path prefix [] = return []
1389 searchEntries path prefix (f:fs)
1390   | looks_like_a_module  =  do
1391         ms <- searchEntries path prefix fs
1392         return (prefix `joinModule` f : ms)
1393   | looks_like_a_component  =  do
1394         ms <- searchDir (path </> f) (prefix `joinModule` f)
1395         ms' <- searchEntries path prefix fs
1396         return (ms ++ ms')
1397   | otherwise
1398         searchEntries path prefix fs
1399
1400   where
1401         (base,suffix) = splitFileExt f
1402         looks_like_a_module =
1403                 suffix `elem` haskell_suffixes &&
1404                 all okInModuleName base
1405         looks_like_a_component =
1406                 null suffix && all okInModuleName base
1407
1408 okInModuleName c
1409
1410 #endif
1411
1412 -- ---------------------------------------------------------------------------
1413 -- expanding environment variables in the package configuration
1414
1415 expandEnvVars :: String -> Force -> IO String
1416 expandEnvVars str0 force = go str0 ""
1417  where
1418    go "" acc = return $! reverse acc
1419    go ('$':'{':str) acc | (var, '}':rest) <- break close str
1420         = do value <- lookupEnvVar var
1421              go rest (reverse value ++ acc)
1422         where close c = c == '}' || c == '\n' -- don't span newlines
1423    go (c:str) acc
1424         = go str (c:acc)
1425
1426    lookupEnvVar :: String -> IO String
1427    lookupEnvVar nm =
1428         catchIO (System.Environment.getEnv nm)
1429            (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1430                                         show nm)
1431                       return "")
1432
1433 -----------------------------------------------------------------------------
1434
1435 getProgramName :: IO String
1436 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1437    where str `withoutSuffix` suff
1438             | suff `isSuffixOf` str = take (length str - length suff) str
1439             | otherwise             = str
1440
1441 bye :: String -> IO a
1442 bye s = putStr s >> exitWith ExitSuccess
1443
1444 die :: String -> IO a
1445 die = dieWith 1
1446
1447 dieWith :: Int -> String -> IO a
1448 dieWith ec s = do
1449   hFlush stdout
1450   prog <- getProgramName
1451   hPutStrLn stderr (prog ++ ": " ++ s)
1452   exitWith (ExitFailure ec)
1453
1454 dieOrForceAll :: Force -> String -> IO ()
1455 dieOrForceAll ForceAll s = ignoreError s
1456 dieOrForceAll _other s   = dieForcible s
1457
1458 warn :: String -> IO ()
1459 warn = reportError
1460
1461 ignoreError :: String -> IO ()
1462 ignoreError s = reportError (s ++ " (ignoring)")
1463
1464 reportError :: String -> IO ()
1465 reportError s = do hFlush stdout; hPutStrLn stderr s
1466
1467 dieForcible :: String -> IO ()
1468 dieForcible s = die (s ++ " (use --force to override)")
1469
1470 my_head :: String -> [a] -> a
1471 my_head s []      = error s
1472 my_head _ (x : _) = x
1473
1474 -----------------------------------------
1475 -- Cut and pasted from ghc/compiler/main/SysTools
1476
1477 #if defined(mingw32_HOST_OS)
1478 subst :: Char -> Char -> String -> String
1479 subst a b ls = map (\ x -> if x == a then b else x) ls
1480
1481 unDosifyPath :: FilePath -> FilePath
1482 unDosifyPath xs = subst '\\' '/' xs
1483
1484 getLibDir :: IO (Maybe String)
1485 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1486
1487 -- (getExecDir cmd) returns the directory in which the current
1488 --                  executable, which should be called 'cmd', is running
1489 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1490 -- you'll get "/a/b/c" back as the result
1491 getExecDir :: String -> IO (Maybe String)
1492 getExecDir cmd =
1493     getExecPath >>= maybe (return Nothing) removeCmdSuffix
1494     where initN n = reverse . drop n . reverse
1495           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1496
1497 getExecPath :: IO (Maybe String)
1498 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1499   where
1500     try_size size = allocaArray (fromIntegral size) $ \buf -> do
1501         ret <- c_GetModuleFileName nullPtr buf size
1502         case ret of
1503           0 -> return Nothing
1504           _ | ret < size -> fmap Just $ peekCWString buf
1505             | otherwise  -> try_size (size * 2)
1506
1507 foreign import stdcall unsafe "windows.h GetModuleFileNameW"
1508   c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1509 #else
1510 getLibDir :: IO (Maybe String)
1511 getLibDir = return Nothing
1512 #endif
1513
1514 -----------------------------------------
1515 -- Adapted from ghc/compiler/utils/Panic
1516
1517 installSignalHandlers :: IO ()
1518 installSignalHandlers = do
1519   threadid <- myThreadId
1520   let
1521       interrupt = Exception.throwTo threadid
1522                                     (Exception.ErrorCall "interrupted")
1523   --
1524 #if !defined(mingw32_HOST_OS)
1525   _ <- installHandler sigQUIT (Catch interrupt) Nothing
1526   _ <- installHandler sigINT  (Catch interrupt) Nothing
1527   return ()
1528 #else
1529   -- GHC 6.3+ has support for console events on Windows
1530   -- NOTE: running GHCi under a bash shell for some reason requires
1531   -- you to press Ctrl-Break rather than Ctrl-C to provoke
1532   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
1533   -- why --SDM 17/12/2004
1534   let sig_handler ControlC = interrupt
1535       sig_handler Break    = interrupt
1536       sig_handler _        = return ()
1537
1538   _ <- installHandler (Catch sig_handler)
1539   return ()
1540 #endif
1541
1542 #if mingw32_HOST_OS || mingw32_TARGET_OS
1543 throwIOIO :: Exception.IOException -> IO a
1544 throwIOIO = Exception.throwIO
1545 #endif
1546
1547 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1548 catchIO = Exception.catch
1549
1550 catchError :: IO a -> (String -> IO a) -> IO a
1551 catchError io handler = io `Exception.catch` handler'
1552     where handler' (Exception.ErrorCall err) = handler err
1553
1554 tryIO :: IO a -> IO (Either Exception.IOException a)
1555 tryIO = Exception.try
1556
1557 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
1558 writeBinaryFileAtomic targetFile obj =
1559   withFileAtomic targetFile $ \h -> do
1560      hSetBinaryMode h True
1561      B.hPutStr h (Bin.encode obj)
1562
1563 writeFileUtf8Atomic :: FilePath -> String -> IO ()
1564 writeFileUtf8Atomic targetFile content =
1565   withFileAtomic targetFile $ \h -> do
1566      hSetEncoding h utf8
1567      hPutStr h content
1568
1569 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1570 -- to use text files here, rather than binary files.
1571 withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
1572 withFileAtomic targetFile write_content = do
1573   (newFile, newHandle) <- openNewFile targetDir template
1574   do  write_content newHandle
1575       hClose newHandle
1576 #if mingw32_HOST_OS || mingw32_TARGET_OS
1577       renameFile newFile targetFile
1578         -- If the targetFile exists then renameFile will fail
1579         `catchIO` \err -> do
1580           exists <- doesFileExist targetFile
1581           if exists
1582             then do removeFileSafe targetFile
1583                     -- Big fat hairy race condition
1584                     renameFile newFile targetFile
1585                     -- If the removeFile succeeds and the renameFile fails
1586                     -- then we've lost the atomic property.
1587             else throwIOIO err
1588 #else
1589       renameFile newFile targetFile
1590 #endif
1591    `Exception.onException` do hClose newHandle
1592                               removeFileSafe newFile
1593   where
1594     template = targetName <.> "tmp"
1595     targetDir | null targetDir_ = "."
1596               | otherwise       = targetDir_
1597     --TODO: remove this when takeDirectory/splitFileName is fixed
1598     --      to always return a valid dir
1599     (targetDir_,targetName) = splitFileName targetFile
1600
1601 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1602 openNewFile dir template = do
1603   -- this was added to System.IO in 6.12.1
1604   -- we must use this version because the version below opens the file
1605   -- in binary mode.
1606   openTempFileWithDefaultPermissions dir template
1607
1608 -- | The function splits the given string to substrings
1609 -- using 'isSearchPathSeparator'.
1610 parseSearchPath :: String -> [FilePath]
1611 parseSearchPath path = split path
1612   where
1613     split :: String -> [String]
1614     split s =
1615       case rest' of
1616         []     -> [chunk]
1617         _:rest -> chunk : split rest
1618       where
1619         chunk =
1620           case chunk' of
1621 #ifdef mingw32_HOST_OS
1622             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1623 #endif
1624             _                                 -> chunk'
1625
1626         (chunk', rest') = break isSearchPathSeparator s
1627
1628 readUTF8File :: FilePath -> IO String
1629 readUTF8File file = do
1630   h <- openFile file ReadMode
1631   -- fix the encoding to UTF-8
1632   hSetEncoding h utf8
1633   hGetContents h
1634
1635 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
1636 removeFileSafe :: FilePath -> IO ()
1637 removeFileSafe fn =
1638   removeFile fn `catchIO` \ e ->
1639     when (not $ isDoesNotExistError e) $ ioError e