utils/ghc-pkg/Main.hs

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