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

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"))

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:

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