ghc/compiler/ghci/InteractiveUI.hs

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