From c1909a1b2fbc945e797c89ba440e01e32703be5f Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 31 Mar 2005 15:16:54 +0000 Subject: [PATCH] [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. --- ghc/compiler/ghci/InteractiveUI.hs | 14 ++-- ghc/compiler/main/GHC.hs | 123 ++++++++++++++++++++++++++++-------- ghc/compiler/main/HscMain.lhs | 95 ++++++++++++++-------------- ghc/compiler/main/HscTypes.lhs | 2 +- ghc/compiler/main/Main.hs | 5 +- 5 files changed, 152 insertions(+), 87 deletions(-) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 3625f44..601d3e5 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -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 diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index df6c21a..3214a41 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -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 diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 0cf5472..3ec5978 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -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 { ------------------- @@ -290,6 +293,38 @@ hscFileFrontEnd hsc_env msg_act mod_summary = do { }}}}} ------------------------------ + +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. diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 6a43db5..114f6c0 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -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 diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index ad25d55..f797899 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -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 () -- 1.7.10.4