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