From 88ce01861a6e2ef0f20628e85c53e7c0d6de907b Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 15 Mar 2001 15:51:38 +0000 Subject: [PATCH] [project @ 2001-03-15 15:51:38 by simonmar] New package management tool, basically a broken-out version of ghc --list-packages, --add-package and --remove-package. These flags will be removed from GHC; use ghc-pkg instead. --- ghc/utils/ghc-pkg/Main.hs | 159 ++++++++++++++++++++++++++++++++++++++++++ ghc/utils/ghc-pkg/Makefile | 12 ++++ ghc/utils/ghc-pkg/Package.hs | 90 ++++++++++++++++++++++++ 3 files changed, 261 insertions(+) create mode 100644 ghc/utils/ghc-pkg/Main.hs create mode 100644 ghc/utils/ghc-pkg/Makefile create mode 100644 ghc/utils/ghc-pkg/Package.hs diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs new file mode 100644 index 0000000..d0a0959 --- /dev/null +++ b/ghc/utils/ghc-pkg/Main.hs @@ -0,0 +1,159 @@ +----------------------------------------------------------------------------- +-- $Id: Main.hs,v 1.1 2001/03/15 15:51:38 simonmar Exp $ +-- +-- Package management tool +----------------------------------------------------------------------------- + +module Main where + +import Package +import Config + +#ifdef __GLASGOW_HASKELL__ +import qualified Exception +#endif +import GetOpt +import Pretty +import Monad +import Directory +import System +import IO + +default_pkgconf = clibdir ++ "/package.conf" + +main = do + args <- getArgs + + case getOpt Permute flags args of + (clis,[],[]) -> runit clis + (_,_,errors) -> die (concat errors ++ + usageInfo usageHeader flags) + +data Flag = Config String | List | Add | Remove String +isConfig (Config _) = True +isConfig _ = False + +usageHeader = "ghc-pkg [OPTION...]" + +flags = [ + Option ['f'] ["config-file"] (ReqArg Config "FILE") + "Use the specified package config file", + Option ['l'] ["list-packages"] (NoArg List) + "List the currently installed packages", + Option ['a'] ["add-package"] (NoArg Add) + "Add a new package", + Option ['r'] ["remove-package"] (ReqArg Remove "NAME") + "Remove an installed package" + ] + +runit clis = do + conf_file <- + case [ f | Config f <- clis ] of + [] -> return default_pkgconf + [f] -> return f + _ -> die (usageInfo usageHeader flags) + + s <- readFile conf_file + let details = read s :: [PackageConfig] + eval_catch details (\_ -> die "parse error in package config file") + + case [ c | c <- clis, not (isConfig c) ] of + [ List ] -> listPackages details + [ Add ] -> addPackage details conf_file + [ Remove p ] -> removePackage details conf_file p + _ -> die (usageInfo usageHeader flags) + + +listPackages :: [PackageConfig] -> IO () +listPackages details = do + hPutStr stdout (listPkgs details) + hPutChar stdout '\n' + exitWith ExitSuccess + +addPackage :: [PackageConfig] -> FilePath -> IO () +addPackage details pkgconf = do + checkConfigAccess pkgconf + hPutStr stdout "Reading package info from stdin... " + s <- getContents + let new_pkg = read s :: PackageConfig + eval_catch new_pkg (\_ -> die "parse error in package info") + hPutStrLn stdout "done." + if (name new_pkg `elem` map name details) + then die ("package `" ++ name new_pkg ++ "' already installed") + else do + savePackageConfig pkgconf + maybeRestoreOldConfig pkgconf $ do + writeNewConfig pkgconf (details ++ [new_pkg]) + exitWith ExitSuccess + +removePackage :: [PackageConfig] -> FilePath -> String -> IO () +removePackage details pkgconf pkg = do + checkConfigAccess pkgconf + if (pkg `notElem` map name details) + then die ("package `" ++ pkg ++ "' not installed") + else do + savePackageConfig pkgconf + maybeRestoreOldConfig pkgconf $ do + writeNewConfig pkgconf (filter ((/= pkg) . name) details) + exitWith ExitSuccess + +checkConfigAccess :: FilePath -> IO () +checkConfigAccess pkgconf = do + access <- getPermissions pkgconf + when (not (writable access)) + (die "you don't have permission to modify the package configuration file") + +maybeRestoreOldConfig :: String -> IO () -> IO () +maybeRestoreOldConfig conf_file io + = my_catch io (\e -> do + hPutStr stdout "\nWARNING: an error was encountered while the new \n\ + \configuration was being written. Attempting to \n\ + \restore the old configuration... " + renameFile (conf_file ++ ".old") conf_file + hPutStrLn stdout "done." + my_throw e + ) + +writeNewConfig :: String -> [PackageConfig] -> IO () +writeNewConfig conf_file details = do + hPutStr stdout "Writing new package config file... " + h <- openFile conf_file WriteMode + hPutStr h (dumpPackages details ) + hClose h + hPutStrLn stdout "done." + +savePackageConfig :: String -> IO () +savePackageConfig conf_file = do + hPutStr stdout "Saving old package config file... " + -- mv rather than cp because we've already done an hGetContents + -- on this file so we won't be able to open it for writing + -- unless we move the old one out of the way... + renameFile conf_file (conf_file ++ ".old") + hPutStrLn stdout "done." + +----------------------------------------------------------------------------- + +die :: String -> IO a +die s = do { hPutStrLn stderr s; exitWith (ExitFailure 1) } + +----------------------------------------------------------------------------- +-- Exceptions + +#ifndef __GLASGOW_HASKELL__ + +eval_catch a h = a `seq` return () +my_catch = IO.catch +my_throw = IO.fail + +#else /* GHC */ + +my_throw = Exception.throw +#if __GLASGOW_HASKELL__ > 408 +eval_catch = Exception.catch . Exception.evaluate +my_catch = Exception.catch +#else +eval_catch = Exception.catchAll +my_catch = Exception.catchAllIO +#endif + +#endif diff --git a/ghc/utils/ghc-pkg/Makefile b/ghc/utils/ghc-pkg/Makefile new file mode 100644 index 0000000..2ddf5d6 --- /dev/null +++ b/ghc/utils/ghc-pkg/Makefile @@ -0,0 +1,12 @@ +# ----------------------------------------------------------------------------- +# $Id: Makefile,v 1.1 2001/03/15 15:51:38 simonmar Exp $ + +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +HS_PROG = ghc-pkg +SRC_HC_OPTS += -cpp -DPKG_TOOL -DWANT_PRETTY -package util -package text -Dlibdir=\"$(libdir)\" + +INSTALL_PROGS = $(HS_PROG) + +include $(TOP)/mk/target.mk diff --git a/ghc/utils/ghc-pkg/Package.hs b/ghc/utils/ghc-pkg/Package.hs new file mode 100644 index 0000000..51a8a93 --- /dev/null +++ b/ghc/utils/ghc-pkg/Package.hs @@ -0,0 +1,90 @@ +----------------------------------------------------------------------------- +-- $Id: Package.hs,v 1.1 2001/03/15 15:51:38 simonmar Exp $ +-- +-- Package configuration defn. +----------------------------------------------------------------------------- + +#ifdef PKG_TOOL +module Package ( + PackageConfig(..), defaultPackageConfig +#ifdef WANT_PRETTY + ,listPkgs -- :: [PackageConfig] -> String + ,dumpPackages -- :: [PackageConfig] -> String +#endif + ) where +#endif + +#ifdef WANT_PRETTY +import Pretty +#endif + +data PackageConfig + = Package { + name :: String, + import_dirs :: [String], + source_dirs :: [String], + library_dirs :: [String], + hs_libraries :: [String], + extra_libraries :: [String], + include_dirs :: [String], + c_includes :: [String], + package_deps :: [String], + extra_ghc_opts :: [String], + extra_cc_opts :: [String], + extra_ld_opts :: [String] + } +#ifdef PKG_TOOL + deriving (Read) +#endif + +defaultPackageConfig + = Package { + name = error "defaultPackage", + import_dirs = [], + source_dirs = [], + library_dirs = [], + hs_libraries = [], + extra_libraries = [], + include_dirs = [], + c_includes = [], + package_deps = [], + extra_ghc_opts = [], + extra_cc_opts = [], + extra_ld_opts = [] + } + +----------------------------------------------------------------------------- +-- Pretty printing package info + +#ifdef WANT_PRETTY +listPkgs :: [PackageConfig] -> String +listPkgs pkgs = render (fsep (punctuate comma (map (text . name) pkgs))) + +dumpPackages :: [PackageConfig] -> String +dumpPackages pkgs = + render (brackets (vcat (punctuate comma (map dumpPkgGuts pkgs)))) + +dumpPkgGuts :: PackageConfig -> Doc +dumpPkgGuts pkg = + text "Package" $$ nest 3 (braces ( + sep (punctuate comma [ + text "name = " <> text (show (name pkg)), + dumpField "import_dirs" (import_dirs pkg), + dumpField "source_dirs" (source_dirs pkg), + dumpField "library_dirs" (library_dirs pkg), + dumpField "hs_libraries" (hs_libraries pkg), + dumpField "extra_libraries" (extra_libraries pkg), + dumpField "include_dirs" (include_dirs pkg), + dumpField "c_includes" (c_includes pkg), + dumpField "package_deps" (package_deps pkg), + dumpField "extra_ghc_opts" (extra_ghc_opts pkg), + dumpField "extra_cc_opts" (extra_cc_opts pkg), + dumpField "extra_ld_opts" (extra_ld_opts pkg) + ]))) + +dumpField :: String -> [String] -> Doc +dumpField name val = + hang (text name <+> equals) 2 + (brackets (sep (punctuate comma (map (text . show) val)))) +#endif + -- 1.7.10.4