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