ghc/compiler/ghci/InteractiveUI.hs

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