From 6b4e00e082b0f4f2445fabbfacae730576adfa2c Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 23 Feb 2005 15:38:52 +0000 Subject: [PATCH] [project @ 2005-02-23 15:38:52 by simonmar] Make :info behave like :type, and show foralls when -fglasgow-exts is on. --- ghc/compiler/ghci/InteractiveUI.hs | 76 ++++++++++++++++++------------------ 1 file changed, 39 insertions(+), 37 deletions(-) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 22dae45..42f6b1b 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.189 2005/02/23 12:44:17 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.190 2005/02/23 15:38:52 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -16,8 +16,10 @@ module InteractiveUI ( import CompManager import HscTypes ( GhciMode(..) ) -import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..), - IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart ) +import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), + IfaceConDecl(..), IfaceType, + IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, + pprIfaceForAllPart, pprIfaceType ) import FunDeps ( pprFundeps ) import DriverFlags import DriverState @@ -26,10 +28,9 @@ import Linker ( showLinkerState, linkPackages ) import Util import Name ( Name, NamedThing(..) ) import OccName ( OccName, isSymOcc, occNameUserString ) -import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..), - failed ) +import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) ) import Outputable -import CmdLineOpts ( DynFlags(..) ) +import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) import Panic hiding ( showException ) import Config import SrcLoc ( SrcLoc, isGoodSrcLoc ) @@ -56,7 +57,6 @@ import Data.Dynamic import Numeric import Data.List import Data.Int ( Int64 ) -import Data.Maybe ( isJust ) import System.Cmd import System.CPUTime import System.Environment @@ -95,7 +95,7 @@ builtin_commands = [ ("help", keepGoing help), ("?", keepGoing help), ("info", keepGoing info), - ("load", keepGoingPaths loadModule_), + ("load", keepGoingPaths loadModule), ("module", keepGoing setContext), ("reload", keepGoing reloadModule), ("set", keepGoing setCmd), @@ -234,13 +234,9 @@ runGHCi paths dflags maybe_expr = do Right hdl -> fileLoop hdl False -- Perform a :load for files given on the GHCi command line - -- When in -e mode, if the load fails then we want to stop - -- immediately rather than going on to evaluate the expression. - when (not (null paths)) $ do - ok <- ghciHandle (\e -> do showException e; return Failed) $ - loadModule paths - when (isJust maybe_expr && failed ok) $ - io (exitWith (ExitFailure 1)) + when (not (null paths)) $ + ghciHandle showException $ + loadModule paths -- if verbosity is greater than 0, or we are connected to a -- terminal, display the prompt in the interactive loop. @@ -503,16 +499,18 @@ info :: String -> GHCi () info "" = throwDyn (CmdLineError "syntax: ':i '") info s = do { let names = words s ; init_cms <- getCmState - ; mapM_ (infoThing init_cms) names } + ; dflags <- getDynFlags + ; let exts = dopt Opt_GlasgowExts dflags + ; mapM_ (infoThing exts init_cms) names } where - infoThing cms name + infoThing exts cms name = do { stuff <- io (cmGetInfo cms name) ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $ - vcat (intersperse (text "") (map showThing stuff)))) } + vcat (intersperse (text "") (map (showThing exts) stuff)))) } -showThing :: GetInfoResult -> SDoc -showThing (wanted_str, (thing, fixity, src_loc, insts)) - = vcat [ showWithLoc src_loc (showDecl want_name thing), +showThing :: Bool -> GetInfoResult -> SDoc +showThing exts (wanted_str, (thing, fixity, src_loc, insts)) + = vcat [ showWithLoc src_loc (showDecl exts want_name thing), show_fixity fixity, vcat (map show_inst insts)] where @@ -539,18 +537,18 @@ showWithLoc loc doc -- Now there is rather a lot of goop just to print declarations in a -- civilised way with "..." for the parts we are less interested in. -showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc -showDecl want_name (IfaceForeign {ifName = tc}) +showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc +showDecl exts want_name (IfaceForeign {ifName = tc}) = ppr tc <+> ptext SLIT("is a foreign type") -showDecl want_name (IfaceId {ifName = var, ifType = ty}) - = ppr var <+> dcolon <+> ppr ty +showDecl exts want_name (IfaceId {ifName = var, ifType = ty}) + = ppr var <+> dcolon <+> showType exts ty -showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) +showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) 2 (equals <+> ppr mono_ty) -showDecl want_name (IfaceData {ifName = tycon, +showDecl exts want_name (IfaceData {ifName = tycon, ifTyVars = tyvars, ifCons = condecls}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 2 (add_bars (ppr_trim show_con cs)) @@ -597,15 +595,21 @@ showDecl want_name (IfaceData {ifName = tycon, ppr_str MarkedUnboxed = ptext SLIT("!!") ppr_str NotMarkedStrict = empty -showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, +showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, ifFDs = fds, ifSigs = sigs}) = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds <+> ptext SLIT("where")) 2 (vcat (ppr_trim show_op sigs)) where show_op (IfaceClassOp op dm ty) - | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty) - | otherwise = Nothing + | want_name clas || want_name op + = Just (ppr_bndr op <+> dcolon <+> showType exts ty) + | otherwise + = Nothing + +showType :: Bool -> IfaceType -> SDoc +showType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls +showType False ty = ppr ty -- otherwise, print without the foralls ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc] ppr_trim show xs @@ -692,13 +696,10 @@ undefineMacro macro_name = do io (writeIORef commands (filter ((/= macro_name) . fst) cmds)) -loadModule :: [FilePath] -> GHCi SuccessFlag +loadModule :: [FilePath] -> GHCi () loadModule fs = timeIt (loadModule' fs) -loadModule_ :: [FilePath] -> GHCi () -loadModule_ fs = do loadModule fs; return () - -loadModule' :: [FilePath] -> GHCi SuccessFlag +loadModule' :: [FilePath] -> GHCi () loadModule' files = do state <- getGHCiState @@ -720,7 +721,6 @@ loadModule' files = do setContextAfterLoad mods dflags <- getDynFlags modulesLoadedMsg ok mods dflags - return ok reloadModule :: String -> GHCi () @@ -812,8 +812,10 @@ browseModule m exports_only = do let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context + dflags <- getDynFlags + let exts = dopt Opt_GlasgowExts dflags io (putStrLn (showSDocForUser unqual ( - vcat (map (showDecl (const True)) things) + vcat (map (showDecl exts (const True)) things) ))) ----------------------------------------------------------------------------- -- 1.7.10.4