Ticket #5461: 0001-Implemented-reconfigurable-pretty-printing-5461.patch

File 0001-Implemented-reconfigurable-pretty-printing-5461.patch, 8.7 KB (added by bravit, 6 years ago)
  • compiler/main/DynFlags.hs

    From 610490432043993286ec60486fe468313ec794ea Mon Sep 17 00:00:00 2001
    From: Vitaly Bragilevsky <bravit111@gmail.com>
    Date: Sun, 24 Jun 2012 21:46:11 +0400
    Subject: [PATCH] Implemented reconfigurable pretty-printing (#5461)
    
    ---
     compiler/main/DynFlags.hs         | 12 +++++++++---
     compiler/main/HscTypes.lhs        | 14 ++++++++++++--
     compiler/typecheck/TcRnDriver.lhs |  3 ++-
     compiler/typecheck/TcRnMonad.lhs  |  3 +++
     ghc/InteractiveUI.hs              | 19 ++++++++++++++++++-
     5 files changed, 44 insertions(+), 7 deletions(-)
    
    diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
    index 014b721..9a00a9c 100644
    a b data DynFlags = DynFlags { 
    626626  -- | what kind of {-# SCC #-} to add automatically
    627627  profAuto              :: ProfAuto,
    628628
     629  interactivePrint      :: Maybe String,
     630
    629631  llvmVersion           :: IORef (Int)
    630632 }
    631633
    defaultDynFlags mySettings = 
    983985        pprCols = 100,
    984986        traceLevel = 1,
    985987        profAuto = NoProfAuto,
    986         llvmVersion = panic "defaultDynFlags: No llvmVersion"
     988        llvmVersion = panic "defaultDynFlags: No llvmVersion",
     989        interactivePrint = Nothing
    987990      }
    988991
    989992-- Do not use tracingDynFlags!
    setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, 
    12451248         setDylibInstallName,
    12461249         setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode,
    12471250         setPgmP, addOptl, addOptP,
    1248          addCmdlineFramework, addHaddockOpts, addGhciScript
     1251         addCmdlineFramework, addHaddockOpts, addGhciScript,
     1252         setInteractivePrint
    12491253   :: String -> DynFlags -> DynFlags
    12501254setOutputFile, setOutputHi, setDumpPrefixForce
    12511255   :: Maybe String -> DynFlags -> DynFlags
    addHaddockOpts f d = d{ haddockOptions = Just f} 
    13191323
    13201324addGhciScript f d = d{ ghciScripts = f : ghciScripts d}
    13211325
     1326setInteractivePrint f d = d{ interactivePrint = Just f}
     1327
    13221328-- -----------------------------------------------------------------------------
    13231329-- Command-line options
    13241330
    dynamic_flags = [ 
    16101616  , Flag "haddock-opts"   (hasArg addHaddockOpts)
    16111617  , Flag "hpcdir"         (SepArg setOptHpcDir)
    16121618  , Flag "ghci-script"    (hasArg addGhciScript)
    1613 
     1619  , Flag "interactive-print" (hasArg setInteractivePrint)
    16141620        ------- recompilation checker --------------------------------------
    16151621  , Flag "recomp"         (NoArg (do unSetDynFlag Opt_ForceRecomp
    16161622                                     deprecate "Use -fno-force-recomp instead"))
  • compiler/main/HscTypes.lhs

    diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
    index 1631e8c..156f081 100644
    a b module HscTypes ( 
    4444        InteractiveContext(..), emptyInteractiveContext,
    4545        icPrintUnqual, icInScopeTTs, icPlusGblRdrEnv,
    4646        extendInteractiveContext, substInteractiveContext,
     47        setInteractivePrintName,
    4748        InteractiveImport(..),
    4849        mkPrintUnqualified, pprModulePrefix,
    4950
    import Annotations 
    136137import Class
    137138import TyCon
    138139import DataCon
    139 import PrelNames        ( gHC_PRIM, ioTyConName )
     140import PrelNames        ( gHC_PRIM, ioTyConName, printName )
    140141import Packages hiding  ( Version(..) )
    141142import DynFlags
    142143import DriverPhases
    data InteractiveContext 
    943944
    944945         ic_fix_env :: FixityEnv,
    945946            -- ^ Fixities declared in let statements
     947         
     948         ic_int_print  :: Name,
     949             -- ^ The function that is used for printing results
     950             -- of expressions in ghci and -e mode.
    946951
    947952#ifdef GHCI
    948953          ic_resume :: [Resume],
    emptyInteractiveContext dflags 
    986991                         ic_sys_vars   = [],
    987992                         ic_instances  = ([],[]),
    988993                         ic_fix_env    = emptyNameEnv,
     994                         -- System.IO.print by default
     995                         ic_int_print  = printName,
    989996#ifdef GHCI
    990997                         ic_resume     = [],
    991998#endif
    extendInteractiveContext ictxt new_tythings 
    10201027
    10211028    new_names = [ nameOccName (getName id) | AnId id <- new_tythings ]
    10221029
     1030setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
     1031setInteractivePrintName ic n = ic{ic_int_print = n}
     1032
    10231033    -- ToDo: should not add Ids to the gbl env here
    10241034
    10251035-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing
    exposed (say P2), so we use M.T for that, and P1:M.T for the other one. 
    10901100This is handled by the qual_mod component of PrintUnqualified, inside
    10911101the (ppr mod) of case (3), in Name.pprModulePrefix
    10921102
    1093 \begin{code}
     1103    \begin{code}
    10941104-- | Creates some functions that work out the best ways to format
    10951105-- names for the user according to a set of heuristics
    10961106mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified
  • compiler/typecheck/TcRnDriver.lhs

    diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
    index eaa3554..fa87eb1 100644
    a b tcUserStmt (L loc (ExprStmt expr _ _ _)) 
    13271327               -- Don't try to typecheck if the renamer fails!
    13281328        ; ghciStep <- getGhciStepIO
    13291329        ; uniq <- newUnique
     1330        ; interPrintName <- getInteractivePrintName
    13301331        ; let fresh_it  = itName uniq loc
    13311332              matches   = [mkMatch [] rn_expr emptyLocalBinds]
    13321333              -- [it = expr]
    tcUserStmt (L loc (ExprStmt expr _ _ _)) 
    13451346                                           (HsVar bindIOName) noSyntaxExpr
    13461347
    13471348              -- [; print it]
    1348               print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
     1349              print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))
    13491350                                           (HsVar thenIOName) noSyntaxExpr placeHolderType
    13501351
    13511352        -- The plans are:
  • compiler/typecheck/TcRnMonad.lhs

    diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
    index 8acd0db..f685998 100644
    a b getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) } 
    493493getGHCiMonad :: TcRn Name
    494494getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
    495495
     496getInteractivePrintName :: TcRn Name
     497getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
     498
    496499tcIsHsBoot :: TcRn Bool
    497500tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
    498501
  • ghc/InteractiveUI.hs

    diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
    index 049b79e..d9d6bc2 100644
    a b import Debugger 
    2121
    2222-- The GHC interface
    2323import DynFlags
     24import GhcMonad ( modifySession )
    2425import qualified GHC
    2526import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
    2627             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
    2728             handleSourceError )
    2829import HsImpExp
    29 import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs )
     30import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs, hsc_IC,
     31                  setInteractivePrintName )
    3032import Module
    3133import Name
    3234import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap )
    runGHCi paths maybe_exprs = do 
    450452     when (isJust maybe_exprs && failed ok) $
    451453        liftIO (exitWith (ExitFailure 1))
    452454
     455  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)
     456
    453457  -- if verbosity is greater than 0, or we are connected to a
    454458  -- terminal, display the prompt in the interactive loop.
    455459  is_tty <- liftIO (hIsTerminalDevice stdin)
    queryQueue = do 
    607611    c:cs -> do setGHCiState st{ cmdqueue = cs }
    608612               return (Just c)
    609613
     614-- Reconfigurable pretty-printing Ticket #5461
     615installInteractivePrint :: Maybe String -> Bool -> GHCi ()
     616installInteractivePrint Nothing _  = return ()
     617installInteractivePrint (Just ipFun) exprmode = do
     618  ok <- trySuccess $ do
     619                (name:_) <- GHC.parseName ipFun
     620                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
     621                                      in he{hsc_IC = new_ic})
     622                return Succeeded
     623
     624  when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))
     625
    610626-- | The main read-eval-print loop
    611627runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
    612628runCommands = runCommands' handler
    newDynFlags interactive_only minus_opts = do 
    19751991              packageFlags idflags1 /= packageFlags idflags0) $ do
    19761992          liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
    19771993      GHC.setInteractiveDynFlags idflags1
     1994      installInteractivePrint (interactivePrint idflags1) False
    19781995
    19791996      dflags0 <- getDynFlags
    19801997      when (not interactive_only) $ do