Ticket #5461: 0001-Implemented-feature-request-on-reconfigurable-pretty.patch

File 0001-Implemented-feature-request-on-reconfigurable-pretty.patch, 5.9 KB (added by bravit, 4 years ago)

  • compiler/main/DynFlags.hs 

    From 62cf92c94d00c75700e771b71533fa951fbeda45 Mon Sep 17 00:00:00 2001
From: Vitaly Bragilesky <bravit111@gmail.com>
Date: Thu, 21 Jun 2012 12:26:29 +0400
Subject: [PATCH] Implemented feature request on reconfigurable
 pretty-printing in GHCi (#5461)

---
 compiler/main/DynFlags.hs         | 22 ++++++++++++++++++----
 compiler/typecheck/TcRnDriver.lhs |  4 +++-
 ghc/InteractiveUI.hs              | 15 +++++++++++++++
 3 files changed, 36 insertions(+), 5 deletions(-)

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 014b721..d81b483 100644
    a b module DynFlags ( 
    8080        setPackageName,
    8181        doingTickyProfiling,
    8282
     83        setInteractivePrintName,        -- Name -> DynFlags -> DynFlags
     84
    8385        -- ** Parsing DynFlags
    8486        parseDynamicFlagsCmdLine,
    8587        parseDynamicFilePragma,
    … … module DynFlags ( 
    109111#include "HsVersions.h"
    110112
    111113import Platform
     114import Name
    112115import Module
    113116import PackageConfig
    114117import PrelNames        ( mAIN )
    … … data DynFlags = DynFlags { 
    626629  -- | what kind of {-# SCC #-} to add automatically
    627630  profAuto              :: ProfAuto,
    628631
    629   llvmVersion           :: IORef (Int)
     632  llvmVersion           :: IORef (Int),
     633
     634  interactivePrint      :: Maybe String,
     635  interactivePrintName  :: Maybe Name
    630636 }
    631637
    632638class HasDynFlags m where
    … … defaultDynFlags mySettings = 
    983989        pprCols = 100,
    984990        traceLevel = 1,
    985991        profAuto = NoProfAuto,
    986         llvmVersion = panic "defaultDynFlags: No llvmVersion"
     992        llvmVersion = panic "defaultDynFlags: No llvmVersion",
     993        interactivePrint = Nothing,
     994        interactivePrintName = Nothing
    987995      }
    988996
    989997-- Do not use tracingDynFlags!
    … … setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, 
    12451253         setDylibInstallName,
    12461254         setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode,
    12471255         setPgmP, addOptl, addOptP,
    1248          addCmdlineFramework, addHaddockOpts, addGhciScript
     1256         addCmdlineFramework, addHaddockOpts, addGhciScript,
     1257         setInteractivePrint
    12491258   :: String -> DynFlags -> DynFlags
    12501259setOutputFile, setOutputHi, setDumpPrefixForce
    12511260   :: Maybe String -> DynFlags -> DynFlags
    … … addHaddockOpts f d = d{ haddockOptions = Just f} 
    13191328
    13201329addGhciScript f d = d{ ghciScripts = f : ghciScripts d}
    13211330
     1331setInteractivePrint f d = d{ interactivePrint = Just f}
     1332
     1333setInteractivePrintName :: Name -> DynFlags -> DynFlags
     1334setInteractivePrintName f d = d{ interactivePrintName = Just f}
     1335
    13221336-- -----------------------------------------------------------------------------
    13231337-- Command-line options
    13241338
    … … dynamic_flags = [ 
    16101624  , Flag "haddock-opts"   (hasArg addHaddockOpts)
    16111625  , Flag "hpcdir"         (SepArg setOptHpcDir)
    16121626  , Flag "ghci-script"    (hasArg addGhciScript)
    1613 
     1627  , Flag "interactive-print" (hasArg setInteractivePrint)
    16141628        ------- recompilation checker --------------------------------------
    16151629  , Flag "recomp"         (NoArg (do unSetDynFlag Opt_ForceRecomp
    16161630                                     deprecate "Use -fno-force-recomp instead"))

  • compiler/typecheck/TcRnDriver.lhs 

    diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index d4eb931..6335dcd 100644
    a b tcUserStmt :: LStmt RdrName -> TcM (PlanResult, FixityEnv) 
    13241324tcUserStmt (L loc (ExprStmt expr _ _ _))
    13251325  = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
    13261326               -- Don't try to typecheck if the renamer fails!
     1327        ; dynFlags <- getDynFlags
    13271328        ; ghciStep <- getGhciStepIO
    13281329        ; uniq <- newUnique
    13291330        ; let fresh_it  = itName uniq loc
    … … tcUserStmt (L loc (ExprStmt expr _ _ _)) 
    13441345                                           (HsVar bindIOName) noSyntaxExpr
    13451346
    13461347              -- [; print it]
    1347               print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
     1348              interPrintName = maybe printName id (interactivePrintName dynFlags)
     1349              print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))
    13481350                                           (HsVar thenIOName) noSyntaxExpr placeHolderType
    13491351
    13501352        -- The plans are:

  • ghc/InteractiveUI.hs 

    diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index c56f506..74b5e7f 100644
    a b runGHCi paths maybe_exprs = do 
    449449     when (isJust maybe_exprs && failed ok) $
    450450        liftIO (exitWith (ExitFailure 1))
    451451
     452  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)
     453
    452454  -- if verbosity is greater than 0, or we are connected to a
    453455  -- terminal, display the prompt in the interactive loop.
    454456  is_tty <- liftIO (hIsTerminalDevice stdin)
    … … queryQueue = do 
    606608    c:cs -> do setGHCiState st{ cmdqueue = cs }
    607609               return (Just c)
    608610
     611-- Reconfigurable pretty-printing Ticket #5461
     612installInteractivePrint :: Maybe String -> Bool -> GHCi ()
     613installInteractivePrint Nothing _  = return ()
     614installInteractivePrint (Just ipFun) exprmode = do
     615  ok <- trySuccess $ do
     616                (name:_) <- GHC.parseName ipFun
     617                dflags <- getDynFlags
     618                GHC.setInteractiveDynFlags (setInteractivePrintName name dflags)
     619                return Succeeded
     620
     621  when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))
     622
    609623-- | The main read-eval-print loop
    610624runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
    611625runCommands = runCommands' handler
    … … newDynFlags interactive_only minus_opts = do 
    19741988              packageFlags idflags1 /= packageFlags idflags0) $ do
    19751989          liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
    19761990      GHC.setInteractiveDynFlags idflags1
     1991      installInteractivePrint (interactivePrint idflags1) False
    19771992
    19781993      dflags0 <- getDynFlags
    19791994      when (not interactive_only) $ do