import Module
import PrelNames ( mainName )
import HscMain ( initPersistentCompilerState )
-import Finder ( findModule, emptyHomeDirCache )
+import Finder
import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM,
UniqFM, listToUFM )
import Unique ( Uniquable )
import Digraph ( SCC(..), stronglyConnComp )
+import DriverPhases
import DriverUtil ( BarfKind(..), splitFilename3 )
import Util
import Outputable
\begin{code}
cmLoadModule :: CmState
- -> ModuleName
- -> IO (CmState, Maybe ModuleName)
+ -> FilePath
+ -> IO (CmState, -- new state
+ Bool, -- was successful
+ [ModuleName]) -- list of modules loaded
cmLoadModule cmstate1 rootname
= do -- version 1's are the original, before downsweep
pci=pcii, gmode=ghci_mode }
let cmstate3
= CmState { pcms=pcms3, pcs=pcs3, pls=pls3 }
- return (cmstate3, Just rootname)
+ return (cmstate3, True, map name_of_summary modsDone)
else
-- Tricky. We need to back out the effects of compiling any
pci=pcii, gmode=ghci_mode }
let cmstate4
= CmState { pcms=pcms4, pcs=pcs3, pls=pls4 }
- return (cmstate4,
- -- choose rather arbitrarily who to return
- if null mods_to_keep then Nothing
- else Just (last mods_to_keep_names))
+ return (cmstate4, False, mods_to_keep_names)
-- Return (names of) all those in modsDone who are part of a cycle
let (CmThreaded pcs1 hst1 hit1) = threaded1
let old_iface = lookupUFM hit1 (name_of_summary summary1)
+ -- We *have* to compile it if we're in batch mode and we can't see
+ -- a previous linkable for it on disk.
+ compilation_mandatory
+ <- if ghci_mode /= Batch then return False
+ else case ml_obj_file (ms_location summary1) of
+ Nothing -> do --putStrLn "cmcm: object?!"
+ return True
+ Just obj_fn -> do --putStrLn ("cmcm: old obj " ++ obj_fn)
+ b <- doesFileExist obj_fn
+ return (not b)
+
let maybe_oldUI_linkable = findModuleLinkable_maybe oldUI mod_name
maybe_oldDisk_linkable
<- case ml_obj_file (ms_location summary1) of
-- Chase downwards from the specified root set, returning summaries
-- for all home modules encountered. Only follow source-import
-- links.
-downsweep :: [ModuleName] -> IO [ModSummary]
+downsweep :: [FilePath] -> IO [ModSummary]
downsweep rootNm
- = do rootSummaries <- mapM getSummary rootNm
+ = do rootSummaries <- mapM getRootSummary rootNm
loop (filter (isModuleInThisPackage.ms_mod) rootSummaries)
where
+ getRootSummary :: FilePath -> IO ModSummary
+ getRootSummary file
+ | haskellish_file file
+ = do exists <- doesFileExist file
+ if exists then summariseFile file
+ else getSummary (mkModuleName file)
+ -- ToDo: should check import paths
+ | otherwise
+ = getSummary (mkModuleName file)
+
getSummary :: ModuleName -> IO ModSummary
getSummary nm
| trace ("getSummary: "++ showSDoc (ppr nm)) True
else loop (newHomeSummaries ++ homeSummaries)
+-----------------------------------------------------------------------------
+-- Summarising modules
+
+-- We have two types of summarisation:
+--
+-- * Summarise a file. This is used for the root module passed to
+-- cmLoadModule. The file is read, and used to determine the root
+-- module name. The module name may differ from the filename.
+--
+-- * Summarise a module. We are given a module name, and must provide
+-- a summary. The finder is used to locate the file in which the module
+-- resides.
+
+summariseFile :: FilePath -> IO ModSummary
+summariseFile file
+ = do hspp_fn <- preprocess file
+ modsrc <- readFile hspp_fn
+
+ let (srcimps,imps,mod_name) = getImports modsrc
+ (path, basename, ext) = splitFilename3 file
+
+ Just (mod, location)
+ <- mkHomeModuleLocn mod_name (path ++ '/':basename) file
+
+ maybe_src_timestamp
+ <- case ml_hs_file location of
+ Nothing -> return Nothing
+ Just src_fn -> maybe_getModificationTime src_fn
+
+ return (ModSummary mod
+ location{ml_hspp_file=Just hspp_fn}
+ srcimps imps
+ maybe_src_timestamp)
+
-- Summarise a module, and pick up source and interface timestamps.
summarise :: Module -> ModuleLocation -> IO ModSummary
summarise mod location
Nothing -> return Nothing
Just src_fn -> maybe_getModificationTime src_fn
- -- If the module name is Main, allow it to be in a file
- -- different from Main.hs, and mash the mod and loc
- -- to match. Otherwise just moan.
- (mashed_mod, mashed_loc)
- <- case () of
- () | mod_name == moduleName mod
- -> return (mod, location)
- | mod_name /= moduleName mod && mod_name == mkModuleName "Main"
- -> return (mash mod location "Main")
- | otherwise
- -> do hPutStrLn stderr (showSDoc (
- text "ghc: warning: file name - module name mismatch:" <+>
- ppr (moduleName mod) <+> text "vs" <+> ppr mod_name))
- return (mash mod location (moduleNameUserString (moduleName mod)))
- where
- mash old_mod old_loc new_nm
- = (mkHomeModule (mkModuleName new_nm),
- old_loc{ml_hi_file = maybe_swizzle_basename new_nm
- (ml_hi_file old_loc)})
-
- maybe_swizzle_basename new Nothing = Nothing
- maybe_swizzle_basename new (Just old)
- = case splitFilename3 old of
- (dir, name, ext) -> Just (dir ++ new ++ ext)
-
- return (ModSummary mashed_mod
- mashed_loc{ml_hspp_file=Just hspp_fn}
- srcimps imps
- maybe_src_timestamp)
+ if mod_name == moduleName mod
+ then return ()
+ else throwDyn (OtherError
+ (showSDoc (text "file name does not match module name: "
+ <+> ppr (moduleName mod) <+> text "vs"
+ <+> ppr mod_name)))
+
+ return (ModSummary mod location{ml_hspp_file=Just hspp_fn}
+ srcimps imps
+ maybe_src_timestamp)
| otherwise
= return (ModSummary mod location [] [] Nothing)
- where
- maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime)
- maybe_getModificationTime fn
- = (do time <- getModificationTime fn
- return (Just time))
- `catch`
- (\err -> return Nothing)
+maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime)
+maybe_getModificationTime fn
+ = (do time <- getModificationTime fn
+ return (Just time))
+ `catch`
+ (\err -> return Nothing)
\end{code}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.4 2000/11/17 16:53:27 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.5 2000/11/20 16:28:29 simonmar Exp $
--
-- GHC Interactive User Interface
--
import DriverState
import Linker
import Module
+import Outputable
import Panic
import Util
("reload", reloadModule),
("set", setOptions),
("type", typeOfExpr),
- ("quit", quit),
- ("!", shellEscape)
+ ("quit", quit)
]
shortHelpText = "use :? for help.\n"
#ifndef NO_READLINE
Readline.initialize
#endif
- _ <- (unGHCi uiLoop) GHCiState{ current_module = mkModuleName "Main",
+ _ <- (unGHCi uiLoop) GHCiState{ modules = [],
+ current_module = Nothing,
target = Nothing,
cmstate = st }
return ()
uiLoop = do
st <- getGHCiState
#ifndef NO_READLINE
- l <- io (readline (moduleNameUserString (current_module st) ++ "> "))
+ l <- io (readline (mkPrompt (current_module st) ++ "> "))
#else
l <- io (hGetLine stdin)
#endif
runCommand l
uiLoop
--- Top level exception handler, just prints out the exception and carries on.
+mkPrompt Nothing = "> "
+mkPrompt (Just mod_name) = moduleNameUserString mod_name
+
+-- Top level exception handler, just prints out the exception
+-- and carries on.
runCommand c =
ghciHandle ( \other_exception ->io (putStrLn (show other_exception) )) $
ghciHandleDyn
doCommand (':' : command) = specialCommand command
doCommand expr = do
st <- getGHCiState
- dflags <- io (readIORef v_DynFlags)
- (st, maybe_hvalue) <-
- io (cmGetExpr (cmstate st) dflags (current_module st) expr)
- case maybe_hvalue of
- Nothing -> return ()
- Just hv -> io (cmRunExpr hv)
+ case current_module st of
+ Nothing -> throwDyn (OtherError "no module context in which to run the expression")
+ Just mod -> do
+ dflags <- io (readIORef v_DynFlags)
+ (st, maybe_hvalue) <-
+ io (cmGetExpr (cmstate st) dflags mod expr)
+ case maybe_hvalue of
+ Nothing -> return ()
+ Just hv -> io (cmRunExpr hv)
{-
let (mod,'.':str) = break (=='.') expr
case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
return ()
-}
+specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
specialCommand str = do
let (cmd,rest) = break isSpace str
case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
loadModule :: String -> GHCi ()
loadModule path = do
state <- getGHCiState
- (new_cmstate, mod) <- io (cmLoadModule (cmstate state)
- ({-ToDo!!-}mkModuleName path))
+ (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
+
let new_state = GHCiState {
cmstate = new_cmstate,
- current_module = case mod of
- Nothing -> current_module state
- Just m -> m,
+ modules = mods,
+ current_module = case mods of
+ [] -> Nothing
+ xs -> Just (last xs),
target = Just path
}
setGHCiState new_state
+ let mod_commas
+ | null mods = text "none."
+ | otherwise = hsep (
+ punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
+ case ok of
+ False ->
+ io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
+ True ->
+ io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
+
reloadModule :: String -> GHCi ()
reloadModule "" = do
state <- getGHCiState
case target state of
- Nothing -> io (putStr "no current target\n")
- Just path -> do (new_cmstate, mod) <- io (cmLoadModule (cmstate state) (mkModuleName path))
- setGHCiState state{cmstate=new_cmstate}
+ Nothing -> io (putStr "no current target\n")
+ Just path -> do (new_cmstate, ok, mod)
+ <- io (cmLoadModule (cmstate state) path)
+ setGHCiState state{cmstate=new_cmstate}
reloadModule _ = noArgs ":reload"
-- set options in the interpreter. Syntax is exactly the same as the
data GHCiState = GHCiState
{
- current_module :: ModuleName,
+ modules :: [ModuleName],
+ current_module :: Maybe ModuleName,
target :: Maybe FilePath,
cmstate :: CmState
}
-----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.10 2000/11/20 15:40:54 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.11 2000/11/20 16:28:29 simonmar Exp $
--
-- Utils for the driver
--
unless (x `elem` xs) $ writeIORef var (x:xs)
splitFilename :: String -> (String,String)
-splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
- where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
- stripDot ('.':xs) = xs
- stripDot xs = xs
+splitFilename f = split_longest_prefix f '.'
-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
splitFilename3 :: String -> (String,String,String)
module Finder (
initFinder, -- :: PackageConfigInfo -> IO (),
findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation))
+ mkHomeModuleLocn, -- :: ModuleName -> String -> FilePath
+ -- -> IO ModuleLocation
emptyHomeDirCache -- :: IO ()
) where
import CmStaticInfo
import DriverPhases
import DriverState
+import DriverUtil
import Module
import FiniteMap
import Util
Just home_map -> return home_map
- let basename = moduleNameUserString mod_name
+ let basename = moduleNameUserString mod_name
hs = basename ++ ".hs"
lhs = basename ++ ".lhs"
case lookupFM home_map hs of {
- Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename)
- (path ++ '/':hs);
+ Just path -> mkHomeModuleLocn mod_name
+ (path ++ '/':basename) (path ++ '/':hs);
Nothing ->
case lookupFM home_map lhs of {
- Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename)
- (path ++ '/':lhs);
+ Just path -> mkHomeModuleLocn mod_name
+ (path ++ '/':basename) (path ++ '/':lhs);
Nothing -> do
-- can't find a source file anywhere, check for a lone .hi file.
hisuf <- readIORef v_Hi_suf
let hi = basename ++ '.':hisuf
case lookupFM home_map hi of {
- Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename)
- (path ++ '/':hs);
+ Just path -> mkHomeModuleLocn mod_name
+ (path ++ '/':basename) (path ++ '/':hs);
Nothing -> do
-- last chance: .hi-boot-<ver> and .hi-boot
let hi_boot = basename ++ ".hi-boot"
let hi_boot_ver = basename ++ ".hi-boot-" ++ cHscIfaceFileVersion
case lookupFM home_map hi_boot_ver of {
- Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename)
- (path ++ '/':hs);
+ Just path -> mkHomeModuleLocn mod_name
+ (path ++ '/':basename) (path ++ '/':hs);
Nothing -> do
case lookupFM home_map hi_boot of {
- Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename)
- (path ++ '/':hs);
+ Just path -> mkHomeModuleLocn mod_name
+ (path ++ '/':basename) (path ++ '/':hs);
Nothing -> return Nothing
}}}}}
+
+-- The .hi file always follows the module name, whereas the object
+-- file may follow the name of the source file in the case where the
+-- two differ (see summariseFile in compMan/CompManager.lhs).
+
mkHomeModuleLocn mod_name basename source_fn = do
-- figure out the .hi file name: it lives in the same dir as the
ohi <- readIORef v_Output_hi
hisuf <- readIORef v_Hi_suf
let hifile = case ohi of
- Nothing -> basename ++ '.':hisuf
+ Nothing -> getdir basename
+ ++ '/':moduleNameUserString mod_name
+ ++ '.':hisuf
Just fn -> fn
-- figure out the .o file name. It also lives in the same dir
-----------------------------------------------------------------------------
--- $Id: Interpreter.hs,v 1.7 2000/11/20 14:48:54 simonpj Exp $
+-- $Id: Interpreter.hs,v 1.8 2000/11/20 16:28:29 simonmar Exp $
--
-- Interpreter subsystem wrapper
--
ClosureEnv, emptyClosureEnv,
ItblEnv, emptyItblEnv,
linkIModules,
- stgToInterpSyn, stgBindsToInterpSyn,
+ stgExprToInterpSyn, stgBindsToInterpSyn,
HValue,
UnlinkedIBind, UnlinkedIExpr,
loadObjs, resolveObjs,
ppr x = text "Can't output UnlinkedIBind"
linkIModules = error "linkIModules"
-stgToInterpSyn = error "stgToInterpSyn"
+stgExprToInterpSyn = error "stgToInterpSyn"
stgBindsToInterpSyn = error "stgBindsToInterpSyn"
loadObjs = error "loadObjs"
resolveObjs = error "loadObjs"
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.26 2000/11/19 19:40:08 simonmar Exp $
+-- $Id: Main.hs,v 1.27 2000/11/20 16:28:29 simonmar Exp $
--
-- GHC Driver program
--
= do case mods of
[] -> throwDyn (UsageError "no input files")
[mod] -> do state <- cmInit pkg_details Batch
- cmLoadModule state (mkModuleName mod)
+ cmLoadModule state mod
return ()
_ -> throwDyn (UsageError "only one module allowed with --make")
= do state <- cmInit pkg_details Interactive
case mods of
[] -> return ()
- [mod] -> do cmLoadModule state (mkModuleName mod); return ()
+ [mod] -> do cmLoadModule state mod; return ()
_ -> throwDyn (UsageError
"only one module allowed with --interactive")
interactiveUI state
-%
+
% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[FiniteMap]{An implementation of finite maps}
projects / ghc-hetmet.git / commitdiff