1 -----------------------------------------------------------------------------
2 -- $Id: PackageMaintenance.hs,v 1.6 2000/12/18 20:42:14 qrczak 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)
41 details <- readIORef v_Package_details
42 hPutStr stdout "Reading package info from stdin... "
44 let new_pkg = read stuff :: Package
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"))
52 conf_file <- readIORef v_Path_package_config
53 savePackageConfig conf_file
54 maybeRestoreOldConfig conf_file $ do
55 writeNewConfig conf_file ( ++ [new_pkg])
58 deletePackage :: String -> IO ()
59 deletePackage pkg = do
61 details <- readIORef v_Package_details
62 if (pkg `notElem` map name details)
63 then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
65 conf_file <- readIORef v_Path_package_config
66 savePackageConfig conf_file
67 maybeRestoreOldConfig conf_file $ do
68 writeNewConfig conf_file (filter ((/= pkg) . name))
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"))
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 ("cp " ++ conf_file ++ ".old " ++ conf_file) "Restoring old configuration"
85 hPutStrLn stdout "done."
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))
96 hPutStrLn stdout "done."
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 ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old") "Saving package configuration"
105 hPutStrLn stdout "done."
107 -----------------------------------------------------------------------------
108 -- Pretty printing package info
110 listPkgs :: [Package] -> String
111 listPkgs pkgs = render (fsep (punctuate comma (map (text . name) pkgs)))
113 dumpPackages :: [Package] -> String
115 render (brackets (vcat (punctuate comma (map dumpPkgGuts pkgs))))
117 dumpPkgGuts :: Package -> Doc
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)
134 dumpField :: String -> [String] -> Doc
136 hang (text name <+> equals) 2
137 (brackets (sep (punctuate comma (map (text . show) val))))