utils/ghc-pkg/Main.hs

   1 {-# OPTIONS -fglasgow-exts #-}
   2 -----------------------------------------------------------------------------
   3 --
   4 -- (c) The University of Glasgow 2004.
   5 --
   6 -- Package management tool
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 -- TODO:
  11 -- * validate modules
  12 -- * expanding of variables in new-style package conf
  13 -- * version manipulation (checking whether old version exists,
  14 --   hiding old version?)
  15
  16 module Main (main) where
  17
  18 import Version ( version, targetOS, targetARCH )
  19 import Distribution.InstalledPackageInfo
  20 import Distribution.Compat.ReadP
  21 import Distribution.ParseUtils
  22 import Distribution.Package
  23 import Distribution.Version
  24 import System.FilePath
  25
  26 #ifdef USING_COMPAT
  27 import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
  28 import Compat.RawSystem ( rawSystem )
  29 #else
  30 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
  31 import System.Cmd       ( rawSystem )
  32 #endif
  33
  34 import Prelude
  35
  36 #include "../../includes/ghcconfig.h"
  37
  38 import System.Console.GetOpt
  39 import Text.PrettyPrint
  40 import qualified Control.Exception as Exception
  41 import Data.Maybe
  42
  43 import Data.Char ( isSpace )
  44 import Monad
  45 import Directory
  46 import System ( getArgs, getProgName, getEnv, exitWith, ExitCode(..) )
  47 import System.IO
  48 import System.IO.Error (try)
  49 import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy )
  50
  51 #ifdef mingw32_HOST_OS
  52 import Foreign
  53 import Foreign.C.String
  54 #endif
  55
  56 import IO ( isPermissionError, isDoesNotExistError )
  57
  58 -- -----------------------------------------------------------------------------
  59 -- Entry point
  60
  61 main :: IO ()
  62 main = do
  63   args <- getArgs
  64
  65   case getOpt Permute (flags ++ deprecFlags) args of
  66         (cli,_,[]) | FlagHelp `elem` cli -> do
  67            prog <- getProgramName
  68            bye (usageInfo (usageHeader prog) flags)
  69         (cli,_,[]) | FlagVersion `elem` cli ->
  70            bye ourCopyright
  71         (cli,nonopts,[]) ->
  72            runit cli nonopts
  73         (_,_,errors) -> do
  74            prog <- getProgramName
  75            die (concat errors ++ usageInfo (usageHeader prog) flags)
  76
  77 -- -----------------------------------------------------------------------------
  78 -- Command-line syntax
  79
  80 data Flag
  81   = FlagUser
  82   | FlagGlobal
  83   | FlagHelp
  84   | FlagVersion
  85   | FlagConfig FilePath
  86   | FlagGlobalConfig FilePath
  87   | FlagForce
  88   | FlagForceFiles
  89   | FlagAutoGHCiLibs
  90   | FlagSimpleOutput
  91   | FlagNamesOnly
  92   deriving Eq
  93
  94 flags :: [OptDescr Flag]
  95 flags = [
  96   Option [] ["user"] (NoArg FlagUser)
  97         "use the current user's package database",
  98   Option [] ["global"] (NoArg FlagGlobal)
  99         "(default) use the global package database",
 100   Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
 101         "act upon specified package config file (only)",
 102   Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
 103         "location of the global package config",
 104   Option [] ["force"] (NoArg FlagForce)
 105          "ignore missing dependencies, directories, and libraries",
 106   Option [] ["force-files"] (NoArg FlagForceFiles)
 107          "ignore missing directories and libraries only",
 108   Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
 109         "automatically build libs for GHCi (with register)",
 110   Option ['?'] ["help"] (NoArg FlagHelp)
 111         "display this help and exit",
 112   Option ['V'] ["version"] (NoArg FlagVersion)
 113         "output version information and exit",
 114   Option [] ["simple-output"] (NoArg FlagSimpleOutput)
 115         "print output in easy-to-parse format for some commands",
 116   Option [] ["names-only"] (NoArg FlagNamesOnly)
 117         "only print package names, not versions; can only be used with list --simple-output"
 118   ]
 119
 120 deprecFlags :: [OptDescr Flag]
 121 deprecFlags = [
 122         -- put deprecated flags here
 123   ]
 124
 125 ourCopyright :: String
 126 ourCopyright = "GHC package manager version " ++ version ++ "\n"
 127
 128 usageHeader :: String -> String
 129 usageHeader prog = substProg prog $
 130   "Usage:\n" ++
 131   "  $p register {filename | -}\n" ++
 132   "    Register the package using the specified installed package\n" ++
 133   "    description. The syntax for the latter is given in the $p\n" ++
 134   "    documentation.\n" ++
 135   "\n" ++
 136   "  $p update {filename | -}\n" ++
 137   "    Register the package, overwriting any other package with the\n" ++
 138   "    same name.\n" ++
 139   "\n" ++
 140   "  $p unregister {pkg-id}\n" ++
 141   "    Unregister the specified package.\n" ++
 142   "\n" ++
 143   "  $p expose {pkg-id}\n" ++
 144   "    Expose the specified package.\n" ++
 145   "\n" ++
 146   "  $p hide {pkg-id}\n" ++
 147   "    Hide the specified package.\n" ++
 148   "\n" ++
 149   "  $p list [pkg]\n" ++
 150   "    List registered packages in the global database, and also the\n" ++
 151   "    user database if --user is given. If a package name is given\n" ++
 152   "    all the registered versions will be listed in ascending order.\n" ++
 153   "    Accepts the --simple-output flag.\n" ++
 154   "\n" ++
 155   "  $p latest pkg\n" ++
 156   "    Prints the highest registered version of a package.\n" ++
 157   "\n" ++
 158   "  $p check\n" ++
 159   "    Check the consistency of package depenencies and list broken packages.\n" ++
 160   "    Accepts the --simple-output flag.\n" ++
 161   "\n" ++
 162   "  $p describe {pkg-id}\n" ++
 163   "    Give the registered description for the specified package. The\n" ++
 164   "    description is returned in precisely the syntax required by $p\n" ++
 165   "    register.\n" ++
 166   "\n" ++
 167   "  $p field {pkg-id} {field}\n" ++
 168   "    Extract the specified field of the package description for the\n" ++
 169   "    specified package.\n" ++
 170   "\n" ++
 171   " The following optional flags are also accepted:\n"
 172
 173 substProg :: String -> String -> String
 174 substProg _ [] = []
 175 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
 176 substProg prog (c:xs) = c : substProg prog xs
 177
 178 -- -----------------------------------------------------------------------------
 179 -- Do the business
 180
 181 data Force = ForceAll | ForceFiles | NoForce
 182
 183 runit :: [Flag] -> [String] -> IO ()
 184 runit cli nonopts = do
 185   prog <- getProgramName
 186   let
 187         force
 188           | FlagForce `elem` cli        = ForceAll
 189           | FlagForceFiles `elem` cli   = ForceFiles
 190           | otherwise                   = NoForce
 191         auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
 192   --
 193   -- first, parse the command
 194   case nonopts of
 195     ["register", filename] ->
 196         registerPackage filename cli auto_ghci_libs False force
 197     ["update", filename] ->
 198         registerPackage filename cli auto_ghci_libs True force
 199     ["unregister", pkgid_str] -> do
 200         pkgid <- readGlobPkgId pkgid_str
 201         unregisterPackage pkgid cli
 202     ["expose", pkgid_str] -> do
 203         pkgid <- readGlobPkgId pkgid_str
 204         exposePackage pkgid cli
 205     ["hide",   pkgid_str] -> do
 206         pkgid <- readGlobPkgId pkgid_str
 207         hidePackage pkgid cli
 208     ["list"] -> do
 209         listPackages cli Nothing Nothing
 210     ["list", pkgid_str] -> do
 211         pkgid <- readGlobPkgId pkgid_str
 212         listPackages cli (Just pkgid) Nothing
 213     ["find-module", moduleName] -> do
 214         listPackages cli Nothing (Just moduleName)
 215     ["latest", pkgid_str] -> do
 216         pkgid <- readGlobPkgId pkgid_str
 217         latestPackage cli pkgid
 218     ["describe", pkgid_str] -> do
 219         pkgid <- readGlobPkgId pkgid_str
 220         describePackage cli pkgid
 221     ["field", pkgid_str, field] -> do
 222         pkgid <- readGlobPkgId pkgid_str
 223         describeField cli pkgid field
 224     ["check"] -> do
 225         checkConsistency cli
 226     [] -> do
 227         die ("missing command\n" ++
 228                 usageInfo (usageHeader prog) flags)
 229     (_cmd:_) -> do
 230         die ("command-line syntax error\n" ++
 231                 usageInfo (usageHeader prog) flags)
 232
 233 parseCheck :: ReadP a a -> String -> String -> IO a
 234 parseCheck parser str what =
 235   case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
 236     [x] -> return x
 237     _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
 238
 239 readGlobPkgId :: String -> IO PackageIdentifier
 240 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
 241
 242 parseGlobPackageId :: ReadP r PackageIdentifier
 243 parseGlobPackageId =
 244   parsePackageId
 245      +++
 246   (do n <- parsePackageName; string "-*"
 247       return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
 248
 249 -- globVersion means "all versions"
 250 globVersion :: Version
 251 globVersion = Version{ versionBranch=[], versionTags=["*"] }
 252
 253 -- -----------------------------------------------------------------------------
 254 -- Package databases
 255
 256 -- Some commands operate on a single database:
 257 --      register, unregister, expose, hide
 258 -- however these commands also check the union of the available databases
 259 -- in order to check consistency.  For example, register will check that
 260 -- dependencies exist before registering a package.
 261 --
 262 -- Some commands operate  on multiple databases, with overlapping semantics:
 263 --      list, describe, field
 264
 265 type PackageDBName  = FilePath
 266 type PackageDB      = [InstalledPackageInfo]
 267
 268 type PackageDBStack = [(PackageDBName,PackageDB)]
 269         -- A stack of package databases.  Convention: head is the topmost
 270         -- in the stack.  Earlier entries override later one.
 271
 272 getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
 273 getPkgDatabases modify flags = do
 274   -- first we determine the location of the global package config.  On Windows,
 275   -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
 276   -- location is passed to the binary using the --global-config flag by the
 277   -- wrapper script.
 278   let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
 279   global_conf <-
 280      case [ f | FlagGlobalConfig f <- flags ] of
 281         [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
 282                  case mb_dir of
 283                         Nothing  -> die err_msg
 284                         Just dir -> return (dir </> "package.conf")
 285         fs -> return (last fs)
 286
 287   let global_conf_dir = global_conf ++ ".d"
 288   global_conf_dir_exists <- doesDirectoryExist global_conf_dir
 289   global_confs <-
 290     if global_conf_dir_exists
 291       then do files <- getDirectoryContents global_conf_dir
 292               return [ global_conf_dir ++ '/' : file
 293                      | file <- files
 294                      , isSuffixOf ".conf" file]
 295       else return []
 296
 297   -- get the location of the user package database, and create it if necessary
 298   appdir <- getAppUserDataDirectory "ghc"
 299
 300   let
 301         subdir = targetARCH ++ '-':targetOS ++ '-':version
 302         archdir   = appdir </> subdir
 303         user_conf = archdir </> "package.conf"
 304   user_exists <- doesFileExist user_conf
 305
 306   -- If the user database doesn't exist, and this command isn't a
 307   -- "modify" command, then we won't attempt to create or use it.
 308   let sys_databases
 309         | modify || user_exists = user_conf : global_confs ++ [global_conf]
 310         | otherwise             = global_confs ++ [global_conf]
 311
 312   e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
 313   let env_stack =
 314         case e_pkg_path of
 315                 Left  _ -> sys_databases
 316                 Right path
 317                   | last cs == ""  -> init cs ++ sys_databases
 318                   | otherwise      -> cs
 319                   where cs = splitSearchPath path
 320
 321         -- The "global" database is always the one at the bottom of the stack.
 322         -- This is the database we modify by default.
 323       virt_global_conf = last env_stack
 324
 325   -- -f flags on the command line add to the database stack, unless any
 326   -- of them are present in the stack already.
 327   let flag_stack = filter (`notElem` env_stack)
 328                         [ f | FlagConfig f <- reverse flags ] ++ env_stack
 329
 330   -- Now we have the full stack of databases.  Next, if the current
 331   -- command is a "modify" type command, then we truncate the stack
 332   -- so that the topmost element is the database being modified.
 333   final_stack <-
 334      if not modify
 335         then return flag_stack
 336         else let
 337                 go (FlagUser : fs)     = modifying user_conf
 338                 go (FlagGlobal : fs)   = modifying virt_global_conf
 339                 go (FlagConfig f : fs) = modifying f
 340                 go (_ : fs)            = go fs
 341                 go []                  = modifying virt_global_conf
 342
 343                 modifying f
 344                   | f `elem` flag_stack = return (dropWhile (/= f) flag_stack)
 345                   | otherwise           = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.")
 346              in
 347                 go flags
 348
 349   db_stack <- mapM readParseDatabase final_stack
 350   return db_stack
 351
 352 readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
 353 readParseDatabase filename = do
 354   str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig
 355   let packages = read str
 356   Exception.evaluate packages
 357     `Exception.catch` \_ ->
 358         die (filename ++ ": parse error in package config file")
 359   return (filename,packages)
 360
 361 emptyPackageConfig :: String
 362 emptyPackageConfig = "[]"
 363
 364 -- -----------------------------------------------------------------------------
 365 -- Registering
 366
 367 registerPackage :: FilePath
 368                 -> [Flag]
 369                 -> Bool              -- auto_ghci_libs
 370                 -> Bool              -- update
 371                 -> Force
 372                 -> IO ()
 373 registerPackage input flags auto_ghci_libs update force = do
 374   db_stack <- getPkgDatabases True flags
 375   let
 376         db_to_operate_on = my_head "db" db_stack
 377         db_filename      = fst db_to_operate_on
 378   --
 379
 380   s <-
 381     case input of
 382       "-" -> do
 383         putStr "Reading package info from stdin ... "
 384         getContents
 385       f   -> do
 386         putStr ("Reading package info from " ++ show f ++ " ... ")
 387         readFile f
 388
 389   expanded <- expandEnvVars s force
 390
 391   pkg <- parsePackageInfo expanded
 392   putStrLn "done."
 393
 394   validatePackageConfig pkg db_stack auto_ghci_libs update force
 395   let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
 396       not_this p = package p /= package pkg
 397   savingOldConfig db_filename $
 398     writeNewConfig db_filename new_details
 399
 400 parsePackageInfo
 401         :: String
 402         -> IO InstalledPackageInfo
 403 parsePackageInfo str =
 404   case parseInstalledPackageInfo str of
 405     ParseOk _warns ok -> return ok
 406     ParseFailed err -> case locatedErrorMsg err of
 407                            (Nothing, s) -> die s
 408                            (Just l, s) -> die (show l ++ ": " ++ s)
 409
 410 -- -----------------------------------------------------------------------------
 411 -- Exposing, Hiding, Unregistering are all similar
 412
 413 exposePackage :: PackageIdentifier ->  [Flag] -> IO ()
 414 exposePackage = modifyPackage (\p -> [p{exposed=True}])
 415
 416 hidePackage :: PackageIdentifier ->  [Flag] -> IO ()
 417 hidePackage = modifyPackage (\p -> [p{exposed=False}])
 418
 419 unregisterPackage :: PackageIdentifier ->  [Flag] -> IO ()
 420 unregisterPackage = modifyPackage (\p -> [])
 421
 422 modifyPackage
 423   :: (InstalledPackageInfo -> [InstalledPackageInfo])
 424   -> PackageIdentifier
 425   -> [Flag]
 426   -> IO ()
 427 modifyPackage fn pkgid flags  = do
 428   db_stack <- getPkgDatabases True{-modify-} flags
 429   let ((db_name, pkgs) : _) = db_stack
 430   ps <- findPackages [(db_name,pkgs)] pkgid
 431   let pids = map package ps
 432   let new_config = concat (map modify pkgs)
 433       modify pkg
 434           | package pkg `elem` pids = fn pkg
 435           | otherwise               = [pkg]
 436   savingOldConfig db_name $
 437       writeNewConfig db_name new_config
 438
 439 -- -----------------------------------------------------------------------------
 440 -- Listing packages
 441
 442 listPackages ::  [Flag] -> Maybe PackageIdentifier -> Maybe String -> IO ()
 443 listPackages flags mPackageName mModuleName = do
 444   let simple_output = FlagSimpleOutput `elem` flags
 445   db_stack <- getPkgDatabases False flags
 446   let db_stack_filtered -- if a package is given, filter out all other packages
 447         | Just this <- mPackageName =
 448             map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
 449                 db_stack
 450         | Just this <- mModuleName = -- packages which expose mModuleName
 451             map (\(conf,pkgs) -> (conf, filter (this `exposedInPkg`) pkgs))
 452                 db_stack
 453         | otherwise = db_stack
 454
 455       db_stack_sorted
 456           = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ]
 457           where sort_pkgs = sortBy cmpPkgIds
 458                 cmpPkgIds pkg1 pkg2 =
 459                    case pkgName p1 `compare` pkgName p2 of
 460                         LT -> LT
 461                         GT -> GT
 462                         EQ -> pkgVersion p1 `compare` pkgVersion p2
 463                    where (p1,p2) = (package pkg1, package pkg2)
 464
 465       pkg_map = map (\p -> (package p, p)) $ concatMap snd db_stack
 466       show_func = if simple_output then show_simple else mapM_ (show_normal pkg_map)
 467
 468   show_func (reverse db_stack_sorted)
 469
 470   where show_normal pkg_map (db_name,pkg_confs) =
 471           hPutStrLn stdout (render $
 472                 text db_name <> colon $$ nest 4 packages
 473                 )
 474            where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
 475                  pp_pkg p
 476                    | isBrokenPackage p pkg_map = braces doc
 477                    | exposed p = doc
 478                    | otherwise = parens doc
 479                    where doc = text (showPackageId (package p))
 480
 481         show_simple db_stack = do
 482           let showPkg = if FlagNamesOnly `elem` flags then pkgName
 483                                                       else showPackageId
 484               pkgs = map showPkg $ sortBy compPkgIdVer $
 485                           map package (concatMap snd db_stack)
 486           when (null pkgs) $ die "no matches"
 487           hPutStrLn stdout $ concat $ intersperse " " pkgs
 488
 489 -- -----------------------------------------------------------------------------
 490 -- Prints the highest (hidden or exposed) version of a package
 491
 492 latestPackage ::  [Flag] -> PackageIdentifier -> IO ()
 493 latestPackage flags pkgid = do
 494   db_stack <- getPkgDatabases False flags
 495   ps <- findPackages db_stack pkgid
 496   show_pkg (sortBy compPkgIdVer (map package ps))
 497   where
 498     show_pkg [] = die "no matches"
 499     show_pkg pids = hPutStrLn stdout (showPackageId (last pids))
 500
 501 -- -----------------------------------------------------------------------------
 502 -- Describe
 503
 504 describePackage :: [Flag] -> PackageIdentifier -> IO ()
 505 describePackage flags pkgid = do
 506   db_stack <- getPkgDatabases False flags
 507   ps <- findPackages db_stack pkgid
 508   mapM_ (putStrLn . showInstalledPackageInfo) ps
 509
 510 -- PackageId is can have globVersion for the version
 511 findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo]
 512 findPackages db_stack pkgid
 513   = case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of
 514         []  -> die ("cannot find package " ++ showPackageId pkgid)
 515         ps -> return ps
 516   where
 517         all_pkgs = concat (map snd db_stack)
 518
 519 matches :: PackageIdentifier -> PackageIdentifier -> Bool
 520 pid `matches` pid'
 521   = (pkgName pid == pkgName pid')
 522     && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
 523
 524 matchesPkg :: PackageIdentifier -> InstalledPackageInfo -> Bool
 525 pid `matchesPkg` pkg = pid `matches` package pkg
 526
 527 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
 528 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
 529
 530 exposedInPkg :: String -> InstalledPackageInfo -> Bool
 531 moduleName `exposedInPkg` pkg = moduleName `elem` exposedModules pkg
 532
 533 -- -----------------------------------------------------------------------------
 534 -- Field
 535
 536 describeField :: [Flag] -> PackageIdentifier -> String -> IO ()
 537 describeField flags pkgid field = do
 538   db_stack <- getPkgDatabases False flags
 539   case toField field of
 540     Nothing -> die ("unknown field: " ++ field)
 541     Just fn -> do
 542         ps <- findPackages db_stack pkgid
 543         let top_dir = takeDirectory (fst (last db_stack))
 544         mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps)
 545
 546 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
 547 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
 548 -- with the current topdir (obtained from the -B option).
 549 mungePackagePaths top_dir ps = map munge_pkg ps
 550   where
 551   munge_pkg p = p{ importDirs        = munge_paths (importDirs p),
 552                    includeDirs       = munge_paths (includeDirs p),
 553                    libraryDirs       = munge_paths (libraryDirs p),
 554                    frameworkDirs     = munge_paths (frameworkDirs p),
 555                    haddockInterfaces = munge_paths (haddockInterfaces p),
 556                    haddockHTMLs      = munge_paths (haddockHTMLs p)
 557                  }
 558
 559   munge_paths = map munge_path
 560
 561   munge_path p
 562    | Just p' <- maybePrefixMatch "$topdir"     p =            top_dir ++ p'
 563    | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
 564    | otherwise                               = p
 565
 566   toHttpPath p = "file:///" ++ p
 567
 568 maybePrefixMatch :: String -> String -> Maybe String
 569 maybePrefixMatch []    rest = Just rest
 570 maybePrefixMatch (_:_) []   = Nothing
 571 maybePrefixMatch (p:pat) (r:rest)
 572   | p == r    = maybePrefixMatch pat rest
 573   | otherwise = Nothing
 574
 575 toField :: String -> Maybe (InstalledPackageInfo -> String)
 576 -- backwards compatibility:
 577 toField "import_dirs"     = Just $ strList . importDirs
 578 toField "source_dirs"     = Just $ strList . importDirs
 579 toField "library_dirs"    = Just $ strList . libraryDirs
 580 toField "hs_libraries"    = Just $ strList . hsLibraries
 581 toField "extra_libraries" = Just $ strList . extraLibraries
 582 toField "include_dirs"    = Just $ strList . includeDirs
 583 toField "c_includes"      = Just $ strList . includes
 584 toField "package_deps"    = Just $ strList . map showPackageId. depends
 585 toField "extra_cc_opts"   = Just $ strList . ccOptions
 586 toField "extra_ld_opts"   = Just $ strList . ldOptions
 587 toField "framework_dirs"  = Just $ strList . frameworkDirs
 588 toField "extra_frameworks"= Just $ strList . frameworks
 589 toField s                 = showInstalledPackageInfoField s
 590
 591 strList :: [String] -> String
 592 strList = show
 593
 594
 595 -- -----------------------------------------------------------------------------
 596 -- Check: Check consistency of installed packages
 597
 598 checkConsistency :: [Flag] -> IO ()
 599 checkConsistency flags = do
 600   db_stack <- getPkgDatabases False flags
 601   let pkgs = map (\p -> (package p, p)) $ concatMap snd db_stack
 602       broken_pkgs = do
 603         (pid, p) <- pkgs
 604         let broken_deps = missingPackageDeps p pkgs
 605         guard (not . null $ broken_deps)
 606         return (pid, broken_deps)
 607   mapM_ (putStrLn . render . show_func) broken_pkgs
 608   where
 609   show_func | FlagSimpleOutput `elem` flags = show_simple
 610             | otherwise = show_normal
 611   show_simple (pid,deps) =
 612     text (showPackageId pid) <> colon
 613       <+> fsep (punctuate comma (map (text . showPackageId) deps))
 614   show_normal (pid,deps) =
 615     text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:"
 616       $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps)))
 617
 618 missingPackageDeps :: InstalledPackageInfo
 619                    -> [(PackageIdentifier, InstalledPackageInfo)]
 620                    -> [PackageIdentifier]
 621 missingPackageDeps pkg pkg_map =
 622   [ d | d <- depends pkg, isNothing (lookup d pkg_map)] ++
 623   [ d | d <- depends pkg, Just p <- return (lookup d pkg_map), isBrokenPackage p pkg_map]
 624
 625 isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool
 626 isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map
 627
 628
 629 -- -----------------------------------------------------------------------------
 630 -- Manipulating package.conf files
 631
 632 writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
 633 writeNewConfig filename packages = do
 634   hPutStr stdout "Writing new package config file... "
 635   createDirectoryIfMissing True $ takeDirectory filename
 636   h <- openFile filename WriteMode `catch` \e ->
 637       if isPermissionError e
 638       then die (filename ++ ": you don't have permission to modify this file")
 639       else ioError e
 640   let shown = concat $ intersperse ",\n " $ map show packages
 641       fileContents = "[" ++ shown ++ "\n]"
 642   hPutStrLn h fileContents
 643   hClose h
 644   hPutStrLn stdout "done."
 645
 646 savingOldConfig :: FilePath -> IO () -> IO ()
 647 savingOldConfig filename io = Exception.block $ do
 648   hPutStr stdout "Saving old package config file... "
 649     -- mv rather than cp because we've already done an hGetContents
 650     -- on this file so we won't be able to open it for writing
 651     -- unless we move the old one out of the way...
 652   let oldFile = filename ++ ".old"
 653   restore_on_error <- catch (renameFile filename oldFile >> return True) $
 654       \err -> do
 655           unless (isDoesNotExistError err) $ do
 656               hPutStrLn stderr (unwords ["Unable to rename", show filename,
 657                                          "to", show oldFile])
 658               ioError err
 659           return False
 660   hPutStrLn stdout "done."
 661   io `catch` \e -> do
 662       hPutStrLn stderr (show e)
 663       hPutStr stdout ("\nWARNING: an error was encountered while writing"
 664                    ++ "the new configuration.\n")
 665       when restore_on_error $ do
 666           hPutStr stdout "Attempting to restore the old configuration..."
 667           do renameFile oldFile filename
 668              hPutStrLn stdout "done."
 669            `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err)
 670       ioError e
 671
 672 -----------------------------------------------------------------------------
 673 -- Sanity-check a new package config, and automatically build GHCi libs
 674 -- if requested.
 675
 676 validatePackageConfig :: InstalledPackageInfo
 677                       -> PackageDBStack
 678                       -> Bool   -- auto-ghc-libs
 679                       -> Bool   -- update
 680                       -> Force
 681                       -> IO ()
 682 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
 683   checkPackageId pkg
 684   checkDuplicates db_stack pkg update
 685   mapM_ (checkDep db_stack force) (depends pkg)
 686   mapM_ (checkDir force) (importDirs pkg)
 687   mapM_ (checkDir force) (libraryDirs pkg)
 688   mapM_ (checkDir force) (includeDirs pkg)
 689   mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg)
 690   -- ToDo: check these somehow?
 691   --    extra_libraries :: [String],
 692   --    c_includes      :: [String],
 693
 694 -- When the package name and version are put together, sometimes we can
 695 -- end up with a package id that cannot be parsed.  This will lead to
 696 -- difficulties when the user wants to refer to the package later, so
 697 -- we check that the package id can be parsed properly here.
 698 checkPackageId :: InstalledPackageInfo -> IO ()
 699 checkPackageId ipi =
 700   let str = showPackageId (package ipi) in
 701   case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of
 702     [_] -> return ()
 703     []  -> die ("invalid package identifier: " ++ str)
 704     _   -> die ("ambiguous package identifier: " ++ str)
 705
 706 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
 707 checkDuplicates db_stack pkg update = do
 708   let
 709         pkgid = package pkg
 710         (_top_db_name, pkgs) : _  = db_stack
 711   --
 712   -- Check whether this package id already exists in this DB
 713   --
 714   when (not update && (pkgid `elem` map package pkgs)) $
 715        die ("package " ++ showPackageId pkgid ++ " is already installed")
 716
 717
 718
 719 checkDir :: Force -> String -> IO ()
 720 checkDir force d
 721  | "$topdir"     `isPrefixOf` d = return ()
 722  | "$httptopdir" `isPrefixOf` d = return ()
 723         -- can't check these, because we don't know what $(http)topdir is
 724  | otherwise = do
 725    there <- doesDirectoryExist d
 726    when (not there)
 727        (dieOrForceFile force (d ++ " doesn't exist or isn't a directory"))
 728
 729 checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
 730 checkDep db_stack force pkgid
 731   | pkgid `elem` pkgids || (not real_version && name_exists) = return ()
 732   | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
 733                                         ++ " doesn't exist")
 734   where
 735         -- for backwards compat, we treat 0.0 as a special version,
 736         -- and don't check that it actually exists.
 737         real_version = realVersion pkgid
 738
 739         name_exists = any (\p -> pkgName (package p) == name) all_pkgs
 740         name = pkgName pkgid
 741
 742         all_pkgs = concat (map snd db_stack)
 743         pkgids = map package all_pkgs
 744
 745 realVersion :: PackageIdentifier -> Bool
 746 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
 747
 748 checkHSLib :: [String] -> Bool -> Force -> String -> IO ()
 749 checkHSLib dirs auto_ghci_libs force lib = do
 750   let batch_lib_file = "lib" ++ lib ++ ".a"
 751   bs <- mapM (doesLibExistIn batch_lib_file) dirs
 752   case [ dir | (exists,dir) <- zip bs dirs, exists ] of
 753         [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++
 754                                     " on library path")
 755         (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
 756
 757 doesLibExistIn :: String -> String -> IO Bool
 758 doesLibExistIn lib d
 759  | "$topdir"     `isPrefixOf` d = return True
 760  | "$httptopdir" `isPrefixOf` d = return True
 761  | otherwise                = doesFileExist (d ++ '/':lib)
 762
 763 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
 764 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
 765   | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
 766   | otherwise  = do
 767       bs <- mapM (doesLibExistIn ghci_lib_file) dirs
 768       case [dir | (exists,dir) <- zip bs dirs, exists] of
 769         []    -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
 770         (_:_) -> return ()
 771   where
 772     ghci_lib_file = lib ++ ".o"
 773
 774 -- automatically build the GHCi version of a batch lib,
 775 -- using ld --whole-archive.
 776
 777 autoBuildGHCiLib :: String -> String -> String -> IO ()
 778 autoBuildGHCiLib dir batch_file ghci_file = do
 779   let ghci_lib_file  = dir ++ '/':ghci_file
 780       batch_lib_file = dir ++ '/':batch_file
 781   hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
 782 #if defined(darwin_HOST_OS)
 783   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
 784 #elif defined(mingw32_HOST_OS)
 785   execDir <- getExecDir "/bin/ghc-pkg.exe"
 786   r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
 787 #else
 788   r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
 789 #endif
 790   when (r /= ExitSuccess) $ exitWith r
 791   hPutStrLn stderr (" done.")
 792
 793 -- -----------------------------------------------------------------------------
 794 -- Searching for modules
 795
 796 #if not_yet
 797
 798 findModules :: [FilePath] -> IO [String]
 799 findModules paths =
 800   mms <- mapM searchDir paths
 801   return (concat mms)
 802
 803 searchDir path prefix = do
 804   fs <- getDirectoryEntries path `catch` \_ -> return []
 805   searchEntries path prefix fs
 806
 807 searchEntries path prefix [] = return []
 808 searchEntries path prefix (f:fs)
 809   | looks_like_a_module  =  do
 810         ms <- searchEntries path prefix fs
 811         return (prefix `joinModule` f : ms)
 812   | looks_like_a_component  =  do
 813         ms <- searchDir (path </> f) (prefix `joinModule` f)
 814         ms' <- searchEntries path prefix fs
 815         return (ms ++ ms')
 816   | otherwise
 817         searchEntries path prefix fs
 818
 819   where
 820         (base,suffix) = splitFileExt f
 821         looks_like_a_module =
 822                 suffix `elem` haskell_suffixes &&
 823                 all okInModuleName base
 824         looks_like_a_component =
 825                 null suffix && all okInModuleName base
 826
 827 okInModuleName c
 828
 829 #endif
 830
 831 -- ---------------------------------------------------------------------------
 832 -- expanding environment variables in the package configuration
 833
 834 expandEnvVars :: String -> Force -> IO String
 835 expandEnvVars str force = go str ""
 836  where
 837    go "" acc = return $! reverse acc
 838    go ('$':'{':str) acc | (var, '}':rest) <- break close str
 839         = do value <- lookupEnvVar var
 840              go rest (reverse value ++ acc)
 841         where close c = c == '}' || c == '\n' -- don't span newlines
 842    go (c:str) acc
 843         = go str (c:acc)
 844
 845    lookupEnvVar :: String -> IO String
 846    lookupEnvVar nm =
 847         catch (System.getEnv nm)
 848            (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
 849                                         show nm)
 850                       return "")
 851
 852 -----------------------------------------------------------------------------
 853
 854 getProgramName :: IO String
 855 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
 856    where str `withoutSuffix` suff
 857             | suff `isSuffixOf` str = take (length str - length suff) str
 858             | otherwise             = str
 859
 860 bye :: String -> IO a
 861 bye s = putStr s >> exitWith ExitSuccess
 862
 863 die :: String -> IO a
 864 die s = do
 865   hFlush stdout
 866   prog <- getProgramName
 867   hPutStrLn stderr (prog ++ ": " ++ s)
 868   exitWith (ExitFailure 1)
 869
 870 dieOrForceAll :: Force -> String -> IO ()
 871 dieOrForceAll ForceAll s = ignoreError s
 872 dieOrForceAll _other s   = dieForcible s
 873
 874 dieOrForceFile :: Force -> String -> IO ()
 875 dieOrForceFile ForceAll   s = ignoreError s
 876 dieOrForceFile ForceFiles s = ignoreError s
 877 dieOrForceFile _other     s = dieForcible s
 878
 879 ignoreError :: String -> IO ()
 880 ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
 881
 882 dieForcible :: String -> IO ()
 883 dieForcible s = die (s ++ " (use --force to override)")
 884
 885 my_head :: String -> [a] -> a
 886 my_head s [] = error s
 887 my_head s (x:xs) = x
 888
 889 -----------------------------------------
 890 -- Cut and pasted from ghc/compiler/SysTools
 891
 892 #if defined(mingw32_HOST_OS)
 893 subst :: Char -> Char -> String -> String
 894 subst a b ls = map (\ x -> if x == a then b else x) ls
 895
 896 unDosifyPath :: FilePath -> FilePath
 897 unDosifyPath xs = subst '\\' '/' xs
 898
 899 getExecDir :: String -> IO (Maybe String)
 900 -- (getExecDir cmd) returns the directory in which the current
 901 --                  executable, which should be called 'cmd', is running
 902 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
 903 -- you'll get "/a/b/c" back as the result
 904 getExecDir cmd
 905   = allocaArray len $ \buf -> do
 906         ret <- getModuleFileName nullPtr buf len
 907         if ret == 0 then return Nothing
 908                     else do s <- peekCString buf
 909                             return (Just (reverse (drop (length cmd)
 910                                                         (reverse (unDosifyPath s)))))
 911   where
 912     len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
 913
 914 foreign import stdcall unsafe  "GetModuleFileNameA"
 915   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 916 #else
 917 getExecDir :: String -> IO (Maybe String)
 918 getExecDir _ = return Nothing
 919 #endif