-- * Flags and settings
DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt,
parseDynamicFlags,
+ initPackages,
getSessionDynFlags,
setSessionDynFlags,
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(..),
isLoaded,
topSortModuleGraph,
+ -- * Inspecting modules
+ ModuleInfo,
+ getModuleInfo,
+ modInfoTyThings,
+ modInfoInstances,
+ lookupName,
+
-- * Interactive evaluation
getBindings, getPrintUnqual,
#ifdef GHCI
getInfo, GetInfoResult,
exprType,
typeKind,
- lookupName,
+ parseName,
RunResult(..),
runStmt,
browseModule,
#endif
-- * Abstract syntax elements
+
+ -- ** Modules
Module, mkModule, pprModule,
+
+ -- ** Identifiers
+ Name,
+ Id, idType,
+
+ -- ** Type constructors
+ TyCon,
+
+ -- ** Data constructors
+ DataCon,
+
+ -- ** Classes
+ Class,
+
+ -- ** Instances
+ Instance,
+
+ -- ** Types and Kinds
Type, dropForAlls,
Kind,
- Name, Id, TyCon, Class, DataCon,
+
+ -- ** Entities
TyThing(..),
- idType,
- -- used by DriverMkDepend:
+ -- * Exceptions
+ GhcException(..), showGhcException,
+
+ -- * Miscellaneous
sessionHscEnv,
cyclicModuleErr,
) where
import qualified Linker
import Linker ( HValue, extendLinkEnv )
import NameEnv ( lookupNameEnv )
-import TcRnDriver ( mkExportEnv, getModuleContents )
-import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
-import HscMain ( hscGetInfo, GetInfoResult,
+import TcRnDriver ( mkExportEnv, getModuleContents, tcRnLookupRdrName )
+import RdrName ( plusGlobalRdrEnv )
+import HscMain ( hscGetInfo, GetInfoResult, hscParseIdentifier,
hscStmt, hscTcExpr, hscKcType )
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
import IfaceSyn ( IfaceDecl )
#endif
+import Packages ( initPackages )
+import RdrName ( GlobalRdrEnv )
+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, putMsg, debugTraceMsg )
import qualified ErrUtils
import Util
-import StringBuffer ( StringBuffer(..), hGetStringBuffer, lexemeToString )
+import StringBuffer ( StringBuffer, hGetStringBuffer )
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 )
import EXCEPTION as Exception hiding (handle)
-import GLAEXTS ( Int(..) )
import DATA_IOREF
import IO
import Prelude hiding (init)
hFlush stdout
case exception of
-- an IO exception probably isn't our fault, so don't panic
- IOException _ -> hPutStrLn stderr (show exception)
+ IOException _ -> putMsg (show exception)
AsyncException StackOverflow ->
- hPutStrLn stderr "stack overflow: use +RTS -K<size> to increase it"
- _other -> hPutStr stderr (show (Panic (show exception)))
+ putMsg "stack overflow: use +RTS -K<size> to increase it"
+ _other -> putMsg (show (Panic (show exception)))
exitWith (ExitFailure 1)
) $
case dyn of
PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1)
- _ -> do hPutStrLn stderr (show (dyn :: GhcException))
+ _ -> do putMsg (show (dyn :: GhcException))
exitWith (ExitFailure 1)
) $
inner
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 ()
old_graph = hsc_mod_graph hsc_env
showPass dflags "Chasing dependencies"
- when (verbosity dflags >= 1 && gmode == BatchCompile) $
- hPutStrLn stderr (showSDoc (hcat [
+ when (gmode == BatchCompile) $
+ debugTraceMsg dflags 1 (showSDoc (hcat [
text "Chasing modules from: ",
hcat (punctuate comma (map pprTarget targets))]))
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
evaluate pruned_hpt
- when (verb >= 2) $
- putStrLn (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
+ debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
text "Stable BCO:" <+> ppr stable_bco))
-- Unload any modules which are going to be re-linked this time around.
-- 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
then
-- Easy; just relink it all.
- do when (verb >= 2) $
- hPutStrLn stderr "Upsweep completely successful."
+ do debugTraceMsg dflags 2 "Upsweep completely successful."
-- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
mod_graph
do_linking = a_root_is_Main || no_hs_main
- when (ghci_mode == BatchCompile && isJust ofile && not do_linking
- && verb > 0) $
- hPutStrLn stderr ("Warning: output was redirected with -o, " ++
+ when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
+ debugTraceMsg dflags 1 ("Warning: output was redirected with -o, " ++
"but no output will be generated\n" ++
"because there is no " ++ main_mod ++ " module.")
-- Tricky. We need to back out the effects of compiling any
-- half-done cycles, both so as to clean up the top level envs
-- and to avoid telling the interactive linker to link them.
- do when (verb >= 2) $
- hPutStrLn stderr "Upsweep partially successful."
+ do debugTraceMsg dflags 2 "Upsweep partially successful."
let modsDone_names
= map ms_mod modsDone
-- 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,
+ -- ToDo: renamedSource
+ 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
unload :: HscEnv -> [Linkable] -> IO ()
unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
= case ghcMode (hsc_dflags hsc_env) of
- BatchCompile -> return ()
+ BatchCompile -> return ()
+ JustTypecheck -> return ()
#ifdef GHCI
Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
#else
upsweep hsc_env old_hpt stable_mods cleanup
(CyclicSCC ms:_)
- = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms))
+ = do putMsg (showSDoc (cyclicModuleErr ms))
return (Failed, hsc_env, [])
upsweep hsc_env old_hpt stable_mods cleanup
-> Maybe Module
-> [SCC ModSummary]
-- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
+-- The resulting list of strongly-connected-components is in topologically
+-- sorted order, starting with the module(s) at the bottom of the
+-- dependency graph (ie compile them first) and ending with the ones at
+-- the top.
--
-- Drop hi-boot nodes (first boolean arg)?
--
return (dflags', "<buffer>", buf)
--- code adapted from the file-based version in DriverUtil
-getOptionsFromStringBuffer :: StringBuffer -> [String]
-getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) =
- let
- ls = lines (lexemeToString buffer (I# len#)) -- lazy, so it's ok
- in
- look ls
- where
- look [] = []
- look (l':ls) = do
- let l = removeSpaces l'
- case () of
- () | null l -> look ls
- | prefixMatch "#" l -> look ls
- | prefixMatch "{-# LINE" l -> look ls -- -}
- | Just opts <- matchOptions l
- -> opts ++ look ls
- | otherwise -> []
-
-----------------------------------------------------------------------------
-- Error messages
-----------------------------------------------------------------------------
getPrintUnqual :: Session -> IO PrintUnqualified
getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
+#ifdef GHCI
+-- | Parses a string as an identifier, and returns the list of 'Name's that
+-- the identifier can refer to in the current interactive context.
+parseName :: Session -> String -> IO [Name]
+parseName s str = withSession s $ \hsc_env -> do
+ maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
+ case maybe_rdr_name of
+ Nothing -> return []
+ Just (L _ rdr_name) -> do
+ mb_names <- tcRnLookupRdrName hsc_env rdr_name
+ case mb_names of
+ Nothing -> return []
+ Just ns -> return ns
+ -- ToDo: should return error messages
+#endif
+
+-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
+-- entity known to GHC, including 'Name's defined using 'runStmt'.
+lookupName :: Session -> Name -> IO (Maybe TyThing)
+lookupName s name = withSession s $ \hsc_env -> do
+ case lookupTypeEnv (ic_type_env (hsc_IC hsc_env)) name of
+ Just tt -> return (Just tt)
+ Nothing -> do
+ eps <- readIORef (hsc_EPS hsc_env)
+ return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
+
+
+-- | Container for information about a 'Module'.
+newtype ModuleInfo = ModuleInfo ModDetails
+ -- ToDo: this should really contain the ModIface too
+ -- We don't want HomeModInfo here, because a ModuleInfo applies
+ -- to package modules too.
+
+-- | Request information about a loaded 'Module'
+getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
+getModuleInfo s mdl = withSession s $ \hsc_env -> do
+ case lookupModuleEnv (hsc_HPT hsc_env) mdl of
+ Nothing -> return Nothing
+ Just hmi -> return (Just (ModuleInfo (hm_details hmi)))
+ -- ToDo: we should be able to call getModuleInfo on a package module,
+ -- even one that isn't loaded yet.
+
+-- | The list of top-level entities defined in a module
+modInfoTyThings :: ModuleInfo -> [TyThing]
+modInfoTyThings (ModuleInfo md) = typeEnvElts (md_types md)
+
+-- | An instance of a class
+newtype Instance = Instance DFunId
+
+-- | The list of 'Instance's defined in a module
+modInfoInstances :: ModuleInfo -> [Instance]
+modInfoInstances (ModuleInfo md) = map Instance (md_insts md)
+
#if 0
-getModuleInfo :: Session -> Module -> IO ModuleInfo
data ObjectCode
= ByteCode
| BinaryCode FilePath
-data ModuleInfo = ModuleInfo {
- lm_modulename :: Module,
- lm_summary :: ModSummary,
- lm_interface :: ModIface,
- lm_tc_code :: Maybe TypecheckedCode,
- lm_rn_code :: Maybe RenamedCode,
- lm_obj :: Maybe ObjectCode
- }
-
type TypecheckedCode = HsTypecheckedGroup
type RenamedCode = [HsGroup Name]
_not_a_home_module -> return False
-- | Looks up an identifier in the current interactive context (for :info)
+{-# DEPRECATED getInfo "we should be using parseName/lookupName instead" #-}
getInfo :: Session -> String -> IO [GetInfoResult]
getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id
Just kind -> return (Just kind)
-----------------------------------------------------------------------------
--- lookupName: returns the TyThing for a Name in the interactive context.
--- ToDo: should look it up in the full environment
-
-lookupName :: Session -> Name -> IO (Maybe TyThing)
-lookupName s name = withSession s $ \hsc_env -> do
- return $! lookupNameEnv (ic_type_env (hsc_IC hsc_env)) name
-
------------------------------------------------------------------------------
-- cmCompileExpr: compile an expression and deliver an HValue
compileExpr :: Session -> String -> IO (Maybe HValue)
-- ---------------------------------------------------------------------------
-- cmBrowseModule: get all the TyThings defined in a module
+{-# DEPRECATED browseModule "we should be using getModuleInfo instead" #-}
browseModule :: Session -> Module -> Bool -> IO [IfaceDecl]
browseModule s modl exports_only = withSession s $ \hsc_env -> do
mb_decls <- getModuleContents hsc_env modl exports_only