ghc/compiler/ghci/InteractiveUI.hs

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