From 610490432043993286ec60486fe468313ec794ea Mon Sep 17 00:00:00 2001 From: Vitaly Bragilevsky Date: Sun, 24 Jun 2012 21:46:11 +0400 Subject: [PATCH] Implemented reconfigurable pretty-printing (#5461) --- compiler/main/DynFlags.hs | 12 +++++++++--- compiler/main/HscTypes.lhs | 14 ++++++++++++-- compiler/typecheck/TcRnDriver.lhs | 3 ++- compiler/typecheck/TcRnMonad.lhs | 3 +++ ghc/InteractiveUI.hs | 19 ++++++++++++++++++- 5 files changed, 44 insertions(+), 7 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 014b721..9a00a9c 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -626,6 +626,8 @@ data DynFlags = DynFlags { -- | what kind of {-# SCC #-} to add automatically profAuto :: ProfAuto, + interactivePrint :: Maybe String, + llvmVersion :: IORef (Int) } @@ -983,7 +985,8 @@ defaultDynFlags mySettings = pprCols = 100, traceLevel = 1, profAuto = NoProfAuto, - llvmVersion = panic "defaultDynFlags: No llvmVersion" + llvmVersion = panic "defaultDynFlags: No llvmVersion", + interactivePrint = Nothing } -- Do not use tracingDynFlags! @@ -1245,7 +1248,8 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, setPgmP, addOptl, addOptP, - addCmdlineFramework, addHaddockOpts, addGhciScript + addCmdlineFramework, addHaddockOpts, addGhciScript, + setInteractivePrint :: String -> DynFlags -> DynFlags setOutputFile, setOutputHi, setDumpPrefixForce :: Maybe String -> DynFlags -> DynFlags @@ -1319,6 +1323,8 @@ addHaddockOpts f d = d{ haddockOptions = Just f} addGhciScript f d = d{ ghciScripts = f : ghciScripts d} +setInteractivePrint f d = d{ interactivePrint = Just f} + -- ----------------------------------------------------------------------------- -- Command-line options @@ -1610,7 +1616,7 @@ dynamic_flags = [ , Flag "haddock-opts" (hasArg addHaddockOpts) , Flag "hpcdir" (SepArg setOptHpcDir) , Flag "ghci-script" (hasArg addGhciScript) - + , Flag "interactive-print" (hasArg setInteractivePrint) ------- recompilation checker -------------------------------------- , Flag "recomp" (NoArg (do unSetDynFlag Opt_ForceRecomp deprecate "Use -fno-force-recomp instead")) 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 @@ -943,6 +944,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], @@ -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 eaa3554..fa87eb1 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1327,6 +1327,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) -- Don't try to typecheck if the renamer fails! ; ghciStep <- getGhciStepIO ; uniq <- newUnique + ; interPrintName <- getInteractivePrintName ; let fresh_it = itName uniq loc matches = [mkMatch [] rn_expr emptyLocalBinds] -- [it = expr] @@ -1345,7 +1346,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) (HsVar bindIOName) noSyntaxExpr -- [; print it] - print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) + print_it = L loc $ ExprStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) (HsVar thenIOName) noSyntaxExpr placeHolderType -- The plans are: 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 049b79e..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 ) @@ -450,6 +452,8 @@ runGHCi paths maybe_exprs = do when (isJust maybe_exprs && failed ok) $ liftIO (exitWith (ExitFailure 1)) + installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs) + -- if verbosity is greater than 0, or we are connected to a -- terminal, display the prompt in the interactive loop. is_tty <- liftIO (hIsTerminalDevice stdin) @@ -607,6 +611,18 @@ queryQueue = do c:cs -> do setGHCiState st{ cmdqueue = cs } return (Just c) +-- Reconfigurable pretty-printing Ticket #5461 +installInteractivePrint :: Maybe String -> Bool -> GHCi () +installInteractivePrint Nothing _ = return () +installInteractivePrint (Just ipFun) exprmode = do + ok <- trySuccess $ do + (name:_) <- GHC.parseName ipFun + 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)) + -- | The main read-eval-print loop runCommands :: InputT GHCi (Maybe String) -> InputT GHCi () runCommands = runCommands' handler @@ -1975,6 +1991,7 @@ newDynFlags interactive_only minus_opts = do packageFlags idflags1 /= packageFlags idflags0) $ do liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set" GHC.setInteractiveDynFlags idflags1 + installInteractivePrint (interactivePrint idflags1) False dflags0 <- getDynFlags when (not interactive_only) $ do -- 1.7.11