compiler/ghci/InteractiveUI.hs

   1 {-# OPTIONS -#include "Linker.h" #-}
   2 -----------------------------------------------------------------------------
   3 --
   4 -- GHC Interactive User Interface
   5 --
   6 -- (c) The GHC Team 2005-2006
   7 --
   8 -----------------------------------------------------------------------------
   9 module InteractiveUI (
  10         interactiveUI,
  11         ghciWelcomeMsg
  12    ) where
  13
  14 #include "HsVersions.h"
  15
  16 import GhciMonad
  17
  18 -- The GHC interface
  19 import qualified GHC
  20 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
  21                           Type, Module, ModuleName, TyThing(..), Phase,
  22                           BreakIndex )
  23 import Debugger
  24 import DynFlags
  25 import Packages
  26 import PackageConfig
  27 import UniqFM
  28 import PprTyThing
  29 import Outputable
  30 import Module           -- for ModuleEnv
  31
  32 -- for createtags
  33 import Name
  34 import OccName
  35 import SrcLoc
  36
  37 -- Other random utilities
  38 import Digraph
  39 import BasicTypes hiding (isTopLevel)
  40 import Panic      hiding (showException)
  41 import Config
  42 import StaticFlags
  43 import Linker
  44 import Util
  45
  46 #ifndef mingw32_HOST_OS
  47 import System.Posix
  48 #if __GLASGOW_HASKELL__ > 504
  49         hiding (getEnv)
  50 #endif
  51 #else
  52 import GHC.ConsoleHandler ( flushConsole )
  53 import System.Win32       ( setConsoleCP, setConsoleOutputCP )
  54 import qualified System.Win32
  55 #endif
  56
  57 #ifdef USE_READLINE
  58 import Control.Concurrent       ( yield )       -- Used in readline loop
  59 import System.Console.Readline as Readline
  60 #endif
  61
  62 --import SystemExts
  63
  64 import Control.Exception as Exception
  65 -- import Control.Concurrent
  66
  67 import Data.List
  68 import Data.Maybe
  69 import System.Cmd
  70 import System.Environment
  71 import System.Exit      ( exitWith, ExitCode(..) )
  72 import System.Directory
  73 import System.IO
  74 import System.IO.Error as IO
  75 import Data.Char
  76 import Data.Dynamic
  77 import Data.Array
  78 import Control.Monad as Monad
  79
  80 import Foreign.StablePtr        ( newStablePtr )
  81 import GHC.Exts         ( unsafeCoerce# )
  82 import GHC.IOBase       ( IOErrorType(InvalidArgument), IO(IO) )
  83
  84 import Data.IORef       ( IORef, readIORef, writeIORef )
  85
  86 import System.Posix.Internals ( setNonBlockingFD )
  87
  88 -- these are needed by the new ghci debugger
  89 import ByteCodeLink (HValue)
  90 import ByteCodeInstr (BreakInfo (..))
  91 import BreakArray
  92
  93 -----------------------------------------------------------------------------
  94
  95 ghciWelcomeMsg =
  96  "   ___         ___ _\n"++
  97  "  / _ \\ /\\  /\\/ __(_)\n"++
  98  " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
  99  "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
 100  "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
 101
 102 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
 103 cmdName (n,_,_,_) = n
 104
 105 GLOBAL_VAR(commands, builtin_commands, [Command])
 106
 107 builtin_commands :: [Command]
 108 builtin_commands = [
 109         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 110   ("?",         keepGoing help,                 False, completeNone),
 111   ("add",       keepGoingPaths addModule,       False, completeFilename),
 112   ("break",     breakCmd, False, completeNone),
 113   ("browse",    keepGoing browseCmd,            False, completeModule),
 114   ("cd",        keepGoing changeDirectory,      False, completeFilename),
 115   ("check",     keepGoing checkModule,          False, completeHomeModule),
 116   ("continue",  continueCmd, False, completeNone),
 117   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 118   ("def",       keepGoing defineMacro,          False, completeIdentifier),
 119   ("delete",    deleteCmd, False, completeNone),
 120   ("e",         keepGoing editFile,             False, completeFilename),
 121   ("edit",      keepGoing editFile,             False, completeFilename),
 122   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 123   ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
 124   ("help",      keepGoing help,                 False, completeNone),
 125   ("info",      keepGoing info,                 False, completeIdentifier),
 126   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 127   ("load",      keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
 128   ("module",    keepGoing setContext,           False, completeModule),
 129   ("main",      keepGoing runMain,              False, completeIdentifier),
 130   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
 131   ("quit",      quit,                           False, completeNone),
 132   ("reload",    keepGoing reloadModule,         False, completeNone),
 133   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 134   ("show",      keepGoing showCmd,              False, completeNone),
 135   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
 136   ("step",      stepCmd, False, completeNone),
 137   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 138   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 139   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions)
 140   ]
 141
 142 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 143 keepGoing a str = a str >> return False
 144
 145 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 146 keepGoingPaths a str = a (toArgs str) >> return False
 147
 148 shortHelpText = "use :? for help.\n"
 149
 150 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 151 helpText =
 152  " Commands available from the prompt:\n" ++
 153  "\n" ++
 154  "   <stmt>                      evaluate/run <stmt>\n" ++
 155  "   :add <filename> ...         add module(s) to the current target set\n" ++
 156  "   :browse [*]<module>         display the names defined by <module>\n" ++
 157  "   :cd <dir>                   change directory to <dir>\n" ++
 158  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 159  "   :edit <file>                edit file\n" ++
 160  "   :edit                       edit last module\n" ++
 161  "   :help, :?                   display this list of commands\n" ++
 162  "   :info [<name> ...]          display information about the given names\n" ++
 163  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 164  "   :sprint [<name> ...]        simplified version of :print\n" ++
 165  "   :load <filename> ...        load module(s) and their dependents\n" ++
 166  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 167  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 168  "   :reload                     reload the current module set\n" ++
 169  "\n" ++
 170  "   :set <option> ...           set options\n" ++
 171  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 172  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 173  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 174  "   :set editor <cmd>           set the command used for :edit\n" ++
 175  "\n" ++
 176  "   :show modules               show the currently loaded modules\n" ++
 177  "   :show bindings              show the current bindings made at the prompt\n" ++
 178  "\n" ++
 179  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 180  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 181  "   :type <expr>                show the type of <expr>\n" ++
 182  "   :kind <type>                show the kind of <type>\n" ++
 183  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 184  "   :unset <option> ...         unset options\n" ++
 185  "   :quit                       exit GHCi\n" ++
 186  "   :!<command>                 run the shell command <command>\n" ++
 187  "\n" ++
 188  " Options for ':set' and ':unset':\n" ++
 189  "\n" ++
 190  "    +r            revert top-level expressions after each evaluation\n" ++
 191  "    +s            print timing/memory stats after each evaluation\n" ++
 192  "    +t            print type after evaluation\n" ++
 193  "    -<flags>      most GHC command line flags can also be set here\n" ++
 194  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 195  "\n"
 196 -- Todo: add help for breakpoint commands here
 197
 198 findEditor = do
 199   getEnv "EDITOR"
 200     `IO.catch` \_ -> do
 201 #if mingw32_HOST_OS
 202         win <- System.Win32.getWindowsDirectory
 203         return (win `joinFileName` "notepad.exe")
 204 #else
 205         return ""
 206 #endif
 207
 208 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 209 interactiveUI session srcs maybe_expr = do
 210    -- HACK! If we happen to get into an infinite loop (eg the user
 211    -- types 'let x=x in x' at the prompt), then the thread will block
 212    -- on a blackhole, and become unreachable during GC.  The GC will
 213    -- detect that it is unreachable and send it the NonTermination
 214    -- exception.  However, since the thread is unreachable, everything
 215    -- it refers to might be finalized, including the standard Handles.
 216    -- This sounds like a bug, but we don't have a good solution right
 217    -- now.
 218    newStablePtr stdin
 219    newStablePtr stdout
 220    newStablePtr stderr
 221
 222         -- Initialise buffering for the *interpreted* I/O system
 223    initInterpBuffering session
 224
 225    when (isNothing maybe_expr) $ do
 226         -- Only for GHCi (not runghc and ghc -e):
 227         -- Turn buffering off for the compiled program's stdout/stderr
 228         turnOffBuffering
 229         -- Turn buffering off for GHCi's stdout
 230         hFlush stdout
 231         hSetBuffering stdout NoBuffering
 232         -- We don't want the cmd line to buffer any input that might be
 233         -- intended for the program, so unbuffer stdin.
 234         hSetBuffering stdin NoBuffering
 235
 236         -- initial context is just the Prelude
 237    prel_mod <- GHC.findModule session prel_name (Just basePackageId)
 238    GHC.setContext session [] [prel_mod]
 239
 240 #ifdef USE_READLINE
 241    Readline.initialize
 242    Readline.setAttemptedCompletionFunction (Just completeWord)
 243    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 244
 245    let symbols = "!#$%&*+/<=>?@\\^|-~"
 246        specials = "(),;[]`{}"
 247        spaces = " \t\n"
 248        word_break_chars = spaces ++ specials ++ symbols
 249
 250    Readline.setBasicWordBreakCharacters word_break_chars
 251    Readline.setCompleterWordBreakCharacters word_break_chars
 252 #endif
 253
 254    default_editor <- findEditor
 255
 256    startGHCi (runGHCi srcs maybe_expr)
 257         GHCiState{ progname = "<interactive>",
 258                    args = [],
 259                    prompt = "%s> ",
 260                    editor = default_editor,
 261                    session = session,
 262                    options = [],
 263                    prelude = prel_mod,
 264                    resume = [],
 265                    breaks = emptyActiveBreakPoints,
 266                    tickarrays = emptyModuleEnv
 267                  }
 268
 269 #ifdef USE_READLINE
 270    Readline.resetTerminal Nothing
 271 #endif
 272
 273    return ()
 274
 275 prel_name = GHC.mkModuleName "Prelude"
 276
 277 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 278 runGHCi paths maybe_expr = do
 279   let read_dot_files = not opt_IgnoreDotGhci
 280
 281   when (read_dot_files) $ do
 282     -- Read in ./.ghci.
 283     let file = "./.ghci"
 284     exists <- io (doesFileExist file)
 285     when exists $ do
 286        dir_ok  <- io (checkPerms ".")
 287        file_ok <- io (checkPerms file)
 288        when (dir_ok && file_ok) $ do
 289           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 290           case either_hdl of
 291              Left e    -> return ()
 292              Right hdl -> fileLoop hdl False
 293
 294   when (read_dot_files) $ do
 295     -- Read in $HOME/.ghci
 296     either_dir <- io (IO.try (getEnv "HOME"))
 297     case either_dir of
 298        Left e -> return ()
 299        Right dir -> do
 300           cwd <- io (getCurrentDirectory)
 301           when (dir /= cwd) $ do
 302              let file = dir ++ "/.ghci"
 303              ok <- io (checkPerms file)
 304              when ok $ do
 305                either_hdl <- io (IO.try (openFile file ReadMode))
 306                case either_hdl of
 307                   Left e    -> return ()
 308                   Right hdl -> fileLoop hdl False
 309
 310   -- Perform a :load for files given on the GHCi command line
 311   -- When in -e mode, if the load fails then we want to stop
 312   -- immediately rather than going on to evaluate the expression.
 313   when (not (null paths)) $ do
 314      ok <- ghciHandle (\e -> do showException e; return Failed) $
 315                 loadModule paths
 316      when (isJust maybe_expr && failed ok) $
 317         io (exitWith (ExitFailure 1))
 318
 319   -- if verbosity is greater than 0, or we are connected to a
 320   -- terminal, display the prompt in the interactive loop.
 321   is_tty <- io (hIsTerminalDevice stdin)
 322   dflags <- getDynFlags
 323   let show_prompt = verbosity dflags > 0 || is_tty
 324
 325   case maybe_expr of
 326         Nothing ->
 327           do
 328 #if defined(mingw32_HOST_OS)
 329             -- The win32 Console API mutates the first character of
 330             -- type-ahead when reading from it in a non-buffered manner. Work
 331             -- around this by flushing the input buffer of type-ahead characters,
 332             -- but only if stdin is available.
 333             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 334             case flushed of
 335              Left err | isDoesNotExistError err -> return ()
 336                       | otherwise -> io (ioError err)
 337              Right () -> return ()
 338 #endif
 339             -- initialise the console if necessary
 340             io setUpConsole
 341
 342             -- enter the interactive loop
 343             interactiveLoop is_tty show_prompt
 344         Just expr -> do
 345             -- just evaluate the expression we were given
 346             runCommandEval expr
 347             return ()
 348
 349   -- and finally, exit
 350   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 351
 352
 353 interactiveLoop is_tty show_prompt =
 354   -- Ignore ^C exceptions caught here
 355   ghciHandleDyn (\e -> case e of
 356                         Interrupted -> do
 357 #if defined(mingw32_HOST_OS)
 358                                 io (putStrLn "")
 359 #endif
 360                                 interactiveLoop is_tty show_prompt
 361                         _other      -> return ()) $
 362
 363   ghciUnblock $ do -- unblock necessary if we recursed from the
 364                    -- exception handler above.
 365
 366   -- read commands from stdin
 367 #ifdef USE_READLINE
 368   if (is_tty)
 369         then readlineLoop
 370         else fileLoop stdin show_prompt
 371 #else
 372   fileLoop stdin show_prompt
 373 #endif
 374
 375
 376 -- NOTE: We only read .ghci files if they are owned by the current user,
 377 -- and aren't world writable.  Otherwise, we could be accidentally
 378 -- running code planted by a malicious third party.
 379
 380 -- Furthermore, We only read ./.ghci if . is owned by the current user
 381 -- and isn't writable by anyone else.  I think this is sufficient: we
 382 -- don't need to check .. and ../.. etc. because "."  always refers to
 383 -- the same directory while a process is running.
 384
 385 checkPerms :: String -> IO Bool
 386 checkPerms name =
 387 #ifdef mingw32_HOST_OS
 388   return True
 389 #else
 390   Util.handle (\_ -> return False) $ do
 391      st <- getFileStatus name
 392      me <- getRealUserID
 393      if fileOwner st /= me then do
 394         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 395         return False
 396       else do
 397         let mode =  fileMode st
 398         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 399            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 400            then do
 401                putStrLn $ "*** WARNING: " ++ name ++
 402                           " is writable by someone else, IGNORING!"
 403                return False
 404           else return True
 405 #endif
 406
 407 fileLoop :: Handle -> Bool -> GHCi ()
 408 fileLoop hdl show_prompt = do
 409    session <- getSession
 410    (mod,imports) <- io (GHC.getContext session)
 411    st <- getGHCiState
 412    when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
 413    l <- io (IO.try (hGetLine hdl))
 414    case l of
 415         Left e | isEOFError e              -> return ()
 416                | InvalidArgument <- etype  -> return ()
 417                | otherwise                 -> io (ioError e)
 418                 where etype = ioeGetErrorType e
 419                 -- treat InvalidArgument in the same way as EOF:
 420                 -- this can happen if the user closed stdin, or
 421                 -- perhaps did getContents which closes stdin at
 422                 -- EOF.
 423         Right l ->
 424           case removeSpaces l of
 425             "" -> fileLoop hdl show_prompt
 426             l  -> do quit <- runCommand l
 427                      if quit then return () else fileLoop hdl show_prompt
 428
 429 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
 430 stringLoop [] = return False
 431 stringLoop (s:ss) = do
 432    case removeSpaces s of
 433         "" -> stringLoop ss
 434         l  -> do quit <- runCommand l
 435                  if quit then return True else stringLoop ss
 436
 437 mkPrompt toplevs exports prompt
 438   = showSDoc $ f prompt
 439     where
 440         f ('%':'s':xs) = perc_s <> f xs
 441         f ('%':'%':xs) = char '%' <> f xs
 442         f (x:xs) = char x <> f xs
 443         f [] = empty
 444
 445         perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
 446                  hsep (map (ppr . GHC.moduleName) exports)
 447
 448
 449 #ifdef USE_READLINE
 450 readlineLoop :: GHCi ()
 451 readlineLoop = do
 452    session <- getSession
 453    (mod,imports) <- io (GHC.getContext session)
 454    io yield
 455    saveSession -- for use by completion
 456    st <- getGHCiState
 457    l <- io (readline (mkPrompt mod imports (prompt st))
 458                 `finally` setNonBlockingFD 0)
 459                 -- readline sometimes puts stdin into blocking mode,
 460                 -- so we need to put it back for the IO library
 461    splatSavedSession
 462    case l of
 463         Nothing -> return ()
 464         Just l  ->
 465           case removeSpaces l of
 466             "" -> readlineLoop
 467             l  -> do
 468                   io (addHistory l)
 469                   quit <- runCommand l
 470                   if quit then return () else readlineLoop
 471 #endif
 472
 473 runCommand :: String -> GHCi Bool
 474 runCommand c = ghciHandle handler (doCommand c)
 475   where
 476     doCommand (':' : command) = specialCommand command
 477     doCommand stmt
 478        = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 479             return False
 480
 481 -- This version is for the GHC command-line option -e.  The only difference
 482 -- from runCommand is that it catches the ExitException exception and
 483 -- exits, rather than printing out the exception.
 484 runCommandEval c = ghciHandle handleEval (doCommand c)
 485   where
 486     handleEval (ExitException code) = io (exitWith code)
 487     handleEval e                    = do handler e
 488                                          io (exitWith (ExitFailure 1))
 489
 490     doCommand (':' : command) = specialCommand command
 491     doCommand stmt
 492        = do nms <- runStmt stmt
 493             case nms of
 494                 Nothing -> io (exitWith (ExitFailure 1))
 495                   -- failure to run the command causes exit(1) for ghc -e.
 496                 _       -> finishEvalExpr nms
 497
 498 runStmt :: String -> GHCi (Maybe (Bool,[Name]))
 499 runStmt stmt
 500  | null (filter (not.isSpace) stmt) = return (Just (False,[]))
 501  | otherwise
 502  = do st <- getGHCiState
 503       session <- getSession
 504       result <- io $ withProgName (progname st) $ withArgs (args st) $
 505                      GHC.runStmt session stmt
 506       switchOnRunResult result
 507
 508 switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
 509 switchOnRunResult GHC.RunFailed = return Nothing
 510 switchOnRunResult (GHC.RunException e) = throw e
 511 switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
 512 switchOnRunResult (GHC.RunBreak threadId names info resume) = do
 513    session <- getSession
 514    Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info)
 515    let modBreaks  = GHC.modInfoModBreaks mod_info
 516    let ticks      = GHC.modBreaks_locs modBreaks
 517
 518    -- display information about the breakpoint
 519    let location = ticks ! breakInfo_number info
 520    unqual <- io $ GHC.getPrintUnqual session
 521    io $ printForUser stdout unqual $
 522       ptext SLIT("Stopped at") <+> ppr location
 523
 524    pushResume location threadId resume
 525    return (Just (True,names))
 526
 527 -- possibly print the type and revert CAFs after evaluating an expression
 528 finishEvalExpr mb_names
 529  = do show_types <- isOptionSet ShowType
 530       session <- getSession
 531       case mb_names of
 532         Nothing    -> return ()
 533         Just (is_break,names) ->
 534                 when (is_break || show_types) $
 535                       mapM_ (showTypeOfName session) names
 536
 537       flushInterpBuffers
 538       io installSignalHandlers
 539       b <- isOptionSet RevertCAFs
 540       io (when b revertCAFs)
 541       return True
 542
 543 showTypeOfName :: Session -> Name -> GHCi ()
 544 showTypeOfName session n
 545    = do maybe_tything <- io (GHC.lookupName session n)
 546         case maybe_tything of
 547           Nothing    -> return ()
 548           Just thing -> showTyThing thing
 549
 550 specialCommand :: String -> GHCi Bool
 551 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 552 specialCommand str = do
 553   let (cmd,rest) = break isSpace str
 554   maybe_cmd <- io (lookupCommand cmd)
 555   case maybe_cmd of
 556     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 557                                     ++ shortHelpText) >> return False)
 558     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 559
 560 lookupCommand :: String -> IO (Maybe Command)
 561 lookupCommand str = do
 562   cmds <- readIORef commands
 563   -- look for exact match first, then the first prefix match
 564   case [ c | c <- cmds, str == cmdName c ] of
 565      c:_ -> return (Just c)
 566      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 567                 [] -> return Nothing
 568                 c:_ -> return (Just c)
 569
 570 -----------------------------------------------------------------------------
 571 -- Commands
 572
 573 help :: String -> GHCi ()
 574 help _ = io (putStr helpText)
 575
 576 info :: String -> GHCi ()
 577 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 578 info s  = do { let names = words s
 579              ; session <- getSession
 580              ; dflags <- getDynFlags
 581              ; let exts = dopt Opt_GlasgowExts dflags
 582              ; mapM_ (infoThing exts session) names }
 583   where
 584     infoThing exts session str = io $ do
 585         names <- GHC.parseName session str
 586         let filtered = filterOutChildren names
 587         mb_stuffs <- mapM (GHC.getInfo session) filtered
 588         unqual <- GHC.getPrintUnqual session
 589         putStrLn (showSDocForUser unqual $
 590                    vcat (intersperse (text "") $
 591                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 592
 593   -- Filter out names whose parent is also there Good
 594   -- example is '[]', which is both a type and data
 595   -- constructor in the same type
 596 filterOutChildren :: [Name] -> [Name]
 597 filterOutChildren names = filter (not . parent_is_there) names
 598  where parent_is_there n
 599 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 600 -- ToDo!!
 601          | otherwise                       = False
 602
 603 pprInfo exts (thing, fixity, insts)
 604   =  pprTyThingInContextLoc exts thing
 605   $$ show_fixity fixity
 606   $$ vcat (map GHC.pprInstance insts)
 607   where
 608     show_fixity fix
 609         | fix == GHC.defaultFixity = empty
 610         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 611
 612 -----------------------------------------------------------------------------
 613 -- Commands
 614
 615 runMain :: String -> GHCi ()
 616 runMain args = do
 617   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 618   runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
 619   return ()
 620
 621 addModule :: [FilePath] -> GHCi ()
 622 addModule files = do
 623   io (revertCAFs)                       -- always revert CAFs on load/add.
 624   files <- mapM expandPath files
 625   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 626   session <- getSession
 627   io (mapM_ (GHC.addTarget session) targets)
 628   ok <- io (GHC.load session LoadAllTargets)
 629   afterLoad ok session
 630
 631 changeDirectory :: String -> GHCi ()
 632 changeDirectory dir = do
 633   session <- getSession
 634   graph <- io (GHC.getModuleGraph session)
 635   when (not (null graph)) $
 636         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 637   io (GHC.setTargets session [])
 638   io (GHC.load session LoadAllTargets)
 639   setContextAfterLoad session []
 640   io (GHC.workingDirectoryChanged session)
 641   dir <- expandPath dir
 642   io (setCurrentDirectory dir)
 643
 644 editFile :: String -> GHCi ()
 645 editFile str
 646   | null str  = do
 647         -- find the name of the "topmost" file loaded
 648      session <- getSession
 649      graph0 <- io (GHC.getModuleGraph session)
 650      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 651      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 652      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 653         Just file -> do_edit file
 654         Nothing   -> throwDyn (CmdLineError "unknown file name")
 655   | otherwise = do_edit str
 656   where
 657         do_edit file = do
 658            st <- getGHCiState
 659            let cmd = editor st
 660            when (null cmd) $
 661                 throwDyn (CmdLineError "editor not set, use :set editor")
 662            io $ system (cmd ++ ' ':file)
 663            return ()
 664
 665 defineMacro :: String -> GHCi ()
 666 defineMacro s = do
 667   let (macro_name, definition) = break isSpace s
 668   cmds <- io (readIORef commands)
 669   if (null macro_name)
 670         then throwDyn (CmdLineError "invalid macro name")
 671         else do
 672   if (macro_name `elem` map cmdName cmds)
 673         then throwDyn (CmdLineError
 674                 ("command '" ++ macro_name ++ "' is already defined"))
 675         else do
 676
 677   -- give the expression a type signature, so we can be sure we're getting
 678   -- something of the right type.
 679   let new_expr = '(' : definition ++ ") :: String -> IO String"
 680
 681   -- compile the expression
 682   cms <- getSession
 683   maybe_hv <- io (GHC.compileExpr cms new_expr)
 684   case maybe_hv of
 685      Nothing -> return ()
 686      Just hv -> io (writeIORef commands --
 687                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 688
 689 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 690 runMacro fun s = do
 691   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 692   stringLoop (lines str)
 693
 694 undefineMacro :: String -> GHCi ()
 695 undefineMacro macro_name = do
 696   cmds <- io (readIORef commands)
 697   if (macro_name `elem` map cmdName builtin_commands)
 698         then throwDyn (CmdLineError
 699                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 700         else do
 701   if (macro_name `notElem` map cmdName cmds)
 702         then throwDyn (CmdLineError
 703                 ("command '" ++ macro_name ++ "' not defined"))
 704         else do
 705   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 706
 707
 708 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 709 loadModule fs = timeIt (loadModule' fs)
 710
 711 loadModule_ :: [FilePath] -> GHCi ()
 712 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 713
 714 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 715 loadModule' files = do
 716   session <- getSession
 717
 718   -- unload first
 719   io (GHC.setTargets session [])
 720   io (GHC.load session LoadAllTargets)
 721
 722   -- expand tildes
 723   let (filenames, phases) = unzip files
 724   exp_filenames <- mapM expandPath filenames
 725   let files' = zip exp_filenames phases
 726   targets <- io (mapM (uncurry GHC.guessTarget) files')
 727
 728   -- NOTE: we used to do the dependency anal first, so that if it
 729   -- fails we didn't throw away the current set of modules.  This would
 730   -- require some re-working of the GHC interface, so we'll leave it
 731   -- as a ToDo for now.
 732
 733   io (GHC.setTargets session targets)
 734   ok <- io (GHC.load session LoadAllTargets)
 735   afterLoad ok session
 736   return ok
 737
 738 checkModule :: String -> GHCi ()
 739 checkModule m = do
 740   let modl = GHC.mkModuleName m
 741   session <- getSession
 742   result <- io (GHC.checkModule session modl)
 743   case result of
 744     Nothing -> io $ putStrLn "Nothing"
 745     Just r  -> io $ putStrLn (showSDoc (
 746         case GHC.checkedModuleInfo r of
 747            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 748                 let
 749                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 750                 in
 751                         (text "global names: " <+> ppr global) $$
 752                         (text "local  names: " <+> ppr local)
 753            _ -> empty))
 754   afterLoad (successIf (isJust result)) session
 755
 756 reloadModule :: String -> GHCi ()
 757 reloadModule "" = do
 758   io (revertCAFs)               -- always revert CAFs on reload.
 759   session <- getSession
 760   ok <- io (GHC.load session LoadAllTargets)
 761   afterLoad ok session
 762 reloadModule m = do
 763   io (revertCAFs)               -- always revert CAFs on reload.
 764   session <- getSession
 765   ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
 766   afterLoad ok session
 767
 768 afterLoad ok session = do
 769   io (revertCAFs)  -- always revert CAFs on load.
 770   discardResumeContext
 771   discardTickArrays
 772   discardActiveBreakPoints
 773   graph <- io (GHC.getModuleGraph session)
 774   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 775   setContextAfterLoad session graph'
 776   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 777
 778 setContextAfterLoad session [] = do
 779   prel_mod <- getPrelude
 780   io (GHC.setContext session [] [prel_mod])
 781 setContextAfterLoad session ms = do
 782   -- load a target if one is available, otherwise load the topmost module.
 783   targets <- io (GHC.getTargets session)
 784   case [ m | Just m <- map (findTarget ms) targets ] of
 785         []    ->
 786           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 787           load_this (last graph')
 788         (m:_) ->
 789           load_this m
 790  where
 791    findTarget ms t
 792     = case filter (`matches` t) ms of
 793         []    -> Nothing
 794         (m:_) -> Just m
 795
 796    summary `matches` Target (TargetModule m) _
 797         = GHC.ms_mod_name summary == m
 798    summary `matches` Target (TargetFile f _) _
 799         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 800    summary `matches` target
 801         = False
 802
 803    load_this summary | m <- GHC.ms_mod summary = do
 804         b <- io (GHC.moduleIsInterpreted session m)
 805         if b then io (GHC.setContext session [m] [])
 806              else do
 807                    prel_mod <- getPrelude
 808                    io (GHC.setContext session []  [prel_mod,m])
 809
 810
 811 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 812 modulesLoadedMsg ok mods = do
 813   dflags <- getDynFlags
 814   when (verbosity dflags > 0) $ do
 815    let mod_commas
 816         | null mods = text "none."
 817         | otherwise = hsep (
 818             punctuate comma (map ppr mods)) <> text "."
 819    case ok of
 820     Failed ->
 821        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 822     Succeeded  ->
 823        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 824
 825
 826 typeOfExpr :: String -> GHCi ()
 827 typeOfExpr str
 828   = do cms <- getSession
 829        maybe_ty <- io (GHC.exprType cms str)
 830        case maybe_ty of
 831           Nothing -> return ()
 832           Just ty -> do ty' <- cleanType ty
 833                         tystr <- showForUser (ppr ty')
 834                         io (putStrLn (str ++ " :: " ++ tystr))
 835
 836 kindOfType :: String -> GHCi ()
 837 kindOfType str
 838   = do cms <- getSession
 839        maybe_ty <- io (GHC.typeKind cms str)
 840        case maybe_ty of
 841           Nothing    -> return ()
 842           Just ty    -> do tystr <- showForUser (ppr ty)
 843                            io (putStrLn (str ++ " :: " ++ tystr))
 844
 845 quit :: String -> GHCi Bool
 846 quit _ = return True
 847
 848 shellEscape :: String -> GHCi Bool
 849 shellEscape str = io (system str >> return False)
 850
 851 -----------------------------------------------------------------------------
 852 -- create tags file for currently loaded modules.
 853
 854 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
 855
 856 createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
 857 createCTagsFileCmd file = ghciCreateTagsFile CTags file
 858
 859 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
 860 createETagsFileCmd file  = ghciCreateTagsFile ETags file
 861
 862 data TagsKind = ETags | CTags
 863
 864 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
 865 ghciCreateTagsFile kind file = do
 866   session <- getSession
 867   io $ createTagsFile session kind file
 868
 869 -- ToDo:
 870 --      - remove restriction that all modules must be interpreted
 871 --        (problem: we don't know source locations for entities unless
 872 --        we compiled the module.
 873 --
 874 --      - extract createTagsFile so it can be used from the command-line
 875 --        (probably need to fix first problem before this is useful).
 876 --
 877 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
 878 createTagsFile session tagskind tagFile = do
 879   graph <- GHC.getModuleGraph session
 880   let ms = map GHC.ms_mod graph
 881       tagModule m = do
 882         is_interpreted <- GHC.moduleIsInterpreted session m
 883         -- should we just skip these?
 884         when (not is_interpreted) $
 885           throwDyn (CmdLineError ("module '"
 886                                 ++ GHC.moduleNameString (GHC.moduleName m)
 887                                 ++ "' is not interpreted"))
 888         mbModInfo <- GHC.getModuleInfo session m
 889         let unqual
 890               | Just modinfo <- mbModInfo,
 891                 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
 892               | otherwise = GHC.alwaysQualify
 893
 894         case mbModInfo of
 895           Just modInfo -> return $! listTags unqual modInfo
 896           _            -> return []
 897
 898   mtags <- mapM tagModule ms
 899   either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
 900   case either_res of
 901     Left e  -> hPutStrLn stderr $ ioeGetErrorString e
 902     Right _ -> return ()
 903
 904 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
 905 listTags unqual modInfo =
 906            [ tagInfo unqual name loc
 907            | name <- GHC.modInfoExports modInfo
 908            , let loc = nameSrcLoc name
 909            , isGoodSrcLoc loc
 910            ]
 911
 912 type TagInfo = (String -- tag name
 913                ,String -- file name
 914                ,Int    -- line number
 915                ,Int    -- column number
 916                )
 917
 918 -- get tag info, for later translation into Vim or Emacs style
 919 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
 920 tagInfo unqual name loc
 921     = ( showSDocForUser unqual $ pprOccName (nameOccName name)
 922       , showSDocForUser unqual $ ftext (srcLocFile loc)
 923       , srcLocLine loc
 924       , srcLocCol loc
 925       )
 926
 927 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
 928 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
 929   let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
 930   IO.try (writeFile file tags)
 931 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
 932   let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
 933       groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
 934   tagGroups <- mapM tagFileGroup groups
 935   IO.try (writeFile file $ concat tagGroups)
 936   where
 937     tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
 938     tagFileGroup group@((_,fileName,_,_):_) = do
 939       file <- readFile fileName -- need to get additional info from sources..
 940       let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
 941           sortedGroup = sortLe byLine group
 942           tags = unlines $ perFile sortedGroup 1 0 $ lines file
 943       return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
 944     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
 945       perFile (tagInfo:tags) (count+1) (pos+length line) lines
 946     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
 947       showETag tagInfo line pos : perFile tags count pos lines
 948     perFile tags count pos lines = []
 949
 950 -- simple ctags format, for Vim et al
 951 showTag :: TagInfo -> String
 952 showTag (tag,file,lineNo,colNo)
 953     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
 954
 955 -- etags format, for Emacs/XEmacs
 956 showETag :: TagInfo -> String -> Int -> String
 957 showETag (tag,file,lineNo,colNo) line charPos
 958     =  take colNo line ++ tag
 959     ++ "\x7f" ++ tag
 960     ++ "\x01" ++ show lineNo
 961     ++ "," ++ show charPos
 962
 963 -----------------------------------------------------------------------------
 964 -- Browsing a module's contents
 965
 966 browseCmd :: String -> GHCi ()
 967 browseCmd m =
 968   case words m of
 969     ['*':m] | looksLikeModuleName m -> browseModule m False
 970     [m]     | looksLikeModuleName m -> browseModule m True
 971     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 972
 973 browseModule m exports_only = do
 974   s <- getSession
 975   modl <- if exports_only then lookupModule s m
 976                           else wantInterpretedModule s m
 977
 978   -- Temporarily set the context to the module we're interested in,
 979   -- just so we can get an appropriate PrintUnqualified
 980   (as,bs) <- io (GHC.getContext s)
 981   prel_mod <- getPrelude
 982   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 983                       else GHC.setContext s [modl] [])
 984   unqual <- io (GHC.getPrintUnqual s)
 985   io (GHC.setContext s as bs)
 986
 987   mb_mod_info <- io $ GHC.getModuleInfo s modl
 988   case mb_mod_info of
 989     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 990     Just mod_info -> do
 991         let names
 992                | exports_only = GHC.modInfoExports mod_info
 993                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 994
 995             filtered = filterOutChildren names
 996
 997         things <- io $ mapM (GHC.lookupName s) filtered
 998
 999         dflags <- getDynFlags
1000         let exts = dopt Opt_GlasgowExts dflags
1001         io (putStrLn (showSDocForUser unqual (
1002                 vcat (map (pprTyThingInContext exts) (catMaybes things))
1003            )))
1004         -- ToDo: modInfoInstances currently throws an exception for
1005         -- package modules.  When it works, we can do this:
1006         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1007
1008 -----------------------------------------------------------------------------
1009 -- Setting the module context
1010
1011 setContext str
1012   | all sensible mods = fn mods
1013   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1014   where
1015     (fn, mods) = case str of
1016                         '+':stuff -> (addToContext,      words stuff)
1017                         '-':stuff -> (removeFromContext, words stuff)
1018                         stuff     -> (newContext,        words stuff)
1019
1020     sensible ('*':m) = looksLikeModuleName m
1021     sensible m       = looksLikeModuleName m
1022
1023 separate :: Session -> [String] -> [Module] -> [Module]
1024         -> GHCi ([Module],[Module])
1025 separate session []           as bs = return (as,bs)
1026 separate session (('*':str):ms) as bs = do
1027    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1028    b <- io $ GHC.moduleIsInterpreted session m
1029    if b then separate session ms (m:as) bs
1030         else throwDyn (CmdLineError ("module '"
1031                         ++ GHC.moduleNameString (GHC.moduleName m)
1032                         ++ "' is not interpreted"))
1033 separate session (str:ms) as bs = do
1034   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1035   separate session ms as (m:bs)
1036
1037 newContext :: [String] -> GHCi ()
1038 newContext strs = do
1039   s <- getSession
1040   (as,bs) <- separate s strs [] []
1041   prel_mod <- getPrelude
1042   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1043   io $ GHC.setContext s as bs'
1044
1045
1046 addToContext :: [String] -> GHCi ()
1047 addToContext strs = do
1048   s <- getSession
1049   (as,bs) <- io $ GHC.getContext s
1050
1051   (new_as,new_bs) <- separate s strs [] []
1052
1053   let as_to_add = new_as \\ (as ++ bs)
1054       bs_to_add = new_bs \\ (as ++ bs)
1055
1056   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1057
1058
1059 removeFromContext :: [String] -> GHCi ()
1060 removeFromContext strs = do
1061   s <- getSession
1062   (as,bs) <- io $ GHC.getContext s
1063
1064   (as_to_remove,bs_to_remove) <- separate s strs [] []
1065
1066   let as' = as \\ (as_to_remove ++ bs_to_remove)
1067       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1068
1069   io $ GHC.setContext s as' bs'
1070
1071 ----------------------------------------------------------------------------
1072 -- Code for `:set'
1073
1074 -- set options in the interpreter.  Syntax is exactly the same as the
1075 -- ghc command line, except that certain options aren't available (-C,
1076 -- -E etc.)
1077 --
1078 -- This is pretty fragile: most options won't work as expected.  ToDo:
1079 -- figure out which ones & disallow them.
1080
1081 setCmd :: String -> GHCi ()
1082 setCmd ""
1083   = do st <- getGHCiState
1084        let opts = options st
1085        io $ putStrLn (showSDoc (
1086               text "options currently set: " <>
1087               if null opts
1088                    then text "none."
1089                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1090            ))
1091 setCmd str
1092   = case toArgs str of
1093         ("args":args) -> setArgs args
1094         ("prog":prog) -> setProg prog
1095         ("prompt":prompt) -> setPrompt (after 6)
1096         ("editor":cmd) -> setEditor (after 6)
1097         wds -> setOptions wds
1098    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1099
1100 setArgs args = do
1101   st <- getGHCiState
1102   setGHCiState st{ args = args }
1103
1104 setProg [prog] = do
1105   st <- getGHCiState
1106   setGHCiState st{ progname = prog }
1107 setProg _ = do
1108   io (hPutStrLn stderr "syntax: :set prog <progname>")
1109
1110 setEditor cmd = do
1111   st <- getGHCiState
1112   setGHCiState st{ editor = cmd }
1113
1114 setPrompt value = do
1115   st <- getGHCiState
1116   if null value
1117       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1118       else setGHCiState st{ prompt = remQuotes value }
1119   where
1120      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1121      remQuotes x = x
1122
1123 setOptions wds =
1124    do -- first, deal with the GHCi opts (+s, +t, etc.)
1125       let (plus_opts, minus_opts)  = partition isPlus wds
1126       mapM_ setOpt plus_opts
1127
1128       -- then, dynamic flags
1129       dflags <- getDynFlags
1130       let pkg_flags = packageFlags dflags
1131       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1132
1133       if (not (null leftovers))
1134                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1135                                                 unwords leftovers))
1136                 else return ()
1137
1138       new_pkgs <- setDynFlags dflags'
1139
1140       -- if the package flags changed, we should reset the context
1141       -- and link the new packages.
1142       dflags <- getDynFlags
1143       when (packageFlags dflags /= pkg_flags) $ do
1144         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1145         session <- getSession
1146         io (GHC.setTargets session [])
1147         io (GHC.load session LoadAllTargets)
1148         io (linkPackages dflags new_pkgs)
1149         setContextAfterLoad session []
1150       return ()
1151
1152
1153 unsetOptions :: String -> GHCi ()
1154 unsetOptions str
1155   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1156        let opts = words str
1157            (minus_opts, rest1) = partition isMinus opts
1158            (plus_opts, rest2)  = partition isPlus rest1
1159
1160        if (not (null rest2))
1161           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1162           else do
1163
1164        mapM_ unsetOpt plus_opts
1165
1166        -- can't do GHC flags for now
1167        if (not (null minus_opts))
1168           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1169           else return ()
1170
1171 isMinus ('-':s) = True
1172 isMinus _ = False
1173
1174 isPlus ('+':s) = True
1175 isPlus _ = False
1176
1177 setOpt ('+':str)
1178   = case strToGHCiOpt str of
1179         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1180         Just o  -> setOption o
1181
1182 unsetOpt ('+':str)
1183   = case strToGHCiOpt str of
1184         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1185         Just o  -> unsetOption o
1186
1187 strToGHCiOpt :: String -> (Maybe GHCiOption)
1188 strToGHCiOpt "s" = Just ShowTiming
1189 strToGHCiOpt "t" = Just ShowType
1190 strToGHCiOpt "r" = Just RevertCAFs
1191 strToGHCiOpt _   = Nothing
1192
1193 optToStr :: GHCiOption -> String
1194 optToStr ShowTiming = "s"
1195 optToStr ShowType   = "t"
1196 optToStr RevertCAFs = "r"
1197
1198 -- ---------------------------------------------------------------------------
1199 -- code for `:show'
1200
1201 showCmd str =
1202   case words str of
1203         ["modules" ] -> showModules
1204         ["bindings"] -> showBindings
1205         ["linker"]   -> io showLinkerState
1206         ["breaks"] -> showBkptTable
1207         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1208
1209 showModules = do
1210   session <- getSession
1211   let show_one ms = do m <- io (GHC.showModule session ms)
1212                        io (putStrLn m)
1213   graph <- io (GHC.getModuleGraph session)
1214   mapM_ show_one graph
1215
1216 showBindings = do
1217   s <- getSession
1218   unqual <- io (GHC.getPrintUnqual s)
1219   bindings <- io (GHC.getBindings s)
1220   mapM_ showTyThing bindings
1221   return ()
1222
1223 showTyThing (AnId id) = do
1224   ty' <- cleanType (GHC.idType id)
1225   str <- showForUser (ppr id <> text " :: " <> ppr ty')
1226   io (putStrLn str)
1227 showTyThing _  = return ()
1228
1229 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1230 cleanType :: Type -> GHCi Type
1231 cleanType ty = do
1232   dflags <- getDynFlags
1233   if dopt Opt_GlasgowExts dflags
1234         then return ty
1235         else return $! GHC.dropForAlls ty
1236
1237 showBkptTable :: GHCi ()
1238 showBkptTable = do
1239    activeBreaks <- getActiveBreakPoints
1240    str <- showForUser $ ppr activeBreaks
1241    io $ putStrLn str
1242
1243 -- -----------------------------------------------------------------------------
1244 -- Completion
1245
1246 completeNone :: String -> IO [String]
1247 completeNone w = return []
1248
1249 #ifdef USE_READLINE
1250 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1251 completeWord w start end = do
1252   line <- Readline.getLineBuffer
1253   case w of
1254      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1255      _other
1256         | Just c <- is_cmd line -> do
1257            maybe_cmd <- lookupCommand c
1258            let (n,w') = selectWord (words' 0 line)
1259            case maybe_cmd of
1260              Nothing -> return Nothing
1261              Just (_,_,False,complete) -> wrapCompleter complete w
1262              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1263                                                               return (map (drop n) rets)
1264                                          in wrapCompleter complete' w'
1265         | otherwise     -> do
1266                 --printf "complete %s, start = %d, end = %d\n" w start end
1267                 wrapCompleter completeIdentifier w
1268     where words' _ [] = []
1269           words' n str = let (w,r) = break isSpace str
1270                              (s,r') = span isSpace r
1271                          in (n,w):words' (n+length w+length s) r'
1272           -- In a Haskell expression we want to parse 'a-b' as three words
1273           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1274           -- only be a single word.
1275           selectWord [] = (0,w)
1276           selectWord ((offset,x):xs)
1277               | offset+length x >= start = (start-offset,take (end-offset) x)
1278               | otherwise = selectWord xs
1279
1280 is_cmd line
1281  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1282  | otherwise = Nothing
1283
1284 completeCmd w = do
1285   cmds <- readIORef commands
1286   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1287
1288 completeMacro w = do
1289   cmds <- readIORef commands
1290   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1291   return (filter (w `isPrefixOf`) cmds')
1292
1293 completeIdentifier w = do
1294   s <- restoreSession
1295   rdrs <- GHC.getRdrNamesInScope s
1296   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1297
1298 completeModule w = do
1299   s <- restoreSession
1300   dflags <- GHC.getSessionDynFlags s
1301   let pkg_mods = allExposedModules dflags
1302   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1303
1304 completeHomeModule w = do
1305   s <- restoreSession
1306   g <- GHC.getModuleGraph s
1307   let home_mods = map GHC.ms_mod_name g
1308   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1309
1310 completeSetOptions w = do
1311   return (filter (w `isPrefixOf`) options)
1312     where options = "args":"prog":allFlags
1313
1314 completeFilename = Readline.filenameCompletionFunction
1315
1316 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1317
1318 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1319 unionComplete f1 f2 w = do
1320   s1 <- f1 w
1321   s2 <- f2 w
1322   return (s1 ++ s2)
1323
1324 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1325 wrapCompleter fun w =  do
1326   strs <- fun w
1327   case strs of
1328     []  -> return Nothing
1329     [x] -> return (Just (x,[]))
1330     xs  -> case getCommonPrefix xs of
1331                 ""   -> return (Just ("",xs))
1332                 pref -> return (Just (pref,xs))
1333
1334 getCommonPrefix :: [String] -> String
1335 getCommonPrefix [] = ""
1336 getCommonPrefix (s:ss) = foldl common s ss
1337   where common s "" = ""
1338         common "" s = ""
1339         common (c:cs) (d:ds)
1340            | c == d = c : common cs ds
1341            | otherwise = ""
1342
1343 allExposedModules :: DynFlags -> [ModuleName]
1344 allExposedModules dflags
1345  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1346  where
1347   pkg_db = pkgIdMap (pkgState dflags)
1348 #else
1349 completeCmd        = completeNone
1350 completeMacro      = completeNone
1351 completeIdentifier = completeNone
1352 completeModule     = completeNone
1353 completeHomeModule = completeNone
1354 completeSetOptions = completeNone
1355 completeFilename   = completeNone
1356 completeHomeModuleOrFile=completeNone
1357 completeBkpt       = completeNone
1358 #endif
1359
1360 -- ---------------------------------------------------------------------------
1361 -- User code exception handling
1362
1363 -- This is the exception handler for exceptions generated by the
1364 -- user's code and exceptions coming from children sessions;
1365 -- it normally just prints out the exception.  The
1366 -- handler must be recursive, in case showing the exception causes
1367 -- more exceptions to be raised.
1368 --
1369 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1370 -- raising another exception.  We therefore don't put the recursive
1371 -- handler arond the flushing operation, so if stderr is closed
1372 -- GHCi will just die gracefully rather than going into an infinite loop.
1373 handler :: Exception -> GHCi Bool
1374
1375 handler exception = do
1376   flushInterpBuffers
1377   io installSignalHandlers
1378   ghciHandle handler (showException exception >> return False)
1379
1380 showException (DynException dyn) =
1381   case fromDynamic dyn of
1382     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1383     Just Interrupted      -> io (putStrLn "Interrupted.")
1384     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1385     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1386     Just other_ghc_ex     -> io (print other_ghc_ex)
1387
1388 showException other_exception
1389   = io (putStrLn ("*** Exception: " ++ show other_exception))
1390
1391 -----------------------------------------------------------------------------
1392 -- recursive exception handlers
1393
1394 -- Don't forget to unblock async exceptions in the handler, or if we're
1395 -- in an exception loop (eg. let a = error a in a) the ^C exception
1396 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1397
1398 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1399 ghciHandle h (GHCi m) = GHCi $ \s ->
1400    Exception.catch (m s)
1401         (\e -> unGHCi (ghciUnblock (h e)) s)
1402
1403 ghciUnblock :: GHCi a -> GHCi a
1404 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1405
1406
1407 -- ----------------------------------------------------------------------------
1408 -- Utils
1409
1410 expandPath :: String -> GHCi String
1411 expandPath path =
1412   case dropWhile isSpace path of
1413    ('~':d) -> do
1414         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1415         return (tilde ++ '/':d)
1416    other ->
1417         return other
1418
1419 -- ----------------------------------------------------------------------------
1420 -- Windows console setup
1421
1422 setUpConsole :: IO ()
1423 setUpConsole = do
1424 #ifdef mingw32_HOST_OS
1425         -- On Windows we need to set a known code page, otherwise the characters
1426         -- we read from the console will be be in some strange encoding, and
1427         -- similarly for characters we write to the console.
1428         --
1429         -- At the moment, GHCi pretends all input is Latin-1.  In the
1430         -- future we should support UTF-8, but for now we set the code pages
1431         -- to Latin-1.
1432         --
1433         -- It seems you have to set the font in the console window to
1434         -- a Unicode font in order for output to work properly,
1435         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1436         -- (see MSDN for SetConsoleOutputCP()).
1437         --
1438         setConsoleCP 28591       -- ISO Latin-1
1439         setConsoleOutputCP 28591 -- ISO Latin-1
1440 #endif
1441         return ()
1442
1443 -- commands for debugger
1444 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1445
1446 stepCmd :: String -> GHCi Bool
1447 stepCmd [] = doContinue setStepFlag
1448 stepCmd expression = do
1449    io $ setStepFlag
1450    runCommand expression
1451
1452 continueCmd :: String -> GHCi Bool
1453 continueCmd [] = doContinue $ return ()
1454 continueCmd other = do
1455    io $ putStrLn "The continue command accepts no arguments."
1456    return False
1457
1458 doContinue :: IO () -> GHCi Bool
1459 doContinue actionBeforeCont = do
1460    resumeAction <- popResume
1461    case resumeAction of
1462       Nothing -> do
1463          io $ putStrLn "There is no computation running."
1464          return False
1465       Just (_,_,handle) -> do
1466          io $ actionBeforeCont
1467          session <- getSession
1468          runResult <- io $ GHC.resume session handle
1469          names <- switchOnRunResult runResult
1470          finishEvalExpr names
1471          return False
1472
1473 deleteCmd :: String -> GHCi Bool
1474 deleteCmd argLine = do
1475    deleteSwitch $ words argLine
1476    return False
1477    where
1478    deleteSwitch :: [String] -> GHCi ()
1479    deleteSwitch [] =
1480       io $ putStrLn "The delete command requires at least one argument."
1481    -- delete all break points
1482    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1483    deleteSwitch idents = do
1484       mapM_ deleteOneBreak idents
1485       where
1486       deleteOneBreak :: String -> GHCi ()
1487       deleteOneBreak str
1488          | all isDigit str = deleteBreak (read str)
1489          | otherwise = return ()
1490
1491 -- handle the "break" command
1492 breakCmd :: String -> GHCi Bool
1493 breakCmd argLine = do
1494    session <- getSession
1495    breakSwitch session $ words argLine
1496
1497 breakSwitch :: Session -> [String] -> GHCi Bool
1498 breakSwitch _session [] = do
1499    io $ putStrLn "The break command requires at least one argument."
1500    return False
1501 breakSwitch session args@(arg1:rest)
1502    | looksLikeModule arg1 = do
1503         mod <- wantInterpretedModule session arg1
1504         breakByModule mod rest
1505         return False
1506    | otherwise = do
1507         (toplevel, _) <- io $ GHC.getContext session
1508         case toplevel of
1509            (mod : _) -> breakByModule mod args
1510            [] -> do
1511               io $ putStrLn "Cannot find default module for breakpoint."
1512               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1513         return False
1514    where
1515    -- Todo there may be a nicer way to test this
1516    looksLikeModule :: String -> Bool
1517    looksLikeModule []    = False
1518    looksLikeModule (x:_) = isUpper x
1519
1520 wantInterpretedModule :: Session -> String -> GHCi Module
1521 wantInterpretedModule session str = do
1522    modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1523    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1524    when (not is_interpreted) $
1525        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1526    return modl
1527
1528 breakByModule :: Module -> [String] -> GHCi ()
1529 breakByModule mod args@(arg1:rest)
1530    | all isDigit arg1 = do  -- looks like a line number
1531         breakByModuleLine mod (read arg1) rest
1532    | looksLikeVar arg1 = do
1533         -- break by a function definition
1534         io $ putStrLn "Break by function definition not implemented."
1535    | otherwise = io $ putStrLn "Invalid arguments to break command."
1536    where
1537    -- Todo there may be a nicer way to test this
1538    looksLikeVar :: String -> Bool
1539    looksLikeVar [] = False
1540    looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+"
1541
1542 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1543 breakByModuleLine mod line args
1544    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1545    | [col] <- args, all isDigit col =
1546         findBreakAndSet mod $ findBreakByCoord (line, read col)
1547    | otherwise = io $ putStrLn "Invalid arguments to break command."
1548
1549 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1550 findBreakAndSet mod lookupTickTree = do
1551    tickArray <- getTickArray mod
1552    (breakArray, _) <- getModBreak mod
1553    case lookupTickTree tickArray of
1554       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1555       Just (tick, span) -> do
1556          success <- io $ setBreakFlag True breakArray tick
1557          session <- getSession
1558          unqual  <- io $ GHC.getPrintUnqual session
1559          if success
1560             then do
1561                (alreadySet, nm) <-
1562                      recordBreak $ BreakLocation
1563                              { breakModule = mod
1564                              , breakLoc = span
1565                              , breakTick = tick
1566                              }
1567                io $ printForUser stdout unqual $
1568                   text "Breakpoint " <> ppr nm <>
1569                   if alreadySet
1570                      then text " was already set at " <> ppr span
1571                      else text " activated at " <> ppr span
1572             else do
1573             str <- showForUser $ text "Breakpoint could not be activated at"
1574                                  <+> ppr span
1575             io $ putStrLn str
1576
1577 -- When a line number is specified, the current policy for choosing
1578 -- the best breakpoint is this:
1579 --    - the leftmost complete subexpression on the specified line, or
1580 --    - the leftmost subexpression starting on the specified line, or
1581 --    - the rightmost subexpression enclosing the specified line
1582 --
1583 findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
1584 findBreakByLine line arr =
1585   listToMaybe (sortBy leftmost complete)   `mplus`
1586   listToMaybe (sortBy leftmost incomplete) `mplus`
1587   listToMaybe (sortBy rightmost ticks)
1588   where
1589         ticks = arr ! line
1590
1591         starts_here = [ tick | tick@(nm,span) <- ticks,
1592                                srcSpanStartLine span == line ]
1593
1594         (complete,incomplete) = partition ends_here starts_here
1595             where ends_here (nm,span) = srcSpanEndLine span == line
1596
1597 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
1598 findBreakByCoord (line, col) arr =
1599   listToMaybe (sortBy rightmost contains)
1600   where
1601         ticks = arr ! line
1602
1603         -- the ticks that span this coordinate
1604         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
1605
1606 leftmost  (_,a) (_,b) = a `compare` b
1607 rightmost (_,a) (_,b) = b `compare` a
1608
1609 spans :: SrcSpan -> (Int,Int) -> Bool
1610 spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
1611    where loc = mkSrcLoc (srcSpanFile span) l c
1612
1613
1614 -- --------------------------------------------------------------------------
1615 -- Tick arrays
1616
1617 getTickArray :: Module -> GHCi TickArray
1618 getTickArray modl = do
1619    st <- getGHCiState
1620    let arrmap = tickarrays st
1621    case lookupModuleEnv arrmap modl of
1622       Just arr -> return arr
1623       Nothing  -> do
1624         (breakArray, ticks) <- getModBreak modl
1625         let arr = mkTickArray (assocs ticks)
1626         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1627         return arr
1628
1629 discardTickArrays :: GHCi ()
1630 discardTickArrays = do
1631    st <- getGHCiState
1632    setGHCiState st{tickarrays = emptyModuleEnv}
1633
1634 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1635 mkTickArray ticks
1636   = accumArray (flip (:)) [] (1, max_line)
1637         [ (line, (nm,span)) | (nm,span) <- ticks,
1638                               line <- srcSpanLines span ]
1639     where
1640         max_line = maximum (map srcSpanEndLine (map snd ticks))
1641         srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
1642
1643 getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
1644 getModBreak mod = do
1645    session <- getSession
1646    Just mod_info <- io $ GHC.getModuleInfo session mod
1647    let modBreaks  = GHC.modInfoModBreaks mod_info
1648    let array      = GHC.modBreaks_flags modBreaks
1649    let ticks      = GHC.modBreaks_locs  modBreaks
1650    return (array, ticks)
1651
1652 lookupModule :: Session -> String -> GHCi Module
1653 lookupModule session modName
1654    = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1655
1656 setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool
1657 setBreakFlag toggle array index
1658    | toggle    = setBreakOn array index
1659    | otherwise = setBreakOff array index
1660
1661
1662 {- these should probably go to the GHC API at some point -}
1663 enableBreakPoint  :: Session -> Module -> Int -> IO ()
1664 enableBreakPoint session mod index = return ()
1665
1666 disableBreakPoint :: Session -> Module -> Int -> IO ()
1667 disableBreakPoint session mod index = return ()
1668
1669 activeBreakPoints :: Session -> IO [(Module,Int)]
1670 activeBreakPoints session = return []
1671
1672 enableSingleStep  :: Session -> IO ()
1673 enableSingleStep session = return ()
1674
1675 disableSingleStep :: Session -> IO ()
1676 disableSingleStep session = return ()