module Main (main) where
import Version ( version, targetOS, targetARCH )
-import Distribution.InstalledPackageInfo
+import Distribution.InstalledPackageInfo hiding (depends)
import Distribution.Compat.ReadP
import Distribution.ParseUtils
import Distribution.Package
+import Distribution.Text
import Distribution.Version
import System.FilePath
-
-#ifdef USING_COMPAT
-import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
-import Compat.RawSystem ( rawSystem )
-#else
-import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
import System.Cmd ( rawSystem )
-#endif
+import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
import Prelude
import Data.Char ( isSpace, toLower )
import Control.Monad
-import System.Directory ( doesDirectoryExist, getDirectoryContents,
+import System.Directory ( doesDirectoryExist, getDirectoryContents,
doesFileExist, renameFile, removeFile )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
import System.IO
import System.IO.Error (try)
-import Data.List ( isPrefixOf, isSuffixOf, isInfixOf, intersperse, sortBy, nub,
+import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub,
unfoldr, break )
+#if __GLASGOW_HASKELL__ > 604
+import Data.List ( isInfixOf )
+#else
+import Data.List ( tails )
+#endif
import Control.Concurrent
#ifdef mingw32_HOST_OS
" $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" ++
+ " all the registered versions will be listed in ascending order.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
" $p find-module {module}\n" ++
" List registered packages exposing module {module} in the global\n" ++
- " database, and also the user database if --user is given. \n" ++
+ " database, and also the user database if --user is given.\n" ++
" All the registered versions will be listed in ascending order.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
parseGlobPackageId :: ReadP r PackageIdentifier
parseGlobPackageId =
- parsePackageId
+ parse
+++
(do n <- parsePackageName; string "-*"
return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
| isBrokenPackage p pkg_map = braces doc
| exposed p = doc
| otherwise = parens doc
- where doc = text (showPackageId (package p))
+ where doc = text (display (package p))
show_simple db_stack = do
let showPkg = if FlagNamesOnly `elem` flags then pkgName
- else showPackageId
+ else display
pkgs = map showPkg $ sortBy compPkgIdVer $
map package (concatMap snd db_stack)
when (not (null pkgs)) $
show_pkg (sortBy compPkgIdVer (map package ps))
where
show_pkg [] = die "no matches"
- show_pkg pids = hPutStrLn stdout (showPackageId (last pids))
+ show_pkg pids = hPutStrLn stdout (display (last pids))
-- -----------------------------------------------------------------------------
-- Describe
ps -> return ps
where
all_pkgs = concat (map snd db_stack)
- pkg_msg (Id pkgid) = showPackageId pkgid
+ pkg_msg (Id pkgid) = display pkgid
pkg_msg (Substring pkgpat _) = "matching "++pkgpat
matches :: PackageIdentifier -> PackageIdentifier -> Bool
matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
(Id pid) `matchesPkg` pkg = pid `matches` package pkg
-(Substring _ m) `matchesPkg` pkg = m (pkgName (package pkg))
+(Substring _ m) `matchesPkg` pkg = m (display (package pkg))
compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
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 "package_deps" = Just $ strList . map display. depends
toField "extra_cc_opts" = Just $ strList . ccOptions
toField "extra_ld_opts" = Just $ strList . ldOptions
toField "framework_dirs" = Just $ strList . frameworkDirs
show_func | FlagSimpleOutput `elem` flags = show_simple
| otherwise = show_normal
show_simple (pid,deps) =
- text (showPackageId pid) <> colon
- <+> fsep (punctuate comma (map (text . showPackageId) deps))
+ text (display pid) <> colon
+ <+> fsep (punctuate comma (map (text . display) deps))
show_normal (pid,deps) =
- text "package" <+> text (showPackageId pid) <+> text "has missing dependencies:"
- $$ nest 4 (fsep (punctuate comma (map (text . showPackageId) deps)))
+ text "package" <+> text (display pid) <+> text "has missing dependencies:"
+ $$ nest 4 (fsep (punctuate comma (map (text . display) deps)))
missingPackageDeps :: InstalledPackageInfo
-> [(PackageIdentifier, InstalledPackageInfo)]
-> [PackageIdentifier]
missingPackageDeps pkg pkg_map =
[ d | d <- depends pkg, isNothing (lookup d pkg_map)] ++
- [ d | d <- depends pkg, Just p <- return (lookup d pkg_map), isBrokenPackage p pkg_map]
+ [ d | d <- depends pkg, Just p <- return (lookup d pkg_map),
+ isBrokenPackage p pkg_map]
isBrokenPackage :: InstalledPackageInfo -> [(PackageIdentifier, InstalledPackageInfo)] -> Bool
-isBrokenPackage pkg pkg_map = not . null $ missingPackageDeps pkg pkg_map
-
+isBrokenPackage pkg pkg_map
+ = not . null $ missingPackageDeps pkg (filter notme pkg_map)
+ where notme (p,ipi) = package pkg /= p
+ -- remove p from the database when we invoke missingPackageDeps,
+ -- because we want mutually recursive groups of package to show up
+ -- as broken. (#1750)
-- -----------------------------------------------------------------------------
-- Manipulating package.conf files
-- 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
+ let str = display (package ipi) in
+ case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
[_] -> return ()
[] -> die ("invalid package identifier: " ++ str)
_ -> die ("ambiguous package identifier: " ++ str)
-- 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")
+ die ("package " ++ display pkgid ++ " is already installed")
let
- uncasep = map toLower . showPackageId
+ uncasep = map toLower . display
dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs)
when (not update && not (null dups)) $ dieOrForceAll force $
"Package names may be treated case-insensitively in the future.\n"++
- "Package " ++ showPackageId pkgid ++
- " overlaps with: " ++ unwords (map showPackageId dups)
+ "Package " ++ display pkgid ++
+ " overlaps with: " ++ unwords (map display dups)
checkDir :: Force -> String -> IO ()
checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
checkDep db_stack force pkgid
| pkgid `elem` pkgids || (not real_version && name_exists) = return ()
- | otherwise = dieOrForceAll force ("dependency " ++ showPackageId pkgid
+ | otherwise = dieOrForceAll force ("dependency " ++ display pkgid
++ " doesn't exist")
where
-- for backwards compat, we treat 0.0 as a special version,
#else
return () -- nothing
#endif
+
+#if __GLASGOW_HASKELL__ <= 604
+isInfixOf :: (Eq a) => [a] -> [a] -> Bool
+isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
+#endif