ghc/compiler/ghci/InteractiveUI.hs

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