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, 22 months 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