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, Id )
  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                let namesSorted = sortBy compareNames names
 635                tythings <- catMaybes `liftM`
 636                               io (mapM (GHC.lookupName session) namesSorted)
 637
 638                printTypeAndContents session [id | AnId id <- tythings]
 639                maybe (return ()) runBreakCmd mb_info
 640                -- run the command set with ":set stop <cmd>"
 641                st <- getGHCiState
 642                enqueueCommands [stop st]
 643                return ()
 644          | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
 645                         afterRunStmt step_here >> return ()
 646      _ -> return ()
 647
 648   flushInterpBuffers
 649   io installSignalHandlers
 650   b <- isOptionSet RevertCAFs
 651   io (when b revertCAFs)
 652
 653   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 654
 655 runBreakCmd :: GHC.BreakInfo -> GHCi ()
 656 runBreakCmd info = do
 657   let mod = GHC.breakInfo_module info
 658       nm  = GHC.breakInfo_number info
 659   st <- getGHCiState
 660   case  [ loc | (_,loc) <- breaks st,
 661                 breakModule loc == mod, breakTick loc == nm ] of
 662         []  -> return ()
 663         loc:_ | null cmd  -> return ()
 664               | otherwise -> do enqueueCommands [cmd]; return ()
 665               where cmd = onBreakCmd loc
 666
 667 printTypeOfNames :: Session -> [Name] -> GHCi ()
 668 printTypeOfNames session names
 669  = mapM_ (printTypeOfName session) $ sortBy compareNames names
 670
 671 compareNames :: Name -> Name -> Ordering
 672 n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
 673     where compareWith n = (getOccString n, getSrcSpan n)
 674
 675 printTypeOfName :: Session -> Name -> GHCi ()
 676 printTypeOfName session n
 677    = do maybe_tything <- io (GHC.lookupName session n)
 678         case maybe_tything of
 679             Nothing    -> return ()
 680             Just thing -> printTyThing thing
 681
 682 printTypeAndContents :: Session -> [Id] -> GHCi ()
 683 printTypeAndContents session ids = do
 684   dflags <- getDynFlags
 685   let pefas     = dopt Opt_PrintExplicitForalls dflags
 686       pcontents = dopt Opt_PrintBindContents dflags
 687   if pcontents
 688     then do
 689       let depthBound = 100
 690       terms      <- mapM (io . GHC.obtainTermB session depthBound False) ids
 691       docs_terms <- mapM (io . showTerm session) terms
 692       printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
 693                                     (map (pprTyThing pefas . AnId) ids)
 694                                     docs_terms
 695     else printForUser $ vcat $ map (pprTyThing pefas . AnId) ids
 696
 697
 698 specialCommand :: String -> GHCi Bool
 699 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 700 specialCommand str = do
 701   let (cmd,rest) = break isSpace str
 702   maybe_cmd <- io (lookupCommand cmd)
 703   case maybe_cmd of
 704     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 705                                     ++ shortHelpText) >> return False)
 706     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 707
 708 lookupCommand :: String -> IO (Maybe Command)
 709 lookupCommand str = do
 710   macros <- readIORef macros_ref
 711   let cmds = builtin_commands ++ macros
 712   -- look for exact match first, then the first prefix match
 713   case [ c | c <- cmds, str == cmdName c ] of
 714      c:_ -> return (Just c)
 715      [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
 716                 [] -> return Nothing
 717                 c:_ -> return (Just c)
 718
 719
 720 getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
 721 getCurrentBreakSpan = do
 722   session <- getSession
 723   resumes <- io $ GHC.getResumeContext session
 724   case resumes of
 725     [] -> return Nothing
 726     (r:_) -> do
 727         let ix = GHC.resumeHistoryIx r
 728         if ix == 0
 729            then return (Just (GHC.resumeSpan r))
 730            else do
 731                 let hist = GHC.resumeHistory r !! (ix-1)
 732                 span <- io $ GHC.getHistorySpan session hist
 733                 return (Just span)
 734
 735 getCurrentBreakModule :: GHCi (Maybe Module)
 736 getCurrentBreakModule = do
 737   session <- getSession
 738   resumes <- io $ GHC.getResumeContext session
 739   case resumes of
 740     [] -> return Nothing
 741     (r:_) -> do
 742         let ix = GHC.resumeHistoryIx r
 743         if ix == 0
 744            then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
 745            else do
 746                 let hist = GHC.resumeHistory r !! (ix-1)
 747                 return $ Just $ GHC.getHistoryModule  hist
 748
 749 -----------------------------------------------------------------------------
 750 -- Commands
 751
 752 noArgs :: GHCi () -> String -> GHCi ()
 753 noArgs m "" = m
 754 noArgs _ _  = io $ putStrLn "This command takes no arguments"
 755
 756 help :: String -> GHCi ()
 757 help _ = io (putStr helpText)
 758
 759 info :: String -> GHCi ()
 760 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 761 info s  = do { let names = words s
 762              ; session <- getSession
 763              ; dflags <- getDynFlags
 764              ; let pefas = dopt Opt_PrintExplicitForalls dflags
 765              ; mapM_ (infoThing pefas session) names }
 766   where
 767     infoThing pefas session str = io $ do
 768         names     <- GHC.parseName session str
 769         mb_stuffs <- mapM (GHC.getInfo session) names
 770         let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
 771         unqual <- GHC.getPrintUnqual session
 772         putStrLn (showSDocForUser unqual $
 773                    vcat (intersperse (text "") $
 774                          map (pprInfo pefas) filtered))
 775
 776   -- Filter out names whose parent is also there Good
 777   -- example is '[]', which is both a type and data
 778   -- constructor in the same type
 779 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
 780 filterOutChildren get_thing xs
 781   = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
 782   where
 783     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
 784
 785 pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
 786 pprInfo pefas (thing, fixity, insts)
 787   =  pprTyThingInContextLoc pefas thing
 788   $$ show_fixity fixity
 789   $$ vcat (map GHC.pprInstance insts)
 790   where
 791     show_fixity fix
 792         | fix == GHC.defaultFixity = empty
 793         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 794
 795 runMain :: String -> GHCi ()
 796 runMain args = do
 797   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 798   enqueueCommands  ['[': ss ++ "] `System.Environment.withArgs` main"]
 799
 800 addModule :: [FilePath] -> GHCi ()
 801 addModule files = do
 802   io (revertCAFs)                       -- always revert CAFs on load/add.
 803   files <- mapM expandPath files
 804   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 805   session <- getSession
 806   io (mapM_ (GHC.addTarget session) targets)
 807   ok <- io (GHC.load session LoadAllTargets)
 808   afterLoad ok session Nothing
 809
 810 changeDirectory :: String -> GHCi ()
 811 changeDirectory dir = do
 812   session <- getSession
 813   graph <- io (GHC.getModuleGraph session)
 814   when (not (null graph)) $
 815         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 816   io (GHC.setTargets session [])
 817   io (GHC.load session LoadAllTargets)
 818   setContextAfterLoad session []
 819   io (GHC.workingDirectoryChanged session)
 820   dir <- expandPath dir
 821   io (setCurrentDirectory dir)
 822
 823 editFile :: String -> GHCi ()
 824 editFile str =
 825   do file <- if null str then chooseEditFile else return str
 826      st <- getGHCiState
 827      let cmd = editor st
 828      when (null cmd)
 829        $ throwDyn (CmdLineError "editor not set, use :set editor")
 830      io $ system (cmd ++ ' ':file)
 831      return ()
 832
 833 -- The user didn't specify a file so we pick one for them.
 834 -- Our strategy is to pick the first module that failed to load,
 835 -- or otherwise the first target.
 836 --
 837 -- XXX: Can we figure out what happened if the depndecy analysis fails
 838 --      (e.g., because the porgrammeer mistyped the name of a module)?
 839 -- XXX: Can we figure out the location of an error to pass to the editor?
 840 -- XXX: if we could figure out the list of errors that occured during the
 841 -- last load/reaload, then we could start the editor focused on the first
 842 -- of those.
 843 chooseEditFile :: GHCi String
 844 chooseEditFile =
 845   do session <- getSession
 846      let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
 847
 848      graph <- io (GHC.getModuleGraph session)
 849      failed_graph <- filterM hasFailed graph
 850      let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
 851          pick xs  = case xs of
 852                       x : _ -> GHC.ml_hs_file (GHC.ms_location x)
 853                       _     -> Nothing
 854
 855      case pick (order failed_graph) of
 856        Just file -> return file
 857        Nothing   ->
 858          do targets <- io (GHC.getTargets session)
 859             case msum (map fromTarget targets) of
 860               Just file -> return file
 861               Nothing   -> throwDyn (CmdLineError "No files to edit.")
 862
 863   where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
 864         fromTarget _ = Nothing -- when would we get a module target?
 865
 866 defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
 867 defineMacro overwrite s = do
 868   let (macro_name, definition) = break isSpace s
 869   macros <- io (readIORef macros_ref)
 870   let defined = map cmdName macros
 871   if (null macro_name)
 872         then if null defined
 873                 then io $ putStrLn "no macros defined"
 874                 else io $ putStr ("the following macros are defined:\n" ++
 875                                   unlines defined)
 876         else do
 877   if (not overwrite && macro_name `elem` defined)
 878         then throwDyn (CmdLineError
 879                 ("macro '" ++ macro_name ++ "' is already defined"))
 880         else do
 881
 882   let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
 883
 884   -- give the expression a type signature, so we can be sure we're getting
 885   -- something of the right type.
 886   let new_expr = '(' : definition ++ ") :: String -> IO String"
 887
 888   -- compile the expression
 889   cms <- getSession
 890   maybe_hv <- io (GHC.compileExpr cms new_expr)
 891   case maybe_hv of
 892      Nothing -> return ()
 893      Just hv -> io (writeIORef macros_ref --
 894                     (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
 895
 896 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 897 runMacro fun s = do
 898   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 899   enqueueCommands (lines str)
 900   return False
 901
 902 undefineMacro :: String -> GHCi ()
 903 undefineMacro str = mapM_ undef (words str)
 904  where undef macro_name = do
 905         cmds <- io (readIORef macros_ref)
 906         if (macro_name `notElem` map cmdName cmds)
 907            then throwDyn (CmdLineError
 908                 ("macro '" ++ macro_name ++ "' is not defined"))
 909            else do
 910             io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
 911
 912 cmdCmd :: String -> GHCi ()
 913 cmdCmd str = do
 914   let expr = '(' : str ++ ") :: IO String"
 915   session <- getSession
 916   maybe_hv <- io (GHC.compileExpr session expr)
 917   case maybe_hv of
 918     Nothing -> return ()
 919     Just hv -> do
 920         cmds <- io $ (unsafeCoerce# hv :: IO String)
 921         enqueueCommands (lines cmds)
 922         return ()
 923
 924 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 925 loadModule fs = timeIt (loadModule' fs)
 926
 927 loadModule_ :: [FilePath] -> GHCi ()
 928 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 929
 930 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 931 loadModule' files = do
 932   session <- getSession
 933
 934   -- unload first
 935   discardActiveBreakPoints
 936   io (GHC.setTargets session [])
 937   io (GHC.load session LoadAllTargets)
 938
 939   -- expand tildes
 940   let (filenames, phases) = unzip files
 941   exp_filenames <- mapM expandPath filenames
 942   let files' = zip exp_filenames phases
 943   targets <- io (mapM (uncurry GHC.guessTarget) files')
 944
 945   -- NOTE: we used to do the dependency anal first, so that if it
 946   -- fails we didn't throw away the current set of modules.  This would
 947   -- require some re-working of the GHC interface, so we'll leave it
 948   -- as a ToDo for now.
 949
 950   io (GHC.setTargets session targets)
 951   doLoad session False LoadAllTargets
 952
 953 checkModule :: String -> GHCi ()
 954 checkModule m = do
 955   let modl = GHC.mkModuleName m
 956   session <- getSession
 957   result <- io (GHC.checkModule session modl False)
 958   case result of
 959     Nothing -> io $ putStrLn "Nothing"
 960     Just r  -> io $ putStrLn (showSDoc (
 961         case GHC.checkedModuleInfo r of
 962            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 963                 let
 964                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 965                 in
 966                         (text "global names: " <+> ppr global) $$
 967                         (text "local  names: " <+> ppr local)
 968            _ -> empty))
 969   afterLoad (successIf (isJust result)) session Nothing
 970
 971 reloadModule :: String -> GHCi ()
 972 reloadModule m = do
 973   session <- getSession
 974   doLoad session True $ if null m then LoadAllTargets
 975                                   else LoadUpTo (GHC.mkModuleName m)
 976   return ()
 977
 978 doLoad :: Session -> Bool -> LoadHowMuch -> GHCi SuccessFlag
 979 doLoad session retain_context howmuch = do
 980   -- turn off breakpoints before we load: we can't turn them off later, because
 981   -- the ModBreaks will have gone away.
 982   discardActiveBreakPoints
 983   context <- io $ GHC.getContext session
 984   ok <- io (GHC.load session howmuch)
 985   afterLoad ok session (if retain_context then Just context else Nothing)
 986   return ok
 987
 988 afterLoad :: SuccessFlag -> Session -> Maybe ([Module],[Module]) -> GHCi ()
 989 afterLoad ok session maybe_context = do
 990   io (revertCAFs)  -- always revert CAFs on load.
 991   discardTickArrays
 992   loaded_mods <- getLoadedModules session
 993
 994   -- try to retain the old module context for :reload.  This might
 995   -- not be possible, for example if some modules have gone away, so
 996   -- we attempt to set the same context, backing off to the default
 997   -- context if that fails.
 998   case maybe_context of
 999      Nothing -> setContextAfterLoad session loaded_mods
1000      Just (as,bs) -> do
1001         r <- io $ Exception.try (GHC.setContext session as bs)
1002         case r of
1003            Left _err -> setContextAfterLoad session loaded_mods
1004            Right _   -> return ()
1005
1006   modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
1007
1008 setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi ()
1009 setContextAfterLoad session [] = do
1010   prel_mod <- getPrelude
1011   io (GHC.setContext session [] [prel_mod])
1012 setContextAfterLoad session ms = do
1013   -- load a target if one is available, otherwise load the topmost module.
1014   targets <- io (GHC.getTargets session)
1015   case [ m | Just m <- map (findTarget ms) targets ] of
1016         []    ->
1017           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
1018           load_this (last graph')
1019         (m:_) ->
1020           load_this m
1021  where
1022    findTarget ms t
1023     = case filter (`matches` t) ms of
1024         []    -> Nothing
1025         (m:_) -> Just m
1026
1027    summary `matches` Target (TargetModule m) _
1028         = GHC.ms_mod_name summary == m
1029    summary `matches` Target (TargetFile f _) _
1030         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
1031    _ `matches` _
1032         = False
1033
1034    load_this summary | m <- GHC.ms_mod summary = do
1035         b <- io (GHC.moduleIsInterpreted session m)
1036         if b then io (GHC.setContext session [m] [])
1037              else do
1038                    prel_mod <- getPrelude
1039                    io (GHC.setContext session []  [prel_mod,m])
1040
1041
1042 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
1043 modulesLoadedMsg ok mods = do
1044   dflags <- getDynFlags
1045   when (verbosity dflags > 0) $ do
1046    let mod_commas
1047         | null mods = text "none."
1048         | otherwise = hsep (
1049             punctuate comma (map ppr mods)) <> text "."
1050    case ok of
1051     Failed ->
1052        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
1053     Succeeded  ->
1054        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
1055
1056
1057 typeOfExpr :: String -> GHCi ()
1058 typeOfExpr str
1059   = do cms <- getSession
1060        maybe_ty <- io (GHC.exprType cms str)
1061        case maybe_ty of
1062           Nothing -> return ()
1063           Just ty -> do dflags <- getDynFlags
1064                         let pefas = dopt Opt_PrintExplicitForalls dflags
1065                         printForUser $ text str <+> dcolon
1066                                         <+> pprTypeForUser pefas ty
1067
1068 kindOfType :: String -> GHCi ()
1069 kindOfType str
1070   = do cms <- getSession
1071        maybe_ty <- io (GHC.typeKind cms str)
1072        case maybe_ty of
1073           Nothing    -> return ()
1074           Just ty    -> printForUser $ text str <+> dcolon <+> ppr ty
1075
1076 quit :: String -> GHCi Bool
1077 quit _ = return True
1078
1079 shellEscape :: String -> GHCi Bool
1080 shellEscape str = io (system str >> return False)
1081
1082 -----------------------------------------------------------------------------
1083 -- Browsing a module's contents
1084
1085 browseCmd :: Bool -> String -> GHCi ()
1086 browseCmd bang m =
1087   case words m of
1088     ['*':s] | looksLikeModuleName s -> do
1089         m <-  wantInterpretedModule s
1090         browseModule bang m False
1091     [s] | looksLikeModuleName s -> do
1092         m <- lookupModule s
1093         browseModule bang m True
1094     [] -> do
1095         s <- getSession
1096         (as,bs) <- io $ GHC.getContext s
1097                 -- Guess which module the user wants to browse.  Pick
1098                 -- modules that are interpreted first.  The most
1099                 -- recently-added module occurs last, it seems.
1100         case (as,bs) of
1101           (as@(_:_), _)   -> browseModule bang (last as) True
1102           ([],  bs@(_:_)) -> browseModule bang (last bs) True
1103           ([],  [])  -> throwDyn (CmdLineError ":browse: no current module")
1104     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
1105
1106 -- without bang, show items in context of their parents and omit children
1107 -- with bang, show class methods and data constructors separately, and
1108 --            indicate import modules, to aid qualifying unqualified names
1109 -- with sorted, sort items alphabetically
1110 browseModule :: Bool -> Module -> Bool -> GHCi ()
1111 browseModule bang modl exports_only = do
1112   s <- getSession
1113   -- Temporarily set the context to the module we're interested in,
1114   -- just so we can get an appropriate PrintUnqualified
1115   (as,bs) <- io (GHC.getContext s)
1116   prel_mod <- getPrelude
1117   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1118                       else GHC.setContext s [modl] [])
1119   unqual <- io (GHC.getPrintUnqual s)
1120   io (GHC.setContext s as bs)
1121
1122   mb_mod_info <- io $ GHC.getModuleInfo s modl
1123   case mb_mod_info of
1124     Nothing -> throwDyn (CmdLineError ("unknown module: " ++
1125                                 GHC.moduleNameString (GHC.moduleName modl)))
1126     Just mod_info -> do
1127         dflags <- getDynFlags
1128         let names
1129                | exports_only = GHC.modInfoExports mod_info
1130                | otherwise    = GHC.modInfoTopLevelScope mod_info
1131                                 `orElse` []
1132
1133                 -- sort alphabetically name, but putting
1134                 -- locally-defined identifiers first.
1135                 -- We would like to improve this; see #1799.
1136             sorted_names = loc_sort local ++ occ_sort external
1137                 where
1138                 (local,external) = partition ((==modl) . nameModule) names
1139                 occ_sort = sortBy (compare `on` nameOccName)
1140                 -- try to sort by src location.  If the first name in
1141                 -- our list has a good source location, then they all should.
1142                 loc_sort names
1143                       | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
1144                       = sortBy (compare `on` nameSrcSpan) names
1145                       | otherwise
1146                       = occ_sort names
1147
1148         mb_things <- io $ mapM (GHC.lookupName s) sorted_names
1149         let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
1150
1151         rdr_env <- io $ GHC.getGRE s
1152
1153         let pefas              = dopt Opt_PrintExplicitForalls dflags
1154             things | bang      = catMaybes mb_things
1155                    | otherwise = filtered_things
1156             pretty | bang      = pprTyThing
1157                    | otherwise = pprTyThingInContext
1158
1159             labels  [] = text "-- not currently imported"
1160             labels  l  = text $ intercalate "\n" $ map qualifier l
1161             qualifier  = maybe "-- defined locally"
1162                              (("-- imported from "++) . intercalate ", "
1163                                . map GHC.moduleNameString)
1164             importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
1165             modNames   = map (importInfo . GHC.getName) things
1166
1167             -- annotate groups of imports with their import modules
1168             -- the default ordering is somewhat arbitrary, so we group
1169             -- by header and sort groups; the names themselves should
1170             -- really come in order of source appearance.. (trac #1799)
1171             annotate mts = concatMap (\(m,ts)->labels m:ts)
1172                          $ sortBy cmpQualifiers $ group mts
1173               where cmpQualifiers =
1174                       compare `on` (map (fmap (map moduleNameFS)) . fst)
1175             group []            = []
1176             group mts@((m,_):_) = (m,map snd g) : group ng
1177               where (g,ng) = partition ((==m).fst) mts
1178
1179         let prettyThings = map (pretty pefas) things
1180             prettyThings' | bang      = annotate $ zip modNames prettyThings
1181                           | otherwise = prettyThings
1182         io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
1183         -- ToDo: modInfoInstances currently throws an exception for
1184         -- package modules.  When it works, we can do this:
1185         --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1186
1187 -----------------------------------------------------------------------------
1188 -- Setting the module context
1189
1190 setContext :: String -> GHCi ()
1191 setContext str
1192   | all sensible mods = fn mods
1193   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1194   where
1195     (fn, mods) = case str of
1196                         '+':stuff -> (addToContext,      words stuff)
1197                         '-':stuff -> (removeFromContext, words stuff)
1198                         stuff     -> (newContext,        words stuff)
1199
1200     sensible ('*':m) = looksLikeModuleName m
1201     sensible m       = looksLikeModuleName m
1202
1203 separate :: Session -> [String] -> [Module] -> [Module]
1204         -> GHCi ([Module],[Module])
1205 separate _       []             as bs = return (as,bs)
1206 separate session (('*':str):ms) as bs = do
1207   m <- wantInterpretedModule str
1208   separate session ms (m:as) bs
1209 separate session (str:ms) as bs = do
1210   m <- lookupModule str
1211   separate session ms as (m:bs)
1212
1213 newContext :: [String] -> GHCi ()
1214 newContext strs = do
1215   s <- getSession
1216   (as,bs) <- separate s strs [] []
1217   prel_mod <- getPrelude
1218   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1219   io $ GHC.setContext s as bs'
1220
1221
1222 addToContext :: [String] -> GHCi ()
1223 addToContext strs = do
1224   s <- getSession
1225   (as,bs) <- io $ GHC.getContext s
1226
1227   (new_as,new_bs) <- separate s strs [] []
1228
1229   let as_to_add = new_as \\ (as ++ bs)
1230       bs_to_add = new_bs \\ (as ++ bs)
1231
1232   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1233
1234
1235 removeFromContext :: [String] -> GHCi ()
1236 removeFromContext strs = do
1237   s <- getSession
1238   (as,bs) <- io $ GHC.getContext s
1239
1240   (as_to_remove,bs_to_remove) <- separate s strs [] []
1241
1242   let as' = as \\ (as_to_remove ++ bs_to_remove)
1243       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1244
1245   io $ GHC.setContext s as' bs'
1246
1247 ----------------------------------------------------------------------------
1248 -- Code for `:set'
1249
1250 -- set options in the interpreter.  Syntax is exactly the same as the
1251 -- ghc command line, except that certain options aren't available (-C,
1252 -- -E etc.)
1253 --
1254 -- This is pretty fragile: most options won't work as expected.  ToDo:
1255 -- figure out which ones & disallow them.
1256
1257 setCmd :: String -> GHCi ()
1258 setCmd ""
1259   = do st <- getGHCiState
1260        let opts = options st
1261        io $ putStrLn (showSDoc (
1262               text "options currently set: " <>
1263               if null opts
1264                    then text "none."
1265                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1266            ))
1267        dflags <- getDynFlags
1268        io $ putStrLn (showSDoc (
1269           vcat (text "GHCi-specific dynamic flag settings:"
1270                :map (flagSetting dflags) ghciFlags)
1271           ))
1272        io $ putStrLn (showSDoc (
1273           vcat (text "other dynamic, non-language, flag settings:"
1274                :map (flagSetting dflags) nonLanguageDynFlags)
1275           ))
1276   where flagSetting dflags (str,f)
1277           | dopt f dflags = text "  " <> text "-f"    <> text str
1278           | otherwise     = text "  " <> text "-fno-" <> text str
1279         (ghciFlags,others)  = partition (\(_,f)->f `elem` flags)
1280                                         DynFlags.fFlags
1281         nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
1282                                      others
1283         flags = [Opt_PrintExplicitForalls
1284                 ,Opt_PrintBindResult
1285                 ,Opt_BreakOnException
1286                 ,Opt_BreakOnError
1287                 ,Opt_PrintEvldWithShow
1288                 ]
1289 setCmd str
1290   = case toArgs str of
1291         ("args":args) -> setArgs args
1292         ("prog":prog) -> setProg prog
1293         ("prompt":_)  -> setPrompt (after 6)
1294         ("editor":_)  -> setEditor (after 6)
1295         ("stop":_)    -> setStop (after 4)
1296         wds -> setOptions wds
1297    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1298
1299 setArgs, setProg, setOptions :: [String] -> GHCi ()
1300 setEditor, setStop, setPrompt :: String -> GHCi ()
1301
1302 setArgs args = do
1303   st <- getGHCiState
1304   setGHCiState st{ args = args }
1305
1306 setProg [prog] = do
1307   st <- getGHCiState
1308   setGHCiState st{ progname = prog }
1309 setProg _ = do
1310   io (hPutStrLn stderr "syntax: :set prog <progname>")
1311
1312 setEditor cmd = do
1313   st <- getGHCiState
1314   setGHCiState st{ editor = cmd }
1315
1316 setStop str@(c:_) | isDigit c
1317   = do let (nm_str,rest) = break (not.isDigit) str
1318            nm = read nm_str
1319        st <- getGHCiState
1320        let old_breaks = breaks st
1321        if all ((/= nm) . fst) old_breaks
1322               then printForUser (text "Breakpoint" <+> ppr nm <+>
1323                                  text "does not exist")
1324               else do
1325        let new_breaks = map fn old_breaks
1326            fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
1327                       | otherwise = (i,loc)
1328        setGHCiState st{ breaks = new_breaks }
1329 setStop cmd = do
1330   st <- getGHCiState
1331   setGHCiState st{ stop = cmd }
1332
1333 setPrompt value = do
1334   st <- getGHCiState
1335   if null value
1336       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1337       else setGHCiState st{ prompt = remQuotes value }
1338   where
1339      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1340      remQuotes x = x
1341
1342 setOptions wds =
1343    do -- first, deal with the GHCi opts (+s, +t, etc.)
1344       let (plus_opts, minus_opts)  = partitionWith isPlus wds
1345       mapM_ setOpt plus_opts
1346       -- then, dynamic flags
1347       newDynFlags minus_opts
1348
1349 newDynFlags :: [String] -> GHCi ()
1350 newDynFlags minus_opts = do
1351       dflags <- getDynFlags
1352       let pkg_flags = packageFlags dflags
1353       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1354
1355       if (not (null leftovers))
1356                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1357                                                 unwords leftovers))
1358                 else return ()
1359
1360       new_pkgs <- setDynFlags dflags'
1361
1362       -- if the package flags changed, we should reset the context
1363       -- and link the new packages.
1364       dflags <- getDynFlags
1365       when (packageFlags dflags /= pkg_flags) $ do
1366         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1367         session <- getSession
1368         io (GHC.setTargets session [])
1369         io (GHC.load session LoadAllTargets)
1370         io (linkPackages dflags new_pkgs)
1371         setContextAfterLoad session []
1372       return ()
1373
1374
1375 unsetOptions :: String -> GHCi ()
1376 unsetOptions str
1377   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1378        let opts = words str
1379            (minus_opts, rest1) = partition isMinus opts
1380            (plus_opts, rest2)  = partitionWith isPlus rest1
1381
1382        if (not (null rest2))
1383           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1384           else do
1385
1386        mapM_ unsetOpt plus_opts
1387
1388        let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
1389            no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
1390
1391        no_flags <- mapM no_flag minus_opts
1392        newDynFlags no_flags
1393
1394 isMinus :: String -> Bool
1395 isMinus ('-':_) = True
1396 isMinus _ = False
1397
1398 isPlus :: String -> Either String String
1399 isPlus ('+':opt) = Left opt
1400 isPlus other     = Right other
1401
1402 setOpt, unsetOpt :: String -> GHCi ()
1403
1404 setOpt str
1405   = case strToGHCiOpt str of
1406         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1407         Just o  -> setOption o
1408
1409 unsetOpt str
1410   = case strToGHCiOpt str of
1411         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1412         Just o  -> unsetOption o
1413
1414 strToGHCiOpt :: String -> (Maybe GHCiOption)
1415 strToGHCiOpt "s" = Just ShowTiming
1416 strToGHCiOpt "t" = Just ShowType
1417 strToGHCiOpt "r" = Just RevertCAFs
1418 strToGHCiOpt _   = Nothing
1419
1420 optToStr :: GHCiOption -> String
1421 optToStr ShowTiming = "s"
1422 optToStr ShowType   = "t"
1423 optToStr RevertCAFs = "r"
1424
1425 -- ---------------------------------------------------------------------------
1426 -- code for `:show'
1427
1428 showCmd :: String -> GHCi ()
1429 showCmd str = do
1430   st <- getGHCiState
1431   case words str of
1432         ["args"]     -> io $ putStrLn (show (args st))
1433         ["prog"]     -> io $ putStrLn (show (progname st))
1434         ["prompt"]   -> io $ putStrLn (show (prompt st))
1435         ["editor"]   -> io $ putStrLn (show (editor st))
1436         ["stop"]     -> io $ putStrLn (show (stop st))
1437         ["modules" ] -> showModules
1438         ["bindings"] -> showBindings
1439         ["linker"]   -> io showLinkerState
1440         ["breaks"]   -> showBkptTable
1441         ["context"]  -> showContext
1442         ["packages"]  -> showPackages
1443         ["languages"]  -> showLanguages
1444         _ -> throwDyn (CmdLineError "syntax:  :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
1445
1446 showModules :: GHCi ()
1447 showModules = do
1448   session <- getSession
1449   loaded_mods <- getLoadedModules session
1450         -- we want *loaded* modules only, see #1734
1451   let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
1452   mapM_ show_one loaded_mods
1453
1454 getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
1455 getLoadedModules session = do
1456   graph <- io (GHC.getModuleGraph session)
1457   filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
1458
1459 showBindings :: GHCi ()
1460 showBindings = do
1461   s <- getSession
1462   bindings <- io (GHC.getBindings s)
1463   printTypeAndContents s [ id | AnId id <- sortBy compareTyThings bindings]
1464
1465 compareTyThings :: TyThing -> TyThing -> Ordering
1466 t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
1467
1468 printTyThing :: TyThing -> GHCi ()
1469 printTyThing tyth = do dflags <- getDynFlags
1470                        let pefas = dopt Opt_PrintExplicitForalls dflags
1471                        printForUser (pprTyThing pefas tyth)
1472
1473 showBkptTable :: GHCi ()
1474 showBkptTable = do
1475   st <- getGHCiState
1476   printForUser $ prettyLocations (breaks st)
1477
1478 showContext :: GHCi ()
1479 showContext = do
1480    session <- getSession
1481    resumes <- io $ GHC.getResumeContext session
1482    printForUser $ vcat (map pp_resume (reverse resumes))
1483   where
1484    pp_resume resume =
1485         ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
1486         $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
1487
1488 showPackages :: GHCi ()
1489 showPackages = do
1490   pkg_flags <- fmap packageFlags getDynFlags
1491   io $ putStrLn $ showSDoc $ vcat $
1492     text ("active package flags:"++if null pkg_flags then " none" else "")
1493     : map showFlag pkg_flags
1494   pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
1495   io $ putStrLn $ showSDoc $ vcat $
1496     text "packages currently loaded:"
1497     : map (nest 2 . text . packageIdString) pkg_ids
1498   where showFlag (ExposePackage p) = text $ "  -package " ++ p
1499         showFlag (HidePackage p)   = text $ "  -hide-package " ++ p
1500         showFlag (IgnorePackage p) = text $ "  -ignore-package " ++ p
1501
1502 showLanguages :: GHCi ()
1503 showLanguages = do
1504    dflags <- getDynFlags
1505    io $ putStrLn $ showSDoc $ vcat $
1506       text "active language flags:" :
1507       [text ("  -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
1508
1509 -- -----------------------------------------------------------------------------
1510 -- Completion
1511
1512 completeNone :: String -> IO [String]
1513 completeNone _w = return []
1514
1515 completeMacro, completeIdentifier, completeModule,
1516     completeHomeModule, completeSetOptions, completeFilename,
1517     completeHomeModuleOrFile
1518     :: String -> IO [String]
1519
1520 #ifdef USE_READLINE
1521 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1522 completeWord w start end = do
1523   line <- Readline.getLineBuffer
1524   let line_words = words (dropWhile isSpace line)
1525   case w of
1526      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1527      _other
1528         | ((':':c) : _) <- line_words -> do
1529            maybe_cmd <- lookupCommand c
1530            let (n,w') = selectWord (words' 0 line)
1531            case maybe_cmd of
1532              Nothing -> return Nothing
1533              Just (_,_,False,complete) -> wrapCompleter complete w
1534              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1535                                                               return (map (drop n) rets)
1536                                          in wrapCompleter complete' w'
1537         | ("import" : _) <- line_words ->
1538                 wrapCompleter completeModule w
1539         | otherwise     -> do
1540                 --printf "complete %s, start = %d, end = %d\n" w start end
1541                 wrapCompleter completeIdentifier w
1542     where words' _ [] = []
1543           words' n str = let (w,r) = break isSpace str
1544                              (s,r') = span isSpace r
1545                          in (n,w):words' (n+length w+length s) r'
1546           -- In a Haskell expression we want to parse 'a-b' as three words
1547           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1548           -- only be a single word.
1549           selectWord [] = (0,w)
1550           selectWord ((offset,x):xs)
1551               | offset+length x >= start = (start-offset,take (end-offset) x)
1552               | otherwise = selectWord xs
1553
1554 completeCmd :: String -> IO [String]
1555 completeCmd w = do
1556   cmds <- readIORef macros_ref
1557   return (filter (w `isPrefixOf`) (map (':':)
1558              (map cmdName (builtin_commands ++ cmds))))
1559
1560 completeMacro w = do
1561   cmds <- readIORef macros_ref
1562   return (filter (w `isPrefixOf`) (map cmdName cmds))
1563
1564 completeIdentifier w = do
1565   s <- restoreSession
1566   rdrs <- GHC.getRdrNamesInScope s
1567   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1568
1569 completeModule w = do
1570   s <- restoreSession
1571   dflags <- GHC.getSessionDynFlags s
1572   let pkg_mods = allExposedModules dflags
1573   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1574
1575 completeHomeModule w = do
1576   s <- restoreSession
1577   g <- GHC.getModuleGraph s
1578   let home_mods = map GHC.ms_mod_name g
1579   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1580
1581 completeSetOptions w = do
1582   return (filter (w `isPrefixOf`) options)
1583     where options = "args":"prog":allFlags
1584
1585 completeFilename = Readline.filenameCompletionFunction
1586
1587 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1588
1589 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1590 unionComplete f1 f2 w = do
1591   s1 <- f1 w
1592   s2 <- f2 w
1593   return (s1 ++ s2)
1594
1595 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1596 wrapCompleter fun w =  do
1597   strs <- fun w
1598   case strs of
1599     []  -> return Nothing
1600     [x] -> return (Just (x,[]))
1601     xs  -> case getCommonPrefix xs of
1602                 ""   -> return (Just ("",xs))
1603                 pref -> return (Just (pref,xs))
1604
1605 getCommonPrefix :: [String] -> String
1606 getCommonPrefix [] = ""
1607 getCommonPrefix (s:ss) = foldl common s ss
1608   where common _s "" = ""
1609         common "" _s = ""
1610         common (c:cs) (d:ds)
1611            | c == d = c : common cs ds
1612            | otherwise = ""
1613
1614 allExposedModules :: DynFlags -> [ModuleName]
1615 allExposedModules dflags
1616  = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
1617  where
1618   pkg_db = pkgIdMap (pkgState dflags)
1619 #else
1620 completeMacro      = completeNone
1621 completeIdentifier = completeNone
1622 completeModule     = completeNone
1623 completeHomeModule = completeNone
1624 completeSetOptions = completeNone
1625 completeFilename   = completeNone
1626 completeHomeModuleOrFile=completeNone
1627 #endif
1628
1629 -- ---------------------------------------------------------------------------
1630 -- User code exception handling
1631
1632 -- This is the exception handler for exceptions generated by the
1633 -- user's code and exceptions coming from children sessions;
1634 -- it normally just prints out the exception.  The
1635 -- handler must be recursive, in case showing the exception causes
1636 -- more exceptions to be raised.
1637 --
1638 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1639 -- raising another exception.  We therefore don't put the recursive
1640 -- handler arond the flushing operation, so if stderr is closed
1641 -- GHCi will just die gracefully rather than going into an infinite loop.
1642 handler :: Exception -> GHCi Bool
1643
1644 handler exception = do
1645   flushInterpBuffers
1646   io installSignalHandlers
1647   ghciHandle handler (showException exception >> return False)
1648
1649 showException :: Exception -> GHCi ()
1650 showException (DynException dyn) =
1651   case fromDynamic dyn of
1652     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1653     Just Interrupted      -> io (putStrLn "Interrupted.")
1654     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1655     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1656     Just other_ghc_ex     -> io (print other_ghc_ex)
1657
1658 showException other_exception
1659   = io (putStrLn ("*** Exception: " ++ show other_exception))
1660
1661 -----------------------------------------------------------------------------
1662 -- recursive exception handlers
1663
1664 -- Don't forget to unblock async exceptions in the handler, or if we're
1665 -- in an exception loop (eg. let a = error a in a) the ^C exception
1666 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1667
1668 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1669 ghciHandle h (GHCi m) = GHCi $ \s ->
1670    Exception.catch (m s)
1671         (\e -> unGHCi (ghciUnblock (h e)) s)
1672
1673 ghciUnblock :: GHCi a -> GHCi a
1674 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1675
1676
1677 -- ----------------------------------------------------------------------------
1678 -- Utils
1679
1680 expandPath :: String -> GHCi String
1681 expandPath path =
1682   case dropWhile isSpace path of
1683    ('~':d) -> do
1684         tilde <- io getHomeDirectory -- will fail if HOME not defined
1685         return (tilde ++ '/':d)
1686    other ->
1687         return other
1688
1689 wantInterpretedModule :: String -> GHCi Module
1690 wantInterpretedModule str = do
1691    session <- getSession
1692    modl <- lookupModule str
1693    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1694    when (not is_interpreted) $
1695        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1696    return modl
1697
1698 wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
1699                               -> (Name -> GHCi ())
1700                               -> GHCi ()
1701 wantNameFromInterpretedModule noCanDo str and_then = do
1702    session <- getSession
1703    names <- io $ GHC.parseName session str
1704    case names of
1705       []    -> return ()
1706       (n:_) -> do
1707             let modl = GHC.nameModule n
1708             if not (GHC.isExternalName n)
1709                then noCanDo n $ ppr n <>
1710                                 text " is not defined in an interpreted module"
1711                else do
1712             is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1713             if not is_interpreted
1714                then noCanDo n $ text "module " <> ppr modl <>
1715                                 text " is not interpreted"
1716                else and_then n
1717
1718 -- ----------------------------------------------------------------------------
1719 -- Windows console setup
1720
1721 setUpConsole :: IO ()
1722 setUpConsole = do
1723 #ifdef mingw32_HOST_OS
1724         -- On Windows we need to set a known code page, otherwise the characters
1725         -- we read from the console will be be in some strange encoding, and
1726         -- similarly for characters we write to the console.
1727         --
1728         -- At the moment, GHCi pretends all input is Latin-1.  In the
1729         -- future we should support UTF-8, but for now we set the code
1730         -- pages to Latin-1.  Doing it this way does lead to problems,
1731         -- however: see bug #1649.
1732         --
1733         -- It seems you have to set the font in the console window to
1734         -- a Unicode font in order for output to work properly,
1735         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1736         -- (see MSDN for SetConsoleOutputCP()).
1737         --
1738         -- This call has been known to hang on some machines, see bug #1483
1739         --
1740         setConsoleCP 28591       -- ISO Latin-1
1741         setConsoleOutputCP 28591 -- ISO Latin-1
1742 #endif
1743         return ()
1744
1745 -- -----------------------------------------------------------------------------
1746 -- commands for debugger
1747
1748 sprintCmd, printCmd, forceCmd :: String -> GHCi ()
1749 sprintCmd = pprintCommand False False
1750 printCmd  = pprintCommand True False
1751 forceCmd  = pprintCommand False True
1752
1753 pprintCommand :: Bool -> Bool -> String -> GHCi ()
1754 pprintCommand bind force str = do
1755   session <- getSession
1756   io $ pprintClosureCommand session bind force str
1757
1758 stepCmd :: String -> GHCi ()
1759 stepCmd []         = doContinue (const True) GHC.SingleStep
1760 stepCmd expression = do runStmt expression GHC.SingleStep; return ()
1761
1762 stepLocalCmd :: String -> GHCi ()
1763 stepLocalCmd  [] = do
1764   mb_span <- getCurrentBreakSpan
1765   case mb_span of
1766     Nothing  -> stepCmd []
1767     Just loc -> do
1768        Just mod <- getCurrentBreakModule
1769        current_toplevel_decl <- enclosingTickSpan mod loc
1770        doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
1771
1772 stepLocalCmd expression = stepCmd expression
1773
1774 stepModuleCmd :: String -> GHCi ()
1775 stepModuleCmd  [] = do
1776   mb_span <- getCurrentBreakSpan
1777   case mb_span of
1778     Nothing  -> stepCmd []
1779     Just _ -> do
1780        Just span <- getCurrentBreakSpan
1781        let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
1782        doContinue f GHC.SingleStep
1783
1784 stepModuleCmd expression = stepCmd expression
1785
1786 -- | Returns the span of the largest tick containing the srcspan given
1787 enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
1788 enclosingTickSpan mod src = do
1789   ticks <- getTickArray mod
1790   let line = srcSpanStartLine src
1791   ASSERT (inRange (bounds ticks) line) do
1792   let enclosing_spans = [ span | (_,span) <- ticks ! line
1793                                , srcSpanEnd span >= srcSpanEnd src]
1794   return . head . sortBy leftmost_largest $ enclosing_spans
1795
1796 traceCmd :: String -> GHCi ()
1797 traceCmd []         = doContinue (const True) GHC.RunAndLogSteps
1798 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
1799
1800 continueCmd :: String -> GHCi ()
1801 continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
1802
1803 -- doContinue :: SingleStep -> GHCi ()
1804 doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
1805 doContinue pred step = do
1806   session <- getSession
1807   runResult <- io $ GHC.resume session step
1808   afterRunStmt pred runResult
1809   return ()
1810
1811 abandonCmd :: String -> GHCi ()
1812 abandonCmd = noArgs $ do
1813   s <- getSession
1814   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
1815   when (not b) $ io $ putStrLn "There is no computation running."
1816   return ()
1817
1818 deleteCmd :: String -> GHCi ()
1819 deleteCmd argLine = do
1820    deleteSwitch $ words argLine
1821    where
1822    deleteSwitch :: [String] -> GHCi ()
1823    deleteSwitch [] =
1824       io $ putStrLn "The delete command requires at least one argument."
1825    -- delete all break points
1826    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1827    deleteSwitch idents = do
1828       mapM_ deleteOneBreak idents
1829       where
1830       deleteOneBreak :: String -> GHCi ()
1831       deleteOneBreak str
1832          | all isDigit str = deleteBreak (read str)
1833          | otherwise = return ()
1834
1835 historyCmd :: String -> GHCi ()
1836 historyCmd arg
1837   | null arg        = history 20
1838   | all isDigit arg = history (read arg)
1839   | otherwise       = io $ putStrLn "Syntax:  :history [num]"
1840   where
1841   history num = do
1842     s <- getSession
1843     resumes <- io $ GHC.getResumeContext s
1844     case resumes of
1845       [] -> io $ putStrLn "Not stopped at a breakpoint"
1846       (r:_) -> do
1847         let hist = GHC.resumeHistory r
1848             (took,rest) = splitAt num hist
1849         spans <- mapM (io . GHC.getHistorySpan s) took
1850         let nums  = map (printf "-%-3d:") [(1::Int)..]
1851         let names = map GHC.historyEnclosingDecl took
1852         printForUser (vcat(zipWith3
1853                              (\x y z -> x <+> y <+> z)
1854                              (map text nums)
1855                              (map (bold . ppr) names)
1856                              (map (parens . ppr) spans)))
1857         io $ putStrLn $ if null rest then "<end of history>" else "..."
1858
1859 bold :: SDoc -> SDoc
1860 bold c | do_bold   = text start_bold <> c <> text end_bold
1861        | otherwise = c
1862
1863 backCmd :: String -> GHCi ()
1864 backCmd = noArgs $ do
1865   s <- getSession
1866   (names, _, span) <- io $ GHC.back s
1867   printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
1868   printTypeOfNames s names
1869    -- run the command set with ":set stop <cmd>"
1870   st <- getGHCiState
1871   enqueueCommands [stop st]
1872
1873 forwardCmd :: String -> GHCi ()
1874 forwardCmd = noArgs $ do
1875   s <- getSession
1876   (names, ix, span) <- io $ GHC.forward s
1877   printForUser $ (if (ix == 0)
1878                     then ptext SLIT("Stopped at")
1879                     else ptext SLIT("Logged breakpoint at")) <+> ppr span
1880   printTypeOfNames s names
1881    -- run the command set with ":set stop <cmd>"
1882   st <- getGHCiState
1883   enqueueCommands [stop st]
1884
1885 -- handle the "break" command
1886 breakCmd :: String -> GHCi ()
1887 breakCmd argLine = do
1888    session <- getSession
1889    breakSwitch session $ words argLine
1890
1891 breakSwitch :: Session -> [String] -> GHCi ()
1892 breakSwitch _session [] = do
1893    io $ putStrLn "The break command requires at least one argument."
1894 breakSwitch session (arg1:rest)
1895    | looksLikeModuleName arg1 = do
1896         mod <- wantInterpretedModule arg1
1897         breakByModule mod rest
1898    | all isDigit arg1 = do
1899         (toplevel, _) <- io $ GHC.getContext session
1900         case toplevel of
1901            (mod : _) -> breakByModuleLine mod (read arg1) rest
1902            [] -> do
1903               io $ putStrLn "Cannot find default module for breakpoint."
1904               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1905    | otherwise = do -- try parsing it as an identifier
1906         wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
1907         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
1908         if GHC.isGoodSrcLoc loc
1909                then findBreakAndSet (GHC.nameModule name) $
1910                          findBreakByCoord (Just (GHC.srcLocFile loc))
1911                                           (GHC.srcLocLine loc,
1912                                            GHC.srcLocCol loc)
1913                else noCanDo name $ text "can't find its location: " <> ppr loc
1914        where
1915           noCanDo n why = printForUser $
1916                 text "cannot set breakpoint on " <> ppr n <> text ": " <> why
1917
1918 breakByModule :: Module -> [String] -> GHCi ()
1919 breakByModule mod (arg1:rest)
1920    | all isDigit arg1 = do  -- looks like a line number
1921         breakByModuleLine mod (read arg1) rest
1922 breakByModule _ _
1923    = breakSyntax
1924
1925 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1926 breakByModuleLine mod line args
1927    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1928    | [col] <- args, all isDigit col =
1929         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
1930    | otherwise = breakSyntax
1931
1932 breakSyntax :: a
1933 breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
1934
1935 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1936 findBreakAndSet mod lookupTickTree = do
1937    tickArray <- getTickArray mod
1938    (breakArray, _) <- getModBreak mod
1939    case lookupTickTree tickArray of
1940       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1941       Just (tick, span) -> do
1942          success <- io $ setBreakFlag True breakArray tick
1943          if success
1944             then do
1945                (alreadySet, nm) <-
1946                      recordBreak $ BreakLocation
1947                              { breakModule = mod
1948                              , breakLoc = span
1949                              , breakTick = tick
1950                              , onBreakCmd = ""
1951                              }
1952                printForUser $
1953                   text "Breakpoint " <> ppr nm <>
1954                   if alreadySet
1955                      then text " was already set at " <> ppr span
1956                      else text " activated at " <> ppr span
1957             else do
1958             printForUser $ text "Breakpoint could not be activated at"
1959                                  <+> ppr span
1960
1961 -- When a line number is specified, the current policy for choosing
1962 -- the best breakpoint is this:
1963 --    - the leftmost complete subexpression on the specified line, or
1964 --    - the leftmost subexpression starting on the specified line, or
1965 --    - the rightmost subexpression enclosing the specified line
1966 --
1967 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1968 findBreakByLine line arr
1969   | not (inRange (bounds arr) line) = Nothing
1970   | otherwise =
1971     listToMaybe (sortBy (leftmost_largest `on` snd)  complete)   `mplus`
1972     listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
1973     listToMaybe (sortBy (rightmost `on` snd) ticks)
1974   where
1975         ticks = arr ! line
1976
1977         starts_here = [ tick | tick@(_,span) <- ticks,
1978                                GHC.srcSpanStartLine span == line ]
1979
1980         (complete,incomplete) = partition ends_here starts_here
1981             where ends_here (_,span) = GHC.srcSpanEndLine span == line
1982
1983 findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
1984                  -> Maybe (BreakIndex,SrcSpan)
1985 findBreakByCoord mb_file (line, col) arr
1986   | not (inRange (bounds arr) line) = Nothing
1987   | otherwise =
1988     listToMaybe (sortBy (rightmost `on` snd) contains ++
1989                  sortBy (leftmost_smallest `on` snd) after_here)
1990   where
1991         ticks = arr ! line
1992
1993         -- the ticks that span this coordinate
1994         contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
1995                             is_correct_file span ]
1996
1997         is_correct_file span
1998                  | Just f <- mb_file = GHC.srcSpanFile span == f
1999                  | otherwise         = True
2000
2001         after_here = [ tick | tick@(_,span) <- ticks,
2002                               GHC.srcSpanStartLine span == line,
2003                               GHC.srcSpanStartCol span >= col ]
2004
2005 -- For now, use ANSI bold on terminals that we know support it.
2006 -- Otherwise, we add a line of carets under the active expression instead.
2007 -- In particular, on Windows and when running the testsuite (which sets
2008 -- TERM to vt100 for other reasons) we get carets.
2009 -- We really ought to use a proper termcap/terminfo library.
2010 do_bold :: Bool
2011 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
2012     where mTerm = System.Environment.getEnv "TERM"
2013                   `Exception.catch` \_ -> return "TERM not set"
2014
2015 start_bold :: String
2016 start_bold = "\ESC[1m"
2017 end_bold :: String
2018 end_bold   = "\ESC[0m"
2019
2020 listCmd :: String -> GHCi ()
2021 listCmd "" = do
2022    mb_span <- getCurrentBreakSpan
2023    case mb_span of
2024       Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
2025       Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
2026                 | otherwise              -> printForUser $ text "unable to list source for" <+> ppr span
2027 listCmd str = list2 (words str)
2028
2029 list2 :: [String] -> GHCi ()
2030 list2 [arg] | all isDigit arg = do
2031     session <- getSession
2032     (toplevel, _) <- io $ GHC.getContext session
2033     case toplevel of
2034         [] -> io $ putStrLn "No module to list"
2035         (mod : _) -> listModuleLine mod (read arg)
2036 list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
2037         mod <- wantInterpretedModule arg1
2038         listModuleLine mod (read arg2)
2039 list2 [arg] = do
2040         wantNameFromInterpretedModule noCanDo arg $ \name -> do
2041         let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
2042         if GHC.isGoodSrcLoc loc
2043                then do
2044                   tickArray <- getTickArray (GHC.nameModule name)
2045                   let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
2046                                         (GHC.srcLocLine loc, GHC.srcLocCol loc)
2047                                         tickArray
2048                   case mb_span of
2049                     Nothing       -> io $ listAround (GHC.srcLocSpan loc) False
2050                     Just (_,span) -> io $ listAround span False
2051                else
2052                   noCanDo name $ text "can't find its location: " <>
2053                                  ppr loc
2054     where
2055         noCanDo n why = printForUser $
2056             text "cannot list source code for " <> ppr n <> text ": " <> why
2057 list2  _other =
2058         io $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
2059
2060 listModuleLine :: Module -> Int -> GHCi ()
2061 listModuleLine modl line = do
2062    session <- getSession
2063    graph <- io (GHC.getModuleGraph session)
2064    let this = filter ((== modl) . GHC.ms_mod) graph
2065    case this of
2066      [] -> panic "listModuleLine"
2067      summ:_ -> do
2068            let filename = fromJust (ml_hs_file (GHC.ms_location summ))
2069                loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
2070            io $ listAround (GHC.srcLocSpan loc) False
2071
2072 -- | list a section of a source file around a particular SrcSpan.
2073 -- If the highlight flag is True, also highlight the span using
2074 -- start_bold/end_bold.
2075 listAround :: SrcSpan -> Bool -> IO ()
2076 listAround span do_highlight = do
2077       contents <- BS.readFile (unpackFS file)
2078       let
2079           lines = BS.split '\n' contents
2080           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
2081                         drop (line1 - 1 - pad_before) $ lines
2082           fst_line = max 1 (line1 - pad_before)
2083           line_nos = [ fst_line .. ]
2084
2085           highlighted | do_highlight = zipWith highlight line_nos these_lines
2086                       | otherwise    = [\p -> BS.concat[p,l] | l <- these_lines]
2087
2088           bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
2089           prefixed = zipWith ($) highlighted bs_line_nos
2090       --
2091       BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
2092   where
2093         file  = GHC.srcSpanFile span
2094         line1 = GHC.srcSpanStartLine span
2095         col1  = GHC.srcSpanStartCol span
2096         line2 = GHC.srcSpanEndLine span
2097         col2  = GHC.srcSpanEndCol span
2098
2099         pad_before | line1 == 1 = 0
2100                    | otherwise  = 1
2101         pad_after = 1
2102
2103         highlight | do_bold   = highlight_bold
2104                   | otherwise = highlight_carets
2105
2106         highlight_bold no line prefix
2107           | no == line1 && no == line2
2108           = let (a,r) = BS.splitAt col1 line
2109                 (b,c) = BS.splitAt (col2-col1) r
2110             in
2111             BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
2112           | no == line1
2113           = let (a,b) = BS.splitAt col1 line in
2114             BS.concat [prefix, a, BS.pack start_bold, b]
2115           | no == line2
2116           = let (a,b) = BS.splitAt col2 line in
2117             BS.concat [prefix, a, BS.pack end_bold, b]
2118           | otherwise   = BS.concat [prefix, line]
2119
2120         highlight_carets no line prefix
2121           | no == line1 && no == line2
2122           = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
2123                                          BS.replicate (col2-col1) '^']
2124           | no == line1
2125           = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
2126                                          prefix, line]
2127           | no == line2
2128           = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
2129                                          BS.pack "^^"]
2130           | otherwise   = BS.concat [prefix, line]
2131          where
2132            indent = BS.pack ("  " ++ replicate (length (show no)) ' ')
2133            nl = BS.singleton '\n'
2134
2135 -- --------------------------------------------------------------------------
2136 -- Tick arrays
2137
2138 getTickArray :: Module -> GHCi TickArray
2139 getTickArray modl = do
2140    st <- getGHCiState
2141    let arrmap = tickarrays st
2142    case lookupModuleEnv arrmap modl of
2143       Just arr -> return arr
2144       Nothing  -> do
2145         (_breakArray, ticks) <- getModBreak modl
2146         let arr = mkTickArray (assocs ticks)
2147         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
2148         return arr
2149
2150 discardTickArrays :: GHCi ()
2151 discardTickArrays = do
2152    st <- getGHCiState
2153    setGHCiState st{tickarrays = emptyModuleEnv}
2154
2155 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
2156 mkTickArray ticks
2157   = accumArray (flip (:)) [] (1, max_line)
2158         [ (line, (nm,span)) | (nm,span) <- ticks,
2159                               line <- srcSpanLines span ]
2160     where
2161         max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
2162         srcSpanLines span = [ GHC.srcSpanStartLine span ..
2163                               GHC.srcSpanEndLine span ]
2164
2165 lookupModule :: String -> GHCi Module
2166 lookupModule modName
2167    = do session <- getSession
2168         io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
2169
2170 -- don't reset the counter back to zero?
2171 discardActiveBreakPoints :: GHCi ()
2172 discardActiveBreakPoints = do
2173    st <- getGHCiState
2174    mapM (turnOffBreak.snd) (breaks st)
2175    setGHCiState $ st { breaks = [] }
2176
2177 deleteBreak :: Int -> GHCi ()
2178 deleteBreak identity = do
2179    st <- getGHCiState
2180    let oldLocations    = breaks st
2181        (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
2182    if null this
2183       then printForUser (text "Breakpoint" <+> ppr identity <+>
2184                          text "does not exist")
2185       else do
2186            mapM (turnOffBreak.snd) this
2187            setGHCiState $ st { breaks = rest }
2188
2189 turnOffBreak :: BreakLocation -> GHCi Bool
2190 turnOffBreak loc = do
2191   (arr, _) <- getModBreak (breakModule loc)
2192   io $ setBreakFlag False arr (breakTick loc)
2193
2194 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
2195 getModBreak mod = do
2196    session <- getSession
2197    Just mod_info <- io $ GHC.getModuleInfo session mod
2198    let modBreaks  = GHC.modInfoModBreaks mod_info
2199    let array      = GHC.modBreaks_flags modBreaks
2200    let ticks      = GHC.modBreaks_locs  modBreaks
2201    return (array, ticks)
2202
2203 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
2204 setBreakFlag toggle array index
2205    | toggle    = GHC.setBreakOn array index
2206    | otherwise = GHC.setBreakOff array index
2207