ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.69 2001/05/28 03:17:03 sof Exp $
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 {-# OPTIONS -#include "Linker.h" #-}
  11 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
  12
  13 #include "../includes/config.h"
  14 #include "HsVersions.h"
  15
  16 import CompManager
  17 import CmStaticInfo
  18 import ByteCodeLink
  19 import DriverFlags
  20 import DriverState
  21 import DriverUtil
  22 import Linker
  23 import Finder           ( flushPackageCache )
  24 import Util
  25 import Name             ( Name )
  26 import Outputable
  27 import CmdLineOpts      ( DynFlag(..), dopt_unset )
  28 import Panic            ( GhcException(..) )
  29 import Config
  30
  31 #ifndef mingw32_TARGET_OS
  32 import Posix
  33 #endif
  34
  35 import Exception
  36 import Dynamic
  37 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
  38 import Readline
  39 #endif
  40 import IOExts
  41
  42 import Numeric
  43 import List
  44 import System
  45 import CPUTime
  46 import Directory
  47 import IO
  48 import Char
  49 import Monad            ( when )
  50
  51 import PrelGHC          ( unsafeCoerce# )
  52 import Foreign          ( nullPtr )
  53 import CString          ( peekCString )
  54
  55 -----------------------------------------------------------------------------
  56
  57 ghciWelcomeMsg = "\
  58 \   ___         ___ _\n\
  59 \  / _ \\ /\\  /\\/ __(_)\n\
  60 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
  61 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  62 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  63
  64 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  65
  66 builtin_commands :: [(String, String -> GHCi Bool)]
  67 builtin_commands = [
  68   ("add",       keepGoing addModule),
  69   ("cd",        keepGoing changeDirectory),
  70   ("def",       keepGoing defineMacro),
  71   ("help",      keepGoing help),
  72   ("?",         keepGoing help),
  73   ("load",      keepGoing loadModule),
  74   ("module",    keepGoing setContext),
  75   ("reload",    keepGoing reloadModule),
  76   ("set",       keepGoing setOptions),
  77   ("type",      keepGoing typeOfExpr),
  78   ("unset",     keepGoing unsetOptions),
  79   ("undef",     keepGoing undefineMacro),
  80   ("quit",      quit)
  81   ]
  82
  83 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
  84 keepGoing a str = a str >> return False
  85
  86 shortHelpText = "use :? for help.\n"
  87
  88 helpText = "\
  89 \ Commands available from the prompt:\n\
  90 \\
  91 \   <stmt>                 evaluate/run <stmt>\n\
  92 \   :cd <dir>              change directory to <dir>\n\
  93 \   :def <cmd> <expr>      define a command :<cmd>\n\
  94 \   :help, :?              display this list of commands\n\
  95 \   :load <filename>       load a module (and its dependents)\n\
  96 \   :module <mod>          set the context for expression evaluation to <mod>\n\
  97 \   :reload                reload the current module set\n\
  98 \   :set <option> ...      set options\n\
  99 \   :undef <cmd>           undefine user-defined command :<cmd>\n\
 100 \   :type <expr>           show the type of <expr>\n\
 101 \   :unset <option> ...    unset options\n\
 102 \   :quit                  exit GHCi\n\
 103 \   :!<command>            run the shell command <command>\n\
 104 \\
 105 \ Options for `:set' and `:unset':\n\
 106 \\
 107 \    +r                 revert top-level expressions after each evaluation\n\
 108 \    +s                 print timing/memory stats after each evaluation\n\
 109 \    +t                 print type after evaluation\n\
 110 \    -<flags>           most GHC command line flags can also be set here\n\
 111 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 112 \"
 113  --ToDo   :add <filename>     add a module to the current set\n\
 114
 115 interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO ()
 116 interactiveUI cmstate mod cmdline_libs = do
 117    hFlush stdout
 118    hSetBuffering stdout NoBuffering
 119
 120    -- link in the available packages
 121    pkgs <- getPackageInfo
 122    initLinker
 123    linkPackages cmdline_libs pkgs
 124
 125    (cmstate, ok, mods) <-
 126         case mod of
 127              Nothing  -> return (cmstate, True, [])
 128              Just m -> cmLoadModule cmstate m
 129
 130 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 131    Readline.initialize
 132 #endif
 133
 134    dflags <- getDynFlags
 135
 136    (cmstate, maybe_hval)
 137         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
 138    case maybe_hval of
 139         Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
 140         _ -> panic "interactiveUI:stderr"
 141
 142    (cmstate, maybe_hval)
 143         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
 144    case maybe_hval of
 145         Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
 146         _ -> panic "interactiveUI:stdout"
 147
 148    (unGHCi runGHCi) GHCiState{ target = mod,
 149                                cmstate = cmstate,
 150                                options = [] }
 151    return ()
 152
 153
 154 runGHCi :: GHCi ()
 155 runGHCi = do
 156   -- Read in ./.ghci.
 157   let file = "./.ghci"
 158   exists <- io (doesFileExist file)
 159   when exists $ do
 160      dir_ok  <- io (checkPerms ".")
 161      file_ok <- io (checkPerms file)
 162      when (dir_ok && file_ok) $ do
 163         either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 164         case either_hdl of
 165            Left e    -> return ()
 166            Right hdl -> fileLoop hdl False
 167
 168   -- Read in $HOME/.ghci
 169   either_dir <- io (IO.try (getEnv "HOME"))
 170   case either_dir of
 171      Left e -> return ()
 172      Right dir -> do
 173         cwd <- io (getCurrentDirectory)
 174         when (dir /= cwd) $ do
 175            let file = dir ++ "/.ghci"
 176            ok <- io (checkPerms file)
 177            either_hdl <- io (IO.try (openFile file ReadMode))
 178            case either_hdl of
 179                 Left e    -> return ()
 180                 Right hdl -> fileLoop hdl False
 181
 182   -- read commands from stdin
 183 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 184   readlineLoop
 185 #else
 186   fileLoop stdin True
 187 #endif
 188
 189   -- and finally, exit
 190   io $ do putStrLn "Leaving GHCi."
 191
 192
 193 -- NOTE: We only read .ghci files if they are owned by the current user,
 194 -- and aren't world writable.  Otherwise, we could be accidentally
 195 -- running code planted by a malicious third party.
 196
 197 -- Furthermore, We only read ./.ghci if both . and ./.ghci are
 198 -- owned by the current user and aren't writable by anyone else.  I
 199 -- think this is sufficient: we don't need to check .. and
 200 -- ../.. etc. because "."  always refers to the same directory while a
 201 -- process is running.
 202
 203 checkPerms :: String -> IO Bool
 204 checkPerms name =
 205   handle (\_ -> return False) $ do
 206 #ifdef mingw32_TARGET_OS
 207      doesFileExist name
 208 #else
 209      st <- getFileStatus name
 210      me <- getRealUserID
 211      if fileOwner st /= me then do
 212         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 213         return False
 214       else do
 215         let mode =  fileMode st
 216         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 217            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 218            then do
 219                putStrLn $ "*** WARNING: " ++ name ++
 220                           " is writable by someone else, IGNORING!"
 221                return False
 222           else return True
 223 #endif
 224
 225 fileLoop :: Handle -> Bool -> GHCi ()
 226 fileLoop hdl prompt = do
 227    st <- getGHCiState
 228    mod <- io (cmGetContext (cmstate st))
 229    when prompt (io (putStr (mod ++ "> ")))
 230    l <- io (IO.try (hGetLine hdl))
 231    case l of
 232         Left e | isEOFError e -> return ()
 233                | otherwise    -> throw e
 234         Right l ->
 235           case remove_spaces l of
 236             "" -> fileLoop hdl prompt
 237             l  -> do quit <- runCommand l
 238                      if quit then return () else fileLoop hdl prompt
 239
 240 stringLoop :: [String] -> GHCi ()
 241 stringLoop [] = return ()
 242 stringLoop (s:ss) = do
 243    st <- getGHCiState
 244    case remove_spaces s of
 245         "" -> stringLoop ss
 246         l  -> do quit <- runCommand l
 247                  if quit then return () else stringLoop ss
 248
 249 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 250 readlineLoop :: GHCi ()
 251 readlineLoop = do
 252    st <- getGHCiState
 253    mod <- io (cmGetContext (cmstate st))
 254    l <- io (readline (mod ++ "> "))
 255    case l of
 256         Nothing -> return ()
 257         Just l  ->
 258           case remove_spaces l of
 259             "" -> readlineLoop
 260             l  -> do
 261                   io (addHistory l)
 262                   quit <- runCommand l
 263                   if quit then return () else readlineLoop
 264 #endif
 265
 266 -- Top level exception handler, just prints out the exception
 267 -- and carries on.
 268 runCommand :: String -> GHCi Bool
 269 runCommand c =
 270   ghciHandle ( \exception ->
 271         (case exception of
 272            DynException dyn ->
 273               case fromDynamic dyn of
 274                 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
 275                 Just ghc_ex ->
 276                   case ghc_ex of
 277                     PhaseFailed phase code ->
 278                         io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 279                                         ++ show code ++ ")"))
 280                     Interrupted -> io (putStrLn "Interrupted.")
 281                         -- omit the location for CmdLineError
 282                     CmdLineError s -> io (putStrLn s)
 283                     other -> io (putStrLn (show (ghc_ex :: GhcException)))
 284
 285            other -> io (putStrLn ("*** Exception: " ++ show exception))
 286
 287         ) >> return False
 288      ) $
 289
 290    doCommand c
 291
 292 doCommand (':' : command) = specialCommand command
 293 doCommand stmt
 294    = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
 295         return False
 296
 297 -- Returns True if the expr was successfully parsed, renamed and
 298 -- typechecked.
 299 runStmt :: String -> GHCi (Maybe [Name])
 300 runStmt stmt
 301  | null (filter (not.isSpace) stmt)
 302  = return Nothing
 303  | otherwise
 304  = do st <- getGHCiState
 305       dflags <- io (getDynFlags)
 306       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 307       (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
 308       setGHCiState st{cmstate = new_cmstate}
 309       return (Just names)
 310
 311 -- possibly print the type and revert CAFs after evaluating an expression
 312 finishEvalExpr Nothing = return False
 313 finishEvalExpr (Just names)
 314  = do b <- isOptionSet ShowType
 315       st <- getGHCiState
 316       when b (mapM_ (showTypeOfName (cmstate st)) names)
 317
 318       b <- isOptionSet RevertCAFs
 319       io (when b revertCAFs)
 320       flushEverything
 321       return True
 322
 323 showTypeOfName :: CmState -> Name -> GHCi ()
 324 showTypeOfName cmstate n
 325    = do maybe_str <- io (cmTypeOfName cmstate n)
 326         case maybe_str of
 327           Nothing  -> return ()
 328           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 329
 330 flushEverything :: GHCi ()
 331 flushEverything
 332    = io $ do flush_so <- readIORef flush_stdout
 333              flush_so
 334              flush_se <- readIORef flush_stdout
 335              flush_se
 336              return ()
 337
 338 specialCommand :: String -> GHCi Bool
 339 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 340 specialCommand str = do
 341   let (cmd,rest) = break isSpace str
 342   cmds <- io (readIORef commands)
 343   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 344      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 345                                     ++ shortHelpText) >> return False)
 346      [(_,f)] -> f (dropWhile isSpace rest)
 347      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 348                                       " matches multiple commands (" ++
 349                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 350                                          ++ ")") >> return False)
 351
 352 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 353
 354 -----------------------------------------------------------------------------
 355 -- Commands
 356
 357 help :: String -> GHCi ()
 358 help _ = io (putStr helpText)
 359
 360 addModule :: String -> GHCi ()
 361 addModule _ = throwDyn (InstallationError ":add not implemented")
 362
 363 setContext :: String -> GHCi ()
 364 setContext ""
 365   = throwDyn (CmdLineError "syntax: `:m <module>'")
 366 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 367   = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
 368 setContext str
 369   = do st <- getGHCiState
 370        new_cmstate <- io (cmSetContext (cmstate st) str)
 371        setGHCiState st{cmstate=new_cmstate}
 372
 373 changeDirectory :: String -> GHCi ()
 374 changeDirectory ('~':d) = do
 375    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 376    io (setCurrentDirectory (tilde ++ '/':d))
 377 changeDirectory d = io (setCurrentDirectory d)
 378
 379 defineMacro :: String -> GHCi ()
 380 defineMacro s = do
 381   let (macro_name, definition) = break isSpace s
 382   cmds <- io (readIORef commands)
 383   if (null macro_name)
 384         then throwDyn (CmdLineError "invalid macro name")
 385         else do
 386   if (macro_name `elem` map fst cmds)
 387         then throwDyn (CmdLineError
 388                 ("command `" ++ macro_name ++ "' is already defined"))
 389         else do
 390
 391   -- give the expression a type signature, so we can be sure we're getting
 392   -- something of the right type.
 393   let new_expr = '(' : definition ++ ") :: String -> IO String"
 394
 395   -- compile the expression
 396   st <- getGHCiState
 397   dflags <- io (getDynFlags)
 398   (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
 399   setGHCiState st{cmstate = new_cmstate}
 400   case maybe_hv of
 401      Nothing -> return ()
 402      Just hv -> io (writeIORef commands --
 403                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 404
 405 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 406 runMacro fun s = do
 407   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 408   stringLoop (lines str)
 409
 410 undefineMacro :: String -> GHCi ()
 411 undefineMacro macro_name = do
 412   cmds <- io (readIORef commands)
 413   if (macro_name `elem` map fst builtin_commands)
 414         then throwDyn (CmdLineError
 415                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 416         else do
 417   if (macro_name `notElem` map fst cmds)
 418         then throwDyn (CmdLineError
 419                 ("command `" ++ macro_name ++ "' not defined"))
 420         else do
 421   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 422
 423 loadModule :: String -> GHCi ()
 424 loadModule path = timeIt (loadModule' path)
 425
 426 loadModule' path = do
 427   state <- getGHCiState
 428   dflags <- io (getDynFlags)
 429   cmstate1 <- io (cmUnload (cmstate state) dflags)
 430   io (revertCAFs)                       -- always revert CAFs on load.
 431   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 432   let new_state = state{ cmstate = cmstate2,
 433                          target = Just path
 434                        }
 435   setGHCiState new_state
 436   modulesLoadedMsg ok mods
 437
 438 reloadModule :: String -> GHCi ()
 439 reloadModule "" = do
 440   state <- getGHCiState
 441   case target state of
 442    Nothing -> io (putStr "no current target\n")
 443    Just path
 444       -> do io (revertCAFs)             -- always revert CAFs on reload.
 445             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 446             setGHCiState state{ cmstate=new_cmstate }
 447             modulesLoadedMsg ok mods
 448
 449 reloadModule _ = noArgs ":reload"
 450
 451
 452 modulesLoadedMsg ok mods = do
 453   let mod_commas
 454         | null mods = text "none."
 455         | otherwise = hsep (
 456             punctuate comma (map text mods)) <> text "."
 457   case ok of
 458     False ->
 459        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 460     True  ->
 461        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 462
 463
 464 typeOfExpr :: String -> GHCi ()
 465 typeOfExpr str
 466   = do st <- getGHCiState
 467        dflags <- io (getDynFlags)
 468        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
 469        setGHCiState st{cmstate = new_cmstate}
 470        case maybe_tystr of
 471           Nothing    -> return ()
 472           Just tystr -> io (putStrLn tystr)
 473
 474 quit :: String -> GHCi Bool
 475 quit _ = return True
 476
 477 shellEscape :: String -> GHCi Bool
 478 shellEscape str = io (system str >> return False)
 479
 480 ----------------------------------------------------------------------------
 481 -- Code for `:set'
 482
 483 -- set options in the interpreter.  Syntax is exactly the same as the
 484 -- ghc command line, except that certain options aren't available (-C,
 485 -- -E etc.)
 486 --
 487 -- This is pretty fragile: most options won't work as expected.  ToDo:
 488 -- figure out which ones & disallow them.
 489
 490 setOptions :: String -> GHCi ()
 491 setOptions ""
 492   = do st <- getGHCiState
 493        let opts = options st
 494        io $ putStrLn (showSDoc (
 495               text "options currently set: " <>
 496               if null opts
 497                    then text "none."
 498                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 499            ))
 500 setOptions str
 501   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 502       let (plus_opts, minus_opts)  = partition isPlus (words str)
 503       mapM setOpt plus_opts
 504
 505       -- now, the GHC flags
 506       pkgs_before <- io (readIORef v_Packages)
 507       leftovers   <- io (processArgs static_flags minus_opts [])
 508       pkgs_after  <- io (readIORef v_Packages)
 509
 510       -- update things if the users wants more packages
 511       when (pkgs_before /= pkgs_after) $
 512          newPackages (pkgs_after \\ pkgs_before)
 513
 514       -- then, dynamic flags
 515       io $ do
 516         dyn_flags <- readIORef v_InitDynFlags
 517         writeIORef v_DynFlags dyn_flags
 518         leftovers <- processArgs dynamic_flags leftovers []
 519         dyn_flags <- readIORef v_DynFlags
 520         writeIORef v_InitDynFlags dyn_flags
 521
 522         if (not (null leftovers))
 523                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 524                                                 unwords leftovers))
 525                 else return ()
 526
 527
 528 unsetOptions :: String -> GHCi ()
 529 unsetOptions str
 530   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 531        let opts = words str
 532            (minus_opts, rest1) = partition isMinus opts
 533            (plus_opts, rest2)  = partition isPlus rest1
 534
 535        if (not (null rest2))
 536           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 537           else do
 538
 539        mapM unsetOpt plus_opts
 540
 541        -- can't do GHC flags for now
 542        if (not (null minus_opts))
 543           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 544           else return ()
 545
 546 isMinus ('-':s) = True
 547 isMinus _ = False
 548
 549 isPlus ('+':s) = True
 550 isPlus _ = False
 551
 552 setOpt ('+':str)
 553   = case strToGHCiOpt str of
 554         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 555         Just o  -> setOption o
 556
 557 unsetOpt ('+':str)
 558   = case strToGHCiOpt str of
 559         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 560         Just o  -> unsetOption o
 561
 562 strToGHCiOpt :: String -> (Maybe GHCiOption)
 563 strToGHCiOpt "s" = Just ShowTiming
 564 strToGHCiOpt "t" = Just ShowType
 565 strToGHCiOpt "r" = Just RevertCAFs
 566 strToGHCiOpt _   = Nothing
 567
 568 optToStr :: GHCiOption -> String
 569 optToStr ShowTiming = "s"
 570 optToStr ShowType   = "t"
 571 optToStr RevertCAFs = "r"
 572
 573 newPackages new_pkgs = do
 574   state <- getGHCiState
 575   dflags <- io (getDynFlags)
 576   cmstate1 <- io (cmUnload (cmstate state) dflags)
 577   setGHCiState state{ cmstate = cmstate1, target = Nothing }
 578
 579   io $ do
 580     pkgs <- getPackageInfo
 581     flushPackageCache pkgs
 582
 583     new_pkg_info <- getPackageDetails new_pkgs
 584     mapM_ (linkPackage False) (reverse new_pkg_info)
 585
 586 -----------------------------------------------------------------------------
 587 -- GHCi monad
 588
 589 data GHCiState = GHCiState
 590      {
 591         target         :: Maybe FilePath,
 592         cmstate        :: CmState,
 593         options        :: [GHCiOption]
 594      }
 595
 596 data GHCiOption
 597         = ShowTiming            -- show time/allocs after evaluation
 598         | ShowType              -- show the type of expressions
 599         | RevertCAFs            -- revert CAFs after every evaluation
 600         deriving Eq
 601
 602 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 603 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 604
 605 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 606
 607 instance Monad GHCi where
 608   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 609   return a  = GHCi $ \s -> return (s,a)
 610
 611 getGHCiState   = GHCi $ \s -> return (s,s)
 612 setGHCiState s = GHCi $ \_ -> return (s,())
 613
 614 isOptionSet :: GHCiOption -> GHCi Bool
 615 isOptionSet opt
 616  = do st <- getGHCiState
 617       return (opt `elem` options st)
 618
 619 setOption :: GHCiOption -> GHCi ()
 620 setOption opt
 621  = do st <- getGHCiState
 622       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 623
 624 unsetOption :: GHCiOption -> GHCi ()
 625 unsetOption opt
 626  = do st <- getGHCiState
 627       setGHCiState (st{ options = filter (/= opt) (options st) })
 628
 629 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 630
 631 -----------------------------------------------------------------------------
 632 -- recursive exception handlers
 633
 634 -- Don't forget to unblock async exceptions in the handler, or if we're
 635 -- in an exception loop (eg. let a = error a in a) the ^C exception
 636 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 637
 638 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 639 ghciHandle h (GHCi m) = GHCi $ \s ->
 640    Exception.catch (m s)
 641         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 642
 643 ghciUnblock :: GHCi a -> GHCi a
 644 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 645
 646 -----------------------------------------------------------------------------
 647 -- package loader
 648
 649 -- Left: full path name of a .o file, including trailing .o
 650 -- Right: "unadorned" name of a .DLL/.so
 651 --        e.g.    On unix     "qt"  denotes "libqt.so"
 652 --                On WinDoze  "burble"  denotes "burble.DLL"
 653 --        addDLL is platform-specific and adds the lib/.so/.DLL
 654 --        prefixes plaform-dependently; we don't do that here.
 655 type LibrarySpec
 656    = Either FilePath String
 657
 658 showLS (Left nm)  = "(static) " ++ nm
 659 showLS (Right nm) = "(dynamic) " ++ nm
 660
 661 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
 662 linkPackages cmdline_lib_specs pkgs
 663    = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
 664         mapM_ preloadLib cmdline_lib_specs
 665      where
 666         -- packages that are already linked into GHCi
 667         loaded = [ "concurrent", "posix", "text", "util" ]
 668
 669         preloadLib lib_spec
 670            = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
 671                 case lib_spec of
 672                    Left static_ish
 673                       -> do b <- doesFileExist static_ish
 674                             if    not b
 675                              then do putStr "not found.\n"
 676                                      croak
 677                              else do loadObj static_ish
 678                                      putStr "done.\n"
 679                    Right dll_unadorned
 680                       -> do maybe_errmsg <- addDLL dll_unadorned
 681                             if    maybe_errmsg == nullPtr
 682                              then putStr "done.\n"
 683                              else do str <- peekCString maybe_errmsg
 684                                      putStr ("failed (" ++ str ++ ")\n")
 685                                      croak
 686
 687         croak = throwDyn (CmdLineError "user specified .o/.so/.DLL could not be loaded.")
 688
 689
 690 linkPackage :: Bool -> PackageConfig -> IO ()
 691 -- ignore rts and gmp for now (ToDo; better?)
 692 linkPackage loaded_in_ghci pkg
 693    | name pkg `elem` ["rts", "gmp"]
 694    = return ()
 695    | otherwise
 696    = do putStr ("Loading package " ++ name pkg ++ " ... ")
 697         -- For each obj, try obj.o and if that fails, obj.so.
 698         -- Complication: all the .so's must be loaded before any of the .o's.
 699         let dirs      =  library_dirs pkg
 700         let objs      =  hs_libraries pkg ++ extra_libraries pkg
 701         classifieds   <- mapM (locateOneObj dirs) objs
 702
 703         -- Don't load the .so libs if this is a package GHCi is already
 704         -- linked against, because we'll already have the .so linked in.
 705         let (so_libs, obj_libs) = partition isRight classifieds
 706         let sos_first | loaded_in_ghci = obj_libs
 707                       | otherwise      = so_libs ++ obj_libs
 708
 709         mapM loadClassified sos_first
 710         putStr "linking ... "
 711         resolveObjs
 712         putStrLn "done."
 713      where
 714         isRight (Right _) = True
 715         isRight (Left _)  = False
 716
 717 loadClassified :: LibrarySpec -> IO ()
 718 loadClassified (Left obj_absolute_filename)
 719    = do loadObj obj_absolute_filename
 720 loadClassified (Right dll_unadorned)
 721    = do maybe_errmsg <- addDLL dll_unadorned
 722         if    maybe_errmsg == nullPtr
 723          then return ()
 724          else do str <- peekCString maybe_errmsg
 725                  throwDyn (CmdLineError ("can't find .o or .so/.DLL for: "
 726                                        ++ dll_unadorned ++ " (" ++ str ++ ")" ))
 727
 728 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
 729 locateOneObj []     obj
 730    = return (Right obj) -- we assume
 731 locateOneObj (d:ds) obj
 732    = do let path = d ++ '/':obj ++ ".o"
 733         b <- doesFileExist path
 734         if b then return (Left path) else locateOneObj ds obj
 735
 736 -----------------------------------------------------------------------------
 737 -- timing & statistics
 738
 739 timeIt :: GHCi a -> GHCi a
 740 timeIt action
 741   = do b <- isOptionSet ShowTiming
 742        if not b
 743           then action
 744           else do allocs1 <- io $ getAllocations
 745                   time1   <- io $ getCPUTime
 746                   a <- action
 747                   allocs2 <- io $ getAllocations
 748                   time2   <- io $ getCPUTime
 749                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
 750                   return a
 751
 752 foreign import "getAllocations" getAllocations :: IO Int
 753
 754 printTimes :: Int -> Integer -> IO ()
 755 printTimes allocs psecs
 756    = do let secs = (fromIntegral psecs / (10^12)) :: Float
 757             secs_str = showFFloat (Just 2) secs
 758         putStrLn (showSDoc (
 759                  parens (text (secs_str "") <+> text "secs" <> comma <+>
 760                          int allocs <+> text "bytes")))
 761
 762 -----------------------------------------------------------------------------
 763 -- reverting CAFs
 764
 765 foreign import revertCAFs :: IO ()      -- make it "safe", just in case