utils/ghc-pkg/Main.hs

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