1 -----------------------------------------------------------------------------
2 -- $Id: PackageMaintenance.hs,v 1.2 2000/10/11 15:26:18 simonmar Exp $
6 -- (c) Simon Marlow 2000
8 -----------------------------------------------------------------------------
10 module PackageMaintenance where
25 -----------------------------------------------------------------------------
26 -- Package maintenance
30 details <- readIORef package_details
31 hPutStr stdout (listPkgs details)
38 details <- readIORef package_details
39 hPutStr stdout "Reading package info from stdin... "
41 let new_pkg = read stuff :: Package
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"))
49 conf_file <- readIORef path_package_config
50 savePackageConfig conf_file
51 maybeRestoreOldConfig conf_file $ do
52 writeNewConfig conf_file ( ++ [new_pkg])
55 deletePackage :: String -> IO ()
56 deletePackage pkg = do
58 details <- readIORef package_details
59 if (pkg `notElem` map name details)
60 then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
62 conf_file <- readIORef path_package_config
63 savePackageConfig conf_file
64 maybeRestoreOldConfig conf_file $ do
65 writeNewConfig conf_file (filter ((/= pkg) . name))
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"))
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."
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))
93 hPutStrLn stdout "done."
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."
104 -----------------------------------------------------------------------------
105 -- Pretty printing package info
107 listPkgs :: [Package] -> String
108 listPkgs pkgs = render (fsep (punctuate comma (map (text . name) pkgs)))
110 dumpPackages :: [Package] -> String
112 render (brackets (vcat (punctuate comma (map dumpPkgGuts pkgs))))
114 dumpPkgGuts :: Package -> Doc
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)
131 dumpField :: String -> [String] -> Doc
133 hang (text name <+> equals) 2
134 (brackets (sep (punctuate comma (map (text . show) val))))