[project @ 2005-02-25 13:06:31 by simonpj]
[ghc-hetmet.git] / ghc / compiler / ghci / InteractiveUI.hs
index ec59f0b..a686e43 100644 (file)
@@ -1,6 +1,6 @@
 {-# 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
 --
@@ -15,10 +15,11 @@ module InteractiveUI (
 #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
@@ -26,10 +27,10 @@ import DriverUtil   ( remove_spaces )
 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 )
@@ -51,7 +52,7 @@ import System.Console.Readline as Readline
 
 import Control.Exception as Exception
 import Data.Dynamic
-import Control.Concurrent
+-- import Control.Concurrent
 
 import Numeric
 import Data.List
@@ -59,6 +60,7 @@ import Data.Int               ( Int64 )
 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
@@ -247,7 +249,7 @@ runGHCi paths dflags maybe_expr = do
            interactiveLoop is_tty show_prompt
        Just expr -> do
            -- just evaluate the expression we were given
-           runCommand expr
+           runCommandEval expr
            return ()
 
   -- and finally, exit
@@ -357,6 +359,15 @@ readlineLoop = do
 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
@@ -400,7 +411,7 @@ runStmt stmt
       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
@@ -446,9 +457,9 @@ noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
 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
@@ -488,18 +499,19 @@ info :: String -> GHCi ()
 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
@@ -508,31 +520,35 @@ showThing  (wanted_str, (thing, fixity, src_loc, insts))
        | 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))
@@ -579,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
@@ -600,8 +622,7 @@ 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)
 
 
 -----------------------------------------------------------------------------
@@ -790,8 +811,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)
       )))
 
 -----------------------------------------------------------------------------