utils/ghc-pkg/Main.hs

   1 {-# OPTIONS -fglasgow-exts -cpp #-}
   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 qualified Distribution.Simple.PackageIndex as PackageIndex
  14 import Distribution.ModuleName hiding (main)
  15 import Distribution.InstalledPackageInfo
  16 import Distribution.Compat.ReadP
  17 import Distribution.ParseUtils
  18 import Distribution.Package hiding (depends)
  19 import Distribution.Text
  20 import Distribution.Version
  21 import System.FilePath
  22 import System.Cmd       ( rawSystem )
  23 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
  24
  25 import Prelude
  26
  27 #include "../../includes/ghcconfig.h"
  28
  29 import System.Console.GetOpt
  30 import Text.PrettyPrint
  31 #if __GLASGOW_HASKELL__ >= 609
  32 import qualified Control.Exception as Exception
  33 #else
  34 import qualified Control.Exception.Extensible as Exception
  35 #endif
  36 import Data.Maybe
  37
  38 import Data.Char ( isSpace, toLower )
  39 import Control.Monad
  40 import System.Directory ( doesDirectoryExist, getDirectoryContents,
  41                           doesFileExist, renameFile, removeFile )
  42 import System.Exit ( exitWith, ExitCode(..) )
  43 import System.Environment ( getArgs, getProgName, getEnv )
  44 import System.IO
  45 import System.IO.Error (try)
  46 import Data.List
  47 import Control.Concurrent
  48
  49 import Foreign
  50 import Foreign.C
  51 #ifdef mingw32_HOST_OS
  52 import GHC.ConsoleHandler
  53 #else
  54 import System.Posix hiding (fdToHandle)
  55 #endif
  56
  57 import IO ( isPermissionError )
  58 import System.Posix.Internals
  59 #if __GLASGOW_HASKELL__ >= 611
  60 import GHC.IO.Handle.FD (fdToHandle)
  61 #else
  62 import GHC.Handle (fdToHandle)
  63 #endif
  64
  65 #if defined(GLOB)
  66 import System.Process(runInteractiveCommand)
  67 import qualified System.Info(os)
  68 #endif
  69
  70 -- -----------------------------------------------------------------------------
  71 -- Entry point
  72
  73 main :: IO ()
  74 main = do
  75   args <- getArgs
  76
  77   case getOpt Permute (flags ++ deprecFlags) args of
  78         (cli,_,[]) | FlagHelp `elem` cli -> do
  79            prog <- getProgramName
  80            bye (usageInfo (usageHeader prog) flags)
  81         (cli,_,[]) | FlagVersion `elem` cli ->
  82            bye ourCopyright
  83         (cli,nonopts,[]) ->
  84            case getVerbosity Normal cli of
  85            Right v -> runit v cli nonopts
  86            Left err -> die err
  87         (_,_,errors) -> do
  88            prog <- getProgramName
  89            die (concat errors ++ usageInfo (usageHeader prog) flags)
  90
  91 -- -----------------------------------------------------------------------------
  92 -- Command-line syntax
  93
  94 data Flag
  95   = FlagUser
  96   | FlagGlobal
  97   | FlagHelp
  98   | FlagVersion
  99   | FlagConfig FilePath
 100   | FlagGlobalConfig FilePath
 101   | FlagForce
 102   | FlagForceFiles
 103   | FlagAutoGHCiLibs
 104   | FlagSimpleOutput
 105   | FlagNamesOnly
 106   | FlagIgnoreCase
 107   | FlagNoUserDb
 108   | FlagVerbosity (Maybe String)
 109   deriving Eq
 110
 111 flags :: [OptDescr Flag]
 112 flags = [
 113   Option [] ["user"] (NoArg FlagUser)
 114         "use the current user's package database",
 115   Option [] ["global"] (NoArg FlagGlobal)
 116         "use the global package database",
 117   Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
 118         "use the specified package config file",
 119   Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
 120         "location of the global package config",
 121   Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
 122         "never read the user package database",
 123   Option [] ["force"] (NoArg FlagForce)
 124          "ignore missing dependencies, directories, and libraries",
 125   Option [] ["force-files"] (NoArg FlagForceFiles)
 126          "ignore missing directories and libraries only",
 127   Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
 128         "automatically build libs for GHCi (with register)",
 129   Option ['?'] ["help"] (NoArg FlagHelp)
 130         "display this help and exit",
 131   Option ['V'] ["version"] (NoArg FlagVersion)
 132         "output version information and exit",
 133   Option [] ["simple-output"] (NoArg FlagSimpleOutput)
 134         "print output in easy-to-parse format for some commands",
 135   Option [] ["names-only"] (NoArg FlagNamesOnly)
 136         "only print package names, not versions; can only be used with list --simple-output",
 137   Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
 138         "ignore case for substring matching",
 139   Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
 140         "verbosity level (0-2, default 1)"
 141   ]
 142
 143 data Verbosity = Silent | Normal | Verbose
 144     deriving (Show, Eq, Ord)
 145
 146 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
 147 getVerbosity v [] = Right v
 148 getVerbosity _ (FlagVerbosity Nothing    : fs) = getVerbosity Verbose fs
 149 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent  fs
 150 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal  fs
 151 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
 152 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
 153 getVerbosity v (_ : fs) = getVerbosity v fs
 154
 155 deprecFlags :: [OptDescr Flag]
 156 deprecFlags = [
 157         -- put deprecated flags here
 158   ]
 159
 160 ourCopyright :: String
 161 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
 162
 163 usageHeader :: String -> String
 164 usageHeader prog = substProg prog $
 165   "Usage:\n" ++
 166   "  $p register {filename | -}\n" ++
 167   "    Register the package using the specified installed package\n" ++
 168   "    description. The syntax for the latter is given in the $p\n" ++
 169   "    documentation.\n" ++
 170   "\n" ++
 171   "  $p update {filename | -}\n" ++
 172   "    Register the package, overwriting any other package with the\n" ++
 173   "    same name.\n" ++
 174   "\n" ++
 175   "  $p unregister {pkg-id}\n" ++
 176   "    Unregister the specified package.\n" ++
 177   "\n" ++
 178   "  $p expose {pkg-id}\n" ++
 179   "    Expose the specified package.\n" ++
 180   "\n" ++
 181   "  $p hide {pkg-id}\n" ++
 182   "    Hide the specified package.\n" ++
 183   "\n" ++
 184   "  $p list [pkg]\n" ++
 185   "    List registered packages in the global database, and also the\n" ++
 186   "    user database if --user is given. If a package name is given\n" ++
 187   "    all the registered versions will be listed in ascending order.\n" ++
 188   "    Accepts the --simple-output flag.\n" ++
 189   "\n" ++
 190   "  $p dot\n" ++
 191   "    Generate a graph of the package dependencies in a form suitable\n" ++
 192   "    for input for the graphviz tools.  For example, to generate a PDF" ++
 193   "    of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
 194   "\n" ++
 195   "  $p find-module {module}\n" ++
 196   "    List registered packages exposing module {module} in the global\n" ++
 197   "    database, and also the user database if --user is given.\n" ++
 198   "    All the registered versions will be listed in ascending order.\n" ++
 199   "    Accepts the --simple-output flag.\n" ++
 200   "\n" ++
 201   "  $p latest {pkg-id}\n" ++
 202   "    Prints the highest registered version of a package.\n" ++
 203   "\n" ++
 204   "  $p check\n" ++
 205   "    Check the consistency of package depenencies and list broken packages.\n" ++
 206   "    Accepts the --simple-output flag.\n" ++
 207   "\n" ++
 208   "  $p describe {pkg}\n" ++
 209   "    Give the registered description for the specified package. The\n" ++
 210   "    description is returned in precisely the syntax required by $p\n" ++
 211   "    register.\n" ++
 212   "\n" ++
 213   "  $p field {pkg} {field}\n" ++
 214   "    Extract the specified field of the package description for the\n" ++
 215   "    specified package. Accepts comma-separated multiple fields.\n" ++
 216   "\n" ++
 217   "  $p dump\n" ++
 218   "    Dump the registered description for every package.  This is like\n" ++
 219   "    \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
 220   "    by tools that parse the results, rather than humans.\n" ++
 221   "\n" ++
 222   " Substring matching is supported for {module} in find-module and\n" ++
 223   " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
 224   " open substring ends (prefix*, *suffix, *infix*).\n" ++
 225   "\n" ++
 226   "  When asked to modify a database (register, unregister, update,\n"++
 227   "  hide, expose, and also check), ghc-pkg modifies the global database by\n"++
 228   "  default.  Specifying --user causes it to act on the user database,\n"++
 229   "  or --package-conf can be used to act on another database\n"++
 230   "  entirely. When multiple of these options are given, the rightmost\n"++
 231   "  one is used as the database to act upon.\n"++
 232   "\n"++
 233   "  Commands that query the package database (list, tree, latest, describe,\n"++
 234   "  field) operate on the list of databases specified by the flags\n"++
 235   "  --user, --global, and --package-conf.  If none of these flags are\n"++
 236   "  given, the default is --global --user.\n"++
 237   "\n" ++
 238   " The following optional flags are also accepted:\n"
 239
 240 substProg :: String -> String -> String
 241 substProg _ [] = []
 242 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
 243 substProg prog (c:xs) = c : substProg prog xs
 244
 245 -- -----------------------------------------------------------------------------
 246 -- Do the business
 247
 248 data Force = NoForce | ForceFiles | ForceAll | CannotForce
 249   deriving (Eq,Ord)
 250
 251 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
 252
 253 runit :: Verbosity -> [Flag] -> [String] -> IO ()
 254 runit verbosity cli nonopts = do
 255   installSignalHandlers -- catch ^C and clean up
 256   prog <- getProgramName
 257   let
 258         force
 259           | FlagForce `elem` cli        = ForceAll
 260           | FlagForceFiles `elem` cli   = ForceFiles
 261           | otherwise                   = NoForce
 262         auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
 263         splitFields fields = unfoldr splitComma (',':fields)
 264           where splitComma "" = Nothing
 265                 splitComma fs = Just $ break (==',') (tail fs)
 266
 267         substringCheck :: String -> Maybe (String -> Bool)
 268         substringCheck ""    = Nothing
 269         substringCheck "*"   = Just (const True)
 270         substringCheck [_]   = Nothing
 271         substringCheck (h:t) =
 272           case (h, init t, last t) of
 273             ('*',s,'*') -> Just (isInfixOf (f s) . f)
 274             ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
 275             ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
 276             _           -> Nothing
 277           where f | FlagIgnoreCase `elem` cli = map toLower
 278                   | otherwise                 = id
 279 #if defined(GLOB)
 280         glob x | System.Info.os=="mingw32" = do
 281           -- glob echoes its argument, after win32 filename globbing
 282           (_,o,_,_) <- runInteractiveCommand ("glob "++x)
 283           txt <- hGetContents o
 284           return (read txt)
 285         glob x | otherwise = return [x]
 286 #endif
 287   --
 288   -- first, parse the command
 289   case nonopts of
 290 #if defined(GLOB)
 291     -- dummy command to demonstrate usage and permit testing
 292     -- without messing things up; use glob to selectively enable
 293     -- windows filename globbing for file parameters
 294     -- register, update, FlagGlobalConfig, FlagConfig; others?
 295     ["glob", filename] -> do
 296         print filename
 297         glob filename >>= print
 298 #endif
 299     ["register", filename] ->
 300         registerPackage filename verbosity cli auto_ghci_libs False force
 301     ["update", filename] ->
 302         registerPackage filename verbosity cli auto_ghci_libs True force
 303     ["unregister", pkgid_str] -> do
 304         pkgid <- readGlobPkgId pkgid_str
 305         unregisterPackage pkgid verbosity cli force
 306     ["expose", pkgid_str] -> do
 307         pkgid <- readGlobPkgId pkgid_str
 308         exposePackage pkgid verbosity cli force
 309     ["hide",   pkgid_str] -> do
 310         pkgid <- readGlobPkgId pkgid_str
 311         hidePackage pkgid verbosity cli force
 312     ["list"] -> do
 313         listPackages verbosity cli Nothing Nothing
 314     ["list", pkgid_str] ->
 315         case substringCheck pkgid_str of
 316           Nothing -> do pkgid <- readGlobPkgId pkgid_str
 317                         listPackages verbosity cli (Just (Id pkgid)) Nothing
 318           Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
 319     ["dot"] -> do
 320         showPackageDot verbosity cli
 321     ["find-module", moduleName] -> do
 322         let match = maybe (==moduleName) id (substringCheck moduleName)
 323         listPackages verbosity cli Nothing (Just match)
 324     ["latest", pkgid_str] -> do
 325         pkgid <- readGlobPkgId pkgid_str
 326         latestPackage cli pkgid
 327     ["describe", pkgid_str] ->
 328         case substringCheck pkgid_str of
 329           Nothing -> do pkgid <- readGlobPkgId pkgid_str
 330                         describePackage cli (Id pkgid)
 331           Just m -> describePackage cli (Substring pkgid_str m)
 332     ["field", pkgid_str, fields] ->
 333         case substringCheck pkgid_str of
 334           Nothing -> do pkgid <- readGlobPkgId pkgid_str
 335                         describeField cli (Id pkgid) (splitFields fields)
 336           Just m -> describeField cli (Substring pkgid_str m)
 337                                       (splitFields fields)
 338     ["check"] -> do
 339         checkConsistency cli
 340
 341     ["dump"] -> do
 342         dumpPackages cli
 343
 344     [] -> do
 345         die ("missing command\n" ++
 346                 usageInfo (usageHeader prog) flags)
 347     (_cmd:_) -> do
 348         die ("command-line syntax error\n" ++
 349                 usageInfo (usageHeader prog) flags)
 350
 351 parseCheck :: ReadP a a -> String -> String -> IO a
 352 parseCheck parser str what =
 353   case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
 354     [x] -> return x
 355     _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
 356
 357 readGlobPkgId :: String -> IO PackageIdentifier
 358 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
 359
 360 parseGlobPackageId :: ReadP r PackageIdentifier
 361 parseGlobPackageId =
 362   parse
 363      +++
 364   (do n <- parse
 365       _ <- string "-*"
 366       return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
 367
 368 -- globVersion means "all versions"
 369 globVersion :: Version
 370 globVersion = Version{ versionBranch=[], versionTags=["*"] }
 371
 372 -- -----------------------------------------------------------------------------
 373 -- Package databases
 374
 375 -- Some commands operate on a single database:
 376 --      register, unregister, expose, hide
 377 -- however these commands also check the union of the available databases
 378 -- in order to check consistency.  For example, register will check that
 379 -- dependencies exist before registering a package.
 380 --
 381 -- Some commands operate  on multiple databases, with overlapping semantics:
 382 --      list, describe, field
 383
 384 type PackageDBName  = FilePath
 385 type PackageDB      = [InstalledPackageInfo]
 386
 387 type NamedPackageDB = (PackageDBName, PackageDB)
 388 type PackageDBStack = [NamedPackageDB]
 389         -- A stack of package databases.  Convention: head is the topmost
 390         -- in the stack.  Earlier entries override later one.
 391
 392 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
 393 allPackagesInStack = concatMap snd
 394
 395 getPkgDatabases :: Bool -> [Flag] -> IO (PackageDBStack, Maybe PackageDBName)
 396 getPkgDatabases modify my_flags = do
 397   -- first we determine the location of the global package config.  On Windows,
 398   -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
 399   -- location is passed to the binary using the --global-config flag by the
 400   -- wrapper script.
 401   let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
 402   global_conf <-
 403      case [ f | FlagGlobalConfig f <- my_flags ] of
 404         [] -> do mb_dir <- getLibDir
 405                  case mb_dir of
 406                         Nothing  -> die err_msg
 407                         Just dir ->
 408                             do let path = dir </> "package.conf"
 409                                exists <- doesFileExist path
 410                                unless exists $ die "Can't find package.conf"
 411                                return path
 412         fs -> return (last fs)
 413
 414   let global_conf_dir = global_conf ++ ".d"
 415   global_conf_dir_exists <- doesDirectoryExist global_conf_dir
 416   global_confs <-
 417     if global_conf_dir_exists
 418       then do files <- getDirectoryContents global_conf_dir
 419               return [ global_conf_dir ++ '/' : file
 420                      | file <- files
 421                      , isSuffixOf ".conf" file]
 422       else return []
 423
 424   let no_user_db = FlagNoUserDb `elem` my_flags
 425
 426   -- get the location of the user package database, and create it if necessary
 427   -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
 428   appdir <- try $ getAppUserDataDirectory "ghc"
 429
 430   mb_user_conf <-
 431      if no_user_db then return Nothing else
 432      case appdir of
 433        Right dir -> do
 434                let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
 435                    user_conf = dir </> subdir </> "package.conf"
 436                user_exists <- doesFileExist user_conf
 437                return (Just (user_conf,user_exists))
 438        Left _ ->
 439                return Nothing
 440
 441   -- If the user database doesn't exist, and this command isn't a
 442   -- "modify" command, then we won't attempt to create or use it.
 443   let sys_databases
 444         | Just (user_conf,user_exists) <- mb_user_conf,
 445           modify || user_exists = user_conf : global_confs ++ [global_conf]
 446         | otherwise             = global_confs ++ [global_conf]
 447
 448   e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
 449   let env_stack =
 450         case e_pkg_path of
 451                 Left  _ -> sys_databases
 452                 Right path
 453                   | last cs == ""  -> init cs ++ sys_databases
 454                   | otherwise      -> cs
 455                   where cs = parseSearchPath path
 456
 457         -- The "global" database is always the one at the bottom of the stack.
 458         -- This is the database we modify by default.
 459       virt_global_conf = last env_stack
 460
 461   let db_flags = [ f | Just f <- map is_db_flag my_flags ]
 462          where is_db_flag FlagUser
 463                       | Just (user_conf, _user_exists) <- mb_user_conf
 464                       = Just user_conf
 465                is_db_flag FlagGlobal     = Just virt_global_conf
 466                is_db_flag (FlagConfig f) = Just f
 467                is_db_flag _              = Nothing
 468
 469   (final_stack, to_modify) <-
 470      if not modify
 471         then    -- For a "read" command, we use all the databases
 472                 -- specified on the command line.  If there are no
 473                 -- command-line flags specifying databases, the default
 474                 -- is to use all the ones we know about.
 475              if null db_flags then return (env_stack, Nothing)
 476                               else return (reverse (nub db_flags), Nothing)
 477         else let
 478                 -- For a "modify" command, treat all the databases as
 479                 -- a stack, where we are modifying the top one, but it
 480                 -- can refer to packages in databases further down the
 481                 -- stack.
 482
 483                 -- -f flags on the command line add to the database
 484                 -- stack, unless any of them are present in the stack
 485                 -- already.
 486                 flag_stack = filter (`notElem` env_stack)
 487                                 [ f | FlagConfig f <- reverse my_flags ]
 488                                 ++ env_stack
 489
 490                 -- the database we actually modify is the one mentioned
 491                 -- rightmost on the command-line.
 492                 to_modify = if null db_flags
 493                                 then Just virt_global_conf
 494                                 else Just (last db_flags)
 495              in
 496                 return (flag_stack, to_modify)
 497
 498   db_stack <- mapM (readParseDatabase mb_user_conf) final_stack
 499   return (db_stack, to_modify)
 500
 501 readParseDatabase :: Maybe (PackageDBName,Bool)
 502                   -> PackageDBName
 503                   -> IO (PackageDBName,PackageDB)
 504 readParseDatabase mb_user_conf filename
 505   -- the user database (only) is allowed to be non-existent
 506   | Just (user_conf,False) <- mb_user_conf, filename == user_conf
 507   = return (filename, [])
 508   | otherwise
 509   = do str <- readFile filename
 510        let packages = map convertPackageInfoIn $ read str
 511        _ <- Exception.evaluate packages
 512          `catchError` \e->
 513             die ("error while parsing " ++ filename ++ ": " ++ show e)
 514        return (filename,packages)
 515
 516 -- -----------------------------------------------------------------------------
 517 -- Registering
 518
 519 registerPackage :: FilePath
 520                 -> Verbosity
 521                 -> [Flag]
 522                 -> Bool              -- auto_ghci_libs
 523                 -> Bool              -- update
 524                 -> Force
 525                 -> IO ()
 526 registerPackage input verbosity my_flags auto_ghci_libs update force = do
 527   (db_stack, Just to_modify) <- getPkgDatabases True my_flags
 528   let
 529         db_to_operate_on = my_head "register" $
 530                            filter ((== to_modify).fst) db_stack
 531   --
 532   s <-
 533     case input of
 534       "-" -> do
 535         when (verbosity >= Normal) $
 536             putStr "Reading package info from stdin ... "
 537         getContents
 538       f   -> do
 539         when (verbosity >= Normal) $
 540             putStr ("Reading package info from " ++ show f ++ " ... ")
 541         readFile f
 542
 543   expanded <- expandEnvVars s force
 544
 545   pkg <- parsePackageInfo expanded
 546   when (verbosity >= Normal) $
 547       putStrLn "done."
 548
 549   let truncated_stack = dropWhile ((/= to_modify).fst) db_stack
 550   -- truncate the stack for validation, because we don't allow
 551   -- packages lower in the stack to refer to those higher up.
 552   validatePackageConfig pkg truncated_stack auto_ghci_libs update force
 553   let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
 554       not_this p = sourcePackageId p /= sourcePackageId pkg
 555   writeNewConfig verbosity to_modify new_details
 556
 557 parsePackageInfo
 558         :: String
 559         -> IO InstalledPackageInfo
 560 parsePackageInfo str =
 561   case parseInstalledPackageInfo str of
 562     ParseOk _warns ok -> return ok
 563     ParseFailed err -> case locatedErrorMsg err of
 564                            (Nothing, s) -> die s
 565                            (Just l, s) -> die (show l ++ ": " ++ s)
 566
 567 -- -----------------------------------------------------------------------------
 568 -- Exposing, Hiding, Unregistering are all similar
 569
 570 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 571 exposePackage = modifyPackage (\p -> [p{exposed=True}])
 572
 573 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 574 hidePackage = modifyPackage (\p -> [p{exposed=False}])
 575
 576 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
 577 unregisterPackage = modifyPackage (\_ -> [])
 578
 579 modifyPackage
 580   :: (InstalledPackageInfo -> [InstalledPackageInfo])
 581   -> PackageIdentifier
 582   -> Verbosity
 583   -> [Flag]
 584   -> Force
 585   -> IO ()
 586 modifyPackage fn pkgid verbosity my_flags force = do
 587   (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags
 588   ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
 589 --  let ((db_name, pkgs) : rest_of_stack) = db_stack
 590 --  ps <- findPackages [(db_name,pkgs)] (Id pkgid)
 591   let
 592       pids = map sourcePackageId ps
 593       modify pkg
 594           | sourcePackageId pkg `elem` pids = fn pkg
 595           | otherwise                       = [pkg]
 596       new_config = concat (map modify pkgs)
 597
 598   let
 599       old_broken = brokenPackages (allPackagesInStack db_stack)
 600       rest_of_stack = [ (nm, mypkgs)
 601                       | (nm, mypkgs) <- db_stack, nm /= db_name ]
 602       new_stack = (db_name,new_config) : rest_of_stack
 603       new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
 604       newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
 605   --
 606   when (not (null newly_broken)) $
 607       dieOrForceAll force ("unregistering " ++ display pkgid ++
 608            " would break the following packages: "
 609               ++ unwords (map display newly_broken))
 610
 611   writeNewConfig verbosity db_name new_config
 612
 613 -- -----------------------------------------------------------------------------
 614 -- Listing packages
 615
 616 listPackages ::  Verbosity -> [Flag] -> Maybe PackageArg
 617              -> Maybe (String->Bool)
 618              -> IO ()
 619 listPackages verbosity my_flags mPackageName mModuleName = do
 620   let simple_output = FlagSimpleOutput `elem` my_flags
 621   (db_stack, _) <- getPkgDatabases False my_flags
 622   let db_stack_filtered -- if a package is given, filter out all other packages
 623         | Just this <- mPackageName =
 624             map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
 625                 db_stack
 626         | Just match <- mModuleName = -- packages which expose mModuleName
 627             map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs))
 628                 db_stack
 629         | otherwise = db_stack
 630
 631       db_stack_sorted
 632           = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ]
 633           where sort_pkgs = sortBy cmpPkgIds
 634                 cmpPkgIds pkg1 pkg2 =
 635                    case pkgName p1 `compare` pkgName p2 of
 636                         LT -> LT
 637                         GT -> GT
 638                         EQ -> pkgVersion p1 `compare` pkgVersion p2
 639                    where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
 640
 641       match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
 642
 643       pkg_map = allPackagesInStack db_stack
 644       broken = map sourcePackageId (brokenPackages pkg_map)
 645
 646       show_func = if simple_output then show_simple else mapM_ show_normal
 647
 648       show_normal (db_name,pkg_confs) =
 649           hPutStrLn stdout (render $
 650                 text db_name <> colon $$ nest 4 packages
 651                 )
 652            where packages
 653                     | verbosity >= Verbose = vcat (map pp_pkg pkg_confs)
 654                     | otherwise = fsep (punctuate comma (map pp_pkg pkg_confs))
 655                  pp_pkg p
 656                    | sourcePackageId p `elem` broken = braces doc
 657                    | exposed p = doc
 658                    | otherwise = parens doc
 659                    where doc | verbosity >= Verbose = pkg <+> parens ipid
 660                              | otherwise            = pkg
 661                           where
 662                           InstalledPackageId ipid_str = installedPackageId p
 663                           ipid = text ipid_str
 664                           pkg = text (display (sourcePackageId p))
 665
 666       show_simple = simplePackageList my_flags . allPackagesInStack
 667
 668   when (not (null broken) && verbosity /= Silent) $ do
 669      prog <- getProgramName
 670      putStrLn ("WARNING: there are broken packages.  Run '" ++ prog ++ " check' for more details.")
 671
 672   show_func (reverse db_stack_sorted)
 673
 674 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
 675 simplePackageList my_flags pkgs = do
 676    let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
 677                                                   else display
 678        strs = map showPkg $ sortBy compPkgIdVer $ map sourcePackageId pkgs
 679    when (not (null pkgs)) $
 680       hPutStrLn stdout $ concat $ intersperse " " strs
 681
 682 showPackageDot :: Verbosity -> [Flag] -> IO ()
 683 showPackageDot _verbosity myflags = do
 684   (db_stack, _) <- getPkgDatabases False myflags
 685   let all_pkgs = allPackagesInStack db_stack
 686       ipix  = PackageIndex.listToInstalledPackageIndex all_pkgs
 687
 688   putStrLn "digraph {"
 689   let quote s = '"':s ++ "\""
 690   mapM_ putStrLn [ quote from ++ " -> " ++ quote to
 691                  | p <- all_pkgs,
 692                    let from = display (sourcePackageId p),
 693                    depid <- depends p,
 694                    Just dep <- [PackageIndex.lookupInstalledPackage ipix depid],
 695                    let to = display (sourcePackageId dep)
 696                  ]
 697   putStrLn "}"
 698
 699 -- -----------------------------------------------------------------------------
 700 -- Prints the highest (hidden or exposed) version of a package
 701
 702 latestPackage ::  [Flag] -> PackageIdentifier -> IO ()
 703 latestPackage my_flags pkgid = do
 704   (db_stack, _) <- getPkgDatabases False my_flags
 705   ps <- findPackages db_stack (Id pkgid)
 706   show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
 707   where
 708     show_pkg [] = die "no matches"
 709     show_pkg pids = hPutStrLn stdout (display (last pids))
 710
 711 -- -----------------------------------------------------------------------------
 712 -- Describe
 713
 714 describePackage :: [Flag] -> PackageArg -> IO ()
 715 describePackage my_flags pkgarg = do
 716   (db_stack, _) <- getPkgDatabases False my_flags
 717   ps <- findPackages db_stack pkgarg
 718   doDump ps
 719
 720 dumpPackages :: [Flag] -> IO ()
 721 dumpPackages my_flags = do
 722   (db_stack, _) <- getPkgDatabases False my_flags
 723   doDump (allPackagesInStack db_stack)
 724
 725 doDump :: [InstalledPackageInfo] -> IO ()
 726 doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo
 727
 728 -- PackageId is can have globVersion for the version
 729 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
 730 findPackages db_stack pkgarg
 731   = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
 732
 733 findPackagesByDB :: PackageDBStack -> PackageArg
 734                  -> IO [(NamedPackageDB, [InstalledPackageInfo])]
 735 findPackagesByDB db_stack pkgarg
 736   = case [ (db, matched)
 737          | db@(_, pkgs) <- db_stack,
 738            let matched = filter (pkgarg `matchesPkg`) pkgs,
 739            not (null matched) ] of
 740         [] -> die ("cannot find package " ++ pkg_msg pkgarg)
 741         ps -> return ps
 742   where
 743         pkg_msg (Id pkgid)           = display pkgid
 744         pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
 745
 746 matches :: PackageIdentifier -> PackageIdentifier -> Bool
 747 pid `matches` pid'
 748   = (pkgName pid == pkgName pid')
 749     && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
 750
 751 realVersion :: PackageIdentifier -> Bool
 752 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
 753   -- when versionBranch == [], this is a glob
 754
 755 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
 756 (Id pid)        `matchesPkg` pkg = pid `matches` sourcePackageId pkg
 757 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
 758
 759 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
 760 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
 761
 762 -- -----------------------------------------------------------------------------
 763 -- Field
 764
 765 describeField :: [Flag] -> PackageArg -> [String] -> IO ()
 766 describeField my_flags pkgarg fields = do
 767   (db_stack, _) <- getPkgDatabases False my_flags
 768   fns <- toFields fields
 769   ps <- findPackages db_stack pkgarg
 770   let top_dir = takeDirectory (fst (last db_stack))
 771   mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
 772   where toFields [] = return []
 773         toFields (f:fs) = case toField f of
 774             Nothing -> die ("unknown field: " ++ f)
 775             Just fn -> do fns <- toFields fs
 776                           return (fn:fns)
 777         selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
 778
 779 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
 780 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
 781 -- with the current topdir (obtained from the -B option).
 782 mungePackagePaths top_dir ps = map munge_pkg ps
 783   where
 784   munge_pkg p = p{ importDirs        = munge_paths (importDirs p),
 785                    includeDirs       = munge_paths (includeDirs p),
 786                    libraryDirs       = munge_paths (libraryDirs p),
 787                    frameworkDirs     = munge_paths (frameworkDirs p),
 788                    haddockInterfaces = munge_paths (haddockInterfaces p),
 789                    haddockHTMLs      = munge_paths (haddockHTMLs p)
 790                  }
 791
 792   munge_paths = map munge_path
 793
 794   munge_path p
 795    | Just p' <- maybePrefixMatch "$topdir"     p =            top_dir ++ p'
 796    | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
 797    | otherwise                               = p
 798
 799   toHttpPath p = "file:///" ++ p
 800
 801 maybePrefixMatch :: String -> String -> Maybe String
 802 maybePrefixMatch []    rest = Just rest
 803 maybePrefixMatch (_:_) []   = Nothing
 804 maybePrefixMatch (p:pat) (r:rest)
 805   | p == r    = maybePrefixMatch pat rest
 806   | otherwise = Nothing
 807
 808 toField :: String -> Maybe (InstalledPackageInfo -> String)
 809 -- backwards compatibility:
 810 toField "import_dirs"     = Just $ strList . importDirs
 811 toField "source_dirs"     = Just $ strList . importDirs
 812 toField "library_dirs"    = Just $ strList . libraryDirs
 813 toField "hs_libraries"    = Just $ strList . hsLibraries
 814 toField "extra_libraries" = Just $ strList . extraLibraries
 815 toField "include_dirs"    = Just $ strList . includeDirs
 816 toField "c_includes"      = Just $ strList . includes
 817 toField "package_deps"    = Just $ strList . map display. depends
 818 toField "extra_cc_opts"   = Just $ strList . ccOptions
 819 toField "extra_ld_opts"   = Just $ strList . ldOptions
 820 toField "framework_dirs"  = Just $ strList . frameworkDirs
 821 toField "extra_frameworks"= Just $ strList . frameworks
 822 toField s                 = showInstalledPackageInfoField s
 823
 824 strList :: [String] -> String
 825 strList = show
 826
 827
 828 -- -----------------------------------------------------------------------------
 829 -- Check: Check consistency of installed packages
 830
 831 checkConsistency :: [Flag] -> IO ()
 832 checkConsistency my_flags = do
 833   (db_stack, _) <- getPkgDatabases True my_flags
 834          -- check behaves like modify for the purposes of deciding which
 835          -- databases to use, because ordering is important.
 836
 837   let simple_output = FlagSimpleOutput `elem` my_flags
 838
 839   let pkgs = allPackagesInStack db_stack
 840
 841       checkPackage p = do
 842          (_,es) <- runValidate $ checkPackageConfig p db_stack False True
 843          if null es
 844             then return []
 845             else do
 846               when (not simple_output) $ do
 847                   reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
 848                   _ <- reportValidateErrors es "  " Nothing
 849                   return ()
 850               return [p]
 851
 852   broken_pkgs <- concat `fmap` mapM checkPackage pkgs
 853
 854   let filterOut pkgs1 pkgs2 = filter not_in pkgs2
 855         where not_in p = sourcePackageId p `notElem` all_ps
 856               all_ps = map sourcePackageId pkgs1
 857
 858   let not_broken_pkgs = filterOut broken_pkgs pkgs
 859       (_, trans_broken_pkgs) = closure [] not_broken_pkgs
 860       all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
 861
 862   when (not (null all_broken_pkgs)) $ do
 863     if simple_output
 864       then simplePackageList my_flags all_broken_pkgs
 865       else do
 866        reportError ("\nThe following packages are broken, either because they have a problem\n"++
 867                 "listed above, or because they depend on a broken package.")
 868        mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
 869
 870   when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
 871
 872
 873 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
 874         -> ([InstalledPackageInfo], [InstalledPackageInfo])
 875 closure pkgs db_stack = go pkgs db_stack
 876  where
 877    go avail not_avail =
 878      case partition (depsAvailable avail) not_avail of
 879         ([],        not_avail') -> (avail, not_avail')
 880         (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
 881
 882    depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
 883                  -> Bool
 884    depsAvailable pkgs_ok pkg = null dangling
 885         where dangling = filter (`notElem` pids) (depends pkg)
 886               pids = map installedPackageId pkgs_ok
 887
 888         -- we want mutually recursive groups of package to show up
 889         -- as broken. (#1750)
 890
 891 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
 892 brokenPackages pkgs = snd (closure [] pkgs)
 893
 894 -- -----------------------------------------------------------------------------
 895 -- Manipulating package.conf files
 896
 897 type InstalledPackageInfoString = InstalledPackageInfo_ String
 898
 899 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
 900 convertPackageInfoOut
 901     (pkgconf@(InstalledPackageInfo { exposedModules = e,
 902                                      hiddenModules = h })) =
 903         pkgconf{ exposedModules = map display e,
 904                  hiddenModules  = map display h }
 905
 906 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
 907 convertPackageInfoIn
 908     (pkgconf@(InstalledPackageInfo { exposedModules = e,
 909                                      hiddenModules = h })) =
 910         pkgconf{ exposedModules = map convert e,
 911                  hiddenModules  = map convert h }
 912     where convert = fromJust . simpleParse
 913
 914 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
 915 writeNewConfig verbosity filename packages = do
 916   when (verbosity >= Normal) $
 917       hPutStr stdout "Writing new package config file... "
 918   createDirectoryIfMissing True $ takeDirectory filename
 919   let shown = concat $ intersperse ",\n "
 920                      $ map (show . convertPackageInfoOut) packages
 921       fileContents = "[" ++ shown ++ "\n]"
 922   writeFileAtomic filename fileContents
 923     `catch` \e ->
 924       if isPermissionError e
 925       then die (filename ++ ": you don't have permission to modify this file")
 926       else ioError e
 927   when (verbosity >= Normal) $
 928       hPutStrLn stdout "done."
 929
 930 -----------------------------------------------------------------------------
 931 -- Sanity-check a new package config, and automatically build GHCi libs
 932 -- if requested.
 933
 934 type ValidateError = (Force,String)
 935
 936 newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
 937
 938 instance Monad Validate where
 939    return a = V $ return (a, [])
 940    m >>= k = V $ do
 941       (a, es) <- runValidate m
 942       (b, es') <- runValidate (k a)
 943       return (b,es++es')
 944
 945 verror :: Force -> String -> Validate ()
 946 verror f s = V (return ((),[(f,s)]))
 947
 948 liftIO :: IO a -> Validate a
 949 liftIO k = V (k >>= \a -> return (a,[]))
 950
 951 -- returns False if we should die
 952 reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
 953 reportValidateErrors es prefix mb_force = do
 954   oks <- mapM report es
 955   return (and oks)
 956   where
 957     report (f,s)
 958       | Just force <- mb_force
 959       = if (force >= f)
 960            then do reportError (prefix ++ s ++ " (ignoring)")
 961                    return True
 962            else if f < CannotForce
 963                    then do reportError (prefix ++ s ++ " (use --force to override)")
 964                            return False
 965                    else do reportError err
 966                            return False
 967       | otherwise = do reportError err
 968                        return False
 969       where
 970              err = prefix ++ s
 971
 972 validatePackageConfig :: InstalledPackageInfo
 973                       -> PackageDBStack
 974                       -> Bool   -- auto-ghc-libs
 975                       -> Bool   -- update, or check
 976                       -> Force
 977                       -> IO ()
 978 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
 979   (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
 980   ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force)
 981   when (not ok) $ exitWith (ExitFailure 1)
 982
 983 checkPackageConfig :: InstalledPackageInfo
 984                       -> PackageDBStack
 985                       -> Bool   -- auto-ghc-libs
 986                       -> Bool   -- update, or check
 987                       -> Validate ()
 988 checkPackageConfig pkg db_stack auto_ghci_libs update = do
 989   checkInstalledPackageId pkg db_stack update
 990   checkPackageId pkg
 991   checkDuplicates db_stack pkg update
 992   mapM_ (checkDep db_stack) (depends pkg)
 993   checkDuplicateDepends (depends pkg)
 994   mapM_ (checkDir "import-dirs") (importDirs pkg)
 995   mapM_ (checkDir "library-dirs") (libraryDirs pkg)
 996   mapM_ (checkDir "include-dirs") (includeDirs pkg)
 997   checkModules pkg
 998   mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
 999   -- ToDo: check these somehow?
1000   --    extra_libraries :: [String],
1001   --    c_includes      :: [String],
1002
1003 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1004                         -> Validate ()
1005 checkInstalledPackageId ipi db_stack update = do
1006   let ipid@(InstalledPackageId str) = installedPackageId ipi
1007   when (null str) $ verror CannotForce "missing id field"
1008   let dups = [ p | p <- allPackagesInStack db_stack,
1009                    installedPackageId p == ipid ]
1010   when (not update && not (null dups)) $
1011     verror CannotForce $
1012         "package(s) with this id already exist: " ++
1013          unwords (map (display.packageId) dups)
1014
1015 -- When the package name and version are put together, sometimes we can
1016 -- end up with a package id that cannot be parsed.  This will lead to
1017 -- difficulties when the user wants to refer to the package later, so
1018 -- we check that the package id can be parsed properly here.
1019 checkPackageId :: InstalledPackageInfo -> Validate ()
1020 checkPackageId ipi =
1021   let str = display (sourcePackageId ipi) in
1022   case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1023     [_] -> return ()
1024     []  -> verror CannotForce ("invalid package identifier: " ++ str)
1025     _   -> verror CannotForce ("ambiguous package identifier: " ++ str)
1026
1027 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1028 checkDuplicates db_stack pkg update = do
1029   let
1030         pkgid = sourcePackageId pkg
1031         (_top_db_name, pkgs) : _  = db_stack
1032   --
1033   -- Check whether this package id already exists in this DB
1034   --
1035   when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
1036        verror CannotForce $
1037           "package " ++ display pkgid ++ " is already installed"
1038
1039   let
1040         uncasep = map toLower . display
1041         dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
1042
1043   when (not update && not (null dups)) $ verror ForceAll $
1044         "Package names may be treated case-insensitively in the future.\n"++
1045         "Package " ++ display pkgid ++
1046         " overlaps with: " ++ unwords (map display dups)
1047
1048
1049 checkDir :: String -> String -> Validate ()
1050 checkDir thisfield d
1051  | "$topdir"     `isPrefixOf` d = return ()
1052  | "$httptopdir" `isPrefixOf` d = return ()
1053         -- can't check these, because we don't know what $(http)topdir is
1054  | otherwise = do
1055    there <- liftIO $ doesDirectoryExist d
1056    when (not there) $
1057        verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
1058
1059 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1060 checkDep db_stack pkgid
1061   | pkgid `elem` pkgids = return ()
1062   | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1063                                  ++ "\" doesn't exist")
1064   where
1065         all_pkgs = allPackagesInStack db_stack
1066         pkgids = map installedPackageId all_pkgs
1067
1068 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1069 checkDuplicateDepends deps
1070   | null dups = return ()
1071   | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1072                                      unwords (map display dups))
1073   where
1074        dups = [ p | (p:_:_) <- group (sort deps) ]
1075
1076 checkHSLib :: [String] -> Bool -> String -> Validate ()
1077 checkHSLib dirs auto_ghci_libs lib = do
1078   let batch_lib_file = "lib" ++ lib ++ ".a"
1079   m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1080   case m of
1081     Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1082                                    " on library path")
1083     Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1084
1085 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1086 doesFileExistOnPath file path = go path
1087   where go []     = return Nothing
1088         go (p:ps) = do b <- doesFileExistIn file p
1089                        if b then return (Just p) else go ps
1090
1091 doesFileExistIn :: String -> String -> IO Bool
1092 doesFileExistIn lib d
1093  | "$topdir"     `isPrefixOf` d = return True
1094  | "$httptopdir" `isPrefixOf` d = return True
1095  | otherwise                = doesFileExist (d </> lib)
1096
1097 checkModules :: InstalledPackageInfo -> Validate ()
1098 checkModules pkg = do
1099   mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1100   where
1101     findModule modl = do
1102       -- there's no .hi file for GHC.Prim
1103       if modl == fromString "GHC.Prim" then return () else do
1104       let file = toFilePath modl <.> "hi"
1105       m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1106       when (isNothing m) $
1107          verror ForceFiles ("file " ++ file ++ " is missing")
1108
1109 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1110 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1111   | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1112   | otherwise  = do
1113       m <- doesFileExistOnPath ghci_lib_file dirs
1114       when (isNothing m && ghci_lib_file /= "HSrts.o") $
1115         hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
1116  where
1117     ghci_lib_file = lib <.> "o"
1118
1119 -- automatically build the GHCi version of a batch lib,
1120 -- using ld --whole-archive.
1121
1122 autoBuildGHCiLib :: String -> String -> String -> IO ()
1123 autoBuildGHCiLib dir batch_file ghci_file = do
1124   let ghci_lib_file  = dir ++ '/':ghci_file
1125       batch_lib_file = dir ++ '/':batch_file
1126   hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1127 #if defined(darwin_HOST_OS)
1128   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1129 #elif defined(mingw32_HOST_OS)
1130   execDir <- getLibDir
1131   r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1132 #else
1133   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1134 #endif
1135   when (r /= ExitSuccess) $ exitWith r
1136   hPutStrLn stderr (" done.")
1137
1138 -- -----------------------------------------------------------------------------
1139 -- Searching for modules
1140
1141 #if not_yet
1142
1143 findModules :: [FilePath] -> IO [String]
1144 findModules paths =
1145   mms <- mapM searchDir paths
1146   return (concat mms)
1147
1148 searchDir path prefix = do
1149   fs <- getDirectoryEntries path `catch` \_ -> return []
1150   searchEntries path prefix fs
1151
1152 searchEntries path prefix [] = return []
1153 searchEntries path prefix (f:fs)
1154   | looks_like_a_module  =  do
1155         ms <- searchEntries path prefix fs
1156         return (prefix `joinModule` f : ms)
1157   | looks_like_a_component  =  do
1158         ms <- searchDir (path </> f) (prefix `joinModule` f)
1159         ms' <- searchEntries path prefix fs
1160         return (ms ++ ms')
1161   | otherwise
1162         searchEntries path prefix fs
1163
1164   where
1165         (base,suffix) = splitFileExt f
1166         looks_like_a_module =
1167                 suffix `elem` haskell_suffixes &&
1168                 all okInModuleName base
1169         looks_like_a_component =
1170                 null suffix && all okInModuleName base
1171
1172 okInModuleName c
1173
1174 #endif
1175
1176 -- ---------------------------------------------------------------------------
1177 -- expanding environment variables in the package configuration
1178
1179 expandEnvVars :: String -> Force -> IO String
1180 expandEnvVars str0 force = go str0 ""
1181  where
1182    go "" acc = return $! reverse acc
1183    go ('$':'{':str) acc | (var, '}':rest) <- break close str
1184         = do value <- lookupEnvVar var
1185              go rest (reverse value ++ acc)
1186         where close c = c == '}' || c == '\n' -- don't span newlines
1187    go (c:str) acc
1188         = go str (c:acc)
1189
1190    lookupEnvVar :: String -> IO String
1191    lookupEnvVar nm =
1192         catch (System.Environment.getEnv nm)
1193            (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1194                                         show nm)
1195                       return "")
1196
1197 -----------------------------------------------------------------------------
1198
1199 getProgramName :: IO String
1200 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1201    where str `withoutSuffix` suff
1202             | suff `isSuffixOf` str = take (length str - length suff) str
1203             | otherwise             = str
1204
1205 bye :: String -> IO a
1206 bye s = putStr s >> exitWith ExitSuccess
1207
1208 die :: String -> IO a
1209 die = dieWith 1
1210
1211 dieWith :: Int -> String -> IO a
1212 dieWith ec s = do
1213   hFlush stdout
1214   prog <- getProgramName
1215   hPutStrLn stderr (prog ++ ": " ++ s)
1216   exitWith (ExitFailure ec)
1217
1218 dieOrForceAll :: Force -> String -> IO ()
1219 dieOrForceAll ForceAll s = ignoreError s
1220 dieOrForceAll _other s   = dieForcible s
1221
1222 ignoreError :: String -> IO ()
1223 ignoreError s = reportError (s ++ " (ignoring)")
1224
1225 reportError :: String -> IO ()
1226 reportError s = do hFlush stdout; hPutStrLn stderr s
1227
1228 dieForcible :: String -> IO ()
1229 dieForcible s = die (s ++ " (use --force to override)")
1230
1231 my_head :: String -> [a] -> a
1232 my_head s []      = error s
1233 my_head _ (x : _) = x
1234
1235 -----------------------------------------
1236 -- Cut and pasted from ghc/compiler/main/SysTools
1237
1238 #if defined(mingw32_HOST_OS)
1239 subst :: Char -> Char -> String -> String
1240 subst a b ls = map (\ x -> if x == a then b else x) ls
1241
1242 unDosifyPath :: FilePath -> FilePath
1243 unDosifyPath xs = subst '\\' '/' xs
1244
1245 getLibDir :: IO (Maybe String)
1246 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1247
1248 -- (getExecDir cmd) returns the directory in which the current
1249 --                  executable, which should be called 'cmd', is running
1250 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1251 -- you'll get "/a/b/c" back as the result
1252 getExecDir :: String -> IO (Maybe String)
1253 getExecDir cmd =
1254     getExecPath >>= maybe (return Nothing) removeCmdSuffix
1255     where initN n = reverse . drop n . reverse
1256           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1257
1258 getExecPath :: IO (Maybe String)
1259 getExecPath =
1260      allocaArray len $ \buf -> do
1261          ret <- getModuleFileName nullPtr buf len
1262          if ret == 0 then return Nothing
1263                      else liftM Just $ peekCString buf
1264     where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1265
1266 foreign import stdcall unsafe "GetModuleFileNameA"
1267     getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1268
1269 #else
1270 getLibDir :: IO (Maybe String)
1271 getLibDir = return Nothing
1272 #endif
1273
1274 -----------------------------------------
1275 -- Adapted from ghc/compiler/utils/Panic
1276
1277 installSignalHandlers :: IO ()
1278 installSignalHandlers = do
1279   threadid <- myThreadId
1280   let
1281       interrupt = Exception.throwTo threadid
1282                                     (Exception.ErrorCall "interrupted")
1283   --
1284 #if !defined(mingw32_HOST_OS)
1285   _ <- installHandler sigQUIT (Catch interrupt) Nothing
1286   _ <- installHandler sigINT  (Catch interrupt) Nothing
1287   return ()
1288 #elif __GLASGOW_HASKELL__ >= 603
1289   -- GHC 6.3+ has support for console events on Windows
1290   -- NOTE: running GHCi under a bash shell for some reason requires
1291   -- you to press Ctrl-Break rather than Ctrl-C to provoke
1292   -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
1293   -- why --SDM 17/12/2004
1294   let sig_handler ControlC = interrupt
1295       sig_handler Break    = interrupt
1296       sig_handler _        = return ()
1297
1298   _ <- installHandler (Catch sig_handler)
1299   return ()
1300 #else
1301   return () -- nothing
1302 #endif
1303
1304 #if __GLASGOW_HASKELL__ <= 604
1305 isInfixOf               :: (Eq a) => [a] -> [a] -> Bool
1306 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
1307 #endif
1308
1309 #if mingw32_HOST_OS || mingw32_TARGET_OS
1310 throwIOIO :: Exception.IOException -> IO a
1311 throwIOIO = Exception.throwIO
1312
1313 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1314 catchIO = Exception.catch
1315 #endif
1316
1317 catchError :: IO a -> (String -> IO a) -> IO a
1318 catchError io handler = io `Exception.catch` handler'
1319     where handler' (Exception.ErrorCall err) = handler err
1320
1321
1322 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1323 -- to use text files here, rather than binary files.
1324 writeFileAtomic :: FilePath -> String -> IO ()
1325 writeFileAtomic targetFile content = do
1326   (newFile, newHandle) <- openNewFile targetDir template
1327   do  hPutStr newHandle content
1328       hClose newHandle
1329 #if mingw32_HOST_OS || mingw32_TARGET_OS
1330       renameFile newFile targetFile
1331         -- If the targetFile exists then renameFile will fail
1332         `catchIO` \err -> do
1333           exists <- doesFileExist targetFile
1334           if exists
1335             then do removeFile targetFile
1336                     -- Big fat hairy race condition
1337                     renameFile newFile targetFile
1338                     -- If the removeFile succeeds and the renameFile fails
1339                     -- then we've lost the atomic property.
1340             else throwIOIO err
1341 #else
1342       renameFile newFile targetFile
1343 #endif
1344    `Exception.onException` do hClose newHandle
1345                               removeFile newFile
1346   where
1347     template = targetName <.> "tmp"
1348     targetDir | null targetDir_ = "."
1349               | otherwise       = targetDir_
1350     --TODO: remove this when takeDirectory/splitFileName is fixed
1351     --      to always return a valid dir
1352     (targetDir_,targetName) = splitFileName targetFile
1353
1354 -- Ugh, this is a copy/paste of code from the base library, but
1355 -- if uses 666 rather than 600 for the permissions.
1356 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1357 openNewFile dir template = do
1358   pid <- c_getpid
1359   findTempName pid
1360   where
1361     -- We split off the last extension, so we can use .foo.ext files
1362     -- for temporary files (hidden on Unix OSes). Unfortunately we're
1363     -- below filepath in the hierarchy here.
1364     (prefix,suffix) =
1365        case break (== '.') $ reverse template of
1366          -- First case: template contains no '.'s. Just re-reverse it.
1367          (rev_suffix, "")       -> (reverse rev_suffix, "")
1368          -- Second case: template contains at least one '.'. Strip the
1369          -- dot from the prefix and prepend it to the suffix (if we don't
1370          -- do this, the unique number will get added after the '.' and
1371          -- thus be part of the extension, which is wrong.)
1372          (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1373          -- Otherwise, something is wrong, because (break (== '.')) should
1374          -- always return a pair with either the empty string or a string
1375          -- beginning with '.' as the second component.
1376          _                      -> error "bug in System.IO.openTempFile"
1377
1378     oflags = rw_flags .|. o_EXCL
1379
1380 #if __GLASGOW_HASKELL__ < 611
1381     withFilePath = withCString
1382 #endif
1383
1384     findTempName x = do
1385       fd <- withFilePath filepath $ \ f ->
1386               c_open f oflags 0o666
1387       if fd < 0
1388        then do
1389          errno <- getErrno
1390          if errno == eEXIST
1391            then findTempName (x+1)
1392            else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1393        else do
1394          -- XXX We want to tell fdToHandle what the filepath is,
1395          -- as any exceptions etc will only be able to report the
1396          -- fd currently
1397          h <-
1398 #if __GLASGOW_HASKELL__ >= 609
1399               fdToHandle fd
1400 #else
1401               fdToHandle (fromIntegral fd)
1402 #endif
1403               `Exception.onException` c_close fd
1404          return (filepath, h)
1405       where
1406         filename        = prefix ++ show x ++ suffix
1407         filepath        = dir `combine` filename
1408
1409 -- XXX Copied from GHC.Handle
1410 std_flags, output_flags, rw_flags :: CInt
1411 std_flags    = o_NONBLOCK   .|. o_NOCTTY
1412 output_flags = std_flags    .|. o_CREAT
1413 rw_flags     = output_flags .|. o_RDWR
1414
1415 -- | The function splits the given string to substrings
1416 -- using 'isSearchPathSeparator'.
1417 parseSearchPath :: String -> [FilePath]
1418 parseSearchPath path = split path
1419   where
1420     split :: String -> [String]
1421     split s =
1422       case rest' of
1423         []     -> [chunk]
1424         _:rest -> chunk : split rest
1425       where
1426         chunk =
1427           case chunk' of
1428 #ifdef mingw32_HOST_OS
1429             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1430 #endif
1431             _                                 -> chunk'
1432
1433         (chunk', rest') = break isSearchPathSeparator s