{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.182 2005/01/12 12:44:25 ross Exp $
+-- $Id: InteractiveUI.hs,v 1.187 2005/02/04 13:32:28 simonmar Exp $
--
-- GHC Interactive User Interface
--
ghciWelcomeMsg
) where
-#include "../includes/ghcconfig.h"
#include "HsVersions.h"
import CompManager
-import HscTypes ( HomeModInfo(hm_linkable), HomePackageTable,
- isObjectLinkable, GhciMode(..) )
+import HscTypes ( GhciMode(..) )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
import FunDeps ( pprFundeps )
import DriverUtil ( remove_spaces )
import Linker ( showLinkerState, linkPackages )
import Util
-import Module ( showModMsg, lookupModuleEnv )
import Name ( Name, NamedThing(..) )
import OccName ( OccName, isSymOcc, occNameUserString )
import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
import Outputable
-import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt_unset )
+import CmdLineOpts ( DynFlags(..) )
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 Foreign.StablePtr ( newStablePtr )
import GHC.Exts ( unsafeCoerce# )
+import GHC.IOBase ( IOErrorType(InvalidArgument) )
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
when prompt (io (putStr (mkPrompt mod imports)))
l <- io (IO.try (hGetLine hdl))
case l of
- Left e | isEOFError e -> return ()
- | otherwise -> io (ioError e)
+ Left e | isEOFError e -> return ()
+ | InvalidArgument <- etype -> return ()
+ | otherwise -> io (ioError e)
+ where etype = ioeGetErrorType e
+ -- treat InvalidArgument in the same way as EOF:
+ -- this can happen if the user closed stdin, or
+ -- perhaps did getContents which closes stdin at
+ -- EOF.
Right l ->
case remove_spaces l of
"" -> fileLoop hdl prompt
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
showThing :: GetInfoResult -> SDoc
showThing (wanted_str, (thing, fixity, src_loc, insts))
- = vcat [ showDecl want_name thing,
+ = vcat [ showWithLoc src_loc (showDecl 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.
["linker"] -> io showLinkerState
_ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
-showModules = do
- cms <- getCmState
- let (mg, hpt) = cmGetModInfo cms
- mapM_ (showModule hpt) mg
-
-
-showModule :: HomePackageTable -> ModSummary -> GHCi ()
-showModule hpt mod_summary
- = case lookupModuleEnv hpt mod of
- Nothing -> panic "missing linkable"
- Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
- where
- obj_linkable = isObjectLinkable (hm_linkable mod_info)
- where
- mod = ms_mod mod_summary
- locn = ms_location mod_summary
+showModules
+ = do { cms <- getCmState
+ ; let show_one ms = io (putStrLn (cmShowModule cms ms))
+ ; mapM_ show_one (cmGetModuleGraph cms) }
showBindings = do
cms <- getCmState