ghc/compiler/main/PackageMaintenance.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: PackageMaintenance.hs,v 1.10 2001/03/12 14:06:47 simonpj Exp $
   3 --
   4 -- GHC Driver program
   5 --
   6 -- (c) Simon Marlow 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module PackageMaintenance
  11      ( listPackages, newPackage, deletePackage
  12      ) where
  13
  14 import CmStaticInfo
  15 import DriverState
  16 import TmpFiles
  17 import Panic
  18
  19 import Exception
  20 import IOExts
  21 import Pretty
  22
  23 import IO
  24 import Directory
  25 import System
  26 import Monad
  27
  28 -----------------------------------------------------------------------------
  29 -- Package maintenance
  30
  31 listPackages :: IO ()
  32 listPackages = do
  33   details <- readIORef v_Package_details
  34   hPutStr stdout (listPkgs details)
  35   hPutChar stdout '\n'
  36   exitWith ExitSuccess
  37
  38 newPackage :: IO ()
  39 newPackage = do
  40   error "wibble" {-
  41   checkConfigAccess
  42   details <- readIORef v_Package_details
  43   hPutStr stdout "Reading package info from stdin... "
  44   stuff <- getContents
  45   let new_pkg = read stuff :: PackageConfig
  46   catchAll new_pkg
  47         (\_ -> throwDyn (OtherError "parse error in package info"))
  48   hPutStrLn stdout "done."
  49   if (name new_pkg `elem` map name details)
  50         then throwDyn (OtherError ("package `" ++ name new_pkg ++
  51                                         "' already installed"))
  52         else do
  53   conf_file <- readIORef v_Path_package_config
  54   savePackageConfig conf_file
  55   maybeRestoreOldConfig conf_file $ do
  56   writeNewConfig conf_file ( ++ [new_pkg])
  57   exitWith ExitSuccess
  58 -}
  59
  60 deletePackage :: String -> IO ()
  61 deletePackage pkg = do
  62   checkConfigAccess
  63   details <- readIORef v_Package_details
  64   if (pkg `notElem` map name details)
  65         then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
  66         else do
  67   conf_file <- readIORef v_Path_package_config
  68   savePackageConfig conf_file
  69   maybeRestoreOldConfig conf_file $ do
  70   writeNewConfig conf_file (filter ((/= pkg) . name))
  71   exitWith ExitSuccess
  72
  73 checkConfigAccess :: IO ()
  74 checkConfigAccess = do
  75   conf_file <- readIORef v_Path_package_config
  76   access <- getPermissions conf_file
  77   unless (writable access)
  78         (throwDyn (OtherError "you don't have permission to modify the package configuration file"))
  79
  80 maybeRestoreOldConfig :: String -> IO () -> IO ()
  81 maybeRestoreOldConfig conf_file io
  82   = catchAllIO io (\e -> do
  83         hPutStr stdout "\nWARNING: an error was encountered while the new \n\
  84                        \configuration was being written.  Attempting to \n\
  85                        \restore the old configuration... "
  86         kludgedSystem ("cp " ++ conf_file ++ ".old " ++ conf_file) "Restoring old configuration"
  87         hPutStrLn stdout "done."
  88         throw e
  89     )
  90
  91 writeNewConfig :: String -> ([PackageConfig] -> [PackageConfig]) -> IO ()
  92 writeNewConfig conf_file fn = do
  93   hPutStr stdout "Writing new package config file... "
  94   old_details <- readIORef v_Package_details
  95   h <- openFile conf_file WriteMode
  96   hPutStr h (dumpPackages (fn old_details))
  97   hClose h
  98   hPutStrLn stdout "done."
  99
 100 savePackageConfig :: String -> IO ()
 101 savePackageConfig conf_file = do
 102   hPutStr stdout "Saving old package config file... "
 103     -- mv rather than cp because we've already done an hGetContents
 104     -- on this file so we won't be able to open it for writing
 105     -- unless we move the old one out of the way...
 106   kludgedSystem ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old") "Saving package configuration"
 107   hPutStrLn stdout "done."
 108
 109 -----------------------------------------------------------------------------
 110 -- Pretty printing package info
 111
 112 listPkgs :: [PackageConfig] -> String
 113 listPkgs pkgs = render (fsep (punctuate comma (map (text . name) pkgs)))
 114
 115 dumpPackages :: [PackageConfig] -> String
 116 dumpPackages pkgs =
 117    render (brackets (vcat (punctuate comma (map dumpPkgGuts pkgs))))
 118
 119 dumpPkgGuts :: PackageConfig -> Doc
 120 dumpPkgGuts pkg =
 121    text "Package" $$ nest 3 (braces (
 122       sep (punctuate comma [
 123          text "name = " <> text (show (name pkg)),
 124          dumpField "import_dirs"     (import_dirs     pkg),
 125          dumpField "library_dirs"    (library_dirs    pkg),
 126          dumpField "hs_libraries"    (hs_libraries    pkg),
 127          dumpField "extra_libraries" (extra_libraries pkg),
 128          dumpField "include_dirs"    (include_dirs    pkg),
 129          dumpField "c_includes"      (c_includes      pkg),
 130          dumpField "package_deps"    (package_deps    pkg),
 131          dumpField "extra_ghc_opts"  (extra_ghc_opts  pkg),
 132          dumpField "extra_cc_opts"   (extra_cc_opts   pkg),
 133          dumpField "extra_ld_opts"   (extra_ld_opts   pkg)
 134       ])))
 135
 136 dumpField :: String -> [String] -> Doc
 137 dumpField name val =
 138    hang (text name <+> equals) 2
 139         (brackets (sep (punctuate comma (map (text . show) val))))