ghc/compiler/ghci/InteractiveUI.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: InteractiveUI.hs,v 1.51 2001/02/14 11:36:07 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          ( nullPtr )
  51 import CString          ( peekCString )
  52
  53 -----------------------------------------------------------------------------
  54
  55 ghciWelcomeMsg = "\
  56 \   ___         ___ _\n\
  57 \  / _ \\ /\\  /\\/ __(_)\n\
  58 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", For Haskell 98.\n\
  59 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  60 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  61
  62 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  63
  64 builtin_commands :: [(String, String -> GHCi Bool)]
  65 builtin_commands = [
  66   ("add",       keepGoing addModule),
  67   ("cd",        keepGoing changeDirectory),
  68   ("def",       keepGoing defineMacro),
  69   ("help",      keepGoing help),
  70   ("?",         keepGoing help),
  71   ("load",      keepGoing loadModule),
  72   ("module",    keepGoing setContext),
  73   ("reload",    keepGoing reloadModule),
  74   ("set",       keepGoing setOptions),
  75   ("type",      keepGoing typeOfExpr),
  76   ("unset",     keepGoing unsetOptions),
  77   ("undef",     keepGoing undefineMacro),
  78   ("quit",      quit)
  79   ]
  80
  81 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
  82 keepGoing a str = a str >> return False
  83
  84 shortHelpText = "use :? for help.\n"
  85
  86 helpText = "\
  87 \ Commands available from the prompt:\n\
  88 \\
  89 \   <expr>              evaluate <expr>\n\
  90 \   :add <filename>     add a module to the current set\n\
  91 \   :cd <dir>           change directory to <dir>\n\
  92 \   :help, :?           display this list of commands\n\
  93 \   :load <filename>    load a module (and it dependents)\n\
  94 \   :module <mod>       set the context for expression evaluation to <mod>\n\
  95 \   :reload             reload the current module set\n\
  96 \   :set <option> ...   set options\n\
  97 \   :unset <option> ... unset options\n\
  98 \   :type <expr>        show the type of <expr>\n\
  99 \   :quit               exit GHCi\n\
 100 \   :!<command>         run the shell command <command>\n\
 101 \\
 102 \ Options for `:set' and `:unset':\n\
 103 \\
 104 \    +s                 print timing/memory stats after each evaluation\n\
 105 \    +t                 print type after evaluation\n\
 106 \    +r                 revert top-level expressions after each evaluation\n\
 107 \    -<flags>           most GHC command line flags can also be set here\n\
 108 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 109 \"
 110
 111 interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO ()
 112 interactiveUI cmstate mod cmdline_libs = do
 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 expr_expanded stuff)
 259         when expr_ok (rememberExpr expr_expanded)
 260         return False
 261
 262 -- Returns True if the expr was successfully parsed, renamed and
 263 -- typechecked.
 264 evalExpr :: String -> GHCi Bool
 265 evalExpr expr
 266  | null (filter (not.isSpace) expr)
 267  = return False
 268  | otherwise
 269  = do st <- getGHCiState
 270       dflags <- io (getDynFlags)
 271       (new_cmstate, maybe_stuff) <-
 272          io (cmGetExpr (cmstate st) dflags True (current_module st) expr)
 273       setGHCiState st{cmstate = new_cmstate}
 274       case maybe_stuff of
 275          Nothing -> return False
 276          Just (hv, unqual, ty) ->
 277                 do io (cmRunExpr hv)
 278                    return True
 279
 280 -- possibly print the type and revert CAFs after evaluating an expression
 281 finishEvalExpr _ False = return False
 282 finishEvalExpr expr True
 283  = do b <- isOptionSet ShowType
 284         -- re-typecheck, don't wrap with print this time
 285       when b (io (putStr ":: ") >> typeOfExpr expr)
 286       b <- isOptionSet RevertCAFs
 287       io (when b revertCAFs)
 288       flushEverything
 289       return True
 290
 291 flushEverything :: GHCi ()
 292 flushEverything
 293    = io $ do flush_so <- readIORef flush_stdout
 294              cmRunExpr flush_so
 295              flush_se <- readIORef flush_stdout
 296              cmRunExpr flush_se
 297
 298 specialCommand :: String -> GHCi Bool
 299 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 300 specialCommand str = do
 301   let (cmd,rest) = break isSpace str
 302   cmds <- io (readIORef commands)
 303   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 304      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 305                                     ++ shortHelpText) >> return False)
 306      [(_,f)] -> f (dropWhile isSpace rest)
 307      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 308                                       " matches multiple commands (" ++
 309                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 310                                          ++ ")") >> return False)
 311
 312 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
 313
 314 -----------------------------------------------------------------------------
 315 -- Commands
 316
 317 help :: String -> GHCi ()
 318 help _ = io (putStr helpText)
 319
 320 addModule :: String -> GHCi ()
 321 addModule _ = throwDyn (OtherError ":add not implemented")
 322
 323 setContext :: String -> GHCi ()
 324 setContext ""
 325   = throwDyn (OtherError "syntax: `:m <module>'")
 326 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
 327   = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
 328 setContext str
 329   = do st <- getGHCiState
 330
 331        let mn = mkModuleName str
 332        m <- case [ m | m <- modules st, moduleName m == mn ] of
 333                 (m:_) -> return m
 334                 []    -> io (moduleNameToModule mn)
 335
 336        if (isHomeModule m && m `notElem` modules st)
 337           then throwDyn (OtherError (showSDoc (quotes (ppr (moduleName m))
 338                                 <+> text "is not currently loaded, use :load")))
 339           else setGHCiState st{current_module = m}
 340
 341 moduleNameToModule :: ModuleName -> IO Module
 342 moduleNameToModule mn
 343  = do maybe_stuff <- findModule mn
 344       case maybe_stuff of
 345         Nothing -> throwDyn (OtherError ("can't find module `"
 346                                     ++ moduleNameUserString mn ++ "'"))
 347         Just (m,_) -> return m
 348
 349 changeDirectory :: String -> GHCi ()
 350 changeDirectory d = io (setCurrentDirectory d)
 351
 352 defineMacro :: String -> GHCi ()
 353 defineMacro s = do
 354   let (macro_name, definition) = break isSpace s
 355   cmds <- io (readIORef commands)
 356   if (null macro_name)
 357         then throwDyn (OtherError "invalid macro name")
 358         else do
 359   if (macro_name `elem` map fst cmds)
 360         then throwDyn (OtherError
 361                 ("command `" ++ macro_name ++ "' already defined"))
 362         else do
 363
 364   -- give the expression a type signature, so we can be sure we're getting
 365   -- something of the right type.
 366   let new_expr = '(' : definition ++ ") :: String -> IO String"
 367
 368   -- compile the expression
 369   st <- getGHCiState
 370   dflags <- io (getDynFlags)
 371   (new_cmstate, maybe_stuff) <-
 372          io (cmGetExpr (cmstate st) dflags False (current_module st) new_expr)
 373   setGHCiState st{cmstate = new_cmstate}
 374   case maybe_stuff of
 375      Nothing -> return ()
 376      Just (hv, unqual, ty)
 377         -> io (writeIORef commands
 378                  ((macro_name, keepGoing (runMacro hv)) : cmds))
 379
 380 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 381 runMacro fun s = do
 382   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 383   stringLoop (lines str)
 384
 385 undefineMacro :: String -> GHCi ()
 386 undefineMacro macro_name = do
 387   cmds <- io (readIORef commands)
 388   if (macro_name `elem` map fst builtin_commands)
 389         then throwDyn (OtherError
 390                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 391         else do
 392   if (macro_name `notElem` map fst cmds)
 393         then throwDyn (OtherError
 394                 ("command `" ++ macro_name ++ "' not defined"))
 395         else do
 396   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 397
 398 loadModule :: String -> GHCi ()
 399 loadModule path = timeIt (loadModule' path)
 400
 401 loadModule' path = do
 402   state <- getGHCiState
 403   cmstate1 <- io (cmUnload (cmstate state))
 404   io (revertCAFs)                       -- always revert CAFs on load.
 405   (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
 406
 407   def_mod <- io (readIORef defaultCurrentModule)
 408
 409   let new_state = state{
 410                         cmstate = cmstate2,
 411                         modules = mods,
 412                         current_module = case mods of
 413                                            [] -> def_mod
 414                                            xs -> head xs,
 415                         target = Just path
 416                    }
 417   setGHCiState new_state
 418
 419   let mod_commas
 420         | null mods = text "none."
 421         | otherwise = hsep (
 422             punctuate comma (map (text.moduleUserString) mods)) <> text "."
 423   case ok of
 424     False ->
 425        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 426     True  ->
 427        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 428
 429 reloadModule :: String -> GHCi ()
 430 reloadModule "" = do
 431   state <- getGHCiState
 432   case target state of
 433    Nothing -> io (putStr "no current target\n")
 434    Just path
 435       -> do io (revertCAFs)             -- always revert CAFs on reload.
 436             (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
 437             def_mod <- io (readIORef defaultCurrentModule)
 438             setGHCiState
 439                state{cmstate=new_cmstate,
 440                      modules = mods,
 441                      current_module = case mods of
 442                                          [] -> def_mod
 443                                          xs -> head xs
 444                     }
 445
 446 reloadModule _ = noArgs ":reload"
 447
 448 typeOfExpr :: String -> GHCi ()
 449 typeOfExpr str
 450   = do st <- getGHCiState
 451        dflags <- io (getDynFlags)
 452        (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False
 453                                          (current_module st) str)
 454        setGHCiState st{cmstate = new_cmstate}
 455        case maybe_ty of
 456          Nothing -> return ()
 457          Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
 458
 459 quit :: String -> GHCi Bool
 460 quit _ = return True
 461
 462 shellEscape :: String -> GHCi Bool
 463 shellEscape str = io (system str >> return False)
 464
 465 ----------------------------------------------------------------------------
 466 -- Code for `:set'
 467
 468 -- set options in the interpreter.  Syntax is exactly the same as the
 469 -- ghc command line, except that certain options aren't available (-C,
 470 -- -E etc.)
 471 --
 472 -- This is pretty fragile: most options won't work as expected.  ToDo:
 473 -- figure out which ones & disallow them.
 474
 475 setOptions :: String -> GHCi ()
 476 setOptions ""
 477   = do st <- getGHCiState
 478        let opts = options st
 479        io $ putStrLn (showSDoc (
 480               text "options currently set: " <>
 481               if null opts
 482                    then text "none."
 483                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 484            ))
 485 setOptions str
 486   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 487        let opts = words str
 488            (minus_opts, rest1) = partition isMinus opts
 489            (plus_opts, rest2)  = partition isPlus rest1
 490
 491        if (not (null rest2))
 492           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 493           else do
 494
 495        mapM setOpt plus_opts
 496
 497        -- now, the GHC flags
 498        io (do -- first, static flags
 499               leftovers <- processArgs static_flags minus_opts []
 500
 501               -- then, dynamic flags
 502               dyn_flags <- readIORef v_InitDynFlags
 503               writeIORef v_DynFlags dyn_flags
 504               leftovers <- processArgs dynamic_flags leftovers []
 505               dyn_flags <- readIORef v_DynFlags
 506               writeIORef v_InitDynFlags dyn_flags
 507
 508               if (not (null leftovers))
 509                  then throwDyn (OtherError ("unrecognised flags: " ++
 510                                                 unwords leftovers))
 511                  else return ()
 512          )
 513
 514 unsetOptions :: String -> GHCi ()
 515 unsetOptions str
 516   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 517        let opts = words str
 518            (minus_opts, rest1) = partition isMinus opts
 519            (plus_opts, rest2)  = partition isPlus rest1
 520
 521        if (not (null rest2))
 522           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 523           else do
 524
 525        mapM unsetOpt plus_opts
 526
 527        -- can't do GHC flags for now
 528        if (not (null minus_opts))
 529           then throwDyn (OtherError "can't unset GHC command-line flags")
 530           else return ()
 531
 532 isMinus ('-':s) = True
 533 isMinus _ = False
 534
 535 isPlus ('+':s) = True
 536 isPlus _ = False
 537
 538 setOpt ('+':str)
 539   = case strToGHCiOpt str of
 540         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 541         Just o  -> setOption o
 542
 543 unsetOpt ('+':str)
 544   = case strToGHCiOpt str of
 545         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 546         Just o  -> unsetOption o
 547
 548 strToGHCiOpt :: String -> (Maybe GHCiOption)
 549 strToGHCiOpt "s" = Just ShowTiming
 550 strToGHCiOpt "t" = Just ShowType
 551 strToGHCiOpt "r" = Just RevertCAFs
 552 strToGHCiOpt _   = Nothing
 553
 554 optToStr :: GHCiOption -> String
 555 optToStr ShowTiming = "s"
 556 optToStr ShowType   = "t"
 557 optToStr RevertCAFs = "r"
 558
 559 -----------------------------------------------------------------------------
 560 -- Code to do last-expression-entered stuff.  (a.k.a the $$ facility)
 561
 562 -- Take a string and replace $$s in it with the last expr, if any.
 563 expandExpr :: String -> GHCi String
 564 expandExpr str
 565    = do mle <- getLastExpr
 566         return (outside mle str)
 567      where
 568         outside mle ('$':'$':cs)
 569            = case mle of
 570                 Just le -> " (" ++ le ++ ") " ++ outside mle cs
 571                 Nothing -> outside mle cs
 572
 573         outside mle []           = []
 574         outside mle ('"':str)    = '"' : inside2 mle str   -- "
 575         outside mle ('\'':str)   = '\'' : inside1 mle str   -- '
 576         outside mle (c:cs)       = c : outside mle cs
 577
 578         inside2 mle ('"':cs)  = '"' : outside mle cs   -- "
 579         inside2 mle (c:cs)    = c : inside2 mle cs
 580         inside2 mle []        = []
 581
 582         inside1 mle ('\'':cs) = '\'': outside mle cs
 583         inside1 mle (c:cs)    = c : inside1 mle cs
 584         inside1 mle []        = []
 585
 586
 587 rememberExpr :: String -> GHCi ()
 588 rememberExpr str
 589    = do let cleaned = (clean . reverse . clean . reverse) str
 590         let forget_me_not | null cleaned = Nothing
 591                           | otherwise    = Just cleaned
 592         setLastExpr forget_me_not
 593      where
 594         clean = dropWhile isSpace
 595
 596
 597 -----------------------------------------------------------------------------
 598 -- GHCi monad
 599
 600 data GHCiState = GHCiState
 601      {
 602         modules        :: [Module],
 603         current_module :: Module,
 604         target         :: Maybe FilePath,
 605         cmstate        :: CmState,
 606         options        :: [GHCiOption],
 607         last_expr      :: Maybe String
 608      }
 609
 610 data GHCiOption
 611         = ShowTiming            -- show time/allocs after evaluation
 612         | ShowType              -- show the type of expressions
 613         | RevertCAFs            -- revert CAFs after every evaluation
 614         deriving Eq
 615
 616 defaultCurrentModuleName = mkModuleName "Prelude"
 617 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
 618
 619 GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
 620 GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
 621
 622 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
 623
 624 instance Monad GHCi where
 625   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
 626   return a  = GHCi $ \s -> return (s,a)
 627
 628 getGHCiState   = GHCi $ \s -> return (s,s)
 629 setGHCiState s = GHCi $ \_ -> return (s,())
 630
 631 isOptionSet :: GHCiOption -> GHCi Bool
 632 isOptionSet opt
 633  = do st <- getGHCiState
 634       return (opt `elem` options st)
 635
 636 setOption :: GHCiOption -> GHCi ()
 637 setOption opt
 638  = do st <- getGHCiState
 639       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 640
 641 unsetOption :: GHCiOption -> GHCi ()
 642 unsetOption opt
 643  = do st <- getGHCiState
 644       setGHCiState (st{ options = filter (/= opt) (options st) })
 645
 646 getLastExpr :: GHCi (Maybe String)
 647 getLastExpr
 648  = do st <- getGHCiState ; return (last_expr st)
 649
 650 setLastExpr :: Maybe String -> GHCi ()
 651 setLastExpr last_expr
 652  = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
 653
 654 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 655
 656 -----------------------------------------------------------------------------
 657 -- recursive exception handlers
 658
 659 -- Don't forget to unblock async exceptions in the handler, or if we're
 660 -- in an exception loop (eg. let a = error a in a) the ^C exception
 661 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 662
 663 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 664 ghciHandle h (GHCi m) = GHCi $ \s ->
 665    Exception.catch (m s)
 666         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 667
 668 ghciUnblock :: GHCi a -> GHCi a
 669 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 670
 671 -----------------------------------------------------------------------------
 672 -- package loader
 673
 674 -- Left: full path name of a .o file, including trailing .o
 675 -- Right: "unadorned" name of a .DLL/.so
 676 --        e.g.    On unix     "qt"  denotes "libqt.so"
 677 --                On WinDoze  "burble"  denotes "burble.DLL"
 678 --        addDLL is platform-specific and adds the lib/.so/.DLL
 679 --        prefixes plaform-dependently; we don't do that here.
 680 type LibrarySpec
 681    = Either FilePath String
 682
 683 showLS (Left nm)  = "(static) " ++ nm
 684 showLS (Right nm) = "(dynamic) " ++ nm
 685
 686 linkPackages :: [LibrarySpec] -> [Package] -> IO ()
 687 linkPackages cmdline_lib_specs pkgs
 688    = do mapM_ linkPackage pkgs
 689         mapM_ preloadLib cmdline_lib_specs
 690      where
 691         preloadLib lib_spec
 692            = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
 693                 case lib_spec of
 694                    Left static_ish
 695                       -> do b <- doesFileExist static_ish
 696                             if    not b
 697                              then do putStr "not found.\n"
 698                                      croak
 699                              else do loadObj static_ish
 700                                      putStr "done.\n"
 701                    Right dll_unadorned
 702                       -> do maybe_errmsg <- addDLL dll_unadorned
 703                             if    maybe_errmsg == nullPtr
 704                              then putStr "done.\n"
 705                              else do str <- peekCString maybe_errmsg
 706                                      putStr ("failed (" ++ str ++ ")\n")
 707                                      croak
 708
 709         croak = throwDyn (OtherError "user specified .o/.so/.DLL could not be loaded.")
 710
 711
 712 linkPackage :: Package -> IO ()
 713 -- ignore rts and gmp for now (ToDo; better?)
 714 linkPackage pkg
 715    | name pkg `elem` ["rts", "gmp"]
 716    = return ()
 717    | otherwise
 718    = do putStr ("Loading package " ++ name pkg ++ " ... ")
 719         -- For each obj, try obj.o and if that fails, obj.so.
 720         -- Complication: all the .so's must be loaded before any of the .o's.
 721         let dirs      =  library_dirs pkg
 722         let objs      =  hs_libraries pkg ++ extra_libraries pkg
 723         classifieds   <- mapM (locateOneObj dirs) objs
 724         let sos_first = filter isRight classifieds
 725                         ++ filter (not.isRight) classifieds
 726         mapM loadClassified sos_first
 727         putStr "linking ... "
 728         resolveObjs
 729         putStrLn "done."
 730      where
 731         isRight (Right _) = True
 732         isRight (Left _)  = False
 733
 734 loadClassified :: LibrarySpec -> IO ()
 735 loadClassified (Left obj_absolute_filename)
 736    = do loadObj obj_absolute_filename
 737 loadClassified (Right dll_unadorned)
 738    = do maybe_errmsg <- addDLL dll_unadorned
 739         if    maybe_errmsg == nullPtr
 740          then return ()
 741          else do str <- peekCString maybe_errmsg
 742                  throwDyn (OtherError ("can't find .o or .so/.DLL for: "
 743                                        ++ dll_unadorned ++ " (" ++ str ++ ")" ))
 744
 745 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
 746 locateOneObj []     obj
 747    = return (Right obj) -- we assume
 748 locateOneObj (d:ds) obj
 749    = do let path = d ++ '/':obj ++ ".o"
 750         b <- doesFileExist path
 751         if b then return (Left path) else locateOneObj ds obj
 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