ghc/compiler/ghci/InteractiveUI.hs

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