+-- 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 ()
+validatePackageConfig pkg db_stack auto_ghci_libs update force = do
+ checkDuplicates db_stack pkg update
+ 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)
+ -- ToDo: check these somehow?
+ -- extra_libraries :: [String],
+ -- c_includes :: [String],
+
+
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
+checkDuplicates db_stack pkg update = do
+ let
+ pkgid = package pkg
+
+ (_top_db_name, pkgs) : _ = db_stack
+
+ pkgs_with_same_name =
+ [ p | p <- pkgs, pkgName (package p) == pkgName pkgid]
+ exposed_pkgs_with_same_name =
+ filter exposed pkgs_with_same_name
+ --
+ -- Check whether this package id already exists in this DB
+ --
+ when (not update && (package pkg `elem` map package pkgs)) $
+ die ("package " ++ showPackageId pkgid ++ " is already installed\n")
+ --
+ -- if we are exposing this new package, then check that
+ -- there are no other exposed packages with the same name.
+ --
+ when (not update && exposed pkg && not (null exposed_pkgs_with_same_name)) $
+ die ("trying to register " ++ showPackageId pkgid
+ ++ " as exposed, but "
+ ++ showPackageId (package (head exposed_pkgs_with_same_name))
+ ++ " is also exposed.")
+
+
+checkDir :: Bool -> String -> IO ()
+checkDir force d
+ | "$libdir" `isPrefixOf` d = return ()
+ -- can't check this, because we don't know what $libdir is
+ | otherwise = do
+ there <- doesDirectoryExist d
+ when (not there)
+ (dieOrForce force (d ++ " doesn't exist or isn't a directory\n"))
+
+checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
+checkDep db_stack force pkgid
+ | real_version && pkgid `elem` pkgids = return ()
+ | not real_version && pkgName pkgid `elem` pkg_names = return ()
+ | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
+ ++ " doesn't exist\n")
+ 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
+ pkg_names = map pkgName pkgids
+
+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
+ | "$libdir" `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_TARGET_OS)
+ r <- system("ld -r -x -o " ++ ghci_lib_file ++
+ " -all_load " ++ batch_lib_file)
+#elif defined(mingw32_HOST_OS)
+ execDir <- getExecDir "/bin/ghc-pkg.exe"
+ r <- system (maybe "" (++"/gcc-lib/") execDir++"ld -r -x -o " ++
+ ghci_lib_file ++ " --whole-archive " ++ batch_lib_file)
+#else
+ r <- system("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
+ -> [InstalledPackageInfo]
+ -> InstalledPackageInfo
+ -> IO [InstalledPackageInfo]
+updatePackageDB db_stack pkgs new_pkg = do
+ let
+ -- we update dependencies without version numbers to
+ -- match the actual versions of the relevant packages instaled.
+ updateDeps p = p{depends = map resolveDep (depends p)}
+
+ resolveDep pkgid
+ | realVersion pkgid = pkgid
+ | otherwise = lookupDep (pkgName pkgid)
+
+ lookupDep name
+ = head [ pid | p <- concat (map snd db_stack),
+ let pid = package p,
+ pkgName pid == name ]
+
+ is_exposed = exposed new_pkg
+ pkgid = package new_pkg
+ name = pkgName pkgid
+
+ pkgs' = [ maybe_hide p | p <- pkgs, package p /= pkgid ]
+
+ -- When update is on, and we're exposing the new package,
+ -- we hide any packages with the same name (different versions)
+ -- in the current DB. Earlier checks will have failed if
+ -- update isn't on.
+ maybe_hide p
+ | is_exposed && pkgName (package p) == name = p{ exposed = False }
+ | otherwise = p
+ --
+ return (pkgs'++[updateDeps 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 config_flags = [ f | Just f <- map conv clis ]
+
+ conv (OF_GlobalConfig f) = Just (FlagGlobalConfig f)
+ conv (OF_Config f) = Just (FlagConfig f)
+ conv _ = Nothing
+
+ db_names <- getPkgDatabases config_flags
+ db_stack <- mapM readParseDatabase db_names
+
+ let fields = [ f | OF_Field f <- clis ]
+
+ let auto_ghci_libs = any isAuto clis
+ where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
+ input_file = head ([ 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 db_stack
+ [ OF_ListLocal ] -> listPackages db_stack
+ [ OF_Add upd ] -> registerPackage input_file defines db_stack
+ auto_ghci_libs upd force
+ [ OF_Remove p ] -> unregisterPackage db_stack (pkgNameToId p)
+ [ OF_Show p ]
+ | null fields -> describePackage db_stack (pkgNameToId p)
+ | otherwise -> mapM_ (describeField db_stack (pkgNameToId p)) fields
+ _ -> do prog <- getProgramName
+ die (usageInfo (usageHeader prog) flags)
+
+-- ---------------------------------------------------------------------------
+
+#ifdef OLD_STUFF
+-- ToDo: reinstate
+expandEnvVars :: PackageConfig -> [(String, String)]
+ -> Bool -> IO PackageConfig
+expandEnvVars pkg defines force = do
+ -- permit _all_ strings to contain ${..} environment variable references,
+ -- arguably too flexible.
+ nm <- expandString (name pkg)
+ imp_dirs <- expandStrings (import_dirs pkg)
+ src_dirs <- expandStrings (source_dirs pkg)
+ lib_dirs <- expandStrings (library_dirs pkg)
+ hs_libs <- expandStrings (hs_libraries pkg)
+ ex_libs <- expandStrings (extra_libraries pkg)
+ inc_dirs <- expandStrings (include_dirs pkg)
+ c_incs <- expandStrings (c_includes pkg)
+ p_deps <- expandStrings (package_deps pkg)
+ e_g_opts <- expandStrings (extra_ghc_opts pkg)
+ e_c_opts <- expandStrings (extra_cc_opts pkg)
+ e_l_opts <- expandStrings (extra_ld_opts pkg)
+ f_dirs <- expandStrings (framework_dirs pkg)
+ e_frames <- expandStrings (extra_frameworks pkg)
+ return (pkg { name = nm
+ , import_dirs = imp_dirs
+ , source_dirs = src_dirs
+ , library_dirs = lib_dirs
+ , hs_libraries = hs_libs
+ , extra_libraries = ex_libs
+ , include_dirs = inc_dirs
+ , c_includes = c_incs
+ , package_deps = p_deps
+ , extra_ghc_opts = e_g_opts
+ , extra_cc_opts = e_c_opts
+ , extra_ld_opts = e_l_opts
+ , framework_dirs = f_dirs
+ , extra_frameworks= e_frames
+ })
+ where
+ expandStrings :: [String] -> IO [String]
+ expandStrings = liftM concat . mapM expandSpecial
+
+ -- Permit substitutions for list-valued variables (but only when
+ -- they occur alone), e.g., package_deps["${deps}"] where env var
+ -- (say) 'deps' is "base,haskell98,network"
+ expandSpecial :: String -> IO [String]
+ expandSpecial str =
+ let expand f = liftM f $ expandString str
+ in case splitString str of
+ [Var _] -> expand (wordsBy (== ','))
+ _ -> expand (\x -> [x])
+
+ expandString :: String -> IO String
+ expandString = liftM concat . mapM expandElem . splitString
+
+ expandElem :: Elem -> IO String
+ expandElem (String s) = return s
+ expandElem (Var v) = lookupEnvVar v
+
+ 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 "")
+
+data Elem = String String | Var String
+
+splitString :: String -> [Elem]
+splitString "" = []
+splitString str =
+ case break (== '$') str of
+ (pre, _:'{':xs) ->
+ case span (/= '}') xs of
+ (var, _:suf) ->
+ (if null pre then id else (String pre :)) (Var var : splitString suf)
+ _ -> [String str] -- no closing brace
+ _ -> [String str] -- no dollar/opening brace combo
+
+-- wordsBy isSpace == words
+wordsBy :: (Char -> Bool) -> String -> [String]
+wordsBy p s = case dropWhile p s of
+ "" -> []
+ s' -> w : wordsBy p s'' where (w,s'') = break p s'
+#endif
+
+-----------------------------------------------------------------------------
+
+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