Commit acef7156 authored by simonmar's avatar simonmar
Browse files

[project @ 2000-11-20 16:28:29 by simonmar]

Allow the root of the module tree to have a filename which is
different from its module name.  The argument to cmLoadModule is now a
filename.
parent 239717d3
......@@ -29,11 +29,12 @@ import Name ( lookupNameEnv )
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
......@@ -149,8 +150,10 @@ the system state at the same time.
\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
......@@ -235,7 +238,7 @@ cmLoadModule cmstate1 rootname
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
......@@ -269,10 +272,7 @@ cmLoadModule cmstate1 rootname
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
......@@ -391,6 +391,17 @@ upsweep_mod ghci_mode oldUI threaded1 summary1 reachable_from_here
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
......@@ -531,11 +542,21 @@ topological_sort include_source_imports summaries
-- 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
......@@ -569,6 +590,40 @@ downsweep rootNm
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
......@@ -583,44 +638,24 @@ 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
--
......@@ -18,6 +18,7 @@ import DriverUtil
import DriverState
import Linker
import Module
import Outputable
import Panic
import Util
......@@ -49,8 +50,7 @@ commands = [
("reload", reloadModule),
("set", setOptions),
("type", typeOfExpr),
("quit", quit),
("!", shellEscape)
("quit", quit)
]
shortHelpText = "use :? for help.\n"
......@@ -81,7 +81,8 @@ interactiveUI st = do
#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 ()
......@@ -90,7 +91,7 @@ uiLoop :: GHCi ()
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
......@@ -104,7 +105,11 @@ uiLoop = do
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
......@@ -120,12 +125,15 @@ runCommand c =
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
......@@ -134,6 +142,7 @@ doCommand expr = do
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
......@@ -159,24 +168,36 @@ changeDirectory = io . setCurrentDirectory
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
......@@ -213,7 +234,8 @@ shellEscape str = io (system str >> return ())
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
--
......@@ -133,10 +133,7 @@ addNoDups var x = do
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)
......
......@@ -7,6 +7,8 @@
module Finder (
initFinder, -- :: PackageConfigInfo -> IO (),
findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation))
mkHomeModuleLocn, -- :: ModuleName -> String -> FilePath
-- -> IO ModuleLocation
emptyHomeDirCache -- :: IO ()
) where
......@@ -16,6 +18,7 @@ import HscTypes ( ModuleLocation(..) )
import CmStaticInfo
import DriverPhases
import DriverState
import DriverUtil
import Module
import FiniteMap
import Util
......@@ -87,41 +90,46 @@ maybeHomeModule mod_name = do
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
......@@ -129,7 +137,9 @@ mkHomeModuleLocn mod_name basename source_fn = do
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
--
......@@ -16,7 +16,7 @@ module Interpreter (
ClosureEnv, emptyClosureEnv,
ItblEnv, emptyItblEnv,
linkIModules,
stgToInterpSyn, stgBindsToInterpSyn,
stgExprToInterpSyn, stgBindsToInterpSyn,
HValue,
UnlinkedIBind, UnlinkedIExpr,
loadObjs, resolveObjs,
......@@ -56,7 +56,7 @@ instance Outputable UnlinkedIBind where
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
--
......@@ -279,7 +279,7 @@ beginMake pkg_details mods
= 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")
......@@ -290,7 +290,7 @@ beginInteractive pkg_details mods
= 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}
......
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