-----------------------------------------------------------------------------
--- $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
--
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
= 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
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
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
--
------- 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) )
------- 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
--
#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
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)
-- 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
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
, "-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
--
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
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)
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'
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
--
-----------------------------------------------------------------------------
-- 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 ()
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}
\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
; writeIORef v_Pgm_T touch_path
; writeIORef v_Pgm_CP cp_path
- ; return top_dir
+ ; return ()
}
\end{code}
--
-- 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.
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}
projects / ghc-hetmet.git / commitdiff