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
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 ()
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
-- unload first
io (GHC.setTargets session [])
- io (GHC.load session Nothing)
+ io (GHC.load session LoadAllTargets)
-- expand tildes
files <- mapM expandPath files
-- 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
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
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(..),
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
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 )
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:
-- -----------------------------------------------------------------------------
-- 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 ()
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
-- 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
-- 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
module HscMain (
HscResult(..),
hscMain, newHscEnv, hscCmmFile,
- hscBufferCheck, hscFileCheck,
+ hscFileCheck,
#ifdef GHCI
hscStmt, hscTcExpr, hscKcType,
hscGetInfo, GetInfoResult,
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 )
= 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)
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 {
-------------------
}}}}}
------------------------------
+
+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
= 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
-------------------
}
-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.
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
-- 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.)
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 ()
projects / ghc-hetmet.git / commitdiff