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

3 files changed, 36 insertions, 5 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 014b721a1b..d81b48393f 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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"))
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index eaa35548a9..2c5084c6bc 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -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:
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 049b79eba9..32316341e1 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -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