ghc/compiler/ghci/InteractiveUI.hs

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