ghc/compiler/ghci/InteractiveUI.hs

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