import Dynamic
import IO
+import Monad
import Array
import List
import System
-- 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:
| PhaseFailed String ExitCode
| Interrupted
| NoInputFiles
+ | OtherError String
deriving Eq
GLOBAL_VAR(prog_name, "ghc", String)
(map (showString . wayName . lkupWay) ws)
showBarf (NoInputFiles)
= showString "no input files"
+showBarf (OtherError str)
+ = showString str
barfKindTc = mkTyCon "BarfKind"
-----------------------------------------------------------------------------
-- 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
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)
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
, ( "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) )
}
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
, 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)))
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)
"-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"
}
),
+ -- 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
projects / ghc-hetmet.git / commitdiff