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