ghc/compiler/ghci/InteractiveUI.hs

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