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