ghc/utils/ghc-pkg/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.15 2001/08/21 14:38:04 sewardj 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 | Field String
  36 isConfigOrField (Config _) = True
  37 isConfigOrField (Field _) = True
  38 isConfigOrField _ = False
  39
  40 usageHeader = "ghc-pkg [OPTION...]"
  41
  42 flags = [
  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)
  48         "Add a new package",
  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"
  55   ]
  56
  57 #ifdef mingw32_TARGET_OS
  58 subst a b ls = map (\ x -> if x == a then b else x) ls
  59
  60 unDosifyPath xs = subst '\\' '/' xs
  61 #endif
  62
  63 runit clis = do
  64   conf_file <-
  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"
  69 #else
  70         [] -> do h <- getModuleHandle Nothing
  71                  n <- getModuleFileName h
  72                  return (reverse (drop (length "/bin/ghc-pkg.exe") (reverse (unDosifyPath n))) ++ "/package.conf")
  73 #endif
  74
  75   let toField "import_dirs"     = return import_dirs
  76       toField "source_dirs"     = return source_dirs
  77       toField "library_dirs"    = return library_dirs
  78       toField "hs_libraries"    = return hs_libraries
  79       toField "extra_libraries" = return extra_libraries
  80       toField "include_dirs"    = return include_dirs
  81       toField "c_includes"      = return c_includes
  82       toField "package_deps"    = return package_deps
  83       toField "extra_ghc_opts"  = return extra_ghc_opts
  84       toField "extra_cc_opts"   = return extra_cc_opts
  85       toField "extra_ld_opts"   = return extra_ld_opts
  86       toField s                 = die ("unknown field: `" ++ s ++ "'")
  87
  88   fields <- mapM toField [ f | Field f <- clis ]
  89
  90   s <- readFile conf_file
  91   let details = read s :: [PackageConfig]
  92   eval_catch details (\_ -> die "parse error in package config file")
  93
  94   case [ c | c <- clis, not (isConfigOrField c) ] of
  95     [ List ]     -> listPackages details
  96     [ Add  ]     -> addPackage details conf_file
  97     [ Remove p ] -> removePackage details conf_file p
  98     [ Show p ]   -> showPackage details conf_file p fields
  99     _            -> die (usageInfo usageHeader flags)
 100
 101
 102 listPackages :: [PackageConfig] -> IO ()
 103 listPackages details = do
 104   hPutStr stdout (listPkgs details)
 105   hPutChar stdout '\n'
 106
 107 showPackage :: [PackageConfig] -> FilePath -> String
 108          -> [PackageConfig->[String]] -> IO ()
 109 showPackage details pkgconf pkg_name fields =
 110   case [ p | p <- details, name p == pkg_name ] of
 111     []    -> die ("can't find package `" ++ pkg_name ++ "'")
 112     [pkg] | null fields -> hPutStrLn stdout (render (dumpPkgGuts pkg))
 113           | otherwise   -> hPutStrLn stdout (render (vcat
 114                                 (map (vcat . map text) (map ($pkg) fields))))
 115     _     -> die "showPackage: internal error"
 116
 117 addPackage :: [PackageConfig] -> FilePath -> IO ()
 118 addPackage details pkgconf = do
 119   checkConfigAccess pkgconf
 120   hPutStr stdout "Reading package info from stdin... "
 121   s <- getContents
 122   let new_pkg = read s :: PackageConfig
 123   eval_catch new_pkg (\_ -> die "parse error in package info")
 124   hPutStrLn stdout "done."
 125   if (name new_pkg `elem` map name details)
 126         then die ("package `" ++ name new_pkg ++ "' already installed")
 127         else do
 128   savePackageConfig pkgconf
 129   maybeRestoreOldConfig pkgconf $
 130     writeNewConfig pkgconf (details ++ [new_pkg])
 131
 132 removePackage :: [PackageConfig] -> FilePath -> String -> IO ()
 133 removePackage details pkgconf pkg = do
 134   checkConfigAccess pkgconf
 135   if (pkg `notElem` map name details)
 136         then die ("package `" ++ pkg ++ "' not installed")
 137         else do
 138   savePackageConfig pkgconf
 139   maybeRestoreOldConfig pkgconf $
 140     writeNewConfig pkgconf (filter ((/= pkg) . name) details)
 141
 142 checkConfigAccess :: FilePath -> IO ()
 143 checkConfigAccess pkgconf = do
 144   access <- getPermissions pkgconf
 145   when (not (writable access))
 146       (die "you don't have permission to modify the package configuration file")
 147
 148 maybeRestoreOldConfig :: String -> IO () -> IO ()
 149 maybeRestoreOldConfig conf_file io
 150   = my_catch io (\e -> do
 151         hPutStr stdout "\nWARNING: an error was encountered while the new \n\
 152                        \configuration was being written.  Attempting to \n\
 153                        \restore the old configuration... "
 154         renameFile (conf_file ++ ".old")  conf_file
 155         hPutStrLn stdout "done."
 156         my_throw e
 157     )
 158
 159 writeNewConfig :: String -> [PackageConfig] -> IO ()
 160 writeNewConfig conf_file details = do
 161   hPutStr stdout "Writing new package config file... "
 162   h <- openFile conf_file WriteMode
 163   hPutStrLn h (dumpPackages details)
 164   hClose h
 165   hPutStrLn stdout "done."
 166
 167 savePackageConfig :: String -> IO ()
 168 savePackageConfig conf_file = do
 169   hPutStr stdout "Saving old package config file... "
 170     -- mv rather than cp because we've already done an hGetContents
 171     -- on this file so we won't be able to open it for writing
 172     -- unless we move the old one out of the way...
 173   renameFile conf_file (conf_file ++ ".old")
 174   hPutStrLn stdout "done."
 175
 176 -----------------------------------------------------------------------------
 177
 178 die :: String -> IO a
 179 die s = do { hPutStrLn stderr s; exitWith (ExitFailure 1) }
 180
 181 -----------------------------------------------------------------------------
 182 -- Exceptions
 183
 184 #ifndef __GLASGOW_HASKELL__
 185
 186 eval_catch a h = a `seq` return ()
 187 my_catch = IO.catch
 188 my_throw = IO.fail
 189
 190 #else /* GHC */
 191
 192 my_throw = Exception.throw
 193 #if __GLASGOW_HASKELL__ > 408
 194 eval_catch = Exception.catch . Exception.evaluate
 195 my_catch = Exception.catch
 196 #else
 197 eval_catch = Exception.catchAll
 198 my_catch = Exception.catchAllIO
 199 #endif
 200
 201 #endif