compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2005-2006
   7 --
   8 -----------------------------------------------------------------------------
   9 module InteractiveUI (
  10         interactiveUI,
  11         ghciWelcomeMsg
  12    ) where
  13
  14 #include "HsVersions.h"
  15
  16 import GhciMonad
  17
  18 -- The GHC interface
  19 import qualified GHC
  20 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
  21                           Type, Module, ModuleName, TyThing(..), Phase,
  22                           BreakIndex )
  23 import Debugger
  24 import DynFlags
  25 import Packages
  26 import PackageConfig
  27 import UniqFM
  28 import PprTyThing
  29 import Outputable       hiding (printForUser)
  30 import Module           -- for ModuleEnv
  31
  32 -- for createtags
  33 import Name
  34 import OccName
  35 import SrcLoc
  36
  37 -- Other random utilities
  38 import Digraph
  39 import BasicTypes hiding (isTopLevel)
  40 import Panic      hiding (showException)
  41 import Config
  42 import StaticFlags
  43 import Linker
  44 import Util
  45
  46 #ifndef mingw32_HOST_OS
  47 import System.Posix
  48 #if __GLASGOW_HASKELL__ > 504
  49         hiding (getEnv)
  50 #endif
  51 #else
  52 import GHC.ConsoleHandler ( flushConsole )
  53 import System.Win32       ( setConsoleCP, setConsoleOutputCP )
  54 import qualified System.Win32
  55 #endif
  56
  57 #ifdef USE_READLINE
  58 import Control.Concurrent       ( yield )       -- Used in readline loop
  59 import System.Console.Readline as Readline
  60 #endif
  61
  62 --import SystemExts
  63
  64 import Control.Exception as Exception
  65 -- import Control.Concurrent
  66
  67 import Data.List
  68 import Data.Maybe
  69 import System.Cmd
  70 import System.Environment
  71 import System.Exit      ( exitWith, ExitCode(..) )
  72 import System.Directory
  73 import System.IO
  74 import System.IO.Error as IO
  75 import Data.Char
  76 import Data.Dynamic
  77 import Data.Array
  78 import Control.Monad as Monad
  79
  80 import Foreign.StablePtr        ( newStablePtr )
  81 import GHC.Exts         ( unsafeCoerce# )
  82 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  83
  84 import Data.IORef       ( IORef, readIORef, writeIORef )
  85
  86 import System.Posix.Internals ( setNonBlockingFD )
  87
  88 -- these are needed by the new ghci debugger
  89 import ByteCodeLink (HValue)
  90 import ByteCodeInstr (BreakInfo (..))
  91 import BreakArray
  92
  93 -----------------------------------------------------------------------------
  94
  95 ghciWelcomeMsg =
  96  "   ___         ___ _\n"++
  97  "  / _ \\ /\\  /\\/ __(_)\n"++
  98  " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
  99  "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
 100  "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
 101
 102 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
 103 cmdName (n,_,_,_) = n
 104
 105 GLOBAL_VAR(commands, builtin_commands, [Command])
 106
 107 builtin_commands :: [Command]
 108 builtin_commands = [
 109         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 110   ("?",         keepGoing help,                 False, completeNone),
 111   ("add",       keepGoingPaths addModule,       False, completeFilename),
 112   ("break",     breakCmd,                       False, completeIdentifier),
 113   ("browse",    keepGoing browseCmd,            False, completeModule),
 114   ("cd",        keepGoing changeDirectory,      False, completeFilename),
 115   ("check",     keepGoing checkModule,          False, completeHomeModule),
 116   ("continue",  continueCmd,                    False, completeNone),
 117   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 118   ("def",       keepGoing defineMacro,          False, completeIdentifier),
 119   ("delete",    deleteCmd,                      False, completeNone),
 120   ("e",         keepGoing editFile,             False, completeFilename),
 121   ("edit",      keepGoing editFile,             False, completeFilename),
 122   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 123   ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
 124   ("help",      keepGoing help,                 False, completeNone),
 125   ("info",      keepGoing info,                 False, completeIdentifier),
 126   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 127   ("load",      keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),
 128   ("module",    keepGoing setContext,           False, completeModule),
 129   ("main",      keepGoing runMain,              False, completeIdentifier),
 130   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
 131   ("quit",      quit,                           False, completeNone),
 132   ("reload",    keepGoing reloadModule,         False, completeNone),
 133   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 134   ("show",      keepGoing showCmd,              False, completeNone),
 135   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
 136   ("step",      stepCmd,                        False, completeIdentifier),
 137   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 138   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 139   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions)
 140   ]
 141
 142 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 143 keepGoing a str = a str >> return False
 144
 145 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 146 keepGoingPaths a str = a (toArgs str) >> return False
 147
 148 shortHelpText = "use :? for help.\n"
 149
 150 helpText =
 151  " Commands available from the prompt:\n" ++
 152  "\n" ++
 153  "   <stmt>                      evaluate/run <stmt>\n" ++
 154  "   :add <filename> ...         add module(s) to the current target set\n" ++
 155  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 156  "   :break <name>               set a breakpoint on the specified function\n" ++
 157  "   :browse [*]<module>         display the names defined by <module>\n" ++
 158  "   :cd <dir>                   change directory to <dir>\n" ++
 159  "   :continue                   resume after a breakpoint\n" ++
 160  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 161  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 162  "   :delete <number>            delete the specified breakpoint\n" ++
 163  "   :delete *                   delete all breakpoints\n" ++
 164  "   :edit <file>                edit file\n" ++
 165  "   :edit                       edit last module\n" ++
 166  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 167 -- "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
 168  "   :help, :?                   display this list of commands\n" ++
 169  "   :info [<name> ...]          display information about the given names\n" ++
 170  "   :kind <type>                show the kind of <type>\n" ++
 171  "   :load <filename> ...        load module(s) and their dependents\n" ++
 172  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 173  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 174  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 175  "   :quit                       exit GHCi\n" ++
 176  "   :reload                     reload the current module set\n" ++
 177  "\n" ++
 178  "   :set <option> ...           set options\n" ++
 179  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 180  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 181  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 182  "   :set editor <cmd>           set the command used for :edit\n" ++
 183  "\n" ++
 184  "   :show breaks                show active breakpoints\n" ++
 185  "   :show context               show the breakpoint context\n" ++
 186  "   :show modules               show the currently loaded modules\n" ++
 187  "   :show bindings              show the current bindings made at the prompt\n" ++
 188  "\n" ++
 189  "   :sprint [<name> ...]        simplifed version of :print\n" ++
 190  "   :step                       single-step after stopping at a breakpoint\n"++
 191  "   :step <expr>                single-step into <expr>\n"++
 192  "   :type <expr>                show the type of <expr>\n" ++
 193  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 194  "   :unset <option> ...         unset options\n" ++
 195  "   :!<command>                 run the shell command <command>\n" ++
 196  "\n" ++
 197  " Options for ':set' and ':unset':\n" ++
 198  "\n" ++
 199  "    +r            revert top-level expressions after each evaluation\n" ++
 200  "    +s            print timing/memory stats after each evaluation\n" ++
 201  "    +t            print type after evaluation\n" ++
 202  "    -<flags>      most GHC command line flags can also be set here\n" ++
 203  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 204  "\n"
 205 -- Todo: add help for breakpoint commands here
 206
 207 findEditor = do
 208   getEnv "EDITOR"
 209     `IO.catch` \_ -> do
 210 #if mingw32_HOST_OS
 211         win <- System.Win32.getWindowsDirectory
 212         return (win `joinFileName` "notepad.exe")
 213 #else
 214         return ""
 215 #endif
 216
 217 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 218 interactiveUI session srcs maybe_expr = do
 219    -- HACK! If we happen to get into an infinite loop (eg the user
 220    -- types 'let x=x in x' at the prompt), then the thread will block
 221    -- on a blackhole, and become unreachable during GC.  The GC will
 222    -- detect that it is unreachable and send it the NonTermination
 223    -- exception.  However, since the thread is unreachable, everything
 224    -- it refers to might be finalized, including the standard Handles.
 225    -- This sounds like a bug, but we don't have a good solution right
 226    -- now.
 227    newStablePtr stdin
 228    newStablePtr stdout
 229    newStablePtr stderr
 230
 231         -- Initialise buffering for the *interpreted* I/O system
 232    initInterpBuffering session
 233
 234    when (isNothing maybe_expr) $ do
 235         -- Only for GHCi (not runghc and ghc -e):
 236         -- Turn buffering off for the compiled program's stdout/stderr
 237         turnOffBuffering
 238         -- Turn buffering off for GHCi's stdout
 239         hFlush stdout
 240         hSetBuffering stdout NoBuffering
 241         -- We don't want the cmd line to buffer any input that might be
 242         -- intended for the program, so unbuffer stdin.
 243         hSetBuffering stdin NoBuffering
 244
 245         -- initial context is just the Prelude
 246    prel_mod <- GHC.findModule session prel_name (Just basePackageId)
 247    GHC.setContext session [] [prel_mod]
 248
 249 #ifdef USE_READLINE
 250    Readline.initialize
 251    Readline.setAttemptedCompletionFunction (Just completeWord)
 252    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 253
 254    let symbols = "!#$%&*+/<=>?@\\^|-~"
 255        specials = "(),;[]`{}"
 256        spaces = " \t\n"
 257        word_break_chars = spaces ++ specials ++ symbols
 258
 259    Readline.setBasicWordBreakCharacters word_break_chars
 260    Readline.setCompleterWordBreakCharacters word_break_chars
 261 #endif
 262
 263    default_editor <- findEditor
 264
 265    startGHCi (runGHCi srcs maybe_expr)
 266         GHCiState{ progname = "<interactive>",
 267                    args = [],
 268                    prompt = "%s> ",
 269                    editor = default_editor,
 270                    session = session,
 271                    options = [],
 272                    prelude = prel_mod,
 273                    resume = [],
 274                    breaks = emptyActiveBreakPoints,
 275                    tickarrays = emptyModuleEnv
 276                  }
 277
 278 #ifdef USE_READLINE
 279    Readline.resetTerminal Nothing
 280 #endif
 281
 282    return ()
 283
 284 prel_name = GHC.mkModuleName "Prelude"
 285
 286 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 287 runGHCi paths maybe_expr = do
 288   let read_dot_files = not opt_IgnoreDotGhci
 289
 290   when (read_dot_files) $ do
 291     -- Read in ./.ghci.
 292     let file = "./.ghci"
 293     exists <- io (doesFileExist file)
 294     when exists $ do
 295        dir_ok  <- io (checkPerms ".")
 296        file_ok <- io (checkPerms file)
 297        when (dir_ok && file_ok) $ do
 298           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 299           case either_hdl of
 300              Left e    -> return ()
 301              Right hdl -> fileLoop hdl False
 302
 303   when (read_dot_files) $ do
 304     -- Read in $HOME/.ghci
 305     either_dir <- io (IO.try (getEnv "HOME"))
 306     case either_dir of
 307        Left e -> return ()
 308        Right dir -> do
 309           cwd <- io (getCurrentDirectory)
 310           when (dir /= cwd) $ do
 311              let file = dir ++ "/.ghci"
 312              ok <- io (checkPerms file)
 313              when ok $ do
 314                either_hdl <- io (IO.try (openFile file ReadMode))
 315                case either_hdl of
 316                   Left e    -> return ()
 317                   Right hdl -> fileLoop hdl False
 318
 319   -- Perform a :load for files given on the GHCi command line
 320   -- When in -e mode, if the load fails then we want to stop
 321   -- immediately rather than going on to evaluate the expression.
 322   when (not (null paths)) $ do
 323      ok <- ghciHandle (\e -> do showException e; return Failed) $
 324                 loadModule paths
 325      when (isJust maybe_expr && failed ok) $
 326         io (exitWith (ExitFailure 1))
 327
 328   -- if verbosity is greater than 0, or we are connected to a
 329   -- terminal, display the prompt in the interactive loop.
 330   is_tty <- io (hIsTerminalDevice stdin)
 331   dflags <- getDynFlags
 332   let show_prompt = verbosity dflags > 0 || is_tty
 333
 334   case maybe_expr of
 335         Nothing ->
 336           do
 337 #if defined(mingw32_HOST_OS)
 338             -- The win32 Console API mutates the first character of
 339             -- type-ahead when reading from it in a non-buffered manner. Work
 340             -- around this by flushing the input buffer of type-ahead characters,
 341             -- but only if stdin is available.
 342             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 343             case flushed of
 344              Left err | isDoesNotExistError err -> return ()
 345                       | otherwise -> io (ioError err)
 346              Right () -> return ()
 347 #endif
 348             -- initialise the console if necessary
 349             io setUpConsole
 350
 351             -- enter the interactive loop
 352             interactiveLoop is_tty show_prompt
 353         Just expr -> do
 354             -- just evaluate the expression we were given
 355             runCommandEval expr
 356             return ()
 357
 358   -- and finally, exit
 359   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 360
 361
 362 interactiveLoop is_tty show_prompt =
 363   -- Ignore ^C exceptions caught here
 364   ghciHandleDyn (\e -> case e of
 365                         Interrupted -> do
 366 #if defined(mingw32_HOST_OS)
 367                                 io (putStrLn "")
 368 #endif
 369                                 interactiveLoop is_tty show_prompt
 370                         _other      -> return ()) $
 371
 372   ghciUnblock $ do -- unblock necessary if we recursed from the
 373                    -- exception handler above.
 374
 375   -- read commands from stdin
 376 #ifdef USE_READLINE
 377   if (is_tty)
 378         then readlineLoop
 379         else fileLoop stdin show_prompt
 380 #else
 381   fileLoop stdin show_prompt
 382 #endif
 383
 384
 385 -- NOTE: We only read .ghci files if they are owned by the current user,
 386 -- and aren't world writable.  Otherwise, we could be accidentally
 387 -- running code planted by a malicious third party.
 388
 389 -- Furthermore, We only read ./.ghci if . is owned by the current user
 390 -- and isn't writable by anyone else.  I think this is sufficient: we
 391 -- don't need to check .. and ../.. etc. because "."  always refers to
 392 -- the same directory while a process is running.
 393
 394 checkPerms :: String -> IO Bool
 395 checkPerms name =
 396 #ifdef mingw32_HOST_OS
 397   return True
 398 #else
 399   Util.handle (\_ -> return False) $ do
 400      st <- getFileStatus name
 401      me <- getRealUserID
 402      if fileOwner st /= me then do
 403         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 404         return False
 405       else do
 406         let mode =  fileMode st
 407         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 408            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 409            then do
 410                putStrLn $ "*** WARNING: " ++ name ++
 411                           " is writable by someone else, IGNORING!"
 412                return False
 413           else return True
 414 #endif
 415
 416 fileLoop :: Handle -> Bool -> GHCi ()
 417 fileLoop hdl show_prompt = do
 418    session <- getSession
 419    (mod,imports) <- io (GHC.getContext session)
 420    st <- getGHCiState
 421    when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
 422    l <- io (IO.try (hGetLine hdl))
 423    case l of
 424         Left e | isEOFError e              -> return ()
 425                | InvalidArgument <- etype  -> return ()
 426                | otherwise                 -> io (ioError e)
 427                 where etype = ioeGetErrorType e
 428                 -- treat InvalidArgument in the same way as EOF:
 429                 -- this can happen if the user closed stdin, or
 430                 -- perhaps did getContents which closes stdin at
 431                 -- EOF.
 432         Right l ->
 433           case removeSpaces l of
 434             "" -> fileLoop hdl show_prompt
 435             l  -> do quit <- runCommand l
 436                      if quit then return () else fileLoop hdl show_prompt
 437
 438 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
 439 stringLoop [] = return False
 440 stringLoop (s:ss) = do
 441    case removeSpaces s of
 442         "" -> stringLoop ss
 443         l  -> do quit <- runCommand l
 444                  if quit then return True else stringLoop ss
 445
 446 mkPrompt toplevs exports prompt
 447   = showSDoc $ f prompt
 448     where
 449         f ('%':'s':xs) = perc_s <> f xs
 450         f ('%':'%':xs) = char '%' <> f xs
 451         f (x:xs) = char x <> f xs
 452         f [] = empty
 453
 454         perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
 455                  hsep (map (ppr . GHC.moduleName) exports)
 456
 457
 458 #ifdef USE_READLINE
 459 readlineLoop :: GHCi ()
 460 readlineLoop = do
 461    session <- getSession
 462    (mod,imports) <- io (GHC.getContext session)
 463    io yield
 464    saveSession -- for use by completion
 465    st <- getGHCiState
 466    l <- io (readline (mkPrompt mod imports (prompt st))
 467                 `finally` setNonBlockingFD 0)
 468                 -- readline sometimes puts stdin into blocking mode,
 469                 -- so we need to put it back for the IO library
 470    splatSavedSession
 471    case l of
 472         Nothing -> return ()
 473         Just l  ->
 474           case removeSpaces l of
 475             "" -> readlineLoop
 476             l  -> do
 477                   io (addHistory l)
 478                   quit <- runCommand l
 479                   if quit then return () else readlineLoop
 480 #endif
 481
 482 runCommand :: String -> GHCi Bool
 483 runCommand c = ghciHandle handler (doCommand c)
 484   where
 485     doCommand (':' : command) = specialCommand command
 486     doCommand stmt
 487        = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 488             return False
 489
 490 -- This version is for the GHC command-line option -e.  The only difference
 491 -- from runCommand is that it catches the ExitException exception and
 492 -- exits, rather than printing out the exception.
 493 runCommandEval c = ghciHandle handleEval (doCommand c)
 494   where
 495     handleEval (ExitException code) = io (exitWith code)
 496     handleEval e                    = do handler e
 497                                          io (exitWith (ExitFailure 1))
 498
 499     doCommand (':' : command) = specialCommand command
 500     doCommand stmt
 501        = do nms <- runStmt stmt
 502             case nms of
 503                 Nothing -> io (exitWith (ExitFailure 1))
 504                   -- failure to run the command causes exit(1) for ghc -e.
 505                 _       -> finishEvalExpr nms
 506
 507 runStmt :: String -> GHCi (Maybe (Bool,[Name]))
 508 runStmt stmt
 509  | null (filter (not.isSpace) stmt) = return (Just (False,[]))
 510  | otherwise
 511  = do st <- getGHCiState
 512       session <- getSession
 513       result <- io $ withProgName (progname st) $ withArgs (args st) $
 514                      GHC.runStmt session stmt
 515       switchOnRunResult result
 516
 517 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
 518 switchOnRunResult GHC.RunFailed = return Nothing
 519 switchOnRunResult (GHC.RunException e) = throw e
 520 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
 521 switchOnRunResult (GHC.RunBreak threadId names info resume) = do
 522    session <- getSession
 523    Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info)
 524    let modBreaks  = GHC.modInfoModBreaks mod_info
 525    let ticks      = GHC.modBreaks_locs modBreaks
 526
 527    -- display information about the breakpoint
 528    let location = ticks ! breakInfo_number info
 529    printForUser $ ptext SLIT("Stopped at") <+> ppr location
 530
 531    pushResume location threadId resume
 532    return (Just (True,names))
 533
 534 -- possibly print the type and revert CAFs after evaluating an expression
 535 finishEvalExpr mb_names
 536  = do show_types <- isOptionSet ShowType
 537       session <- getSession
 538       case mb_names of
 539         Nothing    -> return ()
 540         Just (is_break,names) ->
 541                 when (is_break || show_types) $
 542                       mapM_ (showTypeOfName session) names
 543
 544       flushInterpBuffers
 545       io installSignalHandlers
 546       b <- isOptionSet RevertCAFs
 547       io (when b revertCAFs)
 548       return True
 549
 550 showTypeOfName :: Session -> Name -> GHCi ()
 551 showTypeOfName session n
 552    = do maybe_tything <- io (GHC.lookupName session n)
 553         case maybe_tything of
 554           Nothing    -> return ()
 555           Just thing -> showTyThing thing
 556
 557 specialCommand :: String -> GHCi Bool
 558 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 559 specialCommand str = do
 560   let (cmd,rest) = break isSpace str
 561   maybe_cmd <- io (lookupCommand cmd)
 562   case maybe_cmd of
 563     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 564                                     ++ shortHelpText) >> return False)
 565     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 566
 567 lookupCommand :: String -> IO (Maybe Command)
 568 lookupCommand str = do
 569   cmds <- readIORef commands
 570   -- look for exact match first, then the first prefix match
 571   case [ c | c <- cmds, str == cmdName c ] of
 572      c:_ -> return (Just c)
 573      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 574                 [] -> return Nothing
 575                 c:_ -> return (Just c)
 576
 577 -----------------------------------------------------------------------------
 578 -- Commands
 579
 580 help :: String -> GHCi ()
 581 help _ = io (putStr helpText)
 582
 583 info :: String -> GHCi ()
 584 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 585 info s  = do { let names = words s
 586              ; session <- getSession
 587              ; dflags <- getDynFlags
 588              ; let exts = dopt Opt_GlasgowExts dflags
 589              ; mapM_ (infoThing exts session) names }
 590   where
 591     infoThing exts session str = io $ do
 592         names <- GHC.parseName session str
 593         let filtered = filterOutChildren names
 594         mb_stuffs <- mapM (GHC.getInfo session) filtered
 595         unqual <- GHC.getPrintUnqual session
 596         putStrLn (showSDocForUser unqual $
 597                    vcat (intersperse (text "") $
 598                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 599
 600   -- Filter out names whose parent is also there Good
 601   -- example is '[]', which is both a type and data
 602   -- constructor in the same type
 603 filterOutChildren :: [Name] -> [Name]
 604 filterOutChildren names = filter (not . parent_is_there) names
 605  where parent_is_there n
 606 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 607 -- ToDo!!
 608          | otherwise                       = False
 609
 610 pprInfo exts (thing, fixity, insts)
 611   =  pprTyThingInContextLoc exts thing
 612   $$ show_fixity fixity
 613   $$ vcat (map GHC.pprInstance insts)
 614   where
 615     show_fixity fix
 616         | fix == GHC.defaultFixity = empty
 617         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 618
 619 -----------------------------------------------------------------------------
 620 -- Commands
 621
 622 runMain :: String -> GHCi ()
 623 runMain args = do
 624   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 625   runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
 626   return ()
 627
 628 addModule :: [FilePath] -> GHCi ()
 629 addModule files = do
 630   io (revertCAFs)                       -- always revert CAFs on load/add.
 631   files <- mapM expandPath files
 632   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 633   session <- getSession
 634   io (mapM_ (GHC.addTarget session) targets)
 635   ok <- io (GHC.load session LoadAllTargets)
 636   afterLoad ok session
 637
 638 changeDirectory :: String -> GHCi ()
 639 changeDirectory dir = do
 640   session <- getSession
 641   graph <- io (GHC.getModuleGraph session)
 642   when (not (null graph)) $
 643         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 644   io (GHC.setTargets session [])
 645   io (GHC.load session LoadAllTargets)
 646   setContextAfterLoad session []
 647   io (GHC.workingDirectoryChanged session)
 648   dir <- expandPath dir
 649   io (setCurrentDirectory dir)
 650
 651 editFile :: String -> GHCi ()
 652 editFile str
 653   | null str  = do
 654         -- find the name of the "topmost" file loaded
 655      session <- getSession
 656      graph0 <- io (GHC.getModuleGraph session)
 657      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 658      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 659      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 660         Just file -> do_edit file
 661         Nothing   -> throwDyn (CmdLineError "unknown file name")
 662   | otherwise = do_edit str
 663   where
 664         do_edit file = do
 665            st <- getGHCiState
 666            let cmd = editor st
 667            when (null cmd) $
 668                 throwDyn (CmdLineError "editor not set, use :set editor")
 669            io $ system (cmd ++ ' ':file)
 670            return ()
 671
 672 defineMacro :: String -> GHCi ()
 673 defineMacro s = do
 674   let (macro_name, definition) = break isSpace s
 675   cmds <- io (readIORef commands)
 676   if (null macro_name)
 677         then throwDyn (CmdLineError "invalid macro name")
 678         else do
 679   if (macro_name `elem` map cmdName cmds)
 680         then throwDyn (CmdLineError
 681                 ("command '" ++ macro_name ++ "' is already defined"))
 682         else do
 683
 684   -- give the expression a type signature, so we can be sure we're getting
 685   -- something of the right type.
 686   let new_expr = '(' : definition ++ ") :: String -> IO String"
 687
 688   -- compile the expression
 689   cms <- getSession
 690   maybe_hv <- io (GHC.compileExpr cms new_expr)
 691   case maybe_hv of
 692      Nothing -> return ()
 693      Just hv -> io (writeIORef commands --
 694                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 695
 696 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 697 runMacro fun s = do
 698   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 699   stringLoop (lines str)
 700
 701 undefineMacro :: String -> GHCi ()
 702 undefineMacro macro_name = do
 703   cmds <- io (readIORef commands)
 704   if (macro_name `elem` map cmdName builtin_commands)
 705         then throwDyn (CmdLineError
 706                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 707         else do
 708   if (macro_name `notElem` map cmdName cmds)
 709         then throwDyn (CmdLineError
 710                 ("command '" ++ macro_name ++ "' not defined"))
 711         else do
 712   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 713
 714
 715 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 716 loadModule fs = timeIt (loadModule' fs)
 717
 718 loadModule_ :: [FilePath] -> GHCi ()
 719 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 720
 721 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 722 loadModule' files = do
 723   session <- getSession
 724
 725   -- unload first
 726   io (GHC.setTargets session [])
 727   io (GHC.load session LoadAllTargets)
 728
 729   -- expand tildes
 730   let (filenames, phases) = unzip files
 731   exp_filenames <- mapM expandPath filenames
 732   let files' = zip exp_filenames phases
 733   targets <- io (mapM (uncurry GHC.guessTarget) files')
 734
 735   -- NOTE: we used to do the dependency anal first, so that if it
 736   -- fails we didn't throw away the current set of modules.  This would
 737   -- require some re-working of the GHC interface, so we'll leave it
 738   -- as a ToDo for now.
 739
 740   io (GHC.setTargets session targets)
 741   ok <- io (GHC.load session LoadAllTargets)
 742   afterLoad ok session
 743   return ok
 744
 745 checkModule :: String -> GHCi ()
 746 checkModule m = do
 747   let modl = GHC.mkModuleName m
 748   session <- getSession
 749   result <- io (GHC.checkModule session modl)
 750   case result of
 751     Nothing -> io $ putStrLn "Nothing"
 752     Just r  -> io $ putStrLn (showSDoc (
 753         case GHC.checkedModuleInfo r of
 754            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 755                 let
 756                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 757                 in
 758                         (text "global names: " <+> ppr global) $$
 759                         (text "local  names: " <+> ppr local)
 760            _ -> empty))
 761   afterLoad (successIf (isJust result)) session
 762
 763 reloadModule :: String -> GHCi ()
 764 reloadModule "" = do
 765   io (revertCAFs)               -- always revert CAFs on reload.
 766   session <- getSession
 767   ok <- io (GHC.load session LoadAllTargets)
 768   afterLoad ok session
 769 reloadModule m = do
 770   io (revertCAFs)               -- always revert CAFs on reload.
 771   session <- getSession
 772   ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
 773   afterLoad ok session
 774
 775 afterLoad ok session = do
 776   io (revertCAFs)  -- always revert CAFs on load.
 777   discardResumeContext
 778   discardTickArrays
 779   discardActiveBreakPoints
 780   graph <- io (GHC.getModuleGraph session)
 781   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 782   setContextAfterLoad session graph'
 783   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 784
 785 setContextAfterLoad session [] = do
 786   prel_mod <- getPrelude
 787   io (GHC.setContext session [] [prel_mod])
 788 setContextAfterLoad session ms = do
 789   -- load a target if one is available, otherwise load the topmost module.
 790   targets <- io (GHC.getTargets session)
 791   case [ m | Just m <- map (findTarget ms) targets ] of
 792         []    ->
 793           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 794           load_this (last graph')
 795         (m:_) ->
 796           load_this m
 797  where
 798    findTarget ms t
 799     = case filter (`matches` t) ms of
 800         []    -> Nothing
 801         (m:_) -> Just m
 802
 803    summary `matches` Target (TargetModule m) _
 804         = GHC.ms_mod_name summary == m
 805    summary `matches` Target (TargetFile f _) _
 806         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 807    summary `matches` target
 808         = False
 809
 810    load_this summary | m <- GHC.ms_mod summary = do
 811         b <- io (GHC.moduleIsInterpreted session m)
 812         if b then io (GHC.setContext session [m] [])
 813              else do
 814                    prel_mod <- getPrelude
 815                    io (GHC.setContext session []  [prel_mod,m])
 816
 817
 818 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 819 modulesLoadedMsg ok mods = do
 820   dflags <- getDynFlags
 821   when (verbosity dflags > 0) $ do
 822    let mod_commas
 823         | null mods = text "none."
 824         | otherwise = hsep (
 825             punctuate comma (map ppr mods)) <> text "."
 826    case ok of
 827     Failed ->
 828        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 829     Succeeded  ->
 830        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 831
 832
 833 typeOfExpr :: String -> GHCi ()
 834 typeOfExpr str
 835   = do cms <- getSession
 836        maybe_ty <- io (GHC.exprType cms str)
 837        case maybe_ty of
 838           Nothing -> return ()
 839           Just ty -> do ty' <- cleanType ty
 840                         printForUser $ text str <> text " :: " <> ppr ty'
 841
 842 kindOfType :: String -> GHCi ()
 843 kindOfType str
 844   = do cms <- getSession
 845        maybe_ty <- io (GHC.typeKind cms str)
 846        case maybe_ty of
 847           Nothing    -> return ()
 848           Just ty    -> printForUser $ text str <> text " :: " <> ppr ty
 849
 850 quit :: String -> GHCi Bool
 851 quit _ = return True
 852
 853 shellEscape :: String -> GHCi Bool
 854 shellEscape str = io (system str >> return False)
 855
 856 -----------------------------------------------------------------------------
 857 -- create tags file for currently loaded modules.
 858
 859 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
 860
 861 createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
 862 createCTagsFileCmd file = ghciCreateTagsFile CTags file
 863
 864 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
 865 createETagsFileCmd file  = ghciCreateTagsFile ETags file
 866
 867 data TagsKind = ETags | CTags
 868
 869 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
 870 ghciCreateTagsFile kind file = do
 871   session <- getSession
 872   io $ createTagsFile session kind file
 873
 874 -- ToDo:
 875 --      - remove restriction that all modules must be interpreted
 876 --        (problem: we don't know source locations for entities unless
 877 --        we compiled the module.
 878 --
 879 --      - extract createTagsFile so it can be used from the command-line
 880 --        (probably need to fix first problem before this is useful).
 881 --
 882 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
 883 createTagsFile session tagskind tagFile = do
 884   graph <- GHC.getModuleGraph session
 885   let ms = map GHC.ms_mod graph
 886       tagModule m = do
 887         is_interpreted <- GHC.moduleIsInterpreted session m
 888         -- should we just skip these?
 889         when (not is_interpreted) $
 890           throwDyn (CmdLineError ("module '"
 891                                 ++ GHC.moduleNameString (GHC.moduleName m)
 892                                 ++ "' is not interpreted"))
 893         mbModInfo <- GHC.getModuleInfo session m
 894         let unqual
 895               | Just modinfo <- mbModInfo,
 896                 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
 897               | otherwise = GHC.alwaysQualify
 898
 899         case mbModInfo of
 900           Just modInfo -> return $! listTags unqual modInfo
 901           _            -> return []
 902
 903   mtags <- mapM tagModule ms
 904   either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
 905   case either_res of
 906     Left e  -> hPutStrLn stderr $ ioeGetErrorString e
 907     Right _ -> return ()
 908
 909 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
 910 listTags unqual modInfo =
 911            [ tagInfo unqual name loc
 912            | name <- GHC.modInfoExports modInfo
 913            , let loc = nameSrcLoc name
 914            , isGoodSrcLoc loc
 915            ]
 916
 917 type TagInfo = (String -- tag name
 918                ,String -- file name
 919                ,Int    -- line number
 920                ,Int    -- column number
 921                )
 922
 923 -- get tag info, for later translation into Vim or Emacs style
 924 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
 925 tagInfo unqual name loc
 926     = ( showSDocForUser unqual $ pprOccName (nameOccName name)
 927       , showSDocForUser unqual $ ftext (srcLocFile loc)
 928       , srcLocLine loc
 929       , srcLocCol loc
 930       )
 931
 932 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
 933 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
 934   let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
 935   IO.try (writeFile file tags)
 936 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
 937   let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
 938       groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
 939   tagGroups <- mapM tagFileGroup groups
 940   IO.try (writeFile file $ concat tagGroups)
 941   where
 942     tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
 943     tagFileGroup group@((_,fileName,_,_):_) = do
 944       file <- readFile fileName -- need to get additional info from sources..
 945       let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
 946           sortedGroup = sortLe byLine group
 947           tags = unlines $ perFile sortedGroup 1 0 $ lines file
 948       return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
 949     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
 950       perFile (tagInfo:tags) (count+1) (pos+length line) lines
 951     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
 952       showETag tagInfo line pos : perFile tags count pos lines
 953     perFile tags count pos lines = []
 954
 955 -- simple ctags format, for Vim et al
 956 showTag :: TagInfo -> String
 957 showTag (tag,file,lineNo,colNo)
 958     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
 959
 960 -- etags format, for Emacs/XEmacs
 961 showETag :: TagInfo -> String -> Int -> String
 962 showETag (tag,file,lineNo,colNo) line charPos
 963     =  take colNo line ++ tag
 964     ++ "\x7f" ++ tag
 965     ++ "\x01" ++ show lineNo
 966     ++ "," ++ show charPos
 967
 968 -----------------------------------------------------------------------------
 969 -- Browsing a module's contents
 970
 971 browseCmd :: String -> GHCi ()
 972 browseCmd m =
 973   case words m of
 974     ['*':m] | looksLikeModuleName m -> browseModule m False
 975     [m]     | looksLikeModuleName m -> browseModule m True
 976     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 977
 978 browseModule m exports_only = do
 979   s <- getSession
 980   modl <- if exports_only then lookupModule s m
 981                           else wantInterpretedModule s m
 982
 983   -- Temporarily set the context to the module we're interested in,
 984   -- just so we can get an appropriate PrintUnqualified
 985   (as,bs) <- io (GHC.getContext s)
 986   prel_mod <- getPrelude
 987   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 988                       else GHC.setContext s [modl] [])
 989   unqual <- io (GHC.getPrintUnqual s)
 990   io (GHC.setContext s as bs)
 991
 992   mb_mod_info <- io $ GHC.getModuleInfo s modl
 993   case mb_mod_info of
 994     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 995     Just mod_info -> do
 996         let names
 997                | exports_only = GHC.modInfoExports mod_info
 998                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 999
1000             filtered = filterOutChildren names
1001
1002         things <- io $ mapM (GHC.lookupName s) filtered
1003
1004         dflags <- getDynFlags
1005         let exts = dopt Opt_GlasgowExts dflags
1006         io (putStrLn (showSDocForUser unqual (
1007                 vcat (map (pprTyThingInContext exts) (catMaybes things))
1008            )))
1009         -- ToDo: modInfoInstances currently throws an exception for
1010         -- package modules.  When it works, we can do this:
1011         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1012
1013 -----------------------------------------------------------------------------
1014 -- Setting the module context
1015
1016 setContext str
1017   | all sensible mods = fn mods
1018   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1019   where
1020     (fn, mods) = case str of
1021                         '+':stuff -> (addToContext,      words stuff)
1022                         '-':stuff -> (removeFromContext, words stuff)
1023                         stuff     -> (newContext,        words stuff)
1024
1025     sensible ('*':m) = looksLikeModuleName m
1026     sensible m       = looksLikeModuleName m
1027
1028 separate :: Session -> [String] -> [Module] -> [Module]
1029         -> GHCi ([Module],[Module])
1030 separate session []           as bs = return (as,bs)
1031 separate session (('*':str):ms) as bs = do
1032    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1033    b <- io $ GHC.moduleIsInterpreted session m
1034    if b then separate session ms (m:as) bs
1035         else throwDyn (CmdLineError ("module '"
1036                         ++ GHC.moduleNameString (GHC.moduleName m)
1037                         ++ "' is not interpreted"))
1038 separate session (str:ms) as bs = do
1039   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1040   separate session ms as (m:bs)
1041
1042 newContext :: [String] -> GHCi ()
1043 newContext strs = do
1044   s <- getSession
1045   (as,bs) <- separate s strs [] []
1046   prel_mod <- getPrelude
1047   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1048   io $ GHC.setContext s as bs'
1049
1050
1051 addToContext :: [String] -> GHCi ()
1052 addToContext strs = do
1053   s <- getSession
1054   (as,bs) <- io $ GHC.getContext s
1055
1056   (new_as,new_bs) <- separate s strs [] []
1057
1058   let as_to_add = new_as \\ (as ++ bs)
1059       bs_to_add = new_bs \\ (as ++ bs)
1060
1061   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1062
1063
1064 removeFromContext :: [String] -> GHCi ()
1065 removeFromContext strs = do
1066   s <- getSession
1067   (as,bs) <- io $ GHC.getContext s
1068
1069   (as_to_remove,bs_to_remove) <- separate s strs [] []
1070
1071   let as' = as \\ (as_to_remove ++ bs_to_remove)
1072       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1073
1074   io $ GHC.setContext s as' bs'
1075
1076 ----------------------------------------------------------------------------
1077 -- Code for `:set'
1078
1079 -- set options in the interpreter.  Syntax is exactly the same as the
1080 -- ghc command line, except that certain options aren't available (-C,
1081 -- -E etc.)
1082 --
1083 -- This is pretty fragile: most options won't work as expected.  ToDo:
1084 -- figure out which ones & disallow them.
1085
1086 setCmd :: String -> GHCi ()
1087 setCmd ""
1088   = do st <- getGHCiState
1089        let opts = options st
1090        io $ putStrLn (showSDoc (
1091               text "options currently set: " <>
1092               if null opts
1093                    then text "none."
1094                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1095            ))
1096 setCmd str
1097   = case toArgs str of
1098         ("args":args) -> setArgs args
1099         ("prog":prog) -> setProg prog
1100         ("prompt":prompt) -> setPrompt (after 6)
1101         ("editor":cmd) -> setEditor (after 6)
1102         wds -> setOptions wds
1103    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1104
1105 setArgs args = do
1106   st <- getGHCiState
1107   setGHCiState st{ args = args }
1108
1109 setProg [prog] = do
1110   st <- getGHCiState
1111   setGHCiState st{ progname = prog }
1112 setProg _ = do
1113   io (hPutStrLn stderr "syntax: :set prog <progname>")
1114
1115 setEditor cmd = do
1116   st <- getGHCiState
1117   setGHCiState st{ editor = cmd }
1118
1119 setPrompt value = do
1120   st <- getGHCiState
1121   if null value
1122       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1123       else setGHCiState st{ prompt = remQuotes value }
1124   where
1125      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1126      remQuotes x = x
1127
1128 setOptions wds =
1129    do -- first, deal with the GHCi opts (+s, +t, etc.)
1130       let (plus_opts, minus_opts)  = partition isPlus wds
1131       mapM_ setOpt plus_opts
1132
1133       -- then, dynamic flags
1134       dflags <- getDynFlags
1135       let pkg_flags = packageFlags dflags
1136       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1137
1138       if (not (null leftovers))
1139                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1140                                                 unwords leftovers))
1141                 else return ()
1142
1143       new_pkgs <- setDynFlags dflags'
1144
1145       -- if the package flags changed, we should reset the context
1146       -- and link the new packages.
1147       dflags <- getDynFlags
1148       when (packageFlags dflags /= pkg_flags) $ do
1149         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1150         session <- getSession
1151         io (GHC.setTargets session [])
1152         io (GHC.load session LoadAllTargets)
1153         io (linkPackages dflags new_pkgs)
1154         setContextAfterLoad session []
1155       return ()
1156
1157
1158 unsetOptions :: String -> GHCi ()
1159 unsetOptions str
1160   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1161        let opts = words str
1162            (minus_opts, rest1) = partition isMinus opts
1163            (plus_opts, rest2)  = partition isPlus rest1
1164
1165        if (not (null rest2))
1166           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1167           else do
1168
1169        mapM_ unsetOpt plus_opts
1170
1171        -- can't do GHC flags for now
1172        if (not (null minus_opts))
1173           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1174           else return ()
1175
1176 isMinus ('-':s) = True
1177 isMinus _ = False
1178
1179 isPlus ('+':s) = True
1180 isPlus _ = False
1181
1182 setOpt ('+':str)
1183   = case strToGHCiOpt str of
1184         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1185         Just o  -> setOption o
1186
1187 unsetOpt ('+':str)
1188   = case strToGHCiOpt str of
1189         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1190         Just o  -> unsetOption o
1191
1192 strToGHCiOpt :: String -> (Maybe GHCiOption)
1193 strToGHCiOpt "s" = Just ShowTiming
1194 strToGHCiOpt "t" = Just ShowType
1195 strToGHCiOpt "r" = Just RevertCAFs
1196 strToGHCiOpt _   = Nothing
1197
1198 optToStr :: GHCiOption -> String
1199 optToStr ShowTiming = "s"
1200 optToStr ShowType   = "t"
1201 optToStr RevertCAFs = "r"
1202
1203 -- ---------------------------------------------------------------------------
1204 -- code for `:show'
1205
1206 showCmd str =
1207   case words str of
1208         ["modules" ] -> showModules
1209         ["bindings"] -> showBindings
1210         ["linker"]   -> io showLinkerState
1211         ["breaks"] -> showBkptTable
1212         ["context"] -> showContext
1213         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings|breaks]")
1214
1215 showModules = do
1216   session <- getSession
1217   let show_one ms = do m <- io (GHC.showModule session ms)
1218                        io (putStrLn m)
1219   graph <- io (GHC.getModuleGraph session)
1220   mapM_ show_one graph
1221
1222 showBindings = do
1223   s <- getSession
1224   unqual <- io (GHC.getPrintUnqual s)
1225   bindings <- io (GHC.getBindings s)
1226   mapM_ showTyThing bindings
1227   return ()
1228
1229 showTyThing (AnId id) = do
1230   ty' <- cleanType (GHC.idType id)
1231   printForUser $ ppr id <> text " :: " <> ppr ty'
1232 showTyThing _  = return ()
1233
1234 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1235 cleanType :: Type -> GHCi Type
1236 cleanType ty = do
1237   dflags <- getDynFlags
1238   if dopt Opt_GlasgowExts dflags
1239         then return ty
1240         else return $! GHC.dropForAlls ty
1241
1242 showBkptTable :: GHCi ()
1243 showBkptTable = do
1244    activeBreaks <- getActiveBreakPoints
1245    printForUser $ ppr activeBreaks
1246
1247 showContext :: GHCi ()
1248 showContext = do
1249    st <- getGHCiState
1250    printForUser $ vcat (map pp_resume (resume st))
1251   where
1252    pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
1253
1254 -- -----------------------------------------------------------------------------
1255 -- Completion
1256
1257 completeNone :: String -> IO [String]
1258 completeNone w = return []
1259
1260 #ifdef USE_READLINE
1261 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1262 completeWord w start end = do
1263   line <- Readline.getLineBuffer
1264   case w of
1265      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1266      _other
1267         | Just c <- is_cmd line -> do
1268            maybe_cmd <- lookupCommand c
1269            let (n,w') = selectWord (words' 0 line)
1270            case maybe_cmd of
1271              Nothing -> return Nothing
1272              Just (_,_,False,complete) -> wrapCompleter complete w
1273              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1274                                                               return (map (drop n) rets)
1275                                          in wrapCompleter complete' w'
1276         | otherwise     -> do
1277                 --printf "complete %s, start = %d, end = %d\n" w start end
1278                 wrapCompleter completeIdentifier w
1279     where words' _ [] = []
1280           words' n str = let (w,r) = break isSpace str
1281                              (s,r') = span isSpace r
1282                          in (n,w):words' (n+length w+length s) r'
1283           -- In a Haskell expression we want to parse 'a-b' as three words
1284           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1285           -- only be a single word.
1286           selectWord [] = (0,w)
1287           selectWord ((offset,x):xs)
1288               | offset+length x >= start = (start-offset,take (end-offset) x)
1289               | otherwise = selectWord xs
1290
1291 is_cmd line
1292  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1293  | otherwise = Nothing
1294
1295 completeCmd w = do
1296   cmds <- readIORef commands
1297   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1298
1299 completeMacro w = do
1300   cmds <- readIORef commands
1301   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1302   return (filter (w `isPrefixOf`) cmds')
1303
1304 completeIdentifier w = do
1305   s <- restoreSession
1306   rdrs <- GHC.getRdrNamesInScope s
1307   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1308
1309 completeModule w = do
1310   s <- restoreSession
1311   dflags <- GHC.getSessionDynFlags s
1312   let pkg_mods = allExposedModules dflags
1313   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1314
1315 completeHomeModule w = do
1316   s <- restoreSession
1317   g <- GHC.getModuleGraph s
1318   let home_mods = map GHC.ms_mod_name g
1319   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1320
1321 completeSetOptions w = do
1322   return (filter (w `isPrefixOf`) options)
1323     where options = "args":"prog":allFlags
1324
1325 completeFilename = Readline.filenameCompletionFunction
1326
1327 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1328
1329 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1330 unionComplete f1 f2 w = do
1331   s1 <- f1 w
1332   s2 <- f2 w
1333   return (s1 ++ s2)
1334
1335 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1336 wrapCompleter fun w =  do
1337   strs <- fun w
1338   case strs of
1339     []  -> return Nothing
1340     [x] -> return (Just (x,[]))
1341     xs  -> case getCommonPrefix xs of
1342                 ""   -> return (Just ("",xs))
1343                 pref -> return (Just (pref,xs))
1344
1345 getCommonPrefix :: [String] -> String
1346 getCommonPrefix [] = ""
1347 getCommonPrefix (s:ss) = foldl common s ss
1348   where common s "" = ""
1349         common "" s = ""
1350         common (c:cs) (d:ds)
1351            | c == d = c : common cs ds
1352            | otherwise = ""
1353
1354 allExposedModules :: DynFlags -> [ModuleName]
1355 allExposedModules dflags
1356  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1357  where
1358   pkg_db = pkgIdMap (pkgState dflags)
1359 #else
1360 completeCmd        = completeNone
1361 completeMacro      = completeNone
1362 completeIdentifier = completeNone
1363 completeModule     = completeNone
1364 completeHomeModule = completeNone
1365 completeSetOptions = completeNone
1366 completeFilename   = completeNone
1367 completeHomeModuleOrFile=completeNone
1368 completeBkpt       = completeNone
1369 #endif
1370
1371 -- ---------------------------------------------------------------------------
1372 -- User code exception handling
1373
1374 -- This is the exception handler for exceptions generated by the
1375 -- user's code and exceptions coming from children sessions;
1376 -- it normally just prints out the exception.  The
1377 -- handler must be recursive, in case showing the exception causes
1378 -- more exceptions to be raised.
1379 --
1380 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1381 -- raising another exception.  We therefore don't put the recursive
1382 -- handler arond the flushing operation, so if stderr is closed
1383 -- GHCi will just die gracefully rather than going into an infinite loop.
1384 handler :: Exception -> GHCi Bool
1385
1386 handler exception = do
1387   flushInterpBuffers
1388   io installSignalHandlers
1389   ghciHandle handler (showException exception >> return False)
1390
1391 showException (DynException dyn) =
1392   case fromDynamic dyn of
1393     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1394     Just Interrupted      -> io (putStrLn "Interrupted.")
1395     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1396     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1397     Just other_ghc_ex     -> io (print other_ghc_ex)
1398
1399 showException other_exception
1400   = io (putStrLn ("*** Exception: " ++ show other_exception))
1401
1402 -----------------------------------------------------------------------------
1403 -- recursive exception handlers
1404
1405 -- Don't forget to unblock async exceptions in the handler, or if we're
1406 -- in an exception loop (eg. let a = error a in a) the ^C exception
1407 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1408
1409 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1410 ghciHandle h (GHCi m) = GHCi $ \s ->
1411    Exception.catch (m s)
1412         (\e -> unGHCi (ghciUnblock (h e)) s)
1413
1414 ghciUnblock :: GHCi a -> GHCi a
1415 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1416
1417
1418 -- ----------------------------------------------------------------------------
1419 -- Utils
1420
1421 expandPath :: String -> GHCi String
1422 expandPath path =
1423   case dropWhile isSpace path of
1424    ('~':d) -> do
1425         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1426         return (tilde ++ '/':d)
1427    other ->
1428         return other
1429
1430 -- ----------------------------------------------------------------------------
1431 -- Windows console setup
1432
1433 setUpConsole :: IO ()
1434 setUpConsole = do
1435 #ifdef mingw32_HOST_OS
1436         -- On Windows we need to set a known code page, otherwise the characters
1437         -- we read from the console will be be in some strange encoding, and
1438         -- similarly for characters we write to the console.
1439         --
1440         -- At the moment, GHCi pretends all input is Latin-1.  In the
1441         -- future we should support UTF-8, but for now we set the code pages
1442         -- to Latin-1.
1443         --
1444         -- It seems you have to set the font in the console window to
1445         -- a Unicode font in order for output to work properly,
1446         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1447         -- (see MSDN for SetConsoleOutputCP()).
1448         --
1449         setConsoleCP 28591       -- ISO Latin-1
1450         setConsoleOutputCP 28591 -- ISO Latin-1
1451 #endif
1452         return ()
1453
1454 -- commands for debugger
1455 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1456
1457 stepCmd :: String -> GHCi Bool
1458 stepCmd [] = doContinue setStepFlag
1459 stepCmd expression = do
1460    io $ setStepFlag
1461    runCommand expression
1462
1463 continueCmd :: String -> GHCi Bool
1464 continueCmd [] = doContinue $ return ()
1465 continueCmd other = do
1466    io $ putStrLn "The continue command accepts no arguments."
1467    return False
1468
1469 doContinue :: IO () -> GHCi Bool
1470 doContinue actionBeforeCont = do
1471    resumeAction <- popResume
1472    case resumeAction of
1473       Nothing -> do
1474          io $ putStrLn "There is no computation running."
1475          return False
1476       Just (_,_,handle) -> do
1477          io $ actionBeforeCont
1478          session <- getSession
1479          runResult <- io $ GHC.resume session handle
1480          names <- switchOnRunResult runResult
1481          finishEvalExpr names
1482          return False
1483
1484 deleteCmd :: String -> GHCi Bool
1485 deleteCmd argLine = do
1486    deleteSwitch $ words argLine
1487    return False
1488    where
1489    deleteSwitch :: [String] -> GHCi ()
1490    deleteSwitch [] =
1491       io $ putStrLn "The delete command requires at least one argument."
1492    -- delete all break points
1493    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1494    deleteSwitch idents = do
1495       mapM_ deleteOneBreak idents
1496       where
1497       deleteOneBreak :: String -> GHCi ()
1498       deleteOneBreak str
1499          | all isDigit str = deleteBreak (read str)
1500          | otherwise = return ()
1501
1502 -- handle the "break" command
1503 breakCmd :: String -> GHCi Bool
1504 breakCmd argLine = do
1505    session <- getSession
1506    breakSwitch session $ words argLine
1507    return False
1508
1509 breakSwitch :: Session -> [String] -> GHCi ()
1510 breakSwitch _session [] = do
1511    io $ putStrLn "The break command requires at least one argument."
1512 breakSwitch session args@(arg1:rest)
1513    | looksLikeModuleName arg1 = do
1514         mod <- wantInterpretedModule session arg1
1515         breakByModule session mod rest
1516    | all isDigit arg1 = do
1517         (toplevel, _) <- io $ GHC.getContext session
1518         case toplevel of
1519            (mod : _) -> breakByModuleLine mod (read arg1) rest
1520            [] -> do
1521               io $ putStrLn "Cannot find default module for breakpoint."
1522               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1523    | otherwise = do -- assume it's a name
1524         names <- io $ GHC.parseName session arg1
1525         case names of
1526           []    -> return ()
1527           (n:_) -> do
1528             let loc  = nameSrcLoc n
1529                 modl = nameModule n
1530             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1531             if not is_interpreted
1532                then noCanDo $ text "module " <> ppr modl <>
1533                               text " is not interpreted"
1534                else do
1535             if isGoodSrcLoc loc
1536                then findBreakAndSet (nameModule n) $
1537                          findBreakByCoord (srcLocLine loc, srcLocCol loc)
1538                else noCanDo $ text "can't find its location: " <>
1539                               ppr loc
1540            where
1541              noCanDo why = printForUser $
1542                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1543
1544
1545 wantInterpretedModule :: Session -> String -> GHCi Module
1546 wantInterpretedModule session str = do
1547    modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1548    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1549    when (not is_interpreted) $
1550        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1551    return modl
1552
1553 breakByModule :: Session -> Module -> [String] -> GHCi ()
1554 breakByModule session mod args@(arg1:rest)
1555    | all isDigit arg1 = do  -- looks like a line number
1556         breakByModuleLine mod (read arg1) rest
1557    | otherwise = io $ putStrLn "Invalid arguments to :break"
1558
1559 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1560 breakByModuleLine mod line args
1561    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1562    | [col] <- args, all isDigit col =
1563         findBreakAndSet mod $ findBreakByCoord (line, read col)
1564    | otherwise = io $ putStrLn "Invalid arguments to :break"
1565
1566 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1567 findBreakAndSet mod lookupTickTree = do
1568    tickArray <- getTickArray mod
1569    (breakArray, _) <- getModBreak mod
1570    case lookupTickTree tickArray of
1571       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1572       Just (tick, span) -> do
1573          success <- io $ setBreakFlag True breakArray tick
1574          session <- getSession
1575          if success
1576             then do
1577                (alreadySet, nm) <-
1578                      recordBreak $ BreakLocation
1579                              { breakModule = mod
1580                              , breakLoc = span
1581                              , breakTick = tick
1582                              }
1583                printForUser $
1584                   text "Breakpoint " <> ppr nm <>
1585                   if alreadySet
1586                      then text " was already set at " <> ppr span
1587                      else text " activated at " <> ppr span
1588             else do
1589             printForUser $ text "Breakpoint could not be activated at"
1590                                  <+> ppr span
1591
1592 -- When a line number is specified, the current policy for choosing
1593 -- the best breakpoint is this:
1594 --    - the leftmost complete subexpression on the specified line, or
1595 --    - the leftmost subexpression starting on the specified line, or
1596 --    - the rightmost subexpression enclosing the specified line
1597 --
1598 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1599 findBreakByLine line arr
1600   | not (inRange (bounds arr) line) = Nothing
1601   | otherwise =
1602     listToMaybe (sortBy leftmost complete)   `mplus`
1603     listToMaybe (sortBy leftmost incomplete) `mplus`
1604     listToMaybe (sortBy rightmost ticks)
1605   where
1606         ticks = arr ! line
1607
1608         starts_here = [ tick | tick@(nm,span) <- ticks,
1609                                srcSpanStartLine span == line ]
1610
1611         (complete,incomplete) = partition ends_here starts_here
1612             where ends_here (nm,span) = srcSpanEndLine span == line
1613
1614 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
1615 findBreakByCoord (line, col) arr
1616   | not (inRange (bounds arr) line) = Nothing
1617   | otherwise =
1618     listToMaybe (sortBy rightmost contains)
1619   where
1620         ticks = arr ! line
1621
1622         -- the ticks that span this coordinate
1623         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
1624
1625 leftmost  (_,a) (_,b) = a `compare` b
1626 rightmost (_,a) (_,b) = b `compare` a
1627
1628 spans :: SrcSpan -> (Int,Int) -> Bool
1629 spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
1630    where loc = mkSrcLoc (srcSpanFile span) l c
1631
1632
1633 -- --------------------------------------------------------------------------
1634 -- Tick arrays
1635
1636 getTickArray :: Module -> GHCi TickArray
1637 getTickArray modl = do
1638    st <- getGHCiState
1639    let arrmap = tickarrays st
1640    case lookupModuleEnv arrmap modl of
1641       Just arr -> return arr
1642       Nothing  -> do
1643         (breakArray, ticks) <- getModBreak modl
1644         let arr = mkTickArray (assocs ticks)
1645         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1646         return arr
1647
1648 discardTickArrays :: GHCi ()
1649 discardTickArrays = do
1650    st <- getGHCiState
1651    setGHCiState st{tickarrays = emptyModuleEnv}
1652
1653 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1654 mkTickArray ticks
1655   = accumArray (flip (:)) [] (1, max_line)
1656         [ (line, (nm,span)) | (nm,span) <- ticks,
1657                               line <- srcSpanLines span ]
1658     where
1659         max_line = maximum (map srcSpanEndLine (map snd ticks))
1660         srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
1661
1662 getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
1663 getModBreak mod = do
1664    session <- getSession
1665    Just mod_info <- io $ GHC.getModuleInfo session mod
1666    let modBreaks  = GHC.modInfoModBreaks mod_info
1667    let array      = GHC.modBreaks_flags modBreaks
1668    let ticks      = GHC.modBreaks_locs  modBreaks
1669    return (array, ticks)
1670
1671 lookupModule :: Session -> String -> GHCi Module
1672 lookupModule session modName
1673    = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1674
1675 setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool
1676 setBreakFlag toggle array index
1677    | toggle    = setBreakOn array index
1678    | otherwise = setBreakOff array index
1679
1680
1681 {- these should probably go to the GHC API at some point -}
1682 enableBreakPoint  :: Session -> Module -> Int -> IO ()
1683 enableBreakPoint session mod index = return ()
1684
1685 disableBreakPoint :: Session -> Module -> Int -> IO ()
1686 disableBreakPoint session mod index = return ()
1687
1688 activeBreakPoints :: Session -> IO [(Module,Int)]
1689 activeBreakPoints session = return []
1690
1691 enableSingleStep  :: Session -> IO ()
1692 enableSingleStep session = return ()
1693
1694 disableSingleStep :: Session -> IO ()
1695 disableSingleStep session = return ()