ghc/compiler/ghci/InteractiveUI.hs

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