ghc/compiler/main/PackageMaintenance.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: PackageMaintenance.hs,v 1.5 2000/12/12 14:35:08 simonmar 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 DriverUtil
  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   checkConfigAccess
  41   details <- readIORef v_Package_details
  42   hPutStr stdout "Reading package info from stdin... "
  43   stuff <- getContents
  44   let new_pkg = read stuff :: Package
  45   catchAll new_pkg
  46         (\_ -> throwDyn (OtherError "parse error in package info"))
  47   hPutStrLn stdout "done."
  48   if (name new_pkg `elem` map name details)
  49         then throwDyn (OtherError ("package `" ++ name new_pkg ++
  50                                         "' already installed"))
  51         else do
  52   conf_file <- readIORef v_Path_package_config
  53   savePackageConfig conf_file
  54   maybeRestoreOldConfig conf_file $ do
  55   writeNewConfig conf_file ( ++ [new_pkg])
  56   exitWith ExitSuccess
  57
  58 deletePackage :: String -> IO ()
  59 deletePackage pkg = do
  60   checkConfigAccess
  61   details <- readIORef v_Package_details
  62   if (pkg `notElem` map name details)
  63         then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
  64         else do
  65   conf_file <- readIORef v_Path_package_config
  66   savePackageConfig conf_file
  67   maybeRestoreOldConfig conf_file $ do
  68   writeNewConfig conf_file (filter ((/= pkg) . name))
  69   exitWith ExitSuccess
  70
  71 checkConfigAccess :: IO ()
  72 checkConfigAccess = do
  73   conf_file <- readIORef v_Path_package_config
  74   access <- getPermissions conf_file
  75   unless (writable access)
  76         (throwDyn (OtherError "you don't have permission to modify the package configuration file"))
  77
  78 maybeRestoreOldConfig :: String -> IO () -> IO ()
  79 maybeRestoreOldConfig conf_file io
  80   = catchAllIO io (\e -> do
  81         hPutStr stdout "\nWARNING: an error was encountered while the new \n\
  82                        \configuration was being written.  Attempting to \n\
  83                        \restore the old configuration... "
  84         kludgedSystem "Restoring old configuration" ("cp " ++ conf_file ++ ".old " ++ conf_file)
  85         hPutStrLn stdout "done."
  86         throw e
  87     )
  88
  89 writeNewConfig :: String -> ([Package] -> [Package]) -> IO ()
  90 writeNewConfig conf_file fn = do
  91   hPutStr stdout "Writing new package config file... "
  92   old_details <- readIORef v_Package_details
  93   h <- openFile conf_file WriteMode
  94   hPutStr h (dumpPackages (fn old_details))
  95   hClose h
  96   hPutStrLn stdout "done."
  97
  98 savePackageConfig :: String -> IO ()
  99 savePackageConfig conf_file = do
 100   hPutStr stdout "Saving old package config file... "
 101     -- mv rather than cp because we've already done an hGetContents
 102     -- on this file so we won't be able to open it for writing
 103     -- unless we move the old one out of the way...
 104   kludgedSystem "Saving package configuration" ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
 105   hPutStrLn stdout "done."
 106
 107 -----------------------------------------------------------------------------
 108 -- Pretty printing package info
 109
 110 listPkgs :: [Package] -> String
 111 listPkgs pkgs = render (fsep (punctuate comma (map (text . name) pkgs)))
 112
 113 dumpPackages :: [Package] -> String
 114 dumpPackages pkgs =
 115    render (brackets (vcat (punctuate comma (map dumpPkgGuts pkgs))))
 116
 117 dumpPkgGuts :: Package -> Doc
 118 dumpPkgGuts pkg =
 119    text "Package" $$ nest 3 (braces (
 120       sep (punctuate comma [
 121          text "name = " <> text (show (name pkg)),
 122          dumpField "import_dirs"     (import_dirs     pkg),
 123          dumpField "library_dirs"    (library_dirs    pkg),
 124          dumpField "hs_libraries"    (hs_libraries    pkg),
 125          dumpField "extra_libraries" (extra_libraries pkg),
 126          dumpField "include_dirs"    (include_dirs    pkg),
 127          dumpField "c_includes"      (c_includes      pkg),
 128          dumpField "package_deps"    (package_deps    pkg),
 129          dumpField "extra_ghc_opts"  (extra_ghc_opts  pkg),
 130          dumpField "extra_cc_opts"   (extra_cc_opts   pkg),
 131          dumpField "extra_ld_opts"   (extra_ld_opts   pkg)
 132       ])))
 133
 134 dumpField :: String -> [String] -> Doc
 135 dumpField name val =
 136    hang (text name <+> equals) 2
 137         (brackets (sep (punctuate comma (map (text . show) val))))