ghc/compiler/main/PackageMaintenance.hs

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