ghc/compiler/ghci/InteractiveUI.hs

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