diff --git a/GhciHaskeline/Main.hs b/GhciHaskeline/Main.hs new file mode 100644 --- /dev/null +++ b/GhciHaskeline/Main.hs @@ -0,0 +1,608 @@ +{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver program +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module GhciHaskeline.Main (main) where + +-- The official GHC API +import qualified GHC +import GHC ( DynFlags(..), HscTarget(..), + GhcMode(..), GhcLink(..), + LoadHowMuch(..), dopt, DynFlag(..) ) +import CmdLineParser + +-- Implementations of the various modes (--show-iface, mkdependHS. etc.) +import LoadIface ( showIface ) +import HscMain ( newHscEnv ) +import DriverPipeline ( oneShot, compileFile ) +import DriverMkDepend ( doMkDependHS ) +#ifdef GHCI +import GhciHaskeline.InteractiveUI ( interactiveUI, ghciWelcomeMsg ) +#endif + +-- Various other random stuff that we need +import Config +import HscTypes +import Packages ( dumpPackages ) +import DriverPhases ( Phase(..), isSourceFilename, anyHsc, + startPhase, isHaskellSrcFilename ) +import BasicTypes ( failed ) +import StaticFlags +import StaticFlagParser +import DynFlags +import ErrUtils +import FastString +import Outputable +import SrcLoc +import Util +import Panic +import MonadUtils ( liftIO ) + +-- Standard Haskell libraries +import System.IO +import System.Environment +import System.Exit +import System.FilePath +import Control.Monad +import Data.List +import Data.Maybe + +import GHC.Paths + +----------------------------------------------------------------------------- +-- ToDo: + +-- time commands when run with -v +-- user ways +-- Win32 support: proper signal handling +-- reading the package configuration file is too slow +-- -K + +----------------------------------------------------------------------------- +-- GHC's command-line interface + +main :: IO () +main = + + GHC.defaultErrorHandler defaultDynFlags $ do + -- 1. extract the -B flag from the args + argv0 <- getArgs + + let + (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 + mbMinusB | null minusB_args = Just libdir + | otherwise = Just (drop 2 (last minusB_args)) + + let argv1' = map (mkGeneralLocated "on the commandline") ("--interactive" : argv1) + (argv2, staticFlagWarnings) <- parseStaticFlags argv1' + + -- 2. Parse the "mode" flags (--make, --interactive etc.) + (m_uber_mode, cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 + + -- If all we want to do is to show the version number then do it + -- now, before we start a GHC session etc. + -- If we do it later then bootstrapping gets confused as it tries + -- to find out what version of GHC it's using before package.conf + -- exists, so starting the session fails. + case m_uber_mode of + -- ShowUsage currently has to be handled specially, as it needs to + -- actually start up GHC so that it can find the usage.txt files + -- in the libdir. It would be nice to embed the text in the + -- executable so that we don't have to do that, and things are more + -- uniform here. + Just ShowUsage -> return () + Just um -> + do case um of + ShowInfo -> showInfo + ShowSupportedLanguages -> showSupportedLanguages + ShowVersion -> showVersion + ShowNumVersion -> putStrLn cProjectVersion + exitWith ExitSuccess + Nothing -> return () + + -- start our GHC session + GHC.runGhc mbMinusB $ do + + dflags0 <- GHC.getSessionDynFlags + + -- set the default GhcMode, HscTarget and GhcLink. The HscTarget + -- can be further adjusted on a module by module basis, using only + -- the -fvia-C and -fasm flags. If the default HscTarget is not + -- HscC or HscAsm, -fvia-C and -fasm have no effect. + let dflt_target = hscTarget dflags0 + (mode, lang, link) + = case cli_mode of + DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) + DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) + DoMake -> (CompManager, dflt_target, LinkBinary) + DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) + _ -> (OneShot, dflt_target, LinkBinary) + + let dflags1 = dflags0{ ghcMode = mode, + hscTarget = lang, + ghcLink = link, + -- leave out hscOutName for now + hscOutName = panic "Main.main:hscOutName not set", + verbosity = case cli_mode of + DoEval _ -> 0 + _other -> 1 + } + + -- turn on -fimplicit-import-qualified for GHCi now, so that it + -- can be overriden from the command-line + dflags1a | DoInteractive <- cli_mode = imp_qual_enabled + | DoEval _ <- cli_mode = imp_qual_enabled + | otherwise = dflags1 + where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified + + -- The rest of the arguments are "dynamic" + -- Leftover ones are presumably files + (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a argv3 + + -- As noted earlier, currently we hvae to handle ShowUsage down here + case m_uber_mode of + Just ShowUsage -> liftIO $ showGhcUsage dflags2 cli_mode + _ -> return () + + let flagWarnings = staticFlagWarnings + ++ modeFlagWarnings + ++ dynamicFlagWarnings + liftIO $ handleFlagWarnings dflags2 flagWarnings + + -- make sure we clean up after ourselves + GHC.defaultCleanupHandler dflags2 $ do + + liftIO $ showBanner cli_mode dflags2 + + -- we've finished manipulating the DynFlags, update the session + GHC.setSessionDynFlags dflags2 + dflags3 <- GHC.getSessionDynFlags + hsc_env <- GHC.getSession + + let + -- To simplify the handling of filepaths, we normalise all filepaths right + -- away - e.g., for win32 platforms, backslashes are converted + -- into forward slashes. + normal_fileish_paths = map (normalise . unLoc) fileish_args + (srcs, objs) = partition_args normal_fileish_paths [] [] + + -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on + -- the command-line. + liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs) + + ---------------- Display configuration ----------- + when (verbosity dflags3 >= 4) $ + liftIO $ dumpPackages dflags3 + + when (verbosity dflags3 >= 3) $ do + liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) + + ---------------- Final sanity checking ----------- + liftIO $ checkOptions cli_mode dflags3 srcs objs + + ---------------- Do the business ----------- + handleSourceError (\e -> do + GHC.printExceptionAndWarnings e + liftIO $ exitWith (ExitFailure 1)) $ do + case cli_mode of + PrintLibdir -> liftIO $ putStrLn (topDir dflags3) + ShowInterface f -> liftIO $ doShowIface dflags3 f + DoMake -> doMake srcs + DoMkDependHS -> doMkDependHS (map fst srcs) + StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings + DoInteractive -> interactiveUI srcs Nothing + DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs + + liftIO $ dumpFinalStats dflags3 + liftIO $ exitWith ExitSuccess + +#ifndef GHCI +interactiveUI :: b -> c -> Ghc () +interactiveUI _ _ = + ghcError (CmdLineError "not built for interactive use") +#endif + +-- ----------------------------------------------------------------------------- +-- Splitting arguments into source files and object files. This is where we +-- interpret the -x option, and attach a (Maybe Phase) to each source +-- file indicating the phase specified by the -x option in force, if any. + +partition_args :: [String] -> [(String, Maybe Phase)] -> [String] + -> ([(String, Maybe Phase)], [String]) +partition_args [] srcs objs = (reverse srcs, reverse objs) +partition_args ("-x":suff:args) srcs objs + | "none" <- suff = partition_args args srcs objs + | StopLn <- phase = partition_args args srcs (slurp ++ objs) + | otherwise = partition_args rest (these_srcs ++ srcs) objs + where phase = startPhase suff + (slurp,rest) = break (== "-x") args + these_srcs = zip slurp (repeat (Just phase)) +partition_args (arg:args) srcs objs + | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs + | otherwise = partition_args args srcs (arg:objs) + + {- + We split out the object files (.o, .dll) and add them + to v_Ld_inputs for use by the linker. + + The following things should be considered compilation manager inputs: + + - haskell source files (strings ending in .hs, .lhs or other + haskellish extension), + + - module names (not forgetting hierarchical module names), + + - and finally we consider everything not containing a '.' to be + a comp manager input, as shorthand for a .hs or .lhs filename. + + Everything else is considered to be a linker object, and passed + straight through to the linker. + -} +looks_like_an_input :: String -> Bool +looks_like_an_input m = isSourceFilename m + || looksLikeModuleName m + || '.' `notElem` m + +-- ----------------------------------------------------------------------------- +-- Option sanity checks + +-- | Ensure sanity of options. +-- +-- Throws 'UsageError' or 'CmdLineError' if not. +checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () + -- Final sanity checking before kicking off a compilation (pipeline). +checkOptions cli_mode dflags srcs objs = do + -- Complain about any unknown flags + let unknown_opts = [ f | (f@('-':_), _) <- srcs ] + when (notNull unknown_opts) (unknownFlagsErr unknown_opts) + + when (notNull (filter isRTSWay (wayNames dflags)) + && isInterpretiveMode cli_mode) $ + hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") + + -- -prof and --interactive are not a good combination + when (notNull (filter (not . isRTSWay) (wayNames dflags)) + && isInterpretiveMode cli_mode) $ + do ghcError (UsageError + "--interactive can't be used with -prof or -unreg.") + -- -ohi sanity check + if (isJust (outputHi dflags) && + (isCompManagerMode cli_mode || srcs `lengthExceeds` 1)) + then ghcError (UsageError "-ohi can only be used when compiling a single source file") + else do + + -- -o sanity checking + if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) + && not (isLinkMode cli_mode)) + then ghcError (UsageError "can't apply -o to multiple source files") + else do + + let not_linking = not (isLinkMode cli_mode) || isNoLink (ghcLink dflags) + + when (not_linking && not (null objs)) $ + hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs) + + -- Check that there are some input files + -- (except in the interactive case) + if null srcs && (null objs || not_linking) && needsInputsMode cli_mode + then ghcError (UsageError "no input files") + else do + + -- Verify that output files point somewhere sensible. + verifyOutputFiles dflags + + +-- Compiler output options + +-- called to verify that the output files & directories +-- point somewhere valid. +-- +-- The assumption is that the directory portion of these output +-- options will have to exist by the time 'verifyOutputFiles' +-- is invoked. +-- +verifyOutputFiles :: DynFlags -> IO () +verifyOutputFiles dflags = do + -- not -odir: we create the directory for -odir if it doesn't exist (#2278). + let ofile = outputFile dflags + when (isJust ofile) $ do + let fn = fromJust ofile + flg <- doesDirNameExist fn + when (not flg) (nonExistentDir "-o" fn) + let ohi = outputHi dflags + when (isJust ohi) $ do + let hi = fromJust ohi + flg <- doesDirNameExist hi + when (not flg) (nonExistentDir "-ohi" hi) + where + nonExistentDir flg dir = + ghcError (CmdLineError ("error: directory portion of " ++ + show dir ++ " does not exist (used with " ++ + show flg ++ " option.)")) + +----------------------------------------------------------------------------- +-- GHC modes of operation + +data UberMode + = ShowUsage -- ghc -? + | ShowVersion -- ghc -V/--version + | ShowNumVersion -- ghc --numeric-version + | ShowSupportedLanguages -- ghc --supported-languages + | ShowInfo -- ghc --info + deriving (Show) + +data CmdLineMode + = PrintLibdir -- ghc --print-libdir + | ShowInterface String -- ghc --show-iface + | DoMkDependHS -- ghc -M + | StopBefore Phase -- ghc -E | -C | -S + -- StopBefore StopLn is the default + | DoMake -- ghc --make + | DoInteractive -- ghc --interactive + | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] + deriving (Show) + +#ifdef GHCI +isInteractiveMode :: CmdLineMode -> Bool +isInteractiveMode DoInteractive = True +isInteractiveMode _ = False +#endif + +-- isInterpretiveMode: byte-code compiler involved +isInterpretiveMode :: CmdLineMode -> Bool +isInterpretiveMode DoInteractive = True +isInterpretiveMode (DoEval _) = True +isInterpretiveMode _ = False + +needsInputsMode :: CmdLineMode -> Bool +needsInputsMode DoMkDependHS = True +needsInputsMode (StopBefore _) = True +needsInputsMode DoMake = True +needsInputsMode _ = False + +-- True if we are going to attempt to link in this mode. +-- (we might not actually link, depending on the GhcLink flag) +isLinkMode :: CmdLineMode -> Bool +isLinkMode (StopBefore StopLn) = True +isLinkMode DoMake = True +isLinkMode DoInteractive = True +isLinkMode (DoEval _) = True +isLinkMode _ = False + +isCompManagerMode :: CmdLineMode -> Bool +isCompManagerMode DoMake = True +isCompManagerMode DoInteractive = True +isCompManagerMode (DoEval _) = True +isCompManagerMode _ = False + + +-- ----------------------------------------------------------------------------- +-- Parsing the mode flag + +parseModeFlags :: [Located String] + -> IO (Maybe UberMode, + CmdLineMode, + [Located String], + [Located String]) +parseModeFlags args = do + let ((leftover, errs, warns), (mUberMode, mode, _, flags')) = + runCmdLine (processArgs mode_flags args) + (Nothing, StopBefore StopLn, "", []) + when (not (null errs)) $ ghcError $ errorsToGhcException errs + return (mUberMode, mode, flags' ++ leftover, warns) + +type ModeM = CmdLineP (Maybe UberMode, CmdLineMode, String, [Located String]) + -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) + -- so we collect the new ones and return them. + +mode_flags :: [Flag ModeM] +mode_flags = + [ ------- help / version ---------------------------------------------- + Flag "?" (NoArg (setUberMode ShowUsage)) + Supported + , Flag "-help" (NoArg (setUberMode ShowUsage)) + Supported + , Flag "V" (NoArg (setUberMode ShowVersion)) + Supported + , Flag "-version" (NoArg (setUberMode ShowVersion)) + Supported + , Flag "-numeric-version" (NoArg (setUberMode ShowNumVersion)) + Supported + , Flag "-info" (NoArg (setUberMode ShowInfo)) + Supported + , Flag "-supported-languages" (NoArg (setUberMode ShowSupportedLanguages)) + Supported + , Flag "-print-libdir" (PassFlag (setMode PrintLibdir)) + Supported + + ------- interfaces ---------------------------------------------------- + , Flag "-show-iface" (HasArg (\f -> setMode (ShowInterface f) + "--show-iface")) + Supported + + ------- primary modes ------------------------------------------------ + , Flag "M" (PassFlag (setMode DoMkDependHS)) + Supported + , Flag "E" (PassFlag (setMode (StopBefore anyHsc))) + Supported + , Flag "C" (PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fvia-C")) + Supported + , Flag "S" (PassFlag (setMode (StopBefore As))) + Supported + , Flag "-make" (PassFlag (setMode DoMake)) + Supported + , Flag "-interactive" (PassFlag (setMode DoInteractive)) + Supported + , Flag "e" (HasArg (\s -> updateMode (updateDoEval s) "-e")) + Supported + + -- -fno-code says to stop after Hsc but don't generate any code. + , Flag "fno-code" (PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fno-code" + addFlag "-fforce-recomp")) + Supported + ] + +setUberMode :: UberMode -> ModeM () +setUberMode m = do + (_, cmdLineMode, flag, flags') <- getCmdLineState + putCmdLineState (Just m, cmdLineMode, flag, flags') + +setMode :: CmdLineMode -> String -> ModeM () +setMode m flag = updateMode (\_ -> m) flag + +updateDoEval :: String -> CmdLineMode -> CmdLineMode +updateDoEval expr (DoEval exprs) = DoEval (expr : exprs) +updateDoEval expr _ = DoEval [expr] + +updateMode :: (CmdLineMode -> CmdLineMode) -> String -> ModeM () +updateMode f flag = do + (m_uber_mode, old_mode, old_flag, flags') <- getCmdLineState + if null old_flag || flag == old_flag + then putCmdLineState (m_uber_mode, f old_mode, flag, flags') + else ghcError (UsageError + ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'")) + +addFlag :: String -> ModeM () +addFlag s = do + (u, m, f, flags') <- getCmdLineState + -- XXX Can we get a useful Loc? + putCmdLineState (u, m, f, mkGeneralLocated "addFlag" s : flags') + + +-- ---------------------------------------------------------------------------- +-- Run --make mode + +doMake :: [(String,Maybe Phase)] -> Ghc () +doMake [] = ghcError (UsageError "no input files") +doMake srcs = do + let (hs_srcs, non_hs_srcs) = partition haskellish srcs + + haskellish (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f + haskellish (_,Just phase) = + phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] + + hsc_env <- GHC.getSession + o_files <- mapM (\x -> do + f <- compileFile hsc_env StopLn x + GHC.printWarnings + return f) + non_hs_srcs + liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files) + + targets <- mapM (uncurry GHC.guessTarget) hs_srcs + GHC.setTargets targets + ok_flag <- GHC.load LoadAllTargets + + when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) + return () + + +-- --------------------------------------------------------------------------- +-- --show-iface mode + +doShowIface :: DynFlags -> FilePath -> IO () +doShowIface dflags file = do + hsc_env <- newHscEnv dflags + showIface hsc_env file + +-- --------------------------------------------------------------------------- +-- Various banners and verbosity output. + +showBanner :: CmdLineMode -> DynFlags -> IO () +showBanner _cli_mode dflags = do + let verb = verbosity dflags + +#ifdef GHCI + -- Show the GHCi banner + when (isInteractiveMode _cli_mode && verb >= 1) $ putStrLn ghciWelcomeMsg +#endif + + -- Display details of the configuration in verbose mode + when (verb >= 2) $ + do hPutStr stderr "Glasgow Haskell Compiler, Version " + hPutStr stderr cProjectVersion + hPutStr stderr ", for Haskell 98, stage " + hPutStr stderr cStage + hPutStr stderr " booted by GHC version " + hPutStrLn stderr cBooterVersion + +-- We print out a Read-friendly string, but a prettier one than the +-- Show instance gives us +showInfo :: IO () +showInfo = do + let sq x = " [" ++ x ++ "\n ]" + putStrLn $ sq $ concat $ intersperse "\n ," $ map show compilerInfo + exitWith ExitSuccess + +showSupportedLanguages :: IO () +showSupportedLanguages = do mapM_ putStrLn supportedLanguages + exitWith ExitSuccess + +showVersion :: IO () +showVersion = do + putStrLn (cProjectName ++ ", version " ++ cProjectVersion) + exitWith ExitSuccess + +showGhcUsage :: DynFlags -> CmdLineMode -> IO () +showGhcUsage dflags cli_mode = do + let usage_path + | DoInteractive <- cli_mode = ghciUsagePath dflags + | otherwise = ghcUsagePath dflags + usage <- readFile usage_path + dump usage + exitWith ExitSuccess + where + dump "" = return () + dump ('$':'$':s) = putStr progName >> dump s + dump (c:s) = putChar c >> dump s + +dumpFinalStats :: DynFlags -> IO () +dumpFinalStats dflags = + when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags + +dumpFastStringStats :: DynFlags -> IO () +dumpFastStringStats dflags = do + buckets <- getFastStringTable + let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets + msg = text "FastString stats:" $$ + nest 4 (vcat [text "size: " <+> int (length buckets), + text "entries: " <+> int entries, + text "longest chain: " <+> int longest, + text "z-encoded: " <+> (is_z `pcntOf` entries), + text "has z-encoding: " <+> (has_z `pcntOf` entries) + ]) + -- we usually get more "has z-encoding" than "z-encoded", because + -- when we z-encode a string it might hash to the exact same string, + -- which will is not counted as "z-encoded". Only strings whose + -- Z-encoding is different from the original string are counted in + -- the "z-encoded" total. + putMsg dflags msg + where + x `pcntOf` y = int ((x * 100) `quot` y) <> char '%' + +countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int) +countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z) +countFS entries longest is_z has_z (b:bs) = + let + len = length b + longest' = max len longest + entries' = entries + len + is_zs = length (filter isZEncoded b) + has_zs = length (filter hasZEncoding b) + in + countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs + +-- ----------------------------------------------------------------------------- +-- Util + +unknownFlagsErr :: [String] -> a +unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs)) diff --git a/GhciHaskeline612/GhciMonad.hs b/GhciHaskeline612/GhciMonad.hs new file mode 100644 --- /dev/null +++ b/GhciHaskeline612/GhciMonad.hs @@ -0,0 +1,370 @@ +{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +----------------------------------------------------------------------------- +-- +-- Monadery code used in InteractiveUI +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module GhciHaskeline612.GhciMonad where + +import qualified GHC +import Outputable hiding (printForUser, printForUserPartWay) +import qualified Outputable +import Panic hiding (showException) +import Util +import DynFlags +import HscTypes hiding (liftIO) +import SrcLoc +import Module +import ObjLink +import Linker +import StaticFlags +import qualified MonadUtils + +import Exception +-- import Data.Maybe +import Numeric +import Data.Array +-- import Data.Char +import Data.Int ( Int64 ) +import Data.IORef +-- import Data.List +import System.CPUTime +import System.Environment +import System.IO +import Control.Monad as Monad +import GHC.Exts + +import System.Console.Haskeline (CompletionFunc, InputT) +import qualified System.Console.Haskeline as Haskeline +import Control.Monad.Trans as Trans + +-- copied from HsVersions.h + +#define GLOBAL_VAR(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.global (value); + + +----------------------------------------------------------------------------- +-- GHCi monad + +type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi) + +data GHCiState = GHCiState + { + progname :: String, + args :: [String], + prompt :: String, + editor :: String, + stop :: String, + options :: [GHCiOption], + prelude :: GHC.Module, + break_ctr :: !Int, + breaks :: ![(Int, BreakLocation)], + tickarrays :: ModuleEnv TickArray, + -- tickarrays caches the TickArray for loaded modules, + -- so that we don't rebuild it each time the user sets + -- a breakpoint. + -- ":" at the GHCi prompt repeats the last command, so we + -- remember is here: + last_command :: Maybe Command, + cmdqueue :: [String], + remembered_ctx :: [(CtxtCmd, [String], [String])], + -- we remember the :module commands between :loads, so that + -- on a :reload we can replay them. See bugs #2049, + -- \#1873, #1360. Previously we tried to remember modules that + -- were supposed to be in the context but currently had errors, + -- but this was complicated. Just replaying the :module commands + -- seems to be the right thing. + ghc_e :: Bool -- True if this is 'ghc -e' (or runghc) + } + +data CtxtCmd + = SetContext + | AddModules + | RemModules + +type TickArray = Array Int [(BreakIndex,SrcSpan)] + +data GHCiOption + = ShowTiming -- show time/allocs after evaluation + | ShowType -- show the type of expressions + | RevertCAFs -- revert CAFs after every evaluation + deriving Eq + +data BreakLocation + = BreakLocation + { breakModule :: !GHC.Module + , breakLoc :: !SrcSpan + , breakTick :: {-# UNPACK #-} !Int + , onBreakCmd :: String + } + +instance Eq BreakLocation where + loc1 == loc2 = breakModule loc1 == breakModule loc2 && + breakTick loc1 == breakTick loc2 + +prettyLocations :: [(Int, BreakLocation)] -> SDoc +prettyLocations [] = text "No active breakpoints." +prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs + +instance Outputable BreakLocation where + ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> + if null (onBreakCmd loc) + then empty + else doubleQuotes (text (onBreakCmd loc)) + +recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int) +recordBreak brkLoc = do + st <- getGHCiState + let oldActiveBreaks = breaks st + -- don't store the same break point twice + case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of + (nm:_) -> return (True, nm) + [] -> do + let oldCounter = break_ctr st + newCounter = oldCounter + 1 + setGHCiState $ st { break_ctr = newCounter, + breaks = (oldCounter, brkLoc) : oldActiveBreaks + } + return (False, oldCounter) + +newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a } + +reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a +reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s + +reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a +reifyGHCi f = GHCi f' + where + -- f' :: IORef GHCiState -> Ghc a + f' gs = reifyGhc (f'' gs) + -- f'' :: IORef GHCiState -> Session -> IO a + f'' gs s = f (s, gs) + +startGHCi :: GHCi a -> GHCiState -> Ghc a +startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref + +instance Monad GHCi where + (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s + return a = GHCi $ \_ -> return a + +instance Functor GHCi where + fmap f m = m >>= return . f + +ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a +ghciHandleGhcException = handleGhcException + +getGHCiState :: GHCi GHCiState +getGHCiState = GHCi $ \r -> liftIO $ readIORef r +setGHCiState :: GHCiState -> GHCi () +setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s + +liftGhc :: Ghc a -> GHCi a +liftGhc m = GHCi $ \_ -> m + +instance MonadUtils.MonadIO GHCi where + liftIO = liftGhc . MonadUtils.liftIO + +instance Trans.MonadIO Ghc where + liftIO = MonadUtils.liftIO + +instance GhcMonad GHCi where + setSession s' = liftGhc $ setSession s' + getSession = liftGhc $ getSession + +instance GhcMonad (InputT GHCi) where + setSession = lift . setSession + getSession = lift getSession + +instance MonadUtils.MonadIO (InputT GHCi) where + liftIO = Trans.liftIO + +instance WarnLogMonad (InputT GHCi) where + setWarnings = lift . setWarnings + getWarnings = lift getWarnings + +instance ExceptionMonad GHCi where + gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) + gblock (GHCi m) = GHCi $ \r -> gblock (m r) + gunblock (GHCi m) = GHCi $ \r -> gunblock (m r) + +instance WarnLogMonad GHCi where + setWarnings warns = liftGhc $ setWarnings warns + getWarnings = liftGhc $ getWarnings + +instance MonadIO GHCi where + liftIO = io + +instance Haskeline.MonadException GHCi where + catch = gcatch + block = gblock + unblock = gunblock + +instance ExceptionMonad (InputT GHCi) where + gcatch = Haskeline.catch + gblock = Haskeline.block + gunblock = Haskeline.unblock + +-- for convenience... +getPrelude :: GHCi Module +getPrelude = getGHCiState >>= return . prelude + +getDynFlags :: GhcMonad m => m DynFlags +getDynFlags = do + GHC.getSessionDynFlags + +setDynFlags :: DynFlags -> GHCi [PackageId] +setDynFlags dflags = do + GHC.setSessionDynFlags dflags + +isOptionSet :: GHCiOption -> GHCi Bool +isOptionSet opt + = do st <- getGHCiState + return (opt `elem` options st) + +setOption :: GHCiOption -> GHCi () +setOption opt + = do st <- getGHCiState + setGHCiState (st{ options = opt : filter (/= opt) (options st) }) + +unsetOption :: GHCiOption -> GHCi () +unsetOption opt + = do st <- getGHCiState + setGHCiState (st{ options = filter (/= opt) (options st) }) + +io :: IO a -> GHCi a +io = MonadUtils.liftIO + +printForUser :: GhcMonad m => SDoc -> m () +printForUser doc = do + unqual <- GHC.getPrintUnqual + MonadUtils.liftIO $ Outputable.printForUser stdout unqual doc + +printForUserPartWay :: SDoc -> GHCi () +printForUserPartWay doc = do + unqual <- GHC.getPrintUnqual + io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc + +runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult +runStmt expr step = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e + return GHC.RunFailed) $ do + GHC.runStmt expr step + +resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult +resume canLogSpan step = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.resume canLogSpan step + +-- -------------------------------------------------------------------------- +-- timing & statistics + +timeIt :: InputT GHCi a -> InputT GHCi a +timeIt action + = do b <- lift $ isOptionSet ShowTiming + if not b + then action + else do allocs1 <- liftIO $ getAllocations + time1 <- liftIO $ getCPUTime + a <- action + allocs2 <- liftIO $ getAllocations + time2 <- liftIO $ getCPUTime + liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) + (time2 - time1) + return a + +foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 + -- defined in ghc/rts/Stats.c + +printTimes :: Integer -> Integer -> IO () +printTimes allocs psecs + = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float + secs_str = showFFloat (Just 2) secs + putStrLn (showSDoc ( + parens (text (secs_str "") <+> text "secs" <> comma <+> + text (show allocs) <+> text "bytes"))) + +----------------------------------------------------------------------------- +-- reverting CAFs + +revertCAFs :: GHCi () +revertCAFs = do + io $ rts_revertCAFs + s <- getGHCiState + when (not (ghc_e s)) $ io turnOffBuffering + -- Have to turn off buffering again, because we just + -- reverted stdout, stderr & stdin to their defaults. + +foreign import ccall "revertCAFs" rts_revertCAFs :: IO () + -- Make it "safe", just in case + +----------------------------------------------------------------------------- +-- To flush buffers for the *interpreted* computation we need +-- to refer to *its* stdout/stderr handles + +GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ()) +GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ()) +GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ()) + +-- After various attempts, I believe this is the least bad way to do +-- what we want. We know look up the address of the static stdin, +-- stdout, and stderr closures in the loaded base package, and each +-- time we need to refer to them we cast the pointer to a Handle. +-- This avoids any problems with the CAF having been reverted, because +-- we'll always get the current value. +-- +-- The previous attempt that didn't work was to compile an expression +-- like "hSetBuffering stdout NoBuffering" into an expression of type +-- IO () and run this expression each time we needed it, but the +-- problem is that evaluating the expression might cache the contents +-- of the Handle rather than referring to it from its static address +-- each time. There's no safe workaround for this. + +initInterpBuffering :: Ghc () +initInterpBuffering = do -- make sure these are linked + dflags <- GHC.getSessionDynFlags + liftIO $ do + initDynLinker dflags + + -- ToDo: we should really look up these names properly, but + -- it's a fiddle and not all the bits are exposed via the GHC + -- interface. + mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure" + mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure" + mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure" + + let f ref (Just ptr) = writeIORef ref ptr + f _ Nothing = panic "interactiveUI:setBuffering2" + zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr] + [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] + +flushInterpBuffers :: GHCi () +flushInterpBuffers + = io $ do getHandle stdout_ptr >>= hFlush + getHandle stderr_ptr >>= hFlush + +turnOffBuffering :: IO () +turnOffBuffering + = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr] + mapM_ (\h -> hSetBuffering h NoBuffering) hdls + +getHandle :: IORef (Ptr ()) -> IO Handle +getHandle ref = do + (Ptr addr) <- readIORef ref + case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval) diff --git a/GhciHaskeline612/GhciTags.hs b/GhciHaskeline612/GhciTags.hs new file mode 100644 --- /dev/null +++ b/GhciHaskeline612/GhciTags.hs @@ -0,0 +1,202 @@ +----------------------------------------------------------------------------- +-- +-- GHCi's :ctags and :etags commands +-- +-- (c) The GHC Team 2005-2007 +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module GhciHaskeline612.GhciTags ( + createCTagsWithLineNumbersCmd, + createCTagsWithRegExesCmd, + createETagsFileCmd +) where + +import GHC +import GhciHaskeline612.GhciMonad +import Outputable +import Util + +-- ToDo: figure out whether we need these, and put something appropriate +-- into the GHC API instead +import Name (nameOccName) +import OccName (pprOccName) +import MonadUtils + +import Data.Maybe +import Panic +import Data.List +import Control.Monad +import System.IO +import System.IO.Error as IO + +----------------------------------------------------------------------------- +-- create tags file for currently loaded modules. + +createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd, + createETagsFileCmd :: String -> GHCi () + +createCTagsWithLineNumbersCmd "" = + ghciCreateTagsFile CTagsWithLineNumbers "tags" +createCTagsWithLineNumbersCmd file = + ghciCreateTagsFile CTagsWithLineNumbers file + +createCTagsWithRegExesCmd "" = + ghciCreateTagsFile CTagsWithRegExes "tags" +createCTagsWithRegExesCmd file = + ghciCreateTagsFile CTagsWithRegExes file + +createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS" +createETagsFileCmd file = ghciCreateTagsFile ETags file + +data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes + +ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi () +ghciCreateTagsFile kind file = do + createTagsFile kind file + +-- ToDo: +-- - remove restriction that all modules must be interpreted +-- (problem: we don't know source locations for entities unless +-- we compiled the module. +-- +-- - extract createTagsFile so it can be used from the command-line +-- (probably need to fix first problem before this is useful). +-- +createTagsFile :: TagsKind -> FilePath -> GHCi () +createTagsFile tagskind tagsFile = do + graph <- GHC.getModuleGraph + mtags <- mapM listModuleTags (map GHC.ms_mod graph) + either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags + case either_res of + Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e + Right _ -> return () + + +listModuleTags :: GHC.Module -> GHCi [TagInfo] +listModuleTags m = do + is_interpreted <- GHC.moduleIsInterpreted m + -- should we just skip these? + when (not is_interpreted) $ + let mName = GHC.moduleNameString (GHC.moduleName m) in + ghcError (CmdLineError ("module '" ++ mName ++ "' is not interpreted")) + mbModInfo <- GHC.getModuleInfo m + case mbModInfo of + Nothing -> return [] + Just mInfo -> do + mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo + let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual + let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo + let localNames = filter ((m==) . nameModule) names + mbTyThings <- mapM GHC.lookupName localNames + return $! [ tagInfo unqual exported kind name loc + | tyThing <- catMaybes mbTyThings + , let name = getName tyThing + , let exported = GHC.modInfoIsExportedName mInfo name + , let kind = tyThing2TagKind tyThing + , let loc = srcSpanStart (nameSrcSpan name) + , isGoodSrcLoc loc + ] + + where + tyThing2TagKind (AnId _) = 'v' + tyThing2TagKind (ADataCon _) = 'd' + tyThing2TagKind (ATyCon _) = 't' + tyThing2TagKind (AClass _) = 'c' + + +data TagInfo = TagInfo + { tagExported :: Bool -- is tag exported + , tagKind :: Char -- tag kind + , tagName :: String -- tag name + , tagFile :: String -- file name + , tagLine :: Int -- line number + , tagCol :: Int -- column number + , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset + } + + +-- get tag info, for later translation into Vim or Emacs style +tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> SrcLoc -> TagInfo +tagInfo unqual exported kind name loc + = TagInfo exported kind + (showSDocForUser unqual $ pprOccName (nameOccName name)) + (showSDocForUser unqual $ ftext (srcLocFile loc)) + (srcLocLine loc) (srcLocCol loc) Nothing + + +collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ()) +-- ctags style with the Ex exresion being just the line number, Vim et al +collateAndWriteTags CTagsWithLineNumbers file tagInfos = do + let tags = unlines $ sortLe (<=) $ map showCTag tagInfos + IO.try (writeFile file tags) + +-- ctags style with the Ex exresion being a regex searching the line, Vim et al +collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al + tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos + let tags = unlines $ sortLe (<=) $ map showCTag $concat tagInfoGroups + IO.try (writeFile file tags) + +collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs + tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos + let tagGroups = map processGroup tagInfoGroups + IO.try (writeFile file $ concat tagGroups) + + where + processGroup [] = ghcError (CmdLineError "empty tag file group??") + processGroup group@(tagInfo:_) = + let tags = unlines $ map showETag group in + "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags + + +makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]] +makeTagGroupsWithSrcInfo tagInfos = do + let byFile op ti0 ti1 = tagFile ti0 `op` tagFile ti1 + groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos + mapM addTagSrcInfo groups + + where + addTagSrcInfo [] = ghcError (CmdLineError "empty tag file group??") + addTagSrcInfo group@(tagInfo:_) = do + file <- readFile $tagFile tagInfo + let byLine ti0 ti1 = tagLine ti0 <= tagLine ti1 + sortedGroup = sortLe byLine group + return $ perFile sortedGroup 1 0 $ lines file + + perFile allTags@(tag:tags) cnt pos allLs@(l:ls) + | tagLine tag > cnt = + perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls + | tagLine tag == cnt = + tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs + perFile _ _ _ _ = [] + + +-- ctags format, for Vim et al +showCTag :: TagInfo -> String +showCTag ti = + tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++ + tagKind ti : ( if tagExported ti then "" else "\tfile:" ) + + where + tagCmd = + case tagSrcInfo ti of + Nothing -> show $tagLine ti + Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/" + + where + escapeSlashes '/' r = '\\' : '/' : r + escapeSlashes '\\' r = '\\' : '\\' : r + escapeSlashes c r = c : r + + +-- etags format, for Emacs/XEmacs +showETag :: TagInfo -> String +showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo, + tagSrcInfo = Just (srcLine,charPos) } + = take colNo srcLine ++ tag + ++ "\x7f" ++ tag + ++ "\x01" ++ show lineNo + ++ "," ++ show charPos +showETag _ = ghcError (CmdLineError "missing source file info in showETag") + diff --git a/GhciHaskeline612/InteractiveUI.hs b/GhciHaskeline612/InteractiveUI.hs new file mode 100644 --- /dev/null +++ b/GhciHaskeline612/InteractiveUI.hs @@ -0,0 +1,2282 @@ +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +----------------------------------------------------------------------------- +-- +-- GHC Interactive User Interface +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module GhciHaskeline612.InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where + +import qualified GhciHaskeline612.GhciMonad as GhciMonad +import GhciHaskeline612.GhciMonad hiding (runStmt) +import GhciHaskeline612.GhciTags +import Debugger + +-- The GHC interface +import qualified GHC hiding (resume, runStmt) +import GHC ( LoadHowMuch(..), Target(..), TargetId(..), + TyThing(..), Phase, + BreakIndex, Resume, SingleStep, + Ghc, handleSourceError ) +import PprTyThing +import DynFlags + +import Packages +-- import PackageConfig +import UniqFM + +import HscTypes ( implicitTyThings, handleFlagWarnings ) +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 CmdLineParser +import Digraph +import BasicTypes hiding (isTopLevel) +import Panic hiding (showException) +import Config +import StaticFlags +import Linker +import Util +import NameSet +import Maybes ( orElse, expectJust ) +import FastString +import Encoding +import Foreign.C + +#ifndef mingw32_HOST_OS +import System.Posix hiding (getEnv) +#else +import qualified System.Win32 +#endif + +import System.Console.Haskeline as Haskeline +import qualified System.Console.Haskeline.Encoding as Encoding +import Control.Monad.Trans + +--import SystemExts + +import Exception hiding (catch, block, unblock) + +-- 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.Array +import Control.Monad as Monad +import Text.Printf +import Foreign +import GHC.Exts ( unsafeCoerce# ) + +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) +import GHC.IO.Handle ( hFlushAll ) +#else +import GHC.IOBase ( IOErrorType(InvalidArgument) ) +#endif + +import GHC.TopHandler + +import Data.IORef ( IORef, readIORef, writeIORef ) + +-- Copied from HsVersions.h +#define ASSERT(e) if False && (not (e)) then panic "ASSERT" else +#define GLOBAL_VAR(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.global (value); + + +----------------------------------------------------------------------------- + +ghciWelcomeMsg :: String +ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ + ": http://www.haskell.org/ghc/ :? for help" + +cmdName :: Command -> String +cmdName (n,_,_) = n + +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, noCompletion), + ("add", keepGoingPaths addModule, completeFilename), + ("abandon", keepGoing abandonCmd, noCompletion), + ("break", keepGoing breakCmd, completeIdentifier), + ("back", keepGoing backCmd, noCompletion), + ("browse", keepGoing' (browseCmd False), completeModule), + ("browse!", keepGoing' (browseCmd True), completeModule), + ("cd", keepGoing' changeDirectory, completeFilename), + ("check", keepGoing' checkModule, completeHomeModule), + ("continue", keepGoing continueCmd, noCompletion), + ("cmd", keepGoing cmdCmd, completeExpression), + ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename), + ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename), + ("def", keepGoing (defineMacro False), completeExpression), + ("def!", keepGoing (defineMacro True), completeExpression), + ("delete", keepGoing deleteCmd, noCompletion), + ("edit", keepGoing editFile, completeFilename), + ("etags", keepGoing createETagsFileCmd, completeFilename), + ("force", keepGoing forceCmd, completeExpression), + ("forward", keepGoing forwardCmd, noCompletion), + ("help", keepGoing help, noCompletion), + ("history", keepGoing historyCmd, noCompletion), + ("info", keepGoing' info, completeIdentifier), + ("kind", keepGoing' kindOfType, completeIdentifier), + ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), + ("list", keepGoing' listCmd, noCompletion), + ("module", keepGoing setContext, completeModule), + ("main", keepGoing runMain, completeFilename), + ("print", keepGoing printCmd, completeExpression), + ("quit", quit, noCompletion), + ("reload", keepGoing' reloadModule, noCompletion), + ("run", keepGoing runRun, completeFilename), + ("set", keepGoing setCmd, completeSetOptions), + ("show", keepGoing showCmd, completeShowOptions), + ("sprint", keepGoing sprintCmd, completeExpression), + ("step", keepGoing stepCmd, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), + ("type", keepGoing' typeOfExpr, completeExpression), + ("trace", keepGoing traceCmd, completeExpression), + ("undef", keepGoing undefineMacro, completeMacro), + ("unset", keepGoing unsetOptions, 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. +word_break_chars :: String +word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" + specials = "(),;[]`{}" + spaces = " \t\n" + in spaces ++ specials ++ symbols + +flagWordBreakChars :: String +flagWordBreakChars = " \t\n" + + +keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool) +keepGoing a str = keepGoing' (lift . a) str + +keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool +keepGoing' a str = a str >> return False + +keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool) +keepGoingPaths a str + = do case toArgs str of + Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr + Right args -> a args + return False + +shortHelpText :: String +shortHelpText = "use :? for help.\n" + +helpText :: String +helpText = + " Commands available from the prompt:\n" ++ + "\n" ++ + " evaluate/run \n" ++ + " : repeat last command\n" ++ + " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ + " :add [*] ... add module(s) to the current target set\n" ++ + " :browse[!] [[*]] display the names defined by module \n" ++ + " (!: more details; *: all top-level names)\n" ++ + " :cd change directory to \n" ++ + " :cmd run the commands returned by ::IO String\n" ++ + " :ctags[!] [] create tags file for Vi (default: \"tags\")\n" ++ + " (!: use regex instead of line number)\n" ++ + " :def define a command :\n" ++ + " :edit edit file\n" ++ + " :edit edit last module\n" ++ + " :etags [] create tags file for Emacs (default: \"TAGS\")\n" ++ + " :help, :? display this list of commands\n" ++ + " :info [ ...] display information about the given names\n" ++ + " :kind show the kind of \n" ++ + " :load [*] ... load module(s) and their dependents\n" ++ + " :main [ ...] run the main function with the given arguments\n" ++ + " :module [+/-] [*] ... set the context for expression evaluation\n" ++ + " :quit exit GHCi\n" ++ + " :reload reload the current module set\n" ++ + " :run function [ ...] run the function with the given arguments\n" ++ + " :type show the type of \n" ++ + " :undef undefine user-defined command :\n" ++ + " :! run the shell 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 [] [] set a breakpoint at the specified location\n" ++ + " :break set a breakpoint on the specified function\n" ++ + " :continue resume after a breakpoint\n" ++ + " :delete delete the specified breakpoint\n" ++ + " :delete * delete all breakpoints\n" ++ + " :force print , forcing unevaluated parts\n" ++ + " :forward go forward in the history (after :back)\n" ++ + " :history [] after :trace, show the execution history\n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list identifier show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ + " :print [ ...] prints a value without forcing its computation\n" ++ + " :sprint [ ...] simplifed version of :print\n" ++ + " :step single-step after stopping at a breakpoint\n"++ + " :step single-step into \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 evaluate with tracing on (see :history)\n"++ + + "\n" ++ + " -- Commands for changing settings:\n" ++ + "\n" ++ + " :set