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