ghc/compiler/ghci/InteractiveUI.hs

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