diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,7 @@ +20210815 ghci-dap-0.0.16.0 + * [INFO] support ghc-9.0.1. + + 20210131 ghci-dap-0.0.15.0 * [FIX] hda issue #12. * [INFO] support ghc-8.10.3. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,4 +20,4 @@ # Limitation Currently this project is an __experimental__ design and implementation. -* Supported ghc-8.10, ghc-8.8 +* Supported ghc-9.0, ghc-8.10 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.6/GHCMain.hs b/app-ghc-8.6/GHCMain.hs deleted file mode 100644 --- a/app-ghc-8.6/GHCMain.hs +++ /dev/null @@ -1,943 +0,0 @@ -{-# LANGUAGE CPP, NondecreasingIndentation, 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(GHCI) -import GHCi.UI ( interactiveUI, ghciWelcomeMsg, GhciSettings ) -- DAP Modified -#endif - --- Frontend plugins -#if defined(GHCI) -import DynamicLoading ( loadFrontendPlugin ) -import Plugins -#else -import DynamicLoading ( pluginError ) -#endif -import Module ( ModuleName ) - - --- Various other random stuff that we need -import GHC.HandleEncoding -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 SrcLoc -import Util -import Panic -import UniqSupply -import MonadUtils ( liftIO ) -import DynamicLoading ( initializePlugins ) - --- 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 Data.Char -import Data.List -import Data.Maybe - --- 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 - 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 - 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 [] [] - - 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(GHCI) -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" - _ -> 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(GHCI) -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(GHCI) - -- 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 - -showSupportedExtensions :: IO () -showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions - -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 - buckets <- getFastStringTable - let (entries, longest, has_z) = countFS 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 "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 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 '%' - -countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int) -countFS entries longest has_z [] = (entries, longest, has_z) -countFS entries longest has_z (b:bs) = - let - len = length b - longest' = max len longest - entries' = entries + len - has_zs = length (filter hasZEncoding b) - in - countFS entries' longest' (has_z + has_zs) bs - -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 () -#if !defined(GHCI) -doFrontend modname _ = pluginError [modname] -#else -doFrontend modname srcs = do - hsc_env <- getSession - frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname - frontend frontend_plugin - (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs -#endif - --- ----------------------------------------------------------------------------- --- 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 (Trac #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) 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. --} - -foreign import ccall safe "initGCStatistics" - initGCStatistics :: IO () diff --git a/app-ghc-8.6/GHCi/Leak.hs b/app-ghc-8.6/GHCi/Leak.hs deleted file mode 100644 --- a/app-ghc-8.6/GHCi/Leak.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE RecordWildCards, LambdaCase #-} -module GHCi.Leak - ( LeakIndicators - , getLeakIndicators - , checkLeakIndicators - ) where - -import Control.Monad -import GHC -import Outputable -import HscTypes -import UniqDFM -import System.Mem -import System.Mem.Weak - --- 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 _) = - putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive!") diff --git a/app-ghc-8.6/GHCi/UI.hs b/app-ghc-8.6/GHCi/UI.hs deleted file mode 100644 --- a/app-ghc-8.6/GHCi/UI.hs +++ /dev/null @@ -1,3945 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - ------------------------------------------------------------------------------ --- --- GHC Interactive User Interface --- --- (c) The GHC Team 2005-2006 --- ------------------------------------------------------------------------------ - -module GHCi.UI ( - interactiveUI, - GhciSettings(..), - -- defaultGhciSettings, -- DAP Modified - ghciCommands, - ghciWelcomeMsg, - -- DAP add. - defaultGhciSettings, - getLoadedModules, - breakCmd, - deleteCmd, - backCmd, - forwardCmd, - historyCmd, - traceCmd, - stepCmd, - stepLocalCmd, - runStmt, - toBreakIdAndLocation, - forceCmd, - setContext - ) where - -#include "HsVersions.h" - --- GHCi -import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls ) -import GHCi.UI.Monad hiding ( args, runStmt, runDecls ) -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 HsImpExp -import HsSyn -import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, - setInteractivePrintName, hsc_dflags, msObjFilePath ) -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 - --- 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, nub, - partition, sort, sortBy ) -import qualified Data.Set as S -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as M -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 ++ - ": http://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), - ("doc", keepGoing' docCmd, completeIdentifier), - ("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 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) - ] ++ 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" ++ - " :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" ++ - " :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 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 breakpoint\n" ++ - " :delete * delete 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