ghc/compiler/ghci/InteractiveUI.hs

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