ghc/compiler/ghci/InteractiveUI.hs

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