ghc/compiler/main/PackageMaintenance.hs

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