Commit b2d52fc9 authored by simonmar's avatar simonmar
Browse files

[project @ 2000-07-05 17:01:59 by simonmar]

Packages can now be added/removed from an installed GHC as follows:

    $ ./ghc-inplace --list-packages
    gmp, rts, std, lang, concurrent, data, net, posix, text, util,
    hssource, win32, com, std2
    $ ./ghc-inplace --add-package <newpkg
    Reading package info from stdin... done.
    Saving old package config file... done.
    Writing new package config file... done.
    $ ./ghc-inplace --list-packages
    gmp, rts, std, lang, concurrent, data, net, posix, text, util,
    hssource, win32, com, std2, mypkg
    $ ./ghc-inplace --delete-package mypkg
    Saving old package config file... done.
    Writing new package config file... done.
    $ ./ghc-inplace --list-packages
    gmp, rts, std, lang, concurrent, data, net, posix, text, util,
    hssource, win32, com, std2

This is a first stab at the kind of functionality we need for
installing Haskell libraries via RPMs: the RPM script would install
the libraries, and then do a "ghc --add-package" passing the
appropriate paths.  You'd then have "ghc -package" at your disposal to
use the newly installed package.  Similarly on de-install, the RPM
script would run "ghc --delete-package".

Also in this commit: prettify the package dumping.
parent 8d5bf65c
......@@ -18,6 +18,7 @@ import Exception
import Dynamic
import IO
import Monad
import Array
import List
import System
......@@ -38,6 +39,7 @@ name = global (value) :: IORef (ty); \
-- user ways
-- Win32 support
-- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
-- reading the package configuration file is too slow
-----------------------------------------------------------------------------
-- Differences vs. old driver:
......@@ -120,6 +122,7 @@ data BarfKind
| PhaseFailed String ExitCode
| Interrupted
| NoInputFiles
| OtherError String
deriving Eq
GLOBAL_VAR(prog_name, "ghc", String)
......@@ -146,6 +149,8 @@ showBarf (WayCombinationNotSupported ws)
(map (showString . wayName . lkupWay) ws)
showBarf (NoInputFiles)
= showString "no input files"
showBarf (OtherError str)
= showString str
barfKindTc = mkTyCon "BarfKind"
......@@ -533,6 +538,66 @@ augment_library_paths path
-----------------------------------------------------------------------------
-- Packages
GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)
listPackages :: IO ()
listPackages = do
details <- readIORef package_details
hPutStr stdout (listPkgs details)
hPutChar stdout '\n'
exitWith ExitSuccess
newPackage :: IO ()
newPackage = do
hPutStr stdout "Reading package info from stdin... "
stuff <- getContents
let new_pkg = read stuff :: (String,Package)
catchAll new_pkg
(\e -> throwDyn (OtherError "parse error in package info"))
hPutStrLn stdout "done."
conf_file <- readIORef package_config
savePackageConfig conf_file
maybeRestoreOldConfig conf_file $ do
writeNewConfig conf_file ( ++ [new_pkg])
exitWith ExitSuccess
maybeRestoreOldConfig :: String -> IO () -> IO ()
maybeRestoreOldConfig conf_file io
= catchAllIO 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... "
system ("cp " ++ conf_file ++ ".old " ++ conf_file)
hPutStrLn stdout "done."
throw e
)
writeNewConfig :: String -> ([(String,Package)] -> [(String,Package)]) -> IO ()
writeNewConfig conf_file fn = do
hPutStr stdout "Writing new package config file... "
old_details <- readIORef package_details
h <- openFile conf_file WriteMode
hPutStr h (dumpPackages (fn old_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...
system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
hPutStrLn stdout "done."
deletePackage :: String -> IO ()
deletePackage pkg = do
conf_file <- readIORef package_config
savePackageConfig conf_file
maybeRestoreOldConfig conf_file $ do
writeNewConfig conf_file (filter ((/= pkg) . fst))
exitWith ExitSuccess
-- package list is maintained in dependency order
packages = global ["std", "rts", "gmp"] :: IORef [String]
-- comma in value, so can't use macro, grrr
......@@ -1025,8 +1090,8 @@ main =
argv' <- setTopDir argv
-- read the package configuration
let conf = findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")
contents <- readFile conf
conf_file <- readIORef package_config
contents <- readFile conf_file
writeIORef package_details (read contents)
-- find the phase to stop after (i.e. -E, -C, -c, -S flags)
......@@ -1039,6 +1104,11 @@ main =
more_opts <- findBuildTag
_ <- processArgs more_opts []
-- get the -v flag
verb <- readIORef verbose
when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
if stop_phase == MkDependHS -- mkdependHS is special
then do_mkdependHS flags2 srcs
else do
......@@ -1700,6 +1770,10 @@ opts =
, ( "package" , HasArg (addPackage) )
, ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns
, ( "-list-packages" , NoArg (listPackages) )
, ( "-add-package" , NoArg (newPackage) )
, ( "-delete-package" , SepArg (deletePackage) )
------- Specific phases --------------------------------------------
, ( "pgmdep" , HasArg (writeIORef pgm_dep) )
, ( "pgmL" , HasArg (writeIORef pgm_L) )
......
......@@ -15,10 +15,17 @@ data Package = Package {
}
deriving (Read, Show)
pprPackage :: [(String,Package)] -> String
pprPackage pkgs = render (brackets (vcat (punctuate comma (map pprPkg pkgs))))
listPkgs :: [(String,Package)] -> String
listPkgs pkgs = render (fsep (punctuate comma (map (text . fst) pkgs)))
pprPkg (name, (Package
dumpPackages :: [(String,Package)] -> String
dumpPackages pkgs =
render (brackets (vcat (punctuate comma (map dumpPkg pkgs))))
dumpPkg (name, pkg) = parens (hang (text (show name) <> comma)
2 (dumpPkgGuts pkg))
dumpPkgGuts (Package
{ import_dirs = import_dirs
, library_dirs = library_dirs
, libraries = libraries
......@@ -27,19 +34,18 @@ pprPkg (name, (Package
, package_deps = package_deps
, extra_ghc_opts = extra_ghc_opts
, extra_cc_opts = extra_cc_opts
, extra_ld_opts = extra_ld_opts }))
= parens (
text (show name) <> comma
<+> text "Package" <+> braces (
vcat [
text "import_dirs = " <> text (show import_dirs) <> comma,
text "library_dirs = " <> text (show library_dirs) <> comma,
text "libraries = " <> text (show libraries) <> comma,
text "include_dir = " <> text (show include_dir) <> comma,
text "c_include = " <> text (show c_include) <> comma,
text "package_deps = " <> text (show package_deps) <> comma,
text "extra_ghc_opts = " <> text (show extra_ghc_opts) <> comma,
text "extra_cc_opts = " <> text (show extra_cc_opts) <> comma,
text "extra_ld_opts = " <> text (show extra_ld_opts)
])
)
, extra_ld_opts = extra_ld_opts })
= text "Package" $$ nest 3 (braces (
sep (punctuate comma [
hang (text "import_dirs =" ) 2 (pprStrs import_dirs),
hang (text "library_dirs = " ) 2 (pprStrs library_dirs),
hang (text "libraries = " ) 2 (pprStrs libraries),
hang (text "include_dir = " ) 2 (text (show include_dir)),
hang (text "c_include = " ) 2 (text (show c_include)),
hang (text "package_deps = " ) 2 (pprStrs package_deps),
hang (text "extra_ghc_opts = " ) 2 (text (show extra_ghc_opts)),
hang (text "extra_cc_opts = " ) 2 (text (show extra_cc_opts)),
hang (text "extra_ld_opts = " ) 2 (text (show extra_ld_opts))
])))
pprStrs strs = brackets (sep (punctuate comma (map (text . show) strs)))
......@@ -9,8 +9,8 @@ import Package
main = do
args <- getArgs
case args of
[ "install" ] -> do { putStr (pprPackage (package_details True)) }
[ "in-place" ] -> do { putStr (pprPackage (package_details False)) }
[ "install" ] -> do { putStr (dumpPackages (package_details True)) }
[ "in-place" ] -> do { putStr (dumpPackages (package_details False)) }
_ -> do hPutStr stderr "usage: pkgconf (install | in-place)\n"
exitWith (ExitFailure 1)
......@@ -74,11 +74,11 @@ package_details installing =
"-u PrelBase_False_closure",
"-u PrelBase_True_closure",
"-u PrelPack_unpackCString_closure",
"-u PrelException_stackOverflow_closure",
"-u PrelException_heapOverflow_closure",
"-u PrelException_NonTermination_closure",
"-u PrelException_PutFullMVar_closure",
"-u PrelException_BlockedOnDeadMVar_closure",
"-u PrelIOBase_stackOverflow_closure",
"-u PrelIOBase_heapOverflow_closure",
"-u PrelIOBase_NonTermination_closure",
"-u PrelIOBase_PutFullMVar_closure",
"-u PrelIOBase_BlockedOnDeadMVar_closure",
"-u PrelWeak_runFinalizzerBatch_closure",
"-u __init_Prelude",
"-u __init_PrelMain"
......@@ -263,6 +263,26 @@ package_details installing =
}
),
-- no cbits at the moment, we'll need to add one if this library
-- ever calls out to any C libs.
( "hssource",
Package {
import_dirs = if installing
then [ clibdir ++ "/imports/hssource" ]
else [ cFPTOOLS_TOP_ABS ++ "/hslibs/hssource" ],
library_dirs = if installing
then [ clibdir ]
else [ cFPTOOLS_TOP_ABS ++ "/hslibs/hssource" ],
libraries = [ "HShssource" ],
include_dir = "",
c_include = "",
package_deps = ["text"],
extra_ghc_opts = "",
extra_cc_opts = "",
extra_ld_opts = ""
}
),
( "win32",
Package {
import_dirs = if installing
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment