ghc/compiler/ghci/InteractiveUI.hs

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