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 ( |
80 | 80 | setPackageName, |
81 | 81 | doingTickyProfiling, |
82 | 82 | |
| 83 | setInteractivePrintName, -- Name -> DynFlags -> DynFlags |
| 84 | |
83 | 85 | -- ** Parsing DynFlags |
84 | 86 | parseDynamicFlagsCmdLine, |
85 | 87 | parseDynamicFilePragma, |
… |
… |
module DynFlags ( |
109 | 111 | #include "HsVersions.h" |
110 | 112 | |
111 | 113 | import Platform |
| 114 | import Name |
112 | 115 | import Module |
113 | 116 | import PackageConfig |
114 | 117 | import PrelNames ( mAIN ) |
… |
… |
data DynFlags = DynFlags { |
626 | 629 | -- | what kind of {-# SCC #-} to add automatically |
627 | 630 | profAuto :: ProfAuto, |
628 | 631 | |
629 | | llvmVersion :: IORef (Int) |
| 632 | llvmVersion :: IORef (Int), |
| 633 | |
| 634 | interactivePrint :: Maybe String, |
| 635 | interactivePrintName :: Maybe Name |
630 | 636 | } |
631 | 637 | |
632 | 638 | class HasDynFlags m where |
… |
… |
defaultDynFlags mySettings = |
983 | 989 | pprCols = 100, |
984 | 990 | traceLevel = 1, |
985 | 991 | profAuto = NoProfAuto, |
986 | | llvmVersion = panic "defaultDynFlags: No llvmVersion" |
| 992 | llvmVersion = panic "defaultDynFlags: No llvmVersion", |
| 993 | interactivePrint = Nothing, |
| 994 | interactivePrintName = Nothing |
987 | 995 | } |
988 | 996 | |
989 | 997 | -- Do not use tracingDynFlags! |
… |
… |
setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, |
1245 | 1253 | setDylibInstallName, |
1246 | 1254 | setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, |
1247 | 1255 | setPgmP, addOptl, addOptP, |
1248 | | addCmdlineFramework, addHaddockOpts, addGhciScript |
| 1256 | addCmdlineFramework, addHaddockOpts, addGhciScript, |
| 1257 | setInteractivePrint |
1249 | 1258 | :: String -> DynFlags -> DynFlags |
1250 | 1259 | setOutputFile, setOutputHi, setDumpPrefixForce |
1251 | 1260 | :: Maybe String -> DynFlags -> DynFlags |
… |
… |
addHaddockOpts f d = d{ haddockOptions = Just f} |
1319 | 1328 | |
1320 | 1329 | addGhciScript f d = d{ ghciScripts = f : ghciScripts d} |
1321 | 1330 | |
| 1331 | setInteractivePrint f d = d{ interactivePrint = Just f} |
| 1332 | |
| 1333 | setInteractivePrintName :: Name -> DynFlags -> DynFlags |
| 1334 | setInteractivePrintName f d = d{ interactivePrintName = Just f} |
| 1335 | |
1322 | 1336 | -- ----------------------------------------------------------------------------- |
1323 | 1337 | -- Command-line options |
1324 | 1338 | |
… |
… |
dynamic_flags = [ |
1610 | 1624 | , Flag "haddock-opts" (hasArg addHaddockOpts) |
1611 | 1625 | , Flag "hpcdir" (SepArg setOptHpcDir) |
1612 | 1626 | , Flag "ghci-script" (hasArg addGhciScript) |
1613 | | |
| 1627 | , Flag "interactive-print" (hasArg setInteractivePrint) |
1614 | 1628 | ------- recompilation checker -------------------------------------- |
1615 | 1629 | , Flag "recomp" (NoArg (do unSetDynFlag Opt_ForceRecomp |
1616 | 1630 | deprecate "Use -fno-force-recomp instead")) |
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index d4eb931..6335dcd 100644
a
|
b
|
tcUserStmt :: LStmt RdrName -> TcM (PlanResult, FixityEnv) |
1324 | 1324 | tcUserStmt (L loc (ExprStmt expr _ _ _)) |
1325 | 1325 | = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) |
1326 | 1326 | -- Don't try to typecheck if the renamer fails! |
| 1327 | ; dynFlags <- getDynFlags |
1327 | 1328 | ; ghciStep <- getGhciStepIO |
1328 | 1329 | ; uniq <- newUnique |
1329 | 1330 | ; let fresh_it = itName uniq loc |
… |
… |
tcUserStmt (L loc (ExprStmt expr _ _ _)) |
1344 | 1345 | (HsVar bindIOName) noSyntaxExpr |
1345 | 1346 | |
1346 | 1347 | -- [; 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)) |
1348 | 1350 | (HsVar thenIOName) noSyntaxExpr placeHolderType |
1349 | 1351 | |
1350 | 1352 | -- The plans are: |
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index c56f506..74b5e7f 100644
a
|
b
|
runGHCi paths maybe_exprs = do |
449 | 449 | when (isJust maybe_exprs && failed ok) $ |
450 | 450 | liftIO (exitWith (ExitFailure 1)) |
451 | 451 | |
| 452 | installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs) |
| 453 | |
452 | 454 | -- if verbosity is greater than 0, or we are connected to a |
453 | 455 | -- terminal, display the prompt in the interactive loop. |
454 | 456 | is_tty <- liftIO (hIsTerminalDevice stdin) |
… |
… |
queryQueue = do |
606 | 608 | c:cs -> do setGHCiState st{ cmdqueue = cs } |
607 | 609 | return (Just c) |
608 | 610 | |
| 611 | -- Reconfigurable pretty-printing Ticket #5461 |
| 612 | installInteractivePrint :: Maybe String -> Bool -> GHCi () |
| 613 | installInteractivePrint Nothing _ = return () |
| 614 | installInteractivePrint (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 | |
609 | 623 | -- | The main read-eval-print loop |
610 | 624 | runCommands :: InputT GHCi (Maybe String) -> InputT GHCi () |
611 | 625 | runCommands = runCommands' handler |
… |
… |
newDynFlags interactive_only minus_opts = do |
1974 | 1988 | packageFlags idflags1 /= packageFlags idflags0) $ do |
1975 | 1989 | liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set" |
1976 | 1990 | GHC.setInteractiveDynFlags idflags1 |
| 1991 | installInteractivePrint (interactivePrint idflags1) False |
1977 | 1992 | |
1978 | 1993 | dflags0 <- getDynFlags |
1979 | 1994 | when (not interactive_only) $ do |