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