setMsgHandler,
-- * Targets
- Target(..), TargetId(..),
+ Target(..), TargetId(..), Phase,
setTargets,
getTargets,
addTarget,
modInfoTopLevelScope,
modInfoPrintUnqualified,
modInfoExports,
- lookupName,
+ modInfoInstances,
+ modInfoIsExportedName,
+ modInfoLookupName,
+ lookupGlobalName,
+
+ -- * Printing
+ PrintUnqualified, alwaysQualify,
-- * Interactive evaluation
getBindings, getPrintUnqual,
setContext, getContext,
getNamesInScope,
moduleIsInterpreted,
- getInfo, GetInfoResult,
+ getInfo,
exprType,
typeKind,
parseName,
RunResult(..),
runStmt,
- browseModule,
showModule,
compileExpr, HValue,
+ lookupName,
#endif
-- * Abstract syntax elements
Module, mkModule, pprModule,
-- ** Names
- Name,
+ Name,
+ nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
+ NamedThing(..),
-- ** Identifiers
Id, idType,
isImplicitId, isDeadBinder,
isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
isRecordSelector,
- isPrimOpId, isFCallId,
+ isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
isBottomingId, isDictonaryId,
+ recordSelectorFieldLabel,
-- ** Type constructors
TyCon,
+ tyConTyVars, tyConDataCons,
isClassTyCon, isSynTyCon, isNewTyCon,
+ getSynTyConDefn,
-- ** Data constructors
DataCon,
+ dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
+ dataConIsInfix, isVanillaDataCon,
+ dataConStrictMarks,
+ StrictnessMark(..), isMarkedStrict,
-- ** Classes
Class,
- classSCTheta, classTvsFds,
+ classMethods, classSCTheta, classTvsFds,
+ pprFundeps,
+
+ -- ** Instances
+ Instance,
+ instanceDFunId, pprInstance,
-- ** Types and Kinds
- Type, dropForAlls,
+ Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
Kind,
+ PredType,
+ ThetaType, pprThetaArrow,
-- ** Entities
TyThing(..),
-- ** Syntax
module HsSyn, -- ToDo: remove extraneous bits
+ -- ** Fixities
+ FixityDirection(..),
+ defaultFixity, maxPrecedence,
+ negateFixity,
+ compareFixity,
+
+ -- ** Source locations
+ SrcLoc, pprDefnLoc,
+
-- * Exceptions
GhcException(..), showGhcException,
{-
ToDo:
- * inline bits of HscMain here to simplify layering: hscGetInfo,
- hscTcExpr, hscStmt.
+ * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
* we need to expose DynFlags, so should parseDynamicFlags really be
part of this interface?
* what StaticFlags should we expose, if any?
#ifdef GHCI
import qualified Linker
import Linker ( HValue, extendLinkEnv )
-import NameEnv ( lookupNameEnv )
-import TcRnDriver ( mkExportEnv, getModuleContents, tcRnLookupRdrName )
-import RdrName ( plusGlobalRdrEnv )
-import HscMain ( hscGetInfo, GetInfoResult, hscParseIdentifier,
- hscStmt, hscTcExpr, hscKcType )
+import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
+ tcRnLookupName, getModuleExports )
+import RdrName ( plusGlobalRdrEnv, Provenance(..),
+ ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
+ emptyGlobalRdrEnv, mkGlobalRdrEnv )
+import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
import GHC.Exts ( unsafeCoerce# )
-import IfaceSyn ( IfaceDecl )
#endif
-import Packages ( initPackages )
-import NameSet ( NameSet, nameSetToList )
-import RdrName ( GlobalRdrEnv )
+import Packages ( initPackages, isHomeModule )
+import NameSet ( NameSet, nameSetToList, elemNameSet )
+import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName,
+ globalRdrEnvElts )
import HsSyn
-import Type ( Kind, Type, dropForAlls )
+import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
+ pprThetaArrow, pprParendType, splitForAllTys,
+ funResultTy )
import Id ( Id, idType, isImplicitId, isDeadBinder,
isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
- isRecordSelector,
- isPrimOpId, isFCallId,
+ isRecordSelector, recordSelectorFieldLabel,
+ isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
isBottomingId )
-import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon )
-import Class ( Class, classSCTheta, classTvsFds )
-import DataCon ( DataCon )
-import InstEnv ( Instance )
-import Name ( Name, getName, nameModule_maybe )
-import RdrName ( RdrName, gre_name, globalRdrEnvElts )
+import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
+ tyConTyVars, tyConDataCons, getSynTyConDefn )
+import Class ( Class, classSCTheta, classTvsFds, classMethods )
+import FunDeps ( pprFundeps )
+import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
+ dataConFieldLabels, dataConStrictMarks,
+ dataConIsInfix, isVanillaDataCon )
+import Name ( Name, nameModule, NamedThing(..), nameParent_maybe,
+ nameSrcLoc )
+import OccName ( parenSymOcc )
import NameEnv ( nameEnvElts )
-import SrcLoc ( Located(..), mkSrcLoc, srcLocSpan )
+import InstEnv ( Instance, instanceDFunId, pprInstance )
+import SrcLoc
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import GetImports ( getImports )
import FiniteMap
import Panic
import Digraph
-import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg )
+import Bag ( unitBag, emptyBag )
+import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg,
+ mkPlainErrMsg, pprBagOfErrors )
import qualified ErrUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
import Outputable
import SysTools ( cleanTempFilesExcept )
-import BasicTypes ( SuccessFlag(..), succeeded, failed )
-import Maybes ( orElse, expectJust, mapCatMaybes )
+import BasicTypes
import TcType ( tcSplitSigmaTy, isDictTy )
-import Bag ( unitBag, emptyBag )
import FastString ( mkFastString )
import Directory ( getModificationTime, doesFileExist )
-import Maybe ( isJust, isNothing, fromJust, fromMaybe, catMaybes )
-import Maybes ( expectJust )
+import Maybe ( isJust, isNothing, fromJust )
+import Maybes ( orElse, expectJust, mapCatMaybes )
import List ( partition, nub )
import qualified List
-import Monad ( unless, when, foldM )
+import Monad ( unless, when )
import System ( exitWith, ExitCode(..) )
import Time ( ClockTime )
import EXCEPTION as Exception hiding (handle)
exitWith (ExitFailure 1)
) $
- -- all error messages are propagated as exceptions
+ -- program errors: messages with locations attached. Sometimes it is
+ -- convenient to just throw these as exceptions.
+ handleDyn (\dyn -> do printErrs (pprBagOfErrors (unitBag dyn))
+ exitWith (ExitFailure 1)) $
+
+ -- error messages propagated as exceptions
handleDyn (\dyn -> do
hFlush stdout
case dyn of
-- then use that
-- - otherwise interpret the string as a module name
--
-guessTarget :: String -> IO Target
-guessTarget file
+guessTarget :: String -> Maybe Phase -> IO Target
+guessTarget file (Just phase)
+ = return (Target (TargetFile file (Just phase)) Nothing)
+guessTarget file Nothing
| isHaskellSrcFilename file
- = return (Target (TargetFile file) Nothing)
+ = return (Target (TargetFile file Nothing) Nothing)
| otherwise
= do exists <- doesFileExist hs_file
- if exists then return (Target (TargetFile hs_file) Nothing) else do
+ if exists
+ then return (Target (TargetFile hs_file Nothing) Nothing)
+ else do
exists <- doesFileExist lhs_file
- if exists then return (Target (TargetFile lhs_file) Nothing) else do
+ if exists
+ then return (Target (TargetFile lhs_file Nothing) Nothing)
+ else do
return (Target (TargetModule (mkModule file)) Nothing)
where
- hs_file = file ++ ".hs"
- lhs_file = file ++ ".lhs"
+ hs_file = file `joinFileExt` "hs"
+ lhs_file = file `joinFileExt` "lhs"
-- -----------------------------------------------------------------------------
-- Loading the program
-- Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
-depanal :: Session -> [Module] -> IO ()
+depanal :: Session -> [Module] -> IO (Either Messages ModuleGraph)
depanal (Session ref) excluded_mods = do
hsc_env <- readIORef ref
let
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 }
+ r <- downsweep hsc_env old_graph excluded_mods
+ case r of
+ Right mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
+ _ -> return ()
+ return r
{-
-- | The result of load.
-- even if we don't get a fully successful upsweep, the full module
-- graph is still retained in the Session. We can tell which modules
-- were successfully loaded by inspecting the Session's HPT.
- depanal s []
+ mb_graph <- depanal s []
+ case mb_graph of
+ Left msgs -> do msg_act msgs; return Failed
+ Right mod_graph -> loadMsgs2 s how_much msg_act mod_graph
+loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
hsc_env <- readIORef ref
let hpt1 = hsc_HPT hsc_env
let dflags = hsc_dflags hsc_env
- let mod_graph = hsc_mod_graph hsc_env
-
- let ghci_mode = ghcMode (hsc_dflags hsc_env) -- this never changes
- let verb = verbosity dflags
+ let ghci_mode = ghcMode dflags -- this never changes
-- The "bad" boot modules are the ones for which we have
-- B.hs-boot in the module graph, but no B.hs
-- The downsweep should have ensured this does not happen
-- (see msDeps)
let all_home_mods = [ms_mod s | s <- mod_graph, not (isBootSummary s)]
+#ifdef DEBUG
bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
not (ms_mod s `elem` all_home_mods)]
+#endif
ASSERT( null bad_boot_mods ) return ()
-- mg2_with_srcimps drops the hi-boot nodes, returning a
typecheckedSource :: Maybe TypecheckedSource,
checkedModuleInfo :: Maybe ModuleInfo
}
+ -- ToDo: improvements that could be made here:
+ -- if the module succeeded renaming but not typechecking,
+ -- we can still get back the GlobalRdrEnv and exports, so
+ -- perhaps the ModuleInfo should be split up into separate
+ -- fields within CheckedModule.
type ParsedSource = Located (HsModule RdrName)
type RenamedSource = HsGroup Name
type TypecheckedSource = LHsBinds Id
+-- NOTE:
+-- - things that aren't in the output of the renamer:
+-- - the export list
+-- - the imports
+-- - things that aren't in the output of the typechecker right now:
+-- - the export list
+-- - the imports
+-- - type signatures
+-- - type/data/newtype declarations
+-- - class declarations
+-- - instances
+-- - extra things in the typechecker's output:
+-- - default methods are turned into top-level decls.
+-- - dictionary bindings
+
+
-- | 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
HscChecked parsed renamed
(Just (tc_binds, rdr_env, details)) -> do
let minf = ModuleInfo {
- minf_details = details,
- minf_rdr_env = Just rdr_env
+ minf_type_env = md_types details,
+ minf_exports = md_exports details,
+ minf_rdr_env = Just rdr_env,
+ minf_instances = md_insts details
}
return (Just (CheckedModule {
parsedSource = parsed,
renamedSource = renamed,
typecheckedSource = Just tc_binds,
checkedModuleInfo = Just minf }))
+ _other ->
+ panic "checkModule"
-- ---------------------------------------------------------------------------
-- Unloading
| otherwise = False
where
same_as_prev t = case lookupModuleEnv hpt (ms_mod ms) of
- Nothing -> True
Just hmi | Just l <- hm_linkable hmi
-> isObjectLinkable l && t == linkableTime l
+ _other -> True
-- why '>=' rather than '>' above? If the filesystem stores
-- times to the nearset second, we may occasionally find that
-- the object & source have the same modification time,
bco_ok ms
= case lookupModuleEnv hpt (ms_mod ms) of
- Nothing -> False
Just hmi | Just l <- hm_linkable hmi ->
not (isObjectLinkable l) &&
linkableTime l >= ms_hs_date ms
+ _other -> False
ms_allimps :: ModSummary -> [Module]
-ms_allimps ms = ms_srcimps ms ++ ms_imps ms
+ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms)
-- -----------------------------------------------------------------------------
-- Prune the HomePackageTable
-- We use integers as the keys for the SCC algorithm
nodes :: [(ModSummary, Int, [Int])]
nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod s)),
- out_edge_keys hs_boot_key (ms_srcimps s) ++
- out_edge_keys HsSrcFile (ms_imps s) )
+ out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++
+ out_edge_keys HsSrcFile (map unLoc (ms_imps s)) )
| s <- summaries
, not (isBootSummary s && drop_hs_boot_nodes) ]
-- Drop the hi-boot ones if told to do so
msKey :: ModSummary -> NodeKey
msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot)
-emptyNodeMap :: NodeMap a
-emptyNodeMap = emptyFM
-
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = eltsFM
--- -----------------------------------------------------------------
--- The unlinked image
---
--- The compilation manager keeps a list of compiled, but as-yet unlinked
--- binaries (byte code or object code). Even when it links bytecode
--- it keeps the unlinked version so it can re-link it later without
--- recompiling.
-
-type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
-
-findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
-findModuleLinkable_maybe lis mod
- = case [LM time nm us | LM time nm us <- lis, nm == mod] of
- [] -> Nothing
- [li] -> Just li
- many -> pprPanic "findModuleLinkable" (ppr mod)
-
-delModuleLinkable :: [Linkable] -> Module -> [Linkable]
-delModuleLinkable ls mod = [ l | l@(LM _ nm _) <- ls, nm /= mod ]
-
-----------------------------------------------------------------------------
-- Downsweep (dependency analysis)
-> [ModSummary] -- Old summaries
-> [Module] -- Ignore dependencies on these; treat them as
-- if they were package modules
- -> IO [ModSummary]
+ -> IO (Either Messages [ModSummary])
downsweep hsc_env old_summaries excl_mods
- = do rootSummaries <- mapM getRootSummary roots
- checkDuplicates rootSummaries
- loop (concatMap msDeps rootSummaries)
- (mkNodeMap rootSummaries)
+ = -- catch error messages and return them
+ handleDyn (\err_msg -> return (Left (emptyBag, unitBag err_msg))) $ do
+ rootSummaries <- mapM getRootSummary roots
+ checkDuplicates rootSummaries
+ summs <- loop (concatMap msDeps rootSummaries) (mkNodeMap rootSummaries)
+ return (Right summs)
where
roots = hsc_targets hsc_env
old_summary_map = mkNodeMap old_summaries
getRootSummary :: Target -> IO ModSummary
- getRootSummary (Target (TargetFile file) maybe_buf)
+ getRootSummary (Target (TargetFile file mb_phase) maybe_buf)
= do exists <- doesFileExist file
- if exists then summariseFile hsc_env file maybe_buf else do
- throwDyn (CmdLineError ("can't find file: " ++ file))
+ if exists
+ then summariseFile hsc_env old_summaries file mb_phase maybe_buf
+ else throwDyn $ mkPlainErrMsg noSrcSpan $
+ text "can't find file:" <+> text file
getRootSummary (Target (TargetModule modl) maybe_buf)
- = do maybe_summary <- summarise hsc_env emptyNodeMap Nothing False
- modl maybe_buf excl_mods
+ = do maybe_summary <- summariseModule hsc_env old_summary_map False
+ (L rootLoc modl) maybe_buf excl_mods
case maybe_summary of
Nothing -> packageModErr modl
Just s -> return s
+ rootLoc = mkGeneralSrcSpan FSLIT("<command line>")
+
-- In a root module, the filename is allowed to diverge from the module
-- name, so we have to check that there aren't multiple root files
-- defining the same module (otherwise the duplicates will be silently
[ expectJust "checkDup" (ml_hs_file (ms_location summ'))
| summ' <- summaries, ms_mod summ' == modl ]
- loop :: [(FilePath,Module,IsBootInterface)]
+ loop :: [(Located Module,IsBootInterface)]
-- Work list: process these modules
-> NodeMap ModSummary
-- Visited set
-- The result includes the worklist, except
-- for those mentioned in the visited set
loop [] done = return (nodeMapElts done)
- loop ((cur_path, wanted_mod, is_boot) : ss) done
+ loop ((wanted_mod, is_boot) : ss) done
| key `elemFM` done = loop ss done
- | otherwise = do { mb_s <- summarise hsc_env old_summary_map
- (Just cur_path) is_boot
- wanted_mod Nothing excl_mods
+ | otherwise = do { mb_s <- summariseModule hsc_env old_summary_map
+ is_boot wanted_mod Nothing excl_mods
; case mb_s of
Nothing -> loop ss done
Just s -> loop (msDeps s ++ ss)
(addToFM done key s) }
where
- key = (wanted_mod, if is_boot then HsBootFile else HsSrcFile)
+ key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
-msDeps :: ModSummary -> [(FilePath, -- Importing module
- Module, -- Imported module
- IsBootInterface)] -- {-# SOURCE #-} import or not
+msDeps :: ModSummary -> [(Located Module, IsBootInterface)]
-- (msDeps s) returns the dependencies of the ModSummary s.
-- A wrinkle is that for a {-# SOURCE #-} import we return
-- *both* the hs-boot file
-- modules always contains B.hs if it contains B.hs-boot.
-- Remember, this pass isn't doing the topological sort. It's
-- just gathering the list of all relevant ModSummaries
-msDeps s = concat [ [(f, m, True), (f,m,False)] | m <- ms_srcimps s]
- ++ [(f,m,False) | m <- ms_imps s]
- where
- f = msHsFilePath s -- Keep the importing module for error reporting
-
+msDeps s =
+ concat [ [(m,True), (m,False)] | m <- ms_srcimps s ]
+ ++ [ (m,False) | m <- ms_imps s ]
-----------------------------------------------------------------------------
-- Summarising modules
-- a summary. The finder is used to locate the file in which the module
-- resides.
-summariseFile :: HscEnv -> FilePath
- -> Maybe (StringBuffer,ClockTime)
- -> IO ModSummary
--- Used for Haskell source only, I think
--- We know the file name, and we know it exists,
--- but we don't necessarily know the module name (might differ)
-summariseFile hsc_env file maybe_buf
- = do let dflags = hsc_dflags hsc_env
+summariseFile
+ :: HscEnv
+ -> [ModSummary] -- old summaries
+ -> FilePath -- source file name
+ -> Maybe Phase -- start phase
+ -> Maybe (StringBuffer,ClockTime)
+ -> IO ModSummary
+
+summariseFile hsc_env old_summaries file mb_phase maybe_buf
+ -- we can use a cached summary if one is available and the
+ -- source file hasn't changed, But we have to look up the summary
+ -- by source file, rather than module name as we do in summarise.
+ | Just old_summary <- findSummaryBySourceFile old_summaries file
+ = do
+ let location = ms_location old_summary
+
+ -- return the cached summary if the source didn't change
+ src_timestamp <- case maybe_buf of
+ Just (_,t) -> return t
+ Nothing -> getModificationTime file
+
+ if ms_hs_date old_summary == src_timestamp
+ then do -- update the object-file timestamp
+ obj_timestamp <- getObjTimestamp location False
+ return old_summary{ ms_obj_date = obj_timestamp }
+ else
+ new_summary
+
+ | otherwise
+ = new_summary
+ where
+ new_summary = do
+ let dflags = hsc_dflags hsc_env
(dflags', hspp_fn, buf)
- <- preprocessFile dflags file maybe_buf
+ <- preprocessFile dflags file mb_phase maybe_buf
- (srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn
+ (srcimps,the_imps, L _ mod) <- getImports dflags' buf hspp_fn
-- Make a ModLocation for this file
location <- mkHomeModLocation dflags mod file
ms_hs_date = src_timestamp,
ms_obj_date = obj_timestamp })
+findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
+findSummaryBySourceFile summaries file
+ = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
+ fromJust (ml_hs_file (ms_location ms)) == file ] of
+ [] -> Nothing
+ (x:xs) -> Just x
+
-- Summarise a module, and pick up source and timestamp.
-summarise :: HscEnv
+summariseModule
+ :: HscEnv
-> NodeMap ModSummary -- Map of old summaries
- -> Maybe FilePath -- Importing module (for error messages)
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
- -> Module -- Imported module to be summarised
+ -> Located Module -- Imported module to be summarised
-> Maybe (StringBuffer, ClockTime)
-> [Module] -- Modules to exclude
-> IO (Maybe ModSummary) -- Its new summary
-summarise hsc_env old_summary_map cur_mod is_boot wanted_mod maybe_buf excl_mods
+summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods
| wanted_mod `elem` excl_mods
= return Nothing
= do -- Find its new timestamp; all the
-- ModSummaries in the old map have valid ml_hs_files
let location = ms_location old_summary
- src_fn = expectJust "summarise" (ml_hs_file location)
+ src_fn = expectJust "summariseModule" (ml_hs_file location)
-- return the cached summary if the source didn't change
src_timestamp <- case maybe_buf of
-- Drop external-pkg
| isJust (ml_hs_file location) -> just_found location
-- Home package
- err -> noModError dflags cur_mod wanted_mod err
+ err -> noModError dflags loc wanted_mod err
-- Not found
where
dflags = hsc_dflags hsc_env
-- It might have been deleted since the Finder last found it
maybe_t <- modificationTimeIfExists src_fn
case maybe_t of
- Nothing -> noHsFileErr cur_mod src_fn
+ Nothing -> noHsFileErr loc src_fn
Just t -> new_summary location' src_fn Nothing t
= do
-- Preprocess the source file and get its imports
-- The dflags' contains the OPTIONS pragmas
- (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn maybe_buf
- (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn
+ (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
+ (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn
when (mod_name /= wanted_mod) $
- throwDyn (ProgramError
- (showSDoc (text src_fn
- <> text ": file name does not match module name"
- <+> quotes (ppr mod_name))))
+ throwDyn $ mkPlainErrMsg mod_loc $
+ text "file name does not match module name"
+ <+> quotes (ppr mod_name)
-- Find the object timestamp, and return the summary
obj_timestamp <- getObjTimestamp location is_boot
else modificationTimeIfExists (ml_obj_file location)
-preprocessFile :: DynFlags -> FilePath -> Maybe (StringBuffer,ClockTime)
+preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
-> IO (DynFlags, FilePath, StringBuffer)
-preprocessFile dflags src_fn Nothing
+preprocessFile dflags src_fn mb_phase Nothing
= do
- (dflags', hspp_fn) <- preprocess dflags src_fn
+ (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
buf <- hGetStringBuffer hspp_fn
return (dflags', hspp_fn, buf)
-preprocessFile dflags src_fn (Just (buf, time))
+preprocessFile dflags src_fn mb_phase (Just (buf, time))
= do
-- case we bypass the preprocessing stage?
let
let
needs_preprocessing
- | Unlit _ <- startPhase src_fn = True
+ | Just (Unlit _) <- mb_phase = True
+ | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
-- note: local_opts is only required if there's no Unlit phase
| dopt Opt_Cpp dflags' = True
| dopt Opt_Pp dflags' = True
-- Error messages
-----------------------------------------------------------------------------
-noModError :: DynFlags -> Maybe FilePath -> Module -> FindResult -> IO ab
+noModError :: DynFlags -> SrcSpan -> Module -> FindResult -> IO ab
-- ToDo: we don't have a proper line number for this error
-noModError dflags cur_mod wanted_mod err
- = throwDyn $ ProgramError $ showSDoc $
- vcat [cantFindError dflags wanted_mod err,
- nest 2 (parens (pp_where cur_mod))]
+noModError dflags loc wanted_mod err
+ = throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err
-noHsFileErr cur_mod path
- = throwDyn $ CmdLineError $ showSDoc $
- vcat [text "Can't find" <+> text path,
- nest 2 (parens (pp_where cur_mod))]
+noHsFileErr loc path
+ = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
-pp_where Nothing = text "one of the roots of the dependency analysis"
-pp_where (Just p) = text "imported from" <+> text p
-
packageModErr mod
- = throwDyn (CmdLineError (showSDoc (text "module" <+>
- quotes (ppr mod) <+>
- text "is a package module")))
+ = throwDyn $ mkPlainErrMsg noSrcSpan $
+ text "module" <+> quotes (ppr mod) <+> text "is a package module"
multiRootsErr mod files
- = throwDyn (ProgramError (showSDoc (
+ = throwDyn $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+>
- sep (map text files))))
+ sep (map text files)
cyclicModuleErr :: [ModSummary] -> SDoc
cyclicModuleErr ms
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'.
data ModuleInfo = ModuleInfo {
- minf_details :: ModDetails,
- minf_rdr_env :: Maybe GlobalRdrEnv
- }
+ minf_type_env :: TypeEnv,
+ minf_exports :: NameSet,
+ minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
+ minf_instances :: [Instance]
-- 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
+ let mg = hsc_mod_graph hsc_env
+ if mdl `elem` map ms_mod mg
+ then getHomeModuleInfo hsc_env mdl
+ else do
+ if isHomeModule (hsc_dflags hsc_env) mdl
+ then return Nothing
+ else getPackageModuleInfo hsc_env mdl
+ -- getPackageModuleInfo will attempt to find the interface, so
+ -- we don't want to call it for a home module, just in case there
+ -- was a problem loading the module and the interface doesn't
+ -- exist... hence the isHomeModule test here.
+
+getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
+getPackageModuleInfo hsc_env mdl = do
+#ifdef GHCI
+ (_msgs, mb_names) <- getModuleExports hsc_env mdl
+ case mb_names of
+ Nothing -> return Nothing
+ Just names -> do
+ eps <- readIORef (hsc_EPS hsc_env)
+ let
+ pte = eps_PTE eps
+ n_list = nameSetToList names
+ tys = [ ty | name <- n_list,
+ Just ty <- [lookupTypeEnv pte name] ]
+ --
+ return (Just (ModuleInfo {
+ minf_type_env = mkTypeEnv tys,
+ minf_exports = names,
+ minf_rdr_env = Just $! nameSetToGlobalRdrEnv names mdl,
+ minf_instances = error "getModuleInfo: instances for package module unimplemented"
+ }))
+#else
+ -- bogusly different for non-GHCI (ToDo)
+ return Nothing
+#endif
+
+getHomeModuleInfo hsc_env mdl =
case lookupModuleEnv (hsc_HPT hsc_env) mdl of
Nothing -> return Nothing
- Just hmi ->
- return (Just (ModuleInfo {
- minf_details = hm_details hmi,
- minf_rdr_env = mi_globals $! hm_iface hmi
+ Just hmi -> do
+ let details = hm_details hmi
+ return (Just (ModuleInfo {
+ minf_type_env = md_types details,
+ minf_exports = md_exports details,
+ minf_rdr_env = mi_globals $! hm_iface hmi,
+ minf_instances = md_insts details
}))
- -- 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 minf = typeEnvElts (md_types (minf_details minf))
+modInfoTyThings minf = typeEnvElts (minf_type_env minf)
modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
modInfoTopLevelScope minf
= fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
modInfoExports :: ModuleInfo -> [Name]
-modInfoExports minf = nameSetToList $! (md_exports $! minf_details minf)
+modInfoExports minf = nameSetToList $! minf_exports minf
+
+-- | Returns the instances defined by the specified module.
+-- Warning: currently unimplemented for package modules.
+modInfoInstances :: ModuleInfo -> [Instance]
+modInfoInstances = minf_instances
+
+modInfoIsExportedName :: ModuleInfo -> Name -> Bool
+modInfoIsExportedName minf name = elemNameSet name (minf_exports minf)
modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified
modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf)
+modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing)
+modInfoLookupName s minf name = withSession s $ \hsc_env -> do
+ case lookupTypeEnv (minf_type_env minf) name of
+ Just tyThing -> return (Just tyThing)
+ Nothing -> do
+ eps <- readIORef (hsc_EPS hsc_env)
+ return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
+
isDictonaryId :: Id -> Bool
isDictonaryId id
= case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
-#if 0
+-- | Looks up a global name: that is, any top-level name in any
+-- visible module. Unlike 'lookupName', lookupGlobalName does not use
+-- the interactive context, and therefore does not require a preceding
+-- 'setContext'.
+lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
+lookupGlobalName s name = withSession s $ \hsc_env -> do
+ eps <- readIORef (hsc_EPS hsc_env)
+ return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
-data ObjectCode
- = ByteCode
- | BinaryCode FilePath
+-- -----------------------------------------------------------------------------
+-- Misc exported utils
--- ToDo: typechecks abstract syntax or renamed abstract syntax. Issues:
--- - typechecked syntax includes extra dictionary translation and
--- AbsBinds which need to be translated back into something closer to
--- the original source.
--- - renamed syntax currently doesn't exist in a single blob, since
--- renaming and typechecking are interleaved at splice points. We'd
--- need a restriction that there are no splices in the source module.
+dataConType :: DataCon -> Type
+dataConType dc = idType (dataConWrapId dc)
--- ToDo:
--- - Data and Typeable instances for HsSyn.
+-- | print a 'NamedThing', adding parentheses if the name is an operator.
+pprParenSymName :: NamedThing a => a -> SDoc
+pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
--- ToDo:
--- - things that aren't in the output of the renamer:
--- - the export list
--- - the imports
+-- ----------------------------------------------------------------------------
+
+#if 0
-- ToDo:
--- - things that aren't in the output of the typechecker right now:
--- - the export list
--- - the imports
--- - type signatures
--- - type/data/newtype declarations
--- - class declarations
--- - instances
--- - extra things in the typechecker's output:
--- - default methods are turned into top-level decls.
--- - dictionary bindings
+-- - Data and Typeable instances for HsSyn.
-- ToDo: check for small transformations that happen to the syntax in
-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
-- :browse will use either lm_toplev or inspect lm_interface, depending
-- on whether the module is interpreted or not.
--- various abstract syntax types (perhaps IfaceBlah)
-data Type = ...
-data Kind = ...
-
-- This is for reconstructing refactored source code
-- Calls the lexer repeatedly.
-- ToDo: add comment tokens to token stream
ic_exports = exports,
ic_rn_gbl_env = all_env } }
+-- Make a GlobalRdrEnv based on the exports of the modules only.
+mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
+mkExportEnv hsc_env mods = do
+ stuff <- mapM (getModuleExports hsc_env) mods
+ let
+ (_msgs, mb_name_sets) = unzip stuff
+ gres = [ nameSetToGlobalRdrEnv name_set mod
+ | (Just name_set, mod) <- zip mb_name_sets mods ]
+ --
+ return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
+
+nameSetToGlobalRdrEnv :: NameSet -> Module -> GlobalRdrEnv
+nameSetToGlobalRdrEnv names mod =
+ mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod }
+ | name <- nameSetToList names ]
+
+vanillaProv :: Module -> Provenance
+-- We're building a GlobalRdrEnv as if the user imported
+-- all the specified modules into the global interactive module
+vanillaProv mod = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
+ where
+ decl = ImpDeclSpec { is_mod = mod, is_as = mod,
+ is_qual = False,
+ is_dloc = srcLocSpan interactiveSrcLoc }
+
checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO ()
checkModuleExists hsc_env hpt mod =
case lookupModuleEnv hpt mod of
_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
+getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
+getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
-- | Returns all names in scope in the current interactive context
getNamesInScope :: Session -> IO [Name]
getNamesInScope s = withSession s $ \hsc_env -> do
return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
+-- | 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
+
+-- | 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 -> tcRnLookupName hsc_env name
+
-- -----------------------------------------------------------------------------
-- Getting the type of an expression
Just ty -> return (Just tidy_ty)
where
tidy_ty = tidyType emptyTidyEnv ty
- dflags = hsc_dflags hsc_env
-- -----------------------------------------------------------------------------
-- Getting the kind of a type
-- more informative than the C type!
-}
--- ---------------------------------------------------------------------------
--- 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
- case mb_decls of
- Nothing -> return [] -- An error of some kind
- Just ds -> return ds
-
-
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
projects / ghc-hetmet.git / blobdiff