ghc/compiler/ghci/InteractiveUI.hs

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