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