X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=2157d071a118ffae2ecbdde84e526db501cadf2e;hp=8c106b038da838ecb2e0567087db16586c410ec0;hb=37557940c005d34fc755203139cfaa555fdb3cb8;hpb=2c23d7c5f5155b950ffab85ef9ab037932c938a9 diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 8c106b0..2157d07 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -62,7 +62,7 @@ main :: IO () main = do args <- getArgs - case getOpt Permute flags args of + case getOpt Permute (flags ++ deprecFlags) args of (cli,_,[]) | FlagHelp `elem` cli -> do prog <- getProgramName bye (usageInfo (usageHeader prog) flags) @@ -120,8 +120,6 @@ flags = [ "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) @@ -129,7 +127,13 @@ flags = [ Option [] ["names-only"] (NoArg FlagNamesOnly) "only print package names, not versions; can only be used with list --simple-output" ] - where + +deprecFlags :: [OptDescr Flag] +deprecFlags = [ + Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE") + "define NAME as VALUE" + ] + where toDefined str = case break (=='=') str of (nm,[]) -> FlagDefinedName nm [] @@ -220,10 +224,12 @@ runit cli nonopts = do pkgid <- readGlobPkgId pkgid_str hidePackage pkgid cli ["list"] -> do - listPackages cli Nothing + listPackages cli Nothing Nothing ["list", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str - listPackages cli (Just pkgid) + listPackages cli (Just pkgid) Nothing + ["find-module", moduleName] -> do + listPackages cli Nothing (Just moduleName) ["latest", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str latestPackage cli pkgid @@ -404,10 +410,9 @@ registerPackage input defines flags auto_ghci_libs update force = do expanded <- expandEnvVars s defines force - pkg0 <- parsePackageInfo expanded defines + pkg <- parsePackageInfo expanded defines putStrLn "done." - let pkg = resolveDeps db_stack pkg0 validatePackageConfig pkg db_stack auto_ghci_libs update force let new_details = filter not_this (snd db_to_operate_on) ++ [pkg] not_this p = package p /= package pkg @@ -457,14 +462,17 @@ modifyPackage fn pkgid flags = do -- ----------------------------------------------------------------------------- -- Listing packages -listPackages :: [Flag] -> Maybe PackageIdentifier -> IO () -listPackages flags mPackageName = do +listPackages :: [Flag] -> Maybe PackageIdentifier -> Maybe String -> IO () +listPackages flags mPackageName mModuleName = 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 + | Just this <- mModuleName = -- packages which expose mModuleName + map (\(conf,pkgs) -> (conf, filter (this `exposedInPkg`) pkgs)) + db_stack | otherwise = db_stack db_stack_sorted @@ -542,6 +550,9 @@ pid `matchesPkg` pkg = pid `matches` package pkg compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2 +exposedInPkg :: String -> InstalledPackageInfo -> Bool +moduleName `exposedInPkg` pkg = moduleName `elem` exposedModules pkg + -- ----------------------------------------------------------------------------- -- Field @@ -556,7 +567,7 @@ describeField flags pkgid field = do mapM_ (putStrLn . fn) (mungePackagePaths top_dir ps) mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo] --- Replace the string "$topdir" at the beginning of a path +-- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path -- with the current topdir (obtained from the -B option). mungePackagePaths top_dir ps = map munge_pkg ps where @@ -571,8 +582,11 @@ mungePackagePaths top_dir ps = map munge_pkg ps munge_paths = map munge_path munge_path p - | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' - | otherwise = p + | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' + | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p' + | otherwise = p + + toHttpPath p = "file:///" ++ p maybePrefixMatch :: String -> String -> Maybe String maybePrefixMatch [] rest = Just rest @@ -712,32 +726,6 @@ checkPackageId ipi = [] -> 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 -> IO () checkDuplicates db_stack pkg update = do let @@ -753,8 +741,9 @@ checkDuplicates db_stack pkg update = do checkDir :: Force -> String -> IO () checkDir force d - | "$topdir" `isPrefixOf` d = return () - -- can't check this, because we don't know what $topdir is + | "$topdir" `isPrefixOf` d = return () + | "$httptopdir" `isPrefixOf` d = return () + -- can't check these, because we don't know what $(http)topdir is | otherwise = do there <- doesDirectoryExist d when (not there) @@ -790,7 +779,8 @@ checkHSLib dirs auto_ghci_libs force lib = do doesLibExistIn :: String -> String -> IO Bool doesLibExistIn lib d - | "$topdir" `isPrefixOf` d = return True + | "$topdir" `isPrefixOf` d = return True + | "$httptopdir" `isPrefixOf` d = return True | otherwise = doesFileExist (d ++ '/':lib) checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () @@ -942,8 +932,8 @@ oldRunit clis = do 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_List ] -> listPackages new_flags Nothing Nothing + [ OF_ListLocal ] -> listPackages new_flags Nothing Nothing [ OF_Add upd ] -> registerPackage input_file defines new_flags auto_ghci_libs upd force [ OF_Remove pkgid_str ] -> do