{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.185 2005/01/28 12:55:23 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.191 2005/02/25 13:07:10 simonpj Exp $
--
-- GHC Interactive User Interface
--
#include "HsVersions.h"
import CompManager
-import HscTypes ( HomeModInfo(hm_linkable), HomePackageTable,
- isObjectLinkable, GhciMode(..) )
-import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
- IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
+import HscTypes ( GhciMode(..) )
+import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
+ IfaceConDecl(..), IfaceType,
+ IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType,
+ pprIfaceForAllPart, pprIfaceType )
import FunDeps ( pprFundeps )
import DriverFlags
import DriverState
import Linker ( showLinkerState, linkPackages )
import Util
import Name ( Name, NamedThing(..) )
-import OccName ( OccName, isSymOcc, occNameUserString )
+import OccName ( OccName, parenSymOcc, occNameUserString )
import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
import Outputable
-import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt_unset )
+import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt )
import Panic hiding ( showException )
import Config
import SrcLoc ( SrcLoc, isGoodSrcLoc )
import Control.Exception as Exception
import Data.Dynamic
-import Control.Concurrent
+-- import Control.Concurrent
import Numeric
import Data.List
import System.Cmd
import System.CPUTime
import System.Environment
+import System.Exit ( exitWith, ExitCode(..) )
import System.Directory
import System.IO
import System.IO.Error as IO
interactiveLoop is_tty show_prompt
Just expr -> do
-- just evaluate the expression we were given
- runCommand expr
+ runCommandEval expr
return ()
-- and finally, exit
runCommand :: String -> GHCi Bool
runCommand c = ghciHandle handler (doCommand c)
+-- This version is for the GHC command-line option -e. The only difference
+-- from runCommand is that it catches the ExitException exception and
+-- exits, rather than printing out the exception.
+runCommandEval c = ghciHandle handleEval (doCommand c)
+ where
+ handleEval (ExitException code) = io (exitWith code)
+ handleEval e = do showException e
+ io (exitWith (ExitFailure 1))
+
-- This is the exception handler for exceptions generated by the
-- user's code; it normally just prints out the exception. The
-- handler must be recursive, in case showing the exception causes
setGHCiState st{cmstate = new_cmstate}
case result of
CmRunFailed -> return []
- CmRunException e -> showException e >> return []
+ CmRunException e -> throw e -- this is caught by runCommand(Eval)
CmRunOk names -> return names
-- possibly print the type and revert CAFs after evaluating an expression
GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
-no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
- " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
-flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
+no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
+ " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
+flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
initInterpBuffering :: CmState -> IO ()
initInterpBuffering cmstate
info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
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 [ 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,
- show_loc src_loc,
vcat (map show_inst insts)]
where
want_name occ = wanted_str == occNameUserString occ
| fix == defaultFixity = empty
| otherwise = ppr fix <+> text wanted_str
+ show_inst (iface_inst, loc)
+ = showWithLoc loc (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
+
+showWithLoc :: SrcLoc -> SDoc -> SDoc
+showWithLoc loc doc
+ = hang doc 2 (char '\t' <> show_loc loc)
+ -- The tab tries to make them line up a bit
+ where
show_loc loc -- The ppr function for SrcLocs is a bit wonky
| isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
| otherwise = comment <+> ppr loc
comment = ptext SLIT("--")
- show_inst (iface_inst, loc)
- = hang (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
- 2 (char '\t' <> show_loc loc)
- -- The tab tries to make them line up a bit
-- 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))
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
ppr_bndr :: OccName -> SDoc
-- Wrap operators in ()
-ppr_bndr occ | isSymOcc occ = parens (ppr occ)
- | otherwise = ppr occ
+ppr_bndr occ = parenSymOcc occ (ppr occ)
-----------------------------------------------------------------------------
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)
)))
-----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff