Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/bec0737c9a96eb19f521a07de615366433ce6a4d >--------------------------------------------------------------- commit bec0737c9a96eb19f521a07de615366433ce6a4d Author: Vitaly Bragilesky <[email protected]> Date: Thu Jun 21 12:26:29 2012 +0400 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/compiler/main/DynFlags.hs +++ b/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")) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index eaa3554..2c5084c 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/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: diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 049b79e..3231634 100644 --- a/ghc/InteractiveUI.hs +++ b/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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
