compileCoreToObj,
getModSummary,
- -- * Parsing Haddock comments
- parseHaddockComment,
-
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
getModuleGraph,
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 ByteCodeInstr
import BreakArray
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 )
cleanTempDirs )
import Annotations
import Module
-import LazyUniqFM
-import qualified UniqFM as UFM
+import UniqFM
import FiniteMap
import Panic
import Digraph
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
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)
) $
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
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
++ [ (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)
= 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)
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
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
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