ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.143 2003/02/12 15:01:35 simonpj 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, isImplicitId, recordSelectorFieldLabel, idName )
  30 import Class            ( className )
  31 import TyCon            ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
  32 import DataCon          ( dataConName )
  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 (ADataCon dc)
 501        = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
 502     showTyThing (ATyCon ty)
 503        | isPrimTyCon ty
 504        = hcat [ppr ty, text " is a primitive type constructor"]
 505        | otherwise
 506        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
 507     showTyThing (AnId   id)
 508        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 509
 510     idDescr id
 511        | isRecordSelector id =
 512                 case tyConClass_maybe (fieldLabelTyCon (
 513                                 recordSelectorFieldLabel id)) of
 514                         Nothing -> text "record selector"
 515                         Just c  -> text "method in class " <> ppr c
 516        | otherwise           = text "variable"
 517
 518         -- also print out the source location for home things
 519     showSrcLoc name
 520         | isHomePackageName name && isGoodSrcLoc loc
 521         = hsep [ text ", defined at", ppr loc ]
 522         | otherwise
 523         = empty
 524         where loc = nameSrcLoc name
 525
 526   cms <- infoThings init_cms names
 527   setCmState cms
 528   return ()
 529
 530 addModule :: String -> GHCi ()
 531 addModule str = do
 532   let files = words str
 533   state <- getGHCiState
 534   dflags <- io (getDynFlags)
 535   io (revertCAFs)                       -- always revert CAFs on load/add.
 536   let new_targets = files ++ targets state
 537   graph <- io (cmDepAnal (cmstate state) dflags new_targets)
 538   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
 539   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 540   setContextAfterLoad mods
 541   modulesLoadedMsg ok mods dflags
 542
 543 changeDirectory :: String -> GHCi ()
 544 changeDirectory ('~':d) = do
 545    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 546    io (setCurrentDirectory (tilde ++ '/':d))
 547 changeDirectory d = io (setCurrentDirectory d)
 548
 549 defineMacro :: String -> GHCi ()
 550 defineMacro s = do
 551   let (macro_name, definition) = break isSpace s
 552   cmds <- io (readIORef commands)
 553   if (null macro_name)
 554         then throwDyn (CmdLineError "invalid macro name")
 555         else do
 556   if (macro_name `elem` map fst cmds)
 557         then throwDyn (CmdLineError
 558                 ("command `" ++ macro_name ++ "' is already defined"))
 559         else do
 560
 561   -- give the expression a type signature, so we can be sure we're getting
 562   -- something of the right type.
 563   let new_expr = '(' : definition ++ ") :: String -> IO String"
 564
 565   -- compile the expression
 566   cms <- getCmState
 567   dflags <- io getDynFlags
 568   (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
 569   setCmState new_cmstate
 570   case maybe_hv of
 571      Nothing -> return ()
 572      Just hv -> io (writeIORef commands --
 573                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 574
 575 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 576 runMacro fun s = do
 577   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 578   stringLoop (lines str)
 579
 580 undefineMacro :: String -> GHCi ()
 581 undefineMacro macro_name = do
 582   cmds <- io (readIORef commands)
 583   if (macro_name `elem` map fst builtin_commands)
 584         then throwDyn (CmdLineError
 585                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 586         else do
 587   if (macro_name `notElem` map fst cmds)
 588         then throwDyn (CmdLineError
 589                 ("command `" ++ macro_name ++ "' not defined"))
 590         else do
 591   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 592
 593
 594 loadModule :: String -> GHCi ()
 595 loadModule str = timeIt (loadModule' str)
 596
 597 loadModule' str = do
 598   let files = words str
 599   state <- getGHCiState
 600   dflags <- io getDynFlags
 601
 602   -- do the dependency anal first, so that if it fails we don't throw
 603   -- away the current set of modules.
 604   graph <- io (cmDepAnal (cmstate state) dflags files)
 605
 606   -- Dependency anal ok, now unload everything
 607   cmstate1 <- io (cmUnload (cmstate state) dflags)
 608   setGHCiState state{ cmstate = cmstate1, targets = [] }
 609
 610   io (revertCAFs)  -- always revert CAFs on load.
 611   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
 612   setGHCiState state{ cmstate = cmstate2, targets = files }
 613
 614   setContextAfterLoad mods
 615   modulesLoadedMsg ok mods dflags
 616
 617
 618 reloadModule :: String -> GHCi ()
 619 reloadModule "" = do
 620   state <- getGHCiState
 621   dflags <- io getDynFlags
 622   case targets state of
 623    [] -> io (putStr "no current target\n")
 624    paths -> do
 625         -- do the dependency anal first, so that if it fails we don't throw
 626         -- away the current set of modules.
 627         graph <- io (cmDepAnal (cmstate state) dflags paths)
 628
 629         io (revertCAFs)         -- always revert CAFs on reload.
 630         (cmstate1, ok, mods)
 631                 <- io (cmLoadModules (cmstate state) dflags graph)
 632         setGHCiState state{ cmstate=cmstate1 }
 633         setContextAfterLoad mods
 634         modulesLoadedMsg ok mods dflags
 635
 636 reloadModule _ = noArgs ":reload"
 637
 638 setContextAfterLoad [] = setContext prel
 639 setContextAfterLoad (m:_) = do
 640   cmstate <- getCmState
 641   b <- io (cmModuleIsInterpreted cmstate m)
 642   if b then setContext ('*':m) else setContext m
 643
 644 modulesLoadedMsg ok mods dflags =
 645   when (verbosity dflags > 0) $ do
 646    let mod_commas
 647         | null mods = text "none."
 648         | otherwise = hsep (
 649             punctuate comma (map text mods)) <> text "."
 650    case ok of
 651     Failed ->
 652        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 653     Succeeded  ->
 654        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 655
 656
 657 typeOfExpr :: String -> GHCi ()
 658 typeOfExpr str
 659   = do cms <- getCmState
 660        dflags <- io getDynFlags
 661        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
 662        setCmState new_cmstate
 663        case maybe_tystr of
 664           Nothing    -> return ()
 665           Just tystr -> io (putStrLn tystr)
 666
 667 quit :: String -> GHCi Bool
 668 quit _ = return True
 669
 670 shellEscape :: String -> GHCi Bool
 671 shellEscape str = io (system str >> return False)
 672
 673 -----------------------------------------------------------------------------
 674 -- Browing a module's contents
 675
 676 browseCmd :: String -> GHCi ()
 677 browseCmd m =
 678   case words m of
 679     ['*':m] | looksLikeModuleName m -> browseModule m False
 680     [m]     | looksLikeModuleName m -> browseModule m True
 681     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 682
 683 browseModule m exports_only = do
 684   cms <- getCmState
 685   dflags <- io getDynFlags
 686
 687   is_interpreted <- io (cmModuleIsInterpreted cms m)
 688   when (not is_interpreted && not exports_only) $
 689         throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 690
 691   -- temporarily set the context to the module we're interested in,
 692   -- just so we can get an appropriate PrintUnqualified
 693   (as,bs) <- io (cmGetContext cms)
 694   cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
 695                               else cmSetContext cms dflags [m] [])
 696   cms2 <- io (cmSetContext cms1 dflags as bs)
 697
 698   (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
 699
 700   setCmState cms3
 701
 702   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 703
 704       things' = filter wantToSee things
 705
 706       wantToSee (AnId id)    = not (isImplicitId id)
 707       wantToSee (ADataCon _) = False    -- They'll come via their TyCon
 708       wantToSee _            = True
 709
 710       thing_names = map getName things
 711
 712       thingDecl thing@(AnId id)  = ifaceTyThing thing
 713
 714       thingDecl thing@(AClass c) =
 715         let rn_decl = ifaceTyThing thing in
 716         case rn_decl of
 717           ClassDecl { tcdSigs = cons } ->
 718                 rn_decl{ tcdSigs = filter methodIsVisible cons }
 719           other -> other
 720         where
 721            methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
 722
 723       thingDecl thing@(ATyCon t) =
 724         let rn_decl = ifaceTyThing thing in
 725         case rn_decl of
 726           TyData { tcdCons = DataCons cons } ->
 727                 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
 728           other -> other
 729         where
 730           conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
 731
 732   io (putStrLn (showSDocForUser unqual (
 733          vcat (map (ppr . thingDecl) things')))
 734    )
 735
 736   where
 737
 738 -----------------------------------------------------------------------------
 739 -- Setting the module context
 740
 741 setContext str
 742   | all sensible mods = fn mods
 743   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 744   where
 745     (fn, mods) = case str of
 746                         '+':stuff -> (addToContext,      words stuff)
 747                         '-':stuff -> (removeFromContext, words stuff)
 748                         stuff     -> (newContext,        words stuff)
 749
 750     sensible ('*':m) = looksLikeModuleName m
 751     sensible m       = looksLikeModuleName m
 752
 753 newContext mods = do
 754   cms <- getCmState
 755   dflags <- io getDynFlags
 756   (as,bs) <- separate cms mods [] []
 757   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 758   cms' <- io (cmSetContext cms dflags as bs')
 759   setCmState cms'
 760
 761 separate cmstate []           as bs = return (as,bs)
 762 separate cmstate (('*':m):ms) as bs = do
 763    b <- io (cmModuleIsInterpreted cmstate m)
 764    if b then separate cmstate ms (m:as) bs
 765         else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 766 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 767
 768 prel = "Prelude"
 769
 770
 771 addToContext mods = do
 772   cms <- getCmState
 773   dflags <- io getDynFlags
 774   (as,bs) <- io (cmGetContext cms)
 775
 776   (as',bs') <- separate cms mods [] []
 777
 778   let as_to_add = as' \\ (as ++ bs)
 779       bs_to_add = bs' \\ (as ++ bs)
 780
 781   cms' <- io (cmSetContext cms dflags
 782                         (as ++ as_to_add) (bs ++ bs_to_add))
 783   setCmState cms'
 784
 785
 786 removeFromContext mods = do
 787   cms <- getCmState
 788   dflags <- io getDynFlags
 789   (as,bs) <- io (cmGetContext cms)
 790
 791   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 792
 793   let as' = as \\ (as_to_remove ++ bs_to_remove)
 794       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 795
 796   cms' <- io (cmSetContext cms dflags as' bs')
 797   setCmState cms'
 798
 799 ----------------------------------------------------------------------------
 800 -- Code for `:set'
 801
 802 -- set options in the interpreter.  Syntax is exactly the same as the
 803 -- ghc command line, except that certain options aren't available (-C,
 804 -- -E etc.)
 805 --
 806 -- This is pretty fragile: most options won't work as expected.  ToDo:
 807 -- figure out which ones & disallow them.
 808
 809 setCmd :: String -> GHCi ()
 810 setCmd ""
 811   = do st <- getGHCiState
 812        let opts = options st
 813        io $ putStrLn (showSDoc (
 814               text "options currently set: " <>
 815               if null opts
 816                    then text "none."
 817                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 818            ))
 819 setCmd str
 820   = case words str of
 821         ("args":args) -> setArgs args
 822         ("prog":prog) -> setProg prog
 823         wds -> setOptions wds
 824
 825 setArgs args = do
 826   st <- getGHCiState
 827   setGHCiState st{ args = args }
 828
 829 setProg [prog] = do
 830   st <- getGHCiState
 831   setGHCiState st{ progname = prog }
 832 setProg _ = do
 833   io (hPutStrLn stderr "syntax: :set prog <progname>")
 834
 835 setOptions wds =
 836    do -- first, deal with the GHCi opts (+s, +t, etc.)
 837       let (plus_opts, minus_opts)  = partition isPlus wds
 838       mapM_ setOpt plus_opts
 839
 840       -- now, the GHC flags
 841       pkgs_before <- io (readIORef v_ExplicitPackages)
 842       leftovers   <- io (processArgs static_flags minus_opts [])
 843       pkgs_after  <- io (readIORef v_ExplicitPackages)
 844
 845       -- update things if the users wants more packages
 846       let new_packages = pkgs_after \\ pkgs_before
 847       when (not (null new_packages)) $
 848          newPackages new_packages
 849
 850       -- don't forget about the extra command-line flags from the
 851       -- extra_ghc_opts fields in the new packages
 852       new_package_details <- io (getPackageDetails new_packages)
 853       let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
 854       pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
 855
 856       -- then, dynamic flags
 857       io $ do
 858         restoreDynFlags
 859         leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
 860         saveDynFlags
 861
 862         if (not (null leftovers))
 863                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 864                                                 unwords leftovers))
 865                 else return ()
 866
 867
 868 unsetOptions :: String -> GHCi ()
 869 unsetOptions str
 870   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 871        let opts = words str
 872            (minus_opts, rest1) = partition isMinus opts
 873            (plus_opts, rest2)  = partition isPlus rest1
 874
 875        if (not (null rest2))
 876           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 877           else do
 878
 879        mapM_ unsetOpt plus_opts
 880
 881        -- can't do GHC flags for now
 882        if (not (null minus_opts))
 883           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 884           else return ()
 885
 886 isMinus ('-':s) = True
 887 isMinus _ = False
 888
 889 isPlus ('+':s) = True
 890 isPlus _ = False
 891
 892 setOpt ('+':str)
 893   = case strToGHCiOpt str of
 894         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 895         Just o  -> setOption o
 896
 897 unsetOpt ('+':str)
 898   = case strToGHCiOpt str of
 899         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 900         Just o  -> unsetOption o
 901
 902 strToGHCiOpt :: String -> (Maybe GHCiOption)
 903 strToGHCiOpt "s" = Just ShowTiming
 904 strToGHCiOpt "t" = Just ShowType
 905 strToGHCiOpt "r" = Just RevertCAFs
 906 strToGHCiOpt _   = Nothing
 907
 908 optToStr :: GHCiOption -> String
 909 optToStr ShowTiming = "s"
 910 optToStr ShowType   = "t"
 911 optToStr RevertCAFs = "r"
 912
 913 newPackages new_pkgs = do       -- The new packages are already in v_Packages
 914   state    <- getGHCiState
 915   dflags   <- io getDynFlags
 916   cmstate1 <- io (cmUnload (cmstate state) dflags)
 917   setGHCiState state{ cmstate = cmstate1, targets = [] }
 918   io (linkPackages dflags new_pkgs)
 919   setContextAfterLoad []
 920
 921 -- ---------------------------------------------------------------------------
 922 -- code for `:show'
 923
 924 showCmd str =
 925   case words str of
 926         ["modules" ] -> showModules
 927         ["bindings"] -> showBindings
 928         ["linker"]   -> io showLinkerState
 929         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 930
 931 showModules = do
 932   cms <- getCmState
 933   let (mg, hpt) = cmGetModInfo cms
 934   mapM_ (showModule hpt) mg
 935
 936
 937 showModule :: HomePackageTable -> ModSummary -> GHCi ()
 938 showModule hpt mod_summary
 939   = case lookupModuleEnv hpt mod of
 940         Nothing       -> panic "missing linkable"
 941         Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
 942                       where
 943                          obj_linkable = isObjectLinkable (hm_linkable mod_info)
 944   where
 945     mod = ms_mod mod_summary
 946     locn = ms_location mod_summary
 947
 948 showBindings = do
 949   cms <- getCmState
 950   let
 951         unqual = cmGetPrintUnqual cms
 952         showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
 953
 954   io (mapM_ showBinding (cmGetBindings cms))
 955   return ()
 956
 957
 958 -----------------------------------------------------------------------------
 959 -- GHCi monad
 960
 961 data GHCiState = GHCiState
 962      {
 963         progname       :: String,
 964         args           :: [String],
 965         targets        :: [FilePath],
 966         cmstate        :: CmState,
 967         options        :: [GHCiOption]
 968      }
 969
 970 data GHCiOption
 971         = ShowTiming            -- show time/allocs after evaluation
 972         | ShowType              -- show the type of expressions
 973         | RevertCAFs            -- revert CAFs after every evaluation
 974         deriving Eq
 975
 976 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 977
 978 startGHCi :: GHCi a -> GHCiState -> IO a
 979 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 980
 981 instance Monad GHCi where
 982   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 983   return a  = GHCi $ \s -> return a
 984
 985 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 986 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 987    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 988
 989 getGHCiState   = GHCi $ \r -> readIORef r
 990 setGHCiState s = GHCi $ \r -> writeIORef r s
 991
 992 -- for convenience...
 993 getCmState = getGHCiState >>= return . cmstate
 994 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
 995
 996 isOptionSet :: GHCiOption -> GHCi Bool
 997 isOptionSet opt
 998  = do st <- getGHCiState
 999       return (opt `elem` options st)
1000
1001 setOption :: GHCiOption -> GHCi ()
1002 setOption opt
1003  = do st <- getGHCiState
1004       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1005
1006 unsetOption :: GHCiOption -> GHCi ()
1007 unsetOption opt
1008  = do st <- getGHCiState
1009       setGHCiState (st{ options = filter (/= opt) (options st) })
1010
1011 io :: IO a -> GHCi a
1012 io m = GHCi { unGHCi = \s -> m >>= return }
1013
1014 -----------------------------------------------------------------------------
1015 -- recursive exception handlers
1016
1017 -- Don't forget to unblock async exceptions in the handler, or if we're
1018 -- in an exception loop (eg. let a = error a in a) the ^C exception
1019 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1020
1021 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1022 ghciHandle h (GHCi m) = GHCi $ \s ->
1023    Exception.catch (m s)
1024         (\e -> unGHCi (ghciUnblock (h e)) s)
1025
1026 ghciUnblock :: GHCi a -> GHCi a
1027 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1028
1029 -----------------------------------------------------------------------------
1030 -- timing & statistics
1031
1032 timeIt :: GHCi a -> GHCi a
1033 timeIt action
1034   = do b <- isOptionSet ShowTiming
1035        if not b
1036           then action
1037           else do allocs1 <- io $ getAllocations
1038                   time1   <- io $ getCPUTime
1039                   a <- action
1040                   allocs2 <- io $ getAllocations
1041                   time2   <- io $ getCPUTime
1042                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
1043                   return a
1044
1045 foreign import ccall "getAllocations" getAllocations :: IO Int
1046
1047 printTimes :: Int -> Integer -> IO ()
1048 printTimes allocs psecs
1049    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1050             secs_str = showFFloat (Just 2) secs
1051         putStrLn (showSDoc (
1052                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1053                          int allocs <+> text "bytes")))
1054
1055 -----------------------------------------------------------------------------
1056 -- reverting CAFs
1057
1058 revertCAFs :: IO ()
1059 revertCAFs = do
1060   rts_revertCAFs
1061   turnOffBuffering
1062         -- Have to turn off buffering again, because we just
1063         -- reverted stdout, stderr & stdin to their defaults.
1064
1065 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1066         -- Make it "safe", just in case