ghc/compiler/ghci/InteractiveUI.hs

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