Commit 9a3a6d71 authored by simonmar's avatar simonmar
Browse files

[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 <file> 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.
parent d246ceb8
-----------------------------------------------------------------------------
-- $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
......
{-# 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
......
-----------------------------------------------------------------------------
-- $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])
......
{-# 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
......
-----------------------------------------------------------------------------
-- 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<dir>
-- 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}
......
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