1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.9 2001/04/07 22:30:01 qrczak Exp $
4 -- Package management tool
5 -----------------------------------------------------------------------------
11 #ifdef __GLASGOW_HASKELL__
12 import qualified Exception
24 case getOpt Permute flags args of
25 (clis,[],[]) -> runit clis
26 (_,_,errors) -> die (concat errors ++
27 usageInfo usageHeader flags)
29 data Flag = Config String | List | Add | Remove String | Show String | Field String
30 isConfigOrField (Config _) = True
31 isConfigOrField (Field _) = True
32 isConfigOrField _ = False
34 usageHeader = "ghc-pkg [OPTION...]"
37 Option ['f'] ["config-file"] (ReqArg Config "FILE")
38 "Use the specified package config file",
39 Option ['l'] ["list-packages"] (NoArg List)
40 "List the currently installed packages",
41 Option ['a'] ["add-package"] (NoArg Add)
43 Option ['s'] ["show-package"] (ReqArg Show "NAME")
44 "Show the configuration for package NAME",
45 Option [] ["field"] (ReqArg Field "FIELD")
46 "(with --show-package) Show field FIELD only",
47 Option ['r'] ["remove-package"] (ReqArg Remove "NAME")
48 "Remove an installed package"
53 case [ f | Config f <- clis ] of
54 [] -> die "missing -f option, location of package.conf unknown"
56 _ -> die (usageInfo usageHeader flags)
58 let toField "import_dirs" = return import_dirs
59 toField "source_dirs" = return source_dirs
60 toField "library_dirs" = return library_dirs
61 toField "hs_libraries" = return hs_libraries
62 toField "extra_libraries" = return extra_libraries
63 toField "include_dirs" = return include_dirs
64 toField "c_includes" = return c_includes
65 toField "package_deps" = return package_deps
66 toField "extra_ghc_opts" = return extra_ghc_opts
67 toField "extra_cc_opts" = return extra_cc_opts
68 toField "extra_ld_opts" = return extra_ld_opts
69 toField s = die ("unknown field: `" ++ s ++ "'")
71 fields <- mapM toField [ f | Field f <- clis ]
73 s <- readFile conf_file
74 let details = read s :: [PackageConfig]
75 eval_catch details (\_ -> die "parse error in package config file")
77 case [ c | c <- clis, not (isConfigOrField c) ] of
78 [ List ] -> listPackages details
79 [ Add ] -> addPackage details conf_file
80 [ Remove p ] -> removePackage details conf_file p
81 [ Show p ] -> showPackage details conf_file p fields
82 _ -> die (usageInfo usageHeader flags)
85 listPackages :: [PackageConfig] -> IO ()
86 listPackages details = do
87 hPutStr stdout (listPkgs details)
91 showPackage :: [PackageConfig] -> FilePath -> String
92 -> [PackageConfig->[String]] -> IO ()
93 showPackage details pkgconf pkg_name fields =
94 case [ p | p <- details, name p == pkg_name ] of
95 [] -> die ("can't find package `" ++ pkg_name ++ "'")
96 [pkg] | null fields -> hPutStrLn stdout (render (dumpPkgGuts pkg))
97 | otherwise -> hPutStrLn stdout (render (vcat
98 (map (vcat . map text) (map ($pkg) fields))))
99 _ -> die "showPackage: internal error"
101 addPackage :: [PackageConfig] -> FilePath -> IO ()
102 addPackage details pkgconf = do
103 checkConfigAccess pkgconf
104 hPutStr stdout "Reading package info from stdin... "
106 let new_pkg = read s :: PackageConfig
107 eval_catch new_pkg (\_ -> die "parse error in package info")
108 hPutStrLn stdout "done."
109 if (name new_pkg `elem` map name details)
110 then die ("package `" ++ name new_pkg ++ "' already installed")
112 savePackageConfig pkgconf
113 maybeRestoreOldConfig pkgconf $ do
114 writeNewConfig pkgconf (details ++ [new_pkg])
117 removePackage :: [PackageConfig] -> FilePath -> String -> IO ()
118 removePackage details pkgconf pkg = do
119 checkConfigAccess pkgconf
120 if (pkg `notElem` map name details)
121 then die ("package `" ++ pkg ++ "' not installed")
123 savePackageConfig pkgconf
124 maybeRestoreOldConfig pkgconf $ do
125 writeNewConfig pkgconf (filter ((/= pkg) . name) details)
128 checkConfigAccess :: FilePath -> IO ()
129 checkConfigAccess pkgconf = do
130 access <- getPermissions pkgconf
131 when (not (writable access))
132 (die "you don't have permission to modify the package configuration file")
134 maybeRestoreOldConfig :: String -> IO () -> IO ()
135 maybeRestoreOldConfig conf_file io
136 = my_catch io (\e -> do
137 hPutStr stdout "\nWARNING: an error was encountered while the new \n\
138 \configuration was being written. Attempting to \n\
139 \restore the old configuration... "
140 renameFile (conf_file ++ ".old") conf_file
141 hPutStrLn stdout "done."
145 writeNewConfig :: String -> [PackageConfig] -> IO ()
146 writeNewConfig conf_file details = do
147 hPutStr stdout "Writing new package config file... "
148 h <- openFile conf_file WriteMode
149 hPutStrLn h (dumpPackages details)
151 hPutStrLn stdout "done."
153 savePackageConfig :: String -> IO ()
154 savePackageConfig conf_file = do
155 hPutStr stdout "Saving old package config file... "
156 -- mv rather than cp because we've already done an hGetContents
157 -- on this file so we won't be able to open it for writing
158 -- unless we move the old one out of the way...
159 renameFile conf_file (conf_file ++ ".old")
160 hPutStrLn stdout "done."
162 -----------------------------------------------------------------------------
164 die :: String -> IO a
165 die s = do { hPutStrLn stderr s; exitWith (ExitFailure 1) }
167 -----------------------------------------------------------------------------
170 #ifndef __GLASGOW_HASKELL__
172 eval_catch a h = a `seq` return ()
178 my_throw = Exception.throw
179 #if __GLASGOW_HASKELL__ > 408
180 eval_catch = Exception.catch . Exception.evaluate
181 my_catch = Exception.catch
183 eval_catch = Exception.catchAll
184 my_catch = Exception.catchAllIO