Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/0753cf09d5ef990ca620632409a1db18a75563fa >--------------------------------------------------------------- commit 0753cf09d5ef990ca620632409a1db18a75563fa Author: Paolo Capriotti <[email protected]> Date: Mon Jun 25 13:45:03 2012 +0100 New version of the patch for #5461. >--------------------------------------------------------------- compiler/main/DynFlags.hs | 14 +++----------- compiler/main/HscTypes.lhs | 14 ++++++++++++-- compiler/typecheck/TcRnDriver.lhs | 3 +-- compiler/typecheck/TcRnMonad.lhs | 3 +++ ghc/InteractiveUI.hs | 8 +++++--- 5 files changed, 24 insertions(+), 18 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index d81b483..9a00a9c 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -80,8 +80,6 @@ module DynFlags ( setPackageName, doingTickyProfiling, - setInteractivePrintName, -- Name -> DynFlags -> DynFlags - -- ** Parsing DynFlags parseDynamicFlagsCmdLine, parseDynamicFilePragma, @@ -111,7 +109,6 @@ module DynFlags ( #include "HsVersions.h" import Platform -import Name import Module import PackageConfig import PrelNames ( mAIN ) @@ -629,10 +626,9 @@ data DynFlags = DynFlags { -- | what kind of {-# SCC #-} to add automatically profAuto :: ProfAuto, - llvmVersion :: IORef (Int), - interactivePrint :: Maybe String, - interactivePrintName :: Maybe Name + + llvmVersion :: IORef (Int) } class HasDynFlags m where @@ -990,8 +986,7 @@ defaultDynFlags mySettings = traceLevel = 1, profAuto = NoProfAuto, llvmVersion = panic "defaultDynFlags: No llvmVersion", - interactivePrint = Nothing, - interactivePrintName = Nothing + interactivePrint = Nothing } -- Do not use tracingDynFlags! @@ -1330,9 +1325,6 @@ addGhciScript f d = d{ ghciScripts = f : ghciScripts d} setInteractivePrint f d = d{ interactivePrint = Just f} -setInteractivePrintName :: Name -> DynFlags -> DynFlags -setInteractivePrintName f d = d{ interactivePrintName = Just f} - -- ----------------------------------------------------------------------------- -- Command-line options diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 1631e8c..156f081 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -44,6 +44,7 @@ module HscTypes ( InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, icInScopeTTs, icPlusGblRdrEnv, extendInteractiveContext, substInteractiveContext, + setInteractivePrintName, InteractiveImport(..), mkPrintUnqualified, pprModulePrefix, @@ -136,7 +137,7 @@ import Annotations import Class import TyCon import DataCon -import PrelNames ( gHC_PRIM, ioTyConName ) +import PrelNames ( gHC_PRIM, ioTyConName, printName ) import Packages hiding ( Version(..) ) import DynFlags import DriverPhases @@ -944,6 +945,10 @@ data InteractiveContext ic_fix_env :: FixityEnv, -- ^ Fixities declared in let statements + ic_int_print :: Name, + -- ^ The function that is used for printing results + -- of expressions in ghci and -e mode. + #ifdef GHCI ic_resume :: [Resume], -- ^ The stack of breakpoint contexts @@ -986,6 +991,8 @@ emptyInteractiveContext dflags ic_sys_vars = [], ic_instances = ([],[]), ic_fix_env = emptyNameEnv, + -- System.IO.print by default + ic_int_print = printName, #ifdef GHCI ic_resume = [], #endif @@ -1020,6 +1027,9 @@ extendInteractiveContext ictxt new_tythings new_names = [ nameOccName (getName id) | AnId id <- new_tythings ] +setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext +setInteractivePrintName ic n = ic{ic_int_print = n} + -- ToDo: should not add Ids to the gbl env here -- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing @@ -1090,7 +1100,7 @@ exposed (say P2), so we use M.T for that, and P1:M.T for the other one. This is handled by the qual_mod component of PrintUnqualified, inside the (ppr mod) of case (3), in Name.pprModulePrefix -\begin{code} + \begin{code} -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 2c5084c..fa87eb1 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1325,9 +1325,9 @@ tcUserStmt :: LStmt RdrName -> TcM (PlanResult, FixityEnv) tcUserStmt (L loc (ExprStmt expr _ _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! - ; dynFlags <- getDynFlags ; ghciStep <- getGhciStepIO ; uniq <- newUnique + ; interPrintName <- getInteractivePrintName ; let fresh_it = itName uniq loc matches = [mkMatch [] rn_expr emptyLocalBinds] -- [it = expr] @@ -1346,7 +1346,6 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) (HsVar bindIOName) noSyntaxExpr -- [; print it] - interPrintName = maybe printName id (interactivePrintName dynFlags) print_it = L loc $ ExprStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) (HsVar thenIOName) noSyntaxExpr placeHolderType diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 8acd0db..f685998 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -493,6 +493,9 @@ getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) } getGHCiMonad :: TcRn Name getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) } +getInteractivePrintName :: TcRn Name +getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } + tcIsHsBoot :: TcRn Bool tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 3231634..d9d6bc2 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -21,12 +21,14 @@ import Debugger -- The GHC interface import DynFlags +import GhcMonad ( modifySession ) import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, handleSourceError ) import HsImpExp -import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs ) +import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs, hsc_IC, + setInteractivePrintName ) import Module import Name import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap ) @@ -615,8 +617,8 @@ installInteractivePrint Nothing _ = return () installInteractivePrint (Just ipFun) exprmode = do ok <- trySuccess $ do (name:_) <- GHC.parseName ipFun - dflags <- getDynFlags - GHC.setInteractiveDynFlags (setInteractivePrintName name dflags) + modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name + in he{hsc_IC = new_ic}) return Succeeded when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1)) _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
