1 -----------------------------------------------------------------------------
2 -- $Id: PackageMaintenance.hs,v 1.7 2001/03/06 11:23:46 simonmar Exp $
6 -- (c) Simon Marlow 2000
8 -----------------------------------------------------------------------------
10 module PackageMaintenance
11 ( listPackages, newPackage, deletePackage
28 -----------------------------------------------------------------------------
29 -- Package maintenance
33 details <- readIORef v_Package_details
34 hPutStr stdout (listPkgs details)
42 details <- readIORef v_Package_details
43 hPutStr stdout "Reading package info from stdin... "
45 let new_pkg = read stuff :: Package
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"))
53 conf_file <- readIORef v_Path_package_config
54 savePackageConfig conf_file
55 maybeRestoreOldConfig conf_file $ do
56 writeNewConfig conf_file ( ++ [new_pkg])
60 deletePackage :: String -> IO ()
61 deletePackage pkg = do
63 details <- readIORef v_Package_details
64 if (pkg `notElem` map name details)
65 then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
67 conf_file <- readIORef v_Path_package_config
68 savePackageConfig conf_file
69 maybeRestoreOldConfig conf_file $ do
70 writeNewConfig conf_file (filter ((/= pkg) . name))
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"))
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."
91 writeNewConfig :: String -> ([Package] -> [Package]) -> 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))
98 hPutStrLn stdout "done."
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."
109 -----------------------------------------------------------------------------
110 -- Pretty printing package info
112 listPkgs :: [Package] -> String
113 listPkgs pkgs = render (fsep (punctuate comma (map (text . name) pkgs)))
115 dumpPackages :: [Package] -> String
117 render (brackets (vcat (punctuate comma (map dumpPkgGuts pkgs))))
119 dumpPkgGuts :: Package -> Doc
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)
136 dumpField :: String -> [String] -> Doc
138 hang (text name <+> equals) 2
139 (brackets (sep (punctuate comma (map (text . show) val))))