InteractiveUI.hs

{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
--
-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------

module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where

#include "HsVersions.h"

import GhciMonad
import GhciTags
import Debugger

-- The GHC interface
import qualified GHC
import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
                          Module, ModuleName, TyThing(..), Phase,
                          BreakIndex, SrcSpan, Resume, SingleStep )
import PprTyThing
import DynFlags

import Packages
#ifdef USE_READLINE
import PackageConfig
import UniqFM
#endif

import HscTypes		( implicitTyThings )
import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
import Outputable       hiding (printForUser, printForUserPartWay)
import Module           -- for ModuleEnv
import Name
import SrcLoc

-- Other random utilities
import Digraph
import BasicTypes hiding (isTopLevel)
import Panic      hiding (showException)
import Config
import StaticFlags
import Linker
import Util
import NameSet
import Maybes		( orElse )
import FastString
import Encoding

#ifndef mingw32_HOST_OS
import System.Posix hiding (getEnv)
#else
import GHC.ConsoleHandler ( flushConsole )
import qualified System.Win32
#endif

#ifdef USE_READLINE
import Control.Concurrent	( yield )	-- Used in readline loop
import System.Console.Readline as Readline
#endif

--import SystemExts

import Control.Exception as Exception
-- import Control.Concurrent

import System.FilePath
import qualified Data.ByteString.Char8 as BS
import Data.List
import Data.Maybe
import System.Cmd
import System.Environment
import System.Exit	( exitWith, ExitCode(..) )
import System.Directory
import System.IO
import System.IO.Error as IO
import Data.Char
import Data.Dynamic
import Data.Array
import Control.Monad as Monad
import Text.Printf
import Foreign
import Foreign.C
import GHC.Exts		( unsafeCoerce# )
import GHC.IOBase	( IOErrorType(InvalidArgument) )
import GHC.TopHandler

import Data.IORef	( IORef, readIORef, writeIORef )

#ifdef USE_READLINE
import System.Posix.Internals ( setNonBlockingFD )
#endif

-----------------------------------------------------------------------------

ghciWelcomeMsg :: String
ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
                 ": http://www.haskell.org/ghc/  :? for help"

cmdName :: Command -> String
cmdName (n,_,_,_) = n

macros_ref :: IORef [Command]
GLOBAL_VAR(macros_ref, [], [Command])

builtin_commands :: [Command]
builtin_commands = [
	-- Hugs users are accustomed to :e, so make sure it doesn't overlap
  ("?",		keepGoing help,			Nothing, completeNone),
  ("add",	keepGoingPaths addModule,	Just filenameWordBreakChars, completeFilename),
  ("abandon",   keepGoing abandonCmd,           Nothing, completeNone),
  ("break",     keepGoing breakCmd,             Nothing, completeIdentifier),
  ("back",      keepGoing backCmd,              Nothing, completeNone),
  ("browse",    keepGoing (browseCmd False),	Nothing, completeModule),
  ("browse!",   keepGoing (browseCmd True),	Nothing, completeModule),
  ("cd",    	keepGoing changeDirectory,	Just filenameWordBreakChars, completeFilename),
  ("check",	keepGoing checkModule,		Nothing, completeHomeModule),
  ("continue",  keepGoing continueCmd,          Nothing, completeNone),
  ("cmd",       keepGoing cmdCmd,               Nothing, completeIdentifier),
  ("ctags",	keepGoing createCTagsFileCmd, 	Just filenameWordBreakChars, completeFilename),
  ("def",	keepGoing (defineMacro False),  Nothing, completeIdentifier),
  ("def!",	keepGoing (defineMacro True),   Nothing, completeIdentifier),
  ("delete",    keepGoing deleteCmd,            Nothing, completeNone),
  ("e", 	keepGoing editFile,		Just filenameWordBreakChars, completeFilename),
  ("edit",	keepGoing editFile,		Just filenameWordBreakChars, completeFilename),
  ("etags",	keepGoing createETagsFileCmd,	Just filenameWordBreakChars, completeFilename),
  ("force",     keepGoing forceCmd,             Nothing, completeIdentifier),
  ("forward",   keepGoing forwardCmd,           Nothing, completeNone),
  ("help",	keepGoing help,			Nothing, completeNone),
  ("history",   keepGoing historyCmd,           Nothing, completeNone), 
  ("info",      keepGoing info,			Nothing, completeIdentifier),
  ("kind",	keepGoing kindOfType,		Nothing, completeIdentifier),
  ("load",	keepGoingPaths loadModule_,     Just filenameWordBreakChars, completeHomeModuleOrFile),
  ("list",	keepGoing listCmd,              Nothing, completeNone),
  ("module",	keepGoing setContext,		Nothing, completeModule),
  ("main",	keepGoing runMain,		Nothing, completeIdentifier),
  ("print",     keepGoing printCmd,             Nothing, completeIdentifier),
  ("quit",	quit,				Nothing, completeNone),
  ("reload", 	keepGoing reloadModule,  	Nothing, completeNone),
  ("run",	keepGoing runRun,		Nothing, completeIdentifier),
  ("set",	keepGoing setCmd,		Just flagWordBreakChars, completeSetOptions),
  ("show",	keepGoing showCmd,		Nothing, completeNone),
  ("sprint",    keepGoing sprintCmd,            Nothing, completeIdentifier),
  ("step",      keepGoing stepCmd,              Nothing, completeIdentifier), 
  ("steplocal", keepGoing stepLocalCmd,         Nothing, completeIdentifier), 
  ("stepmodule",keepGoing stepModuleCmd,        Nothing, completeIdentifier), 
  ("type",	keepGoing typeOfExpr,		Nothing, completeIdentifier),
  ("trace",     keepGoing traceCmd,             Nothing, completeIdentifier), 
  ("undef",     keepGoing undefineMacro,	Nothing, completeMacro),
  ("unset",	keepGoing unsetOptions,		Just flagWordBreakChars,  completeSetOptions)
  ]


-- We initialize readline (in the interactiveUI function) to use 
-- word_break_chars as the default set of completion word break characters.
-- This can be overridden for a particular command (for example, filename
-- expansion shouldn't consider '/' to be a word break) by setting the third
-- entry in the Command tuple above.
-- 
-- NOTE: in order for us to override the default correctly, any custom entry
-- must be a SUBSET of word_break_chars.
#ifdef USE_READLINE
word_break_chars :: String
word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
                       specials = "(),;[]`{}"
                       spaces = " \t\n"
                   in spaces ++ specials ++ symbols
#endif

flagWordBreakChars, filenameWordBreakChars :: String
flagWordBreakChars = " \t\n"
filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults


keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False

keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
keepGoingPaths a str
 = do case toArgs str of
          Left err -> io (hPutStrLn stderr err)
          Right args -> a args
      return False

shortHelpText :: String
shortHelpText = "use :? for help.\n"

helpText :: String
helpText =
 " Commands available from the prompt:\n" ++
 "\n" ++
 "   <statement>                 evaluate/run <statement>\n" ++
 "   :                           repeat last command\n" ++
 "   :{\\n ..lines.. \\n:}\\n       multiline command\n" ++
 "   :add <filename> ...         add module(s) to the current target set\n" ++
 "   :browse[!] [[*]<mod>]       display the names defined by module <mod>\n" ++
 "                               (!: more details; *: all top-level names)\n" ++
 "   :cd <dir>                   change directory to <dir>\n" ++
 "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" ++
 "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
 "   :def <cmd> <expr>           define a command :<cmd>\n" ++
 "   :edit <file>                edit file\n" ++
 "   :edit                       edit last module\n" ++
 "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
 "   :help, :?                   display this list of commands\n" ++
 "   :info [<name> ...]          display information about the given names\n" ++
 "   :kind <type>                show the kind of <type>\n" ++
 "   :load <filename> ...        load module(s) and their dependents\n" ++
 "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
 "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
 "   :quit                       exit GHCi\n" ++
 "   :reload                     reload the current module set\n" ++
 "   :run function [<arguments> ...] run the function with the given arguments\n" ++
 "   :type <expr>                show the type of <expr>\n" ++
 "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
 "   :!<command>                 run the shell command <command>\n" ++
 "\n" ++
 " -- Commands for debugging:\n" ++
 "\n" ++
 "   :abandon                    at a breakpoint, abandon current computation\n" ++
 "   :back                       go back in the history (after :trace)\n" ++
 "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
 "   :break <name>               set a breakpoint on the specified function\n" ++
 "   :continue                   resume after a breakpoint\n" ++
 "   :delete <number>            delete the specified breakpoint\n" ++
 "   :delete *                   delete all breakpoints\n" ++
 "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
 "   :forward                    go forward in the history (after :back)\n" ++
 "   :history [<n>]              after :trace, show the execution history\n" ++
 "   :print [<name> ...]         prints a value without forcing its computation\n" ++
 "   :sprint [<name> ...]        simplifed version of :print\n" ++
 "   :step                       single-step after stopping at a breakpoint\n"++
 "   :step <expr>                single-step into <expr>\n"++
 "   :steplocal                  single-step within the current top-level binding\n"++
 "   :stepmodule                 single-step restricted to the current module\n"++
 "   :trace                      trace after stopping at a breakpoint\n"++
 "   :trace <expr>               evaluate <expr> with tracing on (see :history)\n"++

 "\n" ++
 " -- Commands for changing settings:\n" ++
 "\n" ++
 "   :set <option> ...           set options\n" ++
 "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
 "   :set prog <progname>        set the value returned by System.getProgName\n" ++
 "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
 "   :set editor <cmd>           set the command used for :edit\n" ++
 "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
 "   :unset <option> ...         unset options\n" ++
 "\n" ++
 "  Options for ':set' and ':unset':\n" ++
 "\n" ++
 "    +r            revert top-level expressions after each evaluation\n" ++
 "    +s            print timing/memory stats after each evaluation\n" ++
 "    +t            print type after evaluation\n" ++
 "    -<flags>      most GHC command line flags can also be set here\n" ++
 "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
 "                    for GHCi-specific flags, see User's Guide,\n"++
 "                    Flag reference, Interactive-mode options\n" ++
 "\n" ++
 " -- Commands for displaying information:\n" ++
 "\n" ++
 "   :show bindings              show the current bindings made at the prompt\n" ++
 "   :show breaks                show the active breakpoints\n" ++
 "   :show context               show the breakpoint context\n" ++
 "   :show modules               show the currently loaded modules\n" ++
 "   :show packages              show the currently active package flags\n" ++
 "   :show languages             show the currently active language flags\n" ++
 "   :show <setting>             show value of <setting>, which is one of\n" ++
 "                                  [args, prog, prompt, editor, stop]\n" ++
 "\n" 

findEditor :: IO String
findEditor = do
  getEnv "EDITOR" 
    `IO.catch` \_ -> do
#if mingw32_HOST_OS
        win <- System.Win32.getWindowsDirectory
        return (win </> "notepad.exe")
#else
        return ""
#endif

interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String]
              -> IO ()
interactiveUI session srcs maybe_exprs = do
   -- HACK! If we happen to get into an infinite loop (eg the user
   -- types 'let x=x in x' at the prompt), then the thread will block
   -- on a blackhole, and become unreachable during GC.  The GC will
   -- detect that it is unreachable and send it the NonTermination
   -- exception.  However, since the thread is unreachable, everything
   -- it refers to might be finalized, including the standard Handles.
   -- This sounds like a bug, but we don't have a good solution right
   -- now.
   newStablePtr stdin
   newStablePtr stdout
   newStablePtr stderr

    -- Initialise buffering for the *interpreted* I/O system
   initInterpBuffering session

   when (isNothing maybe_exprs) $ do
        -- Only for GHCi (not runghc and ghc -e):

        -- Turn buffering off for the compiled program's stdout/stderr
        turnOffBuffering
        -- Turn buffering off for GHCi's stdout
        hFlush stdout
        hSetBuffering stdout NoBuffering
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
        hSetBuffering stdin NoBuffering

#ifdef USE_READLINE
        is_tty <- hIsTerminalDevice stdin
        when is_tty $ do
            Readline.initialize

            withGhcAppData
                 (\dir -> Readline.readHistory (dir </> "ghci_history"))
                 (return True)
            
            Readline.setAttemptedCompletionFunction (Just completeWord)
            --Readline.parseAndBind "set show-all-if-ambiguous 1"

            Readline.setBasicWordBreakCharacters word_break_chars
            Readline.setCompleterWordBreakCharacters word_break_chars
            Readline.setCompletionAppendCharacter Nothing
#endif

   -- initial context is just the Prelude
   prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") 
                                      (Just basePackageId)
   GHC.setContext session [] [prel_mod]

   default_editor <- findEditor

   startGHCi (runGHCi srcs maybe_exprs)
        GHCiState{ progname = "<interactive>",
                   args = [],
                   prompt = "%s> ",
                   stop = "",
                   editor = default_editor,
                   session = session,
                   options = [],
                   prelude = prel_mod,
                   break_ctr = 0,
                   breaks = [],
                   tickarrays = emptyModuleEnv,
                   last_command = Nothing,
                   cmdqueue = [],
                   remembered_ctx = []
                 }

#ifdef USE_READLINE
   Readline.stifleHistory 100
   withGhcAppData (\dir -> Readline.writeHistory (dir </> "ghci_history"))
                  (return True)
   Readline.resetTerminal Nothing
#endif

   return ()

withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
withGhcAppData right left = do
   either_dir <- IO.try (getAppUserDataDirectory "ghc")
   case either_dir of
      Right dir -> right dir
      _ -> left


runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
runGHCi paths maybe_exprs = do
  let 
   read_dot_files = not opt_IgnoreDotGhci

   current_dir = return (Just ".ghci")

   app_user_dir = io $ withGhcAppData 
                    (\dir -> return (Just (dir </> "ghci.conf")))
                    (return Nothing)

   home_dir = do
    either_dir <- io $ IO.try (getEnv "HOME")
    case either_dir of
      Right home -> return (Just (home </> ".ghci"))
      _ -> return Nothing

   sourceConfigFile :: FilePath -> GHCi ()
   sourceConfigFile file = do
     exists <- io $ doesFileExist file
     when exists $ do
       dir_ok  <- io $ checkPerms (getDirectory file)
       file_ok <- io $ checkPerms file
       when (dir_ok && file_ok) $ do
         either_hdl <- io $ IO.try (openFile file ReadMode)
         case either_hdl of
           Left _e   -> return ()
           Right hdl -> runCommands (fileLoop hdl False False)
     where
      getDirectory f = case takeDirectory f of "" -> "."; d -> d

  when (read_dot_files) $ do
    cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
    cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
    mapM_ sourceConfigFile (nub cfgs)
        -- nub, because we don't want to read .ghci twice if the
        -- CWD is $HOME.

  -- Perform a :load for files given on the GHCi command line
  -- When in -e mode, if the load fails then we want to stop
  -- immediately rather than going on to evaluate the expression.
  when (not (null paths)) $ do
     ok <- ghciHandle (\e -> do showException e; return Failed) $
                loadModule paths
     when (isJust maybe_exprs && failed ok) $
        io (exitWith (ExitFailure 1))

  -- if verbosity is greater than 0, or we are connected to a
  -- terminal, display the prompt in the interactive loop.
  is_tty <- io (hIsTerminalDevice stdin)
  dflags <- getDynFlags
  let show_prompt = verbosity dflags > 0 || is_tty

  case maybe_exprs of
        Nothing ->
          do
#if defined(mingw32_HOST_OS)
            -- The win32 Console API mutates the first character of
            -- type-ahead when reading from it in a non-buffered manner. Work
            -- around this by flushing the input buffer of type-ahead characters,
            -- but only if stdin is available.
            flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
            case flushed of
             Left err | isDoesNotExistError err -> return ()
                      | otherwise -> io (ioError err)
             Right () -> return ()
#endif
            -- enter the interactive loop
            interactiveLoop is_tty show_prompt
        Just exprs -> do
            -- just evaluate the expression we were given
            enqueueCommands exprs
            let handle e = do st <- getGHCiState
                                   -- Jump through some hoops to get the
                                   -- current progname in the exception text:
                                   -- <progname>: <exception>
                              io $ withProgName (progname st)
                                   -- The "fast exit" part just calls exit()
                                   -- directly instead of doing an orderly
                                   -- runtime shutdown, otherwise the main
                                   -- GHCi thread will complain about being
                                   -- interrupted.
                                 $ topHandlerFastExit e
            runCommands' handle (return Nothing)

  -- and finally, exit
  io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."

interactiveLoop :: Bool -> Bool -> GHCi ()
interactiveLoop is_tty show_prompt =
  -- Ignore ^C exceptions caught here
  ghciHandleDyn (\e -> case e of 
			Interrupted -> do
#if defined(mingw32_HOST_OS)
				io (putStrLn "")
#endif
				interactiveLoop is_tty show_prompt
			_other      -> return ()) $ 

  ghciUnblock $ do -- unblock necessary if we recursed from the 
		   -- exception handler above.

  -- read commands from stdin
#ifdef USE_READLINE
  if (is_tty) 
	then runCommands readlineLoop
	else runCommands (fileLoop stdin show_prompt is_tty)
#else
  runCommands (fileLoop stdin show_prompt is_tty)
#endif


-- NOTE: We only read .ghci files if they are owned by the current user,
-- and aren't world writable.  Otherwise, we could be accidentally 
-- running code planted by a malicious third party.

-- Furthermore, We only read ./.ghci if . is owned by the current user
-- and isn't writable by anyone else.  I think this is sufficient: we
-- don't need to check .. and ../.. etc. because "."  always refers to
-- the same directory while a process is running.

checkPerms :: String -> IO Bool
#ifdef mingw32_HOST_OS
checkPerms _ =
  return True
#else
checkPerms name =
  Util.handle (\_ -> return False) $ do
     st <- getFileStatus name
     me <- getRealUserID
     if fileOwner st /= me then do
   	putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
   	return False
      else do
   	let mode =  fileMode st
   	if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
   	   || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) 
   	   then do
   	       putStrLn $ "*** WARNING: " ++ name ++ 
   			  " is writable by someone else, IGNORING!"
   	       return False
   	  else return True
#endif

fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
fileLoop hdl show_prompt is_tty = do
   when show_prompt $ do
        prompt <- mkPrompt
        (io (putStr prompt))
   l <- io (IO.try (hGetLine hdl))
   case l of
        Left e | isEOFError e              -> return Nothing
               | InvalidArgument <- etype  -> return Nothing
               | otherwise                 -> io (ioError e)
                where etype = ioeGetErrorType e
                -- treat InvalidArgument in the same way as EOF:
                -- this can happen if the user closed stdin, or
                -- perhaps did getContents which closes stdin at
                -- EOF.
        Right l -> do
                   str <- io $ consoleInputToUnicode is_tty l
                   return (Just str)

#ifdef mingw32_HOST_OS
-- Convert the console input into Unicode according to the current code page.
-- The Windows console stores Unicode characters directly, so this is a
-- rather roundabout way of doing things... oh well.
-- See #782, #1483, #1649
consoleInputToUnicode :: Bool -> String -> IO String
consoleInputToUnicode is_tty str
  | is_tty = do
    cp <- System.Win32.getConsoleCP
    System.Win32.stringToUnicode cp str
  | otherwise =
    decodeStringAsUTF8 str
#else
-- for Unix, assume the input is in UTF-8 and decode it to a Unicode String. 
-- See #782.
consoleInputToUnicode :: Bool -> String -> IO String
consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
#endif

decodeStringAsUTF8 :: String -> IO String
decodeStringAsUTF8 str =
  withCStringLen str $ \(cstr,len) -> 
    utf8DecodeString (castPtr cstr :: Ptr Word8) len

mkPrompt :: GHCi String
mkPrompt = do
  session <- getSession
  (toplevs,exports) <- io (GHC.getContext session)
  resumes <- io $ GHC.getResumeContext session
  -- st <- getGHCiState

  context_bit <-
        case resumes of
            [] -> return empty
            r:_ -> do
                let ix = GHC.resumeHistoryIx r
                if ix == 0
                   then return (brackets (ppr (GHC.resumeSpan r)) <> space)
                   else do
                        let hist = GHC.resumeHistory r !! (ix-1)
                        span <- io$ GHC.getHistorySpan session hist
                        return (brackets (ppr (negate ix) <> char ':' 
                                          <+> ppr span) <> space)
  let
        dots | _:rs <- resumes, not (null rs) = text "... "
             | otherwise = empty

        

        modules_bit = 
       -- ToDo: maybe...
       --  let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
       --  hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
       --  hsep (map (\m -> char '!'  <> ppr (GHC.moduleName m)) bexports) <+>
             hsep (map (\m -> char '*'  <> ppr (GHC.moduleName m)) toplevs) <+>
             hsep (map (ppr . GHC.moduleName) exports)

        deflt_prompt = dots <> context_bit <> modules_bit

        f ('%':'s':xs) = deflt_prompt <> f xs
        f ('%':'%':xs) = char '%' <> f xs
        f (x:xs) = char x <> f xs
        f [] = empty
   --
  st <- getGHCiState
  return (showSDoc (f (prompt st)))


#ifdef USE_READLINE
readlineLoop :: GHCi (Maybe String)
readlineLoop = do
   io yield
   saveSession -- for use by completion
   prompt <- mkPrompt
   l <- io (readline prompt `finally` setNonBlockingFD 0)
                -- readline sometimes puts stdin into blocking mode,
                -- so we need to put it back for the IO library
   splatSavedSession
   case l of
        Nothing -> return Nothing
        Just "" -> return (Just "") -- Don't put empty lines in the history
        Just l  -> do
                   io (addHistory l)
                   str <- io $ consoleInputToUnicode True l
                   return (Just str)
#endif

queryQueue :: GHCi (Maybe String)
queryQueue = do
  st <- getGHCiState
  case cmdqueue st of
    []   -> return Nothing
    c:cs -> do setGHCiState st{ cmdqueue = cs }
               return (Just c)

runCommands :: GHCi (Maybe String) -> GHCi ()
runCommands = runCommands' handler

runCommands' :: (Exception -> GHCi Bool) -- Exception handler
             -> GHCi (Maybe String) -> GHCi ()
runCommands' eh getCmd = do
  mb_cmd <- noSpace queryQueue
  mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
  case mb_cmd of 
    Nothing -> return ()
    Just c  -> do
      b <- ghciHandle eh (doCommand c)
      if b then return () else runCommands' eh getCmd
  where
    noSpace q = q >>= maybe (return Nothing)
                            (\c->case removeSpaces c of 
                                   ""   -> noSpace q
                                   ":{" -> multiLineCmd q
                                   c    -> return (Just c) )
    multiLineCmd q = do
      st <- getGHCiState
      let p = prompt st
      setGHCiState st{ prompt = "%s| " }
      mb_cmd <- collectCommand q ""
      getGHCiState >>= \st->setGHCiState st{ prompt = p }
      return mb_cmd
    -- we can't use removeSpaces for the sublines here, so 
    -- multiline commands are somewhat more brittle against
    -- fileformat errors (such as \r in dos input on unix), 
    -- we get rid of any extra spaces for the ":}" test; 
    -- we also avoid silent failure if ":}" is not found;
    -- and since there is no (?) valid occurrence of \r (as 
    -- opposed to its String representation, "\r") inside a
    -- ghci command, we replace any such with ' ' (argh:-(
    collectCommand q c = q >>= 
      maybe (io (ioError collectError))
            (\l->if removeSpaces l == ":}" 
                 then return (Just $ removeSpaces c) 
                 else collectCommand q (c++map normSpace l))
      where normSpace '\r' = ' '
            normSpace   c  = c
    -- QUESTION: is userError the one to use here?
    collectError = userError "unterminated multiline command :{ .. :}"
    doCommand (':' : cmd) = specialCommand cmd
    doCommand stmt        = do timeIt $ runStmt stmt GHC.RunToCompletion
                               return False

enqueueCommands :: [String] -> GHCi ()
enqueueCommands cmds = do
  st <- getGHCiState
  setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }


runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
 | null (filter (not.isSpace) stmt) = return False
 | ["import", mod] <- words stmt    = keepGoing setContext ('+':mod)
 | otherwise
 = do st <- getGHCiState
      session <- getSession
      result <- io $ withProgName (progname st) $ withArgs (args st) $
	     	     GHC.runStmt session stmt step
      afterRunStmt (const True) result


--afterRunStmt :: GHC.RunResult -> GHCi Bool
                                 -- False <=> the statement failed to compile
afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
afterRunStmt _ (GHC.RunException e) = throw e
afterRunStmt step_here run_result = do
  session     <- getSession
  resumes <- io $ GHC.getResumeContext session
  case run_result of
     GHC.RunOk names -> do
        show_types <- isOptionSet ShowType
        when show_types $ printTypeOfNames session names
     GHC.RunBreak _ names mb_info 
         | isNothing  mb_info || 
           step_here (GHC.resumeSpan $ head resumes) -> do
               printForUser $ ptext SLIT("Stopped at") <+> 
                       ppr (GHC.resumeSpan $ head resumes)
--               printTypeOfNames session names
               let namesSorted = sortBy compareNames names
               tythings <- catMaybes `liftM` 
                              io (mapM (GHC.lookupName session) namesSorted)
               docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
               printForUserPartWay docs
               maybe (return ()) runBreakCmd mb_info
               -- run the command set with ":set stop <cmd>"
               st <- getGHCiState
               enqueueCommands [stop st]
               return ()
         | otherwise -> io(GHC.resume session GHC.SingleStep) >>= 
                        afterRunStmt step_here >> return ()
     _ -> return ()

  flushInterpBuffers
  io installSignalHandlers
  b <- isOptionSet RevertCAFs
  io (when b revertCAFs)

  return (case run_result of GHC.RunOk _ -> True; _ -> False)

runBreakCmd :: GHC.BreakInfo -> GHCi ()
runBreakCmd info = do
  let mod = GHC.breakInfo_module info
      nm  = GHC.breakInfo_number info
  st <- getGHCiState
  case  [ loc | (_,loc) <- breaks st,
                breakModule loc == mod, breakTick loc == nm ] of
        []  -> return ()
        loc:_ | null cmd  -> return ()
              | otherwise -> do enqueueCommands [cmd]; return ()
              where cmd = onBreakCmd loc

printTypeOfNames :: Session -> [Name] -> GHCi ()
printTypeOfNames session names
 = mapM_ (printTypeOfName session) $ sortBy compareNames names

compareNames :: Name -> Name -> Ordering
n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
    where compareWith n = (getOccString n, getSrcSpan n)

printTypeOfName :: Session -> Name -> GHCi ()
printTypeOfName session n
   = do maybe_tything <- io (GHC.lookupName session n)
        case maybe_tything of
            Nothing    -> return ()
            Just thing -> printTyThing thing


data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand

specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
specialCommand str = do
  let (cmd,rest) = break isSpace str
  maybe_cmd <- lookupCommand cmd
  case maybe_cmd of
    GotCommand (_,f,_,_) -> f (dropWhile isSpace rest)
    BadCommand ->
      do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
                           ++ shortHelpText)
         return False
    NoLastCommand ->
      do io $ hPutStr stdout ("there is no last command to perform\n"
                           ++ shortHelpText)
         return False

lookupCommand :: String -> GHCi (MaybeCommand)
lookupCommand "" = do
  st <- getGHCiState
  case last_command st of
      Just c -> return $ GotCommand c
      Nothing -> return NoLastCommand
lookupCommand str = do
  mc <- io $ lookupCommand' str
  st <- getGHCiState
  setGHCiState st{ last_command = mc }
  return $ case mc of
           Just c -> GotCommand c
           Nothing -> BadCommand

lookupCommand' :: String -> IO (Maybe Command)
lookupCommand' str = do
  macros <- readIORef macros_ref
  let cmds = builtin_commands ++ macros
  -- look for exact match first, then the first prefix match
  return $ case [ c | c <- cmds, str == cmdName c ] of
           c:_ -> Just c
           [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
                 [] -> Nothing
                 c:_ -> Just c

getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
  session <- getSession
  resumes <- io $ GHC.getResumeContext session
  case resumes of
    [] -> return Nothing
    (r:_) -> do
        let ix = GHC.resumeHistoryIx r
        if ix == 0
           then return (Just (GHC.resumeSpan r))
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
                span <- io $ GHC.getHistorySpan session hist
                return (Just span)

getCurrentBreakModule :: GHCi (Maybe Module)
getCurrentBreakModule = do
  session <- getSession
  resumes <- io $ GHC.getResumeContext session
  case resumes of
    [] -> return Nothing
    (r:_) -> do
        let ix = GHC.resumeHistoryIx r
        if ix == 0
           then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
           else do
                let hist = GHC.resumeHistory r !! (ix-1)
                return $ Just $ GHC.getHistoryModule  hist

-----------------------------------------------------------------------------
-- Commands

noArgs :: GHCi () -> String -> GHCi ()
noArgs m "" = m
noArgs _ _  = io $ putStrLn "This command takes no arguments"

help :: String -> GHCi ()
help _ = io (putStr helpText)

info :: String -> GHCi ()
info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
info s  = do { let names = words s
	     ; session <- getSession
	     ; dflags <- getDynFlags
	     ; let pefas = dopt Opt_PrintExplicitForalls dflags
	     ; mapM_ (infoThing pefas session) names }
  where
    infoThing pefas session str = io $ do
	names     <- GHC.parseName session str
	mb_stuffs <- mapM (GHC.getInfo session) names
	let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
	unqual <- GHC.getPrintUnqual session
	putStrLn (showSDocForUser unqual $
     		   vcat (intersperse (text "") $
		         map (pprInfo pefas) filtered))

  -- Filter out names whose parent is also there Good
  -- example is '[]', which is both a type and data
  -- constructor in the same type
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren get_thing xs 
  = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
  where
    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]

pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts)
  =  pprTyThingInContextLoc pefas thing
  $$ show_fixity fixity
  $$ vcat (map GHC.pprInstance insts)
  where
    show_fixity fix 
	| fix == GHC.defaultFixity = empty
	| otherwise		   = ppr fix <+> ppr (GHC.getName thing)

runMain :: String -> GHCi ()
runMain s = case toArgs s of
            Left err   -> io (hPutStrLn stderr err)
            Right args ->
                do dflags <- getDynFlags
                   case mainFunIs dflags of
                       Nothing -> doWithArgs args "main"
                       Just f  -> doWithArgs args f

runRun :: String -> GHCi ()
runRun s = case toCmdArgs s of
           Left err          -> io (hPutStrLn stderr err)
           Right (cmd, args) -> doWithArgs args cmd

doWithArgs :: [String] -> String -> GHCi ()
doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
                                       show args ++ " (" ++ cmd ++ ")"]

addModule :: [FilePath] -> GHCi ()
addModule files = do
  io (revertCAFs)			-- always revert CAFs on load/add.
  files <- mapM expandPath files
  targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
  session <- getSession
  io (mapM_ (GHC.addTarget session) targets)
  prev_context <- io $ GHC.getContext session
  ok <- io (GHC.load session LoadAllTargets)
  afterLoad ok session False prev_context

changeDirectory :: String -> GHCi ()
changeDirectory "" = do
  -- :cd on its own changes to the user's home directory
  either_dir <- io (IO.try getHomeDirectory)
  case either_dir of
     Left _e -> return ()
     Right dir -> changeDirectory dir
changeDirectory dir = do
  session <- getSession
  graph <- io (GHC.getModuleGraph session)
  when (not (null graph)) $
	io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
  prev_context <- io $ GHC.getContext session
  io (GHC.setTargets session [])
  io (GHC.load session LoadAllTargets)
  setContextAfterLoad session prev_context False []
  io (GHC.workingDirectoryChanged session)
  dir <- expandPath dir
  io (setCurrentDirectory dir)

editFile :: String -> GHCi ()
editFile str =
  do file <- if null str then chooseEditFile else return str
     st <- getGHCiState
     let cmd = editor st
     when (null cmd) 
       $ throwDyn (CmdLineError "editor not set, use :set editor")
     io $ system (cmd ++ ' ':file)
     return ()

-- The user didn't specify a file so we pick one for them.
-- Our strategy is to pick the first module that failed to load,
-- or otherwise the first target.
--
-- XXX: Can we figure out what happened if the depndecy analysis fails
--      (e.g., because the porgrammeer mistyped the name of a module)?
-- XXX: Can we figure out the location of an error to pass to the editor?
-- XXX: if we could figure out the list of errors that occured during the
-- last load/reaload, then we could start the editor focused on the first
-- of those.
chooseEditFile :: GHCi String
chooseEditFile =
  do session <- getSession
     let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x

     graph <- io (GHC.getModuleGraph session)
     failed_graph <- filterM hasFailed graph
     let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
         pick xs  = case xs of
                      x : _ -> GHC.ml_hs_file (GHC.ms_location x)
                      _     -> Nothing

     case pick (order failed_graph) of
       Just file -> return file
       Nothing   -> 
         do targets <- io (GHC.getTargets session)
            case msum (map fromTarget targets) of
              Just file -> return file
              Nothing   -> throwDyn (CmdLineError "No files to edit.")
          
  where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
        fromTarget _ = Nothing -- when would we get a module target?

defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
defineMacro overwrite s = do
  let (macro_name, definition) = break isSpace s
  macros <- io (readIORef macros_ref)
  let defined = map cmdName macros
  if (null macro_name) 
	then if null defined
                then io $ putStrLn "no macros defined"
                else io $ putStr ("the following macros are defined:\n" ++
                                  unlines defined)
	else do
  if (not overwrite && macro_name `elem` defined)
	then throwDyn (CmdLineError 
		("macro '" ++ macro_name ++ "' is already defined"))
	else do

  let