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