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