ghc/utils/ghc-pkg/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.17 2001/10/10 23:17:14 sof Exp $
   3 --
   4 -- Package management tool
   5 -----------------------------------------------------------------------------
   6
   7 module Main where
   8
   9 import Package
  10
  11 #ifdef __GLASGOW_HASKELL__
  12 import qualified Exception
  13 #endif
  14 import GetOpt
  15 import Pretty
  16 import Monad
  17 import Directory
  18 import System
  19 import IO
  20
  21 #include "../../includes/config.h"
  22
  23 #ifdef mingw32_TARGET_OS
  24 import Win32DLL
  25 #endif
  26
  27 main = do
  28   args <- getArgs
  29
  30   case getOpt Permute flags args of
  31         (clis,[],[]) -> runit clis
  32         (_,_,errors) -> die (concat errors ++
  33                              usageInfo usageHeader flags)
  34
  35 data Flag = Config String | List | Add | Remove String | Show String
  36                 | Field String | AutoGHCiLibs
  37
  38 isAction (Config _)     = False
  39 isAction (Field _)      = False
  40 isAction (AutoGHCiLibs) = False
  41 isAction _              = True
  42
  43 usageHeader = "ghc-pkg [OPTION...]"
  44
  45 flags = [
  46   Option ['f'] ["config-file"] (ReqArg Config "FILE")
  47         "Use the specified package config file",
  48   Option ['l'] ["list-packages"] (NoArg List)
  49         "List the currently installed packages",
  50   Option ['a'] ["add-package"] (NoArg Add)
  51         "Add a new package",
  52   Option ['s'] ["show-package"] (ReqArg Show "NAME")
  53         "Show the configuration for package NAME",
  54   Option [] ["field"] (ReqArg Field "FIELD")
  55         "(with --show-package) Show field FIELD only",
  56   Option ['r'] ["remove-package"] (ReqArg Remove "NAME")
  57         "Remove an installed package",
  58   Option ['g'] ["auto-ghci-libs"] (NoArg AutoGHCiLibs)
  59         "Automatically build libs for GHCi (with -a)"
  60   ]
  61
  62 #ifdef mingw32_TARGET_OS
  63 subst a b ls = map (\ x -> if x == a then b else x) ls
  64
  65 unDosifyPath xs = subst '\\' '/' xs
  66 #endif
  67
  68 runit clis = do
  69   conf_file <-
  70      case [ f | Config f <- clis ] of
  71         fs@(_:_)  -> return (last fs)
  72 #ifndef mingw32_TARGET_OS
  73         [] -> die "missing -f option, location of package.conf unknown"
  74 #else
  75         [] -> do h <- getModuleHandle Nothing
  76                  n <- getModuleFileName h
  77                  return (reverse (drop (length "/bin/ghc-pkg.exe") (reverse (unDosifyPath n))) ++ "/package.conf")
  78 #endif
  79
  80   let toField "import_dirs"     = return import_dirs
  81       toField "source_dirs"     = return source_dirs
  82       toField "library_dirs"    = return library_dirs
  83       toField "hs_libraries"    = return hs_libraries
  84       toField "extra_libraries" = return extra_libraries
  85       toField "include_dirs"    = return include_dirs
  86       toField "c_includes"      = return c_includes
  87       toField "package_deps"    = return package_deps
  88       toField "extra_ghc_opts"  = return extra_ghc_opts
  89       toField "extra_cc_opts"   = return extra_cc_opts
  90       toField "extra_ld_opts"   = return extra_ld_opts
  91       toField s                 = die ("unknown field: `" ++ s ++ "'")
  92
  93   fields <- mapM toField [ f | Field f <- clis ]
  94
  95   s <- readFile conf_file
  96   let details = read s :: [PackageConfig]
  97   eval_catch details (\_ -> die "parse error in package config file")
  98
  99   let auto_ghci_libs = any isAuto clis
 100          where isAuto AutoGHCiLibs = True; isAuto _ = False
 101
 102   case [ c | c <- clis, isAction c ] of
 103     [ List ]     -> listPackages details
 104     [ Add  ]     -> addPackage details conf_file auto_ghci_libs
 105     [ Remove p ] -> removePackage details conf_file p
 106     [ Show p ]   -> showPackage details conf_file p fields
 107     _            -> die (usageInfo usageHeader flags)
 108
 109
 110 listPackages :: [PackageConfig] -> IO ()
 111 listPackages details = do
 112   hPutStr stdout (listPkgs details)
 113   hPutChar stdout '\n'
 114
 115 showPackage :: [PackageConfig] -> FilePath -> String
 116          -> [PackageConfig->[String]] -> IO ()
 117 showPackage details pkgconf pkg_name fields =
 118   case [ p | p <- details, name p == pkg_name ] of
 119     []    -> die ("can't find package `" ++ pkg_name ++ "'")
 120     [pkg] | null fields -> hPutStrLn stdout (render (dumpPkgGuts pkg))
 121           | otherwise   -> hPutStrLn stdout (render (vcat
 122                                 (map (vcat . map text) (map ($pkg) fields))))
 123     _     -> die "showPackage: internal error"
 124
 125 addPackage :: [PackageConfig] -> FilePath -> Bool -> IO ()
 126 addPackage details pkgconf auto_ghci_libs = do
 127   checkConfigAccess pkgconf
 128   hPutStr stdout "Reading package info from stdin... "
 129   s <- getContents
 130   let new_pkg = read s :: PackageConfig
 131   eval_catch new_pkg (\_ -> die "parse error in package info")
 132   hPutStrLn stdout "done."
 133   checkPackageConfig new_pkg details auto_ghci_libs
 134   savePackageConfig pkgconf
 135   maybeRestoreOldConfig pkgconf $
 136     writeNewConfig pkgconf (details ++ [new_pkg])
 137
 138 removePackage :: [PackageConfig] -> FilePath -> String -> IO ()
 139 removePackage details pkgconf pkg = do
 140   checkConfigAccess pkgconf
 141   if (pkg `notElem` map name details)
 142         then die ("package `" ++ pkg ++ "' not installed")
 143         else do
 144   savePackageConfig pkgconf
 145   maybeRestoreOldConfig pkgconf $
 146     writeNewConfig pkgconf (filter ((/= pkg) . name) details)
 147
 148 checkConfigAccess :: FilePath -> IO ()
 149 checkConfigAccess pkgconf = do
 150   access <- getPermissions pkgconf
 151   when (not (writable access))
 152       (die "you don't have permission to modify the package configuration file")
 153
 154 maybeRestoreOldConfig :: String -> IO () -> IO ()
 155 maybeRestoreOldConfig conf_file io
 156   = my_catch io (\e -> do
 157         hPutStr stdout "\nWARNING: an error was encountered while the new \n\
 158                        \configuration was being written.  Attempting to \n\
 159                        \restore the old configuration... "
 160         renameFile (conf_file ++ ".old")  conf_file
 161         hPutStrLn stdout "done."
 162         my_throw e
 163     )
 164
 165 writeNewConfig :: String -> [PackageConfig] -> IO ()
 166 writeNewConfig conf_file details = do
 167   hPutStr stdout "Writing new package config file... "
 168   h <- openFile conf_file WriteMode
 169   hPutStrLn h (dumpPackages details)
 170   hClose h
 171   hPutStrLn stdout "done."
 172
 173 savePackageConfig :: String -> IO ()
 174 savePackageConfig conf_file = do
 175   hPutStr stdout "Saving old package config file... "
 176     -- mv rather than cp because we've already done an hGetContents
 177     -- on this file so we won't be able to open it for writing
 178     -- unless we move the old one out of the way...
 179   let oldFile = conf_file ++ ".old"
 180   doesExist <- doesFileExist oldFile  `catch` (\ _ -> return False)
 181   when doesExist (removeFile oldFile `catch` (const $ return ()))
 182   catch (renameFile conf_file oldFile)
 183         (\ err -> do
 184                 hPutStrLn stderr (unwords [ "Unable to rename"
 185                                           , show conf_file
 186                                           , " to "
 187                                           , show oldFile
 188                                           ])
 189                 ioError err)
 190   hPutStrLn stdout "done."
 191
 192 -----------------------------------------------------------------------------
 193 -- Sanity-check a new package config, and automatically build GHCi libs
 194 -- if requested.
 195
 196 checkPackageConfig :: PackageConfig -> [PackageConfig] -> Bool -> IO ()
 197 checkPackageConfig pkg pkgs auto_ghci_libs = do
 198   if (name pkg `elem` map name pkgs)
 199         then die ("package `" ++ name pkg ++ "' is already installed")
 200         else do
 201   mapM_ (checkDep pkgs) (package_deps pkg)
 202   mapM_ checkDir (import_dirs pkg)
 203   mapM_ checkDir (source_dirs pkg)
 204   mapM_ checkDir (library_dirs pkg)
 205   mapM_ checkDir (include_dirs pkg)
 206   mapM_ (checkHSLib (library_dirs pkg) auto_ghci_libs) (hs_libraries pkg)
 207   -- ToDo: check these somehow?
 208   --    extra_libraries :: [String],
 209   --    c_includes      :: [String],
 210
 211 checkDir d = do
 212   b <- doesDirectoryExist d
 213   if b then return ()
 214        else die ("`" ++ d ++ "' doesn't exist or isn't a directory")
 215
 216 checkDep :: [PackageConfig] -> String -> IO ()
 217 checkDep pkgs n
 218   | n `elem` map name pkgs = return ()
 219   | otherwise = die ("dependency `" ++ n ++ "' doesn't exist")
 220
 221 checkHSLib :: [String] -> Bool -> String -> IO ()
 222 checkHSLib dirs auto_ghci_libs lib = do
 223   let batch_lib_file = "lib" ++ lib ++ ".a"
 224   bs <- mapM (\d -> doesFileExist (d ++ '/':batch_lib_file)) dirs
 225   case [ dir | (exists,dir) <- zip bs dirs, exists ] of
 226         [] -> die ("cannot find `" ++ batch_lib_file ++ "' on library path")
 227         (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
 228
 229 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
 230 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build = do
 231   let ghci_lib_file = lib ++ ".o"
 232       ghci_lib_path = batch_lib_dir ++ '/':ghci_lib_file
 233   bs <- mapM (\d -> doesFileExist (d ++ '/':ghci_lib_file)) dirs
 234   case [ dir | (exists,dir) <- zip bs dirs, exists ] of
 235         [] | auto_build ->
 236                 autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
 237            | otherwise  ->
 238                 hPutStrLn stderr ("warning: can't find GHCi lib `"
 239                                          ++ ghci_lib_file ++ "'")
 240         (dir:_) -> return ()
 241
 242 -- automatically build the GHCi version of a batch lib,
 243 -- using ld --whole-archive.
 244
 245 autoBuildGHCiLib dir batch_file ghci_file = do
 246   let ghci_lib_file  = dir ++ '/':ghci_file
 247       batch_lib_file = dir ++ '/':batch_file
 248   hPutStr stderr ("building GHCi library `" ++ ghci_lib_file ++ "'...")
 249   system("ld -r -x -o " ++ ghci_lib_file ++
 250          " --whole-archive " ++ batch_lib_file)
 251   hPutStrLn stderr (" done.")
 252
 253 -----------------------------------------------------------------------------
 254
 255 die :: String -> IO a
 256 die s = do { hPutStrLn stderr s; exitWith (ExitFailure 1) }
 257
 258 -----------------------------------------------------------------------------
 259 -- Exceptions
 260
 261 #ifndef __GLASGOW_HASKELL__
 262
 263 eval_catch a h = a `seq` return ()
 264 my_catch = IO.catch
 265 my_throw = IO.fail
 266
 267 #else /* GHC */
 268
 269 my_throw = Exception.throw
 270 #if __GLASGOW_HASKELL__ > 408
 271 eval_catch = Exception.catch . Exception.evaluate
 272 my_catch = Exception.catch
 273 #else
 274 eval_catch = Exception.catchAll
 275 my_catch = Exception.catchAllIO
 276 #endif
 277
 278 #endif