1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.18 2001/12/13 00:59:57 sof Exp $
4 -- Package management tool
5 -----------------------------------------------------------------------------
11 #ifdef __GLASGOW_HASKELL__
12 import qualified Exception
21 #include "../../includes/config.h"
23 #ifdef mingw32_TARGET_OS
30 case getOpt Permute flags args of
31 (clis@(_:_),[],[]) -> runit clis
32 (_,_,errors) -> die (concat errors ++
33 usageInfo usageHeader flags)
38 | List | Add | Remove String | Show String
39 | Field String | AutoGHCiLibs
41 isAction (Config _) = False
42 isAction (Field _) = False
43 isAction (Input _) = False
44 isAction (AutoGHCiLibs) = False
47 usageHeader = "ghc-pkg [OPTION...]"
50 Option ['f'] ["config-file"] (ReqArg Config "FILE")
51 "Use the specified package config file",
52 Option ['l'] ["list-packages"] (NoArg List)
53 "List the currently installed packages",
54 Option ['a'] ["add-package"] (NoArg Add)
56 Option ['i'] ["input-file"] (ReqArg Input "FILE")
57 "Read new package info from specified file",
58 Option ['s'] ["show-package"] (ReqArg Show "NAME")
59 "Show the configuration for package NAME",
60 Option [] ["field"] (ReqArg Field "FIELD")
61 "(with --show-package) Show field FIELD only",
62 Option ['r'] ["remove-package"] (ReqArg Remove "NAME")
63 "Remove an installed package",
64 Option ['g'] ["auto-ghci-libs"] (NoArg AutoGHCiLibs)
65 "Automatically build libs for GHCi (with -a)"
68 #ifdef mingw32_TARGET_OS
69 subst a b ls = map (\ x -> if x == a then b else x) ls
71 unDosifyPath xs = subst '\\' '/' xs
76 case [ f | Config f <- clis ] of
77 fs@(_:_) -> return (last fs)
78 #ifndef mingw32_TARGET_OS
79 [] -> die "missing -f option, location of package.conf unknown"
81 [] -> do h <- getModuleHandle Nothing
82 n <- getModuleFileName h
83 return (reverse (drop (length "/bin/ghc-pkg.exe") (reverse (unDosifyPath n))) ++ "/package.conf")
86 let toField "import_dirs" = return import_dirs
87 toField "source_dirs" = return source_dirs
88 toField "library_dirs" = return library_dirs
89 toField "hs_libraries" = return hs_libraries
90 toField "extra_libraries" = return extra_libraries
91 toField "include_dirs" = return include_dirs
92 toField "c_includes" = return c_includes
93 toField "package_deps" = return package_deps
94 toField "extra_ghc_opts" = return extra_ghc_opts
95 toField "extra_cc_opts" = return extra_cc_opts
96 toField "extra_ld_opts" = return extra_ld_opts
97 toField s = die ("unknown field: `" ++ s ++ "'")
99 fields <- mapM toField [ f | Field f <- clis ]
101 s <- readFile conf_file
102 let details = read s :: [PackageConfig]
103 eval_catch details (\_ -> die "parse error in package config file")
105 let auto_ghci_libs = any isAuto clis
106 where isAuto AutoGHCiLibs = True; isAuto _ = False
107 input_file = head ([ f | (Input f) <- clis] ++ ["-"])
109 case [ c | c <- clis, isAction c ] of
110 [ List ] -> listPackages details
111 [ Add ] -> addPackage details conf_file input_file auto_ghci_libs
112 [ Remove p ] -> removePackage details conf_file p
113 [ Show p ] -> showPackage details conf_file p fields
114 _ -> die (usageInfo usageHeader flags)
117 listPackages :: [PackageConfig] -> IO ()
118 listPackages details = do
119 hPutStr stdout (listPkgs details)
122 showPackage :: [PackageConfig] -> FilePath -> String
123 -> [PackageConfig->[String]] -> IO ()
124 showPackage details pkgconf pkg_name fields =
125 case [ p | p <- details, name p == pkg_name ] of
126 [] -> die ("can't find package `" ++ pkg_name ++ "'")
127 [pkg] | null fields -> hPutStrLn stdout (render (dumpPkgGuts pkg))
128 | otherwise -> hPutStrLn stdout (render (vcat
129 (map (vcat . map text) (map ($pkg) fields))))
130 _ -> die "showPackage: internal error"
132 addPackage :: [PackageConfig] -> FilePath -> FilePath -> Bool -> IO ()
133 addPackage details pkgconf inputFile auto_ghci_libs = do
134 checkConfigAccess pkgconf
138 hPutStr stdout "Reading package info from stdin... "
141 hPutStr stdout ("Reading package info from " ++ show f)
143 let new_pkg = read s :: PackageConfig
144 eval_catch new_pkg (\_ -> die "parse error in package info")
145 hPutStrLn stdout "done."
146 checkPackageConfig new_pkg details auto_ghci_libs
147 savePackageConfig pkgconf
148 maybeRestoreOldConfig pkgconf $
149 writeNewConfig pkgconf (details ++ [new_pkg])
151 removePackage :: [PackageConfig] -> FilePath -> String -> IO ()
152 removePackage details pkgconf pkg = do
153 checkConfigAccess pkgconf
154 if (pkg `notElem` map name details)
155 then die ("package `" ++ pkg ++ "' not installed")
157 savePackageConfig pkgconf
158 maybeRestoreOldConfig pkgconf $
159 writeNewConfig pkgconf (filter ((/= pkg) . name) details)
161 checkConfigAccess :: FilePath -> IO ()
162 checkConfigAccess pkgconf = do
163 access <- getPermissions pkgconf
164 when (not (writable access))
165 (die "you don't have permission to modify the package configuration file")
167 maybeRestoreOldConfig :: String -> IO () -> IO ()
168 maybeRestoreOldConfig conf_file io
169 = my_catch io (\e -> do
170 hPutStr stdout "\nWARNING: an error was encountered while the new \n\
171 \configuration was being written. Attempting to \n\
172 \restore the old configuration... "
173 renameFile (conf_file ++ ".old") conf_file
174 hPutStrLn stdout "done."
178 writeNewConfig :: String -> [PackageConfig] -> IO ()
179 writeNewConfig conf_file details = do
180 hPutStr stdout "Writing new package config file... "
181 h <- openFile conf_file WriteMode
182 hPutStrLn h (dumpPackages details)
184 hPutStrLn stdout "done."
186 savePackageConfig :: String -> IO ()
187 savePackageConfig conf_file = do
188 hPutStr stdout "Saving old package config file... "
189 -- mv rather than cp because we've already done an hGetContents
190 -- on this file so we won't be able to open it for writing
191 -- unless we move the old one out of the way...
192 let oldFile = conf_file ++ ".old"
193 doesExist <- doesFileExist oldFile `catch` (\ _ -> return False)
194 when doesExist (removeFile oldFile `catch` (const $ return ()))
195 catch (renameFile conf_file oldFile)
197 hPutStrLn stderr (unwords [ "Unable to rename"
203 hPutStrLn stdout "done."
205 -----------------------------------------------------------------------------
206 -- Sanity-check a new package config, and automatically build GHCi libs
209 checkPackageConfig :: PackageConfig -> [PackageConfig] -> Bool -> IO ()
210 checkPackageConfig pkg pkgs auto_ghci_libs = do
211 if (name pkg `elem` map name pkgs)
212 then die ("package `" ++ name pkg ++ "' is already installed")
214 mapM_ (checkDep pkgs) (package_deps pkg)
215 mapM_ checkDir (import_dirs pkg)
216 mapM_ checkDir (source_dirs pkg)
217 mapM_ checkDir (library_dirs pkg)
218 mapM_ checkDir (include_dirs pkg)
219 mapM_ (checkHSLib (library_dirs pkg) auto_ghci_libs) (hs_libraries pkg)
220 -- ToDo: check these somehow?
221 -- extra_libraries :: [String],
222 -- c_includes :: [String],
225 b <- doesDirectoryExist d
227 else die ("`" ++ d ++ "' doesn't exist or isn't a directory")
229 checkDep :: [PackageConfig] -> String -> IO ()
231 | n `elem` map name pkgs = return ()
232 | otherwise = die ("dependency `" ++ n ++ "' doesn't exist")
234 checkHSLib :: [String] -> Bool -> String -> IO ()
235 checkHSLib dirs auto_ghci_libs lib = do
236 let batch_lib_file = "lib" ++ lib ++ ".a"
237 bs <- mapM (\d -> doesFileExist (d ++ '/':batch_lib_file)) dirs
238 case [ dir | (exists,dir) <- zip bs dirs, exists ] of
239 [] -> die ("cannot find `" ++ batch_lib_file ++ "' on library path")
240 (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
242 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
243 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build = do
244 let ghci_lib_file = lib ++ ".o"
245 ghci_lib_path = batch_lib_dir ++ '/':ghci_lib_file
246 bs <- mapM (\d -> doesFileExist (d ++ '/':ghci_lib_file)) dirs
247 case [ dir | (exists,dir) <- zip bs dirs, exists ] of
249 autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
251 hPutStrLn stderr ("warning: can't find GHCi lib `"
252 ++ ghci_lib_file ++ "'")
255 -- automatically build the GHCi version of a batch lib,
256 -- using ld --whole-archive.
258 autoBuildGHCiLib dir batch_file ghci_file = do
259 let ghci_lib_file = dir ++ '/':ghci_file
260 batch_lib_file = dir ++ '/':batch_file
261 hPutStr stderr ("building GHCi library `" ++ ghci_lib_file ++ "'...")
262 system("ld -r -x -o " ++ ghci_lib_file ++
263 " --whole-archive " ++ batch_lib_file)
264 hPutStrLn stderr (" done.")
266 -----------------------------------------------------------------------------
268 die :: String -> IO a
269 die s = do { hPutStrLn stderr s; exitWith (ExitFailure 1) }
271 -----------------------------------------------------------------------------
274 #ifndef __GLASGOW_HASKELL__
276 eval_catch a h = a `seq` return ()
282 my_throw = Exception.throw
283 #if __GLASGOW_HASKELL__ > 408
284 eval_catch = Exception.catch . Exception.evaluate
285 my_catch = Exception.catch
287 eval_catch = Exception.catchAll
288 my_catch = Exception.catchAllIO