compileCoreToObj,
getModSummary,
- -- * Parsing Haddock comments
- parseHaddockComment,
-
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
getModuleGraph,
-- * Interactive evaluation
getBindings, getPrintUnqual,
findModule,
+ lookupModule,
#ifdef GHCI
setContext, getContext,
getNamesInScope,
typeKind,
parseName,
RunResult(..),
- runStmt, SingleStep(..),
+ runStmt, parseImportDecl, SingleStep(..),
resume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
resumeHistory, resumeHistoryIx),
showModule,
isModuleInterpreted,
InteractiveEval.compileExpr, HValue, dynCompileExpr,
- lookupName,
GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
BreakArray, setBreakOn, setBreakOff, getBreak,
#endif
+ lookupName,
-- * Abstract syntax elements
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
- isOpenTyCon,
+ isFamilyTyCon,
synTyConDefn, synTyConType, synTyConResKind,
-- ** Type variables
-- ** Data constructors
DataCon,
dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
- dataConIsInfix, isVanillaDataCon,
+ dataConIsInfix, isVanillaDataCon, dataConUserType,
dataConStrictMarks,
StrictnessMark(..), isMarkedStrict,
pprParendType, pprTypeApp,
Kind,
PredType,
- ThetaType, pprThetaArrow,
+ ThetaType, pprForAll, pprThetaArrow,
-- ** Entities
TyThing(..),
import Linker ( HValue )
import ByteCodeInstr
import BreakArray
-import NameSet
import InteractiveEval
-import TcRnDriver
#endif
+import TcRnDriver
import TcIface
-import TcRnTypes hiding (LIE)
+import TcRnTypes
import TcRnMonad ( initIfaceCheck )
import Packages
import NameSet
import RdrName
import qualified HsSyn -- hack as we want to reexport the whole module
import HsSyn hiding ((<.>))
-import Type hiding (typeKind)
-import TcType hiding (typeKind)
+import Type
+import Coercion ( synTyConResKind )
+import TcType hiding( typeKind )
import Id
import Var
import TysPrim ( alphaTyVars )
import TyCon
import Class
-import FunDeps
+-- import FunDeps
import DataCon
import Name hiding ( varName )
-import OccName ( parenSymOcc )
+-- import OccName ( parenSymOcc )
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
emptyInstEnv )
import FamInstEnv ( emptyFamInstEnv )
--import CoreSyn
import TidyPgm
import DriverPipeline
-import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
+import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import HeaderInfo
import Finder
import HscMain
cleanTempDirs )
import Annotations
import Module
-import LazyUniqFM
-import qualified UniqFM as UFM
-import UniqSet
-import Unique
-import FiniteMap
+import UniqFM
import Panic
import Digraph
import Bag ( unitBag, listToBag, emptyBag, isEmptyBag )
import Outputable
import BasicTypes
import Maybes ( expectJust, mapCatMaybes )
-import HaddockParse
-import HaddockLex ( tokenise )
import FastString
import Lexer
-import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist,
getCurrentDirectory )
import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map
import Data.List
import qualified Data.List as List
import Data.Typeable ( Typeable )
Just (ioe :: IOException) ->
fatalErrorMsg dflags (text (show ioe))
_ -> case fromException exception of
+ Just UserInterrupt -> exitWith (ExitFailure 1)
Just StackOverflow ->
fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
_ -> case fromException exception of
hFlush stdout
case ge of
PhaseFailed _ code -> exitWith code
- Interrupted -> exitWith (ExitFailure 1)
+ Signal _ -> exitWith (ExitFailure 1)
_ -> do fatalErrorMsg dflags (text (show ge))
exitWith (ExitFailure 1)
) $
DynFlags -> m a -> m a
defaultCleanupHandler dflags inner =
-- make sure we clean up after ourselves
- inner `gonException`
+ inner `gfinally`
(liftIO $ do
cleanTempFiles dflags
cleanTempDirs dflags
initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
initGhcMonad mb_top_dir = do
-- catch ^C
- main_thread <- liftIO $ myThreadId
- liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :))
liftIO $ installSignalHandlers
liftIO $ StaticFlags.initStaticOpts
hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
-- -----------------------------------------------------------------------------
--- Parsing Haddock comments
-
-parseHaddockComment :: String -> Either String (HsDoc RdrName)
-parseHaddockComment string =
- case parseHaddockParagraphs (tokenise string) of
- MyLeft x -> Left x
- MyRight x -> Right x
-
--- -----------------------------------------------------------------------------
-- Loading the program
-- | Perform a dependency analysis starting from the current targets
(flattenSCCs mg2_with_srcimps)
stable_mods
- liftIO $ evaluate pruned_hpt
+ _ <- liftIO $ evaluate pruned_hpt
-- before we unload anything, make sure we don't leave an old
-- interactive context around pointing to dead bindings. Also,
let
main_mod = mainModIs dflags
a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
- do_linking = a_root_is_Main || no_hs_main
+ do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib
when (ghcLink dflags == LinkBinary
&& isJust ofile && not do_linking) $
type ParsedSource = Located (HsModule RdrName)
type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
- Maybe (HsDoc Name), HaddockModInfo Name)
+ Maybe LHsDocString)
type TypecheckedSource = LHsBinds Id
-- NOTE:
loadModule tcm = do
let ms = modSummary tcm
let mod = ms_mod_name ms
+ let loc = ms_location ms
let (tcg, _details) = tm_internals tcm
hpt_new <-
withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do
let compilerBackend comp env ms' _ _mb_old_iface _ =
withTempSession (\_ -> env) $
- hscBackend comp tcg ms'
- Nothing
+ hscBackend comp tcg ms' Nothing
+
hsc_env <- getSession
- mod_info
- <- compile' (compilerBackend hscNothingCompiler
- ,compilerBackend hscInteractiveCompiler
- ,compilerBackend hscBatchCompiler)
- hsc_env ms 1 1 Nothing Nothing
+ mod_info <- do
+ mb_linkable <-
+ case ms_obj_date ms of
+ Just t | t > ms_hs_date ms -> do
+ l <- liftIO $ findObjectLinkable (ms_mod ms)
+ (ml_obj_file loc) t
+ return (Just l)
+ _otherwise -> return Nothing
+
+ compile' (compilerBackend hscNothingCompiler
+ ,compilerBackend hscInteractiveCompiler
+ ,hscCheckRecompBackend hscBatchCompiler tcg)
+ hsc_env ms 1 1 Nothing mb_linkable
-- compile' shouldn't change the environment
return $ addToUFM (hsc_HPT hsc_env) mod mod_info
modifySession $ \e -> e{ hsc_HPT = hpt_new }
return tcm
+
-- | This is the way to get access to the Core bindings corresponding
-- to a module. 'compileToCore' parses, typechecks, and
-- desugars the module, then returns the resulting Core module (consisting of
(iface, changed, _details, cgguts)
<- hscNormalIface guts Nothing
hscWriteIface iface changed modSummary
- hscGenHardCode cgguts modSummary
+ _ <- hscGenHardCode cgguts modSummary
return ()
-- Makes a "vanilla" ModGuts.
-- First, set the target to the desired filename
target <- guessTarget fn Nothing
addTarget target
- load LoadAllTargets
+ _ <- load LoadAllTargets
-- Then find dependencies
modGraph <- depanal [] True
case find ((== fn) . msHsFilePath) modGraph of
numbered_summaries = zip summaries [1..]
lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
- lookup_node hs_src mod = lookupFM node_map (mod, hs_src)
+ lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map
lookup_key :: HscSource -> ModuleName -> Maybe Int
lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
node_map :: NodeMap SummaryNode
- node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node)
- | node@(s, _, _) <- nodes ]
+ node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)
+ | node@(s, _, _) <- nodes ]
-- We use integers as the keys for the SCC algorithm
nodes :: [SummaryNode]
type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
-type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs
+type NodeMap a = Map NodeKey a -- keyed by (mod, src_file_type) pairs
msKey :: ModSummary -> NodeKey
msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
-mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries]
+mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
nodeMapElts :: NodeMap a -> [a]
-nodeMapElts = eltsFM
+nodeMapElts = Map.elems
-- | If there are {-# SOURCE #-} imports between strongly connected
-- components in the topological sort, then those imports can
-- for those mentioned in the visited set
loop [] done = return (concat (nodeMapElts done))
loop ((wanted_mod, is_boot) : ss) done
- | Just summs <- lookupFM done key
+ | Just summs <- Map.lookup key done
= if isSingleton summs then
loop ss done
else
Nothing excl_mods
case mb_s of
Nothing -> loop ss done
- Just s -> loop (msDeps s ++ ss) (addToFM done key [s])
+ Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done)
where
key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
+-- XXX Does the (++) here need to be flipped?
mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
-mkRootMap summaries = addListToFM_C (++) emptyFM
- [ (msKey s, [s]) | s <- summaries ]
+mkRootMap summaries = Map.insertListWith (flip (++))
+ [ (msKey s, [s]) | s <- summaries ]
+ Map.empty
msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
-- (msDeps s) returns the dependencies of the ModSummary s.
++ [ (m,False) | m <- ms_home_imps s ]
home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
-home_imps imps = [ ideclName i | L _ i <- imps, isNothing (ideclPkgQual i) ]
+home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ]
+ where isLocal Nothing = True
+ isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
+ isLocal _ = False
ms_home_allimps :: ModSummary -> [ModuleName]
ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
| wanted_mod `elem` excl_mods
= return Nothing
- | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src)
+ | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map
= do -- Find its new timestamp; all the
-- ModSummaries in the old map have valid ml_hs_files
let location = ms_location old_summary
| 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
+ | xopt Opt_Cpp dflags' = True
| dopt Opt_Pp dflags' = True
| otherwise = False
= hang (ptext (sLit "Module imports form a cycle for modules:"))
2 (vcat (map show_one ms))
where
- show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms),
- nest 2 $ ptext (sLit "imports:") <+>
- (pp_imps HsBootFile (ms_srcimps ms)
- $$ pp_imps HsSrcFile (ms_imps ms))]
+ mods_in_cycle = map ms_mod_name ms
+ imp_modname = unLoc . ideclName . unLoc
+ just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)
+
+ show_one ms =
+ vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>
+ maybe empty (parens . text) (ml_hs_file (ms_location ms)),
+ nest 2 $ ptext (sLit "imports:") <+> vcat [
+ pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),
+ pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ]
+ ]
show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
- pp_imps src mods = fsep (map (show_mod src) mods)
+ pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)
-- | Inform GHC that the working directory has changed. GHC will flush
-- its cache of module locations, since it may no longer be valid.
--- Note: if you change the working directory, you should also unload
--- the current program (set targets to empty, followed by load).
+--
+-- Note: Before changing the working directory make sure all threads running
+-- in the same session have stopped. If you change the working directory,
+-- you should also unload the current program (set targets to empty,
+-- followed by load).
workingDirectoryChanged :: GhcMonad m => m ()
workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
-- have Template Haskell enabled whether it is actually needed or not.
needsTemplateHaskell :: ModuleGraph -> Bool
needsTemplateHaskell ms =
- any (dopt Opt_TemplateHaskell . ms_hspp_opts) ms
+ any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms
-- | Return @True@ <==> module is loaded.
isLoaded :: GhcMonad m => ModuleName -> m Bool
-- we have to implement the shadowing behaviour of ic_tmp_ids here
-- (see InteractiveContext) and the quickest way is to use an OccEnv.
let
- tmp_ids = ic_tmp_ids (hsc_IC hsc_env)
- filtered = foldr f (const []) tmp_ids emptyUniqSet
- f id rest set
- | uniq `elementOfUniqSet` set = rest set
- | otherwise = AnId id : rest (addOneToUniqSet set uniq)
- where uniq = getUnique (nameOccName (idName id))
+ occ_env = mkOccEnv [ (nameOccName (idName id), AnId id)
+ | id <- ic_tmp_ids (hsc_IC hsc_env) ]
in
- return filtered
+ return (occEnvElts occ_env)
getPrintUnqual :: GhcMonad m => m PrintUnqualified
getPrintUnqual = withSession $ \hsc_env ->
return (Just (ModuleInfo {
minf_type_env = mkTypeEnv tys,
minf_exports = names,
- minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
+ minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
minf_instances = error "getModuleInfo: instances for package module unimplemented",
minf_modBreaks = emptyModBreaks
}))
-> m [Module]
packageDbModules only_exposed = do
dflags <- getSessionDynFlags
- let pkgs = UFM.eltsUFM (pkgIdMap (pkgState dflags))
+ let pkgs = eltsUFM (pkgIdMap (pkgState dflags))
return $
[ mkModule pid modname | p <- pkgs
, not only_exposed || exposed p
- , pid <- [mkPackageId (package p)]
+ , let pid = packageConfigId p
, modname <- exposedModules p ]
-- -----------------------------------------------------------------------------
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
- let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
+ let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
getRichTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
- let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0
+ let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
showRichTokenStream :: [(Located Token, String)] -> String
showRichTokenStream ts = go startLoc ts ""
where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
- startLoc = mkSrcLoc sourceFile 0 0
+ startLoc = mkSrcLoc sourceFile 1 1
go _ [] = id
go loc ((L span _, str):ts)
| not (isGoodSrcSpan span) = go loc ts
-- filesystem and package database to find the corresponding 'Module',
-- using the algorithm that is used for an @import@ declaration.
findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
-findModule mod_name maybe_pkg = withSession $ \hsc_env -> liftIO $ -- XXX
- let
- dflags = hsc_dflags hsc_env
- hpt = hsc_HPT hsc_env
- this_pkg = thisPackage dflags
- in
- case lookupUFM hpt mod_name of
- Just mod_info -> return (mi_module (hm_iface mod_info))
- _not_a_home_module -> do
- res <- findImportedModule hsc_env mod_name maybe_pkg
- case res of
- Found _ m | modulePackageId m /= this_pkg -> return m
- | otherwise -> ghcError (CmdLineError (showSDoc $
- text "module" <+> quotes (ppr (moduleName m)) <+>
- text "is not loaded"))
- err -> let msg = cannotFindModule dflags mod_name err in
- ghcError (CmdLineError (showSDoc msg))
+findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
+ let
+ dflags = hsc_dflags hsc_env
+ this_pkg = thisPackage dflags
+ --
+ case maybe_pkg of
+ Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
+ res <- findImportedModule hsc_env mod_name maybe_pkg
+ case res of
+ Found _ m -> return m
+ err -> noModError dflags noSrcSpan mod_name err
+ _otherwise -> do
+ home <- lookupLoadedHomeModule mod_name
+ case home of
+ Just m -> return m
+ Nothing -> liftIO $ do
+ res <- findImportedModule hsc_env mod_name maybe_pkg
+ case res of
+ Found loc m | modulePackageId m /= this_pkg -> return m
+ | otherwise -> modNotLoadedError m loc
+ err -> noModError dflags noSrcSpan mod_name err
+
+modNotLoadedError :: Module -> ModLocation -> IO a
+modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $
+ text "module is not loaded:" <+>
+ quotes (ppr (moduleName m)) <+>
+ parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
+
+-- | Like 'findModule', but differs slightly when the module refers to
+-- a source file, and the file has not been loaded via 'load'. In
+-- this case, 'findModule' will throw an error (module not loaded),
+-- but 'lookupModule' will check to see whether the module can also be
+-- found in a package, and if so, that package 'Module' will be
+-- returned. If not, the usual module-not-found error will be thrown.
+--
+lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
+lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
+lookupModule mod_name Nothing = withSession $ \hsc_env -> do
+ home <- lookupLoadedHomeModule mod_name
+ case home of
+ Just m -> return m
+ Nothing -> liftIO $ do
+ res <- findExposedPackageModule hsc_env mod_name Nothing
+ case res of
+ Found _ m -> return m
+ err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
+
+lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
+lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
+ case lookupUFM (hsc_HPT hsc_env) mod_name of
+ Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
+ _not_a_home_module -> return Nothing
#ifdef GHCI
getHistorySpan :: GhcMonad m => History -> m SrcSpan
liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
#endif
+
+-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
+-- entity known to GHC, including 'Name's defined using 'runStmt'.
+lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
+lookupName name = withSession $ \hsc_env -> do
+ mb_tything <- ioMsg $ tcRnLookupName hsc_env name
+ return mb_tything
+ -- XXX: calls panic in some circumstances; is that ok?
+
projects / ghc-hetmet.git / blobdiff