diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,6 @@ +20221024 ghci-dap-0.0.19.0 + * [INFO] support ghc-8.10.7. + 20220930 ghci-dap-0.0.18.0 * [INFO] support ghc-9.4.2. diff --git a/app-ghc-8.10/GHCMain.hs b/app-ghc-8.10/GHCMain.hs new file mode 100644 --- /dev/null +++ b/app-ghc-8.10/GHCMain.hs @@ -0,0 +1,990 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver program +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module GHCMain (ghcMain) where -- DAP Modified + +-- The official GHC API +import qualified GHC +import GHC ( -- DynFlags(..), HscTarget(..), + -- GhcMode(..), GhcLink(..), + Ghc, GhcMonad(..), + LoadHowMuch(..) ) +import CmdLineParser + +-- Implementations of the various modes (--show-iface, mkdependHS. etc.) +import LoadIface ( showIface ) +import HscMain ( newHscEnv ) +import DriverPipeline ( oneShot, compileFile ) +import DriverMkDepend ( doMkDependHS ) +import DriverBkp ( doBackpack ) +#if defined(HAVE_INTERNAL_INTERPRETER) +import GHCi.UI ( interactiveUI, ghciWelcomeMsg, GhciSettings ) -- DAP Modified +#endif + +-- Frontend plugins +import DynamicLoading ( loadFrontendPlugin ) +import Plugins +#if defined(HAVE_INTERNAL_INTERPRETER) +import DynamicLoading ( initializePlugins ) +#endif +import Module ( ModuleName ) + + +-- Various other random stuff that we need +import GHC.HandleEncoding +import GHC.Platform +import GHC.Platform.Host +import Config +import Constants +import HscTypes +import Packages ( pprPackages, pprPackagesSimple ) +import DriverPhases +import BasicTypes ( failed ) +import DynFlags hiding (WarnReason(..)) +import ErrUtils +import FastString +import Outputable +import SysTools.BaseDir +import SysTools.Settings +import SrcLoc +import Util +import Panic +import UniqSupply +import MonadUtils ( liftIO ) + +-- Imports for --abi-hash +import LoadIface ( loadUserInterface ) +import Module ( mkModuleName ) +import Finder ( findImportedModule, cannotFindModule ) +import TcRnMonad ( initIfaceCheck ) +import Binary ( openBinMem, put_ ) +import BinFingerprint ( fingerprintBinMem ) + +-- Standard Haskell libraries +import System.IO +import System.Environment +import System.Exit +import System.FilePath +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except (throwE, runExceptT) +import Data.Char +import Data.List ( isPrefixOf, partition, intercalate ) +import Data.Maybe +import Prelude + +-- DAP add +import qualified 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 + +ghcMain :: GhciSettings -> IO () -- DAP Modified +ghcMain setting = do -- DAP Modified + initGCStatistics -- See Note [-Bsymbolic and hooks] + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + + configureHandleEncoding + GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do + -- 1. extract the -B flag from the args + argv0 <- getArgs + + let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 + mbMinusB | null minusB_args = Just GHC.Paths.libdir -- DAP Modified + | otherwise = Just (drop 2 (last minusB_args)) + + let argv2 = map (mkGeneralLocated "on the commandline") argv1 + + -- 2. Parse the "mode" flags (--make, --interactive etc.) + (mode, argv3, flagWarnings) <- parseModeFlags argv2 + + -- If all we want to do is something like showing the version number + -- then do it now, before we start a GHC session etc. This makes + -- getting basic information much more resilient. + + -- In particular, if we wait until later before giving the version + -- number 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 mode of + Left preStartupMode -> + do case preStartupMode of + ShowSupportedExtensions -> showSupportedExtensions mbMinusB + ShowVersion -> showVersion + ShowNumVersion -> putStrLn cProjectVersion + ShowOptions isInteractive -> showOptions isInteractive + Right postStartupMode -> + -- start our GHC session + GHC.runGhc mbMinusB $ do + + dflags <- GHC.getSessionDynFlags + + case postStartupMode of + Left preLoadMode -> + liftIO $ do + case preLoadMode of + ShowInfo -> showInfo dflags + ShowGhcUsage -> showGhcUsage dflags + ShowGhciUsage -> showGhciUsage dflags + PrintWithDynFlags f -> putStrLn (f dflags) + Right postLoadMode -> + main' setting postLoadMode dflags argv3 flagWarnings -- DAP Modified + +main' :: GhciSettings -> PostLoadMode -> DynFlags -> [Located String] -> [Warn] -- DAP Modified + -> Ghc () +main' setting postLoadMode dflags0 args flagWarnings = do -- DAP Modified + -- 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 postLoadMode of + DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) + DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) + DoMake -> (CompManager, dflt_target, LinkBinary) + DoBackpack -> (CompManager, dflt_target, LinkBinary) + DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) + DoAbiHash -> (OneShot, dflt_target, LinkBinary) + _ -> (OneShot, dflt_target, LinkBinary) + + let dflags1 = dflags0{ ghcMode = mode, + hscTarget = lang, + ghcLink = link, + verbosity = case postLoadMode of + DoEval _ -> 0 + _other -> 1 + } + + -- turn on -fimplicit-import-qualified for GHCi now, so that it + -- can be overriden from the command-line + -- XXX: this should really be in the interactive DynFlags, but + -- we don't set that until later in interactiveUI + -- We also set -fignore-optim-changes and -fignore-hpc-changes, + -- which are program-level options. Again, this doesn't really + -- feel like the right place to handle this, but we don't have + -- a great story for the moment. + dflags2 | DoInteractive <- postLoadMode = def_ghci_flags + | DoEval _ <- postLoadMode = def_ghci_flags + | otherwise = dflags1 + where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified + `gopt_set` Opt_IgnoreOptimChanges + `gopt_set` Opt_IgnoreHpcChanges + + -- The rest of the arguments are "dynamic" + -- Leftover ones are presumably files + (dflags3, fileish_args, dynamicFlagWarnings) <- + GHC.parseDynamicFlags dflags2 args + + let dflags4 = case lang of + HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) -> + let platform = targetPlatform dflags3 + dflags3a = updateWays $ dflags3 { ways = interpWays } + dflags3b = foldl gopt_set dflags3a + $ concatMap (wayGeneralFlags platform) + interpWays + dflags3c = foldl gopt_unset dflags3b + $ concatMap (wayUnsetGeneralFlags platform) + interpWays + in dflags3c + _ -> + dflags3 + + GHC.prettyPrintGhcErrors dflags4 $ do + + let flagWarnings' = flagWarnings ++ dynamicFlagWarnings + + handleSourceError (\e -> do + GHC.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + liftIO $ handleFlagWarnings dflags4 flagWarnings' + + liftIO $ showBanner postLoadMode dflags4 + + let + -- To simplify the handling of filepaths, we normalise all filepaths right + -- away. Note the asymmetry of FilePath.normalise: + -- Linux: p/q -> p/q; p\q -> p\q + -- Windows: p/q -> p\q; p\q -> p\q + -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs + -- to -foo.hs. We have to re-prepend the current directory. + normalise_hyp fp + | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp + | otherwise = nfp + where +#if defined(mingw32_HOST_OS) + strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp +#else + strt_dot_sl = "./" `isPrefixOf` fp +#endif + cur_dir = '.' : [pathSeparator] + nfp = normalise fp + normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args + (srcs, objs) = partition_args normal_fileish_paths [] [] + + dflags5 = dflags4 { ldInputs = map (FileOption "") objs + ++ ldInputs dflags4 } + + -- we've finished manipulating the DynFlags, update the session + _ <- GHC.setSessionDynFlags dflags5 + dflags6 <- GHC.getSessionDynFlags + hsc_env <- GHC.getSession + + ---------------- Display configuration ----------- + case verbosity dflags6 of + v | v == 4 -> liftIO $ dumpPackagesSimple dflags6 + | v >= 5 -> liftIO $ dumpPackages dflags6 + | otherwise -> return () + + liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) + ---------------- Final sanity checking ----------- + liftIO $ checkOptions postLoadMode dflags6 srcs objs + + ---------------- Do the business ----------- + handleSourceError (\e -> do + GHC.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + case postLoadMode of + ShowInterface f -> liftIO $ doShowIface dflags6 f + DoMake -> doMake srcs + DoMkDependHS -> doMkDependHS (map fst srcs) + StopBefore p -> liftIO (oneShot hsc_env p srcs) + DoInteractive -> ghciUI setting hsc_env dflags6 srcs Nothing -- DAP Modified + DoEval exprs -> ghciUI setting hsc_env dflags6 srcs $ Just $ -- DAP Modified + reverse exprs + DoAbiHash -> abiHash (map fst srcs) + ShowPackages -> liftIO $ showPackages dflags6 + DoFrontend f -> doFrontend f srcs + DoBackpack -> doBackpack (map fst srcs) + + liftIO $ dumpFinalStats dflags6 + +ghciUI :: GhciSettings -> HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String] -- DAP Modified + -> Ghc () +#if !defined(HAVE_INTERNAL_INTERPRETER) +ghciUI _ _ _ _ _ = -- DAP Modified + throwGhcException (CmdLineError "not built for interactive use") +#else +ghciUI st hsc_env dflags0 srcs maybe_expr = do -- DAP Modified + dflags1 <- liftIO (initializePlugins hsc_env dflags0) + _ <- GHC.setSessionDynFlags dflags1 + interactiveUI st srcs maybe_expr -- DAP Modified +#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 ldInputs 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), + + - things beginning with '-' are flags that were not recognised by + the flag parser, and we want them to generate errors later in + checkOptions, so we class them as source files (#5921) + + - and finally we consider everything without an extension 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 + || "-" `isPrefixOf` m + || not (hasExtension m) + +-- ----------------------------------------------------------------------------- +-- Option sanity checks + +-- | Ensure sanity of options. +-- +-- Throws 'UsageError' or 'CmdLineError' if not. +checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () + -- Final sanity checking before kicking off a compilation (pipeline). +checkOptions 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 wayRTSOnly (ways dflags)) + && isInterpretiveMode mode) $ + hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") + + -- -prof and --interactive are not a good combination + when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays) + && isInterpretiveMode mode + && not (gopt Opt_ExternalInterpreter dflags)) $ + do throwGhcException (UsageError + "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).") + -- -ohi sanity check + if (isJust (outputHi dflags) && + (isCompManagerMode mode || srcs `lengthExceeds` 1)) + then throwGhcException (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 mode)) + then throwGhcException (UsageError "can't apply -o to multiple source files") + else do + + let not_linking = not (isLinkMode 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 mode + then throwGhcException (UsageError "no input files") + else do + + case mode of + StopBefore HCc | hscTarget dflags /= HscC + -> throwGhcException $ UsageError $ + "the option -C is only available with an unregisterised GHC" + StopBefore (As False) | ghcLink dflags == NoLink + -> throwGhcException $ UsageError $ + "the options -S and -fno-code are incompatible. Please omit -S" + + _ -> return () + + -- Verify that output files point somewhere sensible. + verifyOutputFiles dflags + +-- Compiler output options + +-- Called to verify that the output files point somewhere valid. +-- +-- The assumption is that the directory portion of these output +-- options will have to exist by the time 'verifyOutputFiles' +-- is invoked. +-- +-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if +-- they don't exist, so don't check for those here (#2278). +verifyOutputFiles :: DynFlags -> IO () +verifyOutputFiles dflags = do + 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 = + throwGhcException (CmdLineError ("error: directory portion of " ++ + show dir ++ " does not exist (used with " ++ + show flg ++ " option.)")) + +----------------------------------------------------------------------------- +-- GHC modes of operation + +type Mode = Either PreStartupMode PostStartupMode +type PostStartupMode = Either PreLoadMode PostLoadMode + +data PreStartupMode + = ShowVersion -- ghc -V/--version + | ShowNumVersion -- ghc --numeric-version + | ShowSupportedExtensions -- ghc --supported-extensions + | ShowOptions Bool {- isInteractive -} -- ghc --show-options + +showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode +showVersionMode = mkPreStartupMode ShowVersion +showNumVersionMode = mkPreStartupMode ShowNumVersion +showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions +showOptionsMode = mkPreStartupMode (ShowOptions False) + +mkPreStartupMode :: PreStartupMode -> Mode +mkPreStartupMode = Left + +isShowVersionMode :: Mode -> Bool +isShowVersionMode (Left ShowVersion) = True +isShowVersionMode _ = False + +isShowNumVersionMode :: Mode -> Bool +isShowNumVersionMode (Left ShowNumVersion) = True +isShowNumVersionMode _ = False + +data PreLoadMode + = ShowGhcUsage -- ghc -? + | ShowGhciUsage -- ghci -? + | ShowInfo -- ghc --info + | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo + +showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode +showGhcUsageMode = mkPreLoadMode ShowGhcUsage +showGhciUsageMode = mkPreLoadMode ShowGhciUsage +showInfoMode = mkPreLoadMode ShowInfo + +printSetting :: String -> Mode +printSetting k = mkPreLoadMode (PrintWithDynFlags f) + where f dflags = fromMaybe (panic ("Setting not found: " ++ show k)) + $ lookup k (compilerInfo dflags) + +mkPreLoadMode :: PreLoadMode -> Mode +mkPreLoadMode = Right . Left + +isShowGhcUsageMode :: Mode -> Bool +isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True +isShowGhcUsageMode _ = False + +isShowGhciUsageMode :: Mode -> Bool +isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True +isShowGhciUsageMode _ = False + +data PostLoadMode + = ShowInterface FilePath -- ghc --show-iface + | DoMkDependHS -- ghc -M + | StopBefore Phase -- ghc -E | -C | -S + -- StopBefore StopLn is the default + | DoMake -- ghc --make + | DoBackpack -- ghc --backpack foo.bkp + | DoInteractive -- ghc --interactive + | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] + | DoAbiHash -- ghc --abi-hash + | ShowPackages -- ghc --show-packages + | DoFrontend ModuleName -- ghc --frontend Plugin.Module + +doMkDependHSMode, doMakeMode, doInteractiveMode, + doAbiHashMode, showPackagesMode :: Mode +doMkDependHSMode = mkPostLoadMode DoMkDependHS +doMakeMode = mkPostLoadMode DoMake +doInteractiveMode = mkPostLoadMode DoInteractive +doAbiHashMode = mkPostLoadMode DoAbiHash +showPackagesMode = mkPostLoadMode ShowPackages + +showInterfaceMode :: FilePath -> Mode +showInterfaceMode fp = mkPostLoadMode (ShowInterface fp) + +stopBeforeMode :: Phase -> Mode +stopBeforeMode phase = mkPostLoadMode (StopBefore phase) + +doEvalMode :: String -> Mode +doEvalMode str = mkPostLoadMode (DoEval [str]) + +doFrontendMode :: String -> Mode +doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str)) + +doBackpackMode :: Mode +doBackpackMode = mkPostLoadMode DoBackpack + +mkPostLoadMode :: PostLoadMode -> Mode +mkPostLoadMode = Right . Right + +isDoInteractiveMode :: Mode -> Bool +isDoInteractiveMode (Right (Right DoInteractive)) = True +isDoInteractiveMode _ = False + +isStopLnMode :: Mode -> Bool +isStopLnMode (Right (Right (StopBefore StopLn))) = True +isStopLnMode _ = False + +isDoMakeMode :: Mode -> Bool +isDoMakeMode (Right (Right DoMake)) = True +isDoMakeMode _ = False + +isDoEvalMode :: Mode -> Bool +isDoEvalMode (Right (Right (DoEval _))) = True +isDoEvalMode _ = False + +#if defined(HAVE_INTERNAL_INTERPRETER) +isInteractiveMode :: PostLoadMode -> Bool +isInteractiveMode DoInteractive = True +isInteractiveMode _ = False +#endif + +-- isInterpretiveMode: byte-code compiler involved +isInterpretiveMode :: PostLoadMode -> Bool +isInterpretiveMode DoInteractive = True +isInterpretiveMode (DoEval _) = True +isInterpretiveMode _ = False + +needsInputsMode :: PostLoadMode -> 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 :: PostLoadMode -> Bool +isLinkMode (StopBefore StopLn) = True +isLinkMode DoMake = True +isLinkMode DoInteractive = True +isLinkMode (DoEval _) = True +isLinkMode _ = False + +isCompManagerMode :: PostLoadMode -> Bool +isCompManagerMode DoMake = True +isCompManagerMode DoInteractive = True +isCompManagerMode (DoEval _) = True +isCompManagerMode _ = False + +-- ----------------------------------------------------------------------------- +-- Parsing the mode flag + +parseModeFlags :: [Located String] + -> IO (Mode, + [Located String], + [Warn]) +parseModeFlags args = do + let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = + runCmdLine (processArgs mode_flags args) + (Nothing, [], []) + mode = case mModeFlag of + Nothing -> doMakeMode + Just (m, _) -> m + + -- See Note [Handling errors when parsing commandline flags] + unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $ + map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2 + + return (mode, flags' ++ leftover, warns) + +type ModeM = CmdLineP (Maybe (Mode, String), [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 ---------------------------------------------- + defFlag "?" (PassFlag (setMode showGhcUsageMode)) + , defFlag "-help" (PassFlag (setMode showGhcUsageMode)) + , defFlag "V" (PassFlag (setMode showVersionMode)) + , defFlag "-version" (PassFlag (setMode showVersionMode)) + , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode)) + , defFlag "-info" (PassFlag (setMode showInfoMode)) + , defFlag "-show-options" (PassFlag (setMode showOptionsMode)) + , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) + , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) + , defFlag "-show-packages" (PassFlag (setMode showPackagesMode)) + ] ++ + [ defFlag k' (PassFlag (setMode (printSetting k))) + | k <- ["Project version", + "Project Git commit id", + "Booter version", + "Stage", + "Build platform", + "Host platform", + "Target platform", + "Have interpreter", + "Object splitting supported", + "Have native code generator", + "Support SMP", + "Unregisterised", + "Tables next to code", + "RTS ways", + "Leading underscore", + "Debug on", + "LibDir", + "Global Package DB", + "C compiler flags", + "C compiler link flags", + "ld flags"], + let k' = "-print-" ++ map (replaceSpace . toLower) k + replaceSpace ' ' = '-' + replaceSpace c = c + ] ++ + ------- interfaces ---------------------------------------------------- + [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) + "--show-iface")) + + ------- primary modes ------------------------------------------------ + , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f + addFlag "-no-link" f)) + , defFlag "M" (PassFlag (setMode doMkDependHSMode)) + , defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) + , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc))) + , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False)))) + , defFlag "-make" (PassFlag (setMode doMakeMode)) + , defFlag "-backpack" (PassFlag (setMode doBackpackMode)) + , defFlag "-interactive" (PassFlag (setMode doInteractiveMode)) + , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode)) + , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) + , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend")) + ] + +setMode :: Mode -> String -> EwM ModeM () +setMode newMode newFlag = liftEwM $ do + (mModeFlag, errs, flags') <- getCmdLineState + let (modeFlag', errs') = + case mModeFlag of + Nothing -> ((newMode, newFlag), errs) + Just (oldMode, oldFlag) -> + case (oldMode, newMode) of + -- -c/--make are allowed together, and mean --make -no-link + _ | isStopLnMode oldMode && isDoMakeMode newMode + || isStopLnMode newMode && isDoMakeMode oldMode -> + ((doMakeMode, "--make"), []) + + -- If we have both --help and --interactive then we + -- want showGhciUsage + _ | isShowGhcUsageMode oldMode && + isDoInteractiveMode newMode -> + ((showGhciUsageMode, oldFlag), []) + | isShowGhcUsageMode newMode && + isDoInteractiveMode oldMode -> + ((showGhciUsageMode, newFlag), []) + + -- If we have both -e and --interactive then -e always wins + _ | isDoEvalMode oldMode && + isDoInteractiveMode newMode -> + ((oldMode, oldFlag), []) + | isDoEvalMode newMode && + isDoInteractiveMode oldMode -> + ((newMode, newFlag), []) + + -- Otherwise, --help/--version/--numeric-version always win + | isDominantFlag oldMode -> ((oldMode, oldFlag), []) + | isDominantFlag newMode -> ((newMode, newFlag), []) + -- We need to accumulate eval flags like "-e foo -e bar" + (Right (Right (DoEval esOld)), + Right (Right (DoEval [eNew]))) -> + ((Right (Right (DoEval (eNew : esOld))), oldFlag), + errs) + -- Saying e.g. --interactive --interactive is OK + _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs) + + -- --interactive and --show-options are used together + (Right (Right DoInteractive), Left (ShowOptions _)) -> + ((Left (ShowOptions True), + "--interactive --show-options"), errs) + (Left (ShowOptions _), (Right (Right DoInteractive))) -> + ((Left (ShowOptions True), + "--show-options --interactive"), errs) + -- Otherwise, complain + _ -> let err = flagMismatchErr oldFlag newFlag + in ((oldMode, oldFlag), err : errs) + putCmdLineState (Just modeFlag', errs', flags') + where isDominantFlag f = isShowGhcUsageMode f || + isShowGhciUsageMode f || + isShowVersionMode f || + isShowNumVersionMode f + +flagMismatchErr :: String -> String -> String +flagMismatchErr oldFlag newFlag + = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'" + +addFlag :: String -> String -> EwM ModeM () +addFlag s flag = liftEwM $ do + (m, e, flags') <- getCmdLineState + putCmdLineState (m, e, mkGeneralLocated loc s : flags') + where loc = "addFlag by " ++ flag ++ " on the commandline" + +-- ---------------------------------------------------------------------------- +-- Run --make mode + +doMake :: [(String,Maybe Phase)] -> Ghc () +doMake srcs = do + let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs + + hsc_env <- GHC.getSession + + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then liftIO (oneShot hsc_env StopLn srcs) + else do + + o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) + non_hs_srcs + dflags <- GHC.getSessionDynFlags + let dflags' = dflags { ldInputs = map (FileOption "") o_files + ++ ldInputs dflags } + _ <- GHC.setSessionDynFlags dflags' + + 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 :: PostLoadMode -> DynFlags -> IO () +showBanner _postLoadMode dflags = do + let verb = verbosity dflags + +#if defined(HAVE_INTERNAL_INTERPRETER) + -- Show the GHCi banner + when (isInteractiveMode _postLoadMode && 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 ", 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 :: DynFlags -> IO () +showInfo dflags = do + let sq x = " [" ++ x ++ "\n ]" + putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags + +-- TODO use ErrUtils once that is disentangled from all the other GhcMonad stuff? +showSupportedExtensions :: Maybe String -> IO () +showSupportedExtensions m_top_dir = do + res <- runExceptT $ do + top_dir <- lift (tryFindTopDir m_top_dir) >>= \case + Nothing -> throwE $ SettingsError_MissingData "Could not find the top directory, missing -B flag" + Just dir -> pure dir + initSettings top_dir + targetPlatformMini <- case res of + Right s -> pure $ platformMini $ sTargetPlatform s + Left (SettingsError_MissingData msg) -> do + hPutStrLn stderr $ "WARNING: " ++ show msg + hPutStrLn stderr $ "cannot know target platform so guessing target == host (native compiler)." + pure cHostPlatformMini + Left (SettingsError_BadData msg) -> do + hPutStrLn stderr msg + exitWith $ ExitFailure 1 + mapM_ putStrLn $ supportedLanguagesAndExtensions targetPlatformMini + +showVersion :: IO () +showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion) + +showOptions :: Bool -> IO () +showOptions isInteractive = putStr (unlines availableOptions) + where + availableOptions = concat [ + flagsForCompletion isInteractive, + map ('-':) (getFlagNames mode_flags) + ] + getFlagNames opts = map flagName opts + +showGhcUsage :: DynFlags -> IO () +showGhcUsage = showUsage False + +showGhciUsage :: DynFlags -> IO () +showGhciUsage = showUsage True + +showUsage :: Bool -> DynFlags -> IO () +showUsage ghci dflags = do + let usage_path = if ghci then ghciUsagePath dflags + else ghcUsagePath dflags + usage <- readFile usage_path + dump usage + where + dump "" = return () + dump ('$':'$':s) = putStr progName >> dump s + dump (c:s) = putChar c >> dump s + +dumpFinalStats :: DynFlags -> IO () +dumpFinalStats dflags = + when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags + +dumpFastStringStats :: DynFlags -> IO () +dumpFastStringStats dflags = do + segments <- getFastStringTable + hasZ <- getFastStringZEncCounter + let buckets = concat segments + bucketsPerSegment = map length segments + entriesPerBucket = map length buckets + entries = sum entriesPerBucket + msg = text "FastString stats:" $$ nest 4 (vcat + [ text "segments: " <+> int (length segments) + , text "buckets: " <+> int (sum bucketsPerSegment) + , text "entries: " <+> int entries + , text "largest segment: " <+> int (maximum bucketsPerSegment) + , text "smallest segment: " <+> int (minimum bucketsPerSegment) + , text "longest bucket: " <+> int (maximum entriesPerBucket) + , text "has z-encoding: " <+> (hasZ `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 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) Outputable.<> char '%' + +showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO () +showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags)) +dumpPackages dflags = putMsg dflags (pprPackages dflags) +dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags) + +-- ----------------------------------------------------------------------------- +-- Frontend plugin support + +doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc () +doFrontend modname srcs = do + hsc_env <- getSession + frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname + frontend frontend_plugin + (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs + +-- ----------------------------------------------------------------------------- +-- ABI hash support + +{- + ghc --abi-hash Data.Foo System.Bar + +Generates a combined hash of the ABI for modules Data.Foo and +System.Bar. The modules must already be compiled, and appropriate -i +options may be necessary in order to find the .hi files. + +This is used by Cabal for generating the ComponentId for a +package. The ComponentId must change when the visible ABI of +the package chagnes, so during registration Cabal calls ghc --abi-hash +to get a hash of the package's ABI. +-} + +-- | Print ABI hash of input modules. +-- +-- The resulting hash is the MD5 of the GHC version used (#5328, +-- see 'hiVersion') and of the existing ABI hash from each module (see +-- 'mi_mod_hash'). +abiHash :: [String] -- ^ List of module names + -> Ghc () +abiHash strs = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + + liftIO $ do + + let find_it str = do + let modname = mkModuleName str + r <- findImportedModule hsc_env modname Nothing + case r of + Found _ m -> return m + _error -> throwGhcException $ CmdLineError $ showSDoc dflags $ + cannotFindModule dflags modname r + + mods <- mapM find_it strs + + let get_iface modl = loadUserInterface False (text "abiHash") modl + ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods + + bh <- openBinMem (3*1024) -- just less than a block + put_ bh hiVersion + -- package hashes change when the compiler version changes (for now) + -- see #5328 + mapM_ (put_ bh . mi_mod_hash . mi_final_exts) ifaces + f <- fingerprintBinMem bh + + putStrLn (showPpr dflags f) + +-- ----------------------------------------------------------------------------- +-- Util + +unknownFlagsErr :: [String] -> a +unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs + where + oneError f = + "unrecognised flag: " ++ f ++ "\n" ++ + (case match f (nubSort allNonDeprecatedFlags) of + [] -> "" + suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs)) + -- fixes #11789 + -- If the flag contains '=', + -- this uses both the whole and the left side of '=' for comparing. + match f allFlags + | elem '=' f = + let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags + fName = takeWhile (/= '=') f + in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq) + | otherwise = fuzzyMatch f allFlags + +{- Note [-Bsymbolic and hooks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-Bsymbolic is a flag that prevents the binding of references to global +symbols to symbols outside the shared library being compiled (see `man +ld`). When dynamically linking, we don't use -Bsymbolic on the RTS +package: that is because we want hooks to be overridden by the user, +we don't want to constrain them to the RTS package. + +Unfortunately this seems to have broken somehow on OS X: as a result, +defaultHooks (in hschooks.c) is not called, which does not initialize +the GC stats. As a result, this breaks things like `:set +s` in GHCi +(#8754). As a hacky workaround, we instead call 'defaultHooks' +directly to initalize the flags in the RTS. + +A byproduct of this, I believe, is that hooks are likely broken on OS +X when dynamically linking. But this probably doesn't affect most +people since we're linking GHC dynamically, but most things themselves +link statically. +-} + +-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then +-- running it causes an error like this: +-- +-- Loading temp shared object failed: +-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics +-- +-- Skipping the foreign call fixes this problem, and the outer GHCi +-- should have already made this call anyway. +#if defined(GHC_LOADED_INTO_GHCI) +initGCStatistics :: IO () +initGCStatistics = return () +#else +foreign import ccall safe "initGCStatistics" + initGCStatistics :: IO () +#endif diff --git a/app-ghc-8.10/GHCi/GhcApiCompat.hs b/app-ghc-8.10/GHCi/GhcApiCompat.hs new file mode 100644 --- /dev/null +++ b/app-ghc-8.10/GHCi/GhcApiCompat.hs @@ -0,0 +1,29 @@ +module GHCi.GhcApiCompat ( + module GhcMonad + , module RdrName + , module Outputable + , module Exception + , module FastString + , module DataCon + , module DynFlags + , module RtClosureInspect + , module HscTypes + , module Debugger + , module InteractiveEvalTypes + , module PprTyThing + , module Module + ) where + +import GhcMonad +import RdrName +import Outputable +import Exception +import FastString +import DataCon +import DynFlags +import RtClosureInspect +import HscTypes +import Debugger +import InteractiveEvalTypes +import PprTyThing +import Module diff --git a/app-ghc-8.10/GHCi/Leak.hs b/app-ghc-8.10/GHCi/Leak.hs new file mode 100644 --- /dev/null +++ b/app-ghc-8.10/GHCi/Leak.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE RecordWildCards, LambdaCase #-} +module GHCi.Leak + ( LeakIndicators + , getLeakIndicators + , checkLeakIndicators + ) where + +import Control.Monad +import Data.Bits +import Foreign.Ptr (ptrToIntPtr, intPtrToPtr) +import GHC +import GHC.Ptr (Ptr (..)) +import GHCi.Util +import HscTypes +import Outputable +import GHC.Platform (target32Bit) +import Prelude +import System.Mem +import System.Mem.Weak +import UniqDFM + +-- Checking for space leaks in GHCi. See #15111, and the +-- -fghci-leak-check flag. + +data LeakIndicators = LeakIndicators [LeakModIndicators] + +data LeakModIndicators = LeakModIndicators + { leakMod :: Weak HomeModInfo + , leakIface :: Weak ModIface + , leakDetails :: Weak ModDetails + , leakLinkable :: Maybe (Weak Linkable) + } + +-- | Grab weak references to some of the data structures representing +-- the currently loaded modules. +getLeakIndicators :: HscEnv -> IO LeakIndicators +getLeakIndicators HscEnv{..} = + fmap LeakIndicators $ + forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do + leakMod <- mkWeakPtr hmi Nothing + leakIface <- mkWeakPtr hm_iface Nothing + leakDetails <- mkWeakPtr hm_details Nothing + leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable + return $ LeakModIndicators{..} + +-- | Look at the LeakIndicators collected by an earlier call to +-- `getLeakIndicators`, and print messasges if any of them are still +-- alive. +checkLeakIndicators :: DynFlags -> LeakIndicators -> IO () +checkLeakIndicators dflags (LeakIndicators leakmods) = do + performGC + forM_ leakmods $ \LeakModIndicators{..} -> do + deRefWeak leakMod >>= \case + Nothing -> return () + Just hmi -> + report ("HomeModInfo for " ++ + showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi) + deRefWeak leakIface >>= report "ModIface" + deRefWeak leakDetails >>= report "ModDetails" + forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable" + where + report :: String -> Maybe a -> IO () + report _ Nothing = return () + report msg (Just a) = do + addr <- anyToPtr a + putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++ + show (maskTagBits addr)) + + tagBits + | target32Bit (targetPlatform dflags) = 2 + | otherwise = 3 + + maskTagBits :: Ptr a -> Ptr a + maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1)) diff --git a/app-ghc-8.10/GHCi/UI.hs b/app-ghc-8.10/GHCi/UI.hs new file mode 100644 --- /dev/null +++ b/app-ghc-8.10/GHCi/UI.hs @@ -0,0 +1,4225 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- +-- GHC Interactive User Interface +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module GHCi.UI ( + interactiveUI, + GhciSettings(..), + defaultGhciSettings, + ghciCommands, + ghciWelcomeMsg, + -- DAP add. + getLoadedModules, + breakCmd, + deleteCmd, + backCmd, + forwardCmd, + historyCmd, + traceCmd, + stepCmd, + stepLocalCmd, + runStmt, + toBreakIdAndLocation, + forceCmd, + setContext, + keepGoing + ) where + +#include "HsVersions.h" + +-- GHCi +import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' ) +import GHCi.UI.Monad hiding ( args, runStmt ) +import GHCi.UI.Tags +import GHCi.UI.Info +import Debugger + +-- The GHC interface +import GHCi +import GHCi.RemoteTypes +import GHCi.BreakArray +import DynFlags +import ErrUtils hiding (traceCmd) +import Finder +import GhcMonad ( modifySession ) +import qualified GHC +import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), + TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, + GetDocsFailure(..), + getModuleGraph, handleSourceError ) +import HscMain (hscParseDeclsWithLocation, hscParseStmtWithLocation) +import GHC.Hs.ImpExp +import GHC.Hs +import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, + setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc, + hsc_dynLinker ) +import Module +import Name +import Packages ( trusted, getPackageDetails, getInstalledPackageDetails, + listVisibleModuleNames, pprFlag ) +import IfaceSyn ( showToHeader ) +import PprTyThing +import PrelNames +import RdrName ( getGRE_NameQualifier_maybes, getRdrName ) +import SrcLoc +import qualified Lexer + +import StringBuffer +import Outputable hiding ( printForUser, printForUserPartWay ) + +import DynamicLoading ( initializePlugins ) + +-- Other random utilities +import BasicTypes hiding ( isTopLevel ) +import Config +import Digraph +import Encoding +import FastString +import Linker +import Maybes ( orElse, expectJust ) +import NameSet +import Panic hiding ( showException ) +import Util +import qualified GHC.LanguageExtensions as LangExt +import Bag (unitBag) + +-- Haskell Libraries +import System.Console.Haskeline as Haskeline + +import Control.Applicative hiding (empty) +import Control.DeepSeq (deepseq) +import Control.Monad as Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except + +import Data.Array +import qualified Data.ByteString.Char8 as BS +import Data.Char +import Data.Function +import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) +import Data.List ( find, group, intercalate, intersperse, isPrefixOf, + isSuffixOf, nub, partition, sort, sortBy, (\\) ) +import qualified Data.Set as S +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.IntMap.Strict as IntMap +import Data.Time.LocalTime ( getZonedTime ) +import Data.Time.Format ( formatTime, defaultTimeLocale ) +import Data.Version ( showVersion ) +import Prelude hiding ((<>)) + +import Exception hiding (catch) +import Foreign hiding (void) +import GHC.Stack hiding (SrcLoc(..)) + +import System.Directory +import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) +import System.FilePath +import System.Info +import System.IO +import System.IO.Error +import System.IO.Unsafe ( unsafePerformIO ) +import System.Process +import Text.Printf +import Text.Read ( readMaybe ) +import Text.Read.Lex (isSymbolChar) + +import Unsafe.Coerce + +#if !defined(mingw32_HOST_OS) +import System.Posix hiding ( getEnv ) +#else +import qualified System.Win32 +#endif + +import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) +import GHC.IO.Handle ( hFlushAll ) +import GHC.TopHandler ( topHandler ) + +import GHCi.Leak + +------------------------------------------------------------------------------ +-- DAP +------------------------------------------------------------------------------ +import qualified GHCi.DAP.Type as DAP +import Control.Concurrent +----------------------------------------------------------------------------- + +data GhciSettings = GhciSettings { + availableCommands :: [Command], + shortHelpText :: String, + fullHelpText :: String, + defPrompt :: PromptFunction, + defPromptCont :: PromptFunction, + dapContextGhciSettings :: DAP.MVarDAPContext + } + +defaultGhciSettings :: DAP.MVarDAPContext -> GhciSettings +defaultGhciSettings dapCtx = + GhciSettings { + availableCommands = ghciCommands, + shortHelpText = defShortHelpText, + defPrompt = default_prompt, + defPromptCont = default_prompt_cont, + fullHelpText = defFullHelpText, + dapContextGhciSettings = dapCtx + } + +ghciWelcomeMsg :: String +ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ + ": https://www.haskell.org/ghc/ :? for help" + +ghciCommands :: [Command] +ghciCommands = map mkCmd [ + -- 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), + ("disable", keepGoing disableCmd, noCompletion), + ("doc", keepGoing' docCmd, completeIdentifier), + ("edit", keepGoing' editFile, completeFilename), + ("enable", keepGoing enableCmd, noCompletion), + ("etags", keepGoing createETagsFileCmd, completeFilename), + ("force", keepGoing forceCmd, completeExpression), + ("forward", keepGoing forwardCmd, noCompletion), + ("help", keepGoing help, noCompletion), + ("history", keepGoing historyCmd, noCompletion), + ("info", keepGoing' (info False), completeIdentifier), + ("info!", keepGoing' (info True), completeIdentifier), + ("issafe", keepGoing' isSafeCmd, completeModule), + ("kind", keepGoing' (kindOfType False), completeIdentifier), + ("kind!", keepGoing' (kindOfType True), completeIdentifier), + ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), + ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile), + ("list", keepGoing' listCmd, noCompletion), + ("module", keepGoing moduleCmd, completeSetModule), + ("main", keepGoing runMain, completeFilename), + ("print", keepGoing printCmd, completeExpression), + ("quit", quit, noCompletion), + ("reload", keepGoing' reloadModule, noCompletion), + ("reload!", keepGoing' reloadModuleDefer, noCompletion), + ("run", keepGoing runRun, completeFilename), + ("script", keepGoing' scriptCmd, completeFilename), + ("set", keepGoing setCmd, completeSetOptions), + ("seti", keepGoing setiCmd, completeSeti), + ("show", keepGoing showCmd, completeShowOptions), + ("showi", keepGoing showiCmd, completeShowiOptions), + ("sprint", keepGoing sprintCmd, completeExpression), + ("step", keepGoing stepCmd, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), + ("type", keepGoing' typeOfExpr, completeExpression), + ("trace", keepGoing traceCmd, completeExpression), + ("unadd", keepGoingPaths unAddModule, completeFilename), + ("undef", keepGoing undefineMacro, completeMacro), + ("unset", keepGoing unsetOptions, completeSetOptions), + ("where", keepGoing whereCmd, noCompletion), + ("instances", keepGoing' instancesCmd, completeExpression) + ] ++ map mkCmdHidden [ -- hidden commands + ("all-types", keepGoing' allTypesCmd), + ("complete", keepGoing completeCmd), + ("loc-at", keepGoing' locAtCmd), + ("type-at", keepGoing' typeAtCmd), + ("uses", keepGoing' usesCmd) + ] + where + mkCmd (n,a,c) = Command { cmdName = n + , cmdAction = a + , cmdHidden = False + , cmdCompletionFunc = c + } + + mkCmdHidden (n,a) = Command { cmdName = n + , cmdAction = a + , cmdHidden = True + , cmdCompletionFunc = noCompletion + } + +-- 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 = spaces ++ specials ++ symbols + +symbols, specials, spaces :: String +symbols = "!#$%&*+/<=>?@\\^|-~" +specials = "(),;[]`{}" +spaces = " \t\n" + +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 -> liftIO $ hPutStrLn stderr err + Right args -> a args + return False + +defShortHelpText :: String +defShortHelpText = "use :? for help.\n" + +defFullHelpText :: String +defFullHelpText = + " 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" ++ + " :complete [] list completions for partial input string\n" ++ + " :ctags[!] [] create tags file for Vi (default: \"tags\")\n" ++ + " (!: use regex instead of line number)\n" ++ + " :def[!] define command : (later defined command has\n" ++ + " precedence, :: is always a builtin command)\n" ++ + " (!: redefine an existing command name)\n" ++ + " :doc display docs for the given name (experimental)\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" ++ + " (!: do not filter instances)\n" ++ + " :instances display the class instances available for \n" ++ + " :issafe [] display safe haskell information of module \n" ++ + " :kind[!] show the kind of \n" ++ + " (!: also print the normalised type)\n" ++ + " :load[!] [*] ... load module(s) and their dependents\n" ++ + " (!: defer type errors)\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" ++ + " (!: defer type errors)\n" ++ + " :run function [ ...] run the function with the given arguments\n" ++ + " :script run the script \n" ++ + " :type show the type of \n" ++ + " :type +d show the type of , defaulting type variables\n" ++ + " :type +v show the type of , with its specified tyvars\n" ++ + " :unadd ... remove module(s) from the current target set\n" ++ + " :undef undefine user-defined command :\n" ++ + " :: run the builtin 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 N steps (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 breakpoints\n" ++ + " :delete * delete all breakpoints\n" ++ + " :disable ... disable the specified breakpoints\n" ++ + " :disable * disable all breakpoints\n" ++ + " :enable ... enable the specified breakpoints\n" ++ + " :enable * enable all breakpoints\n" ++ + " :force print , forcing unevaluated parts\n" ++ + " :forward [] go forward in the history N step s(after :back)\n" ++ + " :history [] after :trace, show the execution history\n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ + " :print [ ...] show a value without forcing its computation\n" ++ + " :sprint [ ...] simplified 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