ghc/utils/ghc-pkg/Main.hs

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