ghc/compiler/ghci/InteractiveUI.hs

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