ghc/utils/ghc-pkg/Main.hs

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