+++ /dev/null
-{-# OPTIONS -fglasgow-exts #-}
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 2004.
---
--- Package management tool
---
------------------------------------------------------------------------------
-
--- TODO:
--- - validate modules
--- - expanding of variables in new-style package conf
--- - version manipulation (checking whether old version exists,
--- hiding old version?)
-
-module Main (main) where
-
-import Version ( version, targetOS, targetARCH )
-import Distribution.InstalledPackageInfo
-import Distribution.Compat.ReadP
-import Distribution.ParseUtils ( showError )
-import Distribution.Package
-import Distribution.Version
-import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
-import Compat.RawSystem ( rawSystem )
-
-import Prelude
-
-#include "../../includes/ghcconfig.h"
-
-#if __GLASGOW_HASKELL__ >= 504
-import System.Console.GetOpt
-import Text.PrettyPrint
-import qualified Control.Exception as Exception
-import Data.Maybe
-#else
-import GetOpt
-import Pretty
-import qualified Exception
-import Maybe
-#endif
-
-import Data.Char ( isSpace )
-import Monad
-import Directory
-import System ( getArgs, getProgName, getEnv,
- exitWith, ExitCode(..)
- )
-import System.IO
-#if __GLASGOW_HASKELL__ >= 600
-import System.IO.Error (try)
-#else
-import System.IO (try)
-#endif
-import Data.List ( isPrefixOf, isSuffixOf, intersperse, groupBy, sortBy )
-
-#ifdef mingw32_HOST_OS
-import Foreign
-
-#if __GLASGOW_HASKELL__ >= 504
-import Foreign.C.String
-#else
-import CString
-#endif
-#endif
-
--- -----------------------------------------------------------------------------
--- Entry point
-
-main :: IO ()
-main = do
- args <- getArgs
-
- case getOpt Permute flags args of
- (cli,_,[]) | FlagHelp `elem` cli -> do
- prog <- getProgramName
- bye (usageInfo (usageHeader prog) flags)
- (cli,_,[]) | FlagVersion `elem` cli ->
- bye ourCopyright
- (cli,nonopts,[]) ->
- runit cli nonopts
- (_,_,errors) -> tryOldCmdLine errors args
-
--- If the new command-line syntax fails, then we try the old. If that
--- fails too, then we output the original errors and the new syntax
--- (so the old syntax is still available, but hidden).
-tryOldCmdLine :: [String] -> [String] -> IO ()
-tryOldCmdLine errors args = do
- case getOpt Permute oldFlags args of
- (cli@(_:_),[],[]) ->
- oldRunit cli
- _failed -> do
- prog <- getProgramName
- die (concat errors ++ usageInfo (usageHeader prog) flags)
-
--- -----------------------------------------------------------------------------
--- Command-line syntax
-
-data Flag
- = FlagUser
- | FlagGlobal
- | FlagHelp
- | FlagVersion
- | FlagConfig FilePath
- | FlagGlobalConfig FilePath
- | FlagForce
- | FlagAutoGHCiLibs
- | FlagDefinedName String String
- | FlagSimpleOutput
- deriving Eq
-
-flags :: [OptDescr Flag]
-flags = [
- Option [] ["user"] (NoArg FlagUser)
- "use the current user's package database",
- Option [] ["global"] (NoArg FlagGlobal)
- "(default) use the global package database",
- Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
- "act upon specified package config file (only)",
- Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
- "location of the global package config",
- Option [] ["force"] (NoArg FlagForce)
- "ignore missing dependencies, directories, and libraries",
- Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
- "automatically build libs for GHCi (with register)",
- Option ['?'] ["help"] (NoArg FlagHelp)
- "display this help and exit",
- Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
- "define NAME as VALUE",
- Option ['V'] ["version"] (NoArg FlagVersion)
- "output version information and exit",
- Option [] ["simple-output"] (NoArg FlagSimpleOutput)
- "print output in easy-to-parse format when running command 'list'"
- ]
- where
- toDefined str =
- case break (=='=') str of
- (nm,[]) -> FlagDefinedName nm []
- (nm,_:val) -> FlagDefinedName nm val
-
-ourCopyright :: String
-ourCopyright = "GHC package manager version " ++ version ++ "\n"
-
-usageHeader :: String -> String
-usageHeader prog = substProg prog $
- "Usage:\n" ++
- " $p register {filename | -}\n" ++
- " Register the package using the specified installed package\n" ++
- " description. The syntax for the latter is given in the $p\n" ++
- " documentation.\n" ++
- "\n" ++
- " $p update {filename | -}\n" ++
- " Register the package, overwriting any other package with the\n" ++
- " same name.\n" ++
- "\n" ++
- " $p unregister {pkg-id}\n" ++
- " Unregister the specified package.\n" ++
- "\n" ++
- " $p expose {pkg-id}\n" ++
- " Expose the specified package.\n" ++
- "\n" ++
- " $p hide {pkg-id}\n" ++
- " Hide the specified package.\n" ++
- "\n" ++
- " $p list [pkg]\n" ++
- " List registered packages in the global database, and also the\n" ++
- " user database if --user is given. If a package name is given\n" ++
- " all the registered versions will be listed in ascending order.\n" ++
- "\n" ++
- " $p latest pkg\n" ++
- " Prints the highest registered version of a package.\n" ++
- "\n" ++
- " $p describe {pkg-id}\n" ++
- " Give the registered description for the specified package. The\n" ++
- " description is returned in precisely the syntax required by $p\n" ++
- " register.\n" ++
- "\n" ++
- " $p field {pkg-id} {field}\n" ++
- " Extract the specified field of the package description for the\n" ++
- " specified package.\n" ++
- "\n" ++
- " The following optional flags are also accepted:\n"
-
-substProg :: String -> String -> String
-substProg _ [] = []
-substProg prog ('$':'p':xs) = prog ++ substProg prog xs
-substProg prog (c:xs) = c : substProg prog xs
-
--- -----------------------------------------------------------------------------
--- Do the business
-
-runit :: [Flag] -> [String] -> IO ()
-runit cli nonopts = do
- prog <- getProgramName
- let
- force = FlagForce `elem` cli
- auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
- defines = [ (nm,val) | FlagDefinedName nm val <- cli ]
- --
- -- first, parse the command
- case nonopts of
- ["register", filename] ->
- registerPackage filename defines cli auto_ghci_libs False force
- ["update", filename] ->
- registerPackage filename defines cli auto_ghci_libs True force
- ["unregister", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- unregisterPackage pkgid cli
- ["expose", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- exposePackage pkgid cli
- ["hide", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- hidePackage pkgid cli
- ["list"] -> do
- listPackages cli Nothing
- ["list", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- listPackages cli (Just pkgid)
- ["latest", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- latestPackage cli pkgid
- ["describe", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- describePackage cli pkgid
- ["field", pkgid_str, field] -> do
- pkgid <- readGlobPkgId pkgid_str
- describeField cli pkgid field
- [] -> do
- die ("missing command\n" ++
- usageInfo (usageHeader prog) flags)
- (_cmd:_) -> do
- die ("command-line syntax error\n" ++
- usageInfo (usageHeader prog) flags)
-
-parseCheck :: ReadP a a -> String -> String -> IO a
-parseCheck parser str what =
- case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
- [x] -> return x
- _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
-
-readPkgId :: String -> IO PackageIdentifier
-readPkgId str = parseCheck parsePackageId str "package identifier"
-
-readGlobPkgId :: String -> IO PackageIdentifier
-readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
-
-parseGlobPackageId :: ReadP r PackageIdentifier
-parseGlobPackageId =
- parsePackageId
- +++
- (do n <- parsePackageName; string "-*"
- return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
-
--- globVersion means "all versions"
-globVersion :: Version
-globVersion = Version{ versionBranch=[], versionTags=["*"] }
-
--- -----------------------------------------------------------------------------
--- Package databases
-
--- Some commands operate on a single database:
--- register, unregister, expose, hide
--- however these commands also check the union of the available databases
--- in order to check consistency. For example, register will check that
--- dependencies exist before registering a package.
---
--- Some commands operate on multiple databases, with overlapping semantics:
--- list, describe, field
-
-type PackageDBName = FilePath
-type PackageDB = [InstalledPackageInfo]
-
-type PackageDBStack = [(PackageDBName,PackageDB)]
- -- A stack of package databases. Convention: head is the topmost
- -- in the stack. Earlier entries override later one.
-
-getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
-getPkgDatabases modify flags = do
- -- first we determine the location of the global package config. On Windows,
- -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
- -- location is passed to the binary using the --global-config flag by the
- -- wrapper script.
- let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
- global_conf <-
- case [ f | FlagGlobalConfig f <- flags ] of
- [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
- case mb_dir of
- Nothing -> die err_msg
- Just dir -> return (dir `joinFileName` "package.conf")
- fs -> return (last fs)
-
- let global_conf_dir = global_conf ++ ".d"
- global_conf_dir_exists <- doesDirectoryExist global_conf_dir
- global_confs <-
- if global_conf_dir_exists
- then do files <- getDirectoryContents global_conf_dir
- return [ global_conf_dir ++ '/' : file
- | file <- files
- , isSuffixOf ".conf" file]
- else return []
-
- -- get the location of the user package database, and create it if necessary
- appdir <- getAppUserDataDirectory "ghc"
-
- let
- subdir = targetARCH ++ '-':targetOS ++ '-':version
- archdir = appdir `joinFileName` subdir
- user_conf = archdir `joinFileName` "package.conf"
- user_exists <- doesFileExist user_conf
-
- -- If the user database doesn't exist, and this command isn't a
- -- "modify" command, then we won't attempt to create or use it.
- let sys_databases
- | modify || user_exists = user_conf : global_confs ++ [global_conf]
- | otherwise = global_confs ++ [global_conf]
-
- e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
- let env_stack =
- case e_pkg_path of
- Left _ -> sys_databases
- Right path
- | last cs == "" -> init cs ++ sys_databases
- | otherwise -> cs
- where cs = parseSearchPath path
-
- -- The "global" database is always the one at the bottom of the stack.
- -- This is the database we modify by default.
- virt_global_conf = last env_stack
-
- -- -f flags on the command line add to the database stack, unless any
- -- of them are present in the stack already.
- let flag_stack = filter (`notElem` env_stack)
- [ f | FlagConfig f <- reverse flags ] ++ env_stack
-
- -- Now we have the full stack of databases. Next, if the current
- -- command is a "modify" type command, then we truncate the stack
- -- so that the topmost element is the database being modified.
- final_stack <-
- if not modify
- then return flag_stack
- else let
- go (FlagUser : fs) = modifying user_conf
- go (FlagGlobal : fs) = modifying virt_global_conf
- go (FlagConfig f : fs) = modifying f
- go (_ : fs) = go fs
- go [] = modifying virt_global_conf
-
- modifying f
- | f `elem` flag_stack = return (dropWhile (/= f) flag_stack)
- | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.")
- in
- go flags
-
- -- we create the user database iff (a) we're modifying, and (b) the
- -- user asked to use it by giving the --user flag.
- when (not user_exists && user_conf `elem` final_stack) $ do
- putStrLn ("Creating user package database in " ++ user_conf)
- createDirectoryIfMissing True archdir
- writeFile user_conf emptyPackageConfig
-
- db_stack <- mapM readParseDatabase final_stack
- return db_stack
-
-readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
-readParseDatabase filename = do
- str <- readFile filename
- let packages = read str
- Exception.evaluate packages
- `Exception.catch` \_ ->
- die (filename ++ ": parse error in package config file")
- return (filename,packages)
-
-emptyPackageConfig :: String
-emptyPackageConfig = "[]"
-
--- -----------------------------------------------------------------------------
--- Registering
-
-registerPackage :: FilePath
- -> [(String,String)] -- defines
- -> [Flag]
- -> Bool -- auto_ghci_libs
- -> Bool -- update
- -> Bool -- force
- -> IO ()
-registerPackage input defines flags auto_ghci_libs update force = do
- db_stack <- getPkgDatabases True flags
- let
- db_to_operate_on = my_head "db" db_stack
- db_filename = fst db_to_operate_on
- --
- checkConfigAccess db_filename
-
- s <-
- case input of
- "-" -> do
- putStr "Reading package info from stdin ... "
- getContents
- f -> do
- putStr ("Reading package info from " ++ show f ++ " ... ")
- readFile f
-
- expanded <- expandEnvVars s defines force
-
- pkg0 <- parsePackageInfo expanded defines force
- putStrLn "done."
-
- let pkg = resolveDeps db_stack pkg0
- overlaps <- validatePackageConfig pkg db_stack auto_ghci_libs update force
- new_details <- updatePackageDB db_stack overlaps (snd db_to_operate_on) pkg
- savePackageConfig db_filename
- maybeRestoreOldConfig db_filename $
- writeNewConfig db_filename new_details
-
-parsePackageInfo
- :: String
- -> [(String,String)]
- -> Bool
- -> IO InstalledPackageInfo
-parsePackageInfo str defines force =
- case parseInstalledPackageInfo str of
- ParseOk _warns ok -> return ok
- ParseFailed err -> die (showError err)
-
--- -----------------------------------------------------------------------------
--- Exposing, Hiding, Unregistering are all similar
-
-exposePackage :: PackageIdentifier -> [Flag] -> IO ()
-exposePackage = modifyPackage (\p -> [p{exposed=True}])
-
-hidePackage :: PackageIdentifier -> [Flag] -> IO ()
-hidePackage = modifyPackage (\p -> [p{exposed=False}])
-
-unregisterPackage :: PackageIdentifier -> [Flag] -> IO ()
-unregisterPackage = modifyPackage (\p -> [])
-
-modifyPackage
- :: (InstalledPackageInfo -> [InstalledPackageInfo])
- -> PackageIdentifier
- -> [Flag]
- -> IO ()
-modifyPackage fn pkgid flags = do
- db_stack <- getPkgDatabases True{-modify-} flags
- let ((db_name, pkgs) : _) = db_stack
- checkConfigAccess db_name
- ps <- findPackages [(db_name,pkgs)] pkgid
- let pids = map package ps
- savePackageConfig db_name
- let new_config = concat (map modify pkgs)
- modify pkg
- | package pkg `elem` pids = fn pkg
- | otherwise = [pkg]
- maybeRestoreOldConfig db_name $
- writeNewConfig db_name new_config
-
--- -----------------------------------------------------------------------------
--- Listing packages
-
-listPackages :: [Flag] -> Maybe PackageIdentifier -> IO ()
-listPackages flags mPackageName = do
- let simple_output = FlagSimpleOutput `elem` flags
- db_stack <- getPkgDatabases False flags
- let db_stack_filtered -- if a package is given, filter out all other packages
- | Just this <- mPackageName =
- map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
- db_stack
- | otherwise = db_stack
-
- db_stack_sorted
- = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ]
- where sort_pkgs = sortBy cmpPkgIds
- cmpPkgIds pkg1 pkg2 =
- case pkgName p1 `compare` pkgName p2 of
- LT -> LT
- GT -> GT
- EQ -> pkgVersion p1 `compare` pkgVersion p2
- where (p1,p2) = (package pkg1, package pkg2)
-
- show_func = if simple_output then show_easy else mapM_ show_regular
-
- show_func (reverse db_stack_sorted)
-
- where show_regular (db_name,pkg_confs) =
- hPutStrLn stdout (render $
- text (db_name ++ ":") $$ nest 4 packages
- )
- where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
- pp_pkg p
- | exposed p = doc
- | otherwise = parens doc
- where doc = text (showPackageId (package p))
-
- show_easy db_stack = do
- let pkgs = map showPackageId $ sortBy compPkgIdVer $
- map package (concatMap snd db_stack)
- when (null pkgs) $ die "no matches"
- hPutStrLn stdout $ concat $ intersperse " " pkgs
-
--- -----------------------------------------------------------------------------
--- Prints the highest (hidden or exposed) version of a package
-
-latestPackage :: [Flag] -> PackageIdentifier -> IO ()
-latestPackage flags pkgid = do
- db_stack <- getPkgDatabases False flags
- ps <- findPackages db_stack pkgid
- show_pkg (sortBy compPkgIdVer (map package ps))
- where
- show_pkg [] = die "no matches"
- show_pkg pids = hPutStrLn stdout (showPackageId (last pids))
-
--- -----------------------------------------------------------------------------
--- Describe
-
-describePackage :: [Flag] -> PackageIdentifier -> IO ()
-describePackage flags pkgid = do
- db_stack <- getPkgDatabases False flags
- ps <- findPackages db_stack pkgid
- mapM_ (putStrLn . showInstalledPackageInfo) ps
-
--- PackageId is can have globVersion for the version
-findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo]
-findPackages db_stack pkgid
- = case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of
- [] -> die ("cannot find package " ++ showPackageId pkgid)
- ps -> return ps
- where
- all_pkgs = concat (map snd db_stack)
-
-matches :: PackageIdentifier -> PackageIdentifier -> Bool
-pid `matches` pid'
- = (pkgName pid == pkgName pid')
- && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
-
-matchesPkg :: PackageIdentifier -> InstalledPackageInfo -> Bool
-pid `matchesPkg` pkg = pid `matches` package pkg
-
-compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
-compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
-
--- -----------------------------------------------------------------------------
--- Field
-
-describeField :: [Flag] -> PackageIdentifier -> String -> IO ()
-describeField flags pkgid field = do
- db_stack <- getPkgDatabases False flags
- case toField field of
- Nothing -> die ("unknown field: " ++ field)
- Just fn -> do
- ps <- findPackages db_stack pkgid
- mapM_ (putStrLn.fn) ps
-
-toField :: String -> Maybe (InstalledPackageInfo -> String)
--- backwards compatibility:
-toField "import_dirs" = Just $ strList . importDirs
-toField "source_dirs" = Just $ strList . importDirs
-toField "library_dirs" = Just $ strList . libraryDirs
-toField "hs_libraries" = Just $ strList . hsLibraries
-toField "extra_libraries" = Just $ strList . extraLibraries
-toField "include_dirs" = Just $ strList . includeDirs
-toField "c_includes" = Just $ strList . includes
-toField "package_deps" = Just $ strList . map showPackageId. depends
-toField "extra_cc_opts" = Just $ strList . ccOptions
-toField "extra_ld_opts" = Just $ strList . ldOptions
-toField "framework_dirs" = Just $ strList . frameworkDirs
-toField "extra_frameworks"= Just $ strList . frameworks
-toField s = showInstalledPackageInfoField s
-
-strList :: [String] -> String
-strList = show
-
--- -----------------------------------------------------------------------------
--- Manipulating package.conf files
-
-checkConfigAccess :: FilePath -> IO ()
-checkConfigAccess filename = do
- access <- getPermissions filename
- when (not (writable access))
- (die (filename ++ ": you don't have permission to modify this file"))
-
-maybeRestoreOldConfig :: FilePath -> IO () -> IO ()
-maybeRestoreOldConfig filename io
- = io `catch` \e -> do
- hPutStrLn stderr (show e)
- hPutStr stdout ("\nWARNING: an error was encountered while the new \n"++
- "configuration was being written. Attempting to \n"++
- "restore the old configuration... ")
- renameFile (filename ++ ".old") filename
- hPutStrLn stdout "done."
- ioError e
-
-writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
-writeNewConfig filename packages = do
- hPutStr stdout "Writing new package config file... "
- h <- openFile filename WriteMode
- hPutStrLn h (show packages)
- hClose h
- hPutStrLn stdout "done."
-
-savePackageConfig :: FilePath -> IO ()
-savePackageConfig filename = do
- hPutStr stdout "Saving old package config file... "
- -- mv rather than cp because we've already done an hGetContents
- -- on this file so we won't be able to open it for writing
- -- unless we move the old one out of the way...
- let oldFile = filename ++ ".old"
- doesExist <- doesFileExist oldFile `catch` (\ _ -> return False)
- when doesExist (removeFile oldFile `catch` (const $ return ()))
- catch (renameFile filename oldFile)
- (\ err -> do
- hPutStrLn stderr (unwords [ "Unable to rename "
- , show filename
- , " to "
- , show oldFile
- ])
- ioError err)
- hPutStrLn stdout "done."
-
------------------------------------------------------------------------------
--- Sanity-check a new package config, and automatically build GHCi libs
--- if requested.
-
-validatePackageConfig :: InstalledPackageInfo
- -> PackageDBStack
- -> Bool -- auto-ghc-libs
- -> Bool -- update
- -> Bool -- force
- -> IO [PackageIdentifier]
-validatePackageConfig pkg db_stack auto_ghci_libs update force = do
- checkPackageId pkg
- overlaps <- checkDuplicates db_stack pkg update force
- mapM_ (checkDep db_stack force) (depends pkg)
- mapM_ (checkDir force) (importDirs pkg)
- mapM_ (checkDir force) (libraryDirs pkg)
- mapM_ (checkDir force) (includeDirs pkg)
- mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg)
- return overlaps
- -- ToDo: check these somehow?
- -- extra_libraries :: [String],
- -- c_includes :: [String],
-
--- When the package name and version are put together, sometimes we can
--- end up with a package id that cannot be parsed. This will lead to
--- difficulties when the user wants to refer to the package later, so
--- we check that the package id can be parsed properly here.
-checkPackageId :: InstalledPackageInfo -> IO ()
-checkPackageId ipi =
- let str = showPackageId (package ipi) in
- case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of
- [_] -> return ()
- [] -> die ("invalid package identifier: " ++ str)
- _ -> die ("ambiguous package identifier: " ++ str)
-
-resolveDeps :: PackageDBStack -> InstalledPackageInfo -> InstalledPackageInfo
-resolveDeps db_stack p = updateDeps p
- where
- -- The input package spec is allowed to give a package dependency
- -- without a version number; e.g.
- -- depends: base
- -- Here, we update these dependencies without version numbers to
- -- match the actual versions of the relevant packages installed.
- updateDeps p = p{depends = map resolveDep (depends p)}
-
- resolveDep dep_pkgid
- | realVersion dep_pkgid = dep_pkgid
- | otherwise = lookupDep dep_pkgid
-
- lookupDep dep_pkgid
- = let
- name = pkgName dep_pkgid
- in
- case [ pid | p <- concat (map snd db_stack),
- let pid = package p,
- pkgName pid == name ] of
- (pid:_) -> pid -- Found installed package,
- -- replete with its version
- [] -> dep_pkgid -- No installed package; use
- -- the version-less one
-
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool
- -> IO [PackageIdentifier]
-checkDuplicates db_stack pkg update force = do
- let
- pkgid = package pkg
- (_top_db_name, pkgs) : _ = db_stack
- --
- -- Check whether this package id already exists in this DB
- --
- when (not update && (pkgid `elem` map package pkgs)) $
- die ("package " ++ showPackageId pkgid ++ " is already installed")
-
- --
- -- Check whether any of the dependencies of the current package
- -- conflict with each other.
- --
- let
- all_pkgs = concat (map snd db_stack)
-
- allModules p = exposedModules p ++ hiddenModules p
-
- our_dependencies = closePackageDeps all_pkgs [pkg]
- all_dep_modules = concat (map (\p -> zip (allModules p) (repeat p))
- our_dependencies)
-
- overlaps = [ (m, map snd group)
- | group@((m,_):_) <- groupBy eqfst (sortBy cmpfst all_dep_modules),
- length group > 1 ]
- where eqfst (a,_) (b,_) = a == b
- cmpfst (a,_) (b,_) = a `compare` b
-
- when (not (null overlaps)) $
- diePrettyOrForce force $ vcat [
- text "package" <+> text (showPackageId (package pkg)) <+>
- text "has conflicting dependencies:",
- let complain_about (mod,ps) =
- text mod <+> text "is in the following packages:" <+>
- sep (map (text.showPackageId.package) ps)
- in
- nest 3 (vcat (map complain_about overlaps))
- ]
-
- --
- -- Now check whether exposing this package will result in conflicts, and
- -- Figure out which packages we need to hide to resolve the conflicts.
- --
- let
- closure_exposed_pkgs = closePackageDeps pkgs (filter exposed pkgs)
-
- new_dep_modules = concat $ map allModules $
- filter (\p -> package p `notElem`
- map package closure_exposed_pkgs) $
- our_dependencies
-
- pkgs_with_overlapping_modules =
- [ (p, overlapping_mods)
- | p <- closure_exposed_pkgs,
- let overlapping_mods =
- filter (`elem` new_dep_modules) (allModules p),
- (_:_) <- [overlapping_mods] --trick to get the non-empty ones
- ]
-
- to_hide = map package
- $ filter exposed
- $ closePackageDepsUpward pkgs
- $ map fst pkgs_with_overlapping_modules
-
- when (not update && exposed pkg && not (null pkgs_with_overlapping_modules)) $ do
- diePretty $ vcat [
- text "package" <+> text (showPackageId (package pkg)) <+>
- text "conflicts with the following packages, which are",
- text "either exposed or a dependency (direct or indirect) of an exposed package:",
- let complain_about (p, mods)
- = text (showPackageId (package p)) <+> text "contains modules" <+>
- sep (punctuate comma (map text mods)) in
- nest 3 (vcat (map complain_about pkgs_with_overlapping_modules)),
- text "Using 'update' instead of 'register' will cause the following packages",
- text "to be hidden, which will eliminate the conflict:",
- nest 3 (sep (map (text.showPackageId) to_hide))
- ]
-
- when (not (null to_hide)) $ do
- hPutStrLn stderr $ render $
- sep [text "Warning: hiding the following packages to avoid conflict: ",
- nest 2 (sep (map (text.showPackageId) to_hide))]
-
- return to_hide
-
-
-closure :: (a->[a]->Bool) -> (a -> [a]) -> [a] -> [a] -> [a]
-closure pred more [] res = res
-closure pred more (p:ps) res
- | p `pred` res = closure pred more ps res
- | otherwise = closure pred more (more p ++ ps) (p:res)
-
-closePackageDeps :: [InstalledPackageInfo] -> [InstalledPackageInfo]
- -> [InstalledPackageInfo]
-closePackageDeps db start
- = closure (\p ps -> package p `elem` map package ps) getDepends start []
- where
- getDepends p = [ pkg | dep <- depends p, pkg <- lookupPkg dep ]
- lookupPkg p = [ q | q <- db, p == package q ]
-
-closePackageDepsUpward :: [InstalledPackageInfo] -> [InstalledPackageInfo]
- -> [InstalledPackageInfo]
-closePackageDepsUpward db start
- = closure (\p ps -> package p `elem` map package ps) getUpwardDepends start []
- where
- getUpwardDepends p = [ pkg | pkg <- db, package p `elem` depends pkg ]
-
-
-checkDir :: Bool -> String -> IO ()
-checkDir force d
- | "$topdir" `isPrefixOf` d = return ()
- -- can't check this, because we don't know what $topdir is
- | otherwise = do
- there <- doesDirectoryExist d
- when (not there)
- (dieOrForce force (d ++ " doesn't exist or isn't a directory"))
-
-checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
-checkDep db_stack force pkgid
- | not real_version || pkgid `elem` pkgids = return ()
- | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
- ++ " doesn't exist")
- where
- -- for backwards compat, we treat 0.0 as a special version,
- -- and don't check that it actually exists.
- real_version = realVersion pkgid
-
- all_pkgs = concat (map snd db_stack)
- pkgids = map package all_pkgs
-
-realVersion :: PackageIdentifier -> Bool
-realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
-
-checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
-checkHSLib dirs auto_ghci_libs force lib = do
- let batch_lib_file = "lib" ++ lib ++ ".a"
- bs <- mapM (doesLibExistIn batch_lib_file) dirs
- case [ dir | (exists,dir) <- zip bs dirs, exists ] of
- [] -> dieOrForce force ("cannot find " ++ batch_lib_file ++
- " on library path")
- (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
-
-doesLibExistIn :: String -> String -> IO Bool
-doesLibExistIn lib d
- | "$topdir" `isPrefixOf` d = return True
- | otherwise = doesFileExist (d ++ '/':lib)
-
-checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
-checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
- | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
- | otherwise = do
- bs <- mapM (doesLibExistIn ghci_lib_file) dirs
- case [dir | (exists,dir) <- zip bs dirs, exists] of
- [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
- (_:_) -> return ()
- where
- ghci_lib_file = lib ++ ".o"
-
--- automatically build the GHCi version of a batch lib,
--- using ld --whole-archive.
-
-autoBuildGHCiLib :: String -> String -> String -> IO ()
-autoBuildGHCiLib dir batch_file ghci_file = do
- let ghci_lib_file = dir ++ '/':ghci_file
- batch_lib_file = dir ++ '/':batch_file
- hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
-#if defined(darwin_HOST_OS)
- r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
-#elif defined(mingw32_HOST_OS)
- execDir <- getExecDir "/bin/ghc-pkg.exe"
- r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
-#else
- r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
-#endif
- when (r /= ExitSuccess) $ exitWith r
- hPutStrLn stderr (" done.")
-
--- -----------------------------------------------------------------------------
--- Updating the DB with the new package.
-
-updatePackageDB
- :: PackageDBStack -- the full stack
- -> [PackageIdentifier] -- packages to hide
- -> [InstalledPackageInfo] -- packages in *this* DB
- -> InstalledPackageInfo -- the new package
- -> IO [InstalledPackageInfo]
-updatePackageDB db_stack to_hide pkgs new_pkg = do
- let
- pkgid = package new_pkg
-
- pkgs' = [ maybe_hide p | p <- pkgs, package p /= pkgid ]
-
- -- When update is on, and we're exposing the new package,
- -- we hide any packages which conflict (see checkDuplicates)
- -- in the current DB.
- maybe_hide p
- | exposed new_pkg && package p `elem` to_hide = p{ exposed = False }
- | otherwise = p
- --
- return (pkgs'++ [new_pkg])
-
--- -----------------------------------------------------------------------------
--- Searching for modules
-
-#if not_yet
-
-findModules :: [FilePath] -> IO [String]
-findModules paths =
- mms <- mapM searchDir paths
- return (concat mms)
-
-searchDir path prefix = do
- fs <- getDirectoryEntries path `catch` \_ -> return []
- searchEntries path prefix fs
-
-searchEntries path prefix [] = return []
-searchEntries path prefix (f:fs)
- | looks_like_a_module = do
- ms <- searchEntries path prefix fs
- return (prefix `joinModule` f : ms)
- | looks_like_a_component = do
- ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f)
- ms' <- searchEntries path prefix fs
- return (ms ++ ms')
- | otherwise
- searchEntries path prefix fs
-
- where
- (base,suffix) = splitFileExt f
- looks_like_a_module =
- suffix `elem` haskell_suffixes &&
- all okInModuleName base
- looks_like_a_component =
- null suffix && all okInModuleName base
-
-okInModuleName c
-
-#endif
-
--- -----------------------------------------------------------------------------
--- The old command-line syntax, supported for backwards compatibility
-
-data OldFlag
- = OF_Config FilePath
- | OF_Input FilePath
- | OF_List
- | OF_ListLocal
- | OF_Add Bool {- True => replace existing info -}
- | OF_Remove String | OF_Show String
- | OF_Field String | OF_AutoGHCiLibs | OF_Force
- | OF_DefinedName String String
- | OF_GlobalConfig FilePath
- deriving (Eq)
-
-isAction :: OldFlag -> Bool
-isAction OF_Config{} = False
-isAction OF_Field{} = False
-isAction OF_Input{} = False
-isAction OF_AutoGHCiLibs{} = False
-isAction OF_Force{} = False
-isAction OF_DefinedName{} = False
-isAction OF_GlobalConfig{} = False
-isAction _ = True
-
-oldFlags :: [OptDescr OldFlag]
-oldFlags = [
- Option ['f'] ["config-file"] (ReqArg OF_Config "FILE")
- "use the specified package config file",
- Option ['l'] ["list-packages"] (NoArg OF_List)
- "list packages in all config files",
- Option ['L'] ["list-local-packages"] (NoArg OF_ListLocal)
- "list packages in the specified config file",
- Option ['a'] ["add-package"] (NoArg (OF_Add False))
- "add a new package",
- Option ['u'] ["update-package"] (NoArg (OF_Add True))
- "update package with new configuration",
- Option ['i'] ["input-file"] (ReqArg OF_Input "FILE")
- "read new package info from specified file",
- Option ['s'] ["show-package"] (ReqArg OF_Show "NAME")
- "show the configuration for package NAME",
- Option [] ["field"] (ReqArg OF_Field "FIELD")
- "(with --show-package) Show field FIELD only",
- Option [] ["force"] (NoArg OF_Force)
- "ignore missing directories/libraries",
- Option ['r'] ["remove-package"] (ReqArg OF_Remove "NAME")
- "remove an installed package",
- Option ['g'] ["auto-ghci-libs"] (NoArg OF_AutoGHCiLibs)
- "automatically build libs for GHCi (with -a)",
- Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
- "define NAME as VALUE",
- Option [] ["global-conf"] (ReqArg OF_GlobalConfig "FILE")
- "location of the global package config"
- ]
- where
- toDefined str =
- case break (=='=') str of
- (nm,[]) -> OF_DefinedName nm []
- (nm,_:val) -> OF_DefinedName nm val
-
-oldRunit :: [OldFlag] -> IO ()
-oldRunit clis = do
- let new_flags = [ f | Just f <- map conv clis ]
-
- conv (OF_GlobalConfig f) = Just (FlagGlobalConfig f)
- conv (OF_Config f) = Just (FlagConfig f)
- conv _ = Nothing
-
-
-
- let fields = [ f | OF_Field f <- clis ]
-
- let auto_ghci_libs = any isAuto clis
- where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
- input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
-
- force = OF_Force `elem` clis
-
- defines = [ (nm,val) | OF_DefinedName nm val <- clis ]
-
- case [ c | c <- clis, isAction c ] of
- [ OF_List ] -> listPackages new_flags Nothing
- [ OF_ListLocal ] -> listPackages new_flags Nothing
- [ OF_Add upd ] ->
- registerPackage input_file defines new_flags auto_ghci_libs upd force
- [ OF_Remove pkgid_str ] -> do
- pkgid <- readPkgId pkgid_str
- unregisterPackage pkgid new_flags
- [ OF_Show pkgid_str ]
- | null fields -> do
- pkgid <- readPkgId pkgid_str
- describePackage new_flags pkgid
- | otherwise -> do
- pkgid <- readPkgId pkgid_str
- mapM_ (describeField new_flags pkgid) fields
- _ -> do
- prog <- getProgramName
- die (usageInfo (usageHeader prog) flags)
-
-my_head :: String -> [a] -> a
-my_head s [] = error s
-my_head s (x:xs) = x
-
--- ---------------------------------------------------------------------------
--- expanding environment variables in the package configuration
-
-expandEnvVars :: String -> [(String, String)] -> Bool -> IO String
-expandEnvVars str defines force = go str ""
- where
- go "" acc = return $! reverse acc
- go ('$':'{':str) acc | (var, '}':rest) <- break close str
- = do value <- lookupEnvVar var
- go rest (reverse value ++ acc)
- where close c = c == '}' || c == '\n' -- don't span newlines
- go (c:str) acc
- = go str (c:acc)
-
- lookupEnvVar :: String -> IO String
- lookupEnvVar nm =
- case lookup nm defines of
- Just x | not (null x) -> return x
- _ ->
- catch (System.getEnv nm)
- (\ _ -> do dieOrForce force ("Unable to expand variable " ++
- show nm)
- return "")
-
------------------------------------------------------------------------------
-
-getProgramName :: IO String
-getProgramName = liftM (`withoutSuffix` ".bin") getProgName
- where str `withoutSuffix` suff
- | suff `isSuffixOf` str = take (length str - length suff) str
- | otherwise = str
-
-bye :: String -> IO a
-bye s = putStr s >> exitWith ExitSuccess
-
-die :: String -> IO a
-die s = do
- hFlush stdout
- prog <- getProgramName
- hPutStrLn stderr (prog ++ ": " ++ s)
- exitWith (ExitFailure 1)
-
-dieOrForce :: Bool -> String -> IO ()
-dieOrForce force s
- | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
- | otherwise = die (s ++ " (use --force to override)")
-
-diePretty :: Doc -> IO ()
-diePretty doc = do
- hFlush stdout
- prog <- getProgramName
- hPutStrLn stderr $ render $ (text prog <> colon $$ nest 2 doc)
- exitWith (ExitFailure 1)
-
-diePrettyOrForce :: Bool -> Doc -> IO ()
-diePrettyOrForce force doc
- | force = do hFlush stdout; hPutStrLn stderr (render (doc $$ text "(ignoring)"))
- | otherwise = diePretty (doc $$ text "(use --force to override)")
-
------------------------------------------
--- Cut and pasted from ghc/compiler/SysTools
-
-#if defined(mingw32_HOST_OS)
-subst a b ls = map (\ x -> if x == a then b else x) ls
-unDosifyPath xs = subst '\\' '/' xs
-
-getExecDir :: String -> IO (Maybe String)
--- (getExecDir cmd) returns the directory in which the current
--- executable, which should be called 'cmd', is running
--- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
--- you'll get "/a/b/c" back as the result
-getExecDir cmd
- = allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then return Nothing
- else do s <- peekCString buf
- return (Just (reverse (drop (length cmd)
- (reverse (unDosifyPath s)))))
- where
- len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-#else
-getExecDir :: String -> IO (Maybe String)
-getExecDir _ = return Nothing
-#endif
-
--- -----------------------------------------------------------------------------
--- FilePath utils
-
--- | The 'joinFileName' function is the opposite of 'splitFileName'.
--- It joins directory and file names to form a complete file path.
---
--- The general rule is:
---
--- > dir `joinFileName` basename == path
--- > where
--- > (dir,basename) = splitFileName path
---
--- There might be an exceptions to the rule but in any case the
--- reconstructed path will refer to the same object (file or directory).
--- An example exception is that on Windows some slashes might be converted
--- to backslashes.
-joinFileName :: String -> String -> FilePath
-joinFileName "" fname = fname
-joinFileName "." fname = fname
-joinFileName dir "" = dir
-joinFileName dir fname
- | isPathSeparator (last dir) = dir++fname
- | otherwise = dir++pathSeparator:fname
-
--- | Checks whether the character is a valid path separator for the host
--- platform. The valid character is a 'pathSeparator' but since the Windows
--- operating system also accepts a slash (\"\/\") since DOS 2, the function
--- checks for it on this platform, too.
-isPathSeparator :: Char -> Bool
-isPathSeparator ch = ch == pathSeparator || ch == '/'
-
--- | Provides a platform-specific character used to separate directory levels in
--- a path string that reflects a hierarchical file system organization. The
--- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash
--- (@\"\\\"@) on the Windows operating system.
-pathSeparator :: Char
-#ifdef mingw32_HOST_OS
-pathSeparator = '\\'
-#else
-pathSeparator = '/'
-#endif
-
--- | The function splits the given string to substrings
--- using the 'searchPathSeparator'.
-parseSearchPath :: String -> [FilePath]
-parseSearchPath path = split path
- where
- split :: String -> [String]
- split s =
- case rest' of
- [] -> [chunk]
- _:rest -> chunk : split rest
- where
- chunk =
- case chunk' of
-#ifdef mingw32_HOST_OS
- ('\"':xs@(_:_)) | last xs == '\"' -> init xs
-#endif
- _ -> chunk'
-
- (chunk', rest') = break (==searchPathSeparator) s
-
--- | A platform-specific character used to separate search path strings in
--- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
--- and a semicolon (\";\") on the Windows operating system.
-searchPathSeparator :: Char
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-searchPathSeparator = ';'
-#else
-searchPathSeparator = ':'
-#endif
-
projects / ghc-hetmet.git / blobdiff