ghc/compiler/ghci/InteractiveUI.hs

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