ghc/utils/ghc-pkg/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.21 2002/02/12 15:17:24 simonmar 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   ( getEnv, getArgs,
  19                   system, exitWith,
  20                   ExitCode(..)
  21                 )
  22 import IO
  23 import List ( isPrefixOf )
  24
  25 #include "../../includes/config.h"
  26
  27 #ifdef mingw32_TARGET_OS
  28 import Win32DLL
  29 #endif
  30
  31 main = do
  32   args <- getArgs
  33
  34   case getOpt Permute flags args of
  35         (clis@(_:_),[],[]) -> runit clis
  36         (_,_,errors) -> die (concat errors ++
  37                              usageInfo usageHeader flags)
  38
  39 data Flag
  40   = Config FilePath
  41   | Input FilePath
  42   | List | Add Bool {- True => replace existing info -}
  43   | Remove String | Show String
  44   | Field String | AutoGHCiLibs
  45
  46 isAction (Config _)     = False
  47 isAction (Field _)      = False
  48 isAction (Input _)      = False
  49 isAction (AutoGHCiLibs) = False
  50 isAction _              = True
  51
  52 usageHeader = "ghc-pkg [OPTION...]"
  53
  54 flags = [
  55   Option ['f'] ["config-file"] (ReqArg Config "FILE")
  56         "Use the specified package config file",
  57   Option ['l'] ["list-packages"] (NoArg List)
  58         "List the currently installed packages",
  59   Option ['a'] ["add-package"] (NoArg (Add False))
  60         "Add a new package",
  61   Option ['u'] ["update-package"] (NoArg (Add True))
  62         "Update package with new configuration",
  63   Option ['i'] ["input-file"] (ReqArg Input "FILE")
  64         "Read new package info from specified file",
  65   Option ['s'] ["show-package"] (ReqArg Show "NAME")
  66         "Show the configuration for package NAME",
  67   Option [] ["field"] (ReqArg Field "FIELD")
  68         "(with --show-package) Show field FIELD only",
  69   Option ['r'] ["remove-package"] (ReqArg Remove "NAME")
  70         "Remove an installed package",
  71   Option ['g'] ["auto-ghci-libs"] (NoArg AutoGHCiLibs)
  72         "Automatically build libs for GHCi (with -a)"
  73   ]
  74
  75 #ifdef mingw32_TARGET_OS
  76 subst a b ls = map (\ x -> if x == a then b else x) ls
  77
  78 unDosifyPath xs = subst '\\' '/' xs
  79 #endif
  80
  81 runit clis = do
  82   conf_file <-
  83      case [ f | Config f <- clis ] of
  84         fs@(_:_)  -> return (last fs)
  85 #ifndef mingw32_TARGET_OS
  86         [] -> die "missing -f option, location of package.conf unknown"
  87 #else
  88         [] -> do h <- getModuleHandle Nothing
  89                  n <- getModuleFileName h
  90                  return (reverse (drop (length "/bin/ghc-pkg.exe") (reverse (unDosifyPath n))) ++ "/package.conf")
  91 #endif
  92
  93   let toField "import_dirs"     = return import_dirs
  94       toField "source_dirs"     = return source_dirs
  95       toField "library_dirs"    = return library_dirs
  96       toField "hs_libraries"    = return hs_libraries
  97       toField "extra_libraries" = return extra_libraries
  98       toField "include_dirs"    = return include_dirs
  99       toField "c_includes"      = return c_includes
 100       toField "package_deps"    = return package_deps
 101       toField "extra_ghc_opts"  = return extra_ghc_opts
 102       toField "extra_cc_opts"   = return extra_cc_opts
 103       toField "extra_ld_opts"   = return extra_ld_opts
 104       toField s                 = die ("unknown field: `" ++ s ++ "'")
 105
 106   fields <- mapM toField [ f | Field f <- clis ]
 107
 108   s <- readFile conf_file
 109   let packages = read s :: [PackageConfig]
 110   eval_catch packages (\_ -> die "parse error in package config file")
 111
 112   let auto_ghci_libs = any isAuto clis
 113          where isAuto AutoGHCiLibs = True; isAuto _ = False
 114       input_file = head ([ f | (Input f) <- clis] ++ ["-"])
 115
 116   case [ c | c <- clis, isAction c ] of
 117     [ List ]     -> listPackages packages
 118     [ Add upd ]  -> addPackage packages conf_file input_file auto_ghci_libs upd
 119     [ Remove p ] -> removePackage packages conf_file p
 120     [ Show p ]   -> showPackage packages conf_file p fields
 121     _            -> die (usageInfo usageHeader flags)
 122
 123
 124 listPackages :: [PackageConfig] -> IO ()
 125 listPackages packages = hPutStrLn stdout (listPkgs packages)
 126
 127 showPackage :: [PackageConfig]
 128             -> FilePath
 129             -> String
 130             -> [PackageConfig -> [String]]
 131             -> IO ()
 132 showPackage packages pkgconf pkg_name fields =
 133   case [ p | p <- packages, name p == pkg_name ] of
 134     []    -> die ("can't find package `" ++ pkg_name ++ "'")
 135     [pkg] | null fields -> hPutStrLn stdout (render (dumpPkgGuts pkg))
 136           | otherwise   -> hPutStrLn stdout (render (vcat
 137                                 (map (vcat . map text) (map ($pkg) fields))))
 138     _     -> die "showPackage: internal error"
 139
 140 addPackage :: [PackageConfig] -> FilePath -> FilePath -> Bool -> Bool -> IO ()
 141 addPackage packages pkgconf inputFile auto_ghci_libs updatePkg = do
 142   checkConfigAccess pkgconf
 143   s <-
 144     case inputFile of
 145       "-" -> do
 146         hPutStr stdout "Reading package info from stdin... "
 147         getContents
 148       f   -> do
 149         hPutStr stdout ("Reading package info from " ++ show f)
 150         readFile f
 151   let new_pkg = read s :: PackageConfig
 152   eval_catch new_pkg (\_ -> die "parse error in package info")
 153   hPutStrLn stdout "done."
 154   hPutStr stdout "Expanding embedded variables..."
 155   new_exp_pkg <- expandEnvVars new_pkg
 156   hPutStrLn stdout "done."
 157   new_details <- validatePackageConfig new_exp_pkg packages auto_ghci_libs updatePkg
 158   savePackageConfig pkgconf
 159   maybeRestoreOldConfig pkgconf $
 160     writeNewConfig pkgconf new_details
 161
 162 removePackage :: [PackageConfig] -> FilePath -> String -> IO ()
 163 removePackage packages pkgconf pkgName = do
 164   checkConfigAccess pkgconf
 165   when (pkgName `notElem` map name packages)
 166        (die ("package `" ++ pkgName ++ "' not installed"))
 167   savePackageConfig pkgconf
 168   maybeRestoreOldConfig pkgconf $
 169     writeNewConfig pkgconf (filter ((/= pkgName) . name) packages)
 170
 171 checkConfigAccess :: FilePath -> IO ()
 172 checkConfigAccess pkgconf = do
 173   access <- getPermissions pkgconf
 174   when (not (writable access))
 175       (die "you don't have permission to modify the package configuration file")
 176
 177 maybeRestoreOldConfig :: String -> IO () -> IO ()
 178 maybeRestoreOldConfig conf_file io
 179   = my_catch io (\e -> do
 180         hPutStr stdout "\nWARNING: an error was encountered while the new \n\
 181                        \configuration was being written.  Attempting to \n\
 182                        \restore the old configuration... "
 183         renameFile (conf_file ++ ".old")  conf_file
 184         hPutStrLn stdout "done."
 185         my_throw e
 186     )
 187
 188 writeNewConfig :: String -> [PackageConfig] -> IO ()
 189 writeNewConfig conf_file packages = do
 190   hPutStr stdout "Writing new package config file... "
 191   h <- openFile conf_file WriteMode
 192   hPutStrLn h (dumpPackages packages)
 193   hClose h
 194   hPutStrLn stdout "done."
 195
 196 savePackageConfig :: String -> IO ()
 197 savePackageConfig conf_file = do
 198   hPutStr stdout "Saving old package config file... "
 199     -- mv rather than cp because we've already done an hGetContents
 200     -- on this file so we won't be able to open it for writing
 201     -- unless we move the old one out of the way...
 202   let oldFile = conf_file ++ ".old"
 203   doesExist <- doesFileExist oldFile  `catch` (\ _ -> return False)
 204   when doesExist (removeFile oldFile `catch` (const $ return ()))
 205   catch (renameFile conf_file oldFile)
 206         (\ err -> do
 207                 hPutStrLn stderr (unwords [ "Unable to rename "
 208                                           , show conf_file
 209                                           , " to "
 210                                           , show oldFile
 211                                           ])
 212                 ioError err)
 213   hPutStrLn stdout "done."
 214
 215 -----------------------------------------------------------------------------
 216 -- Sanity-check a new package config, and automatically build GHCi libs
 217 -- if requested.
 218
 219 validatePackageConfig :: PackageConfig
 220                       -> [PackageConfig]
 221                       -> Bool
 222                       -> Bool
 223                       -> IO [PackageConfig]
 224 validatePackageConfig pkg pkgs auto_ghci_libs updatePkg = do
 225   when (not updatePkg && (name pkg `elem` map name pkgs))
 226        (die ("package `" ++ name pkg ++ "' is already installed"))
 227   mapM_ (checkDep pkgs) (package_deps pkg)
 228   mapM_ checkDir (import_dirs pkg)
 229   mapM_ checkDir (source_dirs pkg)
 230   mapM_ checkDir (library_dirs pkg)
 231   mapM_ checkDir (include_dirs pkg)
 232   mapM_ (checkHSLib (library_dirs pkg) auto_ghci_libs) (hs_libraries pkg)
 233   -- ToDo: check these somehow?
 234   --    extra_libraries :: [String],
 235   --    c_includes      :: [String],
 236   let existing_pkgs
 237        | updatePkg = filter ((/=(name pkg)).name) pkgs
 238        | otherwise = pkgs
 239   return (existing_pkgs ++ [pkg])
 240
 241 checkDir d
 242  | "$libdir" `isPrefixOf` d = return ()
 243         -- can't check this, because we don't know what $libdir is
 244  | otherwise = do
 245    there <- doesDirectoryExist d
 246    when (not there)
 247        (die ("`" ++ d ++ "' doesn't exist or isn't a directory"))
 248
 249 checkDep :: [PackageConfig] -> String -> IO ()
 250 checkDep pkgs n
 251   | n `elem` map name pkgs = return ()
 252   | otherwise = die ("dependency `" ++ n ++ "' doesn't exist")
 253
 254 checkHSLib :: [String] -> Bool -> String -> IO ()
 255 checkHSLib dirs auto_ghci_libs lib = do
 256   let batch_lib_file = "lib" ++ lib ++ ".a"
 257   bs <- mapM (doesLibExistIn batch_lib_file) dirs
 258   case [ dir | (exists,dir) <- zip bs dirs, exists ] of
 259         [] -> die ("cannot find `" ++ batch_lib_file ++ "' on library path")
 260         (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
 261
 262 doesLibExistIn lib d
 263  | "$libdir" `isPrefixOf` d = return True
 264  | otherwise                = doesFileExist (d ++ '/':lib)
 265
 266 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
 267 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build = do
 268   let ghci_lib_file = lib ++ ".o"
 269       ghci_lib_path = batch_lib_dir ++ '/':ghci_lib_file
 270   bs <- mapM (\d -> doesFileExist (d ++ '/':ghci_lib_file)) dirs
 271   case [ dir | (exists,dir) <- zip bs dirs, exists ] of
 272         [] | auto_build ->
 273                 autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
 274            | otherwise  ->
 275                 hPutStrLn stderr ("warning: can't find GHCi lib `"
 276                                          ++ ghci_lib_file ++ "'")
 277         (dir:_) -> return ()
 278
 279 -- automatically build the GHCi version of a batch lib,
 280 -- using ld --whole-archive.
 281
 282 autoBuildGHCiLib dir batch_file ghci_file = do
 283   let ghci_lib_file  = dir ++ '/':ghci_file
 284       batch_lib_file = dir ++ '/':batch_file
 285   hPutStr stderr ("building GHCi library `" ++ ghci_lib_file ++ "'...")
 286   system("ld -r -x -o " ++ ghci_lib_file ++
 287          " --whole-archive " ++ batch_lib_file)
 288   hPutStrLn stderr (" done.")
 289
 290 -----------------------------------------------------------------------------
 291 expandEnvVars :: PackageConfig -> IO PackageConfig
 292 expandEnvVars pkg = do
 293    -- permit _all_ strings to contain ${..} environment variable references,
 294    -- arguably too flexible.
 295   nm       <- expandString (name pkg)
 296   imp_dirs <- expandStrings (import_dirs pkg)
 297   src_dirs <- expandStrings (source_dirs pkg)
 298   lib_dirs <- expandStrings (library_dirs pkg)
 299   hs_libs  <- expandStrings (hs_libraries pkg)
 300   ex_libs  <- expandStrings (extra_libraries pkg)
 301   inc_dirs <- expandStrings (include_dirs pkg)
 302   c_incs   <- expandStrings (c_includes pkg)
 303   p_deps   <- expandStrings (package_deps pkg)
 304   e_g_opts <- expandStrings (extra_ghc_opts pkg)
 305   e_c_opts <- expandStrings (extra_cc_opts pkg)
 306   e_l_opts <- expandStrings (extra_ld_opts pkg)
 307   return (pkg { name            = nm
 308               , import_dirs     = imp_dirs
 309               , source_dirs     = src_dirs
 310               , library_dirs    = lib_dirs
 311               , hs_libraries    = hs_libs
 312               , extra_libraries = ex_libs
 313               , include_dirs    = inc_dirs
 314               , c_includes      = c_incs
 315               , package_deps    = p_deps
 316               , extra_ghc_opts  = e_g_opts
 317               , extra_cc_opts   = e_c_opts
 318               , extra_ld_opts   = e_l_opts
 319               })
 320   where
 321    expandStrings = mapM expandString
 322
 323     -- Just for fun, keep this in the IO monad.
 324    expandString :: String -> IO String
 325    expandString str =
 326      case break (=='$') str of
 327        (xs, _:'{':rs) ->
 328          case span (/='}') rs of
 329            (nm,_:remainder) -> do
 330               nm'  <- lookupEnvVar nm
 331               str' <- expandString remainder
 332               return (nm' ++ str')
 333            _ -> return str -- no closing '}'
 334        _ -> return str
 335
 336    lookupEnvVar nm =
 337         catch (System.getEnv nm)
 338               (\ _ -> die ("Unable to expand variable " ++ show nm))
 339
 340 -----------------------------------------------------------------------------
 341
 342 die :: String -> IO a
 343 die s = do { hFlush stdout ; hPutStrLn stderr s; exitWith (ExitFailure 1) }
 344
 345 -----------------------------------------------------------------------------
 346 -- Exceptions
 347
 348 #ifndef __GLASGOW_HASKELL__
 349
 350 eval_catch a h = a `seq` return ()
 351 my_catch = IO.catch
 352 my_throw = IO.fail
 353
 354 #else /* GHC */
 355
 356 my_throw = Exception.throw
 357 #if __GLASGOW_HASKELL__ > 408
 358 eval_catch = Exception.catch . Exception.evaluate
 359 my_catch = Exception.catch
 360 #else
 361 eval_catch = Exception.catchAll
 362 my_catch = Exception.catchAllIO
 363 #endif
 364
 365 #endif