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