ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.167 2004/07/21 09:25:42 simonpj Exp $
   4 --
   5 -- GHC Interactive User Interface
   6 --
   7 -- (c) The GHC Team 2004
   8 --
   9 -----------------------------------------------------------------------------
  10 module InteractiveUI (
  11         interactiveUI,  -- :: CmState -> [FilePath] -> IO ()
  12         ghciWelcomeMsg
  13    ) where
  14
  15 #include "../includes/config.h"
  16 #include "HsVersions.h"
  17
  18 import CompManager
  19 import HscTypes         ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
  20                           isObjectLinkable, GhciMode(..) )
  21 import IfaceSyn         ( IfaceType, IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
  22                           pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
  23 import FunDeps          ( pprFundeps )
  24 import DriverFlags
  25 import DriverState
  26 import DriverUtil       ( remove_spaces )
  27 import Linker           ( showLinkerState, linkPackages )
  28 import Util
  29 import Module           ( showModMsg, lookupModuleEnv )
  30 import Name             ( Name, isHomePackageName, nameSrcLoc, nameOccName,
  31                           NamedThing(..) )
  32 import OccName          ( OccName, isSymOcc, occNameUserString )
  33 import BasicTypes       ( StrictnessMark(..), Fixity, defaultFixity, SuccessFlag(..) )
  34 import Packages
  35 import Outputable
  36 import CmdLineOpts      ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
  37                           restoreDynFlags, dopt_unset )
  38 import Panic            hiding ( showException )
  39 import Config
  40
  41 #ifndef mingw32_HOST_OS
  42 import DriverUtil( handle )
  43 import System.Posix
  44 #if __GLASGOW_HASKELL__ > 504
  45         hiding (getEnv)
  46 #endif
  47 #endif
  48
  49 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
  50 import Control.Concurrent       ( yield )       -- Used in readline loop
  51 import System.Console.Readline as Readline
  52 #endif
  53
  54 --import SystemExts
  55
  56 import Control.Exception as Exception
  57 import Data.Dynamic
  58 import Control.Concurrent
  59
  60 import Numeric
  61 import Data.List
  62 import Data.Int         ( Int64 )
  63 import System.Cmd
  64 import System.CPUTime
  65 import System.Environment
  66 import System.Directory
  67 import System.IO as IO
  68 import Data.Char
  69 import Control.Monad as Monad
  70
  71 import GHC.Exts         ( unsafeCoerce# )
  72
  73 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  74
  75 import System.Posix.Internals ( setNonBlockingFD )
  76
  77 -----------------------------------------------------------------------------
  78
  79 ghciWelcomeMsg = "\
  80 \   ___         ___ _\n\
  81 \  / _ \\ /\\  /\\/ __(_)\n\
  82 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
  83 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  84 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  85
  86 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  87
  88 builtin_commands :: [(String, String -> GHCi Bool)]
  89 builtin_commands = [
  90   ("add",       keepGoingPaths addModule),
  91   ("browse",    keepGoing browseCmd),
  92   ("cd",        keepGoing changeDirectory),
  93   ("def",       keepGoing defineMacro),
  94   ("help",      keepGoing help),
  95   ("?",         keepGoing help),
  96   ("info",      keepGoing info),
  97   ("load",      keepGoingPaths loadModule),
  98   ("module",    keepGoing setContext),
  99   ("reload",    keepGoing reloadModule),
 100   ("set",       keepGoing setCmd),
 101   ("show",      keepGoing showCmd),
 102   ("type",      keepGoing typeOfExpr),
 103   ("kind",      keepGoing kindOfType),
 104   ("unset",     keepGoing unsetOptions),
 105   ("undef",     keepGoing undefineMacro),
 106   ("quit",      quit)
 107   ]
 108
 109 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 110 keepGoing a str = a str >> return False
 111
 112 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 113 keepGoingPaths a str = a (toArgs str) >> return False
 114
 115 shortHelpText = "use :? for help.\n"
 116
 117 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 118 helpText = "\
 119 \ Commands available from the prompt:\n\
 120 \\n\
 121 \   <stmt>                     evaluate/run <stmt>\n\
 122 \   :add <filename> ...        add module(s) to the current target set\n\
 123 \   :browse [*]<module>        display the names defined by <module>\n\
 124 \   :cd <dir>                  change directory to <dir>\n\
 125 \   :def <cmd> <expr>          define a command :<cmd>\n\
 126 \   :help, :?                  display this list of commands\n\
 127 \   :info [<name> ...]         display information about the given names\n\
 128 \   :load <filename> ...       load module(s) and their dependents\n\
 129 \   :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
 130 \   :reload                    reload the current module set\n\
 131 \\n\
 132 \   :set <option> ...          set options\n\
 133 \   :set args <arg> ...        set the arguments returned by System.getArgs\n\
 134 \   :set prog <progname>       set the value returned by System.getProgName\n\
 135 \\n\
 136 \   :show modules              show the currently loaded modules\n\
 137 \   :show bindings             show the current bindings made at the prompt\n\
 138 \\n\
 139 \   :type <expr>               show the type of <expr>\n\
 140 \   :kind <type>               show the kind of <type>\n\
 141 \   :undef <cmd>               undefine user-defined command :<cmd>\n\
 142 \   :unset <option> ...        unset options\n\
 143 \   :quit                      exit GHCi\n\
 144 \   :!<command>                run the shell command <command>\n\
 145 \\n\
 146 \ Options for `:set' and `:unset':\n\
 147 \\n\
 148 \    +r                 revert top-level expressions after each evaluation\n\
 149 \    +s                 print timing/memory stats after each evaluation\n\
 150 \    +t                 print type after evaluation\n\
 151 \    -<flags>           most GHC command line flags can also be set here\n\
 152 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 153 \"
 154
 155 interactiveUI :: [FilePath] -> Maybe String -> IO ()
 156 interactiveUI srcs maybe_expr = do
 157    dflags <- getDynFlags
 158
 159    cmstate <- cmInit Interactive dflags;
 160
 161    hFlush stdout
 162    hSetBuffering stdout NoBuffering
 163
 164         -- Initialise buffering for the *interpreted* I/O system
 165    initInterpBuffering cmstate
 166
 167         -- We don't want the cmd line to buffer any input that might be
 168         -- intended for the program, so unbuffer stdin.
 169    hSetBuffering stdin NoBuffering
 170
 171         -- initial context is just the Prelude
 172    cmstate <- cmSetContext cmstate [] ["Prelude"]
 173
 174 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 175    Readline.initialize
 176 #endif
 177
 178    startGHCi (runGHCi srcs dflags maybe_expr)
 179         GHCiState{ progname = "<interactive>",
 180                    args = [],
 181                    targets = srcs,
 182                    cmstate = cmstate,
 183                    options = [] }
 184
 185 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 186    Readline.resetTerminal Nothing
 187 #endif
 188
 189    return ()
 190
 191 runGHCi :: [FilePath] -> DynFlags -> Maybe String -> GHCi ()
 192 runGHCi paths dflags maybe_expr = do
 193   read_dot_files <- io (readIORef v_Read_DotGHCi)
 194
 195   when (read_dot_files) $ do
 196     -- Read in ./.ghci.
 197     let file = "./.ghci"
 198     exists <- io (doesFileExist file)
 199     when exists $ do
 200        dir_ok  <- io (checkPerms ".")
 201        file_ok <- io (checkPerms file)
 202        when (dir_ok && file_ok) $ do
 203           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 204           case either_hdl of
 205              Left e    -> return ()
 206              Right hdl -> fileLoop hdl False
 207
 208   when (read_dot_files) $ do
 209     -- Read in $HOME/.ghci
 210     either_dir <- io (IO.try (getEnv "HOME"))
 211     case either_dir of
 212        Left e -> return ()
 213        Right dir -> do
 214           cwd <- io (getCurrentDirectory)
 215           when (dir /= cwd) $ do
 216              let file = dir ++ "/.ghci"
 217              ok <- io (checkPerms file)
 218              when ok $ do
 219                either_hdl <- io (IO.try (openFile file ReadMode))
 220                case either_hdl of
 221                   Left e    -> return ()
 222                   Right hdl -> fileLoop hdl False
 223
 224   -- Perform a :load for files given on the GHCi command line
 225   when (not (null paths)) $
 226      ghciHandle showException $
 227         loadModule paths
 228
 229   -- if verbosity is greater than 0, or we are connected to a
 230   -- terminal, display the prompt in the interactive loop.
 231   is_tty <- io (hIsTerminalDevice stdin)
 232   let show_prompt = verbosity dflags > 0 || is_tty
 233
 234   case maybe_expr of
 235         Nothing ->
 236             -- enter the interactive loop
 237             interactiveLoop is_tty show_prompt
 238         Just expr -> do
 239             -- just evaluate the expression we were given
 240             runCommand expr
 241             return ()
 242
 243   -- and finally, exit
 244   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 245
 246
 247 interactiveLoop is_tty show_prompt = do
 248   -- Ignore ^C exceptions caught here
 249   ghciHandleDyn (\e -> case e of
 250                         Interrupted -> ghciUnblock (interactiveLoop is_tty show_prompt)
 251                         _other      -> return ()) $ do
 252
 253   -- read commands from stdin
 254 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 255   if (is_tty)
 256         then readlineLoop
 257         else fileLoop stdin show_prompt
 258 #else
 259   fileLoop stdin show_prompt
 260 #endif
 261
 262
 263 -- NOTE: We only read .ghci files if they are owned by the current user,
 264 -- and aren't world writable.  Otherwise, we could be accidentally
 265 -- running code planted by a malicious third party.
 266
 267 -- Furthermore, We only read ./.ghci if . is owned by the current user
 268 -- and isn't writable by anyone else.  I think this is sufficient: we
 269 -- don't need to check .. and ../.. etc. because "."  always refers to
 270 -- the same directory while a process is running.
 271
 272 checkPerms :: String -> IO Bool
 273 checkPerms name =
 274 #ifdef mingw32_HOST_OS
 275   return True
 276 #else
 277   DriverUtil.handle (\_ -> return False) $ do
 278      st <- getFileStatus name
 279      me <- getRealUserID
 280      if fileOwner st /= me then do
 281         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 282         return False
 283       else do
 284         let mode =  fileMode st
 285         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 286            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 287            then do
 288                putStrLn $ "*** WARNING: " ++ name ++
 289                           " is writable by someone else, IGNORING!"
 290                return False
 291           else return True
 292 #endif
 293
 294 fileLoop :: Handle -> Bool -> GHCi ()
 295 fileLoop hdl prompt = do
 296    cmstate <- getCmState
 297    (mod,imports) <- io (cmGetContext cmstate)
 298    when prompt (io (putStr (mkPrompt mod imports)))
 299    l <- io (IO.try (hGetLine hdl))
 300    case l of
 301         Left e | isEOFError e -> return ()
 302                | otherwise    -> io (ioError e)
 303         Right l ->
 304           case remove_spaces l of
 305             "" -> fileLoop hdl prompt
 306             l  -> do quit <- runCommand l
 307                      if quit then return () else fileLoop hdl prompt
 308
 309 stringLoop :: [String] -> GHCi ()
 310 stringLoop [] = return ()
 311 stringLoop (s:ss) = do
 312    case remove_spaces s of
 313         "" -> stringLoop ss
 314         l  -> do quit <- runCommand l
 315                  if quit then return () else stringLoop ss
 316
 317 mkPrompt toplevs exports
 318    = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
 319
 320 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 321 readlineLoop :: GHCi ()
 322 readlineLoop = do
 323    cmstate <- getCmState
 324    (mod,imports) <- io (cmGetContext cmstate)
 325    io yield
 326    l <- io (readline (mkPrompt mod imports)
 327                 `finally` setNonBlockingFD 0)
 328                 -- readline sometimes puts stdin into blocking mode,
 329                 -- so we need to put it back for the IO library
 330    case l of
 331         Nothing -> return ()
 332         Just l  ->
 333           case remove_spaces l of
 334             "" -> readlineLoop
 335             l  -> do
 336                   io (addHistory l)
 337                   quit <- runCommand l
 338                   if quit then return () else readlineLoop
 339 #endif
 340
 341 runCommand :: String -> GHCi Bool
 342 runCommand c = ghciHandle handler (doCommand c)
 343
 344 -- This is the exception handler for exceptions generated by the
 345 -- user's code; it normally just prints out the exception.  The
 346 -- handler must be recursive, in case showing the exception causes
 347 -- more exceptions to be raised.
 348 --
 349 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
 350 -- raising another exception.  We therefore don't put the recursive
 351 -- handler arond the flushing operation, so if stderr is closed
 352 -- GHCi will just die gracefully rather than going into an infinite loop.
 353 handler :: Exception -> GHCi Bool
 354 handler exception = do
 355   flushInterpBuffers
 356   io installSignalHandlers
 357   ghciHandle handler (showException exception >> return False)
 358
 359 showException (DynException dyn) =
 360   case fromDynamic dyn of
 361     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 362     Just Interrupted      -> io (putStrLn "Interrupted.")
 363     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 364     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 365     Just other_ghc_ex     -> io (print other_ghc_ex)
 366
 367 showException other_exception
 368   = io (putStrLn ("*** Exception: " ++ show other_exception))
 369
 370 doCommand (':' : command) = specialCommand command
 371 doCommand stmt
 372    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 373         return False
 374
 375 runStmt :: String -> GHCi [Name]
 376 runStmt stmt
 377  | null (filter (not.isSpace) stmt) = return []
 378  | otherwise
 379  = do st <- getGHCiState
 380       dflags <- io getDynFlags
 381       let cm_state' = cmSetDFlags (cmstate st)
 382                                   (dopt_unset dflags Opt_WarnUnusedBinds)
 383       (new_cmstate, result) <-
 384         io $ withProgName (progname st) $ withArgs (args st) $
 385              cmRunStmt cm_state' stmt
 386       setGHCiState st{cmstate = new_cmstate}
 387       case result of
 388         CmRunFailed      -> return []
 389         CmRunException e -> showException e >> return []
 390         CmRunOk names    -> return names
 391
 392 -- possibly print the type and revert CAFs after evaluating an expression
 393 finishEvalExpr names
 394  = do b <- isOptionSet ShowType
 395       cmstate <- getCmState
 396       when b (mapM_ (showTypeOfName cmstate) names)
 397
 398       flushInterpBuffers
 399       io installSignalHandlers
 400       b <- isOptionSet RevertCAFs
 401       io (when b revertCAFs)
 402       return True
 403
 404 showTypeOfName :: CmState -> Name -> GHCi ()
 405 showTypeOfName cmstate n
 406    = do maybe_str <- io (cmTypeOfName cmstate n)
 407         case maybe_str of
 408           Nothing  -> return ()
 409           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 410
 411 specialCommand :: String -> GHCi Bool
 412 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 413 specialCommand str = do
 414   let (cmd,rest) = break isSpace str
 415   cmds <- io (readIORef commands)
 416   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 417      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 418                                     ++ shortHelpText) >> return False)
 419      [(_,f)] -> f (dropWhile isSpace rest)
 420      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 421                                       " matches multiple commands (" ++
 422                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 423                                          ++ ")") >> return False)
 424
 425 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 426
 427
 428 -----------------------------------------------------------------------------
 429 -- To flush buffers for the *interpreted* computation we need
 430 -- to refer to *its* stdout/stderr handles
 431
 432 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 433 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 434
 435 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
 436              " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
 437 flush_cmd  = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
 438
 439 initInterpBuffering :: CmState -> IO ()
 440 initInterpBuffering cmstate
 441  = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd
 442
 443       case maybe_hval of
 444         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 445         other     -> panic "interactiveUI:setBuffering"
 446
 447       maybe_hval <- cmCompileExpr cmstate flush_cmd
 448       case maybe_hval of
 449         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 450         _         -> panic "interactiveUI:flush"
 451
 452       turnOffBuffering  -- Turn it off right now
 453
 454       return ()
 455
 456
 457 flushInterpBuffers :: GHCi ()
 458 flushInterpBuffers
 459  = io $ do Monad.join (readIORef flush_interp)
 460            return ()
 461
 462 turnOffBuffering :: IO ()
 463 turnOffBuffering
 464  = do Monad.join (readIORef turn_off_buffering)
 465       return ()
 466
 467 -----------------------------------------------------------------------------
 468 -- Commands
 469
 470 help :: String -> GHCi ()
 471 help _ = io (putStr helpText)
 472
 473 info :: String -> GHCi ()
 474 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 475 info s  = do { let names = words s
 476              ; init_cms <- getCmState
 477              ; mapM_ (infoThing init_cms) names }
 478   where
 479     infoThing cms name
 480         = do { stuff <- io (cmInfoThing cms name)
 481              ; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
 482                    vcat (intersperse (text "") (map (showThing name) stuff)))) }
 483
 484 showThing :: String -> (IfaceDecl, Fixity) -> SDoc
 485 showThing name (thing, fixity)
 486     = vcat [ showDecl (\occ -> name == occNameUserString occ) thing,
 487              showFixity fixity ]
 488   where
 489     showFixity fix
 490         | fix == defaultFixity = empty
 491         | otherwise            = ppr fix <+> text name
 492
 493 -- Now there is rather a lot of goop just to print declarations in a civilised way
 494 -- with "..." for the parts we are less interested in.
 495
 496 showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc
 497 showDecl want_name (IfaceId {ifName = var, ifType = ty})
 498   = ppr var <+> dcolon <+> ppr ty
 499
 500 showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
 501   = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
 502        2 (equals <+> ppr mono_ty)
 503
 504 showDecl want_name (IfaceData {ifCtxt = context, ifName = tycon,
 505                      ifTyVars = tyvars, ifCons = condecls})
 506   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
 507        2 (add_bars (ppr_trim show_con cs))
 508   where
 509     show_con (IfaceConDecl con_name is_infix ex_tvs ex_cxt tys strs flds)
 510         | want_name tycon || want_name con_name || any want_name flds
 511         = Just (pprIfaceForAllPart ex_tvs ex_cxt (show_guts con_name is_infix tys_w_strs flds))
 512         | otherwise = Nothing
 513         where
 514           tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
 515
 516     show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
 517     show_guts con _ tys []   = ppr_bndr con <+> sep (map ppr_bangty tys)
 518     show_guts con _ tys flds
 519         = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
 520         where
 521           show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
 522                               = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
 523                               | otherwise = Nothing
 524
 525     (pp_nd, cs) = case condecls of
 526                     IfAbstractTyCon -> (ptext SLIT("data"),    [])
 527                     IfDataTyCon cs  -> (ptext SLIT("data"),    cs)
 528                     IfNewTyCon c    -> (ptext SLIT("newtype"), [c])
 529
 530     add_bars []      = empty
 531     add_bars [c]     = equals <+> c
 532     add_bars (c:cs)  = equals <+> sep (c : map (char '|' <+>) cs)
 533
 534     ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
 535     ppr_str MarkedStrict    = char '!'
 536     ppr_str MarkedUnboxed   = ptext SLIT("!!")
 537     ppr_str NotMarkedStrict = empty
 538
 539 showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
 540                       ifFDs = fds, ifSigs = sigs})
 541   = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
 542                 <+> pprFundeps fds <+> ptext SLIT("where"))
 543        2 (vcat (ppr_trim show_op sigs))
 544   where
 545     show_op (IfaceClassOp op dm ty)
 546         | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty)
 547         | otherwise                      = Nothing
 548
 549 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
 550 ppr_trim show xs
 551   = snd (foldr go (False, []) xs)
 552   where
 553     go x (eliding, so_far)
 554         | Just doc <- show x = (False, doc : so_far)
 555         | otherwise = if eliding then (True, so_far)
 556                                  else (True, ptext SLIT("...") : so_far)
 557
 558 ppr_bndr :: OccName -> SDoc
 559 -- Wrap operators in ()
 560 ppr_bndr occ | isSymOcc occ = parens (ppr occ)
 561              | otherwise    = ppr occ
 562
 563 {-
 564         -- also print out the source location for home things
 565     showSrcLoc name
 566         | isHomePackageName name && isGoodSrcLoc loc
 567         = hsep [ text ", defined at", ppr loc ]
 568         | otherwise
 569         = empty
 570         where loc = nameSrcLoc name
 571 -}
 572
 573
 574 -----------------------------------------------------------------------------
 575 -- Commands
 576
 577 addModule :: [FilePath] -> GHCi ()
 578 addModule files = do
 579   state <- getGHCiState
 580   io (revertCAFs)                       -- always revert CAFs on load/add.
 581   files <- mapM expandPath files
 582   let new_targets = files ++ targets state
 583   graph <- io (cmDepAnal (cmstate state) new_targets)
 584   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph)
 585   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 586   setContextAfterLoad mods
 587   dflags <- io getDynFlags
 588   modulesLoadedMsg ok mods dflags
 589
 590 changeDirectory :: String -> GHCi ()
 591 changeDirectory dir = do
 592   state    <- getGHCiState
 593   when (targets state /= []) $
 594         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\
 595         \because the search path has changed.\n"
 596   cmstate1 <- io (cmUnload (cmstate state))
 597   setGHCiState state{ cmstate = cmstate1, targets = [] }
 598   setContextAfterLoad []
 599   dir <- expandPath dir
 600   io (setCurrentDirectory dir)
 601
 602 defineMacro :: String -> GHCi ()
 603 defineMacro s = do
 604   let (macro_name, definition) = break isSpace s
 605   cmds <- io (readIORef commands)
 606   if (null macro_name)
 607         then throwDyn (CmdLineError "invalid macro name")
 608         else do
 609   if (macro_name `elem` map fst cmds)
 610         then throwDyn (CmdLineError
 611                 ("command `" ++ macro_name ++ "' is already defined"))
 612         else do
 613
 614   -- give the expression a type signature, so we can be sure we're getting
 615   -- something of the right type.
 616   let new_expr = '(' : definition ++ ") :: String -> IO String"
 617
 618   -- compile the expression
 619   cms <- getCmState
 620   maybe_hv <- io (cmCompileExpr cms new_expr)
 621   case maybe_hv of
 622      Nothing -> return ()
 623      Just hv -> io (writeIORef commands --
 624                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 625
 626 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 627 runMacro fun s = do
 628   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 629   stringLoop (lines str)
 630
 631 undefineMacro :: String -> GHCi ()
 632 undefineMacro macro_name = do
 633   cmds <- io (readIORef commands)
 634   if (macro_name `elem` map fst builtin_commands)
 635         then throwDyn (CmdLineError
 636                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 637         else do
 638   if (macro_name `notElem` map fst cmds)
 639         then throwDyn (CmdLineError
 640                 ("command `" ++ macro_name ++ "' not defined"))
 641         else do
 642   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 643
 644
 645 loadModule :: [FilePath] -> GHCi ()
 646 loadModule fs = timeIt (loadModule' fs)
 647
 648 loadModule' :: [FilePath] -> GHCi ()
 649 loadModule' files = do
 650   state <- getGHCiState
 651
 652   -- expand tildes
 653   files <- mapM expandPath files
 654
 655   -- do the dependency anal first, so that if it fails we don't throw
 656   -- away the current set of modules.
 657   graph <- io (cmDepAnal (cmstate state) files)
 658
 659   -- Dependency anal ok, now unload everything
 660   cmstate1 <- io (cmUnload (cmstate state))
 661   setGHCiState state{ cmstate = cmstate1, targets = [] }
 662
 663   io (revertCAFs)  -- always revert CAFs on load.
 664   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph)
 665   setGHCiState state{ cmstate = cmstate2, targets = files }
 666
 667   setContextAfterLoad mods
 668   dflags <- io (getDynFlags)
 669   modulesLoadedMsg ok mods dflags
 670
 671
 672 reloadModule :: String -> GHCi ()
 673 reloadModule "" = do
 674   state <- getGHCiState
 675   case targets state of
 676    [] -> io (putStr "no current target\n")
 677    paths -> do
 678         -- do the dependency anal first, so that if it fails we don't throw
 679         -- away the current set of modules.
 680         graph <- io (cmDepAnal (cmstate state) paths)
 681
 682         io (revertCAFs)         -- always revert CAFs on reload.
 683         (cmstate1, ok, mods)
 684                 <- io (cmLoadModules (cmstate state) graph)
 685         setGHCiState state{ cmstate=cmstate1 }
 686         setContextAfterLoad mods
 687         dflags <- io getDynFlags
 688         modulesLoadedMsg ok mods dflags
 689
 690 reloadModule _ = noArgs ":reload"
 691
 692 setContextAfterLoad [] = setContext prel
 693 setContextAfterLoad (m:_) = do
 694   cmstate <- getCmState
 695   b <- io (cmModuleIsInterpreted cmstate m)
 696   if b then setContext ('*':m) else setContext m
 697
 698 modulesLoadedMsg ok mods dflags =
 699   when (verbosity dflags > 0) $ do
 700    let mod_commas
 701         | null mods = text "none."
 702         | otherwise = hsep (
 703             punctuate comma (map text mods)) <> text "."
 704    case ok of
 705     Failed ->
 706        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 707     Succeeded  ->
 708        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 709
 710
 711 typeOfExpr :: String -> GHCi ()
 712 typeOfExpr str
 713   = do cms <- getCmState
 714        maybe_tystr <- io (cmTypeOfExpr cms str)
 715        case maybe_tystr of
 716           Nothing    -> return ()
 717           Just tystr -> io (putStrLn tystr)
 718
 719 kindOfType :: String -> GHCi ()
 720 kindOfType str
 721   = do cms <- getCmState
 722        maybe_tystr <- io (cmKindOfType cms str)
 723        case maybe_tystr of
 724           Nothing    -> return ()
 725           Just tystr -> io (putStrLn tystr)
 726
 727 quit :: String -> GHCi Bool
 728 quit _ = return True
 729
 730 shellEscape :: String -> GHCi Bool
 731 shellEscape str = io (system str >> return False)
 732
 733 -----------------------------------------------------------------------------
 734 -- Browsing a module's contents
 735
 736 browseCmd :: String -> GHCi ()
 737 browseCmd m =
 738   case words m of
 739     ['*':m] | looksLikeModuleName m -> browseModule m False
 740     [m]     | looksLikeModuleName m -> browseModule m True
 741     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 742
 743 browseModule m exports_only = do
 744   cms <- getCmState
 745
 746   is_interpreted <- io (cmModuleIsInterpreted cms m)
 747   when (not is_interpreted && not exports_only) $
 748         throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 749
 750   -- Temporarily set the context to the module we're interested in,
 751   -- just so we can get an appropriate PrintUnqualified
 752   (as,bs) <- io (cmGetContext cms)
 753   cms1 <- io (if exports_only then cmSetContext cms [] [prel,m]
 754                               else cmSetContext cms [m] [])
 755   cms2 <- io (cmSetContext cms1 as bs)
 756
 757   things <- io (cmBrowseModule cms2 m exports_only)
 758
 759   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 760
 761   io (putStrLn (showSDocForUser unqual (
 762          vcat (map (showDecl (const True)) things)
 763       )))
 764
 765 -----------------------------------------------------------------------------
 766 -- Setting the module context
 767
 768 setContext str
 769   | all sensible mods = fn mods
 770   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 771   where
 772     (fn, mods) = case str of
 773                         '+':stuff -> (addToContext,      words stuff)
 774                         '-':stuff -> (removeFromContext, words stuff)
 775                         stuff     -> (newContext,        words stuff)
 776
 777     sensible ('*':m) = looksLikeModuleName m
 778     sensible m       = looksLikeModuleName m
 779
 780 newContext mods = do
 781   cms <- getCmState
 782   (as,bs) <- separate cms mods [] []
 783   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 784   cms' <- io (cmSetContext cms as bs')
 785   setCmState cms'
 786
 787 separate cmstate []           as bs = return (as,bs)
 788 separate cmstate (('*':m):ms) as bs = do
 789    b <- io (cmModuleIsInterpreted cmstate m)
 790    if b then separate cmstate ms (m:as) bs
 791         else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 792 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 793
 794 prel = "Prelude"
 795
 796
 797 addToContext mods = do
 798   cms <- getCmState
 799   (as,bs) <- io (cmGetContext cms)
 800
 801   (as',bs') <- separate cms mods [] []
 802
 803   let as_to_add = as' \\ (as ++ bs)
 804       bs_to_add = bs' \\ (as ++ bs)
 805
 806   cms' <- io (cmSetContext cms
 807                         (as ++ as_to_add) (bs ++ bs_to_add))
 808   setCmState cms'
 809
 810
 811 removeFromContext mods = do
 812   cms <- getCmState
 813   (as,bs) <- io (cmGetContext cms)
 814
 815   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 816
 817   let as' = as \\ (as_to_remove ++ bs_to_remove)
 818       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 819
 820   cms' <- io (cmSetContext cms as' bs')
 821   setCmState cms'
 822
 823 ----------------------------------------------------------------------------
 824 -- Code for `:set'
 825
 826 -- set options in the interpreter.  Syntax is exactly the same as the
 827 -- ghc command line, except that certain options aren't available (-C,
 828 -- -E etc.)
 829 --
 830 -- This is pretty fragile: most options won't work as expected.  ToDo:
 831 -- figure out which ones & disallow them.
 832
 833 setCmd :: String -> GHCi ()
 834 setCmd ""
 835   = do st <- getGHCiState
 836        let opts = options st
 837        io $ putStrLn (showSDoc (
 838               text "options currently set: " <>
 839               if null opts
 840                    then text "none."
 841                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 842            ))
 843 setCmd str
 844   = case words str of
 845         ("args":args) -> setArgs args
 846         ("prog":prog) -> setProg prog
 847         wds -> setOptions wds
 848
 849 setArgs args = do
 850   st <- getGHCiState
 851   setGHCiState st{ args = args }
 852
 853 setProg [prog] = do
 854   st <- getGHCiState
 855   setGHCiState st{ progname = prog }
 856 setProg _ = do
 857   io (hPutStrLn stderr "syntax: :set prog <progname>")
 858
 859 setOptions wds =
 860    do -- first, deal with the GHCi opts (+s, +t, etc.)
 861       let (plus_opts, minus_opts)  = partition isPlus wds
 862       mapM_ setOpt plus_opts
 863
 864       -- now, the GHC flags
 865       pkgs_before <- io (readIORef v_ExplicitPackages)
 866       leftovers   <- io (processArgs static_flags minus_opts [])
 867       pkgs_after  <- io (readIORef v_ExplicitPackages)
 868
 869       -- update things if the users wants more packages
 870       let new_packages = pkgs_after \\ pkgs_before
 871       when (not (null new_packages)) $
 872          newPackages new_packages
 873
 874       -- don't forget about the extra command-line flags from the
 875       -- extra_ghc_opts fields in the new packages
 876       new_package_details <- io (getPackageDetails new_packages)
 877       let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
 878       pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
 879
 880       -- then, dynamic flags
 881       io $ do
 882         restoreDynFlags
 883         leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
 884         saveDynFlags
 885
 886         if (not (null leftovers))
 887                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 888                                                 unwords leftovers))
 889                 else return ()
 890
 891
 892 unsetOptions :: String -> GHCi ()
 893 unsetOptions str
 894   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 895        let opts = words str
 896            (minus_opts, rest1) = partition isMinus opts
 897            (plus_opts, rest2)  = partition isPlus rest1
 898
 899        if (not (null rest2))
 900           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 901           else do
 902
 903        mapM_ unsetOpt plus_opts
 904
 905        -- can't do GHC flags for now
 906        if (not (null minus_opts))
 907           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 908           else return ()
 909
 910 isMinus ('-':s) = True
 911 isMinus _ = False
 912
 913 isPlus ('+':s) = True
 914 isPlus _ = False
 915
 916 setOpt ('+':str)
 917   = case strToGHCiOpt str of
 918         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 919         Just o  -> setOption o
 920
 921 unsetOpt ('+':str)
 922   = case strToGHCiOpt str of
 923         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 924         Just o  -> unsetOption o
 925
 926 strToGHCiOpt :: String -> (Maybe GHCiOption)
 927 strToGHCiOpt "s" = Just ShowTiming
 928 strToGHCiOpt "t" = Just ShowType
 929 strToGHCiOpt "r" = Just RevertCAFs
 930 strToGHCiOpt _   = Nothing
 931
 932 optToStr :: GHCiOption -> String
 933 optToStr ShowTiming = "s"
 934 optToStr ShowType   = "t"
 935 optToStr RevertCAFs = "r"
 936
 937 newPackages new_pkgs = do       -- The new packages are already in v_Packages
 938   state    <- getGHCiState
 939   cmstate1 <- io (cmUnload (cmstate state))
 940   setGHCiState state{ cmstate = cmstate1, targets = [] }
 941   dflags   <- io getDynFlags
 942   io (linkPackages dflags new_pkgs)
 943   setContextAfterLoad []
 944
 945 -- ---------------------------------------------------------------------------
 946 -- code for `:show'
 947
 948 showCmd str =
 949   case words str of
 950         ["modules" ] -> showModules
 951         ["bindings"] -> showBindings
 952         ["linker"]   -> io showLinkerState
 953         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 954
 955 showModules = do
 956   cms <- getCmState
 957   let (mg, hpt) = cmGetModInfo cms
 958   mapM_ (showModule hpt) mg
 959
 960
 961 showModule :: HomePackageTable -> ModSummary -> GHCi ()
 962 showModule hpt mod_summary
 963   = case lookupModuleEnv hpt mod of
 964         Nothing       -> panic "missing linkable"
 965         Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
 966                       where
 967                          obj_linkable = isObjectLinkable (hm_linkable mod_info)
 968   where
 969     mod = ms_mod mod_summary
 970     locn = ms_location mod_summary
 971
 972 showBindings = do
 973   cms <- getCmState
 974   let
 975         unqual = cmGetPrintUnqual cms
 976 --      showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
 977         showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b)))
 978
 979   io (mapM_ showBinding (cmGetBindings cms))
 980   return ()
 981
 982
 983 -----------------------------------------------------------------------------
 984 -- GHCi monad
 985
 986 data GHCiState = GHCiState
 987      {
 988         progname       :: String,
 989         args           :: [String],
 990         targets        :: [FilePath],
 991         cmstate        :: CmState,
 992         options        :: [GHCiOption]
 993      }
 994
 995 data GHCiOption
 996         = ShowTiming            -- show time/allocs after evaluation
 997         | ShowType              -- show the type of expressions
 998         | RevertCAFs            -- revert CAFs after every evaluation
 999         deriving Eq
1000
1001 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1002
1003 startGHCi :: GHCi a -> GHCiState -> IO a
1004 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1005
1006 instance Monad GHCi where
1007   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1008   return a  = GHCi $ \s -> return a
1009
1010 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1011 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1012    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1013
1014 getGHCiState   = GHCi $ \r -> readIORef r
1015 setGHCiState s = GHCi $ \r -> writeIORef r s
1016
1017 -- for convenience...
1018 getCmState = getGHCiState >>= return . cmstate
1019 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1020
1021 isOptionSet :: GHCiOption -> GHCi Bool
1022 isOptionSet opt
1023  = do st <- getGHCiState
1024       return (opt `elem` options st)
1025
1026 setOption :: GHCiOption -> GHCi ()
1027 setOption opt
1028  = do st <- getGHCiState
1029       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1030
1031 unsetOption :: GHCiOption -> GHCi ()
1032 unsetOption opt
1033  = do st <- getGHCiState
1034       setGHCiState (st{ options = filter (/= opt) (options st) })
1035
1036 io :: IO a -> GHCi a
1037 io m = GHCi { unGHCi = \s -> m >>= return }
1038
1039 -----------------------------------------------------------------------------
1040 -- recursive exception handlers
1041
1042 -- Don't forget to unblock async exceptions in the handler, or if we're
1043 -- in an exception loop (eg. let a = error a in a) the ^C exception
1044 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1045
1046 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1047 ghciHandle h (GHCi m) = GHCi $ \s ->
1048    Exception.catch (m s)
1049         (\e -> unGHCi (ghciUnblock (h e)) s)
1050
1051 ghciUnblock :: GHCi a -> GHCi a
1052 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1053
1054 -----------------------------------------------------------------------------
1055 -- timing & statistics
1056
1057 timeIt :: GHCi a -> GHCi a
1058 timeIt action
1059   = do b <- isOptionSet ShowTiming
1060        if not b
1061           then action
1062           else do allocs1 <- io $ getAllocations
1063                   time1   <- io $ getCPUTime
1064                   a <- action
1065                   allocs2 <- io $ getAllocations
1066                   time2   <- io $ getCPUTime
1067                   io $ printTimes (fromIntegral (allocs2 - allocs1))
1068                                   (time2 - time1)
1069                   return a
1070
1071 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1072         -- defined in ghc/rts/Stats.c
1073
1074 printTimes :: Integer -> Integer -> IO ()
1075 printTimes allocs psecs
1076    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1077             secs_str = showFFloat (Just 2) secs
1078         putStrLn (showSDoc (
1079                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1080                          text (show allocs) <+> text "bytes")))
1081
1082 -----------------------------------------------------------------------------
1083 -- reverting CAFs
1084
1085 revertCAFs :: IO ()
1086 revertCAFs = do
1087   rts_revertCAFs
1088   turnOffBuffering
1089         -- Have to turn off buffering again, because we just
1090         -- reverted stdout, stderr & stdin to their defaults.
1091
1092 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1093         -- Make it "safe", just in case
1094
1095 -- -----------------------------------------------------------------------------
1096 -- Utils
1097
1098 expandPath :: String -> GHCi String
1099 expandPath path =
1100   case dropWhile isSpace path of
1101    ('~':d) -> do
1102         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1103         return (tilde ++ '/':d)
1104    other ->
1105         return other