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