utils/ghc-pkg/Main.hs

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