ghc/compiler/ghci/InteractiveUI.hs

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