+-- -----------------------------------------------------------------------------
+-- Updating the DB with the new package.
+
+updatePackageDB
+ :: PackageDBStack
+ -> [InstalledPackageInfo]
+ -> InstalledPackageInfo
+ -> IO [InstalledPackageInfo]
+updatePackageDB db_stack pkgs new_pkg = do
+ let
+ -- 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
+
+ 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 = my_head "inp" ([ 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 (pkgNameToId p) db_stack
+ [ 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)
+
+my_head s [] = error s
+my_head s (x:xs) = x
+
+-- ---------------------------------------------------------------------------
+
+#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
+