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)
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
+ (_,_,errors) -> do
prog <- getProgramName
die (concat errors ++ usageInfo (usageHeader prog) flags)
| FlagForce
| FlagForceFiles
| FlagAutoGHCiLibs
- | FlagDefinedName String String
| FlagSimpleOutput
+ | FlagNamesOnly
deriving Eq
flags :: [OptDescr Flag]
"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 for some commands"
+ "print output in easy-to-parse format for some commands",
+ Option [] ["names-only"] (NoArg FlagNamesOnly)
+ "only print package names, not versions; can only be used with list --simple-output"
+ ]
+
+deprecFlags :: [OptDescr Flag]
+deprecFlags = [
+ -- put deprecated flags here
]
- where
- toDefined str =
- case break (=='=') str of
- (nm,[]) -> FlagDefinedName nm []
- (nm,_:val) -> FlagDefinedName nm val
ourCopyright :: String
ourCopyright = "GHC package manager version " ++ version ++ "\n"
| FlagForceFiles `elem` cli = ForceFiles
| otherwise = NoForce
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
+ registerPackage filename cli auto_ghci_libs False force
["update", filename] ->
- registerPackage filename defines cli auto_ghci_libs True force
+ registerPackage filename cli auto_ghci_libs True force
["unregister", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
unregisterPackage pkgid cli
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
[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"
-- Registering
registerPackage :: FilePath
- -> [(String,String)] -- defines
-> [Flag]
-> Bool -- auto_ghci_libs
-> Bool -- update
-> Force
-> IO ()
-registerPackage input defines flags auto_ghci_libs update force = do
+registerPackage input flags auto_ghci_libs update force = do
db_stack <- getPkgDatabases True flags
let
db_to_operate_on = my_head "db" db_stack
putStr ("Reading package info from " ++ show f ++ " ... ")
readFile f
- expanded <- expandEnvVars s defines force
+ expanded <- expandEnvVars s force
- pkg0 <- parsePackageInfo expanded defines
+ pkg <- parsePackageInfo expanded
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
parsePackageInfo
:: String
- -> [(String,String)]
-> IO InstalledPackageInfo
-parsePackageInfo str defines =
+parsePackageInfo str =
case parseInstalledPackageInfo str of
ParseOk _warns ok -> return ok
ParseFailed err -> case locatedErrorMsg err of
-- -----------------------------------------------------------------------------
-- 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
where doc = text (showPackageId (package p))
show_simple db_stack = do
- let pkgs = map showPackageId $ sortBy compPkgIdVer $
+ let showPkg = if FlagNamesOnly `elem` flags then pkgName
+ else showPackageId
+ pkgs = map showPkg $ sortBy compPkgIdVer $
map package (concatMap snd db_stack)
when (null pkgs) $ die "no matches"
hPutStrLn stdout $ concat $ intersperse " " pkgs
compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
+exposedInPkg :: String -> InstalledPackageInfo -> Bool
+moduleName `exposedInPkg` pkg = moduleName `elem` exposedModules pkg
+
-- -----------------------------------------------------------------------------
-- Field
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
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
[] -> 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
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)
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 ()
#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 = if OF_Force `elem` clis then ForceAll else NoForce
-
- 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)] -> Force -> IO String
-expandEnvVars str defines force = go str ""
+expandEnvVars :: String -> Force -> IO String
+expandEnvVars str force = go str ""
where
go "" acc = return $! reverse acc
go ('$':'{':str) acc | (var, '}':rest) <- break close str
lookupEnvVar :: String -> IO String
lookupEnvVar nm =
- case lookup nm defines of
- Just x | not (null x) -> return x
- _ ->
catch (System.getEnv nm)
(\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
show nm)
dieForcible :: String -> IO ()
dieForcible s = die (s ++ " (use --force to override)")
+my_head :: String -> [a] -> a
+my_head s [] = error s
+my_head s (x:xs) = x
+
-----------------------------------------
-- Cut and pasted from ghc/compiler/SysTools
#if defined(mingw32_HOST_OS)
+subst :: Char -> Char -> String -> String
subst a b ls = map (\ x -> if x == a then b else x) ls
+
+unDosifyPath :: FilePath -> FilePath
unDosifyPath xs = subst '\\' '/' xs
getExecDir :: String -> IO (Maybe String)
projects / ghc-hetmet.git / blobdiff