[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.

ghc/driver/Main.hs

@@ -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) )

ghc/driver/Package.hs

@@ -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)))

ghc/driver/PackageSrc.hs

@@ -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