From 9a3a6d713d1a01df5342206993ac9a816e6d5a31 Mon Sep 17 00:00:00 2001 From: simonmar Date: Mon, 13 Aug 2001 15:49:38 +0000 Subject: [PATCH] [project @ 2001-08-13 15:49:37 by simonmar] A bunch of changes (been waiting for the link to cvs.haskell.org to come back): - Two new flags -ignore-dot-ghci and -read-dot-ghci control the reading (or not) of ./.ghci and $HOME/.ghci. This will be useful for automatic testing of GHCi. - A new option -package-conf allows reading an additional package.conf file, which can be used to keep a per-user set of packages. - GHCi now fails gracefully on startup if linking the libraries specified on the command-line fails. --- ghc/compiler/ghci/InteractiveUI.hs | 70 +++++++++++++++++++++--------------- ghc/compiler/main/DriverFlags.hs | 7 +++- ghc/compiler/main/DriverState.hs | 24 ++++++++++--- ghc/compiler/main/Main.hs | 21 ++++++----- ghc/compiler/main/SysTools.lhs | 30 +++++++++------- 5 files changed, 95 insertions(+), 57 deletions(-) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index e5a950a..ea3431c 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.84 2001/08/09 10:55:53 sewardj Exp $ +-- $Id: InteractiveUI.hs,v 1.85 2001/08/13 15:49:37 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -164,31 +164,36 @@ interactiveUI cmstate paths cmdline_libs = do runGHCi :: GHCi () runGHCi = do - -- Read in ./.ghci. - let file = "./.ghci" - exists <- io (doesFileExist file) - when exists $ do - dir_ok <- io (checkPerms ".") - file_ok <- io (checkPerms file) - when (dir_ok && file_ok) $ do - either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) - case either_hdl of - Left e -> return () - Right hdl -> fileLoop hdl False - - -- Read in $HOME/.ghci - either_dir <- io (IO.try (getEnv "HOME")) - case either_dir of - Left e -> return () - Right dir -> do - cwd <- io (getCurrentDirectory) - when (dir /= cwd) $ do - let file = dir ++ "/.ghci" - ok <- io (checkPerms file) - either_hdl <- io (IO.try (openFile file ReadMode)) - case either_hdl of - Left e -> return () - Right hdl -> fileLoop hdl False + read_dot_files <- io (readIORef v_Read_DotGHCi) + + when (read_dot_files) $ do + -- Read in ./.ghci. + let file = "./.ghci" + exists <- io (doesFileExist file) + when exists $ do + dir_ok <- io (checkPerms ".") + file_ok <- io (checkPerms file) + when (dir_ok && file_ok) $ do + either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) + case either_hdl of + Left e -> return () + Right hdl -> fileLoop hdl False + + when (read_dot_files) $ do + -- Read in $HOME/.ghci + either_dir <- io (IO.try (getEnv "HOME")) + case either_dir of + Left e -> return () + Right dir -> do + cwd <- io (getCurrentDirectory) + when (dir /= cwd) $ do + let file = dir ++ "/.ghci" + ok <- io (checkPerms file) + when ok $ do + either_hdl <- io (IO.try (openFile file ReadMode)) + case either_hdl of + Left e -> return () + Right hdl -> fileLoop hdl False -- read commands from stdin #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS @@ -702,6 +707,12 @@ linkPackages cmdline_lib_specs pkgs = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ] lib_paths <- readIORef v_Library_paths mapM_ (preloadLib lib_paths) cmdline_lib_specs + if (null cmdline_lib_specs) + then return () + else do putStr "final link ... " + ok <- resolveObjs + if ok then putStrLn "done." + else throwDyn (InstallationError "linking extra libraries/objects failed") where -- Packages that are already linked into GHCi. For mingw32, we only -- skip gmp and rts, since std and after need to load the msvcrt.dll @@ -719,7 +730,7 @@ linkPackages cmdline_lib_specs pkgs case lib_spec of Left static_ish -> do b <- preload_static lib_paths static_ish - putStrLn (if b then "done" else "not found") + putStrLn (if b then "done." else "not found") Right dll_unadorned -> -- We add "" to the set of paths to try, so that -- if none of the real paths match, we force addDLL @@ -775,8 +786,9 @@ linkPackage loaded_in_ghci pkg mapM loadClassified sos_first putStr "linking ... " - resolveObjs - putStrLn "done." + ok <- resolveObjs + if ok then putStrLn "done." + else panic ("can't load package `" ++ name pkg ++ "'") where isRight (Right _) = True isRight (Left _) = False diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index b3cb69f..9a8efee 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.63 2001/07/24 04:47:06 ken Exp $ +-- $Id: DriverFlags.hs,v 1.64 2001/08/13 15:49:38 simonmar Exp $ -- -- Driver flags -- @@ -167,6 +167,10 @@ static_flags = ------- verbosity ---------------------------------------------------- , ( "n" , NoArg setDryRun ) + ------- GHCi ------------------------------------------------------- + , ( "ignore-dot-ghci", NoArg (writeIORef v_Read_DotGHCi False) ) + , ( "read-dot-ghci" , NoArg (writeIORef v_Read_DotGHCi True) ) + ------- recompilation checker -------------------------------------- , ( "recomp" , NoArg (writeIORef v_Recomp True) ) , ( "no-recomp" , NoArg (writeIORef v_Recomp False) ) @@ -239,6 +243,7 @@ static_flags = ------- Packages ---------------------------------------------------- , ( "package-name" , HasArg (\s -> add v_Opt_C ("-inpackage="++s)) ) + , ( "package-conf" , HasArg (readPackageConf) ) , ( "package" , HasArg (addPackage) ) , ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index f45105f..e9b6282 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.52 2001/08/02 16:30:41 simonmar Exp $ +-- $Id: DriverState.hs,v 1.53 2001/08/13 15:49:38 simonmar Exp $ -- -- Settings for the driver -- @@ -12,7 +12,9 @@ module DriverState where #include "../includes/config.h" #include "HsVersions.h" -import Packages ( PackageConfig(..) ) +import SysTools ( getTopDir ) +import ParsePkgConf ( loadPackageConfig ) +import Packages ( PackageConfig(..), mungePackagePaths ) import CmdLineOpts import DriverPhases import DriverUtil @@ -73,6 +75,7 @@ GLOBAL_VAR(v_Recomp, True, Bool) GLOBAL_VAR(v_Collect_ghc_timing, False, Bool) GLOBAL_VAR(v_Do_asm_mangling, True, Bool) GLOBAL_VAR(v_Excess_precision, False, Bool) +GLOBAL_VAR(v_Read_DotGHCi, True, Bool) ----------------------------------------------------------------------------- -- Splitting object files (for libraries) @@ -404,6 +407,19 @@ GLOBAL_VAR(v_HCHeader, "", String) -- package list is maintained in dependency order GLOBAL_VAR(v_Packages, ("std":"rts":"gmp":[]), [String]) +readPackageConf :: String -> IO () +readPackageConf conf_file = do + proto_pkg_details <- loadPackageConfig conf_file + top_dir <- getTopDir + let pkg_details = mungePackagePaths top_dir proto_pkg_details + old_pkg_details <- readIORef v_Package_details + let intersection = filter (`elem` map name old_pkg_details) + (map name pkg_details) + if (not (null intersection)) + then throwDyn (InstallationError ("package `" ++ head intersection ++ "' is already defined")) + else do + writeIORef v_Package_details (pkg_details ++ old_pkg_details) + addPackage :: String -> IO () addPackage package = do pkg_details <- readIORef v_Package_details @@ -492,7 +508,7 @@ getPackageDetails ps = do pkg_details <- readIORef v_Package_details return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ] -GLOBAL_VAR(v_Package_details, (error "package_details"), [PackageConfig]) +GLOBAL_VAR(v_Package_details, [], [PackageConfig]) lookupPkg :: String -> [PackageConfig] -> Maybe PackageConfig lookupPkg nm ps @@ -682,7 +698,7 @@ unregFlags = , "-fvia-C" ] ----------------------------------------------------------------------------- --- Programs for particular phases +-- Options for particular phases GLOBAL_VAR(v_Opt_dep, [], [String]) GLOBAL_VAR(v_Anti_opt_C, [], [String]) diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 9db7ba3..0ecb6d2 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.85 2001/08/08 08:44:47 simonmar Exp $ +-- $Id: Main.hs,v 1.86 2001/08/13 15:49:38 simonmar Exp $ -- -- GHC Driver program -- @@ -25,9 +25,8 @@ import Finder ( initFinder ) import CompManager ( cmInit, cmLoadModule ) import HscTypes ( GhciMode(..) ) import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion ) -import SysTools ( packageConfigPath, initSysTools, cleanTempFiles ) -import Packages ( showPackages, mungePackagePaths ) -import ParsePkgConf ( loadPackageConfig ) +import SysTools ( getPackageConfigPath, initSysTools, cleanTempFiles ) +import Packages ( showPackages ) import DriverPipeline ( GhcMode(..), doLink, doMkDLL, genPipeline, getGhcMode, pipeLoop, v_GhcMode @@ -36,7 +35,8 @@ import DriverState ( buildCoreToDo, buildStgToDo, defaultHscLang, findBuildTag, getPackageInfo, unregFlags, v_Cmdline_libraries, v_Keep_tmp_files, v_Ld_inputs, v_OptLevel, v_Output_file, v_Output_hi, - v_Package_details, v_Ways, getPackageExtraGhcOpts + v_Package_details, v_Ways, getPackageExtraGhcOpts, + readPackageConf ) import DriverFlags ( dynFlag, buildStaticHscOpts, dynamic_flags, processArgs, static_flags) @@ -151,10 +151,8 @@ main = top_dir <- initSysTools minusB_args -- Read the package configuration - conf_file <- packageConfigPath - proto_pkg_details <- loadPackageConfig conf_file - let pkg_details = mungePackagePaths top_dir proto_pkg_details - writeIORef v_Package_details pkg_details + conf_file <- getPackageConfigPath + readPackageConf conf_file -- find the phase to stop after (i.e. -E, -C, -c, -S flags) (flags2, mode, stop_flag) <- getGhcMode argv' @@ -245,11 +243,12 @@ main = when (verb >= 2) (hPutStrLn stderr ("Using package config file: " ++ conf_file)) + pkg_details <- readIORef v_Package_details + showPackages pkg_details + when (verb >= 3) (hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts)) - showPackages pkg_details - -- initialise the finder pkg_avails <- getPackageInfo initFinder pkg_avails diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index adc8e0c..e3eedf9 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -1,7 +1,9 @@ ----------------------------------------------------------------------------- --- Access to system tools: gcc, cp, rm etc +-- $Id: SysTools.lhs,v 1.48 2001/08/13 15:49:38 simonmar Exp $ +-- +-- (c) The University of Glasgow 2001 -- --- (c) The University of Glasgow 2000 +-- Access to system tools: gcc, cp, rm etc -- ----------------------------------------------------------------------------- @@ -13,8 +15,8 @@ module SysTools ( -- Command-line override setDryRun, - packageConfigPath, -- IO String - -- Where package.conf is + getTopDir, -- IO String -- The value of $libdir + getPackageConfigPath, -- IO String -- Where package.conf is -- Interface to system tools runUnlit, runCpp, runCc, -- [Option] -> IO () @@ -163,8 +165,14 @@ GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp GLOBAL_VAR(v_Path_package_config, error "path_package_config", String) GLOBAL_VAR(v_Path_usage, error "ghc_usage.txt", String) +GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B + -- Parallel system only GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager + +-- ways to get at some of these variables from outside this module +getPackageConfigPath = readIORef v_Path_package_config +getTopDir = readIORef v_TopDir \end{code} @@ -177,15 +185,15 @@ GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager \begin{code} initSysTools :: [String] -- Command-line arguments starting "-B" - -> IO String -- Set all the mutable variables above, holding + -> IO () -- Set all the mutable variables above, holding -- (a) the system programs -- (b) the package-config file -- (c) the GHC usage message - -- Return TopDir initSysTools minusB_args - = do { (am_installed, top_dir) <- getTopDir minusB_args + = do { (am_installed, top_dir) <- findTopDir minusB_args + ; writeIORef v_TopDir top_dir -- top_dir -- for "installed" this is the root of GHC's support files -- for "in-place" it is the root of the build tree @@ -319,7 +327,7 @@ initSysTools minusB_args ; writeIORef v_Pgm_T touch_path ; writeIORef v_Pgm_CP cp_path - ; return top_dir + ; return () } \end{code} @@ -362,11 +370,11 @@ setPgm pgm = unknownFlagErr ("-pgm" ++ pgm) -- -- This is very gruesome indeed -getTopDir :: [String] +findTopDir :: [String] -> IO (Bool, -- True <=> am installed, False <=> in-place String) -- TopDir (in Unix format '/' separated) -getTopDir minusbs +findTopDir minusbs = do { top_dir <- get_proto -- Discover whether we're running in a build tree or in an installation, -- by looking for the package configuration file. @@ -502,8 +510,6 @@ showGhcUsage = do { usage_path <- readIORef v_Path_usage dump "" = return () dump ('$':'$':s) = hPutStr stderr progName >> dump s dump (c:s) = hPutChar stderr c >> dump s - -packageConfigPath = readIORef v_Path_package_config \end{code} -- 1.7.10.4