compiler/ghci/InteractiveUI.hs

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