utils/ghc-pkg/Main.hs

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