ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.158 2003/08/27 12:29: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 HsSyn            ( TyClDecl(..), ConDecl(..), Sig(..) )
  22 import MkIface          ( ifaceTyThing )
  23 import DriverFlags
  24 import DriverState
  25 import DriverUtil       ( remove_spaces )
  26 import Linker           ( showLinkerState, linkPackages )
  27 import Util
  28 import IdInfo           ( GlobalIdDetails(..) )
  29 import Id               ( isImplicitId, idName, globalIdDetails )
  30 import Class            ( className )
  31 import TyCon            ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
  32 import DataCon          ( dataConName )
  33 import FieldLabel       ( fieldLabelTyCon )
  34 import SrcLoc           ( isGoodSrcLoc )
  35 import Module           ( showModMsg, lookupModuleEnv )
  36 import Name             ( Name, isHomePackageName, nameSrcLoc, nameOccName,
  37                           NamedThing(..) )
  38 import OccName          ( isSymOcc )
  39 import BasicTypes       ( defaultFixity, SuccessFlag(..) )
  40 import Packages
  41 import Outputable
  42 import CmdLineOpts      ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
  43                           restoreDynFlags, dopt_unset )
  44 import Panic            hiding ( showException )
  45 import Config
  46
  47 #ifndef mingw32_HOST_OS
  48 import DriverUtil( handle )
  49 import System.Posix
  50 #if __GLASGOW_HASKELL__ > 504
  51         hiding (getEnv)
  52 #endif
  53 #endif
  54
  55 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
  56 import Control.Concurrent       ( yield )       -- Used in readline loop
  57 import System.Console.Readline as Readline
  58 #endif
  59
  60 --import SystemExts
  61
  62 import Control.Exception as Exception
  63 import Data.Dynamic
  64 import Control.Concurrent
  65
  66 import Numeric
  67 import Data.List
  68 import System.Cmd
  69 import System.CPUTime
  70 import System.Environment
  71 import System.Directory
  72 import System.IO as IO
  73 import Data.Char
  74 import Control.Monad as Monad
  75
  76 import GHC.Exts         ( unsafeCoerce# )
  77
  78 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  79
  80 import System.Posix.Internals ( setNonBlockingFD )
  81
  82 -----------------------------------------------------------------------------
  83
  84 ghciWelcomeMsg = "\
  85 \   ___         ___ _\n\
  86 \  / _ \\ /\\  /\\/ __(_)\n\
  87 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
  88 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  89 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  90
  91 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  92
  93 builtin_commands :: [(String, String -> GHCi Bool)]
  94 builtin_commands = [
  95   ("add",       keepGoingPaths addModule),
  96   ("browse",    keepGoing browseCmd),
  97   ("cd",        keepGoing changeDirectory),
  98   ("def",       keepGoing defineMacro),
  99   ("help",      keepGoing help),
 100   ("?",         keepGoing help),
 101   ("info",      keepGoing info),
 102   ("load",      keepGoingPaths loadModule),
 103   ("module",    keepGoing setContext),
 104   ("reload",    keepGoing reloadModule),
 105   ("set",       keepGoing setCmd),
 106   ("show",      keepGoing showCmd),
 107   ("type",      keepGoing typeOfExpr),
 108   ("unset",     keepGoing unsetOptions),
 109   ("undef",     keepGoing undefineMacro),
 110   ("quit",      quit)
 111   ]
 112
 113 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 114 keepGoing a str = a str >> return False
 115
 116 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 117 keepGoingPaths a str = a (toArgs str) >> return False
 118
 119 shortHelpText = "use :? for help.\n"
 120
 121 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 122 helpText = "\
 123 \ Commands available from the prompt:\n\
 124 \\n\
 125 \   <stmt>                     evaluate/run <stmt>\n\
 126 \   :add <filename> ...        add module(s) to the current target set\n\
 127 \   :browse [*]<module>        display the names defined by <module>\n\
 128 \   :cd <dir>                  change directory to <dir>\n\
 129 \   :def <cmd> <expr>          define a command :<cmd>\n\
 130 \   :help, :?                  display this list of commands\n\
 131 \   :info [<name> ...]         display information about the given names\n\
 132 \   :load <filename> ...       load module(s) and their dependents\n\
 133 \   :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
 134 \   :reload                    reload the current module set\n\
 135 \\n\
 136 \   :set <option> ...          set options\n\
 137 \   :set args <arg> ...        set the arguments returned by System.getArgs\n\
 138 \   :set prog <progname>       set the value returned by System.getProgName\n\
 139 \\n\
 140 \   :show modules              show the currently loaded modules\n\
 141 \   :show bindings             show the current bindings made at the prompt\n\
 142 \\n\
 143 \   :type <expr>               show the type of <expr>\n\
 144 \   :undef <cmd>               undefine user-defined command :<cmd>\n\
 145 \   :unset <option> ...        unset options\n\
 146 \   :quit                      exit GHCi\n\
 147 \   :!<command>                run the shell command <command>\n\
 148 \\n\
 149 \ Options for `:set' and `:unset':\n\
 150 \\n\
 151 \    +r                 revert top-level expressions after each evaluation\n\
 152 \    +s                 print timing/memory stats after each evaluation\n\
 153 \    +t                 print type after evaluation\n\
 154 \    -<flags>           most GHC command line flags can also be set here\n\
 155 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 156 \"
 157
 158 interactiveUI :: [FilePath] -> IO ()
 159 interactiveUI srcs = do
 160    dflags <- getDynFlags
 161
 162    cmstate <- cmInit Interactive;
 163
 164    hFlush stdout
 165    hSetBuffering stdout NoBuffering
 166
 167         -- Initialise buffering for the *interpreted* I/O system
 168    cmstate <- initInterpBuffering cmstate dflags
 169
 170         -- We don't want the cmd line to buffer any input that might be
 171         -- intended for the program, so unbuffer stdin.
 172    hSetBuffering stdin NoBuffering
 173
 174         -- initial context is just the Prelude
 175    cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
 176
 177 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 178    Readline.initialize
 179 #endif
 180
 181    startGHCi (runGHCi srcs dflags)
 182         GHCiState{ progname = "<interactive>",
 183                    args = [],
 184                    targets = srcs,
 185                    cmstate = cmstate,
 186                    options = [] }
 187
 188 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 189    Readline.resetTerminal Nothing
 190 #endif
 191
 192    return ()
 193
 194 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
 195 runGHCi paths dflags = do
 196   read_dot_files <- io (readIORef v_Read_DotGHCi)
 197
 198   when (read_dot_files) $ do
 199     -- Read in ./.ghci.
 200     let file = "./.ghci"
 201     exists <- io (doesFileExist file)
 202     when exists $ do
 203        dir_ok  <- io (checkPerms ".")
 204        file_ok <- io (checkPerms file)
 205        when (dir_ok && file_ok) $ do
 206           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 207           case either_hdl of
 208              Left e    -> return ()
 209              Right hdl -> fileLoop hdl False
 210
 211   when (read_dot_files) $ do
 212     -- Read in $HOME/.ghci
 213     either_dir <- io (IO.try (getEnv "HOME"))
 214     case either_dir of
 215        Left e -> return ()
 216        Right dir -> do
 217           cwd <- io (getCurrentDirectory)
 218           when (dir /= cwd) $ do
 219              let file = dir ++ "/.ghci"
 220              ok <- io (checkPerms file)
 221              when ok $ do
 222                either_hdl <- io (IO.try (openFile file ReadMode))
 223                case either_hdl of
 224                   Left e    -> return ()
 225                   Right hdl -> fileLoop hdl False
 226
 227   -- Perform a :load for files given on the GHCi command line
 228   when (not (null paths)) $
 229      ghciHandle showException $
 230         loadModule paths
 231
 232   -- if verbosity is greater than 0, or we are connected to a
 233   -- terminal, display the prompt in the interactive loop.
 234   is_tty <- io (hIsTerminalDevice stdin)
 235   let show_prompt = verbosity dflags > 0 || is_tty
 236
 237   -- enter the interactive loop
 238   interactiveLoop is_tty show_prompt
 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 dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 379       (new_cmstate, result) <-
 380         io $ withProgName (progname st) $ withArgs (args st) $
 381         cmRunStmt (cmstate st) dflags' 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 -> DynFlags -> IO CmState
 436 initInterpBuffering cmstate dflags
 437  = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
 438
 439       case maybe_hval of
 440         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 441         other     -> panic "interactiveUI:setBuffering"
 442
 443       (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
 444       case maybe_hval of
 445         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 446         _         -> panic "interactiveUI:flush"
 447
 448       turnOffBuffering  -- Turn it off right now
 449
 450       return cmstate
 451
 452
 453 flushInterpBuffers :: GHCi ()
 454 flushInterpBuffers
 455  = io $ do Monad.join (readIORef flush_interp)
 456            return ()
 457
 458 turnOffBuffering :: IO ()
 459 turnOffBuffering
 460  = do Monad.join (readIORef turn_off_buffering)
 461       return ()
 462
 463 -----------------------------------------------------------------------------
 464 -- Commands
 465
 466 help :: String -> GHCi ()
 467 help _ = io (putStr helpText)
 468
 469 info :: String -> GHCi ()
 470 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 471 info s = do
 472   let names = words s
 473   init_cms <- getCmState
 474   dflags <- io getDynFlags
 475   let
 476     infoThings cms [] = return cms
 477     infoThings cms (name:names) = do
 478       (cms, stuff) <- io (cmInfoThing cms dflags name)
 479       io (putStrLn (showSDocForUser unqual (
 480             vcat (intersperse (text "") (map showThing stuff))))
 481          )
 482       infoThings cms names
 483
 484     unqual = cmGetPrintUnqual init_cms
 485
 486     showThing (ty_thing, fixity)
 487         = vcat [ text "-- " <> showTyThing ty_thing,
 488                  showFixity fixity (getName ty_thing),
 489                  ppr (ifaceTyThing ty_thing) ]
 490
 491     showFixity fix name
 492         | fix == defaultFixity = empty
 493         | otherwise            = ppr fix <+>
 494                                  (if isSymOcc (nameOccName name)
 495                                   then ppr name
 496                                   else char '`' <> ppr name <> char '`')
 497
 498     showTyThing (AClass cl)
 499        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
 500     showTyThing (ADataCon dc)
 501        = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
 502     showTyThing (ATyCon ty)
 503        | isPrimTyCon ty
 504        = hcat [ppr ty, text " is a primitive type constructor"]
 505        | otherwise
 506        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
 507     showTyThing (AnId   id)
 508        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 509
 510     idDescr id
 511        = case globalIdDetails id of
 512             RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
 513             ClassOpId cls   -> text "method in class" <+> ppr cls
 514             otherwise       -> text "variable"
 515
 516         -- also print out the source location for home things
 517     showSrcLoc name
 518         | isHomePackageName name && isGoodSrcLoc loc
 519         = hsep [ text ", defined at", ppr loc ]
 520         | otherwise
 521         = empty
 522         where loc = nameSrcLoc name
 523
 524   cms <- infoThings init_cms names
 525   setCmState cms
 526   return ()
 527
 528 addModule :: [FilePath] -> GHCi ()
 529 addModule files = do
 530   state <- getGHCiState
 531   dflags <- io (getDynFlags)
 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) dflags new_targets)
 536   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
 537   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 538   setContextAfterLoad mods
 539   modulesLoadedMsg ok mods dflags
 540
 541 changeDirectory :: String -> GHCi ()
 542 changeDirectory dir = do
 543   state    <- getGHCiState
 544   when (targets state /= []) $
 545         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\
 546         \because the search path has changed.\n"
 547   dflags   <- io getDynFlags
 548   cmstate1 <- io (cmUnload (cmstate state) dflags)
 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   dflags <- io getDynFlags
 573   (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
 574   setCmState new_cmstate
 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   dflags <- io getDynFlags
 606
 607   -- expand tildes
 608   files <- mapM expandPath files
 609
 610   -- do the dependency anal first, so that if it fails we don't throw
 611   -- away the current set of modules.
 612   graph <- io (cmDepAnal (cmstate state) dflags files)
 613
 614   -- Dependency anal ok, now unload everything
 615   cmstate1 <- io (cmUnload (cmstate state) dflags)
 616   setGHCiState state{ cmstate = cmstate1, targets = [] }
 617
 618   io (revertCAFs)  -- always revert CAFs on load.
 619   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
 620   setGHCiState state{ cmstate = cmstate2, targets = files }
 621
 622   setContextAfterLoad mods
 623   modulesLoadedMsg ok mods dflags
 624
 625
 626 reloadModule :: String -> GHCi ()
 627 reloadModule "" = do
 628   state <- getGHCiState
 629   dflags <- io getDynFlags
 630   case targets state of
 631    [] -> io (putStr "no current target\n")
 632    paths -> do
 633         -- do the dependency anal first, so that if it fails we don't throw
 634         -- away the current set of modules.
 635         graph <- io (cmDepAnal (cmstate state) dflags paths)
 636
 637         io (revertCAFs)         -- always revert CAFs on reload.
 638         (cmstate1, ok, mods)
 639                 <- io (cmLoadModules (cmstate state) dflags graph)
 640         setGHCiState state{ cmstate=cmstate1 }
 641         setContextAfterLoad mods
 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        dflags <- io getDynFlags
 669        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
 670        setCmState new_cmstate
 671        case maybe_tystr of
 672           Nothing    -> return ()
 673           Just tystr -> io (putStrLn tystr)
 674
 675 quit :: String -> GHCi Bool
 676 quit _ = return True
 677
 678 shellEscape :: String -> GHCi Bool
 679 shellEscape str = io (system str >> return False)
 680
 681 -----------------------------------------------------------------------------
 682 -- Browing a module's contents
 683
 684 browseCmd :: String -> GHCi ()
 685 browseCmd m =
 686   case words m of
 687     ['*':m] | looksLikeModuleName m -> browseModule m False
 688     [m]     | looksLikeModuleName m -> browseModule m True
 689     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 690
 691 browseModule m exports_only = do
 692   cms <- getCmState
 693   dflags <- io getDynFlags
 694
 695   is_interpreted <- io (cmModuleIsInterpreted cms m)
 696   when (not is_interpreted && not exports_only) $
 697         throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 698
 699   -- temporarily set the context to the module we're interested in,
 700   -- just so we can get an appropriate PrintUnqualified
 701   (as,bs) <- io (cmGetContext cms)
 702   cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
 703                               else cmSetContext cms dflags [m] [])
 704   cms2 <- io (cmSetContext cms1 dflags as bs)
 705
 706   (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
 707
 708   setCmState cms3
 709
 710   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 711
 712       things' = filter wantToSee things
 713
 714       wantToSee (AnId id)    = not (isImplicitId id)
 715       wantToSee (ADataCon _) = False    -- They'll come via their TyCon
 716       wantToSee _            = True
 717
 718       thing_names = map getName things
 719
 720       thingDecl thing@(AnId id)  = ifaceTyThing thing
 721
 722       thingDecl thing@(AClass c) =
 723         let rn_decl = ifaceTyThing thing in
 724         case rn_decl of
 725           ClassDecl { tcdSigs = cons } ->
 726                 rn_decl{ tcdSigs = filter methodIsVisible cons }
 727           other -> other
 728         where
 729            methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
 730
 731       thingDecl thing@(ATyCon t) =
 732         let rn_decl = ifaceTyThing thing in
 733         case rn_decl of
 734           TyData { tcdCons = DataCons cons } ->
 735                 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
 736           other -> other
 737         where
 738           conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
 739
 740   io (putStrLn (showSDocForUser unqual (
 741          vcat (map (ppr . thingDecl) things')))
 742    )
 743
 744   where
 745
 746 -----------------------------------------------------------------------------
 747 -- Setting the module context
 748
 749 setContext str
 750   | all sensible mods = fn mods
 751   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 752   where
 753     (fn, mods) = case str of
 754                         '+':stuff -> (addToContext,      words stuff)
 755                         '-':stuff -> (removeFromContext, words stuff)
 756                         stuff     -> (newContext,        words stuff)
 757
 758     sensible ('*':m) = looksLikeModuleName m
 759     sensible m       = looksLikeModuleName m
 760
 761 newContext mods = do
 762   cms <- getCmState
 763   dflags <- io getDynFlags
 764   (as,bs) <- separate cms mods [] []
 765   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 766   cms' <- io (cmSetContext cms dflags as bs')
 767   setCmState cms'
 768
 769 separate cmstate []           as bs = return (as,bs)
 770 separate cmstate (('*':m):ms) as bs = do
 771    b <- io (cmModuleIsInterpreted cmstate m)
 772    if b then separate cmstate ms (m:as) bs
 773         else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 774 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 775
 776 prel = "Prelude"
 777
 778
 779 addToContext mods = do
 780   cms <- getCmState
 781   dflags <- io getDynFlags
 782   (as,bs) <- io (cmGetContext cms)
 783
 784   (as',bs') <- separate cms mods [] []
 785
 786   let as_to_add = as' \\ (as ++ bs)
 787       bs_to_add = bs' \\ (as ++ bs)
 788
 789   cms' <- io (cmSetContext cms dflags
 790                         (as ++ as_to_add) (bs ++ bs_to_add))
 791   setCmState cms'
 792
 793
 794 removeFromContext mods = do
 795   cms <- getCmState
 796   dflags <- io getDynFlags
 797   (as,bs) <- io (cmGetContext cms)
 798
 799   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 800
 801   let as' = as \\ (as_to_remove ++ bs_to_remove)
 802       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 803
 804   cms' <- io (cmSetContext cms dflags as' bs')
 805   setCmState cms'
 806
 807 ----------------------------------------------------------------------------
 808 -- Code for `:set'
 809
 810 -- set options in the interpreter.  Syntax is exactly the same as the
 811 -- ghc command line, except that certain options aren't available (-C,
 812 -- -E etc.)
 813 --
 814 -- This is pretty fragile: most options won't work as expected.  ToDo:
 815 -- figure out which ones & disallow them.
 816
 817 setCmd :: String -> GHCi ()
 818 setCmd ""
 819   = do st <- getGHCiState
 820        let opts = options st
 821        io $ putStrLn (showSDoc (
 822               text "options currently set: " <>
 823               if null opts
 824                    then text "none."
 825                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 826            ))
 827 setCmd str
 828   = case words str of
 829         ("args":args) -> setArgs args
 830         ("prog":prog) -> setProg prog
 831         wds -> setOptions wds
 832
 833 setArgs args = do
 834   st <- getGHCiState
 835   setGHCiState st{ args = args }
 836
 837 setProg [prog] = do
 838   st <- getGHCiState
 839   setGHCiState st{ progname = prog }
 840 setProg _ = do
 841   io (hPutStrLn stderr "syntax: :set prog <progname>")
 842
 843 setOptions wds =
 844    do -- first, deal with the GHCi opts (+s, +t, etc.)
 845       let (plus_opts, minus_opts)  = partition isPlus wds
 846       mapM_ setOpt plus_opts
 847
 848       -- now, the GHC flags
 849       pkgs_before <- io (readIORef v_ExplicitPackages)
 850       leftovers   <- io (processArgs static_flags minus_opts [])
 851       pkgs_after  <- io (readIORef v_ExplicitPackages)
 852
 853       -- update things if the users wants more packages
 854       let new_packages = pkgs_after \\ pkgs_before
 855       when (not (null new_packages)) $
 856          newPackages new_packages
 857
 858       -- don't forget about the extra command-line flags from the
 859       -- extra_ghc_opts fields in the new packages
 860       new_package_details <- io (getPackageDetails new_packages)
 861       let pkg_extra_opts = concatMap extra_ghc_opts new_package_details
 862       pkg_extra_dyn <- io (processArgs static_flags pkg_extra_opts [])
 863
 864       -- then, dynamic flags
 865       io $ do
 866         restoreDynFlags
 867         leftovers <- processArgs dynamic_flags (leftovers ++ pkg_extra_dyn) []
 868         saveDynFlags
 869
 870         if (not (null leftovers))
 871                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 872                                                 unwords leftovers))
 873                 else return ()
 874
 875
 876 unsetOptions :: String -> GHCi ()
 877 unsetOptions str
 878   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 879        let opts = words str
 880            (minus_opts, rest1) = partition isMinus opts
 881            (plus_opts, rest2)  = partition isPlus rest1
 882
 883        if (not (null rest2))
 884           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 885           else do
 886
 887        mapM_ unsetOpt plus_opts
 888
 889        -- can't do GHC flags for now
 890        if (not (null minus_opts))
 891           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 892           else return ()
 893
 894 isMinus ('-':s) = True
 895 isMinus _ = False
 896
 897 isPlus ('+':s) = True
 898 isPlus _ = False
 899
 900 setOpt ('+':str)
 901   = case strToGHCiOpt str of
 902         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 903         Just o  -> setOption o
 904
 905 unsetOpt ('+':str)
 906   = case strToGHCiOpt str of
 907         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 908         Just o  -> unsetOption o
 909
 910 strToGHCiOpt :: String -> (Maybe GHCiOption)
 911 strToGHCiOpt "s" = Just ShowTiming
 912 strToGHCiOpt "t" = Just ShowType
 913 strToGHCiOpt "r" = Just RevertCAFs
 914 strToGHCiOpt _   = Nothing
 915
 916 optToStr :: GHCiOption -> String
 917 optToStr ShowTiming = "s"
 918 optToStr ShowType   = "t"
 919 optToStr RevertCAFs = "r"
 920
 921 newPackages new_pkgs = do       -- The new packages are already in v_Packages
 922   state    <- getGHCiState
 923   dflags   <- io getDynFlags
 924   cmstate1 <- io (cmUnload (cmstate state) dflags)
 925   setGHCiState state{ cmstate = cmstate1, targets = [] }
 926   io (linkPackages dflags new_pkgs)
 927   setContextAfterLoad []
 928
 929 -- ---------------------------------------------------------------------------
 930 -- code for `:show'
 931
 932 showCmd str =
 933   case words str of
 934         ["modules" ] -> showModules
 935         ["bindings"] -> showBindings
 936         ["linker"]   -> io showLinkerState
 937         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 938
 939 showModules = do
 940   cms <- getCmState
 941   let (mg, hpt) = cmGetModInfo cms
 942   mapM_ (showModule hpt) mg
 943
 944
 945 showModule :: HomePackageTable -> ModSummary -> GHCi ()
 946 showModule hpt mod_summary
 947   = case lookupModuleEnv hpt mod of
 948         Nothing       -> panic "missing linkable"
 949         Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
 950                       where
 951                          obj_linkable = isObjectLinkable (hm_linkable mod_info)
 952   where
 953     mod = ms_mod mod_summary
 954     locn = ms_location mod_summary
 955
 956 showBindings = do
 957   cms <- getCmState
 958   let
 959         unqual = cmGetPrintUnqual cms
 960         showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
 961
 962   io (mapM_ showBinding (cmGetBindings cms))
 963   return ()
 964
 965
 966 -----------------------------------------------------------------------------
 967 -- GHCi monad
 968
 969 data GHCiState = GHCiState
 970      {
 971         progname       :: String,
 972         args           :: [String],
 973         targets        :: [FilePath],
 974         cmstate        :: CmState,
 975         options        :: [GHCiOption]
 976      }
 977
 978 data GHCiOption
 979         = ShowTiming            -- show time/allocs after evaluation
 980         | ShowType              -- show the type of expressions
 981         | RevertCAFs            -- revert CAFs after every evaluation
 982         deriving Eq
 983
 984 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 985
 986 startGHCi :: GHCi a -> GHCiState -> IO a
 987 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 988
 989 instance Monad GHCi where
 990   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 991   return a  = GHCi $ \s -> return a
 992
 993 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 994 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 995    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 996
 997 getGHCiState   = GHCi $ \r -> readIORef r
 998 setGHCiState s = GHCi $ \r -> writeIORef r s
 999
1000 -- for convenience...
1001 getCmState = getGHCiState >>= return . cmstate
1002 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
1003
1004 isOptionSet :: GHCiOption -> GHCi Bool
1005 isOptionSet opt
1006  = do st <- getGHCiState
1007       return (opt `elem` options st)
1008
1009 setOption :: GHCiOption -> GHCi ()
1010 setOption opt
1011  = do st <- getGHCiState
1012       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1013
1014 unsetOption :: GHCiOption -> GHCi ()
1015 unsetOption opt
1016  = do st <- getGHCiState
1017       setGHCiState (st{ options = filter (/= opt) (options st) })
1018
1019 io :: IO a -> GHCi a
1020 io m = GHCi { unGHCi = \s -> m >>= return }
1021
1022 -----------------------------------------------------------------------------
1023 -- recursive exception handlers
1024
1025 -- Don't forget to unblock async exceptions in the handler, or if we're
1026 -- in an exception loop (eg. let a = error a in a) the ^C exception
1027 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1028
1029 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1030 ghciHandle h (GHCi m) = GHCi $ \s ->
1031    Exception.catch (m s)
1032         (\e -> unGHCi (ghciUnblock (h e)) s)
1033
1034 ghciUnblock :: GHCi a -> GHCi a
1035 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1036
1037 -----------------------------------------------------------------------------
1038 -- timing & statistics
1039
1040 timeIt :: GHCi a -> GHCi a
1041 timeIt action
1042   = do b <- isOptionSet ShowTiming
1043        if not b
1044           then action
1045           else do allocs1 <- io $ getAllocations
1046                   time1   <- io $ getCPUTime
1047                   a <- action
1048                   allocs2 <- io $ getAllocations
1049                   time2   <- io $ getCPUTime
1050                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
1051                   return a
1052
1053 foreign import ccall "getAllocations" getAllocations :: IO Int
1054
1055 printTimes :: Int -> Integer -> IO ()
1056 printTimes allocs psecs
1057    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1058             secs_str = showFFloat (Just 2) secs
1059         putStrLn (showSDoc (
1060                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1061                          int allocs <+> text "bytes")))
1062
1063 -----------------------------------------------------------------------------
1064 -- reverting CAFs
1065
1066 revertCAFs :: IO ()
1067 revertCAFs = do
1068   rts_revertCAFs
1069   turnOffBuffering
1070         -- Have to turn off buffering again, because we just
1071         -- reverted stdout, stderr & stdin to their defaults.
1072
1073 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1074         -- Make it "safe", just in case
1075
1076 -- -----------------------------------------------------------------------------
1077 -- Utils
1078
1079 expandPath :: String -> GHCi String
1080 expandPath path =
1081   case dropWhile isSpace path of
1082    ('~':d) -> do
1083         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1084         return (tilde ++ '/':d)
1085    other ->
1086         return other