ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.131 2002/08/05 09:18:27 simonmar Exp $
   4 --
   5 -- GHC Interactive User Interface
   6 --
   7 -- (c) The GHC Team 2000
   8 --
   9 -----------------------------------------------------------------------------
  10 module InteractiveUI (
  11         interactiveUI,  -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
  12         LibrarySpec(..),
  13         ghciWelcomeMsg
  14    ) where
  15
  16 #include "../includes/config.h"
  17 #include "HsVersions.h"
  18
  19 import Packages
  20
  21 import CompManager
  22 import CmTypes          ( Linkable, isObjectLinkable, ModSummary(..) )
  23 import CmLink           ( findModuleLinkable_maybe )
  24
  25 import HscTypes         ( TyThing(..), showModMsg, InteractiveContext(..) )
  26 import HsSyn            ( TyClDecl(..), ConDecl(..), Sig(..) )
  27 import MkIface          ( ifaceTyThing )
  28 import DriverFlags
  29 import DriverState
  30 import DriverUtil       ( handle, remove_spaces )
  31 import Linker
  32 import Finder           ( flushPackageCache )
  33 import Util
  34 import Id               ( isRecordSelector, recordSelectorFieldLabel,
  35                           isDataConWrapId, isDataConId, idName )
  36 import Class            ( className )
  37 import TyCon            ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
  38 import FieldLabel       ( fieldLabelTyCon )
  39 import SrcLoc           ( isGoodSrcLoc )
  40 import Module           ( moduleName )
  41 import NameEnv          ( nameEnvElts )
  42 import Name             ( Name, isHomePackageName, nameSrcLoc, nameOccName,
  43                           NamedThing(..) )
  44 import OccName          ( isSymOcc )
  45 import BasicTypes       ( defaultFixity )
  46 import Outputable
  47 import CmdLineOpts      ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
  48                           restoreDynFlags, dopt_unset )
  49 import Panic            ( GhcException(..), showGhcException )
  50 import Config
  51
  52 #ifndef mingw32_TARGET_OS
  53 import Posix
  54 #endif
  55
  56 import Exception
  57 import Dynamic
  58 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
  59 import Readline
  60 #endif
  61 import Concurrent
  62 import IOExts
  63 import SystemExts
  64
  65 import Numeric
  66 import List
  67 import System
  68 import CPUTime
  69 import Directory
  70 import IO
  71 import Char
  72 import Monad
  73
  74 import GlaExts          ( unsafeCoerce# )
  75
  76 import Foreign          ( nullPtr )
  77 import CString          ( CString, peekCString, withCString )
  78
  79 -----------------------------------------------------------------------------
  80
  81 ghciWelcomeMsg = "\
  82 \   ___         ___ _\n\
  83 \  / _ \\ /\\  /\\/ __(_)\n\
  84 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
  85 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  86 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  87
  88 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  89
  90 builtin_commands :: [(String, String -> GHCi Bool)]
  91 builtin_commands = [
  92   ("add",       keepGoing addModule),
  93   ("browse",    keepGoing browseCmd),
  94   ("cd",        keepGoing changeDirectory),
  95   ("def",       keepGoing defineMacro),
  96   ("help",      keepGoing help),
  97   ("?",         keepGoing help),
  98   ("info",      keepGoing info),
  99   ("load",      keepGoing loadModule),
 100   ("module",    keepGoing setContext),
 101   ("reload",    keepGoing reloadModule),
 102   ("set",       keepGoing setCmd),
 103   ("show",      keepGoing showCmd),
 104   ("type",      keepGoing typeOfExpr),
 105   ("unset",     keepGoing unsetOptions),
 106   ("undef",     keepGoing undefineMacro),
 107   ("quit",      quit)
 108   ]
 109
 110 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 111 keepGoing a str = a str >> return False
 112
 113 shortHelpText = "use :? for help.\n"
 114
 115 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 116 helpText = "\
 117 \ Commands available from the prompt:\n\
 118 \\n\
 119 \   <stmt>                     evaluate/run <stmt>\n\
 120 \   :add <filename> ...        add module(s) to the current target set\n\
 121 \   :browse [*]<module>        display the names defined by <module>\n\
 122 \   :cd <dir>                  change directory to <dir>\n\
 123 \   :def <cmd> <expr>          define a command :<cmd>\n\
 124 \   :help, :?                  display this list of commands\n\
 125 \   :info [<name> ...]         display information about the given names\n\
 126 \   :load <filename> ...       load module(s) and their dependents\n\
 127 \   :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
 128 \   :reload                    reload the current module set\n\
 129 \\n\
 130 \   :set <option> ...          set options\n\
 131 \   :set args <arg> ...        set the arguments returned by System.getArgs\n\
 132 \   :set prog <progname>       set the value returned by System.getProgName\n\
 133 \\n\
 134 \   :show modules              show the currently loaded modules\n\
 135 \   :show bindings             show the current bindings made at the prompt\n\
 136 \\n\
 137 \   :type <expr>               show the type of <expr>\n\
 138 \   :undef <cmd>               undefine user-defined command :<cmd>\n\
 139 \   :unset <option> ...        unset options\n\
 140 \   :quit                      exit GHCi\n\
 141 \   :!<command>                run the shell command <command>\n\
 142 \\n\
 143 \ Options for `:set' and `:unset':\n\
 144 \\n\
 145 \    +r                 revert top-level expressions after each evaluation\n\
 146 \    +s                 print timing/memory stats after each evaluation\n\
 147 \    +t                 print type after evaluation\n\
 148 \    -<flags>           most GHC command line flags can also be set here\n\
 149 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 150 \"
 151
 152 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
 153 interactiveUI cmstate paths cmdline_libs = do
 154    hFlush stdout
 155    hSetBuffering stdout NoBuffering
 156
 157    dflags <- getDynFlags
 158
 159    -- link in the available packages
 160    pkgs <- getPackageInfo
 161    initLinker
 162    linkPackages dflags cmdline_libs pkgs
 163
 164    (cmstate, maybe_hval)
 165         <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
 166    case maybe_hval of
 167         Just hval -> do
 168                 let action = unsafeCoerce# hval :: IO ()
 169                 action -- do it now
 170                 writeIORef turn_off_buffering action -- and save it for later
 171         _ -> panic "interactiveUI:buffering"
 172
 173    (cmstate, maybe_hval)
 174         <- cmCompileExpr cmstate dflags "IO.hFlush IO.stderr"
 175    case maybe_hval of
 176         Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
 177         _ -> panic "interactiveUI:stderr"
 178
 179    (cmstate, maybe_hval)
 180         <- cmCompileExpr cmstate dflags "IO.hFlush IO.stdout"
 181    case maybe_hval of
 182         Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
 183         _ -> panic "interactiveUI:stdout"
 184
 185         -- We don't want the cmd line to buffer any input that might be
 186         -- intended for the program, so unbuffer stdin.
 187    hSetBuffering stdin  NoBuffering
 188
 189         -- initial context is just the Prelude
 190    cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
 191
 192 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 193    Readline.initialize
 194 #endif
 195
 196    startGHCi (runGHCi paths dflags)
 197         GHCiState{ progname = "<interactive>",
 198                    args = [],
 199                    targets = paths,
 200                    cmstate = cmstate,
 201                    options = [] }
 202
 203 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 204    Readline.resetTerminal Nothing
 205 #endif
 206
 207    return ()
 208
 209
 210 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
 211 runGHCi paths dflags = do
 212   read_dot_files <- io (readIORef v_Read_DotGHCi)
 213
 214   when (read_dot_files) $ do
 215     -- Read in ./.ghci.
 216     let file = "./.ghci"
 217     exists <- io (doesFileExist file)
 218     when exists $ do
 219        dir_ok  <- io (checkPerms ".")
 220        file_ok <- io (checkPerms file)
 221        when (dir_ok && file_ok) $ do
 222           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 223           case either_hdl of
 224              Left e    -> return ()
 225              Right hdl -> fileLoop hdl False
 226
 227   when (read_dot_files) $ do
 228     -- Read in $HOME/.ghci
 229     either_dir <- io (IO.try (getEnv "HOME"))
 230     case either_dir of
 231        Left e -> return ()
 232        Right dir -> do
 233           cwd <- io (getCurrentDirectory)
 234           when (dir /= cwd) $ do
 235              let file = dir ++ "/.ghci"
 236              ok <- io (checkPerms file)
 237              when ok $ do
 238                either_hdl <- io (IO.try (openFile file ReadMode))
 239                case either_hdl of
 240                   Left e    -> return ()
 241                   Right hdl -> fileLoop hdl False
 242
 243   -- perform a :load for files given on the GHCi command line
 244   when (not (null paths)) $
 245      ghciHandle showException $
 246         loadModule (unwords paths)
 247
 248   -- enter the interactive loop
 249 #if defined(mingw32_TARGET_OS)
 250    -- always show prompt, since hIsTerminalDevice returns True for Consoles
 251    -- only, which we may or may not be running under (cf. Emacs sub-shells.)
 252   interactiveLoop True
 253 #else
 254   is_tty <- io (hIsTerminalDevice stdin)
 255   interactiveLoop is_tty
 256 #endif
 257
 258   -- and finally, exit
 259   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 260
 261
 262 interactiveLoop is_tty = do
 263   -- ignore ^C exceptions caught here
 264   ghciHandleDyn (\e -> case e of
 265                         Interrupted -> ghciUnblock (interactiveLoop is_tty)
 266                         _other      -> return ()) $ do
 267
 268   -- read commands from stdin
 269 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 270   if (is_tty)
 271         then readlineLoop
 272         else fileLoop stdin False  -- turn off prompt for non-TTY input
 273 #else
 274   fileLoop stdin is_tty
 275 #endif
 276
 277
 278 -- NOTE: We only read .ghci files if they are owned by the current user,
 279 -- and aren't world writable.  Otherwise, we could be accidentally
 280 -- running code planted by a malicious third party.
 281
 282 -- Furthermore, We only read ./.ghci if . is owned by the current user
 283 -- and isn't writable by anyone else.  I think this is sufficient: we
 284 -- don't need to check .. and ../.. etc. because "."  always refers to
 285 -- the same directory while a process is running.
 286
 287 checkPerms :: String -> IO Bool
 288 checkPerms name =
 289 #ifdef mingw32_TARGET_OS
 290   return True
 291 #else
 292   DriverUtil.handle (\_ -> return False) $ do
 293      st <- getFileStatus name
 294      me <- getRealUserID
 295      if fileOwner st /= me then do
 296         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 297         return False
 298       else do
 299         let mode =  fileMode st
 300         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 301            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 302            then do
 303                putStrLn $ "*** WARNING: " ++ name ++
 304                           " is writable by someone else, IGNORING!"
 305                return False
 306           else return True
 307 #endif
 308
 309 fileLoop :: Handle -> Bool -> GHCi ()
 310 fileLoop hdl prompt = do
 311    cmstate <- getCmState
 312    (mod,imports) <- io (cmGetContext cmstate)
 313    when prompt (io (putStr (mkPrompt mod imports)))
 314    l <- io (IO.try (hGetLine hdl))
 315    case l of
 316         Left e | isEOFError e -> return ()
 317                | otherwise    -> throw e
 318         Right l ->
 319           case remove_spaces l of
 320             "" -> fileLoop hdl prompt
 321             l  -> do quit <- runCommand l
 322                      if quit then return () else fileLoop hdl prompt
 323
 324 stringLoop :: [String] -> GHCi ()
 325 stringLoop [] = return ()
 326 stringLoop (s:ss) = do
 327    case remove_spaces s of
 328         "" -> stringLoop ss
 329         l  -> do quit <- runCommand l
 330                  if quit then return () else stringLoop ss
 331
 332 mkPrompt toplevs exports
 333    = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
 334
 335 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 336 readlineLoop :: GHCi ()
 337 readlineLoop = do
 338    cmstate <- getCmState
 339    (mod,imports) <- io (cmGetContext cmstate)
 340    io yield
 341    l <- io (readline (mkPrompt mod imports))
 342    case l of
 343         Nothing -> return ()
 344         Just l  ->
 345           case remove_spaces l of
 346             "" -> readlineLoop
 347             l  -> do
 348                   io (addHistory l)
 349                   quit <- runCommand l
 350                   if quit then return () else readlineLoop
 351 #endif
 352
 353 -- Top level exception handler, just prints out the exception
 354 -- and carries on.
 355 runCommand :: String -> GHCi Bool
 356 runCommand c =
 357   ghciHandle ( \exception -> do
 358                 flushEverything
 359                 showException exception
 360                 return False
 361              ) $
 362   doCommand c
 363
 364 showException (DynException dyn) =
 365   case fromDynamic dyn of
 366     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 367     Just Interrupted      -> io (putStrLn "Interrupted.")
 368     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 369     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 370     Just other_ghc_ex     -> io (print other_ghc_ex)
 371
 372 showException other_exception
 373   = io (putStrLn ("*** Exception: " ++ show other_exception))
 374
 375 doCommand (':' : command) = specialCommand command
 376 doCommand stmt
 377    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 378         return False
 379
 380 runStmt :: String -> GHCi [Name]
 381 runStmt stmt
 382  | null (filter (not.isSpace) stmt) = return []
 383  | otherwise
 384  = do st <- getGHCiState
 385       dflags <- io getDynFlags
 386       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 387       (new_cmstate, result) <-
 388         io $ withProgName (progname st) $ withArgs (args st) $
 389         cmRunStmt (cmstate st) dflags' stmt
 390       setGHCiState st{cmstate = new_cmstate}
 391       case result of
 392         CmRunFailed      -> return []
 393         CmRunException e -> showException e >> return []
 394         CmRunOk names    -> return names
 395
 396 -- possibly print the type and revert CAFs after evaluating an expression
 397 finishEvalExpr names
 398  = do b <- isOptionSet ShowType
 399       cmstate <- getCmState
 400       when b (mapM_ (showTypeOfName cmstate) names)
 401
 402       b <- isOptionSet RevertCAFs
 403       io (when b revertCAFs)
 404       flushEverything
 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 flushEverything :: GHCi ()
 415 flushEverything
 416    = io $ do Monad.join (readIORef flush_stdout)
 417              Monad.join (readIORef flush_stderr)
 418              return ()
 419
 420 specialCommand :: String -> GHCi Bool
 421 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 422 specialCommand str = do
 423   let (cmd,rest) = break isSpace str
 424   cmds <- io (readIORef commands)
 425   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 426      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 427                                     ++ shortHelpText) >> return False)
 428      [(_,f)] -> f (dropWhile isSpace rest)
 429      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 430                                       " matches multiple commands (" ++
 431                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 432                                          ++ ")") >> return False)
 433
 434 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 435
 436 -----------------------------------------------------------------------------
 437 -- Commands
 438
 439 help :: String -> GHCi ()
 440 help _ = io (putStr helpText)
 441
 442 info :: String -> GHCi ()
 443 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 444 info s = do
 445   let names = words s
 446   init_cms <- getCmState
 447   dflags <- io getDynFlags
 448   let
 449     infoThings cms [] = return cms
 450     infoThings cms (name:names) = do
 451       (cms, stuff) <- io (cmInfoThing cms dflags name)
 452       io (putStrLn (showSDocForUser unqual (
 453             vcat (intersperse (text "") (map showThing stuff))))
 454          )
 455       infoThings cms names
 456
 457     unqual = cmGetPrintUnqual init_cms
 458
 459     showThing (ty_thing, fixity)
 460         = vcat [ text "-- " <> showTyThing ty_thing,
 461                  showFixity fixity (getName ty_thing),
 462                  ppr (ifaceTyThing ty_thing) ]
 463
 464     showFixity fix name
 465         | fix == defaultFixity = empty
 466         | otherwise            = ppr fix <+>
 467                                  (if isSymOcc (nameOccName name)
 468                                         then ppr name
 469                                         else char '`' <> ppr name <> char '`')
 470
 471     showTyThing (AClass cl)
 472        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
 473     showTyThing (ATyCon ty)
 474        | isPrimTyCon ty
 475        = hcat [ppr ty, text " is a primitive type constructor"]
 476        | otherwise
 477        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
 478     showTyThing (AnId   id)
 479        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 480
 481     idDescr id
 482        | isRecordSelector id =
 483                 case tyConClass_maybe (fieldLabelTyCon (
 484                                 recordSelectorFieldLabel id)) of
 485                         Nothing -> text "record selector"
 486                         Just c  -> text "method in class " <> ppr c
 487        | isDataConWrapId id  = text "data constructor"
 488        | otherwise           = text "variable"
 489
 490         -- also print out the source location for home things
 491     showSrcLoc name
 492         | isHomePackageName name && isGoodSrcLoc loc
 493         = hsep [ text ", defined at", ppr loc ]
 494         | otherwise
 495         = empty
 496         where loc = nameSrcLoc name
 497
 498   cms <- infoThings init_cms names
 499   setCmState cms
 500   return ()
 501
 502 addModule :: String -> GHCi ()
 503 addModule str = do
 504   let files = words str
 505   state <- getGHCiState
 506   dflags <- io (getDynFlags)
 507   io (revertCAFs)                       -- always revert CAFs on load/add.
 508   let new_targets = files ++ targets state
 509   graph <- io (cmDepAnal (cmstate state) dflags new_targets)
 510   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
 511   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 512   setContextAfterLoad mods
 513   modulesLoadedMsg ok mods dflags
 514
 515 changeDirectory :: String -> GHCi ()
 516 changeDirectory ('~':d) = do
 517    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 518    io (setCurrentDirectory (tilde ++ '/':d))
 519 changeDirectory d = io (setCurrentDirectory d)
 520
 521 defineMacro :: String -> GHCi ()
 522 defineMacro s = do
 523   let (macro_name, definition) = break isSpace s
 524   cmds <- io (readIORef commands)
 525   if (null macro_name)
 526         then throwDyn (CmdLineError "invalid macro name")
 527         else do
 528   if (macro_name `elem` map fst cmds)
 529         then throwDyn (CmdLineError
 530                 ("command `" ++ macro_name ++ "' is already defined"))
 531         else do
 532
 533   -- give the expression a type signature, so we can be sure we're getting
 534   -- something of the right type.
 535   let new_expr = '(' : definition ++ ") :: String -> IO String"
 536
 537   -- compile the expression
 538   cms <- getCmState
 539   dflags <- io getDynFlags
 540   (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
 541   setCmState new_cmstate
 542   case maybe_hv of
 543      Nothing -> return ()
 544      Just hv -> io (writeIORef commands --
 545                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 546
 547 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 548 runMacro fun s = do
 549   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 550   stringLoop (lines str)
 551
 552 undefineMacro :: String -> GHCi ()
 553 undefineMacro macro_name = do
 554   cmds <- io (readIORef commands)
 555   if (macro_name `elem` map fst builtin_commands)
 556         then throwDyn (CmdLineError
 557                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 558         else do
 559   if (macro_name `notElem` map fst cmds)
 560         then throwDyn (CmdLineError
 561                 ("command `" ++ macro_name ++ "' not defined"))
 562         else do
 563   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 564
 565
 566 loadModule :: String -> GHCi ()
 567 loadModule str = timeIt (loadModule' str)
 568
 569 loadModule' str = do
 570   let files = words str
 571   state <- getGHCiState
 572   dflags <- io getDynFlags
 573
 574   -- do the dependency anal first, so that if it fails we don't throw
 575   -- away the current set of modules.
 576   graph <- io (cmDepAnal (cmstate state) dflags files)
 577
 578   -- Dependency anal ok, now unload everything
 579   cmstate1 <- io (cmUnload (cmstate state) dflags)
 580   setGHCiState state{ cmstate = cmstate1, targets = [] }
 581
 582   io (revertCAFs)  -- always revert CAFs on load.
 583   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
 584   setGHCiState state{ cmstate = cmstate2, targets = files }
 585
 586   setContextAfterLoad mods
 587   modulesLoadedMsg ok mods dflags
 588
 589
 590 reloadModule :: String -> GHCi ()
 591 reloadModule "" = do
 592   state <- getGHCiState
 593   dflags <- io getDynFlags
 594   case targets state of
 595    [] -> io (putStr "no current target\n")
 596    paths -> do
 597         -- do the dependency anal first, so that if it fails we don't throw
 598         -- away the current set of modules.
 599         graph <- io (cmDepAnal (cmstate state) dflags paths)
 600
 601         io (revertCAFs)         -- always revert CAFs on reload.
 602         (cmstate1, ok, mods)
 603                 <- io (cmLoadModules (cmstate state) dflags graph)
 604         setGHCiState state{ cmstate=cmstate1 }
 605         setContextAfterLoad mods
 606         modulesLoadedMsg ok mods dflags
 607
 608 reloadModule _ = noArgs ":reload"
 609
 610 setContextAfterLoad [] = setContext prel
 611 setContextAfterLoad (m:_) = do
 612   cmstate <- getCmState
 613   b <- io (cmModuleIsInterpreted cmstate m)
 614   if b then setContext ('*':m) else setContext m
 615
 616 modulesLoadedMsg ok mods dflags =
 617   when (verbosity dflags > 0) $ do
 618    let mod_commas
 619         | null mods = text "none."
 620         | otherwise = hsep (
 621             punctuate comma (map text mods)) <> text "."
 622    case ok of
 623     False ->
 624        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 625     True  ->
 626        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 627
 628
 629 typeOfExpr :: String -> GHCi ()
 630 typeOfExpr str
 631   = do cms <- getCmState
 632        dflags <- io getDynFlags
 633        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
 634        setCmState new_cmstate
 635        case maybe_tystr of
 636           Nothing    -> return ()
 637           Just tystr -> io (putStrLn tystr)
 638
 639 quit :: String -> GHCi Bool
 640 quit _ = return True
 641
 642 shellEscape :: String -> GHCi Bool
 643 shellEscape str = io (system str >> return False)
 644
 645 -----------------------------------------------------------------------------
 646 -- Browing a module's contents
 647
 648 browseCmd :: String -> GHCi ()
 649 browseCmd m =
 650   case words m of
 651     ['*':m] | looksLikeModuleName m -> browseModule m False
 652     [m]     | looksLikeModuleName m -> browseModule m True
 653     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 654
 655 browseModule m exports_only = do
 656   cms <- getCmState
 657   dflags <- io getDynFlags
 658
 659   is_interpreted <- io (cmModuleIsInterpreted cms m)
 660   when (not is_interpreted && not exports_only) $
 661         throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 662
 663   -- temporarily set the context to the module we're interested in,
 664   -- just so we can get an appropriate PrintUnqualified
 665   (as,bs) <- io (cmGetContext cms)
 666   cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
 667                               else cmSetContext cms dflags [m] [])
 668   cms2 <- io (cmSetContext cms1 dflags as bs)
 669
 670   (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
 671
 672   setCmState cms3
 673
 674   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 675
 676       things' = filter wantToSee things
 677
 678       wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
 679       wantToSee _ = True
 680
 681       thing_names = map getName things
 682
 683       thingDecl thing@(AnId id)  = ifaceTyThing thing
 684
 685       thingDecl thing@(AClass c) =
 686         let rn_decl = ifaceTyThing thing in
 687         case rn_decl of
 688           ClassDecl { tcdSigs = cons } ->
 689                 rn_decl{ tcdSigs = filter methodIsVisible cons }
 690           other -> other
 691         where
 692            methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
 693
 694       thingDecl thing@(ATyCon t) =
 695         let rn_decl = ifaceTyThing thing in
 696         case rn_decl of
 697           TyData { tcdCons = DataCons cons } ->
 698                 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
 699           other -> other
 700         where
 701           conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
 702
 703   io (putStrLn (showSDocForUser unqual (
 704          vcat (map (ppr . thingDecl) things')))
 705    )
 706
 707   where
 708
 709 -----------------------------------------------------------------------------
 710 -- Setting the module context
 711
 712 setContext str
 713   | all sensible mods = fn mods
 714   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 715   where
 716     (fn, mods) = case str of
 717                         '+':stuff -> (addToContext,      words stuff)
 718                         '-':stuff -> (removeFromContext, words stuff)
 719                         stuff     -> (newContext,        words stuff)
 720
 721     sensible ('*':m) = looksLikeModuleName m
 722     sensible m       = looksLikeModuleName m
 723
 724 newContext mods = do
 725   cms <- getCmState
 726   dflags <- io getDynFlags
 727   (as,bs) <- separate cms mods [] []
 728   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 729   cms' <- io (cmSetContext cms dflags as bs')
 730   setCmState cms'
 731
 732 separate cmstate []           as bs = return (as,bs)
 733 separate cmstate (('*':m):ms) as bs = do
 734    b <- io (cmModuleIsInterpreted cmstate m)
 735    if b then separate cmstate ms (m:as) bs
 736         else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 737 separate cmstate (m:ms)       as bs = separate cmstate ms as (m:bs)
 738
 739 prel = "Prelude"
 740
 741
 742 addToContext mods = do
 743   cms <- getCmState
 744   dflags <- io getDynFlags
 745   (as,bs) <- io (cmGetContext cms)
 746
 747   (as',bs') <- separate cms mods [] []
 748
 749   let as_to_add = as' \\ (as ++ bs)
 750       bs_to_add = bs' \\ (as ++ bs)
 751
 752   cms' <- io (cmSetContext cms dflags
 753                         (as ++ as_to_add) (bs ++ bs_to_add))
 754   setCmState cms'
 755
 756
 757 removeFromContext mods = do
 758   cms <- getCmState
 759   dflags <- io getDynFlags
 760   (as,bs) <- io (cmGetContext cms)
 761
 762   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 763
 764   let as' = as \\ (as_to_remove ++ bs_to_remove)
 765       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 766
 767   cms' <- io (cmSetContext cms dflags as' bs')
 768   setCmState cms'
 769
 770 ----------------------------------------------------------------------------
 771 -- Code for `:set'
 772
 773 -- set options in the interpreter.  Syntax is exactly the same as the
 774 -- ghc command line, except that certain options aren't available (-C,
 775 -- -E etc.)
 776 --
 777 -- This is pretty fragile: most options won't work as expected.  ToDo:
 778 -- figure out which ones & disallow them.
 779
 780 setCmd :: String -> GHCi ()
 781 setCmd ""
 782   = do st <- getGHCiState
 783        let opts = options st
 784        io $ putStrLn (showSDoc (
 785               text "options currently set: " <>
 786               if null opts
 787                    then text "none."
 788                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 789            ))
 790 setCmd str
 791   = case words str of
 792         ("args":args) -> setArgs args
 793         ("prog":prog) -> setProg prog
 794         wds -> setOptions wds
 795
 796 setArgs args = do
 797   st <- getGHCiState
 798   setGHCiState st{ args = args }
 799
 800 setProg [prog] = do
 801   st <- getGHCiState
 802   setGHCiState st{ progname = prog }
 803 setProg _ = do
 804   io (hPutStrLn stderr "syntax: :set prog <progname>")
 805
 806 setOptions wds =
 807    do -- first, deal with the GHCi opts (+s, +t, etc.)
 808       let (plus_opts, minus_opts)  = partition isPlus wds
 809       mapM_ setOpt plus_opts
 810
 811       -- now, the GHC flags
 812       pkgs_before <- io (readIORef v_Packages)
 813       leftovers   <- io (processArgs static_flags minus_opts [])
 814       pkgs_after  <- io (readIORef v_Packages)
 815
 816       -- update things if the users wants more packages
 817       when (pkgs_before /= pkgs_after) $
 818          newPackages (pkgs_after \\ pkgs_before)
 819
 820       -- then, dynamic flags
 821       io $ do
 822         restoreDynFlags
 823         leftovers <- processArgs dynamic_flags leftovers []
 824         saveDynFlags
 825
 826         if (not (null leftovers))
 827                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 828                                                 unwords leftovers))
 829                 else return ()
 830
 831
 832 unsetOptions :: String -> GHCi ()
 833 unsetOptions str
 834   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 835        let opts = words str
 836            (minus_opts, rest1) = partition isMinus opts
 837            (plus_opts, rest2)  = partition isPlus rest1
 838
 839        if (not (null rest2))
 840           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 841           else do
 842
 843        mapM_ unsetOpt plus_opts
 844
 845        -- can't do GHC flags for now
 846        if (not (null minus_opts))
 847           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 848           else return ()
 849
 850 isMinus ('-':s) = True
 851 isMinus _ = False
 852
 853 isPlus ('+':s) = True
 854 isPlus _ = False
 855
 856 setOpt ('+':str)
 857   = case strToGHCiOpt str of
 858         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 859         Just o  -> setOption o
 860
 861 unsetOpt ('+':str)
 862   = case strToGHCiOpt str of
 863         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 864         Just o  -> unsetOption o
 865
 866 strToGHCiOpt :: String -> (Maybe GHCiOption)
 867 strToGHCiOpt "s" = Just ShowTiming
 868 strToGHCiOpt "t" = Just ShowType
 869 strToGHCiOpt "r" = Just RevertCAFs
 870 strToGHCiOpt _   = Nothing
 871
 872 optToStr :: GHCiOption -> String
 873 optToStr ShowTiming = "s"
 874 optToStr ShowType   = "t"
 875 optToStr RevertCAFs = "r"
 876
 877 newPackages new_pkgs = do
 878   state <- getGHCiState
 879   dflags <- io getDynFlags
 880   cmstate1 <- io (cmUnload (cmstate state) dflags)
 881   setGHCiState state{ cmstate = cmstate1, targets = [] }
 882
 883   io $ do
 884     pkgs <- getPackageInfo
 885     flushPackageCache pkgs
 886
 887     new_pkg_info <- getPackageDetails new_pkgs
 888     mapM_ (linkPackage dflags) (reverse new_pkg_info)
 889
 890   setContextAfterLoad []
 891
 892 -----------------------------------------------------------------------------
 893 -- code for `:show'
 894
 895 showCmd str =
 896   case words str of
 897         ["modules" ] -> showModules
 898         ["bindings"] -> showBindings
 899         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 900
 901 showModules = do
 902   cms <- getCmState
 903   let mg = cmGetModuleGraph cms
 904       ls = cmGetLinkables   cms
 905       maybe_linkables = map (findModuleLinkable_maybe ls)
 906                                 (map (moduleName.ms_mod) mg)
 907   zipWithM showModule mg maybe_linkables
 908   return ()
 909
 910 showModule :: ModSummary -> Maybe Linkable -> GHCi ()
 911 showModule m (Just l) = do
 912   io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
 913 showModule _ Nothing = panic "missing linkable"
 914
 915 showBindings = do
 916   cms <- getCmState
 917   let
 918         unqual = cmGetPrintUnqual cms
 919         showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
 920
 921   io (mapM_ showBinding (cmGetBindings cms))
 922   return ()
 923
 924 -----------------------------------------------------------------------------
 925 -- GHCi monad
 926
 927 data GHCiState = GHCiState
 928      {
 929         progname       :: String,
 930         args           :: [String],
 931         targets        :: [FilePath],
 932         cmstate        :: CmState,
 933         options        :: [GHCiOption]
 934      }
 935
 936 data GHCiOption
 937         = ShowTiming            -- show time/allocs after evaluation
 938         | ShowType              -- show the type of expressions
 939         | RevertCAFs            -- revert CAFs after every evaluation
 940         deriving Eq
 941
 942 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 943 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 944 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 945
 946 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 947
 948 startGHCi :: GHCi a -> GHCiState -> IO a
 949 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 950
 951 instance Monad GHCi where
 952   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 953   return a  = GHCi $ \s -> return a
 954
 955 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 956 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 957    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 958
 959 getGHCiState   = GHCi $ \r -> readIORef r
 960 setGHCiState s = GHCi $ \r -> writeIORef r s
 961
 962 -- for convenience...
 963 getCmState = getGHCiState >>= return . cmstate
 964 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
 965
 966 isOptionSet :: GHCiOption -> GHCi Bool
 967 isOptionSet opt
 968  = do st <- getGHCiState
 969       return (opt `elem` options st)
 970
 971 setOption :: GHCiOption -> GHCi ()
 972 setOption opt
 973  = do st <- getGHCiState
 974       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 975
 976 unsetOption :: GHCiOption -> GHCi ()
 977 unsetOption opt
 978  = do st <- getGHCiState
 979       setGHCiState (st{ options = filter (/= opt) (options st) })
 980
 981 io :: IO a -> GHCi a
 982 io m = GHCi { unGHCi = \s -> m >>= return }
 983
 984 -----------------------------------------------------------------------------
 985 -- recursive exception handlers
 986
 987 -- Don't forget to unblock async exceptions in the handler, or if we're
 988 -- in an exception loop (eg. let a = error a in a) the ^C exception
 989 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 990
 991 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 992 ghciHandle h (GHCi m) = GHCi $ \s ->
 993    Exception.catch (m s)
 994         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 995
 996 ghciUnblock :: GHCi a -> GHCi a
 997 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 998
 999 -----------------------------------------------------------------------------
1000 -- package loader
1001
1002 -- Left: full path name of a .o file, including trailing .o
1003 -- Right: "unadorned" name of a .DLL/.so
1004 --        e.g.    On unix     "qt"  denotes "libqt.so"
1005 --                On WinDoze  "burble"  denotes "burble.DLL"
1006 --        addDLL is platform-specific and adds the lib/.so/.DLL
1007 --        suffixes platform-dependently; we don't do that here.
1008 --
1009 -- For dynamic objects only, try to find the object file in all the
1010 -- directories specified in v_Library_Paths before giving up.
1011
1012 data LibrarySpec = Object FilePath | DLL String
1013 #ifdef darwin_TARGET_OS
1014                     | Framework String
1015 #endif
1016
1017 -- Packages that don't need loading, because the compiler shares them with
1018 -- the interpreted program.
1019 dont_load_these = [ "rts" ]
1020
1021 -- Packages that are already linked into GHCi.  For mingw32, we only
1022 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1023 -- library which std depends on.
1024 loaded_in_ghci
1025 #          ifndef mingw32_TARGET_OS
1026            = [ "std", "concurrent", "posix", "text", "util" ]
1027 #          else
1028            = [ ]
1029 #          endif
1030
1031 showLS (Object nm)  = "(static) " ++ nm
1032 showLS (DLL nm) = "(dynamic) " ++ nm
1033 #ifdef darwin_TARGET_OS
1034 showLS (Framework nm) = "(framework) " ++ nm
1035 #endif
1036
1037 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1038 linkPackages dflags cmdline_lib_specs pkgs
1039    = do mapM_ (linkPackage dflags) (reverse pkgs)
1040         lib_paths <- readIORef v_Library_paths
1041         mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1042         if (null cmdline_lib_specs)
1043            then return ()
1044            else do maybePutStr dflags "final link ... "
1045
1046                    ok <- resolveObjs
1047                    if ok then maybePutStrLn dflags "done."
1048                          else throwDyn (InstallationError
1049                                           "linking extra libraries/objects failed")
1050      where
1051         preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1052         preloadLib dflags lib_paths lib_spec
1053            = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1054                 case lib_spec of
1055                    Object static_ish
1056                       -> do b <- preload_static lib_paths static_ish
1057                             maybePutStrLn dflags (if b  then "done."
1058                                                         else "not found")
1059                    DLL dll_unadorned
1060                       -> -- We add "" to the set of paths to try, so that
1061                          -- if none of the real paths match, we force addDLL
1062                          -- to look in the default dynamic-link search paths.
1063                          do maybe_errstr <- loadDynamic (lib_paths++[""])
1064                                                             dll_unadorned
1065                             case maybe_errstr of
1066                                Nothing -> return ()
1067                                Just mm -> preloadFailed mm lib_paths lib_spec
1068                             maybePutStrLn dflags "done"
1069
1070         preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1071         preloadFailed sys_errmsg paths spec
1072            = do maybePutStr dflags
1073                        ("failed.\nDynamic linker error message was:\n   "
1074                         ++ sys_errmsg  ++ "\nWhilst trying to load:  "
1075                         ++ showLS spec ++ "\nDirectories to search are:\n"
1076                         ++ unlines (map ("   "++) paths) )
1077                 give_up
1078
1079         -- not interested in the paths in the static case.
1080         preload_static paths name
1081            = do b <- doesFileExist name
1082                 if not b then return False
1083                          else loadObj name >> return True
1084
1085         give_up
1086            = (throwDyn . CmdLineError)
1087                 "user specified .o/.so/.DLL could not be loaded."
1088
1089 linkPackage :: DynFlags -> PackageConfig -> IO ()
1090 linkPackage dflags pkg
1091    | name pkg `elem` dont_load_these = return ()
1092    | otherwise
1093    = do
1094         let dirs      =  library_dirs pkg
1095         let libs      =  hs_libraries pkg ++ extra_libraries pkg
1096         classifieds   <- mapM (locateOneObj dirs) libs
1097 #ifdef darwin_TARGET_OS
1098         let fwDirs    =  framework_dirs pkg
1099         let frameworks=  extra_frameworks pkg
1100 #endif
1101
1102         -- Complication: all the .so's must be loaded before any of the .o's.
1103         let dlls = [ dll | DLL dll <- classifieds ]
1104             objs = [ obj | Object obj <- classifieds ]
1105
1106         maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1107
1108         -- If this package is already part of the GHCi binary, we'll already
1109         -- have the right DLLs for this package loaded, so don't try to
1110         -- load them again.
1111         when (name pkg `notElem` loaded_in_ghci) $ do
1112 #ifdef darwin_TARGET_OS
1113             loadFrameworks fwDirs frameworks
1114 #endif
1115             loadDynamics dirs dlls
1116
1117         -- After loading all the DLLs, we can load the static objects.
1118         mapM_ loadObj objs
1119
1120         maybePutStr dflags "linking ... "
1121         ok <- resolveObjs
1122         if ok then maybePutStrLn dflags "done."
1123               else panic ("can't load package `" ++ name pkg ++ "'")
1124
1125 loadDynamics dirs [] = return ()
1126 loadDynamics dirs (dll:dlls) = do
1127   r <- loadDynamic dirs dll
1128   case r of
1129     Nothing  -> loadDynamics dirs dlls
1130     Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1131                                        ++ dll ++ " (" ++ err ++ ")" ))
1132 #ifdef darwin_TARGET_OS
1133 loadFrameworks dirs [] = return ()
1134 loadFrameworks dirs (fw:fws) = do
1135   r <- loadFramework dirs fw
1136   case r of
1137     Nothing  -> loadFrameworks dirs fws
1138     Just err -> throwDyn (CmdLineError ("can't load framework: "
1139                                        ++ fw ++ " (" ++ err ++ ")" ))
1140 #endif
1141
1142 -- Try to find an object file for a given library in the given paths.
1143 -- If it isn't present, we assume it's a dynamic library.
1144 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1145 locateOneObj [] lib
1146    = return (DLL lib) -- we assume
1147 locateOneObj (d:ds) lib
1148    = do let path = d ++ '/':lib ++ ".o"
1149         b <- doesFileExist path
1150         if b then return (Object path) else locateOneObj ds lib
1151
1152 -- ----------------------------------------------------------------------------
1153 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1154
1155 #if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
1156 loadDynamic paths rootname = addDLL rootname
1157   -- ignore paths on windows (why? --SDM)
1158
1159 #else
1160
1161 -- return Nothing == success, else Just error message from dlopen
1162 loadDynamic (path:paths) rootname = do
1163   let dll = path ++ '/':mkSOName rootname
1164   b <- doesFileExist dll
1165   if not b
1166      then loadDynamic paths rootname
1167      else addDLL dll
1168 loadDynamic [] rootname = do
1169         -- tried all our known library paths, let dlopen() search its
1170         -- own builtin paths now.
1171    addDLL (mkSOName rootname)
1172
1173 #ifdef darwin_TARGET_OS
1174 mkSOName root = "lib" ++ root ++ ".dylib"
1175 #else
1176 mkSOName root = "lib" ++ root ++ ".so"
1177 #endif
1178
1179 #endif
1180
1181 -- Darwin / MacOS X only: load a framework
1182 -- a framework is a dynamic library packaged inside a directory of the same
1183 -- name. They are searched for in different paths than normal libraries.
1184 #ifdef darwin_TARGET_OS
1185 loadFramework extraPaths rootname
1186    = loadFramework' (extraPaths ++ defaultFrameworkPaths) where
1187    defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1188
1189    loadFramework' (path:paths) = do
1190       let dll = path ++ '/' : rootname ++ ".framework/" ++ rootname
1191       b <- doesFileExist dll
1192       if not b
1193          then loadFramework' paths
1194          else addDLL dll
1195    loadFramework' [] = do
1196         -- tried all our known library paths, but dlopen()
1197         -- has no built-in paths for frameworks: give up
1198       return $ Just $ "not found"
1199 #endif
1200
1201 addDLL :: String -> IO (Maybe String)
1202 addDLL str = do
1203   maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
1204   if maybe_errmsg == nullPtr
1205         then return Nothing
1206         else do str <- peekCString maybe_errmsg
1207                 return (Just str)
1208
1209 foreign import ccall "addDLL" unsafe
1210   c_addDLL :: CString -> IO CString
1211
1212 -----------------------------------------------------------------------------
1213 -- timing & statistics
1214
1215 timeIt :: GHCi a -> GHCi a
1216 timeIt action
1217   = do b <- isOptionSet ShowTiming
1218        if not b
1219           then action
1220           else do allocs1 <- io $ getAllocations
1221                   time1   <- io $ getCPUTime
1222                   a <- action
1223                   allocs2 <- io $ getAllocations
1224                   time2   <- io $ getCPUTime
1225                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
1226                   return a
1227
1228 foreign import "getAllocations" getAllocations :: IO Int
1229
1230 printTimes :: Int -> Integer -> IO ()
1231 printTimes allocs psecs
1232    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1233             secs_str = showFFloat (Just 2) secs
1234         putStrLn (showSDoc (
1235                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1236                          int allocs <+> text "bytes")))
1237
1238 -----------------------------------------------------------------------------
1239 -- utils
1240
1241 looksLikeModuleName [] = False
1242 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1243
1244 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1245
1246 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1247                      | otherwise            = return ()
1248
1249 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1250                        | otherwise            = return ()
1251
1252 -----------------------------------------------------------------------------
1253 -- reverting CAFs
1254
1255 revertCAFs :: IO ()
1256 revertCAFs = do
1257   rts_revertCAFs
1258   Monad.join (readIORef turn_off_buffering)
1259         -- have to do this again, because we just reverted
1260         -- stdout, stderr & stdin to their defaults.
1261
1262 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
1263         -- make it "safe", just in case