ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.134 2002/09/13 15:02:32 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 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 -----------------------------------------------------------------------------
  78
  79 ghciWelcomeMsg = "\
  80 \   ___         ___ _\n\
  81 \  / _ \\ /\\  /\\/ __(_)\n\
  82 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
  83 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  84 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  85
  86 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  87
  88 builtin_commands :: [(String, String -> GHCi Bool)]
  89 builtin_commands = [
  90   ("add",       keepGoing addModule),
  91   ("browse",    keepGoing browseCmd),
  92   ("cd",        keepGoing changeDirectory),
  93   ("def",       keepGoing defineMacro),
  94   ("help",      keepGoing help),
  95   ("?",         keepGoing help),
  96   ("info",      keepGoing info),
  97   ("load",      keepGoing loadModule),
  98   ("module",    keepGoing setContext),
  99   ("reload",    keepGoing reloadModule),
 100   ("set",       keepGoing setCmd),
 101   ("show",      keepGoing showCmd),
 102   ("type",      keepGoing typeOfExpr),
 103   ("unset",     keepGoing unsetOptions),
 104   ("undef",     keepGoing undefineMacro),
 105   ("quit",      quit)
 106   ]
 107
 108 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 109 keepGoing a str = a str >> return False
 110
 111 shortHelpText = "use :? for help.\n"
 112
 113 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 114 helpText = "\
 115 \ Commands available from the prompt:\n\
 116 \\n\
 117 \   <stmt>                     evaluate/run <stmt>\n\
 118 \   :add <filename> ...        add module(s) to the current target set\n\
 119 \   :browse [*]<module>        display the names defined by <module>\n\
 120 \   :cd <dir>                  change directory to <dir>\n\
 121 \   :def <cmd> <expr>          define a command :<cmd>\n\
 122 \   :help, :?                  display this list of commands\n\
 123 \   :info [<name> ...]         display information about the given names\n\
 124 \   :load <filename> ...       load module(s) and their dependents\n\
 125 \   :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
 126 \   :reload                    reload the current module set\n\
 127 \\n\
 128 \   :set <option> ...          set options\n\
 129 \   :set args <arg> ...        set the arguments returned by System.getArgs\n\
 130 \   :set prog <progname>       set the value returned by System.getProgName\n\
 131 \\n\
 132 \   :show modules              show the currently loaded modules\n\
 133 \   :show bindings             show the current bindings made at the prompt\n\
 134 \\n\
 135 \   :type <expr>               show the type of <expr>\n\
 136 \   :undef <cmd>               undefine user-defined command :<cmd>\n\
 137 \   :unset <option> ...        unset options\n\
 138 \   :quit                      exit GHCi\n\
 139 \   :!<command>                run the shell command <command>\n\
 140 \\n\
 141 \ Options for `:set' and `:unset':\n\
 142 \\n\
 143 \    +r                 revert top-level expressions after each evaluation\n\
 144 \    +s                 print timing/memory stats after each evaluation\n\
 145 \    +t                 print type after evaluation\n\
 146 \    -<flags>           most GHC command line flags can also be set here\n\
 147 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 148 \"
 149
 150 interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO ()
 151 interactiveUI cmstate paths cmdline_objs = do
 152    hFlush stdout
 153    hSetBuffering stdout NoBuffering
 154
 155    dflags <- getDynFlags
 156
 157    -- Link in the available packages
 158    initLinker
 159         --      Now that demand-loading works, we don't really need to pre-load the packages
 160         --   pkgs <- getPackages
 161         --   linkPackages dflags  pkgs
 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    case l of
 324         Nothing -> return ()
 325         Just l  ->
 326           case remove_spaces l of
 327             "" -> readlineLoop
 328             l  -> do
 329                   io (addHistory l)
 330                   quit <- runCommand l
 331                   if quit then return () else readlineLoop
 332 #endif
 333
 334 -- Top level exception handler, just prints out the exception
 335 -- and carries on.
 336 runCommand :: String -> GHCi Bool
 337 runCommand c =
 338   ghciHandle ( \exception -> do
 339                 flushInterpBuffers
 340                 showException exception
 341                 return False
 342              ) $
 343   doCommand c
 344
 345 showException (DynException dyn) =
 346   case fromDynamic dyn of
 347     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 348     Just Interrupted      -> io (putStrLn "Interrupted.")
 349     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 350     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 351     Just other_ghc_ex     -> io (print other_ghc_ex)
 352
 353 showException other_exception
 354   = io (putStrLn ("*** Exception: " ++ show other_exception))
 355
 356 doCommand (':' : command) = specialCommand command
 357 doCommand stmt
 358    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 359         return False
 360
 361 runStmt :: String -> GHCi [Name]
 362 runStmt stmt
 363  | null (filter (not.isSpace) stmt) = return []
 364  | otherwise
 365  = do st <- getGHCiState
 366       dflags <- io getDynFlags
 367       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 368       (new_cmstate, result) <-
 369         io $ withProgName (progname st) $ withArgs (args st) $
 370         cmRunStmt (cmstate st) dflags' stmt
 371       setGHCiState st{cmstate = new_cmstate}
 372       case result of
 373         CmRunFailed      -> return []
 374         CmRunException e -> showException e >> return []
 375         CmRunOk names    -> return names
 376
 377 -- possibly print the type and revert CAFs after evaluating an expression
 378 finishEvalExpr names
 379  = do b <- isOptionSet ShowType
 380       cmstate <- getCmState
 381       when b (mapM_ (showTypeOfName cmstate) names)
 382
 383       flushInterpBuffers
 384       b <- isOptionSet RevertCAFs
 385       io (when b revertCAFs)
 386       return True
 387
 388 showTypeOfName :: CmState -> Name -> GHCi ()
 389 showTypeOfName cmstate n
 390    = do maybe_str <- io (cmTypeOfName cmstate n)
 391         case maybe_str of
 392           Nothing  -> return ()
 393           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 394
 395 specialCommand :: String -> GHCi Bool
 396 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 397 specialCommand str = do
 398   let (cmd,rest) = break isSpace str
 399   cmds <- io (readIORef commands)
 400   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 401      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 402                                     ++ shortHelpText) >> return False)
 403      [(_,f)] -> f (dropWhile isSpace rest)
 404      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 405                                       " matches multiple commands (" ++
 406                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 407                                          ++ ")") >> return False)
 408
 409 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 410
 411
 412 -----------------------------------------------------------------------------
 413 -- To flush buffers for the *interpreted* computation we need
 414 -- to refer to *its* stdout/stderr handles
 415
 416 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 417 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 418
 419 no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
 420              " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
 421 flush_cmd  = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
 422
 423 initInterpBuffering :: CmState -> DynFlags -> IO CmState
 424 initInterpBuffering cmstate dflags
 425  = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
 426
 427       case maybe_hval of
 428         Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 429         other     -> panic "interactiveUI:setBuffering"
 430
 431       (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
 432       case maybe_hval of
 433         Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 434         _         -> panic "interactiveUI:flush"
 435
 436       turnOffBuffering  -- Turn it off right now
 437
 438       return cmstate
 439
 440
 441 flushInterpBuffers :: GHCi ()
 442 flushInterpBuffers
 443  = io $ do Monad.join (readIORef flush_interp)
 444            return ()
 445
 446 turnOffBuffering :: IO ()
 447 turnOffBuffering
 448  = do Monad.join (readIORef turn_off_buffering)
 449       return ()
 450
 451 -----------------------------------------------------------------------------
 452 -- Commands
 453
 454 help :: String -> GHCi ()
 455 help _ = io (putStr helpText)
 456
 457 info :: String -> GHCi ()
 458 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 459 info s = do
 460   let names = words s
 461   init_cms <- getCmState
 462   dflags <- io getDynFlags
 463   let
 464     infoThings cms [] = return cms
 465     infoThings cms (name:names) = do
 466       (cms, stuff) <- io (cmInfoThing cms dflags name)
 467       io (putStrLn (showSDocForUser unqual (
 468             vcat (intersperse (text "") (map showThing stuff))))
 469          )
 470       infoThings cms names
 471
 472     unqual = cmGetPrintUnqual init_cms
 473
 474     showThing (ty_thing, fixity)
 475         = vcat [ text "-- " <> showTyThing ty_thing,
 476                  showFixity fixity (getName ty_thing),
 477                  ppr (ifaceTyThing ty_thing) ]
 478
 479     showFixity fix name
 480         | fix == defaultFixity = empty
 481         | otherwise            = ppr fix <+>
 482                                  (if isSymOcc (nameOccName name)
 483                                         then ppr name
 484                                         else char '`' <> ppr name <> char '`')
 485
 486     showTyThing (AClass cl)
 487        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
 488     showTyThing (ATyCon ty)
 489        | isPrimTyCon ty
 490        = hcat [ppr ty, text " is a primitive type constructor"]
 491        | otherwise
 492        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
 493     showTyThing (AnId   id)
 494        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 495
 496     idDescr id
 497        | isRecordSelector id =
 498                 case tyConClass_maybe (fieldLabelTyCon (
 499                                 recordSelectorFieldLabel id)) of
 500                         Nothing -> text "record selector"
 501                         Just c  -> text "method in class " <> ppr c
 502        | isDataConWrapId id  = text "data constructor"
 503        | otherwise           = text "variable"
 504
 505         -- also print out the source location for home things
 506     showSrcLoc name
 507         | isHomePackageName name && isGoodSrcLoc loc
 508         = hsep [ text ", defined at", ppr loc ]
 509         | otherwise
 510         = empty
 511         where loc = nameSrcLoc name
 512
 513   cms <- infoThings init_cms names
 514   setCmState cms
 515   return ()
 516
 517 addModule :: String -> GHCi ()
 518 addModule str = do
 519   let files = words str
 520   state <- getGHCiState
 521   dflags <- io (getDynFlags)
 522   io (revertCAFs)                       -- always revert CAFs on load/add.
 523   let new_targets = files ++ targets state
 524   graph <- io (cmDepAnal (cmstate state) dflags new_targets)
 525   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
 526   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 527   setContextAfterLoad mods
 528   modulesLoadedMsg ok mods dflags
 529
 530 changeDirectory :: String -> GHCi ()
 531 changeDirectory ('~':d) = do
 532    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 533    io (setCurrentDirectory (tilde ++ '/':d))
 534 changeDirectory d = io (setCurrentDirectory d)
 535
 536 defineMacro :: String -> GHCi ()
 537 defineMacro s = do
 538   let (macro_name, definition) = break isSpace s
 539   cmds <- io (readIORef commands)
 540   if (null macro_name)
 541         then throwDyn (CmdLineError "invalid macro name")
 542         else do
 543   if (macro_name `elem` map fst cmds)
 544         then throwDyn (CmdLineError
 545                 ("command `" ++ macro_name ++ "' is already defined"))
 546         else do
 547
 548   -- give the expression a type signature, so we can be sure we're getting
 549   -- something of the right type.
 550   let new_expr = '(' : definition ++ ") :: String -> IO String"
 551
 552   -- compile the expression
 553   cms <- getCmState
 554   dflags <- io getDynFlags
 555   (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
 556   setCmState new_cmstate
 557   case maybe_hv of
 558      Nothing -> return ()
 559      Just hv -> io (writeIORef commands --
 560                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 561
 562 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 563 runMacro fun s = do
 564   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 565   stringLoop (lines str)
 566
 567 undefineMacro :: String -> GHCi ()
 568 undefineMacro macro_name = do
 569   cmds <- io (readIORef commands)
 570   if (macro_name `elem` map fst builtin_commands)
 571         then throwDyn (CmdLineError
 572                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 573         else do
 574   if (macro_name `notElem` map fst cmds)
 575         then throwDyn (CmdLineError
 576                 ("command `" ++ macro_name ++ "' not defined"))
 577         else do
 578   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 579
 580
 581 loadModule :: String -> GHCi ()
 582 loadModule str = timeIt (loadModule' str)
 583
 584 loadModule' str = do
 585   let files = words str
 586   state <- getGHCiState
 587   dflags <- io getDynFlags
 588
 589   -- do the dependency anal first, so that if it fails we don't throw
 590   -- away the current set of modules.
 591   graph <- io (cmDepAnal (cmstate state) dflags files)
 592
 593   -- Dependency anal ok, now unload everything
 594   cmstate1 <- io (cmUnload (cmstate state) dflags)
 595   setGHCiState state{ cmstate = cmstate1, targets = [] }
 596
 597   io (revertCAFs)  -- always revert CAFs on load.
 598   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
 599   setGHCiState state{ cmstate = cmstate2, targets = files }
 600
 601   setContextAfterLoad mods
 602   modulesLoadedMsg ok mods dflags
 603
 604
 605 reloadModule :: String -> GHCi ()
 606 reloadModule "" = do
 607   state <- getGHCiState
 608   dflags <- io getDynFlags
 609   case targets state of
 610    [] -> io (putStr "no current target\n")
 611    paths -> do
 612         -- do the dependency anal first, so that if it fails we don't throw
 613         -- away the current set of modules.
 614         graph <- io (cmDepAnal (cmstate state) dflags paths)
 615
 616         io (revertCAFs)         -- always revert CAFs on reload.
 617         (cmstate1, ok, mods)
 618                 <- io (cmLoadModules (cmstate state) dflags graph)
 619         setGHCiState state{ cmstate=cmstate1 }
 620         setContextAfterLoad mods
 621         modulesLoadedMsg ok mods dflags
 622
 623 reloadModule _ = noArgs ":reload"
 624
 625 setContextAfterLoad [] = setContext prel
 626 setContextAfterLoad (m:_) = do
 627   cmstate <- getCmState
 628   b <- io (cmModuleIsInterpreted cmstate m)
 629   if b then setContext ('*':m) else setContext m
 630
 631 modulesLoadedMsg ok mods dflags =
 632   when (verbosity dflags > 0) $ do
 633    let mod_commas
 634         | null mods = text "none."
 635         | otherwise = hsep (
 636             punctuate comma (map text mods)) <> text "."
 637    case ok of
 638     Failed ->
 639        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 640     Succeeded  ->
 641        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 642
 643
 644 typeOfExpr :: String -> GHCi ()
 645 typeOfExpr str
 646   = do cms <- getCmState
 647        dflags <- io getDynFlags
 648        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
 649        setCmState new_cmstate
 650        case maybe_tystr of
 651           Nothing    -> return ()
 652           Just tystr -> io (putStrLn tystr)
 653
 654 quit :: String -> GHCi Bool
 655 quit _ = return True
 656
 657 shellEscape :: String -> GHCi Bool
 658 shellEscape str = io (system str >> return False)
 659
 660 -----------------------------------------------------------------------------
 661 -- Browing a module's contents
 662
 663 browseCmd :: String -> GHCi ()
 664 browseCmd m =
 665   case words m of
 666     ['*':m] | looksLikeModuleName m -> browseModule m False
 667     [m]     | looksLikeModuleName m -> browseModule m True
 668     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 669
 670 browseModule m exports_only = do
 671   cms <- getCmState
 672   dflags <- io getDynFlags
 673
 674   is_interpreted <- io (cmModuleIsInterpreted cms m)
 675   when (not is_interpreted && not exports_only) $
 676         throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 677
 678   -- temporarily set the context to the module we're interested in,
 679   -- just so we can get an appropriate PrintUnqualified
 680   (as,bs) <- io (cmGetContext cms)
 681   cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
 682                               else cmSetContext cms dflags [m] [])
 683   cms2 <- io (cmSetContext cms1 dflags as bs)
 684
 685   (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
 686
 687   setCmState cms3
 688
 689   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 690
 691       things' = filter wantToSee things
 692
 693       wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
 694       wantToSee _ = True
 695
 696       thing_names = map getName things
 697
 698       thingDecl thing@(AnId id)  = ifaceTyThing thing
 699
 700       thingDecl thing@(AClass c) =
 701         let rn_decl = ifaceTyThing thing in
 702         case rn_decl of
 703           ClassDecl { tcdSigs = cons } ->
 704                 rn_decl{ tcdSigs = filter methodIsVisible cons }
 705           other -> other
 706         where
 707            methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
 708
 709       thingDecl thing@(ATyCon t) =
 710         let rn_decl = ifaceTyThing thing in
 711         case rn_decl of
 712           TyData { tcdCons = DataCons cons } ->
 713                 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
 714           other -> other
 715         where
 716           conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
 717
 718   io (putStrLn (showSDocForUser unqual (
 719          vcat (map (ppr . thingDecl) things')))
 720    )
 721
 722   where
 723
 724 -----------------------------------------------------------------------------
 725 -- Setting the module context
 726
 727 setContext str
 728   | all sensible mods = fn mods
 729   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 730   where
 731     (fn, mods) = case str of
 732                         '+':stuff -> (addToContext,      words stuff)
 733                         '-':stuff -> (removeFromContext, words stuff)
 734                         stuff     -> (newContext,        words stuff)
 735
 736     sensible ('*':m) = looksLikeModuleName m
 737     sensible m       = looksLikeModuleName m
 738
 739 newContext mods = do
 740   cms <- getCmState
 741   dflags <- io getDynFlags
 742   (as,bs) <- separate cms mods [] []
 743   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 744   cms' <- io (cmSetContext cms dflags as bs')
 745   setCmState cms'
 746
 747 separate cmstate []           as bs = return (as,bs)
 748 separate cmstate (('*':m):ms) as bs = do
 749    b <- io (cmModuleIsInterpreted cmstate m)
 750    if b then separate cmstate ms (m:as) bs
 751         else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 752 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 753
 754 prel = "Prelude"
 755
 756
 757 addToContext mods = do
 758   cms <- getCmState
 759   dflags <- io getDynFlags
 760   (as,bs) <- io (cmGetContext cms)
 761
 762   (as',bs') <- separate cms mods [] []
 763
 764   let as_to_add = as' \\ (as ++ bs)
 765       bs_to_add = bs' \\ (as ++ bs)
 766
 767   cms' <- io (cmSetContext cms dflags
 768                         (as ++ as_to_add) (bs ++ bs_to_add))
 769   setCmState cms'
 770
 771
 772 removeFromContext mods = do
 773   cms <- getCmState
 774   dflags <- io getDynFlags
 775   (as,bs) <- io (cmGetContext cms)
 776
 777   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 778
 779   let as' = as \\ (as_to_remove ++ bs_to_remove)
 780       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 781
 782   cms' <- io (cmSetContext cms dflags as' bs')
 783   setCmState cms'
 784
 785 ----------------------------------------------------------------------------
 786 -- Code for `:set'
 787
 788 -- set options in the interpreter.  Syntax is exactly the same as the
 789 -- ghc command line, except that certain options aren't available (-C,
 790 -- -E etc.)
 791 --
 792 -- This is pretty fragile: most options won't work as expected.  ToDo:
 793 -- figure out which ones & disallow them.
 794
 795 setCmd :: String -> GHCi ()
 796 setCmd ""
 797   = do st <- getGHCiState
 798        let opts = options st
 799        io $ putStrLn (showSDoc (
 800               text "options currently set: " <>
 801               if null opts
 802                    then text "none."
 803                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 804            ))
 805 setCmd str
 806   = case words str of
 807         ("args":args) -> setArgs args
 808         ("prog":prog) -> setProg prog
 809         wds -> setOptions wds
 810
 811 setArgs args = do
 812   st <- getGHCiState
 813   setGHCiState st{ args = args }
 814
 815 setProg [prog] = do
 816   st <- getGHCiState
 817   setGHCiState st{ progname = prog }
 818 setProg _ = do
 819   io (hPutStrLn stderr "syntax: :set prog <progname>")
 820
 821 setOptions wds =
 822    do -- first, deal with the GHCi opts (+s, +t, etc.)
 823       let (plus_opts, minus_opts)  = partition isPlus wds
 824       mapM_ setOpt plus_opts
 825
 826       -- now, the GHC flags
 827       pkgs_before <- io (readIORef v_Packages)
 828       leftovers   <- io (processArgs static_flags minus_opts [])
 829       pkgs_after  <- io (readIORef v_Packages)
 830
 831       -- update things if the users wants more packages
 832       when (pkgs_before /= pkgs_after) $
 833          newPackages (pkgs_after \\ pkgs_before)
 834
 835       -- then, dynamic flags
 836       io $ do
 837         restoreDynFlags
 838         leftovers <- processArgs dynamic_flags leftovers []
 839         saveDynFlags
 840
 841         if (not (null leftovers))
 842                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 843                                                 unwords leftovers))
 844                 else return ()
 845
 846
 847 unsetOptions :: String -> GHCi ()
 848 unsetOptions str
 849   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 850        let opts = words str
 851            (minus_opts, rest1) = partition isMinus opts
 852            (plus_opts, rest2)  = partition isPlus rest1
 853
 854        if (not (null rest2))
 855           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 856           else do
 857
 858        mapM_ unsetOpt plus_opts
 859
 860        -- can't do GHC flags for now
 861        if (not (null minus_opts))
 862           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 863           else return ()
 864
 865 isMinus ('-':s) = True
 866 isMinus _ = False
 867
 868 isPlus ('+':s) = True
 869 isPlus _ = False
 870
 871 setOpt ('+':str)
 872   = case strToGHCiOpt str of
 873         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 874         Just o  -> setOption o
 875
 876 unsetOpt ('+':str)
 877   = case strToGHCiOpt str of
 878         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 879         Just o  -> unsetOption o
 880
 881 strToGHCiOpt :: String -> (Maybe GHCiOption)
 882 strToGHCiOpt "s" = Just ShowTiming
 883 strToGHCiOpt "t" = Just ShowType
 884 strToGHCiOpt "r" = Just RevertCAFs
 885 strToGHCiOpt _   = Nothing
 886
 887 optToStr :: GHCiOption -> String
 888 optToStr ShowTiming = "s"
 889 optToStr ShowType   = "t"
 890 optToStr RevertCAFs = "r"
 891
 892 newPackages new_pkgs = do       -- The new packages are already in v_Packages
 893   state    <- getGHCiState
 894   dflags   <- io getDynFlags
 895   cmstate1 <- io (cmUnload (cmstate state) dflags)
 896   setGHCiState state{ cmstate = cmstate1, targets = [] }
 897
 898   io $ do pkgs <- getPackageInfo
 899           flushPackageCache pkgs
 900
 901   setContextAfterLoad []
 902
 903 -----------------------------------------------------------------------------
 904 -- code for `:show'
 905
 906 showCmd str =
 907   case words str of
 908         ["modules" ] -> showModules
 909         ["bindings"] -> showBindings
 910         ["linker"]   -> io showLinkerState
 911         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 912
 913 showModules = do
 914   cms <- getCmState
 915   let (mg, hpt) = cmGetModInfo cms
 916   mapM_ (showModule hpt) mg
 917
 918
 919 showModule :: HomePackageTable -> ModSummary -> GHCi ()
 920 showModule hpt mod_summary
 921   = case lookupModuleEnv hpt mod of
 922         Nothing       -> panic "missing linkable"
 923         Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
 924                       where
 925                          obj_linkable = isObjectLinkable (hm_linkable mod_info)
 926   where
 927     mod = ms_mod mod_summary
 928     locn = ms_location mod_summary
 929
 930 showBindings = do
 931   cms <- getCmState
 932   let
 933         unqual = cmGetPrintUnqual cms
 934         showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
 935
 936   io (mapM_ showBinding (cmGetBindings cms))
 937   return ()
 938
 939
 940 -----------------------------------------------------------------------------
 941 -- GHCi monad
 942
 943 data GHCiState = GHCiState
 944      {
 945         progname       :: String,
 946         args           :: [String],
 947         targets        :: [FilePath],
 948         cmstate        :: CmState,
 949         options        :: [GHCiOption]
 950      }
 951
 952 data GHCiOption
 953         = ShowTiming            -- show time/allocs after evaluation
 954         | ShowType              -- show the type of expressions
 955         | RevertCAFs            -- revert CAFs after every evaluation
 956         deriving Eq
 957
 958 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 959
 960 startGHCi :: GHCi a -> GHCiState -> IO a
 961 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 962
 963 instance Monad GHCi where
 964   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 965   return a  = GHCi $ \s -> return a
 966
 967 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 968 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 969    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 970
 971 getGHCiState   = GHCi $ \r -> readIORef r
 972 setGHCiState s = GHCi $ \r -> writeIORef r s
 973
 974 -- for convenience...
 975 getCmState = getGHCiState >>= return . cmstate
 976 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
 977
 978 isOptionSet :: GHCiOption -> GHCi Bool
 979 isOptionSet opt
 980  = do st <- getGHCiState
 981       return (opt `elem` options st)
 982
 983 setOption :: GHCiOption -> GHCi ()
 984 setOption opt
 985  = do st <- getGHCiState
 986       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 987
 988 unsetOption :: GHCiOption -> GHCi ()
 989 unsetOption opt
 990  = do st <- getGHCiState
 991       setGHCiState (st{ options = filter (/= opt) (options st) })
 992
 993 io :: IO a -> GHCi a
 994 io m = GHCi { unGHCi = \s -> m >>= return }
 995
 996 -----------------------------------------------------------------------------
 997 -- recursive exception handlers
 998
 999 -- Don't forget to unblock async exceptions in the handler, or if we're
1000 -- in an exception loop (eg. let a = error a in a) the ^C exception
1001 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1002
1003 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1004 ghciHandle h (GHCi m) = GHCi $ \s ->
1005    Exception.catch (m s)
1006         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
1007
1008 ghciUnblock :: GHCi a -> GHCi a
1009 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1010
1011 -----------------------------------------------------------------------------
1012 -- timing & statistics
1013
1014 timeIt :: GHCi a -> GHCi a
1015 timeIt action
1016   = do b <- isOptionSet ShowTiming
1017        if not b
1018           then action
1019           else do allocs1 <- io $ getAllocations
1020                   time1   <- io $ getCPUTime
1021                   a <- action
1022                   allocs2 <- io $ getAllocations
1023                   time2   <- io $ getCPUTime
1024                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
1025                   return a
1026
1027 foreign import ccall "getAllocations" getAllocations :: IO Int
1028
1029 printTimes :: Int -> Integer -> IO ()
1030 printTimes allocs psecs
1031    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1032             secs_str = showFFloat (Just 2) secs
1033         putStrLn (showSDoc (
1034                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1035                          int allocs <+> text "bytes")))
1036
1037 -----------------------------------------------------------------------------
1038 -- utils
1039
1040 looksLikeModuleName [] = False
1041 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1042
1043 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1044
1045 -----------------------------------------------------------------------------
1046 -- reverting CAFs
1047
1048 revertCAFs :: IO ()
1049 revertCAFs = do
1050   rts_revertCAFs
1051   turnOffBuffering
1052         -- Have to turn off buffering again, because we just
1053         -- reverted stdout, stderr & stdin to their defaults.
1054
1055 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1056         -- Make it "safe", just in case