ghc/utils/ghc-pkg/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.8 2001/03/27 14:10:34 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
  19 import IO
  20
  21 main = do
  22   args <- getArgs
  23
  24   case getOpt Permute flags args of
  25         (clis,[],[]) -> runit clis
  26         (_,_,errors) -> die (concat errors ++
  27                              usageInfo usageHeader flags)
  28
  29 data Flag = Config String | List | Add | Remove String | Show String | Field String
  30 isConfigOrField (Config _) = True
  31 isConfigOrField (Field _) = True
  32 isConfigOrField _ = False
  33
  34 usageHeader = "ghc-pkg [OPTION...]"
  35
  36 flags = [
  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)
  42         "Add a new package",
  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"
  49   ]
  50
  51 runit clis = do
  52   conf_file <-
  53      case [ f | Config f <- clis ] of
  54         []  -> die "missing -f option, location of package.conf unknown"
  55         [f] -> return f
  56         _   -> die (usageInfo usageHeader flags)
  57
  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 ++ "'")
  70
  71   fields <- mapM toField [ f | Field f <- clis ]
  72
  73   s <- readFile conf_file
  74   let details = read s :: [PackageConfig]
  75   eval_catch details (\_ -> die "parse error in package config file")
  76
  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)
  83
  84
  85 listPackages :: [PackageConfig] -> IO ()
  86 listPackages details = do
  87   hPutStr stdout (listPkgs details)
  88   hPutChar stdout '\n'
  89   exitWith ExitSuccess
  90
  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"
 100
 101 addPackage :: [PackageConfig] -> FilePath -> IO ()
 102 addPackage details pkgconf = do
 103   checkConfigAccess pkgconf
 104   hPutStr stdout "Reading package info from stdin... "
 105   s <- getContents
 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")
 111         else do
 112   savePackageConfig pkgconf
 113   maybeRestoreOldConfig pkgconf $ do
 114   writeNewConfig pkgconf (details ++ [new_pkg])
 115   exitWith ExitSuccess
 116
 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")
 122         else do
 123   savePackageConfig pkgconf
 124   maybeRestoreOldConfig pkgconf $ do
 125   writeNewConfig pkgconf (filter ((/= pkg) . name) details)
 126   exitWith ExitSuccess
 127
 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")
 133
 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."
 142         my_throw e
 143     )
 144
 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   hPutStr h (dumpPackages details )
 150   hClose h
 151   hPutStrLn stdout "done."
 152
 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."
 161
 162 -----------------------------------------------------------------------------
 163
 164 die :: String -> IO a
 165 die s = do { hPutStrLn stderr s; exitWith (ExitFailure 1) }
 166
 167 -----------------------------------------------------------------------------
 168 -- Exceptions
 169
 170 #ifndef __GLASGOW_HASKELL__
 171
 172 eval_catch a h = a `seq` return ()
 173 my_catch = IO.catch
 174 my_throw = IO.fail
 175
 176 #else /* GHC */
 177
 178 my_throw = Exception.throw
 179 #if __GLASGOW_HASKELL__ > 408
 180 eval_catch = Exception.catch . Exception.evaluate
 181 my_catch = Exception.catch
 182 #else
 183 eval_catch = Exception.catchAll
 184 my_catch = Exception.catchAllIO
 185 #endif
 186
 187 #endif