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