summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/DriverPipeline.hs15
-rw-r--r--compiler/main/DynFlags.hs39
-rw-r--r--compiler/main/GHC.hs444
-rw-r--r--compiler/main/GhcMonad.hs9
-rw-r--r--compiler/main/HscMain.hs193
-rw-r--r--compiler/main/InteractiveEval.hs177
6 files changed, 459 insertions, 418 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 2230f3fa40..0e8990777b 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -137,10 +137,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler)
-- We add the directory in which the .hs files resides) to the import path.
-- This is needed when we try to compile the .hc file later, if it
-- imports a _stub.h file that we created here.
- let current_dir = case takeDirectory basename of
- "" -> "." -- XXX Hack required for filepath-1.1 and earlier
- -- (GHC 6.12 and earlier)
- d -> d
+ let current_dir = takeDirectory basename
old_paths = includePaths dflags0
dflags = dflags0 { includePaths = current_dir : old_paths }
hsc_env = hsc_env0 {hsc_dflags = dflags}
@@ -598,8 +595,8 @@ getPipeEnv = P $ \env state -> return (state, env)
getPipeState :: CompPipeline PipeState
getPipeState = P $ \_env state -> return (state, state)
-getDynFlags :: CompPipeline DynFlags
-getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
+instance HasDynFlags CompPipeline where
+ getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
setDynFlags :: DynFlags -> CompPipeline ()
setDynFlags dflags = P $ \_env state ->
@@ -849,11 +846,7 @@ runPhase (Hsc src_flavour) input_fn dflags0
-- we add the current directory (i.e. the directory in which
-- the .hs files resides) to the include path, since this is
-- what gcc does, and it's probably what you want.
- let current_dir = case takeDirectory basename of
- "" -> "." -- XXX Hack required for filepath-1.1 and earlier
- -- (GHC 6.12 and earlier)
- d -> d
-
+ let current_dir = takeDirectory basename
paths = includePaths dflags0
dflags = dflags0 { includePaths = current_dir : paths }
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index de844ea3b5..1bd4fcef8a 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -29,6 +29,7 @@ module DynFlags (
xopt_set,
xopt_unset,
DynFlags(..),
+ HasDynFlags(..),
RtsOptsEnabled(..),
HscTarget(..), isObjectTarget, defaultObjectTarget,
GhcMode(..), isOneShot,
@@ -563,11 +564,12 @@ data DynFlags = DynFlags {
language :: Maybe Language,
-- | Safe Haskell mode
safeHaskell :: SafeHaskellMode,
- -- We store the location of where template haskell and newtype deriving were
- -- turned on so we can produce accurate error messages when Safe Haskell turns
- -- them off.
+ -- We store the location of where some extension and flags were turned on so
+ -- we can produce accurate error messages when Safe Haskell fails due to
+ -- them.
thOnLoc :: SrcSpan,
newDerivOnLoc :: SrcSpan,
+ pkgTrustOnLoc :: SrcSpan,
warnSafeOnLoc :: SrcSpan,
warnUnsafeOnLoc :: SrcSpan,
-- Don't change this without updating extensionFlags:
@@ -585,6 +587,9 @@ data DynFlags = DynFlags {
profAuto :: ProfAuto
}
+class HasDynFlags m where
+ getDynFlags :: m DynFlags
+
data ProfAuto
= NoProfAuto -- ^ no SCC annotations added
| ProfAutoAll -- ^ top-level and nested functions are annotated
@@ -907,6 +912,7 @@ defaultDynFlags mySettings =
safeHaskell = Sf_SafeInfered,
thOnLoc = noSrcSpan,
newDerivOnLoc = noSrcSpan,
+ pkgTrustOnLoc = noSrcSpan,
warnSafeOnLoc = noSrcSpan,
warnUnsafeOnLoc = noSrcSpan,
extensions = [],
@@ -1302,19 +1308,28 @@ parseDynamicFlags dflags0 args cmdline = do
when (not (null errs)) $ ghcError $ errorsToGhcException errs
-- check for disabled flags in safe haskell
- let (dflags2, sh_warns) = safeFlagCheck dflags1
+ let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1
return (dflags2, leftover, sh_warns ++ warns)
-- | Check (and potentially disable) any extensions that aren't allowed
-- in safe mode.
-safeFlagCheck :: DynFlags -> (DynFlags, [Located String])
-safeFlagCheck dflags | not (safeLanguageOn dflags || safeInferOn dflags)
- = (dflags, [])
-safeFlagCheck dflags =
+safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String])
+safeFlagCheck _ dflags | not (safeLanguageOn dflags || safeInferOn dflags)
+ = (dflags, [])
+
+safeFlagCheck cmdl dflags =
case safeLanguageOn dflags of
True -> (dflags', warns)
+ -- throw error if -fpackage-trust by itself with no safe haskell flag
+ False | not cmdl && safeInferOn dflags && packageTrustOn dflags
+ -> (dopt_unset dflags' Opt_PackageTrust,
+ [L (pkgTrustOnLoc dflags') $
+ "Warning: -fpackage-trust ignored;" ++
+ " must be specified with a Safe Haskell flag"]
+ )
+
False | null warns && safeInfOk
-> (dflags', [])
@@ -1660,7 +1675,7 @@ dynamic_flags = [
, Flag "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead"))
------ Safe Haskell flags -------------------------------------------
- , Flag "fpackage-trust" (NoArg (setDynFlag Opt_PackageTrust))
+ , Flag "fpackage-trust" (NoArg setPackageTrust)
, Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None))
]
++ map (mkFlag turnOn "f" setDynFlag ) fFlags
@@ -2173,6 +2188,12 @@ setWarnUnsafe :: Bool -> DynP ()
setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l })
setWarnUnsafe False = return ()
+setPackageTrust :: DynP ()
+setPackageTrust = do
+ setDynFlag Opt_PackageTrust
+ l <- getCurLoc
+ upd $ \d -> d { pkgTrustOnLoc = l }
+
setGenDeriving :: Bool -> DynP ()
setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })
setGenDeriving False = return ()
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 9665c60f2f..df670f1d63 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -6,17 +6,10 @@
--
-- -----------------------------------------------------------------------------
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module GHC (
- -- * Initialisation
- defaultErrorHandler,
- defaultCleanupHandler,
+ -- * Initialisation
+ defaultErrorHandler,
+ defaultCleanupHandler,
-- * GHC Monad
Ghc, GhcT, GhcMonad(..), HscEnv,
@@ -27,31 +20,31 @@ module GHC (
handleSourceError,
needsTemplateHaskell,
- -- * Flags and settings
- DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
+ -- * Flags and settings
+ DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
GhcMode(..), GhcLink(..), defaultObjectTarget,
- parseDynamicFlags,
- getSessionDynFlags,
- setSessionDynFlags,
- parseStaticFlags,
-
- -- * Targets
- Target(..), TargetId(..), Phase,
- setTargets,
- getTargets,
- addTarget,
- removeTarget,
- guessTarget,
-
- -- * Loading\/compiling the program
- depanal,
+ parseDynamicFlags,
+ getSessionDynFlags,
+ setSessionDynFlags,
+ parseStaticFlags,
+
+ -- * Targets
+ Target(..), TargetId(..), Phase,
+ setTargets,
+ getTargets,
+ addTarget,
+ removeTarget,
+ guessTarget,
+
+ -- * Loading\/compiling the program
+ depanal,
load, LoadHowMuch(..), InteractiveImport(..),
- SuccessFlag(..), succeeded, failed,
+ SuccessFlag(..), succeeded, failed,
defaultWarnErrLogger, WarnErrLogger,
- workingDirectoryChanged,
+ workingDirectoryChanged,
parseModule, typecheckModule, desugarModule, loadModule,
ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
- TypecheckedSource, ParsedSource, RenamedSource, -- ditto
+ TypecheckedSource, ParsedSource, RenamedSource, -- ditto
TypecheckedMod, ParsedMod,
moduleInfo, renamedSource, typecheckedSource,
parsedSource, coreModule,
@@ -61,50 +54,50 @@ module GHC (
compileToCoreModule, compileToCoreSimplified,
compileCoreToObj,
- -- * Inspecting the module structure of the program
- ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
+ -- * Inspecting the module structure of the program
+ ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
getModSummary,
getModuleGraph,
- isLoaded,
- topSortModuleGraph,
-
- -- * Inspecting modules
- ModuleInfo,
- getModuleInfo,
- modInfoTyThings,
- modInfoTopLevelScope,
+ isLoaded,
+ topSortModuleGraph,
+
+ -- * Inspecting modules
+ ModuleInfo,
+ getModuleInfo,
+ modInfoTyThings,
+ modInfoTopLevelScope,
modInfoExports,
- modInfoInstances,
- modInfoIsExportedName,
- modInfoLookupName,
+ modInfoInstances,
+ modInfoIsExportedName,
+ modInfoLookupName,
modInfoIface,
- lookupGlobalName,
- findGlobalAnns,
+ lookupGlobalName,
+ findGlobalAnns,
mkPrintUnqualifiedForModule,
ModIface(..),
-- * Querying the environment
packageDbModules,
- -- * Printing
- PrintUnqualified, alwaysQualify,
+ -- * Printing
+ PrintUnqualified, alwaysQualify,
- -- * Interactive evaluation
- getBindings, getInsts, getPrintUnqual,
- findModule,
- lookupModule,
+ -- * Interactive evaluation
+ getBindings, getInsts, getPrintUnqual,
+ findModule, lookupModule,
#ifdef GHCI
- setContext, getContext,
- getNamesInScope,
- getRdrNamesInScope,
+ isModuleTrusted,
+ setContext, getContext,
+ getNamesInScope,
+ getRdrNamesInScope,
getGRE,
- moduleIsInterpreted,
- getInfo,
- exprType,
- typeKind,
- parseName,
- RunResult(..),
- runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
+ moduleIsInterpreted,
+ getInfo,
+ exprType,
+ typeKind,
+ parseName,
+ RunResult(..),
+ runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
parseImportDecl, SingleStep(..),
resume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
@@ -115,9 +108,9 @@ module GHC (
abandon, abandonAll,
InteractiveEval.back,
InteractiveEval.forward,
- showModule,
+ showModule,
isModuleInterpreted,
- InteractiveEval.compileExpr, HValue, dynCompileExpr,
+ InteractiveEval.compileExpr, HValue, dynCompileExpr,
GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
@@ -126,106 +119,106 @@ module GHC (
#endif
lookupName,
- -- * Abstract syntax elements
+ -- * Abstract syntax elements
-- ** Packages
PackageId,
- -- ** Modules
- Module, mkModule, pprModule, moduleName, modulePackageId,
+ -- ** Modules
+ Module, mkModule, pprModule, moduleName, modulePackageId,
ModuleName, mkModuleName, moduleNameString,
- -- ** Names
- Name,
- isExternalName, nameModule, pprParenSymName, nameSrcSpan,
- NamedThing(..),
- RdrName(Qual,Unqual),
-
- -- ** Identifiers
- Id, idType,
- isImplicitId, isDeadBinder,
- isExportedId, isLocalId, isGlobalId,
- isRecordSelector,
- isPrimOpId, isFCallId, isClassOpId_maybe,
- isDataConWorkId, idDataCon,
- isBottomingId, isDictonaryId,
- recordSelectorFieldLabel,
-
- -- ** Type constructors
- TyCon,
- tyConTyVars, tyConDataCons, tyConArity,
- isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
- isFamilyTyCon, tyConClass_maybe,
- synTyConDefn, synTyConType, synTyConResKind,
-
- -- ** Type variables
- TyVar,
- alphaTyVars,
-
- -- ** Data constructors
- DataCon,
- dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
- dataConIsInfix, isVanillaDataCon, dataConUserType,
- dataConStrictMarks,
- StrictnessMark(..), isMarkedStrict,
-
- -- ** Classes
- Class,
- classMethods, classSCTheta, classTvsFds, classATs,
- pprFundeps,
-
- -- ** Instances
- Instance,
- instanceDFunId,
+ -- ** Names
+ Name,
+ isExternalName, nameModule, pprParenSymName, nameSrcSpan,
+ NamedThing(..),
+ RdrName(Qual,Unqual),
+
+ -- ** Identifiers
+ Id, idType,
+ isImplicitId, isDeadBinder,
+ isExportedId, isLocalId, isGlobalId,
+ isRecordSelector,
+ isPrimOpId, isFCallId, isClassOpId_maybe,
+ isDataConWorkId, idDataCon,
+ isBottomingId, isDictonaryId,
+ recordSelectorFieldLabel,
+
+ -- ** Type constructors
+ TyCon,
+ tyConTyVars, tyConDataCons, tyConArity,
+ isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
+ isFamilyTyCon, tyConClass_maybe,
+ synTyConDefn, synTyConType, synTyConResKind,
+
+ -- ** Type variables
+ TyVar,
+ alphaTyVars,
+
+ -- ** Data constructors
+ DataCon,
+ dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
+ dataConIsInfix, isVanillaDataCon, dataConUserType,
+ dataConStrictMarks,
+ StrictnessMark(..), isMarkedStrict,
+
+ -- ** Classes
+ Class,
+ classMethods, classSCTheta, classTvsFds, classATs,
+ pprFundeps,
+
+ -- ** Instances
+ Instance,
+ instanceDFunId,
pprInstance, pprInstanceHdr,
pprFamInst, pprFamInstHdr,
- -- ** Types and Kinds
- Type, splitForAllTys, funResultTy,
- pprParendType, pprTypeApp,
- Kind,
- PredType,
- ThetaType, pprForAll, pprThetaArrowTy,
+ -- ** Types and Kinds
+ Type, splitForAllTys, funResultTy,
+ pprParendType, pprTypeApp,
+ Kind,
+ PredType,
+ ThetaType, pprForAll, pprThetaArrowTy,
- -- ** Entities
- TyThing(..),
+ -- ** Entities
+ TyThing(..),
- -- ** Syntax
- module HsSyn, -- ToDo: remove extraneous bits
+ -- ** Syntax
+ module HsSyn, -- ToDo: remove extraneous bits
- -- ** Fixities
- FixityDirection(..),
- defaultFixity, maxPrecedence,
- negateFixity,
- compareFixity,
+ -- ** Fixities
+ FixityDirection(..),
+ defaultFixity, maxPrecedence,
+ negateFixity,
+ compareFixity,
- -- ** Source locations
- SrcLoc(..), RealSrcLoc,
+ -- ** Source locations
+ SrcLoc(..), RealSrcLoc,
mkSrcLoc, noSrcLoc,
- srcLocFile, srcLocLine, srcLocCol,
+ srcLocFile, srcLocLine, srcLocCol,
SrcSpan(..), RealSrcSpan,
mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
srcSpanStart, srcSpanEnd,
- srcSpanFile,
+ srcSpanFile,
srcSpanStartLine, srcSpanEndLine,
srcSpanStartCol, srcSpanEndCol,
-- ** Located
- GenLocated(..), Located,
+ GenLocated(..), Located,
- -- *** Constructing Located
- noLoc, mkGeneralLocated,
+ -- *** Constructing Located
+ noLoc, mkGeneralLocated,
- -- *** Deconstructing Located
- getLoc, unLoc,
+ -- *** Deconstructing Located
+ getLoc, unLoc,
- -- *** Combining and comparing Located values
- eqLocated, cmpLocated, combineLocs, addCLoc,
+ -- *** Combining and comparing Located values
+ eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost,
spans, isSubspanOf,
- -- * Exceptions
- GhcException(..), showGhcException,
+ -- * Exceptions
+ GhcException(..), showGhcException,
-- * Token stream manipulations
Token,
@@ -235,9 +228,9 @@ module GHC (
-- * Pure interface to the parser
parser,
- -- * Miscellaneous
- --sessionHscEnv,
- cyclicModuleErr,
+ -- * Miscellaneous
+ --sessionHscEnv,
+ cyclicModuleErr,
) where
{-
@@ -258,7 +251,7 @@ import InteractiveEval
import HscMain
import GhcMake
-import DriverPipeline ( compile' )
+import DriverPipeline ( compile' )
import GhcMonad
import TcRnTypes
import Packages
@@ -267,10 +260,10 @@ import RdrName
import qualified HsSyn -- hack as we want to reexport the whole module
import HsSyn
import Type hiding( typeKind )
-import Kind ( synTyConResKind )
-import TcType hiding( typeKind )
+import Kind ( synTyConResKind )
+import TcType hiding( typeKind )
import Id
-import TysPrim ( alphaTyVars )
+import TysPrim ( alphaTyVars )
import TyCon
import Class
import DataCon
@@ -292,26 +285,26 @@ import Annotations
import Module
import UniqFM
import Panic
-import Bag ( unitBag )
+import Bag ( unitBag )
import ErrUtils
import MonadUtils
import Util
import StringBuffer
import Outputable
import BasicTypes
-import Maybes ( expectJust )
+import Maybes ( expectJust )
import FastString
import qualified Parser
import Lexer
import System.Directory ( doesFileExist, getCurrentDirectory )
import Data.Maybe
-import Data.List ( find )
+import Data.List ( find )
import Data.Typeable ( Typeable )
import Data.Word ( Word8 )
import Control.Monad
-import System.Exit ( exitWith, ExitCode(..) )
-import System.Time ( getClockTime )
+import System.Exit ( exitWith, ExitCode(..) )
+import System.Time ( getClockTime )
import Exception
import Data.IORef
import System.FilePath
@@ -320,9 +313,9 @@ import Prelude hiding (init)
-- %************************************************************************
--- %* *
+-- %* *
-- Initialisation: exception handlers
--- %* *
+-- %* *
-- %************************************************************************
@@ -340,7 +333,7 @@ defaultErrorHandler la inner =
Just (ioe :: IOException) ->
fatalErrorMsg' la (text (show ioe))
_ -> case fromException exception of
- Just UserInterrupt -> exitWith (ExitFailure 1)
+ Just UserInterrupt -> exitWith (ExitFailure 1)
Just StackOverflow ->
fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it")
_ -> case fromException exception of
@@ -354,13 +347,13 @@ defaultErrorHandler la inner =
-- error messages propagated as exceptions
handleGhcException
(\ge -> liftIO $ do
- hFlush stdout
- case ge of
- PhaseFailed _ code -> exitWith code
- Signal _ -> exitWith (ExitFailure 1)
- _ -> do fatalErrorMsg' la (text (show ge))
- exitWith (ExitFailure 1)
- ) $
+ hFlush stdout
+ case ge of
+ PhaseFailed _ code -> exitWith code
+ Signal _ -> exitWith (ExitFailure 1)
+ _ -> do fatalErrorMsg' la (text (show ge))
+ exitWith (ExitFailure 1)
+ ) $
inner
-- | Install a default cleanup handler to remove temporary files deposited by
@@ -382,9 +375,9 @@ defaultCleanupHandler dflags inner =
-- %************************************************************************
--- %* *
+-- %* *
-- The Ghc Monad
--- %* *
+-- %* *
-- %************************************************************************
-- | Run function for the 'Ghc' monad.
@@ -450,9 +443,9 @@ initGhcMonad mb_top_dir = do
-- %************************************************************************
--- %* *
+-- %* *
-- Flags & settings
--- %* *
+-- %* *
-- %************************************************************************
-- | Updates the DynFlags in a Session. This also reads
@@ -480,9 +473,9 @@ parseDynamicFlags = parseDynamicFlagsCmdLine
-- %************************************************************************
--- %* *
+-- %* *
-- Setting, getting, and modifying the targets
--- %* *
+-- %* *
-- %************************************************************************
-- ToDo: think about relative vs. absolute file paths. And what
@@ -530,13 +523,13 @@ guessTarget str Nothing
= return (target (TargetFile file Nothing))
| otherwise
= do exists <- liftIO $ doesFileExist hs_file
- if exists
- then return (target (TargetFile hs_file Nothing))
- else do
- exists <- liftIO $ doesFileExist lhs_file
- if exists
- then return (target (TargetFile lhs_file Nothing))
- else do
+ if exists
+ then return (target (TargetFile hs_file Nothing))
+ else do
+ exists <- liftIO $ doesFileExist lhs_file
+ if exists
+ then return (target (TargetFile lhs_file Nothing))
+ else do
if looksLikeModuleName file
then return (target (TargetModule (mkModuleName file)))
else do
@@ -549,8 +542,8 @@ guessTarget str Nothing
| '*':rest <- str = (rest, False)
| otherwise = (str, True)
- hs_file = file <.> "hs"
- lhs_file = file <.> "lhs"
+ hs_file = file <.> "hs"
+ lhs_file = file <.> "lhs"
target tid = Target tid obj_allowed Nothing
@@ -567,9 +560,9 @@ workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
-- %************************************************************************
--- %* *
+-- %* *
-- Running phases one at a time
--- %* *
+-- %* *
-- %************************************************************************
class ParsedMod m where
@@ -581,11 +574,11 @@ class ParsedMod m => TypecheckedMod m where
typecheckedSource :: m -> TypecheckedSource
moduleInfo :: m -> ModuleInfo
tm_internals :: m -> (TcGblEnv, ModDetails)
- -- 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.
+ -- 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.
class TypecheckedMod m => DesugaredMod m where
coreModule :: m -> ModGuts
@@ -768,9 +761,9 @@ loadModule tcm = do
-- %************************************************************************
--- %* *
+-- %* *
-- Dealing with Core
--- %* *
+-- %* *
-- %************************************************************************
-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
@@ -893,9 +886,9 @@ compileCore simplify fn = do
}
-- %************************************************************************
--- %* *
+-- %* *
-- Inspecting the session
--- %* *
+-- %* *
-- %************************************************************************
-- | Get the module dependency graph.
@@ -932,28 +925,28 @@ getPrintUnqual = withSession $ \hsc_env ->
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
- minf_type_env :: TypeEnv,
- minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
- minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
- minf_instances :: [Instance],
+ minf_type_env :: TypeEnv,
+ minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
+ minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
+ minf_instances :: [Instance],
minf_iface :: Maybe ModIface
#ifdef GHCI
,minf_modBreaks :: ModBreaks
#endif
}
- -- We don't want HomeModInfo here, because a ModuleInfo applies
- -- to package modules too.
+ -- We don't want HomeModInfo here, because a ModuleInfo applies
+ -- to package modules too.
-- | Request information about a loaded 'Module'
getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
getModuleInfo mdl = withSession $ \hsc_env -> do
let mg = hsc_mod_graph hsc_env
if mdl `elem` map ms_mod mg
- then liftIO $ getHomeModuleInfo hsc_env mdl
- else do
+ then liftIO $ getHomeModuleInfo hsc_env mdl
+ else do
{- if isHomeModule (hsc_dflags hsc_env) mdl
- then return Nothing
- else -} liftIO $ getPackageModuleInfo hsc_env mdl
+ then return Nothing
+ else -} liftIO $ getPackageModuleInfo hsc_env mdl
-- ToDo: we don't understand what the following comment means.
-- (SDM, 19/7/2011)
-- getPackageModuleInfo will attempt to find the interface, so
@@ -964,23 +957,23 @@ getModuleInfo mdl = withSession $ \hsc_env -> do
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
#ifdef GHCI
getPackageModuleInfo hsc_env mdl
- = do eps <- hscEPS hsc_env
+ = do eps <- hscEPS hsc_env
iface <- hscGetModuleInterface hsc_env mdl
- let
- avails = mi_exports iface
+ let
+ avails = mi_exports iface
names = availsToNameSet avails
- pte = eps_PTE eps
- tys = [ ty | name <- concatMap availNames avails,
- Just ty <- [lookupTypeEnv pte name] ]
- --
- return (Just (ModuleInfo {
- minf_type_env = mkTypeEnv tys,
- minf_exports = names,
- minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
- minf_instances = error "getModuleInfo: instances for package module unimplemented",
+ pte = eps_PTE eps
+ tys = [ ty | name <- concatMap availNames avails,
+ Just ty <- [lookupTypeEnv pte name] ]
+ --
+ return (Just (ModuleInfo {
+ minf_type_env = mkTypeEnv tys,
+ minf_exports = names,
+ minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
+ minf_instances = error "getModuleInfo: instances for package module unimplemented",
minf_iface = Just iface,
minf_modBreaks = emptyModBreaks
- }))
+ }))
#else
-- bogusly different for non-GHCI (ToDo)
getPackageModuleInfo _hsc_env _mdl = do
@@ -995,15 +988,15 @@ getHomeModuleInfo hsc_env mdl =
let details = hm_details hmi
iface = hm_iface hmi
return (Just (ModuleInfo {
- minf_type_env = md_types details,
- minf_exports = availsToNameSet (md_exports details),
- minf_rdr_env = mi_globals $! hm_iface hmi,
- minf_instances = md_insts details,
+ minf_type_env = md_types details,
+ minf_exports = availsToNameSet (md_exports details),
+ minf_rdr_env = mi_globals $! hm_iface hmi,
+ minf_instances = md_insts details,
minf_iface = Just iface
#ifdef GHCI
,minf_modBreaks = getModBreaks hmi
#endif
- }))
+ }))
-- | The list of top-level entities defined in a module
modInfoTyThings :: ModuleInfo -> [TyThing]
@@ -1039,7 +1032,7 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do
Nothing -> do
eps <- liftIO $ readIORef (hsc_EPS hsc_env)
return $! lookupType (hsc_dflags hsc_env)
- (hsc_HPT hsc_env) (eps_PTE eps) name
+ (hsc_HPT hsc_env) (eps_PTE eps) name
modInfoIface :: ModuleInfo -> Maybe ModIface
modInfoIface = minf_iface
@@ -1252,28 +1245,34 @@ lookupModule mod_name Nothing = withSession $ \hsc_env -> 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
+ err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
-lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
+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
+-- | Check that a module is safe to import (according to Safe Haskell).
+--
+-- We return True to indicate the import is safe and False otherwise
+-- although in the False case an error may be thrown first.
+isModuleTrusted :: GhcMonad m => Module -> m Bool
+isModuleTrusted m = withSession $ \hsc_env ->
+ liftIO $ hscCheckSafe hsc_env m noSrcSpan
+
getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan h = withSession $ \hsc_env ->
- return$ InteractiveEval.getHistorySpan hsc_env h
+ return $ InteractiveEval.getHistorySpan hsc_env h
obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
-obtainTermFromVal bound force ty a =
- withSession $ \hsc_env ->
- liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
+obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
+ liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
-obtainTermFromId bound force id =
- withSession $ \hsc_env ->
- liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
+obtainTermFromId bound force id = withSession $ \hsc_env ->
+ liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
#endif
@@ -1307,3 +1306,4 @@ parser str dflags filename =
POk pst rdr_module ->
let (warns,_) = getMessages pst in
Right (warns, rdr_module)
+
diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs
index 816cc4b922..6b8c7bacdf 100644
--- a/compiler/main/GhcMonad.hs
+++ b/compiler/main/GhcMonad.hs
@@ -46,11 +46,10 @@ import Data.IORef
-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
-- before any call to the GHC API functions can occur.
--
-class (Functor m, MonadIO m, ExceptionMonad m) => GhcMonad m where
+class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where
getSession :: m HscEnv
setSession :: HscEnv -> m ()
-
-- | Call the argument with the current session.
withSession :: GhcMonad m => (HscEnv -> m a) -> m a
withSession f = getSession >>= f
@@ -120,6 +119,9 @@ instance ExceptionMonad Ghc where
in
unGhc (f g_restore) s
+instance HasDynFlags Ghc where
+ getDynFlags = getSessionDynFlags
+
instance GhcMonad Ghc where
getSession = Ghc $ \(Session r) -> readIORef r
setSession s' = Ghc $ \(Session r) -> writeIORef r s'
@@ -176,6 +178,9 @@ instance ExceptionMonad m => ExceptionMonad (GhcT m) where
in
unGhcT (f g_restore) s
+instance (Functor m, ExceptionMonad m, MonadIO m) => HasDynFlags (GhcT m) where
+ getDynFlags = getSessionDynFlags
+
instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where
getSession = GhcT $ \(Session r) -> liftIO $ readIORef r
setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index b4cfbf403f..2882816c0b 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -60,6 +60,7 @@ module HscMain
, hscParseIdentifier
, hscTcRcLookupName
, hscTcRnGetInfo
+ , hscCheckSafe
#ifdef GHCI
, hscGetModuleInterface
, hscRnImportDecls
@@ -93,7 +94,7 @@ import HsSyn
import CoreSyn
import StringBuffer
import Parser
-import Lexer hiding (getDynFlags)
+import Lexer
import SrcLoc
import TcRnDriver
import TcIface ( typecheckIface )
@@ -205,6 +206,9 @@ instance Monad Hsc where
instance MonadIO Hsc where
liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
+instance Functor Hsc where
+ fmap f m = m >>= \a -> return $ f a
+
runHsc :: HscEnv -> Hsc a -> IO a
runHsc hsc_env (Hsc hsc) = do
(a, w) <- hsc hsc_env emptyBag
@@ -223,8 +227,8 @@ logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
getHscEnv :: Hsc HscEnv
getHscEnv = Hsc $ \e w -> return (e, w)
-getDynFlags :: Hsc DynFlags
-getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
+instance HasDynFlags Hsc where
+ getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
handleWarnings :: Hsc ()
handleWarnings = do
@@ -886,9 +890,8 @@ hscFileFrontEnd mod_summary = do
-- inference mode.
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports tcg_env = do
- hsc_env <- getHscEnv
dflags <- getDynFlags
- tcg_env' <- checkSafeImports dflags hsc_env tcg_env
+ tcg_env' <- checkSafeImports dflags tcg_env
case safeLanguageOn dflags of
True -> do
-- we nuke user written RULES in -XSafe
@@ -911,22 +914,20 @@ hscCheckSafeImports tcg_env = do
text "Rule \"" <> ftext n <> text "\" ignored" $+$
text "User defined rules are disabled under Safe Haskell"
--- | Validate that safe imported modules are actually safe.
--- For modules in the HomePackage (the package the module we
--- are compiling in resides) this just involves checking its
--- trust type is 'Safe' or 'Trustworthy'. For modules that
--- reside in another package we also must check that the
--- external pacakge is trusted. See the Note [Safe Haskell
--- Trust Check] above for more information.
+-- | Validate that safe imported modules are actually safe. For modules in the
+-- HomePackage (the package the module we are compiling in resides) this just
+-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
+-- that reside in another package we also must check that the external pacakge
+-- is trusted. See the Note [Safe Haskell Trust Check] above for more
+-- information.
--
--- The code for this is quite tricky as the whole algorithm
--- is done in a few distinct phases in different parts of the
--- code base. See RnNames.rnImportDecl for where package trust
--- dependencies for a module are collected and unioned.
--- Specifically see the Note [RnNames . Tracking Trust Transitively]
--- and the Note [RnNames . Trust Own Package].
-checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv
-checkSafeImports dflags hsc_env tcg_env
+-- The code for this is quite tricky as the whole algorithm is done in a few
+-- distinct phases in different parts of the code base. See
+-- RnNames.rnImportDecl for where package trust dependencies for a module are
+-- collected and unioned. Specifically see the Note [RnNames . Tracking Trust
+-- Transitively] and the Note [RnNames . Trust Own Package].
+checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
+checkSafeImports dflags tcg_env
= do
-- We want to use the warning state specifically for detecting if safe
-- inference has failed, so store and clear any existing warnings.
@@ -941,7 +942,7 @@ checkSafeImports dflags hsc_env tcg_env
clearWarnings
logWarnings oldErrs
- -- See the Note [ Safe Haskell Inference]
+ -- See the Note [Safe Haskell Inference]
case (not $ isEmptyBag errs) of
-- We have errors!
@@ -953,7 +954,7 @@ checkSafeImports dflags hsc_env tcg_env
-- All good matey!
False -> do
- when (packageTrustOn dflags) $ checkPkgTrust pkg_reqs
+ when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs
-- add in trusted package requirements for this module
let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
@@ -981,41 +982,36 @@ checkSafeImports dflags hsc_env tcg_env
(text $ "is imported both as a safe and unsafe import!"))
| otherwise
= return v1
+
+ -- easier interface to work with
+ checkSafe (_, _, False) = return Nothing
+ checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l
- lookup' :: Module -> Hsc (Maybe ModIface)
- lookup' m = do
- hsc_eps <- liftIO $ hscEPS hsc_env
- let pkgIfaceT = eps_PIT hsc_eps
- homePkgT = hsc_HPT hsc_env
- iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
- return iface
-
- isHomePkg :: Module -> Bool
- isHomePkg m
- | thisPackage dflags == modulePackageId m = True
- | otherwise = False
-
- -- | Check the package a module resides in is trusted.
- -- Safe compiled modules are trusted without requiring
- -- that their package is trusted. For trustworthy modules,
- -- modules in the home package are trusted but otherwise
- -- we check the package trust flag.
- packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
- packageTrusted _ _ _
- | not (packageTrustOn dflags) = True
- packageTrusted Sf_Safe False _ = True
- packageTrusted Sf_SafeInfered False _ = True
- packageTrusted _ _ m
- | isHomePkg m = True
- | otherwise = trusted $ getPackageDetails (pkgState dflags)
- (modulePackageId m)
-
- -- Is a module trusted? Return Nothing if True, or a String
- -- if it isn't, containing the reason it isn't. Also return
- -- if the module trustworthy (true) or safe (false) so we know
- -- if we should check if the package itself is trusted in the
- -- future.
- isModSafe :: Module -> SrcSpan -> Hsc (Bool)
+-- | Check that a module is safe to import.
+--
+-- We return True to indicate the import is safe and False otherwise
+-- although in the False case an exception may be thrown first.
+hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
+hscCheckSafe hsc_env m l = runHsc hsc_env $ do
+ dflags <- getDynFlags
+ pkgs <- snd `fmap` hscCheckSafe' dflags m l
+ when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs
+ errs <- getWarnings
+ return $ isEmptyBag errs
+
+hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId])
+hscCheckSafe' dflags m l = do
+ (tw, pkgs) <- isModSafe m l
+ case tw of
+ False -> return (Nothing, pkgs)
+ True | isHomePkg m -> return (Nothing, pkgs)
+ | otherwise -> return (Just $ modulePackageId m, pkgs)
+ where
+ -- Is a module trusted? If not, throw or log errors depending on the type.
+ -- Return (regardless of trusted or not) if the trust type requires the
+ -- modules own package be trusted and a list of other packages required to
+ -- be trusted (these later ones haven't been checked)
+ isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId])
isModSafe m l = do
iface <- lookup' m
case iface of
@@ -1032,11 +1028,14 @@ checkSafeImports dflags hsc_env tcg_env
safeM = trust `elem` [Sf_SafeInfered, Sf_Safe, Sf_Trustworthy]
-- check package is trusted
safeP = packageTrusted trust trust_own_pkg m
+ -- pkg trust reqs
+ pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface'
case (safeM, safeP) of
-- General errors we throw but Safe errors we log
- (True, True ) -> return $ trust == Sf_Trustworthy
+ (True, True ) -> return (trust == Sf_Trustworthy, pkgRs)
(True, False) -> liftIO . throwIO $ pkgTrustErr
- (False, _ ) -> logWarnings modTrustErr >> return (trust == Sf_Trustworthy)
+ (False, _ ) -> logWarnings modTrustErr >>
+ return (trust == Sf_Trustworthy, pkgRs)
where
pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m
@@ -1047,30 +1046,60 @@ checkSafeImports dflags hsc_env tcg_env
<+> text "can't be safely imported!"
<+> text "The module itself isn't safe."
- -- Here we check the transitive package trust requirements are OK still.
- checkPkgTrust :: [PackageId] -> Hsc ()
- checkPkgTrust pkgs =
- case errors of
- [] -> return ()
- _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
- where
- errors = catMaybes $ map go pkgs
- go pkg
- | trusted $ getPackageDetails (pkgState dflags) pkg
- = Nothing
- | otherwise
- = Just $ mkPlainErrMsg noSrcSpan
- $ text "The package (" <> ppr pkg <> text ") is required"
- <> text " to be trusted but it isn't!"
-
- checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId)
- checkSafe (_, _, False) = return Nothing
- checkSafe (m, l, True ) = do
- tw <- isModSafe m l
- return $ pkg tw
- where pkg False = Nothing
- pkg True | isHomePkg m = Nothing
- | otherwise = Just (modulePackageId m)
+ -- | Check the package a module resides in is trusted. Safe compiled
+ -- modules are trusted without requiring that their package is trusted. For
+ -- trustworthy modules, modules in the home package are trusted but
+ -- otherwise we check the package trust flag.
+ packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
+ packageTrusted _ _ _
+ | not (packageTrustOn dflags) = True
+ packageTrusted Sf_Safe False _ = True
+ packageTrusted Sf_SafeInfered False _ = True
+ packageTrusted _ _ m
+ | isHomePkg m = True
+ | otherwise = trusted $ getPackageDetails (pkgState dflags)
+ (modulePackageId m)
+
+ lookup' :: Module -> Hsc (Maybe ModIface)
+ lookup' m = do
+ hsc_env <- getHscEnv
+ hsc_eps <- liftIO $ hscEPS hsc_env
+ let pkgIfaceT = eps_PIT hsc_eps
+ homePkgT = hsc_HPT hsc_env
+ iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
+#ifdef GHCI
+ -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
+ -- as the compiler hasn't filled in the various module tables
+ -- so we need to call 'getModuleInterface' to load from disk
+ iface' <- case iface of
+ Just _ -> return iface
+ Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
+ return iface'
+#else
+ return iface
+#endif
+
+
+ isHomePkg :: Module -> Bool
+ isHomePkg m
+ | thisPackage dflags == modulePackageId m = True
+ | otherwise = False
+
+-- | Check the list of packages are trusted.
+checkPkgTrust :: DynFlags -> [PackageId] -> Hsc ()
+checkPkgTrust dflags pkgs =
+ case errors of
+ [] -> return ()
+ _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
+ where
+ errors = catMaybes $ map go pkgs
+ go pkg
+ | trusted $ getPackageDetails (pkgState dflags) pkg
+ = Nothing
+ | otherwise
+ = Just $ mkPlainErrMsg noSrcSpan
+ $ text "The package (" <> ppr pkg <> text ") is required"
+ <> text " to be trusted but it isn't!"
-- | Set module to unsafe and wipe trust information.
--
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index b4cf6b8197..3439231aa6 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -6,17 +6,10 @@
--
-- -----------------------------------------------------------------------------
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module InteractiveEval (
#ifdef GHCI
RunResult(..), Status(..), Resume(..), History(..),
- runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
+ runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation,
parseImportDecl, SingleStep(..),
resume,
abandon, abandonAll,
@@ -25,18 +18,18 @@ module InteractiveEval (
getModBreaks,
getHistoryModule,
back, forward,
- setContext, getContext,
+ setContext, getContext,
availsToGlobalRdrEnv,
- getNamesInScope,
- getRdrNamesInScope,
- moduleIsInterpreted,
- getInfo,
- exprType,
- typeKind,
- parseName,
- showModule,
+ getNamesInScope,
+ getRdrNamesInScope,
+ moduleIsInterpreted,
+ getInfo,
+ exprType,
+ typeKind,
+ parseName,
+ showModule,
isModuleInterpreted,
- compileExpr, dynCompileExpr,
+ compileExpr, dynCompileExpr,
Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
#endif
) where
@@ -51,7 +44,7 @@ import HsSyn
import HscTypes
import InstEnv
import Type hiding( typeKind )
-import TcType hiding( typeKind )
+import TcType hiding( typeKind )
import Var
import Id
import Name hiding ( varName )
@@ -98,7 +91,7 @@ import System.IO.Unsafe
-- running a statement interactively
data RunResult
- = RunOk [Name] -- ^ names bound by this evaluation
+ = RunOk [Name] -- ^ names bound by this evaluation
| RunException SomeException -- ^ statement raised an exception
| RunBreak ThreadId [Name] (Maybe BreakInfo)
@@ -112,13 +105,13 @@ data Resume
= Resume {
resumeStmt :: String, -- the original statement
resumeThreadId :: ThreadId, -- thread running the computation
- resumeBreakMVar :: MVar (),
+ resumeBreakMVar :: MVar (),
resumeStatMVar :: MVar Status,
resumeBindings :: ([TyThing], GlobalRdrEnv),
resumeFinalIds :: [Id], -- [Id] to bind on completion
resumeApStack :: HValue, -- The object from which we can get
-- value of the free variables.
- resumeBreakInfo :: Maybe BreakInfo,
+ resumeBreakInfo :: Maybe BreakInfo,
-- the breakpoint we stopped at
-- (Nothing <=> exception)
resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain
@@ -191,8 +184,8 @@ runStmt = runStmtWithLocation "<interactive>" 1
-- | Run a statement in the current interactive context. Passing debug information
-- Statement may bind multple values.
-runStmtWithLocation :: GhcMonad m => String -> Int ->
- String -> SingleStep -> m RunResult
+runStmtWithLocation :: GhcMonad m => String -> Int ->
+ String -> SingleStep -> m RunResult
runStmtWithLocation source linenumber expr step =
do
hsc_env <- getSession
@@ -216,7 +209,7 @@ runStmtWithLocation source linenumber expr step =
withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
let thing_to_run = unsafeCoerce# hval :: IO [HValue]
liftIO $ sandboxIO dflags' statusMVar thing_to_run
-
+
let ic = hsc_IC hsc_env
bindings = (ic_tythings ic, ic_rn_gbl_env ic)
@@ -242,7 +235,7 @@ runDeclsWithLocation source linenumber expr =
hsc_env' = hsc_env{ hsc_dflags = dflags' }
(tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env' expr source linenumber
-
+
setSession $ hsc_env { hsc_IC = ic }
hsc_env <- getSession
hsc_env' <- liftIO $ rttiEnvironment hsc_env
@@ -257,7 +250,7 @@ withVirtualCWD m = do
let set_cwd = do
dir <- liftIO $ getCurrentDirectory
- case ic_cwd ic of
+ case ic_cwd ic of
Just dir -> liftIO $ setCurrentDirectory dir
Nothing -> return ()
return dir
@@ -283,7 +276,7 @@ handleRunStatus :: GhcMonad m =>
-> m RunResult
handleRunStatus expr bindings final_ids breakMVar statusMVar status
history =
- case status of
+ case status of
-- did we hit a breakpoint or did we complete?
(Break is_exception apStack info tid) -> do
hsc_env <- getSession
@@ -293,9 +286,9 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status
mb_info
let
resume = Resume { resumeStmt = expr, resumeThreadId = tid
- , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
+ , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
, resumeBindings = bindings, resumeFinalIds = final_ids
- , resumeApStack = apStack, resumeBreakInfo = mb_info
+ , resumeApStack = apStack, resumeBreakInfo = mb_info
, resumeSpan = span, resumeHistory = toListBL history
, resumeHistoryIx = 0 }
hsc_env2 = pushResume hsc_env1 resume
@@ -303,9 +296,9 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status
modifySession (\_ -> hsc_env2)
return (RunBreak tid names mb_info)
(Complete either_hvals) ->
- case either_hvals of
- Left e -> return (RunException e)
- Right hvals -> do
+ case either_hvals of
+ Left e -> return (RunException e)
+ Right hvals -> do
hsc_env <- getSession
let final_ic = extendInteractiveContext (hsc_IC hsc_env)
(map AnId final_ids)
@@ -369,8 +362,8 @@ resetStepFlag :: IO ()
resetStepFlag = poke stepFlag 0
-- this points to the IO action that is executed when a breakpoint is hit
-foreign import ccall "&rts_breakpoint_io_action"
- breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
+foreign import ccall "&rts_breakpoint_io_action"
+ breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
-- When running a computation, we redirect ^C exceptions to the running
-- thread. ToDo: we might want a way to continue even if the target
@@ -407,7 +400,7 @@ sandboxIO dflags statusMVar thing =
rethrow :: DynFlags -> IO a -> IO a
rethrow dflags io = Exception.catch io $ \se -> do
-- If -fbreak-on-error, we break unconditionally,
- -- but with care of not breaking twice
+ -- but with care of not breaking twice
if dopt Opt_BreakOnError dflags &&
not (dopt Opt_BreakOnException dflags)
then poke exceptionFlag 1
@@ -481,28 +474,28 @@ resume canLogSpan step
ic_rn_gbl_env = resume_rdr_env,
ic_resume = rs }
modifySession (\_ -> hsc_env{ hsc_IC = ic' })
-
- -- remove any bindings created since the breakpoint from the
+
+ -- remove any bindings created since the breakpoint from the
-- linker's environment
let new_names = map getName (filter (`notElem` resume_tmp_te)
(ic_tythings ic))
liftIO $ Linker.deleteFromLinkEnv new_names
-
+
when (isStep step) $ liftIO setStepFlag
- case r of
+ case r of
Resume { resumeStmt = expr, resumeThreadId = tid
, resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
, resumeBindings = bindings, resumeFinalIds = final_ids
, resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
, resumeHistory = hist } -> do
withVirtualCWD $ do
- withBreakAction (isStep step) (hsc_dflags hsc_env)
+ withBreakAction (isStep step) (hsc_dflags hsc_env)
breakMVar statusMVar $ do
status <- liftIO $ withInterruptsSentTo tid $ do
putMVar breakMVar ()
-- this awakens the stopped thread...
takeMVar statusMVar
- -- and wait for the result
+ -- and wait for the result
let prevHistoryLst = fromListBL 50 hist
hist' = case info of
Nothing -> prevHistoryLst
@@ -511,7 +504,7 @@ resume canLogSpan step
| otherwise -> mkHistory hsc_env apStack i `consBL`
fromListBL 50 hist
case step of
- RunAndLogSteps ->
+ RunAndLogSteps ->
traceRunStatus expr bindings final_ids
breakMVar statusMVar status hist'
_other ->
@@ -543,23 +536,23 @@ moveHist fn = do
update_ic apStack mb_info = do
(hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env
apStack mb_info
- let ic = hsc_IC hsc_env1
+ let ic = hsc_IC hsc_env1
r' = r { resumeHistoryIx = new_ix }
ic' = ic { ic_resume = r':rs }
-
+
modifySession (\_ -> hsc_env1{ hsc_IC = ic' })
-
+
return (names, new_ix, span)
-- careful: we want apStack to be the AP_STACK itself, not a thunk
-- around it, hence the cases are carefully constructed below to
-- make this the case. ToDo: this is v. fragile, do something better.
if new_ix == 0
- then case r of
- Resume { resumeApStack = apStack,
+ then case r of
+ Resume { resumeApStack = apStack,
resumeBreakInfo = mb_info } ->
update_ic apStack mb_info
- else case history !! (new_ix - 1) of
+ else case history !! (new_ix - 1) of
History apStack info _ ->
update_ic apStack (Just info)
@@ -598,9 +591,9 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
-- of the breakpoint and the free variables of the expression.
bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
- let
+ let
mod_name = moduleName (breakInfo_module info)
- hmi = expectJust "bindLocalsAtBreakpoint" $
+ hmi = expectJust "bindLocalsAtBreakpoint" $
lookupUFM (hsc_HPT hsc_env) mod_name
breaks = getModBreaks hmi
index = breakInfo_number info
@@ -628,7 +621,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
when (any isNothing mb_hValues) $
debugTraceMsg (hsc_dflags hsc_env) 1 $
- text "Warning: _result has been evaluated, some bindings have been lost"
+ text "Warning: _result has been evaluated, some bindings have been lost"
us <- mkSplitUniqSupply 'I'
let (us1, us2) = splitUniqSupply us
@@ -683,10 +676,10 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
| (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
, let name = setNameUnique (tyVarName tv) uniq ]
-rttiEnvironment :: HscEnv -> IO HscEnv
+rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
let tmp_ids = [id | AnId id <- ic_tythings ic]
- incompletelyTypedIds =
+ incompletelyTypedIds =
[id | id <- tmp_ids
, not $ noSkolems id
, (occNameFS.nameOccName.idName) id /= result_fs]
@@ -744,7 +737,7 @@ abandon = do
resume = ic_resume ic
case resume of
[] -> return False
- r:rs -> do
+ r:rs -> do
modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
liftIO $ abandon_ r
return True
@@ -756,13 +749,13 @@ abandonAll = do
resume = ic_resume ic
case resume of
[] -> return False
- rs -> do
+ rs -> do
modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
liftIO $ mapM_ abandon_ rs
return True
--- when abandoning a computation we have to
--- (a) kill the thread with an async exception, so that the
+-- when abandoning a computation we have to
+-- (a) kill the thread with an async exception, so that the
-- computation itself is stopped, and
-- (b) fill in the MVar. This step is necessary because any
-- thunks that were under evaluation will now be updated
@@ -773,7 +766,7 @@ abandonAll = do
abandon_ :: Resume -> IO ()
abandon_ r = do
killThread (resumeThreadId r)
- putMVar (resumeBreakMVar r) ()
+ putMVar (resumeBreakMVar r) ()
-- -----------------------------------------------------------------------------
-- Bounded list, optimised for repeated cons
@@ -821,7 +814,7 @@ findGlobalRdrEnv :: HscEnv -> [InteractiveImport] -> IO GlobalRdrEnv
-- Compute the GlobalRdrEnv for the interactive context
findGlobalRdrEnv hsc_env imports
= do { idecls_env <- hscRnImportDecls hsc_env idecls
- -- This call also loads any orphan modules
+ -- This call also loads any orphan modules
; imods_env <- mapM (mkTopLevEnv (hsc_HPT hsc_env)) imods
; return (foldr plusGlobalRdrEnv idecls_env imods_env) }
where
@@ -838,21 +831,21 @@ availsToGlobalRdrEnv mod_name avails
-- We're building a GlobalRdrEnv as if the user imported
-- all the specified modules into the global interactive module
imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
- decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
- is_qual = False,
- is_dloc = srcLocSpan interactiveSrcLoc }
+ decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
+ is_qual = False,
+ is_dloc = srcLocSpan interactiveSrcLoc }
mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
mkTopLevEnv hpt modl
= case lookupUFM hpt (moduleName modl) of
- Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
+ Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
showSDoc (ppr modl)))
Just details ->
- case mi_globals (hm_iface details) of
- Nothing ->
- ghcError (ProgramError ("mkTopLevEnv: not interpreted "
- ++ showSDoc (ppr modl)))
- Just env -> return env
+ case mi_globals (hm_iface details) of
+ Nothing ->
+ ghcError (ProgramError ("mkTopLevEnv: not interpreted "
+ ++ showSDoc (ppr modl)))
+ Just env -> return env
-- | Get the interactive evaluation context, consisting of a pair of the
-- set of modules from which we take the full top-level scope, and the set
@@ -872,10 +865,10 @@ moduleIsInterpreted modl = withSession $ \h ->
_not_a_home_module -> return False
-- | Looks up an identifier in the current interactive context (for :info)
--- Filter the instances by the ones whose tycons (or clases resp)
+-- Filter the instances by the ones whose tycons (or clases resp)
-- are in scope (qualified or otherwise). Otherwise we list a whole lot too many!
-- The exact choice of which ones to show, and which to hide, is a judgement call.
--- (see Trac #1581)
+-- (see Trac #1581)
getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
getInfo name
= withSession $ \hsc_env ->
@@ -886,15 +879,15 @@ getInfo name
let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
return (Just (thing, fixity, filter (plausible rdr_env) ispecs))
where
- plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env
- = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec
- where -- A name is ok if it's in the rdr_env,
- -- whether qualified or not
- ok n | n == name = True -- The one we looked for in the first place!
- | isBuiltInSyntax n = True
- | isExternalName n = any ((== n) . gre_name)
- (lookupGRE_Name rdr_env n)
- | otherwise = True
+ plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env
+ = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec
+ where -- A name is ok if it's in the rdr_env,
+ -- whether qualified or not
+ ok n | n == name = True -- The one we looked for in the first place!
+ | isBuiltInSyntax n = True
+ | isExternalName n = any ((== n) . gre_name)
+ (lookupGRE_Name rdr_env n)
+ | otherwise = True
-- | Returns all names in scope in the current interactive context
getNamesInScope :: GhcMonad m => m [Name]
@@ -903,7 +896,7 @@ getNamesInScope = withSession $ \hsc_env -> do
getRdrNamesInScope :: GhcMonad m => m [RdrName]
getRdrNamesInScope = withSession $ \hsc_env -> do
- let
+ let
ic = hsc_IC hsc_env
gbl_rdrenv = ic_rn_gbl_env ic
gbl_names = concatMap greToRdrNames $ globalRdrEnvElts gbl_rdrenv
@@ -920,9 +913,9 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov }
occ = nameOccName name
unqual = Unqual occ
do_spec decl_spec
- | is_qual decl_spec = [qual]
- | otherwise = [unqual,qual]
- where qual = Qual (is_as decl_spec) occ
+ | is_qual decl_spec = [qual]
+ | otherwise = [unqual,qual]
+ where qual = Qual (is_as decl_spec) occ
-- | Parses a string as an identifier, and returns the list of 'Name's that
-- the identifier can refer to in the current interactive context.
@@ -954,12 +947,12 @@ typeKind normalise str = withSession $ \hsc_env -> do
compileExpr :: GhcMonad m => String -> m HValue
compileExpr expr = withSession $ \hsc_env -> do
Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
- -- Run it!
+ -- Run it!
hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
case (ids,hvals) of
([_],[hv]) -> return hv
- _ -> panic "compileExpr"
+ _ -> panic "compileExpr"
-- -----------------------------------------------------------------------------
-- Compile an expression into a dynamic
@@ -979,7 +972,7 @@ dynCompileExpr expr = do
}
setContext (IIDecl importDecl : iis)
let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
- Just (ids, hvals) <- withSession $ \hsc_env ->
+ Just (ids, hvals) <- withSession $ \hsc_env ->
liftIO $ hscStmt hsc_env stmt
setContext iis
vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
@@ -999,10 +992,10 @@ showModule mod_summary =
isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
isModuleInterpreted mod_summary = withSession $ \hsc_env ->
case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
- Nothing -> panic "missing linkable"
- Just mod_info -> return (not obj_linkable)
- where
- obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
+ Nothing -> panic "missing linkable"
+ Just mod_info -> return (not obj_linkable)
+ where
+ obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
----------------------------------------------------------------------------
-- RTTI primitives
@@ -1019,7 +1012,7 @@ obtainTermFromId hsc_env bound force id = do
-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType hsc_env bound id = do
- hv <- Linker.getHValue hsc_env (varName id)
+ hv <- Linker.getHValue hsc_env (varName id)
cvReconstructType hsc_env bound (idType id) hv
mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
View Lorry Controller Status