1{-# LANGUAGE CPP #-} 2{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE LambdaCase #-} 4{-# LANGUAGE MultiParamTypeClasses #-} 5{-# LANGUAGE TypeSynonymInstances #-} 6{-# LANGUAGE GADTs #-} 7{-# LANGUAGE KindSignatures #-} 8{-# LANGUAGE DataKinds #-} 9{-# LANGUAGE TupleSections #-} 10{-# LANGUAGE ScopedTypeVariables #-} 11{-# OPTIONS_GHC -fno-warn-orphans #-} 12 13-- We never want to link against terminfo while bootstrapping. 14#if defined(BOOTSTRAPPING) 15#if defined(WITH_TERMINFO) 16#undef WITH_TERMINFO 17#endif 18#endif 19 20-- Fine if this comes from make/Hadrian or the pre-built base. 21#include <ghcplatform.h> 22 23----------------------------------------------------------------------------- 24-- 25-- (c) The University of Glasgow 2004-2009. 26-- 27-- Package management tool 28-- 29----------------------------------------------------------------------------- 30 31module Main (main) where 32 33import qualified GHC.PackageDb as GhcPkg 34import GHC.PackageDb (BinaryStringRep(..)) 35import GHC.HandleEncoding 36import GHC.BaseDir (getBaseDir) 37import GHC.Settings (getTargetPlatform, maybeReadFuzzy) 38import GHC.Platform (platformMini) 39import GHC.Platform.Host (cHostPlatformMini) 40import GHC.UniqueSubdir (uniqueSubdir) 41import GHC.Version ( cProjectVersion ) 42import qualified Distribution.Simple.PackageIndex as PackageIndex 43import qualified Data.Graph as Graph 44import qualified Distribution.ModuleName as ModuleName 45import Distribution.ModuleName (ModuleName) 46import Distribution.InstalledPackageInfo as Cabal 47import qualified Distribution.Parsec as Cabal 48import Distribution.Package hiding (installedUnitId) 49import Distribution.Text 50import Distribution.Version 51import Distribution.Backpack 52import Distribution.Types.UnqualComponentName 53import Distribution.Types.LibraryName 54import Distribution.Types.MungedPackageName 55import Distribution.Types.MungedPackageId 56import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS, writeUTF8File, readUTF8File) 57import qualified Data.Version as Version 58import System.FilePath as FilePath 59import qualified System.FilePath.Posix as FilePath.Posix 60import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing, 61 getModificationTime ) 62import Text.Printf 63 64import Prelude 65 66import System.Console.GetOpt 67import qualified Control.Exception as Exception 68import Data.Maybe 69 70import Data.Char ( toLower ) 71import Control.Monad 72import System.Directory ( doesDirectoryExist, getDirectoryContents, 73 doesFileExist, removeFile, 74 getCurrentDirectory ) 75import System.Exit ( exitWith, ExitCode(..) ) 76import System.Environment ( getArgs, getProgName, getEnv ) 77import System.IO 78import System.IO.Error 79import GHC.IO.Exception (IOErrorType(InappropriateType)) 80import Data.List 81import Control.Concurrent 82import qualified Data.Foldable as F 83import qualified Data.Traversable as F 84import qualified Data.Set as Set 85import qualified Data.Map as Map 86import qualified Data.ByteString as BS 87 88#if defined(mingw32_HOST_OS) 89import GHC.ConsoleHandler 90#else 91import System.Posix hiding (fdToHandle) 92#endif 93 94#if defined(GLOB) 95import qualified System.Info(os) 96#endif 97 98#if defined(WITH_TERMINFO) 99import System.Console.Terminfo as Terminfo 100#endif 101 102#if defined(mingw32_HOST_OS) 103# if defined(i386_HOST_ARCH) 104# define WINDOWS_CCONV stdcall 105# elif defined(x86_64_HOST_ARCH) 106# define WINDOWS_CCONV ccall 107# else 108# error Unknown mingw32 arch 109# endif 110#endif 111 112-- | Short-circuit 'any' with a \"monadic predicate\". 113anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool 114anyM _ [] = return False 115anyM p (x:xs) = do 116 b <- p x 117 if b 118 then return True 119 else anyM p xs 120 121-- ----------------------------------------------------------------------------- 122-- Entry point 123 124main :: IO () 125main = do 126 configureHandleEncoding 127 args <- getArgs 128 129 case getOpt Permute (flags ++ deprecFlags) args of 130 (cli,_,[]) | FlagHelp `elem` cli -> do 131 prog <- getProgramName 132 bye (usageInfo (usageHeader prog) flags) 133 (cli,_,[]) | FlagVersion `elem` cli -> 134 bye ourCopyright 135 (cli,nonopts,[]) -> 136 case getVerbosity Normal cli of 137 Right v -> runit v cli nonopts 138 Left err -> die err 139 (_,_,errors) -> do 140 prog <- getProgramName 141 die (concat errors ++ shortUsage prog) 142 143-- ----------------------------------------------------------------------------- 144-- Command-line syntax 145 146data Flag 147 = FlagUser 148 | FlagGlobal 149 | FlagHelp 150 | FlagVersion 151 | FlagConfig FilePath 152 | FlagGlobalConfig FilePath 153 | FlagUserConfig FilePath 154 | FlagForce 155 | FlagForceFiles 156 | FlagMultiInstance 157 | FlagExpandEnvVars 158 | FlagExpandPkgroot 159 | FlagNoExpandPkgroot 160 | FlagSimpleOutput 161 | FlagNamesOnly 162 | FlagIgnoreCase 163 | FlagNoUserDb 164 | FlagVerbosity (Maybe String) 165 | FlagUnitId 166 | FlagShowUnitIds 167 deriving Eq 168 169flags :: [OptDescr Flag] 170flags = [ 171 Option [] ["user"] (NoArg FlagUser) 172 "use the current user's package database", 173 Option [] ["global"] (NoArg FlagGlobal) 174 "use the global package database", 175 Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR") 176 "use the specified package database", 177 Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR") 178 "use the specified package database (DEPRECATED)", 179 Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR") 180 "location of the global package database", 181 Option [] ["no-user-package-db"] (NoArg FlagNoUserDb) 182 "never read the user package database", 183 Option [] ["user-package-db"] (ReqArg FlagUserConfig "DIR") 184 "location of the user package database (use instead of default)", 185 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb) 186 "never read the user package database (DEPRECATED)", 187 Option [] ["force"] (NoArg FlagForce) 188 "ignore missing dependencies, directories, and libraries", 189 Option [] ["force-files"] (NoArg FlagForceFiles) 190 "ignore missing directories and libraries only", 191 Option [] ["enable-multi-instance"] (NoArg FlagMultiInstance) 192 "allow registering multiple instances of the same package version", 193 Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars) 194 "expand environment variables (${name}-style) in input package descriptions", 195 Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot) 196 "expand ${pkgroot}-relative paths to absolute in output package descriptions", 197 Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot) 198 "preserve ${pkgroot}-relative paths in output package descriptions", 199 Option ['?'] ["help"] (NoArg FlagHelp) 200 "display this help and exit", 201 Option ['V'] ["version"] (NoArg FlagVersion) 202 "output version information and exit", 203 Option [] ["simple-output"] (NoArg FlagSimpleOutput) 204 "print output in easy-to-parse format for some commands", 205 Option [] ["show-unit-ids"] (NoArg FlagShowUnitIds) 206 "print unit-ids instead of package identifiers", 207 Option [] ["names-only"] (NoArg FlagNamesOnly) 208 "only print package names, not versions; can only be used with list --simple-output", 209 Option [] ["ignore-case"] (NoArg FlagIgnoreCase) 210 "ignore case for substring matching", 211 Option [] ["ipid", "unit-id"] (NoArg FlagUnitId) 212 "interpret package arguments as unit IDs (e.g. installed package IDs)", 213 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity") 214 "verbosity level (0-2, default 1)" 215 ] 216 217data Verbosity = Silent | Normal | Verbose 218 deriving (Show, Eq, Ord) 219 220getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity 221getVerbosity v [] = Right v 222getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs 223getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs 224getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs 225getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs 226getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v) 227getVerbosity v (_ : fs) = getVerbosity v fs 228 229deprecFlags :: [OptDescr Flag] 230deprecFlags = [ 231 -- put deprecated flags here 232 ] 233 234ourCopyright :: String 235ourCopyright = "GHC package manager version " ++ GHC.Version.cProjectVersion ++ "\n" 236 237shortUsage :: String -> String 238shortUsage prog = "For usage information see '" ++ prog ++ " --help'." 239 240usageHeader :: String -> String 241usageHeader prog = substProg prog $ 242 "Usage:\n" ++ 243 " $p init {path}\n" ++ 244 " Create and initialise a package database at the location {path}.\n" ++ 245 " Packages can be registered in the new database using the register\n" ++ 246 " command with --package-db={path}. To use the new database with GHC,\n" ++ 247 " use GHC's -package-db flag.\n" ++ 248 "\n" ++ 249 " $p register {filename | -}\n" ++ 250 " Register the package using the specified installed package\n" ++ 251 " description. The syntax for the latter is given in the $p\n" ++ 252 " documentation. The input file should be encoded in UTF-8.\n" ++ 253 "\n" ++ 254 " $p update {filename | -}\n" ++ 255 " Register the package, overwriting any other package with the\n" ++ 256 " same name. The input file should be encoded in UTF-8.\n" ++ 257 "\n" ++ 258 " $p unregister [pkg-id] \n" ++ 259 " Unregister the specified packages in the order given.\n" ++ 260 "\n" ++ 261 " $p expose {pkg-id}\n" ++ 262 " Expose the specified package.\n" ++ 263 "\n" ++ 264 " $p hide {pkg-id}\n" ++ 265 " Hide the specified package.\n" ++ 266 "\n" ++ 267 " $p trust {pkg-id}\n" ++ 268 " Trust the specified package.\n" ++ 269 "\n" ++ 270 " $p distrust {pkg-id}\n" ++ 271 " Distrust the specified package.\n" ++ 272 "\n" ++ 273 " $p list [pkg]\n" ++ 274 " List registered packages in the global database, and also the\n" ++ 275 " user database if --user is given. If a package name is given\n" ++ 276 " all the registered versions will be listed in ascending order.\n" ++ 277 " Accepts the --simple-output flag.\n" ++ 278 "\n" ++ 279 " $p dot\n" ++ 280 " Generate a graph of the package dependencies in a form suitable\n" ++ 281 " for input for the graphviz tools. For example, to generate a PDF\n" ++ 282 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf\n" ++ 283 "\n" ++ 284 " $p find-module {module}\n" ++ 285 " List registered packages exposing module {module} in the global\n" ++ 286 " database, and also the user database if --user is given.\n" ++ 287 " All the registered versions will be listed in ascending order.\n" ++ 288 " Accepts the --simple-output flag.\n" ++ 289 "\n" ++ 290 " $p latest {pkg-id}\n" ++ 291 " Prints the highest registered version of a package.\n" ++ 292 "\n" ++ 293 " $p check\n" ++ 294 " Check the consistency of package dependencies and list broken packages.\n" ++ 295 " Accepts the --simple-output flag.\n" ++ 296 "\n" ++ 297 " $p describe {pkg}\n" ++ 298 " Give the registered description for the specified package. The\n" ++ 299 " description is returned in precisely the syntax required by $p\n" ++ 300 " register.\n" ++ 301 "\n" ++ 302 " $p field {pkg} {field}\n" ++ 303 " Extract the specified field of the package description for the\n" ++ 304 " specified package. Accepts comma-separated multiple fields.\n" ++ 305 "\n" ++ 306 " $p dump\n" ++ 307 " Dump the registered description for every package. This is like\n" ++ 308 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++ 309 " by tools that parse the results, rather than humans. The output is\n" ++ 310 " always encoded in UTF-8, regardless of the current locale.\n" ++ 311 "\n" ++ 312 " $p recache\n" ++ 313 " Regenerate the package database cache. This command should only be\n" ++ 314 " necessary if you added a package to the database by dropping a file\n" ++ 315 " into the database directory manually. By default, the global DB\n" ++ 316 " is recached; to recache a different DB use --user or --package-db\n" ++ 317 " as appropriate.\n" ++ 318 "\n" ++ 319 " Substring matching is supported for {module} in find-module and\n" ++ 320 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ 321 " open substring ends (prefix*, *suffix, *infix*). Use --ipid to\n" ++ 322 " match against the installed package ID instead.\n" ++ 323 "\n" ++ 324 " When asked to modify a database (register, unregister, update,\n"++ 325 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++ 326 " default. Specifying --user causes it to act on the user database,\n"++ 327 " or --package-db can be used to act on another database\n"++ 328 " entirely. When multiple of these options are given, the rightmost\n"++ 329 " one is used as the database to act upon.\n"++ 330 "\n"++ 331 " Commands that query the package database (list, tree, latest, describe,\n"++ 332 " field) operate on the list of databases specified by the flags\n"++ 333 " --user, --global, and --package-db. If none of these flags are\n"++ 334 " given, the default is --global --user.\n"++ 335 "\n" ++ 336 " The following optional flags are also accepted:\n" 337 338substProg :: String -> String -> String 339substProg _ [] = [] 340substProg prog ('$':'p':xs) = prog ++ substProg prog xs 341substProg prog (c:xs) = c : substProg prog xs 342 343-- ----------------------------------------------------------------------------- 344-- Do the business 345 346data Force = NoForce | ForceFiles | ForceAll | CannotForce 347 deriving (Eq,Ord) 348 349-- | Enum flag representing argument type 350data AsPackageArg 351 = AsUnitId 352 | AsDefault 353 354-- | Represents how a package may be specified by a user on the command line. 355data PackageArg 356 -- | A package identifier foo-0.1, or a glob foo-* 357 = Id GlobPackageIdentifier 358 -- | An installed package ID foo-0.1-HASH. This is guaranteed to uniquely 359 -- match a single entry in the package database. 360 | IUId UnitId 361 -- | A glob against the package name. The first string is the literal 362 -- glob, the second is a function which returns @True@ if the argument 363 -- matches. 364 | Substring String (String->Bool) 365 366runit :: Verbosity -> [Flag] -> [String] -> IO () 367runit verbosity cli nonopts = do 368 installSignalHandlers -- catch ^C and clean up 369 when (verbosity >= Verbose) 370 (putStr ourCopyright) 371 prog <- getProgramName 372 let 373 force 374 | FlagForce `elem` cli = ForceAll 375 | FlagForceFiles `elem` cli = ForceFiles 376 | otherwise = NoForce 377 as_arg | FlagUnitId `elem` cli = AsUnitId 378 | otherwise = AsDefault 379 multi_instance = FlagMultiInstance `elem` cli 380 expand_env_vars= FlagExpandEnvVars `elem` cli 381 mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli 382 where accumExpandPkgroot _ FlagExpandPkgroot = Just True 383 accumExpandPkgroot _ FlagNoExpandPkgroot = Just False 384 accumExpandPkgroot x _ = x 385 386 splitFields fields = unfoldr splitComma (',':fields) 387 where splitComma "" = Nothing 388 splitComma fs = Just $ break (==',') (tail fs) 389 390 -- | Parses a glob into a predicate which tests if a string matches 391 -- the glob. Returns Nothing if the string in question is not a glob. 392 -- At the moment, we only support globs at the beginning and/or end of 393 -- strings. This function respects case sensitivity. 394 -- 395 -- >>> fromJust (substringCheck "*") "anything" 396 -- True 397 -- 398 -- >>> fromJust (substringCheck "string") "string" 399 -- True 400 -- 401 -- >>> fromJust (substringCheck "*bar") "foobar" 402 -- True 403 -- 404 -- >>> fromJust (substringCheck "foo*") "foobar" 405 -- True 406 -- 407 -- >>> fromJust (substringCheck "*ooba*") "foobar" 408 -- True 409 -- 410 -- >>> fromJust (substringCheck "f*bar") "foobar" 411 -- False 412 substringCheck :: String -> Maybe (String -> Bool) 413 substringCheck "" = Nothing 414 substringCheck "*" = Just (const True) 415 substringCheck [_] = Nothing 416 substringCheck (h:t) = 417 case (h, init t, last t) of 418 ('*',s,'*') -> Just (isInfixOf (f s) . f) 419 ('*',_, _ ) -> Just (isSuffixOf (f t) . f) 420 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f) 421 _ -> Nothing 422 where f | FlagIgnoreCase `elem` cli = map toLower 423 | otherwise = id 424#if defined(GLOB) 425 glob x | System.Info.os=="mingw32" = do 426 -- glob echoes its argument, after win32 filename globbing 427 (_,o,_,_) <- runInteractiveCommand ("glob "++x) 428 txt <- hGetContents o 429 return (read txt) 430 glob x | otherwise = return [x] 431#endif 432 -- 433 -- first, parse the command 434 case nonopts of 435#if defined(GLOB) 436 -- dummy command to demonstrate usage and permit testing 437 -- without messing things up; use glob to selectively enable 438 -- windows filename globbing for file parameters 439 -- register, update, FlagGlobalConfig, FlagConfig; others? 440 ["glob", filename] -> do 441 print filename 442 glob filename >>= print 443#endif 444 ["init", filename] -> 445 initPackageDB filename verbosity cli 446 ["register", filename] -> 447 registerPackage filename verbosity cli 448 multi_instance 449 expand_env_vars False force 450 ["update", filename] -> 451 registerPackage filename verbosity cli 452 multi_instance 453 expand_env_vars True force 454 "unregister" : pkgarg_strs@(_:_) -> do 455 forM_ pkgarg_strs $ \pkgarg_str -> do 456 pkgarg <- readPackageArg as_arg pkgarg_str 457 unregisterPackage pkgarg verbosity cli force 458 ["expose", pkgarg_str] -> do 459 pkgarg <- readPackageArg as_arg pkgarg_str 460 exposePackage pkgarg verbosity cli force 461 ["hide", pkgarg_str] -> do 462 pkgarg <- readPackageArg as_arg pkgarg_str 463 hidePackage pkgarg verbosity cli force 464 ["trust", pkgarg_str] -> do 465 pkgarg <- readPackageArg as_arg pkgarg_str 466 trustPackage pkgarg verbosity cli force 467 ["distrust", pkgarg_str] -> do 468 pkgarg <- readPackageArg as_arg pkgarg_str 469 distrustPackage pkgarg verbosity cli force 470 ["list"] -> do 471 listPackages verbosity cli Nothing Nothing 472 ["list", pkgarg_str] -> 473 case substringCheck pkgarg_str of 474 Nothing -> do pkgarg <- readPackageArg as_arg pkgarg_str 475 listPackages verbosity cli (Just pkgarg) Nothing 476 Just m -> listPackages verbosity cli 477 (Just (Substring pkgarg_str m)) Nothing 478 ["dot"] -> do 479 showPackageDot verbosity cli 480 ["find-module", mod_name] -> do 481 let match = maybe (==mod_name) id (substringCheck mod_name) 482 listPackages verbosity cli Nothing (Just match) 483 ["latest", pkgid_str] -> do 484 pkgid <- readGlobPkgId pkgid_str 485 latestPackage verbosity cli pkgid 486 ["describe", pkgid_str] -> do 487 pkgarg <- case substringCheck pkgid_str of 488 Nothing -> readPackageArg as_arg pkgid_str 489 Just m -> return (Substring pkgid_str m) 490 describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot) 491 492 ["field", pkgid_str, fields] -> do 493 pkgarg <- case substringCheck pkgid_str of 494 Nothing -> readPackageArg as_arg pkgid_str 495 Just m -> return (Substring pkgid_str m) 496 describeField verbosity cli pkgarg 497 (splitFields fields) (fromMaybe True mexpand_pkgroot) 498 499 ["check"] -> do 500 checkConsistency verbosity cli 501 502 ["dump"] -> do 503 dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot) 504 505 ["recache"] -> do 506 recache verbosity cli 507 508 [] -> do 509 die ("missing command\n" ++ shortUsage prog) 510 (_cmd:_) -> do 511 die ("command-line syntax error\n" ++ shortUsage prog) 512 513parseCheck :: Cabal.Parsec a => String -> String -> IO a 514parseCheck str what = 515 case Cabal.eitherParsec str of 516 Left e -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what ++ ": " ++ e) 517 Right x -> pure x 518 519-- | Either an exact 'PackageIdentifier', or a glob for all packages 520-- matching 'PackageName'. 521data GlobPackageIdentifier 522 = ExactPackageIdentifier MungedPackageId 523 | GlobPackageIdentifier MungedPackageName 524 525displayGlobPkgId :: GlobPackageIdentifier -> String 526displayGlobPkgId (ExactPackageIdentifier pid) = display pid 527displayGlobPkgId (GlobPackageIdentifier pn) = display pn ++ "-*" 528 529readGlobPkgId :: String -> IO GlobPackageIdentifier 530readGlobPkgId str 531 | "-*" `isSuffixOf` str = 532 GlobPackageIdentifier <$> parseCheck (init (init str)) "package identifier (glob)" 533 | otherwise = ExactPackageIdentifier <$> parseCheck str "package identifier (exact)" 534 535readPackageArg :: AsPackageArg -> String -> IO PackageArg 536readPackageArg AsUnitId str = IUId <$> parseCheck str "installed package id" 537readPackageArg AsDefault str = Id <$> readGlobPkgId str 538 539-- ----------------------------------------------------------------------------- 540-- Package databases 541 542-- Some commands operate on a single database: 543-- register, unregister, expose, hide, trust, distrust 544-- however these commands also check the union of the available databases 545-- in order to check consistency. For example, register will check that 546-- dependencies exist before registering a package. 547-- 548-- Some commands operate on multiple databases, with overlapping semantics: 549-- list, describe, field 550 551data PackageDB (mode :: GhcPkg.DbMode) 552 = PackageDB { 553 location, locationAbsolute :: !FilePath, 554 -- We need both possibly-relative and definitely-absolute package 555 -- db locations. This is because the relative location is used as 556 -- an identifier for the db, so it is important we do not modify it. 557 -- On the other hand we need the absolute path in a few places 558 -- particularly in relation to the ${pkgroot} stuff. 559 560 packageDbLock :: !(GhcPkg.DbOpenMode mode GhcPkg.PackageDbLock), 561 -- If package db is open in read write mode, we keep its lock around for 562 -- transactional updates. 563 564 packages :: [InstalledPackageInfo] 565 } 566 567type PackageDBStack = [PackageDB 'GhcPkg.DbReadOnly] 568 -- A stack of package databases. Convention: head is the topmost 569 -- in the stack. 570 571-- | Selector for picking the right package DB to modify as 'register' and 572-- 'recache' operate on the database on top of the stack, whereas 'modify' 573-- changes the first database that contains a specific package. 574data DbModifySelector = TopOne | ContainsPkg PackageArg 575 576allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] 577allPackagesInStack = concatMap packages 578 579-- | Retain only the part of the stack up to and including the given package 580-- DB (where the global package DB is the bottom of the stack). The resulting 581-- package DB stack contains exactly the packages that packages from the 582-- specified package DB can depend on, since dependencies can only extend 583-- down the stack, not up (e.g. global packages cannot depend on user 584-- packages). 585stackUpTo :: FilePath -> PackageDBStack -> PackageDBStack 586stackUpTo to_modify = dropWhile ((/= to_modify) . location) 587 588getPkgDatabases :: Verbosity 589 -> GhcPkg.DbOpenMode mode DbModifySelector 590 -> Bool -- use the user db 591 -> Bool -- read caches, if available 592 -> Bool -- expand vars, like ${pkgroot} and $topdir 593 -> [Flag] 594 -> IO (PackageDBStack, 595 -- the real package DB stack: [global,user] ++ 596 -- DBs specified on the command line with -f. 597 GhcPkg.DbOpenMode mode (PackageDB mode), 598 -- which one to modify, if any 599 PackageDBStack) 600 -- the package DBs specified on the command 601 -- line, or [global,user] otherwise. This 602 -- is used as the list of package DBs for 603 -- commands that just read the DB, such as 'list'. 604 605getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do 606 -- Second we determine the location of the global package config. On Windows, 607 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the 608 -- location is passed to the binary using the --global-package-db flag by the 609 -- wrapper script. 610 let err_msg = "missing --global-package-db option, location of global package database unknown\n" 611 global_conf <- 612 case [ f | FlagGlobalConfig f <- my_flags ] of 613 -- See Note [Base Dir] for more information on the base dir / top dir. 614 [] -> do mb_dir <- getBaseDir 615 case mb_dir of 616 Nothing -> die err_msg 617 Just dir -> do 618 r <- lookForPackageDBIn dir 619 case r of 620 Nothing -> die ("Can't find package database in " ++ dir) 621 Just path -> return path 622 fs -> return (last fs) 623 624 -- The value of the $topdir variable used in some package descriptions 625 -- Note that the way we calculate this is slightly different to how it 626 -- is done in ghc itself. We rely on the convention that the global 627 -- package db lives in ghc's libdir. 628 top_dir <- absolutePath (takeDirectory global_conf) 629 630 let no_user_db = FlagNoUserDb `elem` my_flags 631 632 -- get the location of the user package database, and create it if necessary 633 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set) 634 e_appdir <- tryIO $ getAppUserDataDirectory "ghc" 635 636 mb_user_conf <- 637 case [ f | FlagUserConfig f <- my_flags ] of 638 _ | no_user_db -> return Nothing 639 [] -> case e_appdir of 640 Left _ -> return Nothing 641 Right appdir -> do 642 -- See Note [Settings File] about this file, and why we need GHC to share it with us. 643 let settingsFile = top_dir </> "settings" 644 exists_settings_file <- doesFileExist settingsFile 645 targetPlatformMini <- case exists_settings_file of 646 False -> do 647 warn $ "WARNING: settings file doesn't exist " ++ show settingsFile 648 warn "cannot know target platform so guessing target == host (native compiler)." 649 pure cHostPlatformMini 650 True -> do 651 settingsStr <- readFile settingsFile 652 mySettings <- case maybeReadFuzzy settingsStr of 653 Just s -> pure $ Map.fromList s 654 -- It's excusable to not have a settings file (for now at 655 -- least) but completely inexcusable to have a malformed one. 656 Nothing -> die $ "Can't parse settings file " ++ show settingsFile 657 case getTargetPlatform settingsFile mySettings of 658 Right platform -> pure $ platformMini platform 659 Left e -> die e 660 let subdir = uniqueSubdir targetPlatformMini 661 dir = appdir </> subdir 662 r <- lookForPackageDBIn dir 663 case r of 664 Nothing -> return (Just (dir </> "package.conf.d", False)) 665 Just f -> return (Just (f, True)) 666 fs -> return (Just (last fs, True)) 667 668 -- If the user database exists, and for "use_user" commands (which includes 669 -- "ghc-pkg check" and all commands that modify the db) we will attempt to 670 -- use the user db. 671 let sys_databases 672 | Just (user_conf,user_exists) <- mb_user_conf, 673 use_user || user_exists = [user_conf, global_conf] 674 | otherwise = [global_conf] 675 676 e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH") 677 let env_stack = 678 case e_pkg_path of 679 Left _ -> sys_databases 680 Right path 681 | not (null path) && isSearchPathSeparator (last path) 682 -> splitSearchPath (init path) ++ sys_databases 683 | otherwise 684 -> splitSearchPath path 685 686 -- The "global" database is always the one at the bottom of the stack. 687 -- This is the database we modify by default. 688 virt_global_conf = last env_stack 689 690 let db_flags = [ f | Just f <- map is_db_flag my_flags ] 691 where is_db_flag FlagUser 692 | Just (user_conf, _user_exists) <- mb_user_conf 693 = Just user_conf 694 is_db_flag FlagGlobal = Just virt_global_conf 695 is_db_flag (FlagConfig f) = Just f 696 is_db_flag _ = Nothing 697 698 let flag_db_names | null db_flags = env_stack 699 | otherwise = reverse (nub db_flags) 700 701 -- For a "modify" command, treat all the databases as 702 -- a stack, where we are modifying the top one, but it 703 -- can refer to packages in databases further down the 704 -- stack. 705 706 -- -f flags on the command line add to the database 707 -- stack, unless any of them are present in the stack 708 -- already. 709 let final_stack = filter (`notElem` env_stack) 710 [ f | FlagConfig f <- reverse my_flags ] 711 ++ env_stack 712 713 top_db = if null db_flags 714 then virt_global_conf 715 else last db_flags 716 717 (db_stack, db_to_operate_on) <- getDatabases top_dir mb_user_conf 718 flag_db_names final_stack top_db 719 720 let flag_db_stack = [ db | db_name <- flag_db_names, 721 db <- db_stack, location db == db_name ] 722 723 when (verbosity > Normal) $ do 724 infoLn ("db stack: " ++ show (map location db_stack)) 725 F.forM_ db_to_operate_on $ \db -> 726 infoLn ("modifying: " ++ (location db)) 727 infoLn ("flag db stack: " ++ show (map location flag_db_stack)) 728 729 return (db_stack, db_to_operate_on, flag_db_stack) 730 where 731 getDatabases top_dir mb_user_conf flag_db_names 732 final_stack top_db = case mode of 733 -- When we open in read only mode, we simply read all of the databases/ 734 GhcPkg.DbOpenReadOnly -> do 735 db_stack <- mapM readDatabase final_stack 736 return (db_stack, GhcPkg.DbOpenReadOnly) 737 738 -- The only package db we open in read write mode is the one on the top of 739 -- the stack. 740 GhcPkg.DbOpenReadWrite TopOne -> do 741 (db_stack, mto_modify) <- stateSequence Nothing 742 [ \case 743 to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path 744 Nothing -> if db_path /= top_db 745 then (, Nothing) <$> readDatabase db_path 746 else do 747 db <- readParseDatabase verbosity mb_user_conf 748 mode use_cache db_path 749 `Exception.catch` couldntOpenDbForModification db_path 750 let ro_db = db { packageDbLock = GhcPkg.DbOpenReadOnly } 751 return (ro_db, Just db) 752 | db_path <- final_stack ] 753 754 to_modify <- case mto_modify of 755 Just db -> return db 756 Nothing -> die "no database selected for modification" 757 758 return (db_stack, GhcPkg.DbOpenReadWrite to_modify) 759 760 -- The package db we open in read write mode is the first one included in 761 -- flag_db_names that contains specified package. Therefore we need to 762 -- open each one in read/write mode first and decide whether it's for 763 -- modification based on its contents. 764 GhcPkg.DbOpenReadWrite (ContainsPkg pkgarg) -> do 765 (db_stack, mto_modify) <- stateSequence Nothing 766 [ \case 767 to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path 768 Nothing -> if db_path `notElem` flag_db_names 769 then (, Nothing) <$> readDatabase db_path 770 else do 771 let hasPkg :: PackageDB mode -> Bool 772 hasPkg = not . null . findPackage pkgarg . packages 773 774 openRo (e::IOError) = do 775 db <- readDatabase db_path 776 if hasPkg db 777 then couldntOpenDbForModification db_path e 778 else return (db, Nothing) 779 780 -- If we fail to open the database in read/write mode, we need 781 -- to check if it's for modification first before throwing an 782 -- error, so we attempt to open it in read only mode. 783 Exception.handle openRo $ do 784 db <- readParseDatabase verbosity mb_user_conf 785 mode use_cache db_path 786 let ro_db = db { packageDbLock = GhcPkg.DbOpenReadOnly } 787 if hasPkg db 788 then return (ro_db, Just db) 789 else do 790 -- If the database is not for modification after all, 791 -- drop the write lock as we are already finished with 792 -- the database. 793 case packageDbLock db of 794 GhcPkg.DbOpenReadWrite lock -> 795 GhcPkg.unlockPackageDb lock 796 return (ro_db, Nothing) 797 | db_path <- final_stack ] 798 799 to_modify <- case mto_modify of 800 Just db -> return db 801 Nothing -> cannotFindPackage pkgarg Nothing 802 803 return (db_stack, GhcPkg.DbOpenReadWrite to_modify) 804 where 805 couldntOpenDbForModification :: FilePath -> IOError -> IO a 806 couldntOpenDbForModification db_path e = die $ "Couldn't open database " 807 ++ db_path ++ " for modification: " ++ show e 808 809 -- Parse package db in read-only mode. 810 readDatabase :: FilePath -> IO (PackageDB 'GhcPkg.DbReadOnly) 811 readDatabase db_path = do 812 db <- readParseDatabase verbosity mb_user_conf 813 GhcPkg.DbOpenReadOnly use_cache db_path 814 if expand_vars 815 then return $ mungePackageDBPaths top_dir db 816 else return db 817 818 stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s) 819 stateSequence s [] = return ([], s) 820 stateSequence s (m:ms) = do 821 (a, s') <- m s 822 (as, s'') <- stateSequence s' ms 823 return (a : as, s'') 824 825lookForPackageDBIn :: FilePath -> IO (Maybe FilePath) 826lookForPackageDBIn dir = do 827 let path_dir = dir </> "package.conf.d" 828 exists_dir <- doesDirectoryExist path_dir 829 if exists_dir then return (Just path_dir) else do 830 let path_file = dir </> "package.conf" 831 exists_file <- doesFileExist path_file 832 if exists_file then return (Just path_file) else return Nothing 833 834readParseDatabase :: forall mode t. Verbosity 835 -> Maybe (FilePath,Bool) 836 -> GhcPkg.DbOpenMode mode t 837 -> Bool -- use cache 838 -> FilePath 839 -> IO (PackageDB mode) 840readParseDatabase verbosity mb_user_conf mode use_cache path 841 -- the user database (only) is allowed to be non-existent 842 | Just (user_conf,False) <- mb_user_conf, path == user_conf 843 = do lock <- F.forM mode $ \_ -> do 844 createDirectoryIfMissing True path 845 GhcPkg.lockPackageDb cache 846 mkPackageDB [] lock 847 | otherwise 848 = do e <- tryIO $ getDirectoryContents path 849 case e of 850 Left err 851 | ioeGetErrorType err == InappropriateType -> do 852 -- We provide a limited degree of backwards compatibility for 853 -- old single-file style db: 854 mdb <- tryReadParseOldFileStyleDatabase verbosity 855 mb_user_conf mode use_cache path 856 case mdb of 857 Just db -> return db 858 Nothing -> 859 die $ "ghc no longer supports single-file style package " 860 ++ "databases (" ++ path ++ ") use 'ghc-pkg init'" 861 ++ "to create the database with the correct format." 862 863 | otherwise -> ioError err 864 Right fs 865 | not use_cache -> ignore_cache (const $ return ()) 866 | otherwise -> do 867 e_tcache <- tryIO $ getModificationTime cache 868 case e_tcache of 869 Left ex -> do 870 whenReportCacheErrors $ 871 if isDoesNotExistError ex 872 then 873 -- It's fine if the cache is not there as long as the 874 -- database is empty. 875 when (not $ null confs) $ do 876 warn ("WARNING: cache does not exist: " ++ cache) 877 warn ("ghc will fail to read this package db. " ++ 878 recacheAdvice) 879 else do 880 warn ("WARNING: cache cannot be read: " ++ show ex) 881 warn "ghc will fail to read this package db." 882 ignore_cache (const $ return ()) 883 Right tcache -> do 884 when (verbosity >= Verbose) $ do 885 warn ("Timestamp " ++ show tcache ++ " for " ++ cache) 886 -- If any of the .conf files is newer than package.cache, we 887 -- assume that cache is out of date. 888 cache_outdated <- (`anyM` confs) $ \conf -> 889 (tcache <) <$> getModificationTime conf 890 if not cache_outdated 891 then do 892 when (verbosity > Normal) $ 893 infoLn ("using cache: " ++ cache) 894 GhcPkg.readPackageDbForGhcPkg cache mode 895 >>= uncurry mkPackageDB 896 else do 897 whenReportCacheErrors $ do 898 warn ("WARNING: cache is out of date: " ++ cache) 899 warn ("ghc will see an old view of this " ++ 900 "package db. " ++ recacheAdvice) 901 ignore_cache $ \file -> do 902 when (verbosity >= Verbose) $ do 903 tFile <- getModificationTime file 904 let rel = case tcache `compare` tFile of 905 LT -> " (NEWER than cache)" 906 GT -> " (older than cache)" 907 EQ -> " (same as cache)" 908 warn ("Timestamp " ++ show tFile 909 ++ " for " ++ file ++ rel) 910 where 911 confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs 912 913 ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode) 914 ignore_cache checkTime = do 915 -- If we're opening for modification, we need to acquire a 916 -- lock even if we don't open the cache now, because we are 917 -- going to modify it later. 918 lock <- F.mapM (const $ GhcPkg.lockPackageDb cache) mode 919 let doFile f = do checkTime f 920 parseSingletonPackageConf verbosity f 921 pkgs <- mapM doFile confs 922 mkPackageDB pkgs lock 923 924 -- We normally report cache errors for read-only commands, 925 -- since modify commands will usually fix the cache. 926 whenReportCacheErrors = when $ verbosity > Normal 927 || verbosity >= Normal && GhcPkg.isDbOpenReadMode mode 928 where 929 cache = path </> cachefilename 930 931 recacheAdvice 932 | Just (user_conf, True) <- mb_user_conf, path == user_conf 933 = "Use 'ghc-pkg recache --user' to fix." 934 | otherwise 935 = "Use 'ghc-pkg recache' to fix." 936 937 mkPackageDB :: [InstalledPackageInfo] 938 -> GhcPkg.DbOpenMode mode GhcPkg.PackageDbLock 939 -> IO (PackageDB mode) 940 mkPackageDB pkgs lock = do 941 path_abs <- absolutePath path 942 return $ PackageDB { 943 location = path, 944 locationAbsolute = path_abs, 945 packageDbLock = lock, 946 packages = pkgs 947 } 948 949parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo 950parseSingletonPackageConf verbosity file = do 951 when (verbosity > Normal) $ infoLn ("reading package config: " ++ file) 952 BS.readFile file >>= fmap fst . parsePackageInfo 953 954cachefilename :: FilePath 955cachefilename = "package.cache" 956 957mungePackageDBPaths :: FilePath -> PackageDB mode -> PackageDB mode 958mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = 959 db { packages = map (mungePackagePaths top_dir pkgroot) pkgs } 960 where 961 pkgroot = takeDirectory $ dropTrailingPathSeparator (locationAbsolute db) 962 -- It so happens that for both styles of package db ("package.conf" 963 -- files and "package.conf.d" dirs) the pkgroot is the parent directory 964 -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/ 965 966-- TODO: This code is duplicated in compiler/main/Packages.hs 967mungePackagePaths :: FilePath -> FilePath 968 -> InstalledPackageInfo -> InstalledPackageInfo 969-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec 970-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) 971-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. 972-- The "pkgroot" is the directory containing the package database. 973-- 974-- Also perform a similar substitution for the older GHC-specific 975-- "$topdir" variable. The "topdir" is the location of the ghc 976-- installation (obtained from the -B option). 977mungePackagePaths top_dir pkgroot pkg = 978 pkg { 979 importDirs = munge_paths (importDirs pkg), 980 includeDirs = munge_paths (includeDirs pkg), 981 libraryDirs = munge_paths (libraryDirs pkg), 982 libraryDynDirs = munge_paths (libraryDynDirs pkg), 983 frameworkDirs = munge_paths (frameworkDirs pkg), 984 haddockInterfaces = munge_paths (haddockInterfaces pkg), 985 -- haddock-html is allowed to be either a URL or a file 986 haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg)) 987 } 988 where 989 munge_paths = map munge_path 990 munge_urls = map munge_url 991 992 munge_path p 993 | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' 994 | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' 995 | otherwise = p 996 997 munge_url p 998 | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' 999 | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' 1000 | otherwise = p 1001 1002 toUrlPath r p = "file:///" 1003 -- URLs always use posix style '/' separators: 1004 ++ FilePath.Posix.joinPath 1005 (r : -- We need to drop a leading "/" or "\\" 1006 -- if there is one: 1007 dropWhile (all isPathSeparator) 1008 (FilePath.splitDirectories p)) 1009 1010 -- We could drop the separator here, and then use </> above. However, 1011 -- by leaving it in and using ++ we keep the same path separator 1012 -- rather than letting FilePath change it to use \ as the separator 1013 stripVarPrefix var path = case stripPrefix var path of 1014 Just [] -> Just [] 1015 Just cs@(c : _) | isPathSeparator c -> Just cs 1016 _ -> Nothing 1017 1018 1019-- ----------------------------------------------------------------------------- 1020-- Workaround for old single-file style package dbs 1021 1022-- Single-file style package dbs have been deprecated for some time, but 1023-- it turns out that Cabal was using them in one place. So this code is for a 1024-- workaround to allow older Cabal versions to use this newer ghc. 1025 1026-- We check if the file db contains just "[]" and if so, we look for a new 1027-- dir-style db in path.d/, ie in a dir next to the given file. 1028-- We cannot just replace the file with a new dir style since Cabal still 1029-- assumes it's a file and tries to overwrite with 'writeFile'. 1030 1031-- ghc itself also cooperates in this workaround 1032 1033tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool) 1034 -> GhcPkg.DbOpenMode mode t -> Bool -> FilePath 1035 -> IO (Maybe (PackageDB mode)) 1036tryReadParseOldFileStyleDatabase verbosity mb_user_conf 1037 mode use_cache path = do 1038 -- assumes we've already established that path exists and is not a dir 1039 content <- readFile path `catchIO` \_ -> return "" 1040 if take 2 content == "[]" 1041 then do 1042 path_abs <- absolutePath path 1043 let path_dir = adjustOldDatabasePath path 1044 warn $ "Warning: ignoring old file-style db and trying " ++ path_dir 1045 direxists <- doesDirectoryExist path_dir 1046 if direxists 1047 then do 1048 db <- readParseDatabase verbosity mb_user_conf mode use_cache path_dir 1049 -- but pretend it was at the original location 1050 return $ Just db { 1051 location = path, 1052 locationAbsolute = path_abs 1053 } 1054 else do 1055 lock <- F.forM mode $ \_ -> do 1056 createDirectoryIfMissing True path_dir 1057 GhcPkg.lockPackageDb $ path_dir </> cachefilename 1058 return $ Just PackageDB { 1059 location = path, 1060 locationAbsolute = path_abs, 1061 packageDbLock = lock, 1062 packages = [] 1063 } 1064 1065 -- if the path is not a file, or is not an empty db then we fail 1066 else return Nothing 1067 1068adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode) 1069adjustOldFileStylePackageDB db = do 1070 -- assumes we have not yet established if it's an old style or not 1071 mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing 1072 case fmap (take 2) mcontent of 1073 -- it is an old style and empty db, so look for a dir kind in location.d/ 1074 Just "[]" -> return db { 1075 location = adjustOldDatabasePath $ location db, 1076 locationAbsolute = adjustOldDatabasePath $ locationAbsolute db 1077 } 1078 -- it is old style but not empty, we have to bail 1079 Just _ -> die $ "ghc no longer supports single-file style package " 1080 ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'" 1081 ++ "to create the database with the correct format." 1082 -- probably not old style, carry on as normal 1083 Nothing -> return db 1084 1085adjustOldDatabasePath :: FilePath -> FilePath 1086adjustOldDatabasePath = (<.> "d") 1087 1088-- ----------------------------------------------------------------------------- 1089-- Creating a new package DB 1090 1091initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO () 1092initPackageDB filename verbosity _flags = do 1093 let eexist = die ("cannot create: " ++ filename ++ " already exists") 1094 b1 <- doesFileExist filename 1095 when b1 eexist 1096 b2 <- doesDirectoryExist filename 1097 when b2 eexist 1098 createDirectoryIfMissing True filename 1099 lock <- GhcPkg.lockPackageDb $ filename </> cachefilename 1100 filename_abs <- absolutePath filename 1101 changeDB verbosity [] PackageDB { 1102 location = filename, 1103 locationAbsolute = filename_abs, 1104 packageDbLock = GhcPkg.DbOpenReadWrite lock, 1105 packages = [] 1106 } 1107 -- We can get away with passing an empty stack here, because the new DB is 1108 -- going to be initially empty, so no dependencies are going to be actually 1109 -- looked up. 1110 [] 1111 1112-- ----------------------------------------------------------------------------- 1113-- Registering 1114 1115registerPackage :: FilePath 1116 -> Verbosity 1117 -> [Flag] 1118 -> Bool -- multi_instance 1119 -> Bool -- expand_env_vars 1120 -> Bool -- update 1121 -> Force 1122 -> IO () 1123registerPackage input verbosity my_flags multi_instance 1124 expand_env_vars update force = do 1125 (db_stack, GhcPkg.DbOpenReadWrite db_to_operate_on, _flag_dbs) <- 1126 getPkgDatabases verbosity (GhcPkg.DbOpenReadWrite TopOne) 1127 True{-use user-} True{-use cache-} False{-expand vars-} my_flags 1128 1129 let to_modify = location db_to_operate_on 1130 1131 s <- 1132 case input of 1133 "-" -> do 1134 when (verbosity >= Normal) $ 1135 info "Reading package info from stdin ... " 1136 -- fix the encoding to UTF-8, since this is an interchange format 1137 hSetEncoding stdin utf8 1138 getContents 1139 f -> do 1140 when (verbosity >= Normal) $ 1141 info ("Reading package info from " ++ show f ++ " ... ") 1142 readUTF8File f 1143 1144 expanded <- if expand_env_vars then expandEnvVars s force 1145 else return s 1146 1147 (pkg, ws) <- parsePackageInfo $ toUTF8BS expanded 1148 when (verbosity >= Normal) $ 1149 infoLn "done." 1150 1151 -- report any warnings from the parse phase 1152 _ <- reportValidateErrors verbosity [] ws 1153 (display (mungedId pkg) ++ ": Warning: ") Nothing 1154 1155 -- validate the expanded pkg, but register the unexpanded 1156 pkgroot <- absolutePath (takeDirectory to_modify) 1157 let top_dir = takeDirectory (location (last db_stack)) 1158 pkg_expanded = mungePackagePaths top_dir pkgroot pkg 1159 1160 let truncated_stack = stackUpTo to_modify db_stack 1161 -- truncate the stack for validation, because we don't allow 1162 -- packages lower in the stack to refer to those higher up. 1163 validatePackageConfig pkg_expanded verbosity truncated_stack 1164 multi_instance update force 1165 1166 let 1167 -- In the normal mode, we only allow one version of each package, so we 1168 -- remove all instances with the same source package id as the one we're 1169 -- adding. In the multi instance mode we don't do that, thus allowing 1170 -- multiple instances with the same source package id. 1171 removes = [ RemovePackage p 1172 | not multi_instance, 1173 p <- packages db_to_operate_on, 1174 mungedId p == mungedId pkg, 1175 -- Only remove things that were instantiated the same way! 1176 instantiatedWith p == instantiatedWith pkg ] 1177 -- 1178 changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on db_stack 1179 1180parsePackageInfo 1181 :: BS.ByteString 1182 -> IO (InstalledPackageInfo, [ValidateWarning]) 1183parsePackageInfo str = 1184 case parseInstalledPackageInfo str of 1185 Right (warnings, ok) -> pure (mungePackageInfo ok, ws) 1186 where 1187 ws = [ msg | msg <- warnings 1188 , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ] 1189 Left err -> die (unlines (F.toList err)) 1190 1191mungePackageInfo :: InstalledPackageInfo -> InstalledPackageInfo 1192mungePackageInfo ipi = ipi 1193 1194-- ----------------------------------------------------------------------------- 1195-- Making changes to a package database 1196 1197data DBOp = RemovePackage InstalledPackageInfo 1198 | AddPackage InstalledPackageInfo 1199 | ModifyPackage InstalledPackageInfo 1200 1201changeDB :: Verbosity 1202 -> [DBOp] 1203 -> PackageDB 'GhcPkg.DbReadWrite 1204 -> PackageDBStack 1205 -> IO () 1206changeDB verbosity cmds db db_stack = do 1207 let db' = updateInternalDB db cmds 1208 db'' <- adjustOldFileStylePackageDB db' 1209 createDirectoryIfMissing True (location db'') 1210 changeDBDir verbosity cmds db'' db_stack 1211 1212updateInternalDB :: PackageDB 'GhcPkg.DbReadWrite 1213 -> [DBOp] -> PackageDB 'GhcPkg.DbReadWrite 1214updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds } 1215 where 1216 do_cmd pkgs (RemovePackage p) = 1217 filter ((/= installedUnitId p) . installedUnitId) pkgs 1218 do_cmd pkgs (AddPackage p) = p : pkgs 1219 do_cmd pkgs (ModifyPackage p) = 1220 do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p) 1221 1222 1223changeDBDir :: Verbosity 1224 -> [DBOp] 1225 -> PackageDB 'GhcPkg.DbReadWrite 1226 -> PackageDBStack 1227 -> IO () 1228changeDBDir verbosity cmds db db_stack = do 1229 mapM_ do_cmd cmds 1230 updateDBCache verbosity db db_stack 1231 where 1232 do_cmd (RemovePackage p) = do 1233 let file = location db </> display (installedUnitId p) <.> "conf" 1234 when (verbosity > Normal) $ infoLn ("removing " ++ file) 1235 removeFileSafe file 1236 do_cmd (AddPackage p) = do 1237 let file = location db </> display (installedUnitId p) <.> "conf" 1238 when (verbosity > Normal) $ infoLn ("writing " ++ file) 1239 writeUTF8File file (showInstalledPackageInfo p) 1240 do_cmd (ModifyPackage p) = 1241 do_cmd (AddPackage p) 1242 1243updateDBCache :: Verbosity 1244 -> PackageDB 'GhcPkg.DbReadWrite 1245 -> PackageDBStack 1246 -> IO () 1247updateDBCache verbosity db db_stack = do 1248 let filename = location db </> cachefilename 1249 db_stack_below = stackUpTo (location db) db_stack 1250 1251 pkgsCabalFormat :: [InstalledPackageInfo] 1252 pkgsCabalFormat = packages db 1253 1254 -- | All the packages we can legally depend on in this step. 1255 dependablePkgsCabalFormat :: [InstalledPackageInfo] 1256 dependablePkgsCabalFormat = allPackagesInStack db_stack_below 1257 1258 pkgsGhcCacheFormat :: [(PackageCacheFormat, Bool)] 1259 pkgsGhcCacheFormat 1260 -- See Note [Recompute abi-depends] 1261 = map (recomputeValidAbiDeps dependablePkgsCabalFormat) 1262 $ map convertPackageInfoToCacheFormat 1263 pkgsCabalFormat 1264 1265 hasAnyAbiDepends :: InstalledPackageInfo -> Bool 1266 hasAnyAbiDepends x = length (abiDepends x) > 0 1267 1268 -- warn when we find any (possibly-)bogus abi-depends fields; 1269 -- Note [Recompute abi-depends] 1270 when (verbosity >= Normal) $ do 1271 let definitelyBrokenPackages = 1272 nub 1273 . sort 1274 . map (unPackageName . GhcPkg.packageName . fst) 1275 . filter snd 1276 $ pkgsGhcCacheFormat 1277 when (definitelyBrokenPackages /= []) $ do 1278 warn "the following packages have broken abi-depends fields:" 1279 forM_ definitelyBrokenPackages $ \pkg -> 1280 warn $ " " ++ pkg 1281 when (verbosity > Normal) $ do 1282 let possiblyBrokenPackages = 1283 nub 1284 . sort 1285 . filter (not . (`elem` definitelyBrokenPackages)) 1286 . map (unPackageName . pkgName . packageId) 1287 . filter hasAnyAbiDepends 1288 $ pkgsCabalFormat 1289 when (possiblyBrokenPackages /= []) $ do 1290 warn $ 1291 "the following packages have correct abi-depends, " ++ 1292 "but may break in the future:" 1293 forM_ possiblyBrokenPackages $ \pkg -> 1294 warn $ " " ++ pkg 1295 1296 when (verbosity > Normal) $ 1297 infoLn ("writing cache " ++ filename) 1298 1299 GhcPkg.writePackageDb filename (map fst pkgsGhcCacheFormat) pkgsCabalFormat 1300 `catchIO` \e -> 1301 if isPermissionError e 1302 then die $ filename ++ ": you don't have permission to modify this file" 1303 else ioError e 1304 1305 case packageDbLock db of 1306 GhcPkg.DbOpenReadWrite lock -> GhcPkg.unlockPackageDb lock 1307 1308type PackageCacheFormat = GhcPkg.InstalledPackageInfo 1309 ComponentId 1310 PackageIdentifier 1311 PackageName 1312 UnitId 1313 OpenUnitId 1314 ModuleName 1315 OpenModule 1316 1317{- Note [Recompute abi-depends] 1318~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1319 1320Like most fields, `ghc-pkg` relies on who-ever is performing package 1321registration to fill in fields; this includes the `abi-depends` field present 1322for the package. 1323 1324However, this was likely a mistake, and is not very robust; in certain cases, 1325versions of Cabal may use bogus abi-depends fields for a package when doing 1326builds. Why? Because package database information is aggressively cached; it is 1327possible to work Cabal into a situation where it uses a cached version of 1328`abi-depends`, rather than the one in the actual database after it has been 1329recomputed. 1330 1331However, there is an easy fix: ghc-pkg /already/ knows the `abi-depends` of a 1332package, because they are the ABIs of the packages pointed at by the `depends` 1333field. So it can simply look up the abi from the dependencies in the original 1334database, and ignore whatever the system registering gave it. 1335 1336So, instead, we do two things here: 1337 1338 - We throw away the information for a registered package's `abi-depends` field. 1339 1340 - We recompute it: we simply look up the unit ID of the package in the original 1341 database, and use *its* abi-depends. 1342 1343See #14381, and Cabal issue #4728. 1344 1345Additionally, because we are throwing away the original (declared) ABI deps, we 1346return a boolean that indicates whether any abi-depends were actually 1347overridden. 1348 1349-} 1350 1351recomputeValidAbiDeps :: [InstalledPackageInfo] 1352 -> PackageCacheFormat 1353 -> (PackageCacheFormat, Bool) 1354recomputeValidAbiDeps db pkg = 1355 (pkg { GhcPkg.abiDepends = newAbiDeps }, abiDepsUpdated) 1356 where 1357 newAbiDeps = 1358 catMaybes . flip map (GhcPkg.abiDepends pkg) $ \(k, _) -> 1359 case filter (\d -> installedUnitId d == k) db of 1360 [x] -> Just (k, unAbiHash (abiHash x)) 1361 _ -> Nothing 1362 abiDepsUpdated = 1363 GhcPkg.abiDepends pkg /= newAbiDeps 1364 1365convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat 1366convertPackageInfoToCacheFormat pkg = 1367 GhcPkg.InstalledPackageInfo { 1368 GhcPkg.unitId = installedUnitId pkg, 1369 GhcPkg.componentId = installedComponentId pkg, 1370 GhcPkg.instantiatedWith = instantiatedWith pkg, 1371 GhcPkg.sourcePackageId = sourcePackageId pkg, 1372 GhcPkg.packageName = packageName pkg, 1373 GhcPkg.packageVersion = Version.Version (versionNumbers (packageVersion pkg)) [], 1374 GhcPkg.sourceLibName = 1375 fmap (mkPackageName . unUnqualComponentName) (libraryNameString $ sourceLibName pkg), 1376 GhcPkg.depends = depends pkg, 1377 GhcPkg.abiDepends = map (\(AbiDependency k v) -> (k,unAbiHash v)) (abiDepends pkg), 1378 GhcPkg.abiHash = unAbiHash (abiHash pkg), 1379 GhcPkg.importDirs = importDirs pkg, 1380 GhcPkg.hsLibraries = hsLibraries pkg, 1381 GhcPkg.extraLibraries = extraLibraries pkg, 1382 GhcPkg.extraGHCiLibraries = extraGHCiLibraries pkg, 1383 GhcPkg.libraryDirs = libraryDirs pkg, 1384 GhcPkg.libraryDynDirs = libraryDynDirs pkg, 1385 GhcPkg.frameworks = frameworks pkg, 1386 GhcPkg.frameworkDirs = frameworkDirs pkg, 1387 GhcPkg.ldOptions = ldOptions pkg, 1388 GhcPkg.ccOptions = ccOptions pkg, 1389 GhcPkg.includes = includes pkg, 1390 GhcPkg.includeDirs = includeDirs pkg, 1391 GhcPkg.haddockInterfaces = haddockInterfaces pkg, 1392 GhcPkg.haddockHTMLs = haddockHTMLs pkg, 1393 GhcPkg.exposedModules = map convertExposed (exposedModules pkg), 1394 GhcPkg.hiddenModules = hiddenModules pkg, 1395 GhcPkg.indefinite = indefinite pkg, 1396 GhcPkg.exposed = exposed pkg, 1397 GhcPkg.trusted = trusted pkg 1398 } 1399 where 1400 convertExposed (ExposedModule n reexport) = (n, reexport) 1401 1402instance GhcPkg.BinaryStringRep ComponentId where 1403 fromStringRep = mkComponentId . fromStringRep 1404 toStringRep = toStringRep . display 1405 1406instance GhcPkg.BinaryStringRep PackageName where 1407 fromStringRep = mkPackageName . fromStringRep 1408 toStringRep = toStringRep . display 1409 1410instance GhcPkg.BinaryStringRep PackageIdentifier where 1411 fromStringRep = fromMaybe (error "BinaryStringRep PackageIdentifier") 1412 . simpleParse . fromStringRep 1413 toStringRep = toStringRep . display 1414 1415instance GhcPkg.BinaryStringRep ModuleName where 1416 fromStringRep = ModuleName.fromString . fromStringRep 1417 toStringRep = toStringRep . display 1418 1419instance GhcPkg.BinaryStringRep String where 1420 fromStringRep = fromUTF8BS 1421 toStringRep = toUTF8BS 1422 1423instance GhcPkg.BinaryStringRep UnitId where 1424 fromStringRep = mkUnitId . fromStringRep 1425 toStringRep = toStringRep . display 1426 1427instance GhcPkg.DbUnitIdModuleRep UnitId ComponentId OpenUnitId ModuleName OpenModule where 1428 fromDbModule (GhcPkg.DbModule uid mod_name) = OpenModule uid mod_name 1429 fromDbModule (GhcPkg.DbModuleVar mod_name) = OpenModuleVar mod_name 1430 toDbModule (OpenModule uid mod_name) = GhcPkg.DbModule uid mod_name 1431 toDbModule (OpenModuleVar mod_name) = GhcPkg.DbModuleVar mod_name 1432 fromDbUnitId (GhcPkg.DbUnitId cid insts) = IndefFullUnitId cid (Map.fromList insts) 1433 fromDbUnitId (GhcPkg.DbInstalledUnitId uid) 1434 = DefiniteUnitId (unsafeMkDefUnitId uid) 1435 toDbUnitId (IndefFullUnitId cid insts) = GhcPkg.DbUnitId cid (Map.toList insts) 1436 toDbUnitId (DefiniteUnitId def_uid) 1437 = GhcPkg.DbInstalledUnitId (unDefUnitId def_uid) 1438 1439-- ----------------------------------------------------------------------------- 1440-- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar 1441 1442exposePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () 1443exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True}) 1444 1445hidePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () 1446hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False}) 1447 1448trustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () 1449trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True}) 1450 1451distrustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () 1452distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False}) 1453 1454unregisterPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () 1455unregisterPackage = modifyPackage RemovePackage 1456 1457modifyPackage 1458 :: (InstalledPackageInfo -> DBOp) 1459 -> PackageArg 1460 -> Verbosity 1461 -> [Flag] 1462 -> Force 1463 -> IO () 1464modifyPackage fn pkgarg verbosity my_flags force = do 1465 (db_stack, GhcPkg.DbOpenReadWrite db, _flag_dbs) <- 1466 getPkgDatabases verbosity (GhcPkg.DbOpenReadWrite $ ContainsPkg pkgarg) 1467 True{-use user-} True{-use cache-} False{-expand vars-} my_flags 1468 1469 let db_name = location db 1470 pkgs = packages db 1471 1472 -- Get package respecting flags... 1473 ps = findPackage pkgarg pkgs 1474 1475 -- This shouldn't happen if getPkgDatabases picks the DB correctly. 1476 when (null ps) $ cannotFindPackage pkgarg $ Just db 1477 1478 let pks = map installedUnitId ps 1479 1480 cmds = [ fn pkg | pkg <- pkgs, installedUnitId pkg `elem` pks ] 1481 new_db = updateInternalDB db cmds 1482 new_db_ro = new_db { packageDbLock = GhcPkg.DbOpenReadOnly } 1483 1484 -- ...but do consistency checks with regards to the full stack 1485 old_broken = brokenPackages (allPackagesInStack db_stack) 1486 rest_of_stack = filter ((/= db_name) . location) db_stack 1487 new_stack = new_db_ro : rest_of_stack 1488 new_broken = brokenPackages (allPackagesInStack new_stack) 1489 newly_broken = filter ((`notElem` map installedUnitId old_broken) 1490 . installedUnitId) new_broken 1491 -- 1492 let displayQualPkgId pkg 1493 | [_] <- filter ((== pkgid) . mungedId) 1494 (allPackagesInStack db_stack) 1495 = display pkgid 1496 | otherwise = display pkgid ++ "@" ++ display (installedUnitId pkg) 1497 where pkgid = mungedId pkg 1498 when (not (null newly_broken)) $ 1499 dieOrForceAll force ("unregistering would break the following packages: " 1500 ++ unwords (map displayQualPkgId newly_broken)) 1501 1502 changeDB verbosity cmds db db_stack 1503 1504recache :: Verbosity -> [Flag] -> IO () 1505recache verbosity my_flags = do 1506 (_db_stack, GhcPkg.DbOpenReadWrite db_to_operate_on, _flag_dbs) <- 1507 getPkgDatabases verbosity (GhcPkg.DbOpenReadWrite TopOne) 1508 True{-use user-} False{-no cache-} False{-expand vars-} my_flags 1509 changeDB verbosity [] db_to_operate_on _db_stack 1510 1511-- ----------------------------------------------------------------------------- 1512-- Listing packages 1513 1514listPackages :: Verbosity -> [Flag] -> Maybe PackageArg 1515 -> Maybe (String->Bool) 1516 -> IO () 1517listPackages verbosity my_flags mPackageName mModuleName = do 1518 let simple_output = FlagSimpleOutput `elem` my_flags 1519 (db_stack, GhcPkg.DbOpenReadOnly, flag_db_stack) <- 1520 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly 1521 False{-use user-} True{-use cache-} False{-expand vars-} my_flags 1522 1523 let db_stack_filtered -- if a package is given, filter out all other packages 1524 | Just this <- mPackageName = 1525 [ db{ packages = filter (this `matchesPkg`) (packages db) } 1526 | db <- flag_db_stack ] 1527 | Just match <- mModuleName = -- packages which expose mModuleName 1528 [ db{ packages = filter (match `exposedInPkg`) (packages db) } 1529 | db <- flag_db_stack ] 1530 | otherwise = flag_db_stack 1531 1532 db_stack_sorted 1533 = [ db{ packages = sort_pkgs (packages db) } 1534 | db <- db_stack_filtered ] 1535 where sort_pkgs = sortBy cmpPkgIds 1536 cmpPkgIds pkg1 pkg2 = 1537 case mungedName p1 `compare` mungedName p2 of 1538 LT -> LT 1539 GT -> GT 1540 EQ -> case mungedVersion p1 `compare` mungedVersion p2 of 1541 LT -> LT 1542 GT -> GT 1543 EQ -> installedUnitId pkg1 `compare` installedUnitId pkg2 1544 where (p1,p2) = (mungedId pkg1, mungedId pkg2) 1545 1546 stack = reverse db_stack_sorted 1547 1548 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) 1549 1550 pkg_map = allPackagesInStack db_stack 1551 broken = map installedUnitId (brokenPackages pkg_map) 1552 1553 show_normal PackageDB{ location = db_name, packages = pkg_confs } = 1554 do hPutStrLn stdout db_name 1555 if null pkg_confs 1556 then hPutStrLn stdout " (no packages)" 1557 else hPutStrLn stdout $ unlines (map (" " ++) (map pp_pkg pkg_confs)) 1558 where 1559 pp_pkg p 1560 | installedUnitId p `elem` broken = printf "{%s}" doc 1561 | exposed p = doc 1562 | otherwise = printf "(%s)" doc 1563 where doc | verbosity >= Verbose = printf "%s (%s)" pkg (display (installedUnitId p)) 1564 | otherwise = pkg 1565 where 1566 pkg = display (mungedId p) 1567 1568 show_simple = simplePackageList my_flags . allPackagesInStack 1569 1570 when (not (null broken) && not simple_output && verbosity /= Silent) $ do 1571 prog <- getProgramName 1572 warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.") 1573 1574 if simple_output then show_simple stack else do 1575 1576#if !defined(WITH_TERMINFO) 1577 mapM_ show_normal stack 1578#else 1579 let 1580 show_colour withF db@PackageDB{ packages = pkg_confs } = 1581 if null pkg_confs 1582 then termText (location db) <#> termText "\n (no packages)\n" 1583 else 1584 mconcat $ map (<#> termText "\n") $ 1585 (termText (location db) 1586 : map (termText " " <#>) (map pp_pkg pkg_confs)) 1587 where 1588 pp_pkg p 1589 | installedUnitId p `elem` broken = withF Red doc 1590 | exposed p = doc 1591 | otherwise = withF Blue doc 1592 where doc | verbosity >= Verbose 1593 = termText (printf "%s (%s)" pkg (display (installedUnitId p))) 1594 | otherwise 1595 = termText pkg 1596 where 1597 pkg = display (mungedId p) 1598 1599 is_tty <- hIsTerminalDevice stdout 1600 if not is_tty 1601 then mapM_ show_normal stack 1602 else do tty <- Terminfo.setupTermFromEnv 1603 case Terminfo.getCapability tty withForegroundColor of 1604 Nothing -> mapM_ show_normal stack 1605 Just w -> runTermOutput tty $ mconcat $ 1606 map (show_colour w) stack 1607#endif 1608 1609simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () 1610simplePackageList my_flags pkgs = do 1611 let showPkg :: InstalledPackageInfo -> String 1612 showPkg | FlagShowUnitIds `elem` my_flags = display . installedUnitId 1613 | FlagNamesOnly `elem` my_flags = display . mungedName . mungedId 1614 | otherwise = display . mungedId 1615 strs = map showPkg pkgs 1616 when (not (null pkgs)) $ 1617 hPutStrLn stdout $ concat $ intersperse " " strs 1618 1619showPackageDot :: Verbosity -> [Flag] -> IO () 1620showPackageDot verbosity myflags = do 1621 (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <- 1622 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly 1623 False{-use user-} True{-use cache-} False{-expand vars-} myflags 1624 1625 let all_pkgs = allPackagesInStack flag_db_stack 1626 ipix = PackageIndex.fromList all_pkgs 1627 1628 putStrLn "digraph {" 1629 let quote s = '"':s ++ "\"" 1630 mapM_ putStrLn [ quote from ++ " -> " ++ quote to 1631 | p <- all_pkgs, 1632 let from = display (mungedId p), 1633 key <- depends p, 1634 Just dep <- [PackageIndex.lookupUnitId ipix key], 1635 let to = display (mungedId dep) 1636 ] 1637 putStrLn "}" 1638 1639-- ----------------------------------------------------------------------------- 1640-- Prints the highest (hidden or exposed) version of a package 1641 1642-- ToDo: This is no longer well-defined with unit ids, because the 1643-- dependencies may be varying versions 1644latestPackage :: Verbosity -> [Flag] -> GlobPackageIdentifier -> IO () 1645latestPackage verbosity my_flags pkgid = do 1646 (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <- 1647 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly 1648 False{-use user-} True{-use cache-} False{-expand vars-} my_flags 1649 1650 ps <- findPackages flag_db_stack (Id pkgid) 1651 case ps of 1652 [] -> die "no matches" 1653 _ -> show_pkg . maximum . map mungedId $ ps 1654 where 1655 show_pkg pid = hPutStrLn stdout (display pid) 1656 1657-- ----------------------------------------------------------------------------- 1658-- Describe 1659 1660describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO () 1661describePackage verbosity my_flags pkgarg expand_pkgroot = do 1662 (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <- 1663 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly 1664 False{-use user-} True{-use cache-} expand_pkgroot my_flags 1665 dbs <- findPackagesByDB flag_db_stack pkgarg 1666 doDump expand_pkgroot [ (pkg, locationAbsolute db) 1667 | (db, pkgs) <- dbs, pkg <- pkgs ] 1668 1669dumpPackages :: Verbosity -> [Flag] -> Bool -> IO () 1670dumpPackages verbosity my_flags expand_pkgroot = do 1671 (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <- 1672 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly 1673 False{-use user-} True{-use cache-} expand_pkgroot my_flags 1674 doDump expand_pkgroot [ (pkg, locationAbsolute db) 1675 | db <- flag_db_stack, pkg <- packages db ] 1676 1677doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO () 1678doDump expand_pkgroot pkgs = do 1679 -- fix the encoding to UTF-8, since this is an interchange format 1680 hSetEncoding stdout utf8 1681 putStrLn $ 1682 intercalate "---\n" 1683 [ if expand_pkgroot 1684 then showInstalledPackageInfo pkg 1685 else showInstalledPackageInfo pkg ++ pkgrootField 1686 | (pkg, pkgloc) <- pkgs 1687 , let pkgroot = takeDirectory pkgloc 1688 pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ] 1689 1690-- PackageId is can have globVersion for the version 1691findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] 1692findPackages db_stack pkgarg 1693 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg 1694 1695findPackage :: PackageArg -> [InstalledPackageInfo] -> [InstalledPackageInfo] 1696findPackage pkgarg pkgs = filter (pkgarg `matchesPkg`) pkgs 1697 1698findPackagesByDB :: PackageDBStack -> PackageArg 1699 -> IO [(PackageDB 'GhcPkg.DbReadOnly, [InstalledPackageInfo])] 1700findPackagesByDB db_stack pkgarg 1701 = case [ (db, matched) 1702 | db <- db_stack, 1703 let matched = findPackage pkgarg $ packages db, 1704 not (null matched) ] of 1705 [] -> cannotFindPackage pkgarg Nothing 1706 ps -> return ps 1707 1708cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> IO a 1709cannotFindPackage pkgarg mdb = die $ "cannot find package " ++ pkg_msg pkgarg 1710 ++ maybe "" (\db -> " in " ++ location db) mdb 1711 where 1712 pkg_msg (Id pkgid) = displayGlobPkgId pkgid 1713 pkg_msg (IUId ipid) = display ipid 1714 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat 1715 1716matches :: GlobPackageIdentifier -> MungedPackageId -> Bool 1717GlobPackageIdentifier pn `matches` pid' 1718 = (pn == mungedName pid') 1719ExactPackageIdentifier pid `matches` pid' 1720 = mungedName pid == mungedName pid' && 1721 (mungedVersion pid == mungedVersion pid' || mungedVersion pid == nullVersion) 1722 1723matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool 1724(Id pid) `matchesPkg` pkg = pid `matches` mungedId pkg 1725(IUId ipid) `matchesPkg` pkg = ipid == installedUnitId pkg 1726(Substring _ m) `matchesPkg` pkg = m (display (mungedId pkg)) 1727 1728-- ----------------------------------------------------------------------------- 1729-- Field 1730 1731describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO () 1732describeField verbosity my_flags pkgarg fields expand_pkgroot = do 1733 (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <- 1734 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly 1735 False{-use user-} True{-use cache-} expand_pkgroot my_flags 1736 fns <- mapM toField fields 1737 ps <- findPackages flag_db_stack pkgarg 1738 mapM_ (selectFields fns) ps 1739 where showFun = if FlagSimpleOutput `elem` my_flags 1740 then showSimpleInstalledPackageInfoField 1741 else showInstalledPackageInfoField 1742 toField f = case showFun f of 1743 Nothing -> die ("unknown field: " ++ f) 1744 Just fn -> return fn 1745 selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns 1746 1747 1748-- ----------------------------------------------------------------------------- 1749-- Check: Check consistency of installed packages 1750 1751checkConsistency :: Verbosity -> [Flag] -> IO () 1752checkConsistency verbosity my_flags = do 1753 (db_stack, GhcPkg.DbOpenReadOnly, _) <- 1754 getPkgDatabases verbosity GhcPkg.DbOpenReadOnly 1755 True{-use user-} True{-use cache-} True{-expand vars-} my_flags 1756 -- although check is not a modify command, we do need to use the user 1757 -- db, because we may need it to verify package deps. 1758 1759 let simple_output = FlagSimpleOutput `elem` my_flags 1760 let unitid_output = FlagShowUnitIds `elem` my_flags 1761 1762 let pkgs = allPackagesInStack db_stack 1763 1764 checkPackage :: InstalledPackageInfo -> IO [InstalledPackageInfo] 1765 checkPackage p = do 1766 (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack 1767 True True 1768 if null es 1769 then do 1770 when (not simple_output) $ do 1771 _ <- reportValidateErrors verbosity [] ws "" Nothing 1772 return () 1773 return [] 1774 else do 1775 when (not simple_output) $ do 1776 reportError ("There are problems in package " ++ display (mungedId p) ++ ":") 1777 _ <- reportValidateErrors verbosity es ws " " Nothing 1778 return () 1779 return [p] 1780 1781 broken_pkgs <- concat `fmap` mapM checkPackage pkgs 1782 1783 let filterOut pkgs1 pkgs2 = filter not_in pkgs2 1784 where not_in p = mungedId p `notElem` all_ps 1785 all_ps = map mungedId pkgs1 1786 1787 let not_broken_pkgs = filterOut broken_pkgs pkgs 1788 (_, trans_broken_pkgs) = closure [] not_broken_pkgs 1789 1790 all_broken_pkgs :: [InstalledPackageInfo] 1791 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs 1792 1793 when (not (null all_broken_pkgs)) $ do 1794 if simple_output 1795 then simplePackageList my_flags all_broken_pkgs 1796 else do 1797 let disp :: InstalledPackageInfo -> String 1798 disp | unitid_output = display . installedUnitId 1799 | otherwise = display . mungedId 1800 reportError ("\nThe following packages are broken, either because they have a problem\n"++ 1801 "listed above, or because they depend on a broken package.") 1802 mapM_ (hPutStrLn stderr . disp) all_broken_pkgs 1803 1804 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1) 1805 1806 1807closure :: [InstalledPackageInfo] -> [InstalledPackageInfo] 1808 -> ([InstalledPackageInfo], [InstalledPackageInfo]) 1809closure pkgs db_stack = go pkgs db_stack 1810 where 1811 go avail not_avail = 1812 case partition (depsAvailable avail) not_avail of 1813 ([], not_avail') -> (avail, not_avail') 1814 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' 1815 1816 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo 1817 -> Bool 1818 depsAvailable pkgs_ok pkg = null dangling 1819 where dangling = filter (`notElem` pids) (depends pkg) 1820 pids = map installedUnitId pkgs_ok 1821 1822 -- we want mutually recursive groups of package to show up 1823 -- as broken. (#1750) 1824 1825brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] 1826brokenPackages pkgs = snd (closure [] pkgs) 1827 1828----------------------------------------------------------------------------- 1829-- Sanity-check a new package config, and automatically build GHCi libs 1830-- if requested. 1831 1832type ValidateError = (Force,String) 1833type ValidateWarning = String 1834 1835newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) } 1836 1837instance Functor Validate where 1838 fmap = liftM 1839 1840instance Applicative Validate where 1841 pure a = V $ pure (a, [], []) 1842 (<*>) = ap 1843 1844instance Monad Validate where 1845 m >>= k = V $ do 1846 (a, es, ws) <- runValidate m 1847 (b, es', ws') <- runValidate (k a) 1848 return (b,es++es',ws++ws') 1849 1850verror :: Force -> String -> Validate () 1851verror f s = V (return ((),[(f,s)],[])) 1852 1853vwarn :: String -> Validate () 1854vwarn s = V (return ((),[],["Warning: " ++ s])) 1855 1856liftIO :: IO a -> Validate a 1857liftIO k = V (k >>= \a -> return (a,[],[])) 1858 1859-- returns False if we should die 1860reportValidateErrors :: Verbosity -> [ValidateError] -> [ValidateWarning] 1861 -> String -> Maybe Force -> IO Bool 1862reportValidateErrors verbosity es ws prefix mb_force = do 1863 when (verbosity >= Normal) $ mapM_ (warn . (prefix++)) ws 1864 oks <- mapM report es 1865 return (and oks) 1866 where 1867 report (f,s) 1868 | Just force <- mb_force 1869 = if (force >= f) 1870 then do when (verbosity >= Normal) $ 1871 reportError (prefix ++ s ++ " (ignoring)") 1872 return True 1873 else if f < CannotForce 1874 then do reportError (prefix ++ s ++ " (use --force to override)") 1875 return False 1876 else do reportError err 1877 return False 1878 | otherwise = do reportError err 1879 return False 1880 where 1881 err = prefix ++ s 1882 1883validatePackageConfig :: InstalledPackageInfo 1884 -> Verbosity 1885 -> PackageDBStack 1886 -> Bool -- multi_instance 1887 -> Bool -- update, or check 1888 -> Force 1889 -> IO () 1890validatePackageConfig pkg verbosity db_stack 1891 multi_instance update force = do 1892 (_,es,ws) <- runValidate $ 1893 checkPackageConfig pkg verbosity db_stack 1894 multi_instance update 1895 ok <- reportValidateErrors verbosity es ws 1896 (display (mungedId pkg) ++ ": ") (Just force) 1897 when (not ok) $ exitWith (ExitFailure 1) 1898 1899checkPackageConfig :: InstalledPackageInfo 1900 -> Verbosity 1901 -> PackageDBStack 1902 -> Bool -- multi_instance 1903 -> Bool -- update, or check 1904 -> Validate () 1905checkPackageConfig pkg verbosity db_stack 1906 multi_instance update = do 1907 checkPackageId pkg 1908 checkUnitId pkg db_stack update 1909 checkDuplicates db_stack pkg multi_instance update 1910 mapM_ (checkDep db_stack) (depends pkg) 1911 checkDuplicateDepends (depends pkg) 1912 mapM_ (checkDir False "import-dirs") (importDirs pkg) 1913 mapM_ (checkDir True "library-dirs") (libraryDirs pkg) 1914 mapM_ (checkDir True "dynamic-library-dirs") (libraryDynDirs pkg) 1915 mapM_ (checkDir True "include-dirs") (includeDirs pkg) 1916 mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg) 1917 mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg) 1918 mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg) 1919 checkDuplicateModules pkg 1920 checkExposedModules db_stack pkg 1921 checkOtherModules pkg 1922 let has_code = Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith pkg))) 1923 when has_code $ mapM_ (checkHSLib verbosity (libraryDirs pkg ++ libraryDynDirs pkg)) (hsLibraries pkg) 1924 -- ToDo: check these somehow? 1925 -- extra_libraries :: [String], 1926 -- c_includes :: [String], 1927 1928-- When the package name and version are put together, sometimes we can 1929-- end up with a package id that cannot be parsed. This will lead to 1930-- difficulties when the user wants to refer to the package later, so 1931-- we check that the package id can be parsed properly here. 1932checkPackageId :: InstalledPackageInfo -> Validate () 1933checkPackageId ipi = 1934 let str = display (mungedId ipi) in 1935 case Cabal.eitherParsec str :: Either String MungedPackageId of 1936 Left e -> verror CannotForce ("invalid package identifier: '" ++ str ++ "': " ++ e) 1937 Right _ -> pure () 1938 1939checkUnitId :: InstalledPackageInfo -> PackageDBStack -> Bool 1940 -> Validate () 1941checkUnitId ipi db_stack update = do 1942 let uid = installedUnitId ipi 1943 when (null (display uid)) $ verror CannotForce "missing id field" 1944 when (display uid /= compatPackageKey ipi) $ 1945 verror CannotForce $ "installed package info from too old version of Cabal " 1946 ++ "(key field does not match id field)" 1947 let dups = [ p | p <- allPackagesInStack db_stack, 1948 installedUnitId p == uid ] 1949 when (not update && not (null dups)) $ 1950 verror CannotForce $ 1951 "package(s) with this id already exist: " ++ 1952 unwords (map (display.installedUnitId) dups) 1953 1954checkDuplicates :: PackageDBStack -> InstalledPackageInfo 1955 -> Bool -> Bool-> Validate () 1956checkDuplicates db_stack pkg multi_instance update = do 1957 let 1958 pkgid = mungedId pkg 1959 pkgs = packages (head db_stack) 1960 -- 1961 -- Check whether this package id already exists in this DB 1962 -- 1963 when (not update && not multi_instance 1964 && (pkgid `elem` map mungedId pkgs)) $ 1965 verror CannotForce $ 1966 "package " ++ display pkgid ++ " is already installed" 1967 1968 let 1969 uncasep = map toLower . display 1970 dups = filter ((== uncasep pkgid) . uncasep) (map mungedId pkgs) 1971 1972 when (not update && not multi_instance 1973 && not (null dups)) $ verror ForceAll $ 1974 "Package names may be treated case-insensitively in the future.\n"++ 1975 "Package " ++ display pkgid ++ 1976 " overlaps with: " ++ unwords (map display dups) 1977 1978checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate () 1979checkDir = checkPath False True 1980checkFile = checkPath False False 1981checkDirURL = checkPath True True 1982 1983checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate () 1984checkPath url_ok is_dir warn_only thisfield d 1985 | url_ok && ("http://" `isPrefixOf` d 1986 || "https://" `isPrefixOf` d) = return () 1987 1988 | url_ok 1989 , Just d' <- stripPrefix "file://" d 1990 = checkPath False is_dir warn_only thisfield d' 1991 1992 -- Note: we don't check for $topdir/${pkgroot} here. We rely on these 1993 -- variables having been expanded already, see mungePackagePaths. 1994 1995 | isRelative d = verror ForceFiles $ 1996 thisfield ++ ": " ++ d ++ " is a relative path which " 1997 ++ "makes no sense (as there is nothing for it to be " 1998 ++ "relative to). You can make paths relative to the " 1999 ++ "package database itself by using ${pkgroot}." 2000 -- relative paths don't make any sense; #4134 2001 | otherwise = do 2002 there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d 2003 when (not there) $ 2004 let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a " 2005 ++ if is_dir then "directory" else "file" 2006 in 2007 if warn_only 2008 then vwarn msg 2009 else verror ForceFiles msg 2010 2011checkDep :: PackageDBStack -> UnitId -> Validate () 2012checkDep db_stack pkgid 2013 | pkgid `elem` pkgids = return () 2014 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid 2015 ++ "\" doesn't exist") 2016 where 2017 all_pkgs = allPackagesInStack db_stack 2018 pkgids = map installedUnitId all_pkgs 2019 2020checkDuplicateDepends :: [UnitId] -> Validate () 2021checkDuplicateDepends deps 2022 | null dups = return () 2023 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++ 2024 unwords (map display dups)) 2025 where 2026 dups = [ p | (p:_:_) <- group (sort deps) ] 2027 2028checkHSLib :: Verbosity -> [String] -> String -> Validate () 2029checkHSLib _verbosity dirs lib = do 2030 let filenames = ["lib" ++ lib ++ ".a", 2031 "lib" ++ lib ++ "_p.a", 2032 "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".so", 2033 "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib", 2034 lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll"] 2035 b <- liftIO $ doesFileExistOnPath filenames dirs 2036 when (not b) $ 2037 verror ForceFiles ("cannot find any of " ++ show filenames ++ 2038 " on library path") 2039 2040doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO Bool 2041doesFileExistOnPath filenames paths = anyM doesFileExist fullFilenames 2042 where fullFilenames = [ path </> filename 2043 | filename <- filenames 2044 , path <- paths ] 2045 2046-- | Perform validation checks (module file existence checks) on the 2047-- @hidden-modules@ field. 2048checkOtherModules :: InstalledPackageInfo -> Validate () 2049checkOtherModules pkg = mapM_ (checkModuleFile pkg) (hiddenModules pkg) 2050 2051-- | Perform validation checks (module file existence checks and module 2052-- reexport checks) on the @exposed-modules@ field. 2053checkExposedModules :: PackageDBStack -> InstalledPackageInfo -> Validate () 2054checkExposedModules db_stack pkg = 2055 mapM_ checkExposedModule (exposedModules pkg) 2056 where 2057 checkExposedModule (ExposedModule modl reexport) = do 2058 let checkOriginal = checkModuleFile pkg modl 2059 checkReexport = checkModule "module reexport" db_stack pkg 2060 maybe checkOriginal checkReexport reexport 2061 2062-- | Validates the existence of an appropriate @hi@ file associated with 2063-- a module. Used for both @hidden-modules@ and @exposed-modules@ which 2064-- are not reexports. 2065checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate () 2066checkModuleFile pkg modl = 2067 -- there's no interface file for GHC.Prim 2068 unless (modl == ModuleName.fromString "GHC.Prim") $ do 2069 let files = [ ModuleName.toFilePath modl <.> extension 2070 | extension <- ["hi", "p_hi", "dyn_hi" ] ] 2071 b <- liftIO $ doesFileExistOnPath files (importDirs pkg) 2072 when (not b) $ 2073 verror ForceFiles ("cannot find any of " ++ show files) 2074 2075-- | Validates that @exposed-modules@ and @hidden-modules@ do not have duplicate 2076-- entries. 2077-- ToDo: this needs updating for signatures: signatures can validly show up 2078-- multiple times in the @exposed-modules@ list as long as their backing 2079-- implementations agree. 2080checkDuplicateModules :: InstalledPackageInfo -> Validate () 2081checkDuplicateModules pkg 2082 | null dups = return () 2083 | otherwise = verror ForceAll ("package has duplicate modules: " ++ 2084 unwords (map display dups)) 2085 where 2086 dups = [ m | (m:_:_) <- group (sort mods) ] 2087 mods = map exposedName (exposedModules pkg) ++ hiddenModules pkg 2088 2089-- | Validates an original module entry, either the origin of a module reexport 2090-- or the backing implementation of a signature, by checking that it exists, 2091-- really is an original definition, and is accessible from the dependencies of 2092-- the package. 2093-- ToDo: If the original module in question is a backing signature 2094-- implementation, then we should also check that the original module in 2095-- question is NOT a signature (however, if it is a reexport, then it's fine 2096-- for the original module to be a signature.) 2097checkModule :: String 2098 -> PackageDBStack 2099 -> InstalledPackageInfo 2100 -> OpenModule 2101 -> Validate () 2102checkModule _ _ _ (OpenModuleVar _) = error "Impermissible reexport" 2103checkModule field_name db_stack pkg 2104 (OpenModule (DefiniteUnitId def_uid) definingModule) = 2105 let definingPkgId = unDefUnitId def_uid 2106 mpkg = if definingPkgId == installedUnitId pkg 2107 then Just pkg 2108 else PackageIndex.lookupUnitId ipix definingPkgId 2109 in case mpkg of 2110 Nothing 2111 -> verror ForceAll (field_name ++ " refers to a non-existent " ++ 2112 "defining package: " ++ 2113 display definingPkgId) 2114 2115 Just definingPkg 2116 | not (isIndirectDependency definingPkgId) 2117 -> verror ForceAll (field_name ++ " refers to a defining " ++ 2118 "package that is not a direct (or indirect) " ++ 2119 "dependency of this package: " ++ 2120 display definingPkgId) 2121 2122 | otherwise 2123 -> case find ((==definingModule).exposedName) 2124 (exposedModules definingPkg) of 2125 Nothing -> 2126 verror ForceAll (field_name ++ " refers to a module " ++ 2127 display definingModule ++ " " ++ 2128 "that is not exposed in the " ++ 2129 "defining package " ++ display definingPkgId) 2130 Just (ExposedModule {exposedReexport = Just _} ) -> 2131 verror ForceAll (field_name ++ " refers to a module " ++ 2132 display definingModule ++ " " ++ 2133 "that is reexported but not defined in the " ++ 2134 "defining package " ++ display definingPkgId) 2135 _ -> return () 2136 where 2137 all_pkgs = allPackagesInStack db_stack 2138 ipix = PackageIndex.fromList all_pkgs 2139 2140 isIndirectDependency pkgid = fromMaybe False $ do 2141 thispkg <- graphVertex (installedUnitId pkg) 2142 otherpkg <- graphVertex pkgid 2143 return (Graph.path depgraph thispkg otherpkg) 2144 (depgraph, _, graphVertex) = 2145 PackageIndex.dependencyGraph (PackageIndex.insert pkg ipix) 2146 2147checkModule _ _ _ (OpenModule (IndefFullUnitId _ _) _) = 2148 -- TODO: add some checks here 2149 return () 2150 2151 2152-- --------------------------------------------------------------------------- 2153-- expanding environment variables in the package configuration 2154 2155expandEnvVars :: String -> Force -> IO String 2156expandEnvVars str0 force = go str0 "" 2157 where 2158 go "" acc = return $! reverse acc 2159 go ('$':'{':str) acc | (var, '}':rest) <- break close str 2160 = do value <- lookupEnvVar var 2161 go rest (reverse value ++ acc) 2162 where close c = c == '}' || c == '\n' -- don't span newlines 2163 go (c:str) acc 2164 = go str (c:acc) 2165 2166 lookupEnvVar :: String -> IO String 2167 lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special, 2168 lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them 2169 lookupEnvVar nm = 2170 catchIO (System.Environment.getEnv nm) 2171 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ 2172 show nm) 2173 return "") 2174 2175----------------------------------------------------------------------------- 2176 2177getProgramName :: IO String 2178getProgramName = liftM (`withoutSuffix` ".bin") getProgName 2179 where str `withoutSuffix` suff 2180 | suff `isSuffixOf` str = take (length str - length suff) str 2181 | otherwise = str 2182 2183bye :: String -> IO a 2184bye s = putStr s >> exitWith ExitSuccess 2185 2186die :: String -> IO a 2187die = dieWith 1 2188 2189dieWith :: Int -> String -> IO a 2190dieWith ec s = do 2191 prog <- getProgramName 2192 reportError (prog ++ ": " ++ s) 2193 exitWith (ExitFailure ec) 2194 2195dieOrForceAll :: Force -> String -> IO () 2196dieOrForceAll ForceAll s = ignoreError s 2197dieOrForceAll _other s = dieForcible s 2198 2199warn :: String -> IO () 2200warn = reportError 2201 2202-- send info messages to stdout 2203infoLn :: String -> IO () 2204infoLn = putStrLn 2205 2206info :: String -> IO () 2207info = putStr 2208 2209ignoreError :: String -> IO () 2210ignoreError s = reportError (s ++ " (ignoring)") 2211 2212reportError :: String -> IO () 2213reportError s = do hFlush stdout; hPutStrLn stderr s 2214 2215dieForcible :: String -> IO () 2216dieForcible s = die (s ++ " (use --force to override)") 2217 2218----------------------------------------- 2219-- Adapted from ghc/compiler/utils/Panic 2220 2221installSignalHandlers :: IO () 2222installSignalHandlers = do 2223 threadid <- myThreadId 2224 let 2225 interrupt = Exception.throwTo threadid 2226 (Exception.ErrorCall "interrupted") 2227 -- 2228#if !defined(mingw32_HOST_OS) 2229 _ <- installHandler sigQUIT (Catch interrupt) Nothing 2230 _ <- installHandler sigINT (Catch interrupt) Nothing 2231 return () 2232#else 2233 -- GHC 6.3+ has support for console events on Windows 2234 -- NOTE: running GHCi under a bash shell for some reason requires 2235 -- you to press Ctrl-Break rather than Ctrl-C to provoke 2236 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know 2237 -- why --SDM 17/12/2004 2238 let sig_handler ControlC = interrupt 2239 sig_handler Break = interrupt 2240 sig_handler _ = return () 2241 2242 _ <- installHandler (Catch sig_handler) 2243 return () 2244#endif 2245 2246catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a 2247catchIO = Exception.catch 2248 2249tryIO :: IO a -> IO (Either Exception.IOException a) 2250tryIO = Exception.try 2251 2252-- removeFileSave doesn't throw an exceptions, if the file is already deleted 2253removeFileSafe :: FilePath -> IO () 2254removeFileSafe fn = 2255 removeFile fn `catchIO` \ e -> 2256 when (not $ isDoesNotExistError e) $ ioError e 2257 2258-- | Turn a path relative to the current directory into a (normalised) 2259-- absolute path. 2260absolutePath :: FilePath -> IO FilePath 2261absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory 2262