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 import DynFlags
  23 import Packages
  24 import PackageConfig
  25 import UniqFM
  26 import PprTyThing
  27 import Outputable
  28
  29 -- for createtags
  30 import Name
  31 import OccName
  32 import SrcLoc
  33
  34 -- Other random utilities
  35 import Digraph
  36 import BasicTypes hiding (isTopLevel)
  37 import Panic      hiding (showException)
  38 import Config
  39 import StaticFlags
  40 import Linker
  41 import Util
  42
  43 -- The debugger
  44 import Breakpoints
  45 import Debugger hiding  ( addModule )
  46 import HscTypes
  47 import Id
  48 import Var       ( globaliseId )
  49 import IdInfo
  50 import NameEnv
  51 import RdrName
  52 import Module
  53 import Type
  54 import TcType
  55
  56 #ifndef mingw32_HOST_OS
  57 import System.Posix
  58 #if __GLASGOW_HASKELL__ > 504
  59         hiding (getEnv)
  60 #endif
  61 #else
  62 import GHC.ConsoleHandler ( flushConsole )
  63 import System.Win32       ( setConsoleCP, setConsoleOutputCP )
  64 import qualified System.Win32
  65 #endif
  66
  67 #ifdef USE_READLINE
  68 import Control.Concurrent       ( yield )       -- Used in readline loop
  69 import System.Console.Readline as Readline
  70 #endif
  71
  72 --import SystemExts
  73
  74 import Control.Exception as Exception
  75 -- import Control.Concurrent
  76
  77 import Numeric
  78 import Data.List
  79 import Data.Int         ( Int64 )
  80 import Data.Maybe       ( isJust, isNothing, fromMaybe, catMaybes )
  81 import System.Cmd
  82 import System.Environment
  83 import System.Exit      ( exitWith, ExitCode(..) )
  84 import System.Directory
  85 import System.IO
  86 import System.IO.Error as IO
  87 import Data.Char
  88 import Data.Dynamic
  89 import Control.Monad as Monad
  90 import Foreign.StablePtr        ( newStablePtr )
  91
  92 import GHC.Exts         ( unsafeCoerce# )
  93 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  94
  95 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  96
  97 import System.Posix.Internals ( setNonBlockingFD )
  98
  99 -----------------------------------------------------------------------------
 100
 101 ghciWelcomeMsg =
 102  "   ___         ___ _\n"++
 103  "  / _ \\ /\\  /\\/ __(_)\n"++
 104  " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
 105  "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
 106  "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
 107
 108 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
 109 cmdName (n,_,_,_) = n
 110
 111 GLOBAL_VAR(commands, builtin_commands, [Command])
 112
 113 builtin_commands :: [Command]
 114 builtin_commands = [
 115   ("add",       tlC$ keepGoingPaths addModule,  False, completeFilename),
 116   ("browse",    keepGoing browseCmd,            False, completeModule),
 117   ("cd",        keepGoing changeDirectory,      False, completeFilename),
 118   ("def",       keepGoing defineMacro,          False, completeIdentifier),
 119   ("e",         keepGoing editFile,             False, completeFilename),
 120         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 121   ("edit",      keepGoing editFile,             False, completeFilename),
 122   ("help",      keepGoing help,                 False, completeNone),
 123   ("?",         keepGoing help,                 False, completeNone),
 124   ("info",      keepGoing info,                 False, completeIdentifier),
 125   ("load",      tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
 126   ("module",    keepGoing setContext,           False, completeModule),
 127   ("main",      tlC$ keepGoing runMain,         False, completeIdentifier),
 128   ("reload",    tlC$ keepGoing reloadModule,    False, completeNone),
 129   ("check",     keepGoing checkModule,          False, completeHomeModule),
 130   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 131   ("show",      keepGoing showCmd,              False, completeNone),
 132   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 133   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 134   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 135 #if defined(DEBUGGER)
 136   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
 137   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
 138   ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
 139   ("breakpoint",keepGoing bkptOptions,          False, completeBkpt),
 140 #endif
 141   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 142   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions),
 143   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 144   ("quit",      quit,                           False, completeNone)
 145   ]
 146
 147 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 148 keepGoing a str = a str >> return False
 149
 150 -- tlC: Top Level Command
 151 tlC ::  (String -> GHCi Bool) -> (String -> GHCi Bool)
 152 tlC a str = do
 153     top_level <- isTopLevel
 154     if not top_level
 155        then throwDyn (CmdLineError "Command only allowed at Top Level")
 156        else a str
 157
 158 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 159 keepGoingPaths a str = a (toArgs str) >> return False
 160
 161 shortHelpText = "use :? for help.\n"
 162
 163 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 164 helpText =
 165  " Commands available from the prompt:\n" ++
 166  "\n" ++
 167  "   <stmt>                      evaluate/run <stmt>\n" ++
 168  "   :add <filename> ...         add module(s) to the current target set\n" ++
 169  "   :breakpoint <option>        commands for the GHCi debugger\n" ++
 170  "   :browse [*]<module>         display the names defined by <module>\n" ++
 171  "   :cd <dir>                   change directory to <dir>\n" ++
 172  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 173  "   :edit <file>                edit file\n" ++
 174  "   :edit                       edit last module\n" ++
 175  "   :help, :?                   display this list of commands\n" ++
 176  "   :info [<name> ...]          display information about the given names\n" ++
 177  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 178  "   :sprint [<name> ...]        simplified version of :print\n" ++
 179  "   :load <filename> ...        load module(s) and their dependents\n" ++
 180  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 181  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 182  "   :reload                     reload the current module set\n" ++
 183  "\n" ++
 184  "   :set <option> ...           set options\n" ++
 185  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 186  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 187  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 188  "   :set editor <cmd>           set the command used for :edit\n" ++
 189  "\n" ++
 190  "   :show modules               show the currently loaded modules\n" ++
 191  "   :show bindings              show the current bindings made at the prompt\n" ++
 192  "\n" ++
 193  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 194  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 195  "   :type <expr>                show the type of <expr>\n" ++
 196  "   :kind <type>                show the kind of <type>\n" ++
 197  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 198  "   :unset <option> ...         unset options\n" ++
 199  "   :quit                       exit GHCi\n" ++
 200  "   :!<command>                 run the shell command <command>\n" ++
 201  "\n" ++
 202  " Options for ':set' and ':unset':\n" ++
 203  "\n" ++
 204  "    +r            revert top-level expressions after each evaluation\n" ++
 205  "    +s            print timing/memory stats after each evaluation\n" ++
 206  "    +t            print type after evaluation\n" ++
 207  "    -<flags>      most GHC command line flags can also be set here\n" ++
 208  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 209  "\n" ++
 210  " Options for ':breakpoint':\n" ++
 211  "   list                                     list the current breakpoints\n" ++
 212  "   add Module line [col]                    add a new breakpoint\n" ++
 213  "   del (breakpoint# | Module line [col])    delete a breakpoint\n" ++
 214  "   stop                   Stop a computation and return to the top level\n" ++
 215  "   step [count]           Step by step execution (DISABLED)\n"
 216
 217 findEditor = do
 218   getEnv "EDITOR"
 219     `IO.catch` \_ -> do
 220 #if mingw32_HOST_OS
 221         win <- System.Win32.getWindowsDirectory
 222         return (win `joinFileName` "notepad.exe")
 223 #else
 224         return ""
 225 #endif
 226
 227 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 228 interactiveUI session srcs maybe_expr = do
 229    -- HACK! If we happen to get into an infinite loop (eg the user
 230    -- types 'let x=x in x' at the prompt), then the thread will block
 231    -- on a blackhole, and become unreachable during GC.  The GC will
 232    -- detect that it is unreachable and send it the NonTermination
 233    -- exception.  However, since the thread is unreachable, everything
 234    -- it refers to might be finalized, including the standard Handles.
 235    -- This sounds like a bug, but we don't have a good solution right
 236    -- now.
 237    newStablePtr stdin
 238    newStablePtr stdout
 239    newStablePtr stderr
 240
 241         -- Initialise buffering for the *interpreted* I/O system
 242    initInterpBuffering session
 243
 244    when (isNothing maybe_expr) $ do
 245         -- Only for GHCi (not runghc and ghc -e):
 246         -- Turn buffering off for the compiled program's stdout/stderr
 247         turnOffBuffering
 248         -- Turn buffering off for GHCi's stdout
 249         hFlush stdout
 250         hSetBuffering stdout NoBuffering
 251         -- We don't want the cmd line to buffer any input that might be
 252         -- intended for the program, so unbuffer stdin.
 253         hSetBuffering stdin NoBuffering
 254
 255         -- initial context is just the Prelude
 256    prel_mod <- GHC.findModule session prel_name Nothing
 257    GHC.setContext session [] [prel_mod]
 258
 259 #ifdef USE_READLINE
 260    Readline.initialize
 261    Readline.setAttemptedCompletionFunction (Just completeWord)
 262    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 263
 264    let symbols = "!#$%&*+/<=>?@\\^|-~"
 265        specials = "(),;[]`{}"
 266        spaces = " \t\n"
 267        word_break_chars = spaces ++ specials ++ symbols
 268
 269    Readline.setBasicWordBreakCharacters word_break_chars
 270    Readline.setCompleterWordBreakCharacters word_break_chars
 271 #endif
 272
 273    bkptTable <- newIORef emptyBkptTable
 274    GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable)
 275    default_editor <- findEditor
 276
 277    startGHCi (runGHCi srcs maybe_expr)
 278         GHCiState{ progname = "<interactive>",
 279                    args = [],
 280                    prompt = "%s> ",
 281                    editor = default_editor,
 282                    session = session,
 283                    options = [],
 284                    prelude = prel_mod,
 285                    bkptTable = bkptTable,
 286                    topLevel  = True
 287                  }
 288
 289 #ifdef USE_READLINE
 290    Readline.resetTerminal Nothing
 291 #endif
 292
 293    return ()
 294
 295 prel_name = GHC.mkModuleName "Prelude"
 296
 297 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 298 runGHCi paths maybe_expr = do
 299   let read_dot_files = not opt_IgnoreDotGhci
 300
 301   when (read_dot_files) $ do
 302     -- Read in ./.ghci.
 303     let file = "./.ghci"
 304     exists <- io (doesFileExist file)
 305     when exists $ do
 306        dir_ok  <- io (checkPerms ".")
 307        file_ok <- io (checkPerms file)
 308        when (dir_ok && file_ok) $ do
 309           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 310           case either_hdl of
 311              Left e    -> return ()
 312              Right hdl -> fileLoop hdl False
 313
 314   when (read_dot_files) $ do
 315     -- Read in $HOME/.ghci
 316     either_dir <- io (IO.try (getEnv "HOME"))
 317     case either_dir of
 318        Left e -> return ()
 319        Right dir -> do
 320           cwd <- io (getCurrentDirectory)
 321           when (dir /= cwd) $ do
 322              let file = dir ++ "/.ghci"
 323              ok <- io (checkPerms file)
 324              when ok $ do
 325                either_hdl <- io (IO.try (openFile file ReadMode))
 326                case either_hdl of
 327                   Left e    -> return ()
 328                   Right hdl -> fileLoop hdl False
 329
 330   -- Perform a :load for files given on the GHCi command line
 331   -- When in -e mode, if the load fails then we want to stop
 332   -- immediately rather than going on to evaluate the expression.
 333   when (not (null paths)) $ do
 334      ok <- ghciHandle (\e -> do showException e; return Failed) $
 335                 loadModule paths
 336      when (isJust maybe_expr && failed ok) $
 337         io (exitWith (ExitFailure 1))
 338
 339   -- if verbosity is greater than 0, or we are connected to a
 340   -- terminal, display the prompt in the interactive loop.
 341   is_tty <- io (hIsTerminalDevice stdin)
 342   dflags <- getDynFlags
 343   let show_prompt = verbosity dflags > 0 || is_tty
 344
 345   case maybe_expr of
 346         Nothing ->
 347           do
 348 #if defined(mingw32_HOST_OS)
 349             -- The win32 Console API mutates the first character of
 350             -- type-ahead when reading from it in a non-buffered manner. Work
 351             -- around this by flushing the input buffer of type-ahead characters,
 352             -- but only if stdin is available.
 353             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 354             case flushed of
 355              Left err | isDoesNotExistError err -> return ()
 356                       | otherwise -> io (ioError err)
 357              Right () -> return ()
 358 #endif
 359             -- initialise the console if necessary
 360             io setUpConsole
 361
 362             -- enter the interactive loop
 363             interactiveLoop is_tty show_prompt
 364         Just expr -> do
 365             -- just evaluate the expression we were given
 366             runCommandEval expr
 367             return ()
 368
 369   -- and finally, exit
 370   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 371
 372
 373 interactiveLoop is_tty show_prompt =
 374   -- Ignore ^C exceptions caught here
 375   ghciHandleDyn (\e -> case e of
 376                         Interrupted -> do
 377 #if defined(mingw32_HOST_OS)
 378                                 io (putStrLn "")
 379 #endif
 380                                 interactiveLoop is_tty show_prompt
 381                         _other      -> return ()) $
 382
 383   ghciUnblock $ do -- unblock necessary if we recursed from the
 384                    -- exception handler above.
 385
 386   -- read commands from stdin
 387 #ifdef USE_READLINE
 388   if (is_tty)
 389         then readlineLoop
 390         else fileLoop stdin show_prompt
 391 #else
 392   fileLoop stdin show_prompt
 393 #endif
 394
 395
 396 -- NOTE: We only read .ghci files if they are owned by the current user,
 397 -- and aren't world writable.  Otherwise, we could be accidentally
 398 -- running code planted by a malicious third party.
 399
 400 -- Furthermore, We only read ./.ghci if . is owned by the current user
 401 -- and isn't writable by anyone else.  I think this is sufficient: we
 402 -- don't need to check .. and ../.. etc. because "."  always refers to
 403 -- the same directory while a process is running.
 404
 405 checkPerms :: String -> IO Bool
 406 checkPerms name =
 407 #ifdef mingw32_HOST_OS
 408   return True
 409 #else
 410   Util.handle (\_ -> return False) $ do
 411      st <- getFileStatus name
 412      me <- getRealUserID
 413      if fileOwner st /= me then do
 414         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 415         return False
 416       else do
 417         let mode =  fileMode st
 418         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 419            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 420            then do
 421                putStrLn $ "*** WARNING: " ++ name ++
 422                           " is writable by someone else, IGNORING!"
 423                return False
 424           else return True
 425 #endif
 426
 427 fileLoop :: Handle -> Bool -> GHCi ()
 428 fileLoop hdl show_prompt = do
 429    session <- getSession
 430    (mod,imports) <- io (GHC.getContext session)
 431    st <- getGHCiState
 432    when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
 433    l <- io (IO.try (hGetLine hdl))
 434    case l of
 435         Left e | isEOFError e              -> return ()
 436                | InvalidArgument <- etype  -> return ()
 437                | otherwise                 -> io (ioError e)
 438                 where etype = ioeGetErrorType e
 439                 -- treat InvalidArgument in the same way as EOF:
 440                 -- this can happen if the user closed stdin, or
 441                 -- perhaps did getContents which closes stdin at
 442                 -- EOF.
 443         Right l ->
 444           case removeSpaces l of
 445             "" -> fileLoop hdl show_prompt
 446             l  -> do quit <- runCommand l
 447                      if quit then return () else fileLoop hdl show_prompt
 448
 449 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
 450 stringLoop [] = return False
 451 stringLoop (s:ss) = do
 452    case removeSpaces s of
 453         "" -> stringLoop ss
 454         l  -> do quit <- runCommand l
 455                  if quit then return True else stringLoop ss
 456
 457 mkPrompt toplevs exports prompt
 458   = showSDoc $ f prompt
 459     where
 460         f ('%':'s':xs) = perc_s <> f xs
 461         f ('%':'%':xs) = char '%' <> f xs
 462         f (x:xs) = char x <> f xs
 463         f [] = empty
 464
 465         perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
 466                  hsep (map (ppr . GHC.moduleName) exports)
 467
 468
 469 #ifdef USE_READLINE
 470 readlineLoop :: GHCi ()
 471 readlineLoop = do
 472    session <- getSession
 473    (mod,imports) <- io (GHC.getContext session)
 474    io yield
 475    saveSession -- for use by completion
 476    st <- getGHCiState
 477    l <- io (readline (mkPrompt mod imports (prompt st))
 478                 `finally` setNonBlockingFD 0)
 479                 -- readline sometimes puts stdin into blocking mode,
 480                 -- so we need to put it back for the IO library
 481    splatSavedSession
 482    case l of
 483         Nothing -> return ()
 484         Just l  ->
 485           case removeSpaces l of
 486             "" -> readlineLoop
 487             l  -> do
 488                   io (addHistory l)
 489                   quit <- runCommand l
 490                   if quit then return () else readlineLoop
 491 #endif
 492
 493 runCommand :: String -> GHCi Bool
 494 runCommand c = ghciHandle handler (doCommand c)
 495   where
 496     doCommand (':' : command) = specialCommand command
 497     doCommand stmt
 498        = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 499             return False
 500
 501 -- This version is for the GHC command-line option -e.  The only difference
 502 -- from runCommand is that it catches the ExitException exception and
 503 -- exits, rather than printing out the exception.
 504 runCommandEval c = ghciHandle handleEval (doCommand c)
 505   where
 506     handleEval (ExitException code) = io (exitWith code)
 507     handleEval e                    = do handler e
 508                                          io (exitWith (ExitFailure 1))
 509
 510     doCommand (':' : command) = specialCommand command
 511     doCommand stmt
 512        = do nms <- runStmt stmt
 513             case nms of
 514                 Nothing -> io (exitWith (ExitFailure 1))
 515                   -- failure to run the command causes exit(1) for ghc -e.
 516                 _       -> finishEvalExpr nms
 517
 518 runStmt :: String -> GHCi (Maybe [Name])
 519 runStmt stmt
 520  | null (filter (not.isSpace) stmt) = return (Just [])
 521  | otherwise
 522  = do st <- getGHCiState
 523       session <- getSession
 524       result <- io $ withProgName (progname st) $ withArgs (args st) $
 525                      GHC.runStmt session stmt
 526       case result of
 527         GHC.RunFailed      -> return Nothing
 528         GHC.RunException e -> throw e  -- this is caught by runCommand(Eval)
 529         GHC.RunOk names    -> return (Just names)
 530
 531 -- possibly print the type and revert CAFs after evaluating an expression
 532 finishEvalExpr mb_names
 533  = do b <- isOptionSet ShowType
 534       session <- getSession
 535       case mb_names of
 536         Nothing    -> return ()
 537         Just names -> when b (mapM_ (showTypeOfName session) names)
 538
 539       flushInterpBuffers
 540       io installSignalHandlers
 541       b <- isOptionSet RevertCAFs
 542       io (when b revertCAFs)
 543       return True
 544
 545 showTypeOfName :: Session -> Name -> GHCi ()
 546 showTypeOfName session n
 547    = do maybe_tything <- io (GHC.lookupName session n)
 548         case maybe_tything of
 549           Nothing    -> return ()
 550           Just thing -> showTyThing thing
 551
 552 specialCommand :: String -> GHCi Bool
 553 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 554 specialCommand str = do
 555   let (cmd,rest) = break isSpace str
 556   maybe_cmd <- io (lookupCommand cmd)
 557   case maybe_cmd of
 558     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 559                                     ++ shortHelpText) >> return False)
 560     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 561
 562 lookupCommand :: String -> IO (Maybe Command)
 563 lookupCommand str = do
 564   cmds <- readIORef commands
 565   -- look for exact match first, then the first prefix match
 566   case [ c | c <- cmds, str == cmdName c ] of
 567      c:_ -> return (Just c)
 568      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 569                 [] -> return Nothing
 570                 c:_ -> return (Just c)
 571
 572 -----------------------------------------------------------------------------
 573 -- Commands
 574
 575 help :: String -> GHCi ()
 576 help _ = io (putStr helpText)
 577
 578 info :: String -> GHCi ()
 579 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 580 info s  = do { let names = words s
 581              ; session <- getSession
 582              ; dflags <- getDynFlags
 583              ; let exts = dopt Opt_GlasgowExts dflags
 584              ; mapM_ (infoThing exts session) names }
 585   where
 586     infoThing exts session str = io $ do
 587         names <- GHC.parseName session str
 588         let filtered = filterOutChildren names
 589         mb_stuffs <- mapM (GHC.getInfo session) filtered
 590         unqual <- GHC.getPrintUnqual session
 591         putStrLn (showSDocForUser unqual $
 592                    vcat (intersperse (text "") $
 593                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 594
 595   -- Filter out names whose parent is also there Good
 596   -- example is '[]', which is both a type and data
 597   -- constructor in the same type
 598 filterOutChildren :: [Name] -> [Name]
 599 filterOutChildren names = filter (not . parent_is_there) names
 600  where parent_is_there n
 601 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 602 -- ToDo!!
 603          | otherwise                       = False
 604
 605 pprInfo exts (thing, fixity, insts)
 606   =  pprTyThingInContextLoc exts thing
 607   $$ show_fixity fixity
 608   $$ vcat (map GHC.pprInstance insts)
 609   where
 610     show_fixity fix
 611         | fix == GHC.defaultFixity = empty
 612         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 613
 614 -----------------------------------------------------------------------------
 615 -- Commands
 616
 617 runMain :: String -> GHCi ()
 618 runMain args = do
 619   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 620   runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
 621   return ()
 622
 623 addModule :: [FilePath] -> GHCi ()
 624 addModule files = do
 625   io (revertCAFs)                       -- always revert CAFs on load/add.
 626   files <- mapM expandPath files
 627   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 628   session <- getSession
 629   io (mapM_ (GHC.addTarget session) targets)
 630   ok <- io (GHC.load session LoadAllTargets)
 631   afterLoad ok session
 632
 633 changeDirectory :: String -> GHCi ()
 634 changeDirectory dir = do
 635   session <- getSession
 636   graph <- io (GHC.getModuleGraph session)
 637   when (not (null graph)) $
 638         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 639   io (GHC.setTargets session [])
 640   io (GHC.load session LoadAllTargets)
 641   setContextAfterLoad session []
 642   io (GHC.workingDirectoryChanged session)
 643   dir <- expandPath dir
 644   io (setCurrentDirectory dir)
 645
 646 editFile :: String -> GHCi ()
 647 editFile str
 648   | null str  = do
 649         -- find the name of the "topmost" file loaded
 650      session <- getSession
 651      graph0 <- io (GHC.getModuleGraph session)
 652      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 653      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 654      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 655         Just file -> do_edit file
 656         Nothing   -> throwDyn (CmdLineError "unknown file name")
 657   | otherwise = do_edit str
 658   where
 659         do_edit file = do
 660            st <- getGHCiState
 661            let cmd = editor st
 662            when (null cmd) $
 663                 throwDyn (CmdLineError "editor not set, use :set editor")
 664            io $ system (cmd ++ ' ':file)
 665            return ()
 666
 667 defineMacro :: String -> GHCi ()
 668 defineMacro s = do
 669   let (macro_name, definition) = break isSpace s
 670   cmds <- io (readIORef commands)
 671   if (null macro_name)
 672         then throwDyn (CmdLineError "invalid macro name")
 673         else do
 674   if (macro_name `elem` map cmdName cmds)
 675         then throwDyn (CmdLineError
 676                 ("command '" ++ macro_name ++ "' is already defined"))
 677         else do
 678
 679   -- give the expression a type signature, so we can be sure we're getting
 680   -- something of the right type.
 681   let new_expr = '(' : definition ++ ") :: String -> IO String"
 682
 683   -- compile the expression
 684   cms <- getSession
 685   maybe_hv <- io (GHC.compileExpr cms new_expr)
 686   case maybe_hv of
 687      Nothing -> return ()
 688      Just hv -> io (writeIORef commands --
 689                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 690
 691 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 692 runMacro fun s = do
 693   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 694   stringLoop (lines str)
 695
 696 undefineMacro :: String -> GHCi ()
 697 undefineMacro macro_name = do
 698   cmds <- io (readIORef commands)
 699   if (macro_name `elem` map cmdName builtin_commands)
 700         then throwDyn (CmdLineError
 701                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 702         else do
 703   if (macro_name `notElem` map cmdName cmds)
 704         then throwDyn (CmdLineError
 705                 ("command '" ++ macro_name ++ "' not defined"))
 706         else do
 707   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 708
 709
 710 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 711 loadModule fs = timeIt (loadModule' fs)
 712
 713 loadModule_ :: [FilePath] -> GHCi ()
 714 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 715
 716 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 717 loadModule' files = do
 718   session <- getSession
 719
 720   -- unload first
 721   io (GHC.setTargets session [])
 722   io (GHC.load session LoadAllTargets)
 723
 724   -- expand tildes
 725   let (filenames, phases) = unzip files
 726   exp_filenames <- mapM expandPath filenames
 727   let files' = zip exp_filenames phases
 728   targets <- io (mapM (uncurry GHC.guessTarget) files')
 729
 730   -- NOTE: we used to do the dependency anal first, so that if it
 731   -- fails we didn't throw away the current set of modules.  This would
 732   -- require some re-working of the GHC interface, so we'll leave it
 733   -- as a ToDo for now.
 734
 735   io (GHC.setTargets session targets)
 736   ok <- io (GHC.load session LoadAllTargets)
 737   afterLoad ok session
 738   return ok
 739
 740 checkModule :: String -> GHCi ()
 741 checkModule m = do
 742   let modl = GHC.mkModuleName m
 743   session <- getSession
 744   result <- io (GHC.checkModule session modl)
 745   case result of
 746     Nothing -> io $ putStrLn "Nothing"
 747     Just r  -> io $ putStrLn (showSDoc (
 748         case GHC.checkedModuleInfo r of
 749            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 750                 let
 751                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 752                 in
 753                         (text "global names: " <+> ppr global) $$
 754                         (text "local  names: " <+> ppr local)
 755            _ -> empty))
 756   afterLoad (successIf (isJust result)) session
 757
 758 reloadModule :: String -> GHCi ()
 759 reloadModule "" = do
 760   io (revertCAFs)               -- always revert CAFs on reload.
 761   session <- getSession
 762   ok <- io (GHC.load session LoadAllTargets)
 763   afterLoad ok session
 764 reloadModule m = do
 765   io (revertCAFs)               -- always revert CAFs on reload.
 766   session <- getSession
 767   ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
 768   afterLoad ok session
 769
 770 afterLoad ok session = do
 771   io (revertCAFs)  -- always revert CAFs on load.
 772   graph <- io (GHC.getModuleGraph session)
 773   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 774   setContextAfterLoad session graph'
 775   refreshBkptTable 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 <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
 976   is_interpreted <- io (GHC.moduleIsInterpreted s modl)
 977   when (not is_interpreted && not exports_only) $
 978         throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 979
 980   -- Temporarily set the context to the module we're interested in,
 981   -- just so we can get an appropriate PrintUnqualified
 982   (as,bs) <- io (GHC.getContext s)
 983   prel_mod <- getPrelude
 984   io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 985                       else GHC.setContext s [modl] [])
 986   unqual <- io (GHC.getPrintUnqual s)
 987   io (GHC.setContext s as bs)
 988
 989   mb_mod_info <- io $ GHC.getModuleInfo s modl
 990   case mb_mod_info of
 991     Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
 992     Just mod_info -> do
 993         let names
 994                | exports_only = GHC.modInfoExports mod_info
 995                | otherwise    = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
 996
 997             filtered = filterOutChildren names
 998
 999         things <- io $ mapM (GHC.lookupName s) filtered
1000
1001         dflags <- getDynFlags
1002         let exts = dopt Opt_GlasgowExts dflags
1003         io (putStrLn (showSDocForUser unqual (
1004                 vcat (map (pprTyThingInContext exts) (catMaybes things))
1005            )))
1006         -- ToDo: modInfoInstances currently throws an exception for
1007         -- package modules.  When it works, we can do this:
1008         --      $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1009
1010 -----------------------------------------------------------------------------
1011 -- Setting the module context
1012
1013 setContext str
1014   | all sensible mods = fn mods
1015   | otherwise = throwDyn (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
1016   where
1017     (fn, mods) = case str of
1018                         '+':stuff -> (addToContext,      words stuff)
1019                         '-':stuff -> (removeFromContext, words stuff)
1020                         stuff     -> (newContext,        words stuff)
1021
1022     sensible ('*':m) = looksLikeModuleName m
1023     sensible m       = looksLikeModuleName m
1024
1025 separate :: Session -> [String] -> [Module] -> [Module]
1026         -> GHCi ([Module],[Module])
1027 separate session []           as bs = return (as,bs)
1028 separate session (('*':str):ms) as bs = do
1029    m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1030    b <- io $ GHC.moduleIsInterpreted session m
1031    if b then separate session ms (m:as) bs
1032         else throwDyn (CmdLineError ("module '"
1033                         ++ GHC.moduleNameString (GHC.moduleName m)
1034                         ++ "' is not interpreted"))
1035 separate session (str:ms) as bs = do
1036   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1037   separate session ms as (m:bs)
1038
1039 newContext :: [String] -> GHCi ()
1040 newContext strs = do
1041   s <- getSession
1042   (as,bs) <- separate s strs [] []
1043   prel_mod <- getPrelude
1044   let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1045   io $ GHC.setContext s as bs'
1046
1047
1048 addToContext :: [String] -> GHCi ()
1049 addToContext strs = do
1050   s <- getSession
1051   (as,bs) <- io $ GHC.getContext s
1052
1053   (new_as,new_bs) <- separate s strs [] []
1054
1055   let as_to_add = new_as \\ (as ++ bs)
1056       bs_to_add = new_bs \\ (as ++ bs)
1057
1058   io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1059
1060
1061 removeFromContext :: [String] -> GHCi ()
1062 removeFromContext strs = do
1063   s <- getSession
1064   (as,bs) <- io $ GHC.getContext s
1065
1066   (as_to_remove,bs_to_remove) <- separate s strs [] []
1067
1068   let as' = as \\ (as_to_remove ++ bs_to_remove)
1069       bs' = bs \\ (as_to_remove ++ bs_to_remove)
1070
1071   io $ GHC.setContext s as' bs'
1072
1073 ----------------------------------------------------------------------------
1074 -- Code for `:set'
1075
1076 -- set options in the interpreter.  Syntax is exactly the same as the
1077 -- ghc command line, except that certain options aren't available (-C,
1078 -- -E etc.)
1079 --
1080 -- This is pretty fragile: most options won't work as expected.  ToDo:
1081 -- figure out which ones & disallow them.
1082
1083 setCmd :: String -> GHCi ()
1084 setCmd ""
1085   = do st <- getGHCiState
1086        let opts = options st
1087        io $ putStrLn (showSDoc (
1088               text "options currently set: " <>
1089               if null opts
1090                    then text "none."
1091                    else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1092            ))
1093 setCmd str
1094   = case toArgs str of
1095         ("args":args) -> setArgs args
1096         ("prog":prog) -> setProg prog
1097         ("prompt":prompt) -> setPrompt (after 6)
1098         ("editor":cmd) -> setEditor (after 6)
1099         wds -> setOptions wds
1100    where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1101
1102 setArgs args = do
1103   st <- getGHCiState
1104   setGHCiState st{ args = args }
1105
1106 setProg [prog] = do
1107   st <- getGHCiState
1108   setGHCiState st{ progname = prog }
1109 setProg _ = do
1110   io (hPutStrLn stderr "syntax: :set prog <progname>")
1111
1112 setEditor cmd = do
1113   st <- getGHCiState
1114   setGHCiState st{ editor = cmd }
1115
1116 setPrompt value = do
1117   st <- getGHCiState
1118   if null value
1119       then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1120       else setGHCiState st{ prompt = remQuotes value }
1121   where
1122      remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1123      remQuotes x = x
1124
1125 setOptions wds =
1126    do -- first, deal with the GHCi opts (+s, +t, etc.)
1127       let (plus_opts, minus_opts)  = partition isPlus wds
1128       mapM_ setOpt plus_opts
1129
1130       -- then, dynamic flags
1131       dflags <- getDynFlags
1132       let pkg_flags = packageFlags dflags
1133       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1134
1135       if (not (null leftovers))
1136                 then throwDyn (CmdLineError ("unrecognised flags: " ++
1137                                                 unwords leftovers))
1138                 else return ()
1139
1140       new_pkgs <- setDynFlags dflags'
1141
1142       -- if the package flags changed, we should reset the context
1143       -- and link the new packages.
1144       dflags <- getDynFlags
1145       when (packageFlags dflags /= pkg_flags) $ do
1146         io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1147         session <- getSession
1148         io (GHC.setTargets session [])
1149         io (GHC.load session LoadAllTargets)
1150         io (linkPackages dflags new_pkgs)
1151         setContextAfterLoad session []
1152       return ()
1153
1154
1155 unsetOptions :: String -> GHCi ()
1156 unsetOptions str
1157   = do -- first, deal with the GHCi opts (+s, +t, etc.)
1158        let opts = words str
1159            (minus_opts, rest1) = partition isMinus opts
1160            (plus_opts, rest2)  = partition isPlus rest1
1161
1162        if (not (null rest2))
1163           then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1164           else do
1165
1166        mapM_ unsetOpt plus_opts
1167
1168        -- can't do GHC flags for now
1169        if (not (null minus_opts))
1170           then throwDyn (CmdLineError "can't unset GHC command-line flags")
1171           else return ()
1172
1173 isMinus ('-':s) = True
1174 isMinus _ = False
1175
1176 isPlus ('+':s) = True
1177 isPlus _ = False
1178
1179 setOpt ('+':str)
1180   = case strToGHCiOpt str of
1181         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1182         Just o  -> setOption o
1183
1184 unsetOpt ('+':str)
1185   = case strToGHCiOpt str of
1186         Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1187         Just o  -> unsetOption o
1188
1189 strToGHCiOpt :: String -> (Maybe GHCiOption)
1190 strToGHCiOpt "s" = Just ShowTiming
1191 strToGHCiOpt "t" = Just ShowType
1192 strToGHCiOpt "r" = Just RevertCAFs
1193 strToGHCiOpt _   = Nothing
1194
1195 optToStr :: GHCiOption -> String
1196 optToStr ShowTiming = "s"
1197 optToStr ShowType   = "t"
1198 optToStr RevertCAFs = "r"
1199
1200 -- ---------------------------------------------------------------------------
1201 -- code for `:show'
1202
1203 showCmd str =
1204   case words str of
1205         ["modules" ] -> showModules
1206         ["bindings"] -> showBindings
1207         ["linker"]   -> io showLinkerState
1208         ["breakpoints"] -> showBkptTable
1209         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1210
1211 showModules = do
1212   session <- getSession
1213   let show_one ms = do m <- io (GHC.showModule session ms)
1214                        io (putStrLn m)
1215   graph <- io (GHC.getModuleGraph session)
1216   mapM_ show_one graph
1217
1218 showBindings = do
1219   s <- getSession
1220   unqual <- io (GHC.getPrintUnqual s)
1221   bindings <- io (GHC.getBindings s)
1222   mapM_ showTyThing bindings
1223   return ()
1224
1225 showTyThing (AnId id) = do
1226   ty' <- cleanType (GHC.idType id)
1227   str <- showForUser (ppr id <> text " :: " <> ppr ty')
1228   io (putStrLn str)
1229 showTyThing _  = return ()
1230
1231 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1232 cleanType :: Type -> GHCi Type
1233 cleanType ty = do
1234   dflags <- getDynFlags
1235   if dopt Opt_GlasgowExts dflags
1236         then return ty
1237         else return $! GHC.dropForAlls ty
1238
1239 showBkptTable :: GHCi ()
1240 showBkptTable = do
1241   bt     <- getBkptTable
1242   msg <- showForUser . vcat $
1243              [ ppr mod <> colon <+> fcat
1244                        [ parens(int row <> comma <> int col) | (row,col) <- sites]
1245                | (mod, sites) <-  sitesList bt ]
1246   io (putStrLn msg)
1247 -- -----------------------------------------------------------------------------
1248 -- Completion
1249
1250 completeNone :: String -> IO [String]
1251 completeNone w = return []
1252
1253 #ifdef USE_READLINE
1254 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1255 completeWord w start end = do
1256   line <- Readline.getLineBuffer
1257   case w of
1258      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1259      _other
1260         | Just c <- is_cmd line -> do
1261            maybe_cmd <- lookupCommand c
1262            let (n,w') = selectWord (words' 0 line)
1263            case maybe_cmd of
1264              Nothing -> return Nothing
1265              Just (_,_,False,complete) -> wrapCompleter complete w
1266              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1267                                                               return (map (drop n) rets)
1268                                          in wrapCompleter complete' w'
1269         | otherwise     -> do
1270                 --printf "complete %s, start = %d, end = %d\n" w start end
1271                 wrapCompleter completeIdentifier w
1272     where words' _ [] = []
1273           words' n str = let (w,r) = break isSpace str
1274                              (s,r') = span isSpace r
1275                          in (n,w):words' (n+length w+length s) r'
1276           -- In a Haskell expression we want to parse 'a-b' as three words
1277           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1278           -- only be a single word.
1279           selectWord [] = (0,w)
1280           selectWord ((offset,x):xs)
1281               | offset+length x >= start = (start-offset,take (end-offset) x)
1282               | otherwise = selectWord xs
1283
1284 is_cmd line
1285  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1286  | otherwise = Nothing
1287
1288 completeCmd w = do
1289   cmds <- readIORef commands
1290   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1291
1292 completeMacro w = do
1293   cmds <- readIORef commands
1294   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1295   return (filter (w `isPrefixOf`) cmds')
1296
1297 completeIdentifier w = do
1298   s <- restoreSession
1299   rdrs <- GHC.getRdrNamesInScope s
1300   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1301
1302 completeModule w = do
1303   s <- restoreSession
1304   dflags <- GHC.getSessionDynFlags s
1305   let pkg_mods = allExposedModules dflags
1306   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1307
1308 completeHomeModule w = do
1309   s <- restoreSession
1310   g <- GHC.getModuleGraph s
1311   let home_mods = map GHC.ms_mod_name g
1312   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1313
1314 completeSetOptions w = do
1315   return (filter (w `isPrefixOf`) options)
1316     where options = "args":"prog":allFlags
1317
1318 completeBkpt = unionComplete completeModule completeBkptCmds
1319
1320 completeBkptCmds w = do
1321   return (filter (w `isPrefixOf`) options)
1322     where options = ["add","del","list","stop"]
1323
1324 completeFilename = Readline.filenameCompletionFunction
1325
1326 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1327
1328 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1329 unionComplete f1 f2 w = do
1330   s1 <- f1 w
1331   s2 <- f2 w
1332   return (s1 ++ s2)
1333
1334 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1335 wrapCompleter fun w =  do
1336   strs <- fun w
1337   case strs of
1338     []  -> return Nothing
1339     [x] -> return (Just (x,[]))
1340     xs  -> case getCommonPrefix xs of
1341                 ""   -> return (Just ("",xs))
1342                 pref -> return (Just (pref,xs))
1343
1344 getCommonPrefix :: [String] -> String
1345 getCommonPrefix [] = ""
1346 getCommonPrefix (s:ss) = foldl common s ss
1347   where common s "" = s
1348         common "" s = ""
1349         common (c:cs) (d:ds)
1350            | c == d = c : common cs ds
1351            | otherwise = ""
1352
1353 allExposedModules :: DynFlags -> [ModuleName]
1354 allExposedModules dflags
1355  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1356  where
1357   pkg_db = pkgIdMap (pkgState dflags)
1358 #else
1359 completeCmd        = completeNone
1360 completeMacro      = completeNone
1361 completeIdentifier = completeNone
1362 completeModule     = completeNone
1363 completeHomeModule = completeNone
1364 completeSetOptions = completeNone
1365 completeFilename   = completeNone
1366 completeHomeModuleOrFile=completeNone
1367 completeBkpt       = completeNone
1368 #endif
1369
1370 -- ---------------------------------------------------------------------------
1371 -- User code exception handling
1372
1373 -- This is the exception handler for exceptions generated by the
1374 -- user's code and exceptions coming from children sessions;
1375 -- it normally just prints out the exception.  The
1376 -- handler must be recursive, in case showing the exception causes
1377 -- more exceptions to be raised.
1378 --
1379 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
1380 -- raising another exception.  We therefore don't put the recursive
1381 -- handler arond the flushing operation, so if stderr is closed
1382 -- GHCi will just die gracefully rather than going into an infinite loop.
1383 handler :: Exception -> GHCi Bool
1384 handler (DynException dyn)
1385   | Just StopChildSession <- fromDynamic dyn
1386      -- propagate to the parent session
1387   = do ASSERTM (liftM not isTopLevel)
1388        throwDyn StopChildSession
1389
1390   | Just (ChildSessionStopped msg) <- fromDynamic dyn
1391      -- Reload modules and display some message
1392   = do ASSERTM (isTopLevel)
1393        io(putStrLn msg) >> return False
1394
1395 handler exception = do
1396   flushInterpBuffers
1397   io installSignalHandlers
1398   ghciHandle handler (showException exception >> return False)
1399
1400 showException (DynException dyn) =
1401   case fromDynamic dyn of
1402     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
1403     Just Interrupted      -> io (putStrLn "Interrupted.")
1404     Just (CmdLineError s) -> io (putStrLn s)     -- omit the location for CmdLineError
1405     Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
1406     Just other_ghc_ex     -> io (print other_ghc_ex)
1407
1408 showException other_exception
1409   = io (putStrLn ("*** Exception: " ++ show other_exception))
1410
1411 -----------------------------------------------------------------------------
1412 -- recursive exception handlers
1413
1414 -- Don't forget to unblock async exceptions in the handler, or if we're
1415 -- in an exception loop (eg. let a = error a in a) the ^C exception
1416 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
1417
1418 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1419 ghciHandle h (GHCi m) = GHCi $ \s ->
1420    Exception.catch (m s)
1421         (\e -> unGHCi (ghciUnblock (h e)) s)
1422
1423 ghciUnblock :: GHCi a -> GHCi a
1424 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1425
1426
1427 -- ----------------------------------------------------------------------------
1428 -- Utils
1429
1430 expandPath :: String -> GHCi String
1431 expandPath path =
1432   case dropWhile isSpace path of
1433    ('~':d) -> do
1434         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1435         return (tilde ++ '/':d)
1436    other ->
1437         return other
1438
1439 -- ----------------------------------------------------------------------------
1440 -- Windows console setup
1441
1442 setUpConsole :: IO ()
1443 setUpConsole = do
1444 #ifdef mingw32_HOST_OS
1445         -- On Windows we need to set a known code page, otherwise the characters
1446         -- we read from the console will be be in some strange encoding, and
1447         -- similarly for characters we write to the console.
1448         --
1449         -- At the moment, GHCi pretends all input is Latin-1.  In the
1450         -- future we should support UTF-8, but for now we set the code pages
1451         -- to Latin-1.
1452         --
1453         -- It seems you have to set the font in the console window to
1454         -- a Unicode font in order for output to work properly,
1455         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1456         -- (see MSDN for SetConsoleOutputCP()).
1457         --
1458         setConsoleCP 28591       -- ISO Latin-1
1459         setConsoleOutputCP 28591 -- ISO Latin-1
1460 #endif
1461         return ()
1462
1463
1464 instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
1465 instrumentationBkptHandler ref_bkptTable = BkptHandler {
1466     isAutoBkptEnabled = \sess bkptLoc -> do
1467       bktpTable <- readIORef ref_bkptTable
1468       return$ isBkptEnabled bktpTable bkptLoc
1469
1470   , handleBreakpoint = doBreakpoint ref_bkptTable
1471   }
1472
1473 doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
1474 doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
1475          let (ids, hValues) = unzip values
1476              names = map idName ids
1477          ASSERT (length names == length hValues) return ()
1478          let global_ids = map globaliseAndTidy ids
1479          printScopeMsg locMsg global_ids
1480          typed_ids  <- mapM instantiateIdType global_ids
1481          hsc_env <- readIORef ref
1482          let ictxt = hsc_IC hsc_env
1483              rn_env   = ic_rn_local_env ictxt
1484              type_env = ic_type_env ictxt
1485              bound_names = map idName typed_ids
1486              new_rn_env  = extendLocalRdrEnv rn_env bound_names
1487                 -- Remove any shadowed bindings from the type_env;
1488                 -- they are inaccessible but might, I suppose, cause
1489                 -- a space leak if we leave them there
1490              shadowed = [ n | name <- bound_names,
1491                           let rdr_name = mkRdrUnqual (nameOccName name),
1492                           Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
1493              filtered_type_env = delListFromNameEnv type_env shadowed
1494              new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
1495              new_ic = ictxt { ic_rn_local_env = new_rn_env,
1496                               ic_type_env     = new_type_env }
1497          writeIORef ref (hsc_env { hsc_IC = new_ic })
1498          is_tty <- hIsTerminalDevice stdin
1499          prel_mod <- GHC.findModule s prel_name Nothing
1500          withExtendedLinkEnv (zip names hValues) $
1501            startGHCi (interactiveLoop is_tty True) GHCiState{
1502                               progname = "<interactive>",
1503                               args     = [],
1504                               prompt   = locMsg ++ "> ",
1505                               session  = s,
1506                               options  = [],
1507                               bkptTable= ref_bkptTable,
1508                               prelude  = prel_mod,
1509                               topLevel = False }
1510              `catchDyn` (
1511                  \StopChildSession -> evaluate$
1512                         throwDyn (ChildSessionStopped "")
1513            ) `finally` do
1514              writeIORef ref hsc_env
1515              putStrLn $ "Returning to normal execution..."
1516          return b
1517   where
1518      printScopeMsg :: String -> [Id] -> IO ()
1519      printScopeMsg location ids = do
1520        unqual  <- GHC.getPrintUnqual s
1521        printForUser stdout unqual $
1522          text "Stopped at a breakpoint in " <> text (stripColumn location) <>
1523          char '.' <+> text "Local bindings in scope:" $$
1524          nest 2 (pprWithCommas showId ids)
1525       where
1526            showId id =
1527                 ppr (idName id) <+> dcolon <+> ppr (idType id)
1528            stripColumn = reverse . tail . dropWhile (/= ':') . reverse
1529
1530 -- | Give the Id a Global Name, and tidy its type
1531      globaliseAndTidy :: Id -> Id
1532      globaliseAndTidy id
1533       = let tidied_type = tidyTopType$ idType id
1534         in setIdType (globaliseId VanillaGlobal id) tidied_type
1535
1536 -- | Instantiate the tyVars with GHC.Base.Unknown
1537      instantiateIdType :: Id -> IO Id
1538      instantiateIdType id = do
1539        instantiatedType <- instantiateTyVarsToUnknown s (idType id)
1540        return$ setIdType id instantiatedType
1541
1542