ghc/compiler/ghci/InteractiveUI.hs

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