Commit c1909a1b authored by simonmar's avatar simonmar
Browse files

[project @ 2005-03-31 15:16:53 by simonmar]

More hacking on the GHC API to get it into shape for VS

 - load now takes a LoadHowMuch argument, which is either
	LoadAllTargets
	LoadUpTo Module
	LoadDependenciesOf Module
   which should be self-explanatory.  LoadDependenciesOf might go
   away in the future, it's necessary at the moment because it is
   used in the implementation of:

 - checkModule :: Session -> Module -> MessageHandler -> IO CheckResult

   which is currently the only way to get at the parsed & typechecked
   abstract syntax for a module.
parent ee81425d
......@@ -17,7 +17,7 @@ module InteractiveUI (
import qualified GHC
import GHC ( Session, verbosity, dopt, DynFlag(..),
mkModule, pprModule, Type, Module, SuccessFlag(..),
TyThing(..), Name )
TyThing(..), Name, LoadHowMuch(..) )
import Outputable
-- following all needed for :info... ToDo: remove
......@@ -645,7 +645,7 @@ addModule files = do
targets <- mapM (io . GHC.guessTarget) files
session <- getSession
io (mapM_ (GHC.addTarget session) targets)
ok <- io (GHC.load session Nothing)
ok <- io (GHC.load session LoadAllTargets)
afterLoad ok session
changeDirectory :: String -> GHCi ()
......@@ -655,7 +655,7 @@ changeDirectory dir = do
when (not (null graph)) $
io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
io (GHC.setTargets session [])
io (GHC.load session Nothing)
io (GHC.load session LoadAllTargets)
setContextAfterLoad []
io (GHC.workingDirectoryChanged session)
dir <- expandPath dir
......@@ -713,7 +713,7 @@ loadModule' files = do
-- unload first
io (GHC.setTargets session [])
io (GHC.load session Nothing)
io (GHC.load session LoadAllTargets)
-- expand tildes
files <- mapM expandPath files
......@@ -725,7 +725,7 @@ loadModule' files = do
-- as a ToDo for now.
io (GHC.setTargets session targets)
ok <- io (GHC.load session Nothing)
ok <- io (GHC.load session LoadAllTargets)
afterLoad ok session
......@@ -733,12 +733,12 @@ reloadModule :: String -> GHCi ()
reloadModule "" = do
io (revertCAFs) -- always revert CAFs on reload.
session <- getSession
ok <- io (GHC.load session Nothing)
ok <- io (GHC.load session LoadAllTargets)
afterLoad ok session
reloadModule m = do
io (revertCAFs) -- always revert CAFs on reload.
session <- getSession
ok <- io (GHC.load session (Just (mkModule m)))
ok <- io (GHC.load session (LoadUpTo (mkModule m)))
afterLoad ok session
afterLoad ok session = do
......
......@@ -22,16 +22,18 @@ module GHC (
setMsgHandler,
-- * Targets
Target(..),
Target(..), TargetId(..),
setTargets,
getTargets,
addTarget,
removeTarget,
guessTarget,
-- * Loading\/compiling the program
depanal,
load, SuccessFlag(..), -- also does depanal
load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
workingDirectoryChanged,
checkModule, CheckedModule(..),
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..),
......@@ -96,19 +98,22 @@ import GHC.Exts ( unsafeCoerce# )
import IfaceSyn ( IfaceDecl )
#endif
import HsSyn ( HsModule, LHsBinds )
import Type ( Kind, Type, dropForAlls )
import Id ( Id, idType )
import TyCon ( TyCon )
import Class ( Class )
import DataCon ( DataCon )
import Name ( Name )
import RdrName ( RdrName )
import NameEnv ( nameEnvElts )
import SrcLoc ( Located )
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import GetImports ( getImports )
import Packages ( isHomePackage )
import Finder
import HscMain ( newHscEnv )
import HscMain ( newHscEnv, hscFileCheck, HscResult(..) )
import HscTypes
import DynFlags
import StaticFlags
......@@ -117,19 +122,20 @@ import Module
import FiniteMap
import Panic
import Digraph
import ErrUtils ( showPass )
import ErrUtils ( showPass, Messages )
import qualified ErrUtils
import Util
import StringBuffer ( StringBuffer(..), hGetStringBuffer, lexemeToString )
import Outputable
import SysTools ( cleanTempFilesExcept )
import BasicTypes ( SuccessFlag(..), succeeded )
import BasicTypes ( SuccessFlag(..), succeeded, failed )
import Maybes ( orElse, expectJust, mapCatMaybes )
import Directory ( getModificationTime, doesFileExist )
import Maybe ( isJust, isNothing, fromJust )
import Maybes ( expectJust )
import List ( partition, nub )
import qualified List
import Monad ( unless, when, foldM )
import System ( exitWith, ExitCode(..) )
import Time ( ClockTime )
......@@ -265,13 +271,17 @@ setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
getTargets :: Session -> IO [Target]
getTargets s = withSession s (return . hsc_targets)
-- Add another target, or update an existing target with new content.
-- | Add another target
addTarget :: Session -> Target -> IO ()
addTarget s target
= modifySession s (\h -> h{ hsc_targets = target : hsc_targets h })
-- Remove a target
-- removeTarget :: Session -> Module -> IO ()
-- | Remove a target
removeTarget :: Session -> TargetId -> IO ()
removeTarget s target_id
= modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) })
where
filter targets = [ t | t@(Target id _) <- targets, id /= target_id ]
-- Attempts to guess what Target a string refers to. This function implements
-- the --make/GHCi command-line syntax for filenames:
......@@ -299,22 +309,6 @@ guessTarget file
-- -----------------------------------------------------------------------------
-- Loading the program
-- | The result of load.
data LoadResult
= LoadOk Errors -- ^ all specified targets were loaded successfully.
| LoadFailed Errors -- ^ not all modules were loaded.
type Errors = [String]
{-
data ErrMsg = ErrMsg {
errMsgSeverity :: Severity, -- warning, error, etc.
errMsgSpans :: [SrcSpan],
errMsgShortDoc :: Doc,
errMsgExtraInfo :: Doc
}
-}
-- Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
depanal :: Session -> [Module] -> IO ()
......@@ -335,12 +329,32 @@ depanal (Session ref) excluded_mods = do
graph <- downsweep hsc_env old_graph excluded_mods
writeIORef ref hsc_env{ hsc_mod_graph=graph }
{-
-- | The result of load.
data LoadResult
= LoadOk Errors -- ^ all specified targets were loaded successfully.
| LoadFailed Errors -- ^ not all modules were loaded.
type Errors = [String]
data ErrMsg = ErrMsg {
errMsgSeverity :: Severity, -- warning, error, etc.
errMsgSpans :: [SrcSpan],
errMsgShortDoc :: Doc,
errMsgExtraInfo :: Doc
}
-}
data LoadHowMuch
= LoadAllTargets
| LoadUpTo Module
| LoadDependenciesOf Module
-- | Try to load the program. If a Module is supplied, then just
-- attempt to load up to this target. If no Module is supplied,
-- then try to load all targets.
load :: Session -> Maybe Module -> IO SuccessFlag
load s@(Session ref) maybe_mod
load :: Session -> LoadHowMuch -> IO SuccessFlag
load s@(Session ref) how_much
= do
-- Dependency analysis first. Note that this fixes the module graph:
-- even if we don't get a fully successful upsweep, the full module
......@@ -414,9 +428,27 @@ load s@(Session ref) maybe_mod
-- This graph should be cycle-free.
-- If we're restricting the upsweep to a portion of the graph, we
-- also want to retain everything that is still stable.
let full_mg, partial_mg :: [SCC ModSummary]
let full_mg :: [SCC ModSummary]
full_mg = topSortModuleGraph False mod_graph Nothing
partial_mg = topSortModuleGraph False mod_graph maybe_mod
maybe_top_mod = case how_much of
LoadUpTo m -> Just m
LoadDependenciesOf m -> Just m
_ -> Nothing
partial_mg0 :: [SCC ModSummary]
partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
-- LoadDependenciesOf m: we want the upsweep to stop just
-- short of the specified module (unless the specified module
-- is stable).
partial_mg
| LoadDependenciesOf mod <- how_much
= ASSERT( case last partial_mg0 of
AcyclicSCC ms -> ms_mod ms == mod; _ -> False )
List.init partial_mg0
| otherwise
= partial_mg0
stable_mg =
[ AcyclicSCC ms
......@@ -540,6 +572,41 @@ discardProg hsc_env
-- source file, but that doesn't do any harm.
ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ]
-- -----------------------------------------------------------------------------
-- Check module
data CheckedModule =
CheckedModule { parsedSource :: ParsedSource,
typecheckedSource :: Maybe TypecheckedSource
}
type ParsedSource = Located (HsModule RdrName)
type TypecheckedSource = (LHsBinds Id, GlobalRdrEnv)
-- | This is the way to get access to parsed and typechecked source code
-- for a module. 'checkModule' loads all the dependencies of the specified
-- module in the Session, and then attempts to typecheck the module. If
-- successful, it returns the abstract syntax for the module.
checkModule :: Session -> Module -> (Messages -> IO ())
-> IO (Maybe CheckedModule)
checkModule session@(Session ref) mod msg_act = do
-- load up the dependencies first
r <- load session (LoadDependenciesOf mod)
if (failed r) then return Nothing else do
-- now parse & typecheck the module
hsc_env <- readIORef ref
let mg = hsc_mod_graph hsc_env
case [ ms | ms <- mg, ms_mod ms == mod ] of
[] -> return Nothing
(ms:_) -> do
r <- hscFileCheck hsc_env msg_act ms
case r of
HscFail ->
return Nothing
HscChecked parsed tcd ->
return (Just (CheckedModule parsed tcd) )
-----------------------------------------------------------------------------
-- Unloading
......
......@@ -8,7 +8,7 @@
module HscMain (
HscResult(..),
hscMain, newHscEnv, hscCmmFile,
hscBufferCheck, hscFileCheck,
hscFileCheck,
#ifdef GHCI
hscStmt, hscTcExpr, hscKcType,
hscGetInfo, GetInfoResult,
......@@ -44,14 +44,14 @@ import SrcLoc ( SrcLoc, noSrcLoc )
import Module ( emptyModuleEnv )
import RdrName ( RdrName )
import HsSyn ( HsModule )
import HsSyn ( HsModule, LHsBinds )
import SrcLoc ( Located(..) )
import StringBuffer ( hGetStringBuffer )
import Parser
import Lexer ( P(..), ParseResult(..), mkPState )
import SrcLoc ( mkSrcLoc )
import TcRnDriver ( tcRnModule, tcRnExtCore )
import TcRnTypes ( TcGblEnv )
import TcRnTypes ( TcGblEnv(..) )
import TcIface ( typecheckIface )
import IfaceEnv ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState )
......@@ -138,7 +138,7 @@ data HscResult
= HscFail
-- In IDE mode: we just do the static/dynamic checks
| HscChecked (Located (HsModule RdrName)) (Maybe TcGblEnv)
| HscChecked (Located (HsModule RdrName)) (Maybe (LHsBinds Id, GlobalRdrEnv))
-- Concluded that it wasn't necessary
| HscNoRecomp ModDetails -- new details (HomeSymbolTable additions)
......@@ -212,14 +212,17 @@ hscNoRecomp hsc_env msg_act mod_summary
hscRecomp hsc_env msg_act mod_summary
have_object maybe_checked_iface
= case ms_hsc_src mod_summary of
HsSrcFile -> do { front_res <- hscFileFrontEnd hsc_env msg_act mod_summary
; hscBackEnd hsc_env mod_summary maybe_checked_iface front_res }
HsSrcFile -> do
front_res <- hscFileFrontEnd hsc_env msg_act mod_summary
hscBackEnd hsc_env mod_summary maybe_checked_iface front_res
HsBootFile -> do { front_res <- hscFileFrontEnd hsc_env msg_act mod_summary
; hscBootBackEnd hsc_env mod_summary maybe_checked_iface front_res }
HsBootFile -> do
front_res <- hscFileFrontEnd hsc_env msg_act mod_summary
hscBootBackEnd hsc_env mod_summary maybe_checked_iface front_res
ExtCoreFile -> do { front_res <- hscCoreFrontEnd hsc_env msg_act mod_summary
; hscBackEnd hsc_env mod_summary maybe_checked_iface front_res }
ExtCoreFile -> do
front_res <- hscCoreFrontEnd hsc_env msg_act mod_summary
hscBackEnd hsc_env mod_summary maybe_checked_iface front_res
hscCoreFrontEnd hsc_env msg_act mod_summary = do {
-------------------
......@@ -289,6 +292,38 @@ hscFileFrontEnd hsc_env msg_act mod_summary = do {
Just ds_result -> return (Just ds_result)
}}}}}
------------------------------
hscFileCheck :: HscEnv -> MessageAction -> ModSummary -> IO HscResult
hscFileCheck hsc_env msg_act mod_summary = do {
-------------------
-- PARSE
-------------------
; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
hspp_buf = ms_hspp_buf mod_summary
; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf
; case maybe_parsed of {
Left err -> do { msg_act (unitBag err, emptyBag)
; return HscFail } ;
Right rdr_module -> do {
-------------------
-- RENAME and TYPECHECK
-------------------
(tc_msgs, maybe_tc_result)
<- _scc_ "Typecheck-Rename"
tcRnModule hsc_env (ms_hsc_src mod_summary) rdr_module
; msg_act tc_msgs
; case maybe_tc_result of {
Nothing -> return (HscChecked rdr_module Nothing);
Just tc_result -> return (HscChecked rdr_module
(Just (tcg_binds tc_result,
tcg_rdr_env tc_result)))
}}}}
------------------------------
hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult
-- For hs-boot files, there's no code generation to do
......@@ -321,7 +356,7 @@ hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result)
= do { -- OMITTED:
-- ; seqList imported_modules (return ())
let one_shot = isOneShot (ghcMode (hsc_dflags hsc_env))
let one_shot = isOneShot (ghcMode dflags)
dflags = hsc_dflags hsc_env
-------------------
......@@ -414,44 +449,6 @@ hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result)
}
hscFileCheck hsc_env msg_act hspp_file = do {
-------------------
-- PARSE
-------------------
; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file Nothing
; case maybe_parsed of {
Left err -> do { msg_act (unitBag err, emptyBag) ;
; return HscFail ;
};
Right rdr_module -> hscBufferTypecheck hsc_env rdr_module msg_act
}}
-- Perform static/dynamic checks on the source code in a StringBuffer
-- This is a temporary solution: it'll read in interface files lazily, whereas
-- we probably want to use the compilation manager to load in all the modules
-- in a project.
hscBufferCheck :: HscEnv -> StringBuffer -> MessageAction -> IO HscResult
hscBufferCheck hsc_env buffer msg_act = do
let loc = mkSrcLoc (mkFastString "*edit*") 1 0
showPass (hsc_dflags hsc_env) "Parser"
case unP parseModule (mkPState buffer loc (hsc_dflags hsc_env)) of
PFailed span err -> do
msg_act (emptyBag, unitBag (mkPlainErrMsg span err))
return HscFail
POk _ rdr_module -> do
hscBufferTypecheck hsc_env rdr_module msg_act
hscBufferTypecheck hsc_env rdr_module msg_act = do
(tc_msgs, maybe_tc_result) <- {-# SCC "Typecheck-Rename" #-}
tcRnModule hsc_env HsSrcFile rdr_module
msg_act tc_msgs
case maybe_tc_result of
Nothing -> return (HscChecked rdr_module Nothing)
-- space leak on rdr_module!
Just r -> return (HscChecked rdr_module (Just r))
hscCodeGen dflags
ModGuts{ -- This is the last use of the ModGuts in a compilation.
......
......@@ -193,7 +193,7 @@ data Target = Target TargetId (Maybe (StringBuffer,ClockTime))
data TargetId
= TargetModule Module -- ^ A module name: search for the file
| TargetFile FilePath -- ^ A filename: parse it to find the module name.
deriving Eq
pprTarget :: Target -> SDoc
pprTarget (Target id _) = pprTargetId id
......
......@@ -13,7 +13,8 @@ module Main (main) where
-- The official GHC API
import qualified GHC
import GHC ( Session, DynFlags(..), GhcMode(..), HscTarget(..) )
import GHC ( Session, DynFlags(..), GhcMode(..), HscTarget(..),
LoadHowMuch(..) )
import CmdLineParser
-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
......@@ -354,7 +355,7 @@ doMake sess [] = throwDyn (UsageError "no input files")
doMake sess srcs = do
targets <- mapM GHC.guessTarget srcs
GHC.setTargets sess targets
ok_flag <- GHC.load sess Nothing
ok_flag <- GHC.load sess LoadAllTargets
when (failed ok_flag) (exitWith (ExitFailure 1))
return ()
......
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