ghc/utils/ghc-pkg/Main.hs

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