ghc/compiler/ghci/InteractiveUI.hs

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