ghc/compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: InteractiveUI.hs,v 1.112 2002/01/28 13:34:10 simonmar Exp $
   4 --
   5 -- GHC Interactive User Interface
   6 --
   7 -- (c) The GHC Team 2000
   8 --
   9 -----------------------------------------------------------------------------
  10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
  11
  12 #include "../includes/config.h"
  13 #include "HsVersions.h"
  14
  15 import Packages
  16
  17 import CompManager
  18 import CmTypes          ( Linkable, isObjectLinkable, ModSummary(..) )
  19 import CmLink           ( findModuleLinkable_maybe )
  20
  21 import HscTypes         ( TyThing(..), showModMsg, InteractiveContext(..) )
  22 import HsSyn            ( TyClDecl(..), ConDecl(..), Sig(..) )
  23 import MkIface          ( ifaceTyThing )
  24 import DriverFlags
  25 import DriverState
  26 import DriverUtil       ( handle, remove_spaces )
  27 import Linker
  28 import Finder           ( flushPackageCache )
  29 import Util
  30 import Id               ( isRecordSelector, recordSelectorFieldLabel,
  31                           isDataConWrapId, isDataConId, idName )
  32 import Class            ( className )
  33 import TyCon            ( tyConName, tyConClass_maybe, isPrimTyCon )
  34 import FieldLabel       ( fieldLabelTyCon )
  35 import SrcLoc           ( isGoodSrcLoc )
  36 import Module           ( moduleName )
  37 import NameEnv          ( nameEnvElts )
  38 import Name             ( Name, isHomePackageName, nameSrcLoc, nameOccName,
  39                           NamedThing(..) )
  40 import OccName          ( isSymOcc )
  41 import BasicTypes       ( defaultFixity )
  42 import Outputable
  43 import CmdLineOpts      ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
  44                           restoreDynFlags, dopt_unset )
  45 import Panic            ( GhcException(..), showGhcException )
  46 import Config
  47
  48 #ifndef mingw32_TARGET_OS
  49 import Posix
  50 #endif
  51
  52 import Exception
  53 import Dynamic
  54 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
  55 import Readline
  56 #endif
  57 import Concurrent
  58 import IOExts
  59 import SystemExts
  60
  61 import Numeric
  62 import List
  63 import System
  64 import CPUTime
  65 import Directory
  66 import IO
  67 import Char
  68 import Monad
  69
  70 import PrelGHC          ( unsafeCoerce# )
  71 import Foreign          ( nullPtr )
  72 import CString          ( peekCString )
  73
  74 -----------------------------------------------------------------------------
  75
  76 ghciWelcomeMsg = "\
  77 \   ___         ___ _\n\
  78 \  / _ \\ /\\  /\\/ __(_)\n\
  79 \ / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
  80 \/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n\
  81 \\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
  82
  83 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
  84
  85 builtin_commands :: [(String, String -> GHCi Bool)]
  86 builtin_commands = [
  87   ("add",       keepGoing addModule),
  88   ("browse",    keepGoing browseCmd),
  89   ("cd",        keepGoing changeDirectory),
  90   ("def",       keepGoing defineMacro),
  91   ("help",      keepGoing help),
  92   ("?",         keepGoing help),
  93   ("info",      keepGoing info),
  94   ("load",      keepGoing loadModule),
  95   ("module",    keepGoing setContext),
  96   ("reload",    keepGoing reloadModule),
  97   ("set",       keepGoing setCmd),
  98   ("show",      keepGoing showCmd),
  99   ("type",      keepGoing typeOfExpr),
 100   ("unset",     keepGoing unsetOptions),
 101   ("undef",     keepGoing undefineMacro),
 102   ("quit",      quit)
 103   ]
 104
 105 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 106 keepGoing a str = a str >> return False
 107
 108 shortHelpText = "use :? for help.\n"
 109
 110 helpText = "\
 111 \ Commands available from the prompt:\n\
 112 \\
 113 \   <stmt>                 evaluate/run <stmt>\n\
 114 \   :add <filename> ...    add module(s) to the current target set\n\
 115 \   :browse [*]<module>    display the names defined by <module>\n\
 116 \   :cd <dir>              change directory to <dir>\n\
 117 \   :def <cmd> <expr>      define a command :<cmd>\n\
 118 \   :help, :?              display this list of commands\n\
 119 \   :info [<name> ...]     display information about the given names\n\
 120 \   :load <filename> ...   load module(s) and their dependents\n\
 121 \   :module <mod>          set the context for expression evaluation to <mod>\n\
 122 \   :reload                reload the current module set\n\
 123 \\n\
 124 \   :set <option> ...      set options\n\
 125 \   :set args <arg> ...    set the arguments returned by System.getArgs\n\
 126 \   :set prog <progname>   set the value returned by System.getProgName\n\
 127 \\n\
 128 \   :show modules          show the currently loaded modules\n\
 129 \   :show bindings         show the current bindings made at the prompt\n\
 130 \\n\
 131 \   :type <expr>           show the type of <expr>\n\
 132 \   :undef <cmd>           undefine user-defined command :<cmd>\n\
 133 \   :unset <option> ...    unset options\n\
 134 \   :quit                  exit GHCi\n\
 135 \   :!<command>            run the shell command <command>\n\
 136 \\
 137 \ Options for `:set' and `:unset':\n\
 138 \\
 139 \    +r                 revert top-level expressions after each evaluation\n\
 140 \    +s                 print timing/memory stats after each evaluation\n\
 141 \    +t                 print type after evaluation\n\
 142 \    -<flags>           most GHC command line flags can also be set here\n\
 143 \                         (eg. -v2, -fglasgow-exts, etc.)\n\
 144 \"
 145
 146 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
 147 interactiveUI cmstate paths cmdline_libs = do
 148    hFlush stdout
 149    hSetBuffering stdout NoBuffering
 150
 151    dflags <- getDynFlags
 152
 153    -- link in the available packages
 154    pkgs <- getPackageInfo
 155    initLinker
 156    linkPackages dflags cmdline_libs pkgs
 157
 158    (cmstate, maybe_hval)
 159         <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
 160    case maybe_hval of
 161         Just hval -> unsafeCoerce# hval :: IO ()
 162         _ -> panic "interactiveUI:buffering"
 163
 164    (cmstate, maybe_hval)
 165         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
 166    case maybe_hval of
 167         Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
 168         _ -> panic "interactiveUI:stderr"
 169
 170    (cmstate, maybe_hval)
 171         <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
 172    case maybe_hval of
 173         Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
 174         _ -> panic "interactiveUI:stdout"
 175
 176         -- We don't want the cmd line to buffer any input that might be
 177         -- intended for the program, so unbuffer stdin.
 178    hSetBuffering stdin  NoBuffering
 179
 180         -- initial context is just the Prelude
 181    cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
 182
 183 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 184    Readline.initialize
 185 #endif
 186
 187    startGHCi (runGHCi paths dflags)
 188         GHCiState{ progname = "<interactive>",
 189                    args = [],
 190                    targets = paths,
 191                    cmstate = cmstate,
 192                    options = [] }
 193
 194 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 195    Readline.resetTerminal Nothing
 196 #endif
 197
 198    return ()
 199
 200
 201 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
 202 runGHCi paths dflags = do
 203   read_dot_files <- io (readIORef v_Read_DotGHCi)
 204
 205   when (read_dot_files) $ do
 206     -- Read in ./.ghci.
 207     let file = "./.ghci"
 208     exists <- io (doesFileExist file)
 209     when exists $ do
 210        dir_ok  <- io (checkPerms ".")
 211        file_ok <- io (checkPerms file)
 212        when (dir_ok && file_ok) $ do
 213           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 214           case either_hdl of
 215              Left e    -> return ()
 216              Right hdl -> fileLoop hdl False
 217
 218   when (read_dot_files) $ do
 219     -- Read in $HOME/.ghci
 220     either_dir <- io (IO.try (getEnv "HOME"))
 221     case either_dir of
 222        Left e -> return ()
 223        Right dir -> do
 224           cwd <- io (getCurrentDirectory)
 225           when (dir /= cwd) $ do
 226              let file = dir ++ "/.ghci"
 227              ok <- io (checkPerms file)
 228              when ok $ do
 229                either_hdl <- io (IO.try (openFile file ReadMode))
 230                case either_hdl of
 231                   Left e    -> return ()
 232                   Right hdl -> fileLoop hdl False
 233
 234   -- perform a :load for files given on the GHCi command line
 235   when (not (null paths)) $
 236      ghciHandle showException $
 237         loadModule (unwords paths)
 238
 239   -- enter the interactive loop
 240   is_tty <- io (hIsTerminalDevice stdin)
 241   interactiveLoop is_tty
 242
 243   -- and finally, exit
 244   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 245
 246
 247 interactiveLoop is_tty = do
 248   -- ignore ^C exceptions caught here
 249   ghciHandleDyn (\e -> case e of
 250                         Interrupted -> ghciUnblock (interactiveLoop is_tty)
 251                         _other      -> return ()) $ do
 252
 253   -- read commands from stdin
 254 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 255   if (is_tty)
 256         then readlineLoop
 257         else fileLoop stdin False  -- turn off prompt for non-TTY input
 258 #else
 259   fileLoop stdin True
 260 #endif
 261
 262
 263 -- NOTE: We only read .ghci files if they are owned by the current user,
 264 -- and aren't world writable.  Otherwise, we could be accidentally
 265 -- running code planted by a malicious third party.
 266
 267 -- Furthermore, We only read ./.ghci if . is owned by the current user
 268 -- and isn't writable by anyone else.  I think this is sufficient: we
 269 -- don't need to check .. and ../.. etc. because "."  always refers to
 270 -- the same directory while a process is running.
 271
 272 checkPerms :: String -> IO Bool
 273 checkPerms name =
 274   handle (\_ -> return False) $ do
 275 #ifdef mingw32_TARGET_OS
 276      doesFileExist name
 277 #else
 278      st <- getFileStatus name
 279      me <- getRealUserID
 280      if fileOwner st /= me then do
 281         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 282         return False
 283       else do
 284         let mode =  fileMode st
 285         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 286            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 287            then do
 288                putStrLn $ "*** WARNING: " ++ name ++
 289                           " is writable by someone else, IGNORING!"
 290                return False
 291           else return True
 292 #endif
 293
 294 fileLoop :: Handle -> Bool -> GHCi ()
 295 fileLoop hdl prompt = do
 296    cmstate <- getCmState
 297    (mod,imports) <- io (cmGetContext cmstate)
 298    when prompt (io (putStr (mkPrompt mod imports)))
 299    l <- io (IO.try (hGetLine hdl))
 300    case l of
 301         Left e | isEOFError e -> return ()
 302                | otherwise    -> throw e
 303         Right l ->
 304           case remove_spaces l of
 305             "" -> fileLoop hdl prompt
 306             l  -> do quit <- runCommand l
 307                      if quit then return () else fileLoop hdl prompt
 308
 309 stringLoop :: [String] -> GHCi ()
 310 stringLoop [] = return ()
 311 stringLoop (s:ss) = do
 312    case remove_spaces s of
 313         "" -> stringLoop ss
 314         l  -> do quit <- runCommand l
 315                  if quit then return () else stringLoop ss
 316
 317 mkPrompt toplevs exports
 318    = concat (intersperse " " (toplevs ++ map ('*':) exports)) ++ "> "
 319
 320 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 321 readlineLoop :: GHCi ()
 322 readlineLoop = do
 323    cmstate <- getCmState
 324    (mod,imports) <- io (cmGetContext cmstate)
 325    io yield
 326    l <- io (readline (mkPrompt mod imports))
 327    case l of
 328         Nothing -> return ()
 329         Just l  ->
 330           case remove_spaces l of
 331             "" -> readlineLoop
 332             l  -> do
 333                   io (addHistory l)
 334                   quit <- runCommand l
 335                   if quit then return () else readlineLoop
 336 #endif
 337
 338 -- Top level exception handler, just prints out the exception
 339 -- and carries on.
 340 runCommand :: String -> GHCi Bool
 341 runCommand c =
 342   ghciHandle ( \exception -> do
 343                 flushEverything
 344                 showException exception
 345                 return False
 346              ) $
 347   doCommand c
 348
 349 showException (DynException dyn) =
 350   case fromDynamic dyn of
 351     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
 352     Just Interrupted      -> io (putStrLn "Interrupted.")
 353     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
 354     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
 355     Just other_ghc_ex     -> io (print other_ghc_ex)
 356
 357 showException other_exception
 358   = io (putStrLn ("*** Exception: " ++ show other_exception))
 359
 360 doCommand (':' : command) = specialCommand command
 361 doCommand stmt
 362    = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 363         return False
 364
 365 runStmt :: String -> GHCi [Name]
 366 runStmt stmt
 367  | null (filter (not.isSpace) stmt) = return []
 368  | otherwise
 369  = do st <- getGHCiState
 370       dflags <- io getDynFlags
 371       let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
 372       (new_cmstate, result) <-
 373         io $ withProgName (progname st) $ withArgs (args st) $
 374         cmRunStmt (cmstate st) dflags' stmt
 375       setGHCiState st{cmstate = new_cmstate}
 376       case result of
 377         CmRunFailed      -> return []
 378         CmRunException e -> showException e >> return []
 379         CmRunOk names    -> return names
 380
 381 -- possibly print the type and revert CAFs after evaluating an expression
 382 finishEvalExpr names
 383  = do b <- isOptionSet ShowType
 384       cmstate <- getCmState
 385       when b (mapM_ (showTypeOfName cmstate) names)
 386
 387       b <- isOptionSet RevertCAFs
 388       io (when b revertCAFs)
 389       flushEverything
 390       return True
 391
 392 showTypeOfName :: CmState -> Name -> GHCi ()
 393 showTypeOfName cmstate n
 394    = do maybe_str <- io (cmTypeOfName cmstate n)
 395         case maybe_str of
 396           Nothing  -> return ()
 397           Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
 398
 399 flushEverything :: GHCi ()
 400 flushEverything
 401    = io $ do Monad.join (readIORef flush_stdout)
 402              Monad.join (readIORef flush_stderr)
 403              return ()
 404
 405 specialCommand :: String -> GHCi Bool
 406 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 407 specialCommand str = do
 408   let (cmd,rest) = break isSpace str
 409   cmds <- io (readIORef commands)
 410   case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
 411      []      -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
 412                                     ++ shortHelpText) >> return False)
 413      [(_,f)] -> f (dropWhile isSpace rest)
 414      cs      -> io (hPutStrLn stdout ("prefix " ++ cmd ++
 415                                       " matches multiple commands (" ++
 416                                        foldr1 (\a b -> a ++ ',':b) (map fst cs)
 417                                          ++ ")") >> return False)
 418
 419 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
 420
 421 -----------------------------------------------------------------------------
 422 -- Commands
 423
 424 help :: String -> GHCi ()
 425 help _ = io (putStr helpText)
 426
 427 info :: String -> GHCi ()
 428 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
 429 info s = do
 430   let names = words s
 431   init_cms <- getCmState
 432   dflags <- io getDynFlags
 433   let
 434     infoThings cms [] = return cms
 435     infoThings cms (name:names) = do
 436       (cms, stuff) <- io (cmInfoThing cms dflags name)
 437       io (putStrLn (showSDocForUser unqual (
 438             vcat (intersperse (text "") (map showThing stuff))))
 439          )
 440       infoThings cms names
 441
 442     unqual = cmGetPrintUnqual init_cms
 443
 444     showThing (ty_thing, fixity)
 445         = vcat [ text "-- " <> showTyThing ty_thing,
 446                  showFixity fixity (getName ty_thing),
 447                  ppr (ifaceTyThing ty_thing) ]
 448
 449     showFixity fix name
 450         | fix == defaultFixity = empty
 451         | otherwise            = ppr fix <+>
 452                                  (if isSymOcc (nameOccName name)
 453                                         then ppr name
 454                                         else char '`' <> ppr name <> char '`')
 455
 456     showTyThing (AClass cl)
 457        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
 458     showTyThing (ATyCon ty)
 459        | isPrimTyCon ty
 460        = hcat [ppr ty, text " is a primitive type constructor"]
 461        | otherwise
 462        = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
 463     showTyThing (AnId   id)
 464        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 465
 466     idDescr id
 467        | isRecordSelector id =
 468                 case tyConClass_maybe (fieldLabelTyCon (
 469                                 recordSelectorFieldLabel id)) of
 470                         Nothing -> text "record selector"
 471                         Just c  -> text "method in class " <> ppr c
 472        | isDataConWrapId id  = text "data constructor"
 473        | otherwise           = text "variable"
 474
 475         -- also print out the source location for home things
 476     showSrcLoc name
 477         | isHomePackageName name && isGoodSrcLoc loc
 478         = hsep [ text ", defined at", ppr loc ]
 479         | otherwise
 480         = empty
 481         where loc = nameSrcLoc name
 482
 483   cms <- infoThings init_cms names
 484   setCmState cms
 485   return ()
 486
 487 addModule :: String -> GHCi ()
 488 addModule str = do
 489   let files = words str
 490   state <- getGHCiState
 491   dflags <- io (getDynFlags)
 492   io (revertCAFs)                       -- always revert CAFs on load/add.
 493   let new_targets = files ++ targets state
 494   graph <- io (cmDepAnal (cmstate state) dflags new_targets)
 495   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
 496   setGHCiState state{ cmstate = cmstate1, targets = new_targets }
 497   setContextAfterLoad mods
 498   modulesLoadedMsg ok mods dflags
 499
 500 changeDirectory :: String -> GHCi ()
 501 changeDirectory ('~':d) = do
 502    tilde <- io (getEnv "HOME")  -- will fail if HOME not defined
 503    io (setCurrentDirectory (tilde ++ '/':d))
 504 changeDirectory d = io (setCurrentDirectory d)
 505
 506 defineMacro :: String -> GHCi ()
 507 defineMacro s = do
 508   let (macro_name, definition) = break isSpace s
 509   cmds <- io (readIORef commands)
 510   if (null macro_name)
 511         then throwDyn (CmdLineError "invalid macro name")
 512         else do
 513   if (macro_name `elem` map fst cmds)
 514         then throwDyn (CmdLineError
 515                 ("command `" ++ macro_name ++ "' is already defined"))
 516         else do
 517
 518   -- give the expression a type signature, so we can be sure we're getting
 519   -- something of the right type.
 520   let new_expr = '(' : definition ++ ") :: String -> IO String"
 521
 522   -- compile the expression
 523   cms <- getCmState
 524   dflags <- io getDynFlags
 525   (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
 526   setCmState new_cmstate
 527   case maybe_hv of
 528      Nothing -> return ()
 529      Just hv -> io (writeIORef commands --
 530                     ((macro_name, keepGoing (runMacro hv)) : cmds))
 531
 532 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
 533 runMacro fun s = do
 534   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 535   stringLoop (lines str)
 536
 537 undefineMacro :: String -> GHCi ()
 538 undefineMacro macro_name = do
 539   cmds <- io (readIORef commands)
 540   if (macro_name `elem` map fst builtin_commands)
 541         then throwDyn (CmdLineError
 542                 ("command `" ++ macro_name ++ "' cannot be undefined"))
 543         else do
 544   if (macro_name `notElem` map fst cmds)
 545         then throwDyn (CmdLineError
 546                 ("command `" ++ macro_name ++ "' not defined"))
 547         else do
 548   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 549
 550
 551 loadModule :: String -> GHCi ()
 552 loadModule str = timeIt (loadModule' str)
 553
 554 loadModule' str = do
 555   let files = words str
 556   state <- getGHCiState
 557   dflags <- io getDynFlags
 558
 559   -- do the dependency anal first, so that if it fails we don't throw
 560   -- away the current set of modules.
 561   graph <- io (cmDepAnal (cmstate state) dflags files)
 562
 563   -- Dependency anal ok, now unload everything
 564   cmstate1 <- io (cmUnload (cmstate state) dflags)
 565   setGHCiState state{ cmstate = cmstate1, targets = [] }
 566
 567   io (revertCAFs)  -- always revert CAFs on load.
 568   (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
 569   setGHCiState state{ cmstate = cmstate2, targets = files }
 570
 571   setContextAfterLoad mods
 572   modulesLoadedMsg ok mods dflags
 573
 574
 575 reloadModule :: String -> GHCi ()
 576 reloadModule "" = do
 577   state <- getGHCiState
 578   dflags <- io getDynFlags
 579   case targets state of
 580    [] -> io (putStr "no current target\n")
 581    paths -> do
 582         -- do the dependency anal first, so that if it fails we don't throw
 583         -- away the current set of modules.
 584         graph <- io (cmDepAnal (cmstate state) dflags paths)
 585
 586         io (revertCAFs)         -- always revert CAFs on reload.
 587         (cmstate1, ok, mods)
 588                 <- io (cmLoadModules (cmstate state) dflags graph)
 589         setGHCiState state{ cmstate=cmstate1 }
 590         setContextAfterLoad mods
 591         modulesLoadedMsg ok mods dflags
 592
 593 reloadModule _ = noArgs ":reload"
 594
 595 setContextAfterLoad [] = setContext prel
 596 setContextAfterLoad (m:_) = do
 597   cmstate <- getCmState
 598   b <- io (cmModuleIsInterpreted cmstate m)
 599   if b then setContext m else setContext ('*':m)
 600
 601 modulesLoadedMsg ok mods dflags =
 602   when (verbosity dflags > 0) $ do
 603    let mod_commas
 604         | null mods = text "none."
 605         | otherwise = hsep (
 606             punctuate comma (map text mods)) <> text "."
 607    case ok of
 608     False ->
 609        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 610     True  ->
 611        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 612
 613
 614 typeOfExpr :: String -> GHCi ()
 615 typeOfExpr str
 616   = do cms <- getCmState
 617        dflags <- io getDynFlags
 618        (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
 619        setCmState new_cmstate
 620        case maybe_tystr of
 621           Nothing    -> return ()
 622           Just tystr -> io (putStrLn tystr)
 623
 624 quit :: String -> GHCi Bool
 625 quit _ = return True
 626
 627 shellEscape :: String -> GHCi Bool
 628 shellEscape str = io (system str >> return False)
 629
 630 -----------------------------------------------------------------------------
 631 -- Browing a module's contents
 632
 633 browseCmd :: String -> GHCi ()
 634 browseCmd m =
 635   case words m of
 636     ['*':m] | looksLikeModuleName m -> browseModule m True
 637     [m]     | looksLikeModuleName m -> browseModule m False
 638     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 639
 640 browseModule m exports_only = do
 641   cms <- getCmState
 642   dflags <- io getDynFlags
 643
 644   is_interpreted <- io (cmModuleIsInterpreted cms m)
 645   when (not is_interpreted && not exports_only) $
 646         throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 647
 648   -- temporarily set the context to the module we're interested in,
 649   -- just so we can get an appropriate PrintUnqualified
 650   (as,bs) <- io (cmGetContext cms)
 651   cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
 652                               else cmSetContext cms dflags [m] [])
 653   cms2 <- io (cmSetContext cms1 dflags as bs)
 654
 655   (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
 656
 657   setCmState cms3
 658
 659   let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
 660
 661       things' = filter wantToSee things
 662
 663       wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
 664       wantToSee _ = True
 665
 666       thing_names = map getName things
 667
 668       thingDecl thing@(AnId id)  = ifaceTyThing thing
 669
 670       thingDecl thing@(AClass c) =
 671         let rn_decl = ifaceTyThing thing in
 672         case rn_decl of
 673           ClassDecl { tcdSigs = cons } ->
 674                 rn_decl{ tcdSigs = filter methodIsVisible cons }
 675           other -> other
 676         where
 677            methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
 678
 679       thingDecl thing@(ATyCon t) =
 680         let rn_decl = ifaceTyThing thing in
 681         case rn_decl of
 682           TyData { tcdCons = cons } ->
 683                 rn_decl{ tcdCons = filter conIsVisible cons }
 684           other -> other
 685         where
 686           conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
 687
 688   io (putStrLn (showSDocForUser unqual (
 689          vcat (map (ppr . thingDecl) things')))
 690    )
 691
 692   where
 693
 694 -----------------------------------------------------------------------------
 695 -- Setting the module context
 696
 697 setContext str
 698   | all sensible mods = fn mods
 699   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
 700   where
 701     (fn, mods) = case str of
 702                         '+':stuff -> (addToContext,      words stuff)
 703                         '-':stuff -> (removeFromContext, words stuff)
 704                         stuff     -> (newContext,        words stuff)
 705
 706     sensible ('*':m) = looksLikeModuleName m
 707     sensible m       = looksLikeModuleName m
 708
 709 newContext mods = do
 710   cms <- getCmState
 711   dflags <- io getDynFlags
 712   (as,bs) <- separate cms mods [] []
 713   let bs' = if null as && prel `notElem` bs then prel:bs else bs
 714   cms' <- io (cmSetContext cms dflags as bs')
 715   setCmState cms'
 716
 717 separate cmstate []           as bs = return (as,bs)
 718 separate cmstate (('*':m):ms) as bs = separate cmstate ms as (m:bs)
 719 separate cmstate (m:ms)       as bs = do
 720    b <- io (cmModuleIsInterpreted cmstate m)
 721    if b then separate cmstate ms (m:as) bs
 722         else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
 723
 724 prel = "Prelude"
 725
 726
 727 addToContext mods = do
 728   cms <- getCmState
 729   dflags <- io getDynFlags
 730   (as,bs) <- io (cmGetContext cms)
 731
 732   (as',bs') <- separate cms mods [] []
 733
 734   let as_to_add = as' \\ (as ++ bs)
 735       bs_to_add = bs' \\ (as ++ bs)
 736
 737   cms' <- io (cmSetContext cms dflags
 738                         (as ++ as_to_add) (bs ++ bs_to_add))
 739   setCmState cms'
 740
 741
 742 removeFromContext mods = do
 743   cms <- getCmState
 744   dflags <- io getDynFlags
 745   (as,bs) <- io (cmGetContext cms)
 746
 747   (as_to_remove,bs_to_remove) <- separate cms mods [] []
 748
 749   let as' = as \\ (as_to_remove ++ bs_to_remove)
 750       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 751
 752   cms' <- io (cmSetContext cms dflags as' bs')
 753   setCmState cms'
 754
 755 ----------------------------------------------------------------------------
 756 -- Code for `:set'
 757
 758 -- set options in the interpreter.  Syntax is exactly the same as the
 759 -- ghc command line, except that certain options aren't available (-C,
 760 -- -E etc.)
 761 --
 762 -- This is pretty fragile: most options won't work as expected.  ToDo:
 763 -- figure out which ones & disallow them.
 764
 765 setCmd :: String -> GHCi ()
 766 setCmd ""
 767   = do st <- getGHCiState
 768        let opts = options st
 769        io $ putStrLn (showSDoc (
 770               text "options currently set: " <>
 771               if null opts
 772                    then text "none."
 773                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
 774            ))
 775 setCmd str
 776   = case words str of
 777         ("args":args) -> setArgs args
 778         ("prog":prog) -> setProg prog
 779         wds -> setOptions wds
 780
 781 setArgs args = do
 782   st <- getGHCiState
 783   setGHCiState st{ args = args }
 784
 785 setProg [prog] = do
 786   st <- getGHCiState
 787   setGHCiState st{ progname = prog }
 788 setProg _ = do
 789   io (hPutStrLn stderr "syntax: :set prog <progname>")
 790
 791 setOptions wds =
 792    do -- first, deal with the GHCi opts (+s, +t, etc.)
 793       let (plus_opts, minus_opts)  = partition isPlus wds
 794       mapM setOpt plus_opts
 795
 796       -- now, the GHC flags
 797       pkgs_before <- io (readIORef v_Packages)
 798       leftovers   <- io (processArgs static_flags minus_opts [])
 799       pkgs_after  <- io (readIORef v_Packages)
 800
 801       -- update things if the users wants more packages
 802       when (pkgs_before /= pkgs_after) $
 803          newPackages (pkgs_after \\ pkgs_before)
 804
 805       -- then, dynamic flags
 806       io $ do
 807         restoreDynFlags
 808         leftovers <- processArgs dynamic_flags leftovers []
 809         saveDynFlags
 810
 811         if (not (null leftovers))
 812                 then throwDyn (CmdLineError ("unrecognised flags: " ++
 813                                                 unwords leftovers))
 814                 else return ()
 815
 816
 817 unsetOptions :: String -> GHCi ()
 818 unsetOptions str
 819   = do -- first, deal with the GHCi opts (+s, +t, etc.)
 820        let opts = words str
 821            (minus_opts, rest1) = partition isMinus opts
 822            (plus_opts, rest2)  = partition isPlus rest1
 823
 824        if (not (null rest2))
 825           then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
 826           else do
 827
 828        mapM unsetOpt plus_opts
 829
 830        -- can't do GHC flags for now
 831        if (not (null minus_opts))
 832           then throwDyn (CmdLineError "can't unset GHC command-line flags")
 833           else return ()
 834
 835 isMinus ('-':s) = True
 836 isMinus _ = False
 837
 838 isPlus ('+':s) = True
 839 isPlus _ = False
 840
 841 setOpt ('+':str)
 842   = case strToGHCiOpt str of
 843         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 844         Just o  -> setOption o
 845
 846 unsetOpt ('+':str)
 847   = case strToGHCiOpt str of
 848         Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
 849         Just o  -> unsetOption o
 850
 851 strToGHCiOpt :: String -> (Maybe GHCiOption)
 852 strToGHCiOpt "s" = Just ShowTiming
 853 strToGHCiOpt "t" = Just ShowType
 854 strToGHCiOpt "r" = Just RevertCAFs
 855 strToGHCiOpt _   = Nothing
 856
 857 optToStr :: GHCiOption -> String
 858 optToStr ShowTiming = "s"
 859 optToStr ShowType   = "t"
 860 optToStr RevertCAFs = "r"
 861
 862 newPackages new_pkgs = do
 863   state <- getGHCiState
 864   dflags <- io getDynFlags
 865   cmstate1 <- io (cmUnload (cmstate state) dflags)
 866   setGHCiState state{ cmstate = cmstate1, targets = [] }
 867
 868   io $ do
 869     pkgs <- getPackageInfo
 870     flushPackageCache pkgs
 871
 872     new_pkg_info <- getPackageDetails new_pkgs
 873     mapM_ (linkPackage dflags) (reverse new_pkg_info)
 874
 875 -----------------------------------------------------------------------------
 876 -- code for `:show'
 877
 878 showCmd str =
 879   case words str of
 880         ["modules" ] -> showModules
 881         ["bindings"] -> showBindings
 882         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 883
 884 showModules = do
 885   cms <- getCmState
 886   let mg = cmGetModuleGraph cms
 887       ls = cmGetLinkables   cms
 888       maybe_linkables = map (findModuleLinkable_maybe ls)
 889                                 (map (moduleName.ms_mod) mg)
 890   zipWithM showModule mg maybe_linkables
 891   return ()
 892
 893 showModule :: ModSummary -> Maybe Linkable -> GHCi ()
 894 showModule m (Just l) = do
 895   io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
 896 showModule _ Nothing = panic "missing linkable"
 897
 898 showBindings = do
 899   cms <- getCmState
 900   let
 901         unqual = cmGetPrintUnqual cms
 902         showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
 903
 904   io (mapM showBinding (cmGetBindings cms))
 905   return ()
 906
 907 -----------------------------------------------------------------------------
 908 -- GHCi monad
 909
 910 data GHCiState = GHCiState
 911      {
 912         progname       :: String,
 913         args           :: [String],
 914         targets        :: [FilePath],
 915         cmstate        :: CmState,
 916         options        :: [GHCiOption]
 917      }
 918
 919 data GHCiOption
 920         = ShowTiming            -- show time/allocs after evaluation
 921         | ShowType              -- show the type of expressions
 922         | RevertCAFs            -- revert CAFs after every evaluation
 923         deriving Eq
 924
 925 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
 926 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
 927
 928 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 929
 930 startGHCi :: GHCi a -> GHCiState -> IO a
 931 startGHCi g state = do ref <- newIORef state; unGHCi g ref
 932
 933 instance Monad GHCi where
 934   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 935   return a  = GHCi $ \s -> return a
 936
 937 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 938 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
 939    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 940
 941 getGHCiState   = GHCi $ \r -> readIORef r
 942 setGHCiState s = GHCi $ \r -> writeIORef r s
 943
 944 -- for convenience...
 945 getCmState = getGHCiState >>= return . cmstate
 946 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
 947
 948 isOptionSet :: GHCiOption -> GHCi Bool
 949 isOptionSet opt
 950  = do st <- getGHCiState
 951       return (opt `elem` options st)
 952
 953 setOption :: GHCiOption -> GHCi ()
 954 setOption opt
 955  = do st <- getGHCiState
 956       setGHCiState (st{ options = opt : filter (/= opt) (options st) })
 957
 958 unsetOption :: GHCiOption -> GHCi ()
 959 unsetOption opt
 960  = do st <- getGHCiState
 961       setGHCiState (st{ options = filter (/= opt) (options st) })
 962
 963 io :: IO a -> GHCi a
 964 io m = GHCi { unGHCi = \s -> m >>= return }
 965
 966 -----------------------------------------------------------------------------
 967 -- recursive exception handlers
 968
 969 -- Don't forget to unblock async exceptions in the handler, or if we're
 970 -- in an exception loop (eg. let a = error a in a) the ^C exception
 971 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 972
 973 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
 974 ghciHandle h (GHCi m) = GHCi $ \s ->
 975    Exception.catch (m s)
 976         (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 977
 978 ghciUnblock :: GHCi a -> GHCi a
 979 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 980
 981 -----------------------------------------------------------------------------
 982 -- package loader
 983
 984 -- Left: full path name of a .o file, including trailing .o
 985 -- Right: "unadorned" name of a .DLL/.so
 986 --        e.g.    On unix     "qt"  denotes "libqt.so"
 987 --                On WinDoze  "burble"  denotes "burble.DLL"
 988 --        addDLL is platform-specific and adds the lib/.so/.DLL
 989 --        suffixes platform-dependently; we don't do that here.
 990 --
 991 -- For dynamic objects only, try to find the object file in all the
 992 -- directories specified in v_Library_Paths before giving up.
 993
 994 type LibrarySpec
 995    = Either FilePath String
 996
 997 showLS (Left nm)  = "(static) " ++ nm
 998 showLS (Right nm) = "(dynamic) " ++ nm
 999
1000 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1001 linkPackages dflags cmdline_lib_specs pkgs
1002    = do mapM_ (linkPackage dflags) (reverse pkgs)
1003         lib_paths <- readIORef v_Library_paths
1004         mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1005         if (null cmdline_lib_specs)
1006            then return ()
1007            else do maybePutStr dflags "final link ... "
1008                    ok <- resolveObjs
1009                    if ok then maybePutStrLn dflags "done."
1010                          else throwDyn (InstallationError
1011                                           "linking extra libraries/objects failed")
1012      where
1013         preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1014         preloadLib dflags lib_paths lib_spec
1015            = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1016                 case lib_spec of
1017                    Left static_ish
1018                       -> do b <- preload_static lib_paths static_ish
1019                             maybePutStrLn dflags (if b  then "done."
1020                                                         else "not found")
1021                    Right dll_unadorned
1022                       -> -- We add "" to the set of paths to try, so that
1023                          -- if none of the real paths match, we force addDLL
1024                          -- to look in the default dynamic-link search paths.
1025                          do maybe_errstr <- preload_dynamic (lib_paths++[""])
1026                                                             dll_unadorned
1027                             case maybe_errstr of
1028                                Nothing -> return ()
1029                                Just mm -> preloadFailed mm lib_paths lib_spec
1030                             maybePutStrLn dflags "done"
1031
1032         preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1033         preloadFailed sys_errmsg paths spec
1034            = do maybePutStr dflags
1035                        ("failed.\nDynamic linker error message was:\n   "
1036                         ++ sys_errmsg  ++ "\nWhilst trying to load:  "
1037                         ++ showLS spec ++ "\nDirectories to search are:\n"
1038                         ++ unlines (map ("   "++) paths) )
1039                 give_up
1040
1041         -- not interested in the paths in the static case.
1042         preload_static paths name
1043            = do b <- doesFileExist name
1044                 if not b then return False
1045                          else loadObj name >> return True
1046
1047         -- return Nothing == success, else Just error message from addDLL
1048         preload_dynamic [] name
1049            = return Nothing
1050         preload_dynamic (path:paths) rootname
1051            = do -- addDLL returns NULL on success
1052                 maybe_errmsg <- addDLL path rootname
1053                 if    maybe_errmsg == nullPtr
1054                  then preload_dynamic paths rootname
1055                  else do str <- peekCString maybe_errmsg
1056                          return (Just str)
1057
1058         give_up
1059            = (throwDyn . CmdLineError)
1060                 "user specified .o/.so/.DLL could not be loaded."
1061
1062 -- Packages that don't need loading, because the compiler shares them with
1063 -- the interpreted program.
1064 dont_load_these = [ "gmp", "rts" ]
1065
1066 -- Packages that are already linked into GHCi.  For mingw32, we only
1067 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1068 -- library which std depends on.
1069 loaded_in_ghci
1070 #          ifndef mingw32_TARGET_OS
1071            = [ "std", "concurrent", "posix", "text", "util" ]
1072 #          else
1073            = [ ]
1074 #          endif
1075
1076 linkPackage :: DynFlags -> PackageConfig -> IO ()
1077 linkPackage dflags pkg
1078    | name pkg `elem` dont_load_these = return ()
1079    | otherwise
1080    = do
1081         -- For each obj, try obj.o and if that fails, obj.so.
1082         -- Complication: all the .so's must be loaded before any of the .o's.
1083         let dirs      =  library_dirs pkg
1084         let objs      =  hs_libraries pkg ++ extra_libraries pkg
1085         classifieds   <- mapM (locateOneObj dirs) objs
1086
1087         -- Don't load the .so libs if this is a package GHCi is already
1088         -- linked against, because we'll already have the .so linked in.
1089         let (so_libs, obj_libs) = partition isRight classifieds
1090         let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
1091                       | otherwise                      = so_libs ++ obj_libs
1092
1093         maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1094         mapM loadClassified sos_first
1095         maybePutStr dflags "linking ... "
1096         ok <- resolveObjs
1097         if ok then maybePutStrLn dflags "done."
1098               else panic ("can't load package `" ++ name pkg ++ "'")
1099      where
1100         isRight (Right _) = True
1101         isRight (Left _)  = False
1102
1103 loadClassified :: LibrarySpec -> IO ()
1104 loadClassified (Left obj_absolute_filename)
1105    = do loadObj obj_absolute_filename
1106 loadClassified (Right dll_unadorned)
1107    = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
1108         if    maybe_errmsg == nullPtr
1109          then return ()
1110          else do str <- peekCString maybe_errmsg
1111                  throwDyn (CmdLineError ("can't load .so/.DLL for: "
1112                                        ++ dll_unadorned ++ " (" ++ str ++ ")" ))
1113
1114 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1115 locateOneObj []     obj
1116    = return (Right obj) -- we assume
1117 locateOneObj (d:ds) obj
1118    = do let path = d ++ '/':obj ++ ".o"
1119         b <- doesFileExist path
1120         if b then return (Left path) else locateOneObj ds obj
1121
1122 -----------------------------------------------------------------------------
1123 -- timing & statistics
1124
1125 timeIt :: GHCi a -> GHCi a
1126 timeIt action
1127   = do b <- isOptionSet ShowTiming
1128        if not b
1129           then action
1130           else do allocs1 <- io $ getAllocations
1131                   time1   <- io $ getCPUTime
1132                   a <- action
1133                   allocs2 <- io $ getAllocations
1134                   time2   <- io $ getCPUTime
1135                   io $ printTimes (allocs2 - allocs1) (time2 - time1)
1136                   return a
1137
1138 foreign import "getAllocations" getAllocations :: IO Int
1139
1140 printTimes :: Int -> Integer -> IO ()
1141 printTimes allocs psecs
1142    = do let secs = (fromIntegral psecs / (10^12)) :: Float
1143             secs_str = showFFloat (Just 2) secs
1144         putStrLn (showSDoc (
1145                  parens (text (secs_str "") <+> text "secs" <> comma <+>
1146                          int allocs <+> text "bytes")))
1147
1148 -----------------------------------------------------------------------------
1149 -- utils
1150
1151 looksLikeModuleName [] = False
1152 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1153
1154 isAlphaNumEx c = isAlphaNum c || c == '_'
1155
1156 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1157                      | otherwise            = return ()
1158
1159 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1160                        | otherwise            = return ()
1161
1162 -----------------------------------------------------------------------------
1163 -- reverting CAFs
1164
1165 foreign import revertCAFs :: IO ()      -- make it "safe", just in case