Commit bec0737c authored by Vitaly Bragilevsky's avatar Vitaly Bragilevsky Committed by pcapriotti

Implemented feature request on reconfigurable pretty-printing in GHCi (#5461)

parent 66c41963
......@@ -80,6 +80,8 @@ module DynFlags (
setPackageName,
doingTickyProfiling,
setInteractivePrintName, -- Name -> DynFlags -> DynFlags
-- ** Parsing DynFlags
parseDynamicFlagsCmdLine,
parseDynamicFilePragma,
......@@ -109,6 +111,7 @@ module DynFlags (
#include "HsVersions.h"
import Platform
import Name
import Module
import PackageConfig
import PrelNames ( mAIN )
......@@ -626,7 +629,10 @@ data DynFlags = DynFlags {
-- | what kind of {-# SCC #-} to add automatically
profAuto :: ProfAuto,
llvmVersion :: IORef (Int)
llvmVersion :: IORef (Int),
interactivePrint :: Maybe String,
interactivePrintName :: Maybe Name
}
class HasDynFlags m where
......@@ -983,7 +989,9 @@ defaultDynFlags mySettings =
pprCols = 100,
traceLevel = 1,
profAuto = NoProfAuto,
llvmVersion = panic "defaultDynFlags: No llvmVersion"
llvmVersion = panic "defaultDynFlags: No llvmVersion",
interactivePrint = Nothing,
interactivePrintName = Nothing
}
-- Do not use tracingDynFlags!
......@@ -1245,7 +1253,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 +1328,11 @@ addHaddockOpts f d = d{ haddockOptions = Just f}
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
......@@ -1610,7 +1624,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"))
......
......@@ -1325,6 +1325,7 @@ 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
; let fresh_it = itName uniq loc
......@@ -1345,7 +1346,8 @@ tcUserStmt (L loc (ExprStmt expr _ _ _))
(HsVar bindIOName) noSyntaxExpr
-- [; print it]
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
interPrintName = maybe printName id (interactivePrintName dynFlags)
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))
(HsVar thenIOName) noSyntaxExpr placeHolderType
-- The plans are:
......
......@@ -450,6 +450,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 +609,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
dflags <- getDynFlags
GHC.setInteractiveDynFlags (setInteractivePrintName name dflags)
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 +1989,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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment