| FlagForceFiles
| FlagAutoGHCiLibs
| FlagExpandEnvVars
+ | FlagExpandPkgroot
+ | FlagNoExpandPkgroot
| FlagSimpleOutput
| FlagNamesOnly
| FlagIgnoreCase
"automatically build libs for GHCi (with register)",
Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
"expand environment variables (${name}-style) in input package descriptions",
+ Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
+ "expand ${pkgroot}-relative paths to absolute in output package descriptions",
+ Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
+ "preserve ${pkgroot}-relative paths in output package descriptions",
Option ['?'] ["help"] (NoArg FlagHelp)
"display this help and exit",
Option ['V'] ["version"] (NoArg FlagVersion)
| otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
expand_env_vars= FlagExpandEnvVars `elem` cli
+ mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
+ where accumExpandPkgroot _ FlagExpandPkgroot = Just True
+ accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
+ accumExpandPkgroot x _ = x
+
splitFields fields = unfoldr splitComma (',':fields)
where splitComma "" = Nothing
splitComma fs = Just $ break (==',') (tail fs)
["latest", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
latestPackage verbosity cli pkgid
- ["describe", pkgid_str] ->
- case substringCheck pkgid_str of
- Nothing -> do pkgid <- readGlobPkgId pkgid_str
- describePackage verbosity cli (Id pkgid)
- Just m -> describePackage verbosity cli (Substring pkgid_str m)
- ["field", pkgid_str, fields] ->
- case substringCheck pkgid_str of
- Nothing -> do pkgid <- readGlobPkgId pkgid_str
- describeField verbosity cli (Id pkgid)
- (splitFields fields)
- Just m -> describeField verbosity cli (Substring pkgid_str m)
- (splitFields fields)
+ ["describe", pkgid_str] -> do
+ pkgarg <- case substringCheck pkgid_str of
+ Nothing -> liftM Id (readGlobPkgId pkgid_str)
+ Just m -> return (Substring pkgid_str m)
+ describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
+
+ ["field", pkgid_str, fields] -> do
+ pkgarg <- case substringCheck pkgid_str of
+ Nothing -> liftM Id (readGlobPkgId pkgid_str)
+ Just m -> return (Substring pkgid_str m)
+ describeField verbosity cli pkgarg
+ (splitFields fields) (fromMaybe True mexpand_pkgroot)
+
["check"] -> do
checkConsistency verbosity cli
["dump"] -> do
- dumpPackages verbosity cli
+ dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
["recache"] -> do
recache verbosity cli
-- list, describe, field
data PackageDB
- = PackageDB { location :: FilePath,
- packages :: [InstalledPackageInfo] }
+ = PackageDB {
+ location, locationAbsolute :: !FilePath,
+ -- We need both possibly-relative and definately-absolute package
+ -- db locations. This is because the relative location is used as
+ -- an identifier for the db, so it is important we do not modify it.
+ -- On the other hand we need the absolute path in a few places
+ -- particularly in relation to the ${pkgroot} stuff.
+
+ packages :: [InstalledPackageInfo]
+ }
type PackageDBStack = [PackageDB]
-- A stack of package databases. Convention: head is the topmost
db_stack <- sequence
[ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
- if expand_vars then mungePackageDBPaths top_dir db else return db
+ if expand_vars then return (mungePackageDBPaths top_dir db)
+ else return db
| db_path <- final_stack ]
let flag_db_stack = [ db | db_name <- flag_db_names,
readParseDatabase verbosity mb_user_conf use_cache path
-- the user database (only) is allowed to be non-existent
| Just (user_conf,False) <- mb_user_conf, path == user_conf
- = return PackageDB { location = path, packages = [] }
+ = mkPackageDB []
| otherwise
= do e <- tryIO $ getDirectoryContents path
case e of
Left _ -> do
pkgs <- parseMultiPackageConf verbosity path
- return PackageDB{ location = path, packages = pkgs }
+ mkPackageDB pkgs
Right fs
| not use_cache -> ignore_cache
| otherwise -> do
putStrLn ("using cache: " ++ cache)
pkgs <- myReadBinPackageDB cache
let pkgs' = map convertPackageInfoIn pkgs
- return PackageDB { location = path, packages = pkgs' }
+ mkPackageDB pkgs'
| otherwise -> do
when (verbosity >= Normal) $ do
warn ("WARNING: cache is out of date: " ++ cache)
let confs = filter (".conf" `isSuffixOf`) fs
pkgs <- mapM (parseSingletonPackageConf verbosity) $
map (path </>) confs
- return PackageDB { location = path, packages = pkgs }
+ mkPackageDB pkgs
+ where
+ mkPackageDB pkgs = do
+ path_abs <- absolutePath path
+ return PackageDB {
+ location = path,
+ locationAbsolute = path_abs,
+ packages = pkgs
+ }
-- read the package.cache file strictly, to work around a problem with
-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
parseSingletonPackageConf verbosity file = do
when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
- readUTF8File file >>= parsePackageInfo
+ readUTF8File file >>= fmap fst . parsePackageInfo
cachefilename :: FilePath
cachefilename = "package.cache"
-mungePackageDBPaths :: FilePath -> PackageDB -> IO PackageDB
-mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = do
+mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
+mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
+ db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
+ where
+ pkgroot = takeDirectory (locationAbsolute db)
-- It so happens that for both styles of package db ("package.conf"
-- files and "package.conf.d" dirs) the pkgroot is the parent directory
-- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
- pkgroot <- absolutePath (takeDirectory (location db))
- return db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
mungePackagePaths :: FilePath -> FilePath
-> InstalledPackageInfo -> InstalledPackageInfo
when b1 eexist
b2 <- doesDirectoryExist filename
when b2 eexist
- changeDB verbosity [] PackageDB{ location = filename, packages = [] }
+ filename_abs <- absolutePath filename
+ changeDB verbosity [] PackageDB {
+ location = filename, locationAbsolute = filename_abs,
+ packages = []
+ }
-- -----------------------------------------------------------------------------
-- Registering
expanded <- if expand_env_vars then expandEnvVars s force
else return s
- pkg <- parsePackageInfo expanded
+ (pkg, ws) <- parsePackageInfo expanded
when (verbosity >= Normal) $
putStrLn "done."
+ -- report any warnings from the parse phase
+ _ <- reportValidateErrors [] ws
+ (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
+
-- validate the expanded pkg, but register the unexpanded
pkgroot <- absolutePath (takeDirectory to_modify)
let top_dir = takeDirectory (location (last db_stack))
parsePackageInfo
:: String
- -> IO InstalledPackageInfo
+ -> IO (InstalledPackageInfo, [ValidateWarning])
parsePackageInfo str =
case parseInstalledPackageInfo str of
- ParseOk _warns ok -> return ok
+ ParseOk warnings ok -> return (ok, ws)
+ where
+ ws = [ msg | PWarning msg <- warnings
+ , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
ParseFailed err -> case locatedErrorMsg err of
(Nothing, s) -> die s
(Just l, s) -> die (show l ++ ": " ++ s)
-- -----------------------------------------------------------------------------
-- Describe
-describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
-describePackage verbosity my_flags pkgarg = do
+describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
+describePackage verbosity my_flags pkgarg expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} True{-expand vars-} my_flags
- ps <- findPackages flag_db_stack pkgarg
- doDump ps
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+ dbs <- findPackagesByDB flag_db_stack pkgarg
+ doDump expand_pkgroot [ (pkg, locationAbsolute db)
+ | (db, pkgs) <- dbs, pkg <- pkgs ]
-dumpPackages :: Verbosity -> [Flag] -> IO ()
-dumpPackages verbosity my_flags = do
+dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
+dumpPackages verbosity my_flags expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
- doDump (allPackagesInStack flag_db_stack)
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+ doDump expand_pkgroot [ (pkg, locationAbsolute db)
+ | db <- flag_db_stack, pkg <- packages db ]
-doDump :: [InstalledPackageInfo] -> IO ()
-doDump pkgs = do
+doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
+doDump expand_pkgroot pkgs = do
-- fix the encoding to UTF-8, since this is an interchange format
hSetEncoding stdout utf8
- mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
+ putStrLn $
+ intercalate "---\n"
+ [ if expand_pkgroot
+ then showInstalledPackageInfo pkg
+ else showInstalledPackageInfo pkg ++ pkgrootField
+ | (pkg, pkgloc) <- pkgs
+ , let pkgroot = takeDirectory pkgloc
+ pkgrootField = "pkgroot: " ++ pkgroot ++ "\n" ]
-- PackageId is can have globVersion for the version
findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
-- -----------------------------------------------------------------------------
-- Field
-describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
-describeField verbosity my_flags pkgarg fields = do
+describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
+describeField verbosity my_flags pkgarg fields expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} True{-expand vars-} my_flags
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
fns <- toFields fields
ps <- findPackages flag_db_stack pkgarg
mapM_ (selectFields fns) ps
mapM_ (checkDir False "import-dirs") (importDirs pkg)
mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
mapM_ (checkDir True "include-dirs") (includeDirs pkg)
+ mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
+ mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
+ mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
checkModules pkg
mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
-- ToDo: check these somehow?
"Package " ++ display pkgid ++
" overlaps with: " ++ unwords (map display dups)
-checkDir :: Bool -> String -> FilePath -> Validate ()
-checkDir warn_only thisfield d
- -- Note: we don't check for $topdir/${pkgroot} here. We relies on these
+checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
+checkDir = checkPath False True
+checkFile = checkPath False False
+checkDirURL = checkPath True True
+
+checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
+checkPath url_ok is_dir warn_only thisfield d
+ | url_ok && ("http://" `isPrefixOf` d
+ || "https://" `isPrefixOf` d) = return ()
+
+ | url_ok
+ , Just d' <- stripPrefix "file://" d
+ = checkPath False is_dir warn_only thisfield d'
+
+ -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
-- variables having been expanded already, see mungePackagePaths.
| isRelative d = verror ForceFiles $
- thisfield ++ ": " ++ d ++ " is a relative path"
+ thisfield ++ ": " ++ d ++ " is a relative path which "
+ ++ "makes no sense (as there is nothing for it to be "
+ ++ "relative to). You can make paths relative to the "
+ ++ "package database itself by using ${pkgroot}."
-- relative paths don't make any sense; #4134
| otherwise = do
- there <- liftIO $ doesDirectoryExist d
+ there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
when (not there) $
- let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
+ let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
+ ++ if is_dir then "directory" else "file"
in
if warn_only
then vwarn msg
if b then return (Just p) else go ps
doesFileExistIn :: String -> String -> IO Bool
-doesFileExistIn lib d
- | "$topdir" `isPrefixOf` d = return True
- | "$httptopdir" `isPrefixOf` d = return True
- | otherwise = doesFileExist (d </> lib)
+doesFileExistIn lib d = doesFileExist (d </> lib)
checkModules :: InstalledPackageInfo -> Validate ()
checkModules pkg = do