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       hiding (printForUser)
  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) )
  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, completeIdentifier),
 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, completeIdentifier),
 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    printForUser $ ptext SLIT("Stopped at") <+> ppr location
 521
 522    pushResume location threadId resume
 523    return (Just (True,names))
 524
 525 -- possibly print the type and revert CAFs after evaluating an expression
 526 finishEvalExpr mb_names
 527  = do show_types <- isOptionSet ShowType
 528       session <- getSession
 529       case mb_names of
 530         Nothing    -> return ()
 531         Just (is_break,names) ->
 532                 when (is_break || show_types) $
 533                       mapM_ (showTypeOfName session) names
 534
 535       flushInterpBuffers
 536       io installSignalHandlers
 537       b <- isOptionSet RevertCAFs
 538       io (when b revertCAFs)
 539       return True
 540
 541 showTypeOfName :: Session -> Name -> GHCi ()
 542 showTypeOfName session n
 543    = do maybe_tything <- io (GHC.lookupName session n)
 544         case maybe_tything of
 545           Nothing    -> return ()
 546           Just thing -> showTyThing thing
 547
 548 specialCommand :: String -> GHCi Bool
 549 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 550 specialCommand str = do
 551   let (cmd,rest) = break isSpace str
 552   maybe_cmd <- io (lookupCommand cmd)
 553   case maybe_cmd of
 554     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 555                                     ++ shortHelpText) >> return False)
 556     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 557
 558 lookupCommand :: String -> IO (Maybe Command)
 559 lookupCommand str = do
 560   cmds <- readIORef commands
 561   -- look for exact match first, then the first prefix match
 562   case [ c | c <- cmds, str == cmdName c ] of
 563      c:_ -> return (Just c)
 564      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 565                 [] -> return Nothing
 566                 c:_ -> return (Just c)
 567
 568 -----------------------------------------------------------------------------
 569 -- Commands
 570
 571 help :: String -> GHCi ()
 572 help _ = io (putStr helpText)
 573
 574 info :: String -> GHCi ()
 575 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 576 info s  = do { let names = words s
 577              ; session <- getSession
 578              ; dflags <- getDynFlags
 579              ; let exts = dopt Opt_GlasgowExts dflags
 580              ; mapM_ (infoThing exts session) names }
 581   where
 582     infoThing exts session str = io $ do
 583         names <- GHC.parseName session str
 584         let filtered = filterOutChildren names
 585         mb_stuffs <- mapM (GHC.getInfo session) filtered
 586         unqual <- GHC.getPrintUnqual session
 587         putStrLn (showSDocForUser unqual $
 588                    vcat (intersperse (text "") $
 589                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 590
 591   -- Filter out names whose parent is also there Good
 592   -- example is '[]', which is both a type and data
 593   -- constructor in the same type
 594 filterOutChildren :: [Name] -> [Name]
 595 filterOutChildren names = filter (not . parent_is_there) names
 596  where parent_is_there n
 597 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 598 -- ToDo!!
 599          | otherwise                       = False
 600
 601 pprInfo exts (thing, fixity, insts)
 602   =  pprTyThingInContextLoc exts thing
 603   $$ show_fixity fixity
 604   $$ vcat (map GHC.pprInstance insts)
 605   where
 606     show_fixity fix
 607         | fix == GHC.defaultFixity = empty
 608         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 609
 610 -----------------------------------------------------------------------------
 611 -- Commands
 612
 613 runMain :: String -> GHCi ()
 614 runMain args = do
 615   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 616   runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
 617   return ()
 618
 619 addModule :: [FilePath] -> GHCi ()
 620 addModule files = do
 621   io (revertCAFs)                       -- always revert CAFs on load/add.
 622   files <- mapM expandPath files
 623   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 624   session <- getSession
 625   io (mapM_ (GHC.addTarget session) targets)
 626   ok <- io (GHC.load session LoadAllTargets)
 627   afterLoad ok session
 628
 629 changeDirectory :: String -> GHCi ()
 630 changeDirectory dir = do
 631   session <- getSession
 632   graph <- io (GHC.getModuleGraph session)
 633   when (not (null graph)) $
 634         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 635   io (GHC.setTargets session [])
 636   io (GHC.load session LoadAllTargets)
 637   setContextAfterLoad session []
 638   io (GHC.workingDirectoryChanged session)
 639   dir <- expandPath dir
 640   io (setCurrentDirectory dir)
 641
 642 editFile :: String -> GHCi ()
 643 editFile str
 644   | null str  = do
 645         -- find the name of the "topmost" file loaded
 646      session <- getSession
 647      graph0 <- io (GHC.getModuleGraph session)
 648      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 649      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 650      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 651         Just file -> do_edit file
 652         Nothing   -> throwDyn (CmdLineError "unknown file name")
 653   | otherwise = do_edit str
 654   where
 655         do_edit file = do
 656            st <- getGHCiState
 657            let cmd = editor st
 658            when (null cmd) $
 659                 throwDyn (CmdLineError "editor not set, use :set editor")
 660            io $ system (cmd ++ ' ':file)
 661            return ()
 662
 663 defineMacro :: String -> GHCi ()
 664 defineMacro s = do
 665   let (macro_name, definition) = break isSpace s
 666   cmds <- io (readIORef commands)
 667   if (null macro_name)
 668         then throwDyn (CmdLineError "invalid macro name")
 669         else do
 670   if (macro_name `elem` map cmdName cmds)
 671         then throwDyn (CmdLineError
 672                 ("command '" ++ macro_name ++ "' is already defined"))
 673         else do
 674
 675   -- give the expression a type signature, so we can be sure we're getting
 676   -- something of the right type.
 677   let new_expr = '(' : definition ++ ") :: String -> IO String"
 678
 679   -- compile the expression
 680   cms <- getSession
 681   maybe_hv <- io (GHC.compileExpr cms new_expr)
 682   case maybe_hv of
 683      Nothing -> return ()
 684      Just hv -> io (writeIORef commands --
 685                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 686
 687 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 688 runMacro fun s = do
 689   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 690   stringLoop (lines str)
 691
 692 undefineMacro :: String -> GHCi ()
 693 undefineMacro macro_name = do
 694   cmds <- io (readIORef commands)
 695   if (macro_name `elem` map cmdName builtin_commands)
 696         then throwDyn (CmdLineError
 697                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 698         else do
 699   if (macro_name `notElem` map cmdName cmds)
 700         then throwDyn (CmdLineError
 701                 ("command '" ++ macro_name ++ "' not defined"))
 702         else do
 703   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 704
 705
 706 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 707 loadModule fs = timeIt (loadModule' fs)
 708
 709 loadModule_ :: [FilePath] -> GHCi ()
 710 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 711
 712 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 713 loadModule' files = do
 714   session <- getSession
 715
 716   -- unload first
 717   io (GHC.setTargets session [])
 718   io (GHC.load session LoadAllTargets)
 719
 720   -- expand tildes
 721   let (filenames, phases) = unzip files
 722   exp_filenames <- mapM expandPath filenames
 723   let files' = zip exp_filenames phases
 724   targets <- io (mapM (uncurry GHC.guessTarget) files')
 725
 726   -- NOTE: we used to do the dependency anal first, so that if it
 727   -- fails we didn't throw away the current set of modules.  This would
 728   -- require some re-working of the GHC interface, so we'll leave it
 729   -- as a ToDo for now.
 730
 731   io (GHC.setTargets session targets)
 732   ok <- io (GHC.load session LoadAllTargets)
 733   afterLoad ok session
 734   return ok
 735
 736 checkModule :: String -> GHCi ()
 737 checkModule m = do
 738   let modl = GHC.mkModuleName m
 739   session <- getSession
 740   result <- io (GHC.checkModule session modl)
 741   case result of
 742     Nothing -> io $ putStrLn "Nothing"
 743     Just r  -> io $ putStrLn (showSDoc (
 744         case GHC.checkedModuleInfo r of
 745            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 746                 let
 747                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 748                 in
 749                         (text "global names: " <+> ppr global) $$
 750                         (text "local  names: " <+> ppr local)
 751            _ -> empty))
 752   afterLoad (successIf (isJust result)) session
 753
 754 reloadModule :: String -> GHCi ()
 755 reloadModule "" = do
 756   io (revertCAFs)               -- always revert CAFs on reload.
 757   session <- getSession
 758   ok <- io (GHC.load session LoadAllTargets)
 759   afterLoad ok session
 760 reloadModule m = do
 761   io (revertCAFs)               -- always revert CAFs on reload.
 762   session <- getSession
 763   ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
 764   afterLoad ok session
 765
 766 afterLoad ok session = do
 767   io (revertCAFs)  -- always revert CAFs on load.
 768   discardResumeContext
 769   discardTickArrays
 770   discardActiveBreakPoints
 771   graph <- io (GHC.getModuleGraph session)
 772   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 773   setContextAfterLoad session graph'
 774   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 775
 776 setContextAfterLoad session [] = do
 777   prel_mod <- getPrelude
 778   io (GHC.setContext session [] [prel_mod])
 779 setContextAfterLoad session ms = do
 780   -- load a target if one is available, otherwise load the topmost module.
 781   targets <- io (GHC.getTargets session)
 782   case [ m | Just m <- map (findTarget ms) targets ] of
 783         []    ->
 784           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 785           load_this (last graph')
 786         (m:_) ->
 787           load_this m
 788  where
 789    findTarget ms t
 790     = case filter (`matches` t) ms of
 791         []    -> Nothing
 792         (m:_) -> Just m
 793
 794    summary `matches` Target (TargetModule m) _
 795         = GHC.ms_mod_name summary == m
 796    summary `matches` Target (TargetFile f _) _
 797         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 798    summary `matches` target
 799         = False
 800
 801    load_this summary | m <- GHC.ms_mod summary = do
 802         b <- io (GHC.moduleIsInterpreted session m)
 803         if b then io (GHC.setContext session [m] [])
 804              else do
 805                    prel_mod <- getPrelude
 806                    io (GHC.setContext session []  [prel_mod,m])
 807
 808
 809 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 810 modulesLoadedMsg ok mods = do
 811   dflags <- getDynFlags
 812   when (verbosity dflags > 0) $ do
 813    let mod_commas
 814         | null mods = text "none."
 815         | otherwise = hsep (
 816             punctuate comma (map ppr mods)) <> text "."
 817    case ok of
 818     Failed ->
 819        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 820     Succeeded  ->
 821        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 822
 823
 824 typeOfExpr :: String -> GHCi ()
 825 typeOfExpr str
 826   = do cms <- getSession
 827        maybe_ty <- io (GHC.exprType cms str)
 828        case maybe_ty of
 829           Nothing -> return ()
 830           Just ty -> do ty' <- cleanType ty
 831                         printForUser $ text str <> text " :: " <> ppr ty'
 832
 833 kindOfType :: String -> GHCi ()
 834 kindOfType str
 835   = do cms <- getSession
 836        maybe_ty <- io (GHC.typeKind cms str)
 837        case maybe_ty of
 838           Nothing    -> return ()
 839           Just ty    -> printForUser $ text str <> text " :: " <> ppr ty
 840
 841 quit :: String -> GHCi Bool
 842 quit _ = return True
 843
 844 shellEscape :: String -> GHCi Bool
 845 shellEscape str = io (system str >> return False)
 846
 847 -----------------------------------------------------------------------------
 848 -- create tags file for currently loaded modules.
 849
 850 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
 851
 852 createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
 853 createCTagsFileCmd file = ghciCreateTagsFile CTags file
 854
 855 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
 856 createETagsFileCmd file  = ghciCreateTagsFile ETags file
 857
 858 data TagsKind = ETags | CTags
 859
 860 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
 861 ghciCreateTagsFile kind file = do
 862   session <- getSession
 863   io $ createTagsFile session kind file
 864
 865 -- ToDo:
 866 --      - remove restriction that all modules must be interpreted
 867 --        (problem: we don't know source locations for entities unless
 868 --        we compiled the module.
 869 --
 870 --      - extract createTagsFile so it can be used from the command-line
 871 --        (probably need to fix first problem before this is useful).
 872 --
 873 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
 874 createTagsFile session tagskind tagFile = do
 875   graph <- GHC.getModuleGraph session
 876   let ms = map GHC.ms_mod graph
 877       tagModule m = do
 878         is_interpreted <- GHC.moduleIsInterpreted session m
 879         -- should we just skip these?
 880         when (not is_interpreted) $
 881           throwDyn (CmdLineError ("module '"
 882                                 ++ GHC.moduleNameString (GHC.moduleName m)
 883                                 ++ "' is not interpreted"))
 884         mbModInfo <- GHC.getModuleInfo session m
 885         let unqual
 886               | Just modinfo <- mbModInfo,
 887                 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
 888               | otherwise = GHC.alwaysQualify
 889
 890         case mbModInfo of
 891           Just modInfo -> return $! listTags unqual modInfo
 892           _            -> return []
 893
 894   mtags <- mapM tagModule ms
 895   either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
 896   case either_res of
 897     Left e  -> hPutStrLn stderr $ ioeGetErrorString e
 898     Right _ -> return ()
 899
 900 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
 901 listTags unqual modInfo =
 902            [ tagInfo unqual name loc
 903            | name <- GHC.modInfoExports modInfo
 904            , let loc = nameSrcLoc name
 905            , isGoodSrcLoc loc
 906            ]
 907
 908 type TagInfo = (String -- tag name
 909                ,String -- file name
 910                ,Int    -- line number
 911                ,Int    -- column number
 912                )
 913
 914 -- get tag info, for later translation into Vim or Emacs style
 915 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
 916 tagInfo unqual name loc
 917     = ( showSDocForUser unqual $ pprOccName (nameOccName name)
 918       , showSDocForUser unqual $ ftext (srcLocFile loc)
 919       , srcLocLine loc
 920       , srcLocCol loc
 921       )
 922
 923 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
 924 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
 925   let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
 926   IO.try (writeFile file tags)
 927 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
 928   let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
 929       groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
 930   tagGroups <- mapM tagFileGroup groups
 931   IO.try (writeFile file $ concat tagGroups)
 932   where
 933     tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
 934     tagFileGroup group@((_,fileName,_,_):_) = do
 935       file <- readFile fileName -- need to get additional info from sources..
 936       let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
 937           sortedGroup = sortLe byLine group
 938           tags = unlines $ perFile sortedGroup 1 0 $ lines file
 939       return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
 940     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
 941       perFile (tagInfo:tags) (count+1) (pos+length line) lines
 942     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
 943       showETag tagInfo line pos : perFile tags count pos lines
 944     perFile tags count pos lines = []
 945
 946 -- simple ctags format, for Vim et al
 947 showTag :: TagInfo -> String
 948 showTag (tag,file,lineNo,colNo)
 949     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
 950
 951 -- etags format, for Emacs/XEmacs
 952 showETag :: TagInfo -> String -> Int -> String
 953 showETag (tag,file,lineNo,colNo) line charPos
 954     =  take colNo line ++ tag
 955     ++ "\x7f" ++ tag
 956     ++ "\x01" ++ show lineNo
 957     ++ "," ++ show charPos
 958
 959 -----------------------------------------------------------------------------
 960 -- Browsing a module's contents
 961
 962 browseCmd :: String -> GHCi ()
 963 browseCmd m =
 964   case words m of
 965     ['*':m] | looksLikeModuleName m -> browseModule m False
 966     [m]     | looksLikeModuleName m -> browseModule m True
 967     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 968
 969 browseModule m exports_only = do
 970   s <- getSession
 971   modl <- if exports_only then lookupModule s m
 972                           else wantInterpretedModule s m
 973
 974   -- Temporarily set the context to the module we're interested in,
 975   -- just so we can get an appropriate PrintUnqualified
 976   (as,bs) <- io (GHC.getContext s)
 977   prel_mod <- getPrelude
 978   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 979                       else GHC.setContext s [modl] [])
 980   unqual <- io (GHC.getPrintUnqual s)
 981   io (GHC.setContext s as bs)
 982
 983   mb_mod_info <- io $ GHC.getModuleInfo s modl
 984   case mb_mod_info of
 985     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 986     Just mod_info -> do
 987         let names
 988                | exports_only = GHC.modInfoExports mod_info
 989                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 990
 991             filtered = filterOutChildren names
 992
 993         things <- io $ mapM (GHC.lookupName s) filtered
 994
 995         dflags <- getDynFlags
 996         let exts = dopt Opt_GlasgowExts dflags
 997         io (putStrLn (showSDocForUser unqual (
 998                 vcat (map (pprTyThingInContext exts) (catMaybes things))
 999            )))
1000         -- ToDo: modInfoInstances currently throws an exception for
1001         -- package modules.  When it works, we can do this:
1002         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1003
1004 -----------------------------------------------------------------------------
1005 -- Setting the module context
1006
1007 setContext str
1008   | all sensible mods = fn mods
1009   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1010   where
1011     (fn, mods) = case str of
1012                         '+':stuff -> (addToContext,      words stuff)
1013                         '-':stuff -> (removeFromContext, words stuff)
1014                         stuff     -> (newContext,        words stuff)
1015
1016     sensible ('*':m) = looksLikeModuleName m
1017     sensible m       = looksLikeModuleName m
1018
1019 separate :: Session -> [String] -> [Module] -> [Module]
1020         -> GHCi ([Module],[Module])
1021 separate session []           as bs = return (as,bs)
1022 separate session (('*':str):ms) as bs = do
1023    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1024    b <- io $ GHC.moduleIsInterpreted session m
1025    if b then separate session ms (m:as) bs
1026         else throwDyn (CmdLineError ("module '"
1027                         ++ GHC.moduleNameString (GHC.moduleName m)
1028                         ++ "' is not interpreted"))
1029 separate session (str:ms) as bs = do
1030   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1031   separate session ms as (m:bs)
1032
1033 newContext :: [String] -> GHCi ()
1034 newContext strs = do
1035   s <- getSession
1036   (as,bs) <- separate s strs [] []
1037   prel_mod <- getPrelude
1038   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1039   io $ GHC.setContext s as bs'
1040
1041
1042 addToContext :: [String] -> GHCi ()
1043 addToContext strs = do
1044   s <- getSession
1045   (as,bs) <- io $ GHC.getContext s
1046
1047   (new_as,new_bs) <- separate s strs [] []
1048
1049   let as_to_add = new_as \\ (as ++ bs)
1050       bs_to_add = new_bs \\ (as ++ bs)
1051
1052   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1053
1054
1055 removeFromContext :: [String] -> GHCi ()
1056 removeFromContext strs = do
1057   s <- getSession
1058   (as,bs) <- io $ GHC.getContext s
1059
1060   (as_to_remove,bs_to_remove) <- separate s strs [] []
1061
1062   let as' = as \\ (as_to_remove ++ bs_to_remove)
1063       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1064
1065   io $ GHC.setContext s as' bs'
1066
1067 ----------------------------------------------------------------------------
1068 -- Code for `:set'
1069
1070 -- set options in the interpreter.  Syntax is exactly the same as the
1071 -- ghc command line, except that certain options aren't available (-C,
1072 -- -E etc.)
1073 --
1074 -- This is pretty fragile: most options won't work as expected.  ToDo:
1075 -- figure out which ones & disallow them.
1076
1077 setCmd :: String -> GHCi ()
1078 setCmd ""
1079   = do st <- getGHCiState
1080        let opts = options st
1081        io $ putStrLn (showSDoc (
1082               text "options currently set: " <>
1083               if null opts
1084                    then text "none."
1085                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1086            ))
1087 setCmd str
1088   = case toArgs str of
1089         ("args":args) -> setArgs args
1090         ("prog":prog) -> setProg prog
1091         ("prompt":prompt) -> setPrompt (after 6)
1092         ("editor":cmd) -> setEditor (after 6)
1093         wds -> setOptions wds
1094    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1095
1096 setArgs args = do
1097   st <- getGHCiState
1098   setGHCiState st{ args = args }
1099
1100 setProg [prog] = do
1101   st <- getGHCiState
1102   setGHCiState st{ progname = prog }
1103 setProg _ = do
1104   io (hPutStrLn stderr "syntax: :set prog <progname>")
1105
1106 setEditor cmd = do
1107   st <- getGHCiState
1108   setGHCiState st{ editor = cmd }
1109
1110 setPrompt value = do
1111   st <- getGHCiState
1112   if null value
1113       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1114       else setGHCiState st{ prompt = remQuotes value }
1115   where
1116      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1117      remQuotes x = x
1118
1119 setOptions wds =
1120    do -- first, deal with the GHCi opts (+s, +t, etc.)
1121       let (plus_opts, minus_opts)  = partition isPlus wds
1122       mapM_ setOpt plus_opts
1123
1124       -- then, dynamic flags
1125       dflags <- getDynFlags
1126       let pkg_flags = packageFlags dflags
1127       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1128
1129       if (not (null leftovers))
1130                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1131                                                 unwords leftovers))
1132                 else return ()
1133
1134       new_pkgs <- setDynFlags dflags'
1135
1136       -- if the package flags changed, we should reset the context
1137       -- and link the new packages.
1138       dflags <- getDynFlags
1139       when (packageFlags dflags /= pkg_flags) $ do
1140         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1141         session <- getSession
1142         io (GHC.setTargets session [])
1143         io (GHC.load session LoadAllTargets)
1144         io (linkPackages dflags new_pkgs)
1145         setContextAfterLoad session []
1146       return ()
1147
1148
1149 unsetOptions :: String -> GHCi ()
1150 unsetOptions str
1151   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1152        let opts = words str
1153            (minus_opts, rest1) = partition isMinus opts
1154            (plus_opts, rest2)  = partition isPlus rest1
1155
1156        if (not (null rest2))
1157           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1158           else do
1159
1160        mapM_ unsetOpt plus_opts
1161
1162        -- can't do GHC flags for now
1163        if (not (null minus_opts))
1164           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1165           else return ()
1166
1167 isMinus ('-':s) = True
1168 isMinus _ = False
1169
1170 isPlus ('+':s) = True
1171 isPlus _ = False
1172
1173 setOpt ('+':str)
1174   = case strToGHCiOpt str of
1175         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1176         Just o  -> setOption o
1177
1178 unsetOpt ('+':str)
1179   = case strToGHCiOpt str of
1180         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1181         Just o  -> unsetOption o
1182
1183 strToGHCiOpt :: String -> (Maybe GHCiOption)
1184 strToGHCiOpt "s" = Just ShowTiming
1185 strToGHCiOpt "t" = Just ShowType
1186 strToGHCiOpt "r" = Just RevertCAFs
1187 strToGHCiOpt _   = Nothing
1188
1189 optToStr :: GHCiOption -> String
1190 optToStr ShowTiming = "s"
1191 optToStr ShowType   = "t"
1192 optToStr RevertCAFs = "r"
1193
1194 -- ---------------------------------------------------------------------------
1195 -- code for `:show'
1196
1197 showCmd str =
1198   case words str of
1199         ["modules" ] -> showModules
1200         ["bindings"] -> showBindings
1201         ["linker"]   -> io showLinkerState
1202         ["breaks"] -> showBkptTable
1203         ["context"] -> showContext
1204         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings|breaks]")
1205
1206 showModules = do
1207   session <- getSession
1208   let show_one ms = do m <- io (GHC.showModule session ms)
1209                        io (putStrLn m)
1210   graph <- io (GHC.getModuleGraph session)
1211   mapM_ show_one graph
1212
1213 showBindings = do
1214   s <- getSession
1215   unqual <- io (GHC.getPrintUnqual s)
1216   bindings <- io (GHC.getBindings s)
1217   mapM_ showTyThing bindings
1218   return ()
1219
1220 showTyThing (AnId id) = do
1221   ty' <- cleanType (GHC.idType id)
1222   printForUser $ ppr id <> text " :: " <> ppr ty'
1223 showTyThing _  = return ()
1224
1225 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1226 cleanType :: Type -> GHCi Type
1227 cleanType ty = do
1228   dflags <- getDynFlags
1229   if dopt Opt_GlasgowExts dflags
1230         then return ty
1231         else return $! GHC.dropForAlls ty
1232
1233 showBkptTable :: GHCi ()
1234 showBkptTable = do
1235    activeBreaks <- getActiveBreakPoints
1236    printForUser $ ppr activeBreaks
1237
1238 showContext :: GHCi ()
1239 showContext = do
1240    st <- getGHCiState
1241    printForUser $ vcat (map pp_resume (resume st))
1242   where
1243    pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
1244
1245 -- -----------------------------------------------------------------------------
1246 -- Completion
1247
1248 completeNone :: String -> IO [String]
1249 completeNone w = return []
1250
1251 #ifdef USE_READLINE
1252 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1253 completeWord w start end = do
1254   line <- Readline.getLineBuffer
1255   case w of
1256      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1257      _other
1258         | Just c <- is_cmd line -> do
1259            maybe_cmd <- lookupCommand c
1260            let (n,w') = selectWord (words' 0 line)
1261            case maybe_cmd of
1262              Nothing -> return Nothing
1263              Just (_,_,False,complete) -> wrapCompleter complete w
1264              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1265                                                               return (map (drop n) rets)
1266                                          in wrapCompleter complete' w'
1267         | otherwise     -> do
1268                 --printf "complete %s, start = %d, end = %d\n" w start end
1269                 wrapCompleter completeIdentifier w
1270     where words' _ [] = []
1271           words' n str = let (w,r) = break isSpace str
1272                              (s,r') = span isSpace r
1273                          in (n,w):words' (n+length w+length s) r'
1274           -- In a Haskell expression we want to parse 'a-b' as three words
1275           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1276           -- only be a single word.
1277           selectWord [] = (0,w)
1278           selectWord ((offset,x):xs)
1279               | offset+length x >= start = (start-offset,take (end-offset) x)
1280               | otherwise = selectWord xs
1281
1282 is_cmd line
1283  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1284  | otherwise = Nothing
1285
1286 completeCmd w = do
1287   cmds <- readIORef commands
1288   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1289
1290 completeMacro w = do
1291   cmds <- readIORef commands
1292   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1293   return (filter (w `isPrefixOf`) cmds')
1294
1295 completeIdentifier w = do
1296   s <- restoreSession
1297   rdrs <- GHC.getRdrNamesInScope s
1298   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1299
1300 completeModule w = do
1301   s <- restoreSession
1302   dflags <- GHC.getSessionDynFlags s
1303   let pkg_mods = allExposedModules dflags
1304   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1305
1306 completeHomeModule w = do
1307   s <- restoreSession
1308   g <- GHC.getModuleGraph s
1309   let home_mods = map GHC.ms_mod_name g
1310   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1311
1312 completeSetOptions w = do
1313   return (filter (w `isPrefixOf`) options)
1314     where options = "args":"prog":allFlags
1315
1316 completeFilename = Readline.filenameCompletionFunction
1317
1318 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1319
1320 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1321 unionComplete f1 f2 w = do
1322   s1 <- f1 w
1323   s2 <- f2 w
1324   return (s1 ++ s2)
1325
1326 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1327 wrapCompleter fun w =  do
1328   strs <- fun w
1329   case strs of
1330     []  -> return Nothing
1331     [x] -> return (Just (x,[]))
1332     xs  -> case getCommonPrefix xs of
1333                 ""   -> return (Just ("",xs))
1334                 pref -> return (Just (pref,xs))
1335
1336 getCommonPrefix :: [String] -> String
1337 getCommonPrefix [] = ""
1338 getCommonPrefix (s:ss) = foldl common s ss
1339   where common s "" = ""
1340         common "" s = ""
1341         common (c:cs) (d:ds)
1342            | c == d = c : common cs ds
1343            | otherwise = ""
1344
1345 allExposedModules :: DynFlags -> [ModuleName]
1346 allExposedModules dflags
1347  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1348  where
1349   pkg_db = pkgIdMap (pkgState dflags)
1350 #else
1351 completeCmd        = completeNone
1352 completeMacro      = completeNone
1353 completeIdentifier = completeNone
1354 completeModule     = completeNone
1355 completeHomeModule = completeNone
1356 completeSetOptions = completeNone
1357 completeFilename   = completeNone
1358 completeHomeModuleOrFile=completeNone
1359 completeBkpt       = completeNone
1360 #endif
1361
1362 -- ---------------------------------------------------------------------------
1363 -- User code exception handling
1364
1365 -- This is the exception handler for exceptions generated by the
1366 -- user's code and exceptions coming from children sessions;
1367 -- it normally just prints out the exception.  The
1368 -- handler must be recursive, in case showing the exception causes
1369 -- more exceptions to be raised.
1370 --
1371 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1372 -- raising another exception.  We therefore don't put the recursive
1373 -- handler arond the flushing operation, so if stderr is closed
1374 -- GHCi will just die gracefully rather than going into an infinite loop.
1375 handler :: Exception -> GHCi Bool
1376
1377 handler exception = do
1378   flushInterpBuffers
1379   io installSignalHandlers
1380   ghciHandle handler (showException exception >> return False)
1381
1382 showException (DynException dyn) =
1383   case fromDynamic dyn of
1384     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1385     Just Interrupted      -> io (putStrLn "Interrupted.")
1386     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1387     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1388     Just other_ghc_ex     -> io (print other_ghc_ex)
1389
1390 showException other_exception
1391   = io (putStrLn ("*** Exception: " ++ show other_exception))
1392
1393 -----------------------------------------------------------------------------
1394 -- recursive exception handlers
1395
1396 -- Don't forget to unblock async exceptions in the handler, or if we're
1397 -- in an exception loop (eg. let a = error a in a) the ^C exception
1398 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1399
1400 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1401 ghciHandle h (GHCi m) = GHCi $ \s ->
1402    Exception.catch (m s)
1403         (\e -> unGHCi (ghciUnblock (h e)) s)
1404
1405 ghciUnblock :: GHCi a -> GHCi a
1406 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1407
1408
1409 -- ----------------------------------------------------------------------------
1410 -- Utils
1411
1412 expandPath :: String -> GHCi String
1413 expandPath path =
1414   case dropWhile isSpace path of
1415    ('~':d) -> do
1416         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1417         return (tilde ++ '/':d)
1418    other ->
1419         return other
1420
1421 -- ----------------------------------------------------------------------------
1422 -- Windows console setup
1423
1424 setUpConsole :: IO ()
1425 setUpConsole = do
1426 #ifdef mingw32_HOST_OS
1427         -- On Windows we need to set a known code page, otherwise the characters
1428         -- we read from the console will be be in some strange encoding, and
1429         -- similarly for characters we write to the console.
1430         --
1431         -- At the moment, GHCi pretends all input is Latin-1.  In the
1432         -- future we should support UTF-8, but for now we set the code pages
1433         -- to Latin-1.
1434         --
1435         -- It seems you have to set the font in the console window to
1436         -- a Unicode font in order for output to work properly,
1437         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1438         -- (see MSDN for SetConsoleOutputCP()).
1439         --
1440         setConsoleCP 28591       -- ISO Latin-1
1441         setConsoleOutputCP 28591 -- ISO Latin-1
1442 #endif
1443         return ()
1444
1445 -- commands for debugger
1446 foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
1447
1448 stepCmd :: String -> GHCi Bool
1449 stepCmd [] = doContinue setStepFlag
1450 stepCmd expression = do
1451    io $ setStepFlag
1452    runCommand expression
1453
1454 continueCmd :: String -> GHCi Bool
1455 continueCmd [] = doContinue $ return ()
1456 continueCmd other = do
1457    io $ putStrLn "The continue command accepts no arguments."
1458    return False
1459
1460 doContinue :: IO () -> GHCi Bool
1461 doContinue actionBeforeCont = do
1462    resumeAction <- popResume
1463    case resumeAction of
1464       Nothing -> do
1465          io $ putStrLn "There is no computation running."
1466          return False
1467       Just (_,_,handle) -> do
1468          io $ actionBeforeCont
1469          session <- getSession
1470          runResult <- io $ GHC.resume session handle
1471          names <- switchOnRunResult runResult
1472          finishEvalExpr names
1473          return False
1474
1475 deleteCmd :: String -> GHCi Bool
1476 deleteCmd argLine = do
1477    deleteSwitch $ words argLine
1478    return False
1479    where
1480    deleteSwitch :: [String] -> GHCi ()
1481    deleteSwitch [] =
1482       io $ putStrLn "The delete command requires at least one argument."
1483    -- delete all break points
1484    deleteSwitch ("*":_rest) = discardActiveBreakPoints
1485    deleteSwitch idents = do
1486       mapM_ deleteOneBreak idents
1487       where
1488       deleteOneBreak :: String -> GHCi ()
1489       deleteOneBreak str
1490          | all isDigit str = deleteBreak (read str)
1491          | otherwise = return ()
1492
1493 -- handle the "break" command
1494 breakCmd :: String -> GHCi Bool
1495 breakCmd argLine = do
1496    session <- getSession
1497    breakSwitch session $ words argLine
1498
1499 breakSwitch :: Session -> [String] -> GHCi Bool
1500 breakSwitch _session [] = do
1501    io $ putStrLn "The break command requires at least one argument."
1502    return False
1503 breakSwitch session args@(arg1:rest)
1504    | looksLikeModule arg1 = do
1505         mod <- wantInterpretedModule session arg1
1506         breakByModule mod rest
1507         return False
1508    | otherwise = do
1509         (toplevel, _) <- io $ GHC.getContext session
1510         case toplevel of
1511            (mod : _) -> breakByModule mod args
1512            [] -> do
1513               io $ putStrLn "Cannot find default module for breakpoint."
1514               io $ putStrLn "Perhaps no modules are loaded for debugging?"
1515         return False
1516    where
1517    -- Todo there may be a nicer way to test this
1518    looksLikeModule :: String -> Bool
1519    looksLikeModule []    = False
1520    looksLikeModule (x:_) = isUpper x
1521
1522 wantInterpretedModule :: Session -> String -> GHCi Module
1523 wantInterpretedModule session str = do
1524    modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1525    is_interpreted <- io (GHC.moduleIsInterpreted session modl)
1526    when (not is_interpreted) $
1527        throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
1528    return modl
1529
1530 breakByModule :: Module -> [String] -> GHCi ()
1531 breakByModule mod args@(arg1:rest)
1532    | all isDigit arg1 = do  -- looks like a line number
1533         breakByModuleLine mod (read arg1) rest
1534    | looksLikeVar arg1 = do
1535         -- break by a function definition
1536         io $ putStrLn "Break by function definition not implemented."
1537    | otherwise = io $ putStrLn "Invalid arguments to break command."
1538    where
1539    -- Todo there may be a nicer way to test this
1540    looksLikeVar :: String -> Bool
1541    looksLikeVar [] = False
1542    looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+"
1543
1544 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
1545 breakByModuleLine mod line args
1546    | [] <- args = findBreakAndSet mod $ findBreakByLine line
1547    | [col] <- args, all isDigit col =
1548         findBreakAndSet mod $ findBreakByCoord (line, read col)
1549    | otherwise = io $ putStrLn "Invalid arguments to break command."
1550
1551 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
1552 findBreakAndSet mod lookupTickTree = do
1553    tickArray <- getTickArray mod
1554    (breakArray, _) <- getModBreak mod
1555    case lookupTickTree tickArray of
1556       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
1557       Just (tick, span) -> do
1558          success <- io $ setBreakFlag True breakArray tick
1559          session <- getSession
1560          if success
1561             then do
1562                (alreadySet, nm) <-
1563                      recordBreak $ BreakLocation
1564                              { breakModule = mod
1565                              , breakLoc = span
1566                              , breakTick = tick
1567                              }
1568                printForUser $
1569                   text "Breakpoint " <> ppr nm <>
1570                   if alreadySet
1571                      then text " was already set at " <> ppr span
1572                      else text " activated at " <> ppr span
1573             else do
1574             printForUser $ text "Breakpoint could not be activated at"
1575                                  <+> ppr span
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   | not (inRange (bounds arr) line) = Nothing
1586   | otherwise =
1587     listToMaybe (sortBy leftmost complete)   `mplus`
1588     listToMaybe (sortBy leftmost incomplete) `mplus`
1589     listToMaybe (sortBy rightmost ticks)
1590   where
1591         ticks = arr ! line
1592
1593         starts_here = [ tick | tick@(nm,span) <- ticks,
1594                                srcSpanStartLine span == line ]
1595
1596         (complete,incomplete) = partition ends_here starts_here
1597             where ends_here (nm,span) = srcSpanEndLine span == line
1598
1599 findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
1600 findBreakByCoord (line, col) arr
1601   | not (inRange (bounds arr) line) = Nothing
1602   | otherwise =
1603     listToMaybe (sortBy rightmost contains)
1604   where
1605         ticks = arr ! line
1606
1607         -- the ticks that span this coordinate
1608         contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
1609
1610 leftmost  (_,a) (_,b) = a `compare` b
1611 rightmost (_,a) (_,b) = b `compare` a
1612
1613 spans :: SrcSpan -> (Int,Int) -> Bool
1614 spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
1615    where loc = mkSrcLoc (srcSpanFile span) l c
1616
1617
1618 -- --------------------------------------------------------------------------
1619 -- Tick arrays
1620
1621 getTickArray :: Module -> GHCi TickArray
1622 getTickArray modl = do
1623    st <- getGHCiState
1624    let arrmap = tickarrays st
1625    case lookupModuleEnv arrmap modl of
1626       Just arr -> return arr
1627       Nothing  -> do
1628         (breakArray, ticks) <- getModBreak modl
1629         let arr = mkTickArray (assocs ticks)
1630         setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
1631         return arr
1632
1633 discardTickArrays :: GHCi ()
1634 discardTickArrays = do
1635    st <- getGHCiState
1636    setGHCiState st{tickarrays = emptyModuleEnv}
1637
1638 mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
1639 mkTickArray ticks
1640   = accumArray (flip (:)) [] (1, max_line)
1641         [ (line, (nm,span)) | (nm,span) <- ticks,
1642                               line <- srcSpanLines span ]
1643     where
1644         max_line = maximum (map srcSpanEndLine (map snd ticks))
1645         srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
1646
1647 getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
1648 getModBreak mod = do
1649    session <- getSession
1650    Just mod_info <- io $ GHC.getModuleInfo session mod
1651    let modBreaks  = GHC.modInfoModBreaks mod_info
1652    let array      = GHC.modBreaks_flags modBreaks
1653    let ticks      = GHC.modBreaks_locs  modBreaks
1654    return (array, ticks)
1655
1656 lookupModule :: Session -> String -> GHCi Module
1657 lookupModule session modName
1658    = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
1659
1660 setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool
1661 setBreakFlag toggle array index
1662    | toggle    = setBreakOn array index
1663    | otherwise = setBreakOff array index
1664
1665
1666 {- these should probably go to the GHC API at some point -}
1667 enableBreakPoint  :: Session -> Module -> Int -> IO ()
1668 enableBreakPoint session mod index = return ()
1669
1670 disableBreakPoint :: Session -> Module -> Int -> IO ()
1671 disableBreakPoint session mod index = return ()
1672
1673 activeBreakPoints :: Session -> IO [(Module,Int)]
1674 activeBreakPoints session = return []
1675
1676 enableSingleStep  :: Session -> IO ()
1677 enableSingleStep session = return ()
1678
1679 disableSingleStep :: Session -> IO ()
1680 disableSingleStep session = return ()