1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.13 2001/08/21 09:03:32 rrt 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)
35 data Flag = Config String | List | Add | Remove String | Show String | Field String
36 isConfigOrField (Config _) = True
37 isConfigOrField (Field _) = True
38 isConfigOrField _ = False
40 usageHeader = "ghc-pkg [OPTION...]"
43 Option ['f'] ["config-file"] (ReqArg Config "FILE")
44 "Use the specified package config file",
45 Option ['l'] ["list-packages"] (NoArg List)
46 "List the currently installed packages",
47 Option ['a'] ["add-package"] (NoArg Add)
49 Option ['s'] ["show-package"] (ReqArg Show "NAME")
50 "Show the configuration for package NAME",
51 Option [] ["field"] (ReqArg Field "FIELD")
52 "(with --show-package) Show field FIELD only",
53 Option ['r'] ["remove-package"] (ReqArg Remove "NAME")
54 "Remove an installed package"
57 #ifdef mingw32_TARGET_OS
58 subst a b ls = map (\ x -> if x == a then b else x) ls
60 unDosifyPath xs = subst '\\' '/' xs
65 case [ f | Config f <- clis ] of
66 fs@(_:_) -> return (last fs)
67 #ifndef mingw32_TARGET_OS
68 [] -> die "missing -f option, location of package.conf unknown"
70 [] -> do h <- getModuleHandle Nothing
71 n <- getModuleFileName h
72 -- return (reverse (tail (dropWhile (not . isSlash)
73 return (reverse (drop (length "/bin/ghc-pkg.exe") (reverse (unDosifyPath n))) ++ "/package.conf")
74 -- (reverse (unDosifyPath n)))) ++ "/package.conf")
77 let toField "import_dirs" = return import_dirs
78 toField "source_dirs" = return source_dirs
79 toField "library_dirs" = return library_dirs
80 toField "hs_libraries" = return hs_libraries
81 toField "extra_libraries" = return extra_libraries
82 toField "include_dirs" = return include_dirs
83 toField "c_includes" = return c_includes
84 toField "package_deps" = return package_deps
85 toField "extra_ghc_opts" = return extra_ghc_opts
86 toField "extra_cc_opts" = return extra_cc_opts
87 toField "extra_ld_opts" = return extra_ld_opts
88 toField s = die ("unknown field: `" ++ s ++ "'")
90 fields <- mapM toField [ f | Field f <- clis ]
92 s <- readFile conf_file
93 let details = read s :: [PackageConfig]
94 eval_catch details (\_ -> die "parse error in package config file")
96 case [ c | c <- clis, not (isConfigOrField c) ] of
97 [ List ] -> listPackages details
98 [ Add ] -> addPackage details conf_file
99 [ Remove p ] -> removePackage details conf_file p
100 [ Show p ] -> showPackage details conf_file p fields
101 _ -> die (usageInfo usageHeader flags)
104 listPackages :: [PackageConfig] -> IO ()
105 listPackages details = do
106 hPutStr stdout (listPkgs details)
109 showPackage :: [PackageConfig] -> FilePath -> String
110 -> [PackageConfig->[String]] -> IO ()
111 showPackage details pkgconf pkg_name fields =
112 case [ p | p <- details, name p == pkg_name ] of
113 [] -> die ("can't find package `" ++ pkg_name ++ "'")
114 [pkg] | null fields -> hPutStrLn stdout (render (dumpPkgGuts pkg))
115 | otherwise -> hPutStrLn stdout (render (vcat
116 (map (vcat . map text) (map ($pkg) fields))))
117 _ -> die "showPackage: internal error"
119 addPackage :: [PackageConfig] -> FilePath -> IO ()
120 addPackage details pkgconf = do
121 checkConfigAccess pkgconf
122 hPutStr stdout "Reading package info from stdin... "
124 let new_pkg = read s :: PackageConfig
125 eval_catch new_pkg (\_ -> die "parse error in package info")
126 hPutStrLn stdout "done."
127 if (name new_pkg `elem` map name details)
128 then die ("package `" ++ name new_pkg ++ "' already installed")
130 savePackageConfig pkgconf
131 maybeRestoreOldConfig pkgconf $
132 writeNewConfig pkgconf (details ++ [new_pkg])
134 removePackage :: [PackageConfig] -> FilePath -> String -> IO ()
135 removePackage details pkgconf pkg = do
136 checkConfigAccess pkgconf
137 if (pkg `notElem` map name details)
138 then die ("package `" ++ pkg ++ "' not installed")
140 savePackageConfig pkgconf
141 maybeRestoreOldConfig pkgconf $
142 writeNewConfig pkgconf (filter ((/= pkg) . name) details)
144 checkConfigAccess :: FilePath -> IO ()
145 checkConfigAccess pkgconf = do
146 access <- getPermissions pkgconf
147 when (not (writable access))
148 (die "you don't have permission to modify the package configuration file")
150 maybeRestoreOldConfig :: String -> IO () -> IO ()
151 maybeRestoreOldConfig conf_file io
152 = my_catch io (\e -> do
153 hPutStr stdout "\nWARNING: an error was encountered while the new \n\
154 \configuration was being written. Attempting to \n\
155 \restore the old configuration... "
156 renameFile (conf_file ++ ".old") conf_file
157 hPutStrLn stdout "done."
161 writeNewConfig :: String -> [PackageConfig] -> IO ()
162 writeNewConfig conf_file details = do
163 hPutStr stdout "Writing new package config file... "
164 h <- openFile conf_file WriteMode
165 hPutStrLn h (dumpPackages details)
167 hPutStrLn stdout "done."
169 savePackageConfig :: String -> IO ()
170 savePackageConfig conf_file = do
171 hPutStr stdout "Saving old package config file... "
172 -- mv rather than cp because we've already done an hGetContents
173 -- on this file so we won't be able to open it for writing
174 -- unless we move the old one out of the way...
175 renameFile conf_file (conf_file ++ ".old")
176 hPutStrLn stdout "done."
178 -----------------------------------------------------------------------------
180 die :: String -> IO a
181 die s = do { hPutStrLn stderr s; exitWith (ExitFailure 1) }
183 -----------------------------------------------------------------------------
186 #ifndef __GLASGOW_HASKELL__
188 eval_catch a h = a `seq` return ()
194 my_throw = Exception.throw
195 #if __GLASGOW_HASKELL__ > 408
196 eval_catch = Exception.catch . Exception.evaluate
197 my_catch = Exception.catch
199 eval_catch = Exception.catchAll
200 my_catch = Exception.catchAllIO