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 Control.Monad as Monad
  89 import Foreign.StablePtr        ( newStablePtr )
  90
  91 import GHC.Exts         ( unsafeCoerce# )
  92 import GHC.IOBase       ( IOErrorType(InvalidArgument) )
  93
  94 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
  95
  96 import System.Posix.Internals ( setNonBlockingFD )
  97
  98 -----------------------------------------------------------------------------
  99
 100 ghciWelcomeMsg =
 101  "   ___         ___ _\n"++
 102  "  / _ \\ /\\  /\\/ __(_)\n"++
 103  " / /_\\// /_/ / /  | |      GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
 104  "/ /_\\\\/ __  / /___| |      http://www.haskell.org/ghc/\n"++
 105  "\\____/\\/ /_/\\____/|_|      Type :? for help.\n"
 106
 107 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
 108 cmdName (n,_,_,_) = n
 109
 110 GLOBAL_VAR(commands, builtin_commands, [Command])
 111
 112 builtin_commands :: [Command]
 113 builtin_commands = [
 114   ("add",       tlC$ keepGoingPaths addModule,  False, completeFilename),
 115   ("browse",    keepGoing browseCmd,            False, completeModule),
 116   ("cd",        keepGoing changeDirectory,      False, completeFilename),
 117   ("def",       keepGoing defineMacro,          False, completeIdentifier),
 118   ("e",         keepGoing editFile,             False, completeFilename),
 119         -- Hugs users are accustomed to :e, so make sure it doesn't overlap
 120   ("edit",      keepGoing editFile,             False, completeFilename),
 121   ("help",      keepGoing help,                 False, completeNone),
 122   ("?",         keepGoing help,                 False, completeNone),
 123   ("info",      keepGoing info,                 False, completeIdentifier),
 124   ("load",      tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
 125   ("module",    keepGoing setContext,           False, completeModule),
 126   ("main",      tlC$ keepGoing runMain,         False, completeIdentifier),
 127   ("reload",    tlC$ keepGoing reloadModule,    False, completeNone),
 128   ("check",     keepGoing checkModule,          False, completeHomeModule),
 129   ("set",       keepGoing setCmd,               True,  completeSetOptions),
 130   ("show",      keepGoing showCmd,              False, completeNone),
 131   ("etags",     keepGoing createETagsFileCmd,   False, completeFilename),
 132   ("ctags",     keepGoing createCTagsFileCmd,   False, completeFilename),
 133   ("type",      keepGoing typeOfExpr,           False, completeIdentifier),
 134 #if defined(GHCI)
 135   ("breakpoint",keepGoing bkptOptions,          False, completeBkpt),
 136 #endif
 137   ("kind",      keepGoing kindOfType,           False, completeIdentifier),
 138   ("unset",     keepGoing unsetOptions,         True,  completeSetOptions),
 139   ("undef",     keepGoing undefineMacro,        False, completeMacro),
 140   ("quit",      quit,                           False, completeNone)
 141   ]
 142
 143 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 144 keepGoing a str = a str >> return False
 145
 146 -- tlC: Top Level Command
 147 tlC ::  (String -> GHCi Bool) -> (String -> GHCi Bool)
 148 tlC a str = do
 149     top_level <- isTopLevel
 150     if not top_level
 151        then throwDyn (CmdLineError "Command only allowed at Top Level")
 152        else a str
 153
 154 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 155 keepGoingPaths a str = a (toArgs str) >> return False
 156
 157 shortHelpText = "use :? for help.\n"
 158
 159 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 160 helpText =
 161  " Commands available from the prompt:\n" ++
 162  "\n" ++
 163  "   <stmt>                      evaluate/run <stmt>\n" ++
 164  "   :add <filename> ...         add module(s) to the current target set\n" ++
 165  "   :breakpoint <option>        commands for the GHCi debugger\n" ++
 166  "   :browse [*]<module>         display the names defined by <module>\n" ++
 167  "   :cd <dir>                   change directory to <dir>\n" ++
 168  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 169  "   :edit <file>                edit file\n" ++
 170  "   :edit                       edit last module\n" ++
 171  "   :help, :?                   display this list of commands\n" ++
 172  "   :info [<name> ...]          display information about the given names\n" ++
 173  "   :load <filename> ...        load module(s) and their dependents\n" ++
 174  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 175  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 176  "   :reload                     reload the current module set\n" ++
 177  "\n" ++
 178  "   :set <option> ...           set options\n" ++
 179  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 180  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 181  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 182  "   :set editor <cmd>           set the command used for :edit\n" ++
 183  "\n" ++
 184  "   :show modules               show the currently loaded modules\n" ++
 185  "   :show bindings              show the current bindings made at the prompt\n" ++
 186  "\n" ++
 187  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 188  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 189  "   :type <expr>                show the type of <expr>\n" ++
 190  "   :kind <type>                show the kind of <type>\n" ++
 191  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 192  "   :unset <option> ...         unset options\n" ++
 193  "   :quit                       exit GHCi\n" ++
 194  "   :!<command>                 run the shell command <command>\n" ++
 195  "\n" ++
 196  " Options for ':set' and ':unset':\n" ++
 197  "\n" ++
 198  "    +r            revert top-level expressions after each evaluation\n" ++
 199  "    +s            print timing/memory stats after each evaluation\n" ++
 200  "    +t            print type after evaluation\n" ++
 201  "    -<flags>      most GHC command line flags can also be set here\n" ++
 202  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 203  "\n" ++
 204  " Options for ':breakpoint':\n" ++
 205  "   list                                     list the current breakpoints\n" ++
 206  "   add Module line [col]                    add a new breakpoint\n" ++
 207  "   del (breakpoint# | Module line [col])    delete a breakpoint\n" ++
 208  "   stop                   Stop a computation and return to the top level\n" ++
 209  "   step [count]           Step by step execution (DISABLED)\n"
 210
 211 findEditor = do
 212   getEnv "EDITOR"
 213     `IO.catch` \_ -> do
 214 #if mingw32_HOST_OS
 215         win <- System.Win32.getWindowsDirectory
 216         return (win `joinFileName` "notepad.exe")
 217 #else
 218         return ""
 219 #endif
 220
 221 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 222 interactiveUI session srcs maybe_expr = do
 223    -- HACK! If we happen to get into an infinite loop (eg the user
 224    -- types 'let x=x in x' at the prompt), then the thread will block
 225    -- on a blackhole, and become unreachable during GC.  The GC will
 226    -- detect that it is unreachable and send it the NonTermination
 227    -- exception.  However, since the thread is unreachable, everything
 228    -- it refers to might be finalized, including the standard Handles.
 229    -- This sounds like a bug, but we don't have a good solution right
 230    -- now.
 231    newStablePtr stdin
 232    newStablePtr stdout
 233    newStablePtr stderr
 234
 235         -- Initialise buffering for the *interpreted* I/O system
 236    initInterpBuffering session
 237
 238    when (isNothing maybe_expr) $ do
 239         -- Only for GHCi (not runghc and ghc -e):
 240         -- Turn buffering off for the compiled program's stdout/stderr
 241         turnOffBuffering
 242         -- Turn buffering off for GHCi's stdout
 243         hFlush stdout
 244         hSetBuffering stdout NoBuffering
 245         -- We don't want the cmd line to buffer any input that might be
 246         -- intended for the program, so unbuffer stdin.
 247         hSetBuffering stdin NoBuffering
 248
 249         -- initial context is just the Prelude
 250    prel_mod <- GHC.findModule session prel_name Nothing
 251    GHC.setContext session [] [prel_mod]
 252
 253 #ifdef USE_READLINE
 254    Readline.initialize
 255    Readline.setAttemptedCompletionFunction (Just completeWord)
 256    --Readline.parseAndBind "set show-all-if-ambiguous 1"
 257
 258    let symbols = "!#$%&*+/<=>?@\\^|-~"
 259        specials = "(),;[]`{}"
 260        spaces = " \t\n"
 261        word_break_chars = spaces ++ specials ++ symbols
 262
 263    Readline.setBasicWordBreakCharacters word_break_chars
 264    Readline.setCompleterWordBreakCharacters word_break_chars
 265 #endif
 266
 267    bkptTable <- newIORef emptyBkptTable
 268    GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable)
 269    default_editor <- findEditor
 270
 271    startGHCi (runGHCi srcs maybe_expr)
 272         GHCiState{ progname = "<interactive>",
 273                    args = [],
 274                    prompt = "%s> ",
 275                    editor = default_editor,
 276                    session = session,
 277                    options = [],
 278                    prelude = prel_mod,
 279                    bkptTable = bkptTable,
 280                    topLevel  = True
 281                  }
 282
 283 #ifdef USE_READLINE
 284    Readline.resetTerminal Nothing
 285 #endif
 286
 287    return ()
 288
 289 prel_name = GHC.mkModuleName "Prelude"
 290
 291 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 292 runGHCi paths maybe_expr = do
 293   let read_dot_files = not opt_IgnoreDotGhci
 294
 295   when (read_dot_files) $ do
 296     -- Read in ./.ghci.
 297     let file = "./.ghci"
 298     exists <- io (doesFileExist file)
 299     when exists $ do
 300        dir_ok  <- io (checkPerms ".")
 301        file_ok <- io (checkPerms file)
 302        when (dir_ok && file_ok) $ do
 303           either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
 304           case either_hdl of
 305              Left e    -> return ()
 306              Right hdl -> fileLoop hdl False
 307
 308   when (read_dot_files) $ do
 309     -- Read in $HOME/.ghci
 310     either_dir <- io (IO.try (getEnv "HOME"))
 311     case either_dir of
 312        Left e -> return ()
 313        Right dir -> do
 314           cwd <- io (getCurrentDirectory)
 315           when (dir /= cwd) $ do
 316              let file = dir ++ "/.ghci"
 317              ok <- io (checkPerms file)
 318              when ok $ do
 319                either_hdl <- io (IO.try (openFile file ReadMode))
 320                case either_hdl of
 321                   Left e    -> return ()
 322                   Right hdl -> fileLoop hdl False
 323
 324   -- Perform a :load for files given on the GHCi command line
 325   -- When in -e mode, if the load fails then we want to stop
 326   -- immediately rather than going on to evaluate the expression.
 327   when (not (null paths)) $ do
 328      ok <- ghciHandle (\e -> do showException e; return Failed) $
 329                 loadModule paths
 330      when (isJust maybe_expr && failed ok) $
 331         io (exitWith (ExitFailure 1))
 332
 333   -- if verbosity is greater than 0, or we are connected to a
 334   -- terminal, display the prompt in the interactive loop.
 335   is_tty <- io (hIsTerminalDevice stdin)
 336   dflags <- getDynFlags
 337   let show_prompt = verbosity dflags > 0 || is_tty
 338
 339   case maybe_expr of
 340         Nothing ->
 341           do
 342 #if defined(mingw32_HOST_OS)
 343             -- The win32 Console API mutates the first character of
 344             -- type-ahead when reading from it in a non-buffered manner. Work
 345             -- around this by flushing the input buffer of type-ahead characters,
 346             -- but only if stdin is available.
 347             flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
 348             case flushed of
 349              Left err | isDoesNotExistError err -> return ()
 350                       | otherwise -> io (ioError err)
 351              Right () -> return ()
 352 #endif
 353             -- initialise the console if necessary
 354             io setUpConsole
 355
 356             -- enter the interactive loop
 357             interactiveLoop is_tty show_prompt
 358         Just expr -> do
 359             -- just evaluate the expression we were given
 360             runCommandEval expr
 361             return ()
 362
 363   -- and finally, exit
 364   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 365
 366
 367 interactiveLoop is_tty show_prompt =
 368   -- Ignore ^C exceptions caught here
 369   ghciHandleDyn (\e -> case e of
 370                         Interrupted -> do
 371 #if defined(mingw32_HOST_OS)
 372                                 io (putStrLn "")
 373 #endif
 374                                 interactiveLoop is_tty show_prompt
 375                         _other      -> return ()) $
 376
 377   ghciUnblock $ do -- unblock necessary if we recursed from the
 378                    -- exception handler above.
 379
 380   -- read commands from stdin
 381 #ifdef USE_READLINE
 382   if (is_tty)
 383         then readlineLoop
 384         else fileLoop stdin show_prompt
 385 #else
 386   fileLoop stdin show_prompt
 387 #endif
 388
 389
 390 -- NOTE: We only read .ghci files if they are owned by the current user,
 391 -- and aren't world writable.  Otherwise, we could be accidentally
 392 -- running code planted by a malicious third party.
 393
 394 -- Furthermore, We only read ./.ghci if . is owned by the current user
 395 -- and isn't writable by anyone else.  I think this is sufficient: we
 396 -- don't need to check .. and ../.. etc. because "."  always refers to
 397 -- the same directory while a process is running.
 398
 399 checkPerms :: String -> IO Bool
 400 checkPerms name =
 401 #ifdef mingw32_HOST_OS
 402   return True
 403 #else
 404   Util.handle (\_ -> return False) $ do
 405      st <- getFileStatus name
 406      me <- getRealUserID
 407      if fileOwner st /= me then do
 408         putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
 409         return False
 410       else do
 411         let mode =  fileMode st
 412         if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
 413            || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
 414            then do
 415                putStrLn $ "*** WARNING: " ++ name ++
 416                           " is writable by someone else, IGNORING!"
 417                return False
 418           else return True
 419 #endif
 420
 421 fileLoop :: Handle -> Bool -> GHCi ()
 422 fileLoop hdl show_prompt = do
 423    session <- getSession
 424    (mod,imports) <- io (GHC.getContext session)
 425    st <- getGHCiState
 426    when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
 427    l <- io (IO.try (hGetLine hdl))
 428    case l of
 429         Left e | isEOFError e              -> return ()
 430                | InvalidArgument <- etype  -> return ()
 431                | otherwise                 -> io (ioError e)
 432                 where etype = ioeGetErrorType e
 433                 -- treat InvalidArgument in the same way as EOF:
 434                 -- this can happen if the user closed stdin, or
 435                 -- perhaps did getContents which closes stdin at
 436                 -- EOF.
 437         Right l ->
 438           case removeSpaces l of
 439             "" -> fileLoop hdl show_prompt
 440             l  -> do quit <- runCommand l
 441                      if quit then return () else fileLoop hdl show_prompt
 442
 443 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
 444 stringLoop [] = return False
 445 stringLoop (s:ss) = do
 446    case removeSpaces s of
 447         "" -> stringLoop ss
 448         l  -> do quit <- runCommand l
 449                  if quit then return True else stringLoop ss
 450
 451 mkPrompt toplevs exports prompt
 452   = showSDoc $ f prompt
 453     where
 454         f ('%':'s':xs) = perc_s <> f xs
 455         f ('%':'%':xs) = char '%' <> f xs
 456         f (x:xs) = char x <> f xs
 457         f [] = empty
 458
 459         perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
 460                  hsep (map (ppr . GHC.moduleName) exports)
 461
 462
 463 #ifdef USE_READLINE
 464 readlineLoop :: GHCi ()
 465 readlineLoop = do
 466    session <- getSession
 467    (mod,imports) <- io (GHC.getContext session)
 468    io yield
 469    saveSession -- for use by completion
 470    st <- getGHCiState
 471    l <- io (readline (mkPrompt mod imports (prompt st))
 472                 `finally` setNonBlockingFD 0)
 473                 -- readline sometimes puts stdin into blocking mode,
 474                 -- so we need to put it back for the IO library
 475    splatSavedSession
 476    case l of
 477         Nothing -> return ()
 478         Just l  ->
 479           case removeSpaces l of
 480             "" -> readlineLoop
 481             l  -> do
 482                   io (addHistory l)
 483                   quit <- runCommand l
 484                   if quit then return () else readlineLoop
 485 #endif
 486
 487 runCommand :: String -> GHCi Bool
 488 runCommand c = ghciHandle handler (doCommand c)
 489   where
 490     doCommand (':' : command) = specialCommand command
 491     doCommand stmt
 492        = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
 493             return False
 494
 495 -- This version is for the GHC command-line option -e.  The only difference
 496 -- from runCommand is that it catches the ExitException exception and
 497 -- exits, rather than printing out the exception.
 498 runCommandEval c = ghciHandle handleEval (doCommand c)
 499   where
 500     handleEval (ExitException code) = io (exitWith code)
 501     handleEval e                    = do handler e
 502                                          io (exitWith (ExitFailure 1))
 503
 504     doCommand (':' : command) = specialCommand command
 505     doCommand stmt
 506        = do nms <- runStmt stmt
 507             case nms of
 508                 Nothing -> io (exitWith (ExitFailure 1))
 509                   -- failure to run the command causes exit(1) for ghc -e.
 510                 _       -> finishEvalExpr nms
 511
 512 runStmt :: String -> GHCi (Maybe [Name])
 513 runStmt stmt
 514  | null (filter (not.isSpace) stmt) = return (Just [])
 515  | otherwise
 516  = do st <- getGHCiState
 517       session <- getSession
 518       result <- io $ withProgName (progname st) $ withArgs (args st) $
 519                      GHC.runStmt session stmt
 520       case result of
 521         GHC.RunFailed      -> return Nothing
 522         GHC.RunException e -> throw e  -- this is caught by runCommand(Eval)
 523         GHC.RunOk names    -> return (Just names)
 524
 525 -- possibly print the type and revert CAFs after evaluating an expression
 526 finishEvalExpr mb_names
 527  = do b <- isOptionSet ShowType
 528       session <- getSession
 529       case mb_names of
 530         Nothing    -> return ()
 531         Just names -> when b (mapM_ (showTypeOfName session) names)
 532
 533       flushInterpBuffers
 534       io installSignalHandlers
 535       b <- isOptionSet RevertCAFs
 536       io (when b revertCAFs)
 537       return True
 538
 539 showTypeOfName :: Session -> Name -> GHCi ()
 540 showTypeOfName session n
 541    = do maybe_tything <- io (GHC.lookupName session n)
 542         case maybe_tything of
 543           Nothing    -> return ()
 544           Just thing -> showTyThing thing
 545
 546 specialCommand :: String -> GHCi Bool
 547 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 548 specialCommand str = do
 549   let (cmd,rest) = break isSpace str
 550   maybe_cmd <- io (lookupCommand cmd)
 551   case maybe_cmd of
 552     Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
 553                                     ++ shortHelpText) >> return False)
 554     Just (_,f,_,_) -> f (dropWhile isSpace rest)
 555
 556 lookupCommand :: String -> IO (Maybe Command)
 557 lookupCommand str = do
 558   cmds <- readIORef commands
 559   -- look for exact match first, then the first prefix match
 560   case [ c | c <- cmds, str == cmdName c ] of
 561      c:_ -> return (Just c)
 562      [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
 563                 [] -> return Nothing
 564                 c:_ -> return (Just c)
 565
 566 -----------------------------------------------------------------------------
 567 -- Commands
 568
 569 help :: String -> GHCi ()
 570 help _ = io (putStr helpText)
 571
 572 info :: String -> GHCi ()
 573 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 574 info s  = do { let names = words s
 575              ; session <- getSession
 576              ; dflags <- getDynFlags
 577              ; let exts = dopt Opt_GlasgowExts dflags
 578              ; mapM_ (infoThing exts session) names }
 579   where
 580     infoThing exts session str = io $ do
 581         names <- GHC.parseName session str
 582         let filtered = filterOutChildren names
 583         mb_stuffs <- mapM (GHC.getInfo session) filtered
 584         unqual <- GHC.getPrintUnqual session
 585         putStrLn (showSDocForUser unqual $
 586                    vcat (intersperse (text "") $
 587                    [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
 588
 589   -- Filter out names whose parent is also there Good
 590   -- example is '[]', which is both a type and data
 591   -- constructor in the same type
 592 filterOutChildren :: [Name] -> [Name]
 593 filterOutChildren names = filter (not . parent_is_there) names
 594  where parent_is_there n
 595 --       | Just p <- GHC.nameParent_maybe n = p `elem` names
 596 -- ToDo!!
 597          | otherwise                       = False
 598
 599 pprInfo exts (thing, fixity, insts)
 600   =  pprTyThingInContextLoc exts thing
 601   $$ show_fixity fixity
 602   $$ vcat (map GHC.pprInstance insts)
 603   where
 604     show_fixity fix
 605         | fix == GHC.defaultFixity = empty
 606         | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 607
 608 -----------------------------------------------------------------------------
 609 -- Commands
 610
 611 runMain :: String -> GHCi ()
 612 runMain args = do
 613   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
 614   runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
 615   return ()
 616
 617 addModule :: [FilePath] -> GHCi ()
 618 addModule files = do
 619   io (revertCAFs)                       -- always revert CAFs on load/add.
 620   files <- mapM expandPath files
 621   targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
 622   session <- getSession
 623   io (mapM_ (GHC.addTarget session) targets)
 624   ok <- io (GHC.load session LoadAllTargets)
 625   afterLoad ok session
 626
 627 changeDirectory :: String -> GHCi ()
 628 changeDirectory dir = do
 629   session <- getSession
 630   graph <- io (GHC.getModuleGraph session)
 631   when (not (null graph)) $
 632         io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
 633   io (GHC.setTargets session [])
 634   io (GHC.load session LoadAllTargets)
 635   setContextAfterLoad session []
 636   io (GHC.workingDirectoryChanged session)
 637   dir <- expandPath dir
 638   io (setCurrentDirectory dir)
 639
 640 editFile :: String -> GHCi ()
 641 editFile str
 642   | null str  = do
 643         -- find the name of the "topmost" file loaded
 644      session <- getSession
 645      graph0 <- io (GHC.getModuleGraph session)
 646      graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
 647      let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
 648      case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
 649         Just file -> do_edit file
 650         Nothing   -> throwDyn (CmdLineError "unknown file name")
 651   | otherwise = do_edit str
 652   where
 653         do_edit file = do
 654            st <- getGHCiState
 655            let cmd = editor st
 656            when (null cmd) $
 657                 throwDyn (CmdLineError "editor not set, use :set editor")
 658            io $ system (cmd ++ ' ':file)
 659            return ()
 660
 661 defineMacro :: String -> GHCi ()
 662 defineMacro s = do
 663   let (macro_name, definition) = break isSpace s
 664   cmds <- io (readIORef commands)
 665   if (null macro_name)
 666         then throwDyn (CmdLineError "invalid macro name")
 667         else do
 668   if (macro_name `elem` map cmdName cmds)
 669         then throwDyn (CmdLineError
 670                 ("command '" ++ macro_name ++ "' is already defined"))
 671         else do
 672
 673   -- give the expression a type signature, so we can be sure we're getting
 674   -- something of the right type.
 675   let new_expr = '(' : definition ++ ") :: String -> IO String"
 676
 677   -- compile the expression
 678   cms <- getSession
 679   maybe_hv <- io (GHC.compileExpr cms new_expr)
 680   case maybe_hv of
 681      Nothing -> return ()
 682      Just hv -> io (writeIORef commands --
 683                     (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
 684
 685 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 686 runMacro fun s = do
 687   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
 688   stringLoop (lines str)
 689
 690 undefineMacro :: String -> GHCi ()
 691 undefineMacro macro_name = do
 692   cmds <- io (readIORef commands)
 693   if (macro_name `elem` map cmdName builtin_commands)
 694         then throwDyn (CmdLineError
 695                 ("command '" ++ macro_name ++ "' cannot be undefined"))
 696         else do
 697   if (macro_name `notElem` map cmdName cmds)
 698         then throwDyn (CmdLineError
 699                 ("command '" ++ macro_name ++ "' not defined"))
 700         else do
 701   io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
 702
 703
 704 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 705 loadModule fs = timeIt (loadModule' fs)
 706
 707 loadModule_ :: [FilePath] -> GHCi ()
 708 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
 709
 710 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
 711 loadModule' files = do
 712   session <- getSession
 713
 714   -- unload first
 715   io (GHC.setTargets session [])
 716   io (GHC.load session LoadAllTargets)
 717
 718   -- expand tildes
 719   let (filenames, phases) = unzip files
 720   exp_filenames <- mapM expandPath filenames
 721   let files' = zip exp_filenames phases
 722   targets <- io (mapM (uncurry GHC.guessTarget) files')
 723
 724   -- NOTE: we used to do the dependency anal first, so that if it
 725   -- fails we didn't throw away the current set of modules.  This would
 726   -- require some re-working of the GHC interface, so we'll leave it
 727   -- as a ToDo for now.
 728
 729   io (GHC.setTargets session targets)
 730   ok <- io (GHC.load session LoadAllTargets)
 731   afterLoad ok session
 732   return ok
 733
 734 checkModule :: String -> GHCi ()
 735 checkModule m = do
 736   let modl = GHC.mkModuleName m
 737   session <- getSession
 738   result <- io (GHC.checkModule session modl)
 739   case result of
 740     Nothing -> io $ putStrLn "Nothing"
 741     Just r  -> io $ putStrLn (showSDoc (
 742         case GHC.checkedModuleInfo r of
 743            Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
 744                 let
 745                     (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 746                 in
 747                         (text "global names: " <+> ppr global) $$
 748                         (text "local  names: " <+> ppr local)
 749            _ -> empty))
 750   afterLoad (successIf (isJust result)) session
 751
 752 reloadModule :: String -> GHCi ()
 753 reloadModule "" = do
 754   io (revertCAFs)               -- always revert CAFs on reload.
 755   session <- getSession
 756   ok <- io (GHC.load session LoadAllTargets)
 757   afterLoad ok session
 758 reloadModule m = do
 759   io (revertCAFs)               -- always revert CAFs on reload.
 760   session <- getSession
 761   ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
 762   afterLoad ok session
 763
 764 afterLoad ok session = do
 765   io (revertCAFs)  -- always revert CAFs on load.
 766   graph <- io (GHC.getModuleGraph session)
 767   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
 768   setContextAfterLoad session graph'
 769   refreshBkptTable graph'
 770   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 771
 772 setContextAfterLoad session [] = do
 773   prel_mod <- getPrelude
 774   io (GHC.setContext session [] [prel_mod])
 775 setContextAfterLoad session ms = do
 776   -- load a target if one is available, otherwise load the topmost module.
 777   targets <- io (GHC.getTargets session)
 778   case [ m | Just m <- map (findTarget ms) targets ] of
 779         []    ->
 780           let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
 781           load_this (last graph')
 782         (m:_) ->
 783           load_this m
 784  where
 785    findTarget ms t
 786     = case filter (`matches` t) ms of
 787         []    -> Nothing
 788         (m:_) -> Just m
 789
 790    summary `matches` Target (TargetModule m) _
 791         = GHC.ms_mod_name summary == m
 792    summary `matches` Target (TargetFile f _) _
 793         | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
 794    summary `matches` target
 795         = False
 796
 797    load_this summary | m <- GHC.ms_mod summary = do
 798         b <- io (GHC.moduleIsInterpreted session m)
 799         if b then io (GHC.setContext session [m] [])
 800              else do
 801                    prel_mod <- getPrelude
 802                    io (GHC.setContext session []  [prel_mod,m])
 803
 804
 805 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 806 modulesLoadedMsg ok mods = do
 807   dflags <- getDynFlags
 808   when (verbosity dflags > 0) $ do
 809    let mod_commas
 810         | null mods = text "none."
 811         | otherwise = hsep (
 812             punctuate comma (map ppr mods)) <> text "."
 813    case ok of
 814     Failed ->
 815        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
 816     Succeeded  ->
 817        io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
 818
 819
 820 typeOfExpr :: String -> GHCi ()
 821 typeOfExpr str
 822   = do cms <- getSession
 823        maybe_ty <- io (GHC.exprType cms str)
 824        case maybe_ty of
 825           Nothing -> return ()
 826           Just ty -> do ty' <- cleanType ty
 827                         tystr <- showForUser (ppr ty')
 828                         io (putStrLn (str ++ " :: " ++ tystr))
 829
 830 kindOfType :: String -> GHCi ()
 831 kindOfType str
 832   = do cms <- getSession
 833        maybe_ty <- io (GHC.typeKind cms str)
 834        case maybe_ty of
 835           Nothing    -> return ()
 836           Just ty    -> do tystr <- showForUser (ppr ty)
 837                            io (putStrLn (str ++ " :: " ++ tystr))
 838
 839 quit :: String -> GHCi Bool
 840 quit _ = return True
 841
 842 shellEscape :: String -> GHCi Bool
 843 shellEscape str = io (system str >> return False)
 844
 845 -----------------------------------------------------------------------------
 846 -- create tags file for currently loaded modules.
 847
 848 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
 849
 850 createCTagsFileCmd ""   = ghciCreateTagsFile CTags "tags"
 851 createCTagsFileCmd file = ghciCreateTagsFile CTags file
 852
 853 createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
 854 createETagsFileCmd file  = ghciCreateTagsFile ETags file
 855
 856 data TagsKind = ETags | CTags
 857
 858 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
 859 ghciCreateTagsFile kind file = do
 860   session <- getSession
 861   io $ createTagsFile session kind file
 862
 863 -- ToDo:
 864 --      - remove restriction that all modules must be interpreted
 865 --        (problem: we don't know source locations for entities unless
 866 --        we compiled the module.
 867 --
 868 --      - extract createTagsFile so it can be used from the command-line
 869 --        (probably need to fix first problem before this is useful).
 870 --
 871 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
 872 createTagsFile session tagskind tagFile = do
 873   graph <- GHC.getModuleGraph session
 874   let ms = map GHC.ms_mod graph
 875       tagModule m = do
 876         is_interpreted <- GHC.moduleIsInterpreted session m
 877         -- should we just skip these?
 878         when (not is_interpreted) $
 879           throwDyn (CmdLineError ("module '"
 880                                 ++ GHC.moduleNameString (GHC.moduleName m)
 881                                 ++ "' is not interpreted"))
 882         mbModInfo <- GHC.getModuleInfo session m
 883         let unqual
 884               | Just modinfo <- mbModInfo,
 885                 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
 886               | otherwise = GHC.alwaysQualify
 887
 888         case mbModInfo of
 889           Just modInfo -> return $! listTags unqual modInfo
 890           _            -> return []
 891
 892   mtags <- mapM tagModule ms
 893   either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
 894   case either_res of
 895     Left e  -> hPutStrLn stderr $ ioeGetErrorString e
 896     Right _ -> return ()
 897
 898 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
 899 listTags unqual modInfo =
 900            [ tagInfo unqual name loc
 901            | name <- GHC.modInfoExports modInfo
 902            , let loc = nameSrcLoc name
 903            , isGoodSrcLoc loc
 904            ]
 905
 906 type TagInfo = (String -- tag name
 907                ,String -- file name
 908                ,Int    -- line number
 909                ,Int    -- column number
 910                )
 911
 912 -- get tag info, for later translation into Vim or Emacs style
 913 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
 914 tagInfo unqual name loc
 915     = ( showSDocForUser unqual $ pprOccName (nameOccName name)
 916       , showSDocForUser unqual $ ftext (srcLocFile loc)
 917       , srcLocLine loc
 918       , srcLocCol loc
 919       )
 920
 921 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
 922 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
 923   let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
 924   IO.try (writeFile file tags)
 925 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
 926   let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
 927       groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
 928   tagGroups <- mapM tagFileGroup groups
 929   IO.try (writeFile file $ concat tagGroups)
 930   where
 931     tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
 932     tagFileGroup group@((_,fileName,_,_):_) = do
 933       file <- readFile fileName -- need to get additional info from sources..
 934       let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
 935           sortedGroup = sortLe byLine group
 936           tags = unlines $ perFile sortedGroup 1 0 $ lines file
 937       return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
 938     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
 939       perFile (tagInfo:tags) (count+1) (pos+length line) lines
 940     perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
 941       showETag tagInfo line pos : perFile tags count pos lines
 942     perFile tags count pos lines = []
 943
 944 -- simple ctags format, for Vim et al
 945 showTag :: TagInfo -> String
 946 showTag (tag,file,lineNo,colNo)
 947     =  tag ++ "\t" ++ file ++ "\t" ++ show lineNo
 948
 949 -- etags format, for Emacs/XEmacs
 950 showETag :: TagInfo -> String -> Int -> String
 951 showETag (tag,file,lineNo,colNo) line charPos
 952     =  take colNo line ++ tag
 953     ++ "\x7f" ++ tag
 954     ++ "\x01" ++ show lineNo
 955     ++ "," ++ show charPos
 956
 957 -----------------------------------------------------------------------------
 958 -- Browsing a module's contents
 959
 960 browseCmd :: String -> GHCi ()
 961 browseCmd m =
 962   case words m of
 963     ['*':m] | looksLikeModuleName m -> browseModule m False
 964     [m]     | looksLikeModuleName m -> browseModule m True
 965     _ -> throwDyn (CmdLineError "syntax:  :browse <module>")
 966
 967 browseModule m exports_only = do
 968   s <- getSession
 969   modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
 970   is_interpreted <- io (GHC.moduleIsInterpreted s modl)
 971   when (not is_interpreted && not exports_only) $
 972         throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
 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         ["breakpoints"] -> showBkptTable
1203         _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
1204
1205 showModules = do
1206   session <- getSession
1207   let show_one ms = do m <- io (GHC.showModule session ms)
1208                        io (putStrLn m)
1209   graph <- io (GHC.getModuleGraph session)
1210   mapM_ show_one graph
1211
1212 showBindings = do
1213   s <- getSession
1214   unqual <- io (GHC.getPrintUnqual s)
1215   bindings <- io (GHC.getBindings s)
1216   mapM_ showTyThing bindings
1217   return ()
1218
1219 showTyThing (AnId id) = do
1220   ty' <- cleanType (GHC.idType id)
1221   str <- showForUser (ppr id <> text " :: " <> ppr ty')
1222   io (putStrLn str)
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   bt     <- getBkptTable
1236   msg <- showForUser . vcat $
1237              [ ppr mod <> colon <+> fcat
1238                        [ parens(int row <> comma <> int col) | (row,col) <- sites]
1239                | (mod, sites) <-  sitesList bt ]
1240   io (putStrLn msg)
1241 -- -----------------------------------------------------------------------------
1242 -- Completion
1243
1244 completeNone :: String -> IO [String]
1245 completeNone w = return []
1246
1247 #ifdef USE_READLINE
1248 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1249 completeWord w start end = do
1250   line <- Readline.getLineBuffer
1251   case w of
1252      ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1253      _other
1254         | Just c <- is_cmd line -> do
1255            maybe_cmd <- lookupCommand c
1256            let (n,w') = selectWord (words' 0 line)
1257            case maybe_cmd of
1258              Nothing -> return Nothing
1259              Just (_,_,False,complete) -> wrapCompleter complete w
1260              Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1261                                                               return (map (drop n) rets)
1262                                          in wrapCompleter complete' w'
1263         | otherwise     -> do
1264                 --printf "complete %s, start = %d, end = %d\n" w start end
1265                 wrapCompleter completeIdentifier w
1266     where words' _ [] = []
1267           words' n str = let (w,r) = break isSpace str
1268                              (s,r') = span isSpace r
1269                          in (n,w):words' (n+length w+length s) r'
1270           -- In a Haskell expression we want to parse 'a-b' as three words
1271           -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1272           -- only be a single word.
1273           selectWord [] = (0,w)
1274           selectWord ((offset,x):xs)
1275               | offset+length x >= start = (start-offset,take (end-offset) x)
1276               | otherwise = selectWord xs
1277
1278 is_cmd line
1279  | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1280  | otherwise = Nothing
1281
1282 completeCmd w = do
1283   cmds <- readIORef commands
1284   return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1285
1286 completeMacro w = do
1287   cmds <- readIORef commands
1288   let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1289   return (filter (w `isPrefixOf`) cmds')
1290
1291 completeIdentifier w = do
1292   s <- restoreSession
1293   rdrs <- GHC.getRdrNamesInScope s
1294   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1295
1296 completeModule w = do
1297   s <- restoreSession
1298   dflags <- GHC.getSessionDynFlags s
1299   let pkg_mods = allExposedModules dflags
1300   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1301
1302 completeHomeModule w = do
1303   s <- restoreSession
1304   g <- GHC.getModuleGraph s
1305   let home_mods = map GHC.ms_mod_name g
1306   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1307
1308 completeSetOptions w = do
1309   return (filter (w `isPrefixOf`) options)
1310     where options = "args":"prog":allFlags
1311
1312 completeBkpt = unionComplete completeModule completeBkptCmds
1313
1314 completeBkptCmds w = do
1315   return (filter (w `isPrefixOf`) options)
1316     where options = ["add","del","list","stop"]
1317
1318 completeFilename = Readline.filenameCompletionFunction
1319
1320 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1321
1322 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1323 unionComplete f1 f2 w = do
1324   s1 <- f1 w
1325   s2 <- f2 w
1326   return (s1 ++ s2)
1327
1328 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1329 wrapCompleter fun w =  do
1330   strs <- fun w
1331   case strs of
1332     []  -> return Nothing
1333     [x] -> return (Just (x,[]))
1334     xs  -> case getCommonPrefix xs of
1335                 ""   -> return (Just ("",xs))
1336                 pref -> return (Just (pref,xs))
1337
1338 getCommonPrefix :: [String] -> String
1339 getCommonPrefix [] = ""
1340 getCommonPrefix (s:ss) = foldl common s ss
1341   where common s "" = s
1342         common "" s = ""
1343         common (c:cs) (d:ds)
1344            | c == d = c : common cs ds
1345            | otherwise = ""
1346
1347 allExposedModules :: DynFlags -> [ModuleName]
1348 allExposedModules dflags
1349  = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1350  where
1351   pkg_db = pkgIdMap (pkgState dflags)
1352 #else
1353 completeCmd        = completeNone
1354 completeMacro      = completeNone
1355 completeIdentifier = completeNone
1356 completeModule     = completeNone
1357 completeHomeModule = completeNone
1358 completeSetOptions = completeNone
1359 completeFilename   = completeNone
1360 completeHomeModuleOrFile=completeNone
1361 completeBkpt       = completeNone
1362 #endif
1363
1364 -- ----------------------------------------------------------------------------
1365 -- Utils
1366
1367 expandPath :: String -> GHCi String
1368 expandPath path =
1369   case dropWhile isSpace path of
1370    ('~':d) -> do
1371         tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
1372         return (tilde ++ '/':d)
1373    other ->
1374         return other
1375
1376 -- ----------------------------------------------------------------------------
1377 -- Windows console setup
1378
1379 setUpConsole :: IO ()
1380 setUpConsole = do
1381 #ifdef mingw32_HOST_OS
1382         -- On Windows we need to set a known code page, otherwise the characters
1383         -- we read from the console will be be in some strange encoding, and
1384         -- similarly for characters we write to the console.
1385         --
1386         -- At the moment, GHCi pretends all input is Latin-1.  In the
1387         -- future we should support UTF-8, but for now we set the code pages
1388         -- to Latin-1.
1389         --
1390         -- It seems you have to set the font in the console window to
1391         -- a Unicode font in order for output to work properly,
1392         -- otherwise non-ASCII characters are mapped wrongly.  sigh.
1393         -- (see MSDN for SetConsoleOutputCP()).
1394         --
1395         setConsoleCP 28591       -- ISO Latin-1
1396         setConsoleOutputCP 28591 -- ISO Latin-1
1397 #endif
1398         return ()
1399
1400
1401 instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
1402 instrumentationBkptHandler ref_bkptTable = BkptHandler {
1403     isAutoBkptEnabled = \sess bkptLoc -> do
1404       bktpTable <- readIORef ref_bkptTable
1405       return$ isBkptEnabled bktpTable bkptLoc
1406
1407   , handleBreakpoint = doBreakpoint ref_bkptTable
1408   }
1409
1410 doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
1411 doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
1412          let (ids, hValues) = unzip values
1413              names = map idName ids
1414          ASSERT (length names == length hValues) return ()
1415          let global_ids = map globaliseAndTidy ids
1416          printScopeMsg locMsg global_ids
1417          typed_ids  <- mapM instantiateIdType global_ids
1418          hsc_env <- readIORef ref
1419          let ictxt = hsc_IC hsc_env
1420              rn_env   = ic_rn_local_env ictxt
1421              type_env = ic_type_env ictxt
1422              bound_names = map idName typed_ids
1423              new_rn_env  = extendLocalRdrEnv rn_env bound_names
1424                 -- Remove any shadowed bindings from the type_env;
1425                 -- they are inaccessible but might, I suppose, cause
1426                 -- a space leak if we leave them there
1427              shadowed = [ n | name <- bound_names,
1428                           let rdr_name = mkRdrUnqual (nameOccName name),
1429                           Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
1430              filtered_type_env = delListFromNameEnv type_env shadowed
1431              new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
1432              new_ic = ictxt { ic_rn_local_env = new_rn_env,
1433                               ic_type_env     = new_type_env }
1434          writeIORef ref (hsc_env { hsc_IC = new_ic })
1435          is_tty <- hIsTerminalDevice stdin
1436          prel_mod <- GHC.findModule s prel_name Nothing
1437          withExtendedLinkEnv (zip names hValues) $
1438            startGHCi (interactiveLoop is_tty True) GHCiState{
1439                               progname = "<interactive>",
1440                               args     = [],
1441                               prompt   = locMsg ++ "> ",
1442                               session  = s,
1443                               options  = [],
1444                               bkptTable= ref_bkptTable,
1445                               prelude  = prel_mod,
1446                               topLevel = False }
1447              `catchDyn` (
1448                  \StopChildSession -> evaluate$
1449                      throwDyn (ChildSessionStopped "You may need to reload your modules")
1450            ) `finally` do
1451              writeIORef ref hsc_env
1452              putStrLn $ "Returning to normal execution..."
1453          return b
1454   where
1455      printScopeMsg :: String -> [Id] -> IO ()
1456      printScopeMsg location ids = do
1457        unqual  <- GHC.getPrintUnqual s
1458        printForUser stdout unqual $
1459          text "Local bindings in scope:" $$
1460          nest 2 (pprWithCommas showId ids)
1461       where
1462            showId id =
1463                 ppr (idName id) <+> dcolon <+> ppr (idType id)
1464
1465 -- | Give the Id a Global Name, and tidy its type
1466      globaliseAndTidy :: Id -> Id
1467      globaliseAndTidy id
1468       = let tidied_type = tidyTopType$ idType id
1469         in setIdType (globaliseId VanillaGlobal id) tidied_type
1470
1471 -- | Instantiate the tyVars with GHC.Base.Unknown
1472      instantiateIdType :: Id -> IO Id
1473      instantiateIdType id = do
1474        instantiatedType <- instantiateTyVarsToUnknown s (idType id)
1475        return$ setIdType id instantiatedType
1476
1477