ghc/InteractiveUI.hs

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