ghci-dap 0.0.14.0 → 0.0.15.0
raw patch · 26 files changed
+6697/−6236 lines, 26 filesdep +exceptionsdep ~haskell-dapPVP ok
version bump matches the API change (PVP)
Dependencies added: exceptions
Dependency ranges changed: haskell-dap
API changes (from Hackage documentation)
Files
- Changelog.md +5/−0
- LICENSE +1/−30
- README.md +2/−2
- app-ghc-8.10/GHCMain.hs +990/−0
- app-ghc-8.10/GHCi/Leak.hs +74/−0
- app-ghc-8.10/GHCi/UI.hs +4228/−0
- app-ghc-8.10/GHCi/UI/Info.hs +382/−0
- app-ghc-8.10/GHCi/UI/Monad.hs +620/−0
- app-ghc-8.10/GHCi/UI/Tags.hs +216/−0
- app-ghc-8.10/GHCi/Util.hs +16/−0
- app-ghc-8.4/GHCMain.hs +0/−946
- app-ghc-8.4/GHCi/UI.hs +0/−3854
- app-ghc-8.4/GHCi/UI/Info.hs +0/−366
- app-ghc-8.4/GHCi/UI/Monad.hs +0/−493
- app-ghc-8.4/GHCi/UI/Tags.hs +0/−215
- app-ghc-8.6/GHCi/UI.hs +36/−7
- app-ghc-8.6/GHCi/UI/Monad.hs +13/−2
- app-ghc-8.8/GHCi/UI.hs +38/−7
- app-ghc-8.8/GHCi/UI/Monad.hs +12/−2
- app/GHCi/DAP/Command.hs +15/−17
- app/GHCi/DAP/UI.hs +0/−67
- app/GHCi/DAP/Utility.hs +27/−13
- ghci-dap.cabal +22/−25
- src-c-8.4/HsVersions.h +0/−65
- src-c-8.4/PosixSource.h +0/−51
- src-c-8.4/hschooks.c +0/−74
Changelog.md view
@@ -1,3 +1,8 @@+20210131 ghci-dap-0.0.15.0+ * [FIX] hda issue #12.+ * [INFO] support ghc-8.10.3.++ 20200209 ghci-dap-0.0.14.0 * [INFO] support ghc-8.8.2.
LICENSE view
@@ -1,31 +1,2 @@-Copyright Author name here (c) 2015--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Author name here nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+@see https://www.haskell.org/ghc/license.html
README.md view
@@ -1,7 +1,7 @@ # ghci-dap -A GHCi having [DAP](https://code.visualstudio.com/docs/extensions/example-debuggers) interface.+A GHCi with [DAP](https://code.visualstudio.com/docs/extensions/example-debuggers) machine interface. @@ -20,4 +20,4 @@ # Limitation Currently this project is an __experimental__ design and implementation. -* Supported ghc-8.8, ghc-8.6, ghc-8.4+* Supported ghc-8.10, ghc-8.8
+ app-ghc-8.10/GHCMain.hs view
@@ -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<size>++-----------------------------------------------------------------------------+-- 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 <suffix> 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
+ app-ghc-8.10/GHCi/Leak.hs view
@@ -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))
+ app-ghc-8.10/GHCi/UI.hs view
@@ -0,0 +1,4228 @@+{-# 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+ ) 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" +++ " <statement> evaluate/run <statement>\n" +++ " : repeat last command\n" +++ " :{\\n ..lines.. \\n:}\\n multiline command\n" +++ " :add [*]<module> ... add module(s) to the current target set\n" +++ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" +++ " (!: more details; *: all top-level names)\n" +++ " :cd <dir> change directory to <dir>\n" +++ " :cmd <expr> run the commands returned by <expr>::IO String\n" +++ " :complete <dom> [<rng>] <s> list completions for partial input string\n" +++ " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" +++ " (!: use regex instead of line number)\n" +++ " :def[!] <cmd> <expr> define command :<cmd> (later defined command has\n" +++ " precedence, ::<cmd> is always a builtin command)\n" +++ " (!: redefine an existing command name)\n" +++ " :doc <name> display docs for the given name (experimental)\n" +++ " :edit <file> edit file\n" +++ " :edit edit last module\n" +++ " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" +++ " :help, :? display this list of commands\n" +++ " :info[!] [<name> ...] display information about the given names\n" +++ " (!: do not filter instances)\n" +++ " :instances <type> display the class instances available for <type>\n" +++ " :issafe [<mod>] display safe haskell information of module <mod>\n" +++ " :kind[!] <type> show the kind of <type>\n" +++ " (!: also print the normalised type)\n" +++ " :load[!] [*]<module> ... load module(s) and their dependents\n" +++ " (!: defer type errors)\n" +++ " :main [<arguments> ...] run the main function with the given arguments\n" +++ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" +++ " :quit exit GHCi\n" +++ " :reload[!] reload the current module set\n" +++ " (!: defer type errors)\n" +++ " :run function [<arguments> ...] run the function with the given arguments\n" +++ " :script <file> run the script <file>\n" +++ " :type <expr> show the type of <expr>\n" +++ " :type +d <expr> show the type of <expr>, defaulting type variables\n" +++ " :type +v <expr> show the type of <expr>, with its specified tyvars\n" +++ " :unadd <module> ... remove module(s) from the current target set\n" +++ " :undef <cmd> undefine user-defined command :<cmd>\n" +++ " ::<cmd> run the builtin command\n" +++ " :!<command> run the shell command <command>\n" +++ "\n" +++ " -- Commands for debugging:\n" +++ "\n" +++ " :abandon at a breakpoint, abandon current computation\n" +++ " :back [<n>] go back in the history N steps (after :trace)\n" +++ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" +++ " :break <name> set a breakpoint on the specified function\n" +++ " :continue resume after a breakpoint\n" +++ " :delete <number> ... delete the specified breakpoints\n" +++ " :delete * delete all breakpoints\n" +++ " :disable <number> ... disable the specified breakpoints\n" +++ " :disable * disable all breakpoints\n" +++ " :enable <number> ... enable the specified breakpoints\n" +++ " :enable * enable all breakpoints\n" +++ " :force <expr> print <expr>, forcing unevaluated parts\n" +++ " :forward [<n>] go forward in the history N step s(after :back)\n" +++ " :history [<n>] after :trace, show the execution history\n" +++ " :list show the source code around current breakpoint\n" +++ " :list <identifier> show the source code for <identifier>\n" +++ " :list [<module>] <line> show the source code around line number <line>\n" +++ " :print [<name> ...] show a value without forcing its computation\n" +++ " :sprint [<name> ...] simplified version of :print\n" +++ " :step single-step after stopping at a breakpoint\n"+++ " :step <expr> single-step into <expr>\n"+++ " :steplocal single-step within the current top-level binding\n"+++ " :stepmodule single-step restricted to the current module\n"+++ " :trace trace after stopping at a breakpoint\n"+++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++++ "\n" +++ " -- Commands for changing settings:\n" +++ "\n" +++ " :set <option> ... set options\n" +++ " :seti <option> ... set options for interactive evaluation only\n" +++ " :set local-config { source | ignore }\n" +++ " set whether to source .ghci in current dir\n" +++ " (loading untrusted config is a security issue)\n" +++ " :set args <arg> ... set the arguments returned by System.getArgs\n" +++ " :set prog <progname> set the value returned by System.getProgName\n" +++ " :set prompt <prompt> set the prompt used in GHCi\n" +++ " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" +++ " :set prompt-function <expr> set the function to handle the prompt\n" +++ " :set prompt-cont-function <expr>\n" +++ " set the function to handle the continuation prompt\n" +++ " :set editor <cmd> set the command used for :edit\n" +++ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" +++ " :unset <option> ... unset options\n" +++ "\n" +++ " Options for ':set' and ':unset':\n" +++ "\n" +++ " +m allow multiline commands\n" +++ " +r revert top-level expressions after each evaluation\n" +++ " +s print timing/memory stats after each evaluation\n" +++ " +t print type after evaluation\n" +++ " +c collect type/location info after loading modules\n" +++ " -<flags> most GHC command line flags can also be set here\n" +++ " (eg. -v2, -XFlexibleInstances, etc.)\n" +++ " for GHCi-specific flags, see User's Guide,\n"+++ " Flag reference, Interactive-mode options\n" +++ "\n" +++ " -- Commands for displaying information:\n" +++ "\n" +++ " :show bindings show the current bindings made at the prompt\n" +++ " :show breaks show the active breakpoints\n" +++ " :show context show the breakpoint context\n" +++ " :show imports show the current imports\n" +++ " :show linker show current linker state\n" +++ " :show modules show the currently loaded modules\n" +++ " :show packages show the currently active package flags\n" +++ " :show paths show the currently active search paths\n" +++ " :show language show the currently active language flags\n" +++ " :show targets show the current set of targets\n" +++ " :show <setting> show value of <setting>, which is one of\n" +++ " [args, prog, editor, stop]\n" +++ " :showi language show language flags for interactive evaluation\n" +++ "\n"++findEditor :: IO String+findEditor = do+ getEnv "EDITOR"+ `catchIO` \_ -> do+#if defined(mingw32_HOST_OS)+ win <- System.Win32.getWindowsDirectory+ return (win </> "notepad.exe")+#else+ return ""+#endif++default_progname, default_stop :: String+default_progname = "<interactive>"+default_stop = ""++default_prompt, default_prompt_cont :: PromptFunction+default_prompt = generatePromptFunctionFromString "%s> "+default_prompt_cont = generatePromptFunctionFromString "%s| "++default_args :: [String]+default_args = []++interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]+ -> Ghc ()+interactiveUI config srcs maybe_exprs = do+ -- HACK! If we happen to get into an infinite loop (eg the user+ -- types 'let x=x in x' at the prompt), then the thread will block+ -- on a blackhole, and become unreachable during GC. The GC will+ -- detect that it is unreachable and send it the NonTermination+ -- exception. However, since the thread is unreachable, everything+ -- it refers to might be finalized, including the standard Handles.+ -- This sounds like a bug, but we don't have a good solution right+ -- now.+ _ <- liftIO $ newStablePtr stdin+ _ <- liftIO $ newStablePtr stdout+ _ <- liftIO $ newStablePtr stderr++ -- Initialise buffering for the *interpreted* I/O system+ (nobuffering, flush) <- initInterpBuffering++ -- The initial set of DynFlags used for interactive evaluation is the same+ -- as the global DynFlags, plus -XExtendedDefaultRules and+ -- -XNoMonomorphismRestriction.+ -- See note [Changing language extensions for interactive evaluation] #10857+ dflags <- getDynFlags+ let dflags' = (xopt_set_unlessExplSpec+ LangExt.ExtendedDefaultRules xopt_set)+ . (xopt_set_unlessExplSpec+ LangExt.MonomorphismRestriction xopt_unset)+ $ dflags+ GHC.setInteractiveDynFlags dflags'++ lastErrLocationsRef <- liftIO $ newIORef []+ progDynFlags <- GHC.getProgramDynFlags+ _ <- GHC.setProgramDynFlags $+ -- Ensure we don't override the user's log action lest we break+ -- -ddump-json (#14078)+ progDynFlags { log_action = ghciLogAction (log_action progDynFlags)+ lastErrLocationsRef }++ when (isNothing maybe_exprs) $ do+ -- Only for GHCi (not runghc and ghc -e):++ -- Turn buffering off for the compiled program's stdout/stderr+ turnOffBuffering_ nobuffering+ -- Turn buffering off for GHCi's stdout+ liftIO $ hFlush stdout+ liftIO $ hSetBuffering stdout NoBuffering+ -- We don't want the cmd line to buffer any input that might be+ -- intended for the program, so unbuffer stdin.+ liftIO $ hSetBuffering stdin NoBuffering+ liftIO $ hSetBuffering stderr NoBuffering+#if defined(mingw32_HOST_OS)+ -- On Unix, stdin will use the locale encoding. The IO library+ -- doesn't do this on Windows (yet), so for now we use UTF-8,+ -- for consistency with GHC 6.10 and to make the tests work.+ liftIO $ hSetEncoding stdin utf8+#endif++ default_editor <- liftIO $ findEditor+ eval_wrapper <- mkEvalWrapper default_progname default_args+ let prelude_import = simpleImportDecl preludeModuleName+ startGHCi (runGHCi srcs maybe_exprs)+ GHCiState{ progname = default_progname,+ args = default_args,+ evalWrapper = eval_wrapper,+ prompt = defPrompt config,+ prompt_cont = defPromptCont config,+ stop = default_stop,+ editor = default_editor,+ options = [],+ localConfig = SourceLocalConfig,+ -- We initialize line number as 0, not 1, because we use+ -- current line number while reporting errors which is+ -- incremented after reading a line.+ line_number = 0,+ break_ctr = 0,+ breaks = IntMap.empty,+ tickarrays = emptyModuleEnv,+ ghci_commands = availableCommands config,+ ghci_macros = [],+ last_command = Nothing,+ cmd_wrapper = (cmdSuccess =<<),+ cmdqueue = [],+ remembered_ctx = [],+ transient_ctx = [],+ extra_imports = [],+ prelude_imports = [prelude_import],+ ghc_e = isJust maybe_exprs,+ short_help = shortHelpText config,+ long_help = fullHelpText config,+ lastErrorLocations = lastErrLocationsRef,+ mod_infos = M.empty,+ flushStdHandles = flush,+ noBuffering = nobuffering,+ dapContextGHCiState = dapContextGhciSettings config+ }++ return ()++{-+Note [Changing language extensions for interactive evaluation]+--------------------------------------------------------------+GHCi maintains two sets of options:++- The "loading options" apply when loading modules+- The "interactive options" apply when evaluating expressions and commands+ typed at the GHCi prompt.++The loading options are mostly created in ghc/Main.hs:main' from the command+line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options+are copied to the interactive options.++These interactive options (but not the loading options!) are supplemented+unconditionally by setting ExtendedDefaultRules ON and+MonomorphismRestriction OFF. The unconditional setting of these options+eventually overwrite settings already specified at the command line.++Therefore instead of unconditionally setting ExtendedDefaultRules and+NoMonomorphismRestriction for the interactive options, we use the function+'xopt_set_unlessExplSpec' to first check whether the extension has already+specified at the command line.++The ghci config file has not yet been processed.+-}++resetLastErrorLocations :: GhciMonad m => m ()+resetLastErrorLocations = do+ st <- getGHCiState+ liftIO $ writeIORef (lastErrorLocations st) []++ghciLogAction :: LogAction -> IORef [(FastString, Int)] -> LogAction+ghciLogAction old_log_action lastErrLocations+ dflags flag severity srcSpan style msg = do+ old_log_action dflags flag severity srcSpan style msg+ case severity of+ SevError -> case srcSpan of+ RealSrcSpan rsp -> modifyIORef lastErrLocations+ (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])+ _ -> return ()+ _ -> return ()++withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a+withGhcAppData right left = do+ either_dir <- tryIO (getAppUserDataDirectory "ghc")+ case either_dir of+ Right dir ->+ do createDirectoryIfMissing False dir `catchIO` \_ -> return ()+ right dir+ _ -> left++runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+ dflags <- getDynFlags+ let+ ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags++ app_user_dir = liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "ghci.conf")))+ (return Nothing)++ home_dir = do+ either_dir <- liftIO $ tryIO (getEnv "HOME")+ case either_dir of+ Right home -> return (Just (home </> ".ghci"))+ _ -> return Nothing++ canonicalizePath' :: FilePath -> IO (Maybe FilePath)+ canonicalizePath' fp = liftM Just (canonicalizePath fp)+ `catchIO` \_ -> return Nothing++ sourceConfigFile :: FilePath -> GHCi ()+ sourceConfigFile file = do+ exists <- liftIO $ doesFileExist file+ when exists $ do+ either_hdl <- liftIO $ tryIO (openFile file ReadMode)+ case either_hdl of+ Left _e -> return ()+ -- NOTE: this assumes that runInputT won't affect the terminal;+ -- can we assume this will always be the case?+ -- This would be a good place for runFileInputT.+ Right hdl ->+ do runInputTWithPrefs defaultPrefs defaultSettings $+ runCommands $ fileLoop hdl+ liftIO (hClose hdl `catchIO` \_ -> return ())+ -- Don't print a message if this is really ghc -e (#11478).+ -- Also, let the user silence the message with -v0+ -- (the default verbosity in GHCi is 1).+ when (isNothing maybe_exprs && verbosity dflags > 0) $+ liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)++ --++ setGHCContextFromGHCiState++ processedCfgs <- if ignore_dot_ghci+ then pure []+ else do+ userCfgs <- do+ paths <- catMaybes <$> sequence [ app_user_dir, home_dir ]+ checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths+ liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths++ localCfg <- do+ let path = ".ghci"+ ok <- liftIO $ checkFileAndDirPerms path+ if ok then liftIO $ canonicalizePath' path else pure Nothing++ mapM_ sourceConfigFile userCfgs+ -- Process the global and user .ghci+ -- (but not $CWD/.ghci or CLI args, yet)++ behaviour <- localConfig <$> getGHCiState++ processedLocalCfg <- case localCfg of+ Just path | path `notElem` userCfgs ->+ -- don't read .ghci twice if CWD is $HOME+ case behaviour of+ SourceLocalConfig -> localCfg <$ sourceConfigFile path+ IgnoreLocalConfig -> pure Nothing+ _ -> pure Nothing++ pure $ maybe id (:) processedLocalCfg userCfgs++ let arg_cfgs = reverse $ ghciScripts dflags+ -- -ghci-script are collected in reverse order+ -- We don't require that a script explicitly added by -ghci-script+ -- is owned by the current user. (#6017)++ mapM_ sourceConfigFile $ nub arg_cfgs \\ processedCfgs+ -- Dedup, and remove any configs we already processed.+ -- Importantly, if $PWD/.ghci was ignored due to configuration,+ -- explicitly specifying it does cause it to be processed.++ -- Perform a :load for files given on the GHCi command line+ -- When in -e mode, if the load fails then we want to stop+ -- immediately rather than going on to evaluate the expression.+ when (not (null paths)) $ do+ ok <- ghciHandle (\e -> do showException e; return Failed) $+ -- TODO: this is a hack.+ runInputTWithPrefs defaultPrefs defaultSettings $+ loadModule paths+ when (isJust maybe_exprs && failed ok) $+ liftIO (exitWith (ExitFailure 1))++ installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)++ -- if verbosity is greater than 0, or we are connected to a+ -- terminal, display the prompt in the interactive loop.+ -- is_tty <- liftIO (hIsTerminalDevice stdin)+ is_tty <- liftIO (return True) -- DAP modified.+ let show_prompt = verbosity dflags > 0 || is_tty++ -- reset line number+ modifyGHCiState $ \st -> st{line_number=0}++ case maybe_exprs of+ Nothing ->+ do+ -- enter the interactive loop+ runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+ Just exprs -> do+ -- just evaluate the expression we were given+ enqueueCommands exprs+ let hdle e = do st <- getGHCiState+ -- flush the interpreter's stdout/stderr on exit (#3890)+ flushInterpBuffers+ -- Jump through some hoops to get the+ -- current progname in the exception text:+ -- <progname>: <exception>+ liftIO $ withProgName (progname st)+ $ topHandler e+ -- this used to be topHandlerFastExit, see #2228+ runInputTWithPrefs defaultPrefs defaultSettings $ do+ -- make `ghc -e` exit nonzero on invalid input, see #7962+ _ <- runCommands' hdle+ (Just $ hdle (toException $ ExitFailure 1) >> return ())+ (return Nothing)+ return ()++ -- and finally, exit+ liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."++runGHCiInput :: InputT GHCi a -> GHCi a+runGHCiInput f = do+ dflags <- getDynFlags+ let ghciHistory = gopt Opt_GhciHistory dflags+ let localGhciHistory = gopt Opt_LocalGhciHistory dflags+ currentDirectory <- liftIO $ getCurrentDirectory++ histFile <- case (ghciHistory, localGhciHistory) of+ (True, True) -> return (Just (currentDirectory </> ".ghci_history"))+ (True, _) -> liftIO $ withGhcAppData+ (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)+ _ -> return Nothing++ runInputT+ (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})+ f++-- | How to get the next input line from the user+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)+nextInputLine show_prompt is_tty+ | is_tty = do+ prmpt <- if show_prompt then lift mkPrompt else return ""+ r <- getInputLine prmpt+ incrementLineNo+ return r+ | otherwise = do+ when show_prompt $ lift mkPrompt >>= liftIO . putStr+ fileLoop stdin++-- NOTE: We only read .ghci files if they are owned by the current user,+-- and aren't world writable (files owned by root are ok, see #9324).+-- Otherwise, we could be accidentally running code planted by+-- a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else. I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "." always refers to+-- the same directory while a process is running.++checkFileAndDirPerms :: FilePath -> IO Bool+checkFileAndDirPerms file = do+ file_ok <- checkPerms file+ -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will+ -- print some confusing and useless warnings in some cases (e.g. in+ -- travis). Note that we can't add a test for this, as all ghci tests should+ -- run with -ignore-dot-ghci, which means we never get here.+ if file_ok then checkPerms (getDirectory file) else return False+ where+ getDirectory f = case takeDirectory f of+ "" -> "."+ d -> d++checkPerms :: FilePath -> IO Bool+#if defined(mingw32_HOST_OS)+checkPerms _ = return True+#else+checkPerms file =+ handleIO (\_ -> return False) $ do+ st <- getFileStatus file+ me <- getRealUserID+ let mode = System.Posix.fileMode st+ ok = (fileOwner st == me || fileOwner st == 0) &&+ groupWriteMode /= mode `intersectFileModes` groupWriteMode &&+ otherWriteMode /= mode `intersectFileModes` otherWriteMode+ unless ok $+ -- #8248: Improving warning to include a possible fix.+ putStrLn $ "*** WARNING: " ++ file +++ " is writable by someone else, IGNORING!" +++ "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"+ return ok+#endif++incrementLineNo :: GhciMonad m => m ()+incrementLineNo = modifyGHCiState incLineNo+ where+ incLineNo st = st { line_number = line_number st + 1 }++fileLoop :: GhciMonad m => Handle -> m (Maybe String)+fileLoop hdl = do+ l <- liftIO $ tryIO $ hGetLine hdl+ case l of+ Left e | isEOFError e -> return Nothing+ | -- as we share stdin with the program, the program+ -- might have already closed it, so we might get a+ -- handle-closed exception. We therefore catch that+ -- too.+ isIllegalOperation e -> return Nothing+ | InvalidArgument <- etype -> return Nothing+ | otherwise -> liftIO $ ioError e+ where etype = ioeGetErrorType e+ -- treat InvalidArgument in the same way as EOF:+ -- this can happen if the user closed stdin, or+ -- perhaps did getContents which closes stdin at+ -- EOF.+ Right l' -> do+ incrementLineNo+ return (Just l')++formatCurrentTime :: String -> IO String+formatCurrentTime format =+ getZonedTime >>= return . (formatTime defaultTimeLocale format)++getUserName :: IO String+getUserName = do+#if defined(mingw32_HOST_OS)+ getEnv "USERNAME"+ `catchIO` \e -> do+ putStrLn $ show e+ return ""+#else+ getLoginName+#endif++getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)+getInfoForPrompt = do+ st <- getGHCiState+ imports <- GHC.getContext+ resumes <- GHC.getResumeContext++ context_bit <-+ case resumes of+ [] -> return empty+ r:_ -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (brackets (ppr (GHC.resumeSpan r)) <> space)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (brackets (ppr (negate ix) <> char ':'+ <+> ppr pan) <> space)++ let+ dots | _:rs <- resumes, not (null rs) = text "... "+ | otherwise = empty++ rev_imports = reverse imports -- rightmost are the most recent++ myIdeclName d | Just m <- ideclAs d = unLoc m+ | otherwise = unLoc (ideclName d)++ modules_names =+ ['*':(moduleNameString m) | IIModule m <- rev_imports] +++ [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]+ line = 1 + line_number st++ return (dots <> context_bit, modules_names, line)++parseCallEscape :: String -> (String, String)+parseCallEscape s+ | not (all isSpace beforeOpen) = ("", "")+ | null sinceOpen = ("", "")+ | null sinceClosed = ("", "")+ | null cmd = ("", "")+ | otherwise = (cmd, tail sinceClosed)+ where+ (beforeOpen, sinceOpen) = span (/='(') s+ (cmd, sinceClosed) = span (/=')') (tail sinceOpen)++checkPromptStringForErrors :: String -> Maybe String+checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =+ case parseCallEscape xs of+ ("", "") -> Just ("Incorrect %call syntax. " +++ "Should be %call(a command and arguments).")+ (_, afterClosed) -> checkPromptStringForErrors afterClosed+checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs+checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs+checkPromptStringForErrors "" = Nothing++generatePromptFunctionFromString :: String -> PromptFunction+generatePromptFunctionFromString promptS modules_names line =+ processString promptS+ where+ processString :: String -> GHCi SDoc+ processString ('%':'s':xs) =+ liftM2 (<>) (return modules_list) (processString xs)+ where+ modules_list = hsep $ map text modules_names+ processString ('%':'l':xs) =+ liftM2 (<>) (return $ ppr line) (processString xs)+ processString ('%':'d':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%a %b %d"+ processString ('%':'t':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"+ processString ('%':'T':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"+ processString ('%':'@':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M %P"+ processString ('%':'A':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M"+ processString ('%':'u':xs) =+ liftM2 (<>) (liftM text user_name) (processString xs)+ where+ user_name = liftIO $ getUserName+ processString ('%':'w':xs) =+ liftM2 (<>) (liftM text current_directory) (processString xs)+ where+ current_directory = liftIO $ getCurrentDirectory+ processString ('%':'o':xs) =+ liftM ((text os) <>) (processString xs)+ processString ('%':'a':xs) =+ liftM ((text arch) <>) (processString xs)+ processString ('%':'N':xs) =+ liftM ((text compilerName) <>) (processString xs)+ processString ('%':'V':xs) =+ liftM ((text $ showVersion compilerVersion) <>) (processString xs)+ processString ('%':'c':'a':'l':'l':xs) = do+ respond <- liftIO $ do+ (code, out, err) <-+ readProcessWithExitCode+ (head list_words) (tail list_words) ""+ `catchIO` \e -> return (ExitFailure 1, "", show e)+ case code of+ ExitSuccess -> return out+ _ -> do+ hPutStrLn stderr err+ return ""+ liftM ((text respond) <>) (processString afterClosed)+ where+ (cmd, afterClosed) = parseCallEscape xs+ list_words = words cmd+ processString ('%':'%':xs) =+ liftM ((char '%') <>) (processString xs)+ processString (x:xs) =+ liftM (char x <>) (processString xs)+ processString "" =+ return empty++mkPrompt :: GHCi String+mkPrompt = do+ st <- getGHCiState+ dflags <- getDynFlags+ (context, modules_names, line) <- getInfoForPrompt++ prompt_string <- (prompt st) modules_names line+ let prompt_doc = context <> prompt_string++ return (showSDoc dflags prompt_doc)++queryQueue :: GhciMonad m => m (Maybe String)+queryQueue = do+ st <- getGHCiState+ case cmdqueue st of+ [] -> return Nothing+ c:cs -> do setGHCiState st{ cmdqueue = cs }+ return (Just c)++-- Reconfigurable pretty-printing Ticket #5461+installInteractivePrint :: GHC.GhcMonad m => Maybe String -> Bool -> m ()+installInteractivePrint Nothing _ = return ()+installInteractivePrint (Just ipFun) exprmode = do+ ok <- trySuccess $ do+ names <- GHC.parseName ipFun+ let name = case names of+ name':_ -> name'+ [] -> panic "installInteractivePrint"+ modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name+ in he{hsc_IC = new_ic})+ return Succeeded++ when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))++-- | The main read-eval-print loop+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()++runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+ -> Maybe (GHCi ()) -- ^ Source error handler+ -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+ -- We want to return () here, but have to return (Maybe Bool)+ -- because gmask is not polymorphic enough: we want to use+ -- unmask at two different types.+runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do+ b <- ghandle (\e -> case fromException e of+ Just UserInterrupt -> return $ Just False+ _ -> case fromException e of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other ->+ liftIO (Exception.throwIO e))+ (unmask $ runOneCommand eh gCmd)+ case b of+ Nothing -> return Nothing+ Just success -> do+ unless success $ maybe (return ()) lift sourceErrorHandler+ unmask $ runCommands' eh sourceErrorHandler gCmd++-- | Evaluate a single line of user input (either :<command> or Haskell code).+-- A result of Nothing means there was no more input to process.+-- Otherwise the result is Just b where b is True if the command succeeded;+-- this is relevant only to ghc -e, which will exit with status 1+-- if the command was unsuccessful. GHCi will continue in either case.+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+runOneCommand eh gCmd = do+ -- run a previously queued command if there is one, otherwise get new+ -- input from user+ mb_cmd0 <- noSpace (lift queryQueue)+ mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0+ case mb_cmd1 of+ Nothing -> return Nothing+ Just c -> do+ st <- getGHCiState+ ghciHandle (\e -> lift $ eh e >>= return . Just) $+ handleSourceError printErrorAndFail $+ cmd_wrapper st $ doCommand c+ -- source error's are handled by runStmt+ -- is the handler necessary here?+ where+ printErrorAndFail err = do+ GHC.printException err+ return $ Just False -- Exit ghc -e, but not GHCi++ noSpace q = q >>= maybe (return Nothing)+ (\c -> case removeSpaces c of+ "" -> noSpace q+ ":{" -> multiLineCmd q+ _ -> return (Just c) )+ multiLineCmd q = do+ st <- getGHCiState+ let p = prompt st+ setGHCiState st{ prompt = prompt_cont st }+ mb_cmd <- collectCommand q "" `GHC.gfinally`+ modifyGHCiState (\st' -> st' { prompt = p })+ return mb_cmd+ -- we can't use removeSpaces for the sublines here, so+ -- multiline commands are somewhat more brittle against+ -- fileformat errors (such as \r in dos input on unix),+ -- we get rid of any extra spaces for the ":}" test;+ -- we also avoid silent failure if ":}" is not found;+ -- and since there is no (?) valid occurrence of \r (as+ -- opposed to its String representation, "\r") inside a+ -- ghci command, we replace any such with ' ' (argh:-(+ collectCommand q c = q >>=+ maybe (liftIO (ioError collectError))+ (\l->if removeSpaces l == ":}"+ then return (Just c)+ else collectCommand q (c ++ "\n" ++ map normSpace l))+ where normSpace '\r' = ' '+ normSpace x = x+ -- SDM (2007-11-07): is userError the one to use here?+ collectError = userError "unterminated multiline command :{ .. :}"++ -- | Handle a line of input+ doCommand :: String -> InputT GHCi CommandResult++ -- command+ doCommand stmt | stmt'@(':' : cmd) <- removeSpaces stmt = do+ (stats, result) <- runWithStats (const Nothing) $ specialCommand cmd+ let processResult True = Nothing+ processResult False = Just True+ return $ CommandComplete stmt' (processResult <$> result) stats++ -- haskell+ doCommand stmt = do+ -- if 'stmt' was entered via ':{' it will contain '\n's+ let stmt_nl_cnt = length [ () | '\n' <- stmt ]+ ml <- lift $ isOptionSet Multiline+ if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input+ then do+ fst_line_num <- line_number <$> getGHCiState+ mb_stmt <- checkInputForLayout stmt gCmd+ case mb_stmt of+ Nothing -> return CommandIncomplete+ Just ml_stmt -> do+ -- temporarily compensate line-number for multi-line input+ (stats, result) <- runAndPrintStats runAllocs $ lift $+ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion+ return $+ CommandComplete ml_stmt (Just . runSuccess <$> result) stats+ else do -- single line input and :{ - multiline input+ last_line_num <- line_number <$> getGHCiState+ -- reconstruct first line num from last line num and stmt+ let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)+ | otherwise = last_line_num -- single line input+ stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]+ stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines+ -- temporarily compensate line-number for multi-line input+ (stats, result) <- runAndPrintStats runAllocs $ lift $+ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion+ return $ CommandComplete stmt' (Just . runSuccess <$> result) stats++ -- runStmt wrapper for temporarily overridden line-number+ runStmtWithLineNum :: Int -> String -> SingleStep+ -> GHCi (Maybe GHC.ExecResult)+ runStmtWithLineNum lnum stmt step = do+ st0 <- getGHCiState+ setGHCiState st0 { line_number = lnum }+ result <- runStmt stmt step+ -- restore original line_number+ getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }+ return result++ -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'+ dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s+ , all isSpace l0 = dropLeadingWhiteLines r+ | otherwise = s+++-- #4316+-- lex the input. If there is an unclosed layout context, request input+checkInputForLayout+ :: GhciMonad m => String -> m (Maybe String) -> m (Maybe String)+checkInputForLayout stmt getStmt = do+ dflags' <- getDynFlags+ let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule+ st0 <- getGHCiState+ let buf' = stringToStringBuffer stmt+ loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1+ pstate = Lexer.mkPState dflags buf' loc+ case Lexer.unP goToEnd pstate of+ (Lexer.POk _ False) -> return $ Just stmt+ _other -> do+ st1 <- getGHCiState+ let p = prompt st1+ setGHCiState st1{ prompt = prompt_cont st1 }+ mb_stmt <- ghciHandle (\ex -> case fromException ex of+ Just UserInterrupt -> return Nothing+ _ -> case fromException ex of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other -> liftIO (Exception.throwIO ex))+ getStmt+ modifyGHCiState (\st' -> st' { prompt = p })+ -- the recursive call does not recycle parser state+ -- as we use a new string buffer+ case mb_stmt of+ Nothing -> return Nothing+ Just str -> if str == ""+ then return $ Just stmt+ else do+ checkInputForLayout (stmt++"\n"++str) getStmt+ where goToEnd = do+ eof <- Lexer.nextIsEOF+ if eof+ then Lexer.activeContext+ else Lexer.lexer False return >> goToEnd++enqueueCommands :: GhciMonad m => [String] -> m ()+enqueueCommands cmds = do+ -- make sure we force any exceptions in the commands while we're+ -- still inside the exception handler, otherwise bad things will+ -- happen (see #10501)+ cmds `deepseq` return ()+ modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }++-- | Entry point to execute some haskell code from user.+-- The return value True indicates success, as in `runOneCommand`.+runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)+runStmt input step = do+ dflags <- GHC.getInteractiveDynFlags+ -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`+ -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The+ -- declarations and statements are not affected.+ -- See Note [Deferred type errors in GHCi] in typecheck/TcRnDriver.hs+ st <- getGHCiState+ let source = progname st+ let line = line_number st++ if | GHC.isStmt dflags input -> do+ hsc_env <- GHC.getSession+ mb_stmt <- liftIO (runInteractiveHsc hsc_env (hscParseStmtWithLocation source line input))+ case mb_stmt of+ Nothing ->+ -- empty statement / comment+ return (Just exec_complete)+ Just stmt ->+ run_stmt stmt++ | GHC.isImport dflags input -> run_import++ -- Every import declaration should be handled by `run_import`. As GHCi+ -- in general only accepts one command at a time, we simply throw an+ -- exception when the input contains multiple commands of which at least+ -- one is an import command (see #10663).+ | GHC.hasImport dflags input -> throwGhcException+ (CmdLineError "error: expecting a single import declaration")++ -- Otherwise assume a declaration (or a list of declarations)+ -- Note: `GHC.isDecl` returns False on input like+ -- `data Infix a b = a :@: b; infixl 4 :@:`+ -- and should therefore not be used here.+ | otherwise -> do+ hsc_env <- GHC.getSession+ decls <- liftIO (hscParseDeclsWithLocation hsc_env source line input)+ run_decls decls+ where+ exec_complete = GHC.ExecComplete (Right []) 0++ run_import = do+ addImportToContext input+ return (Just exec_complete)++ run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult)+ run_stmt stmt = do+ m_result <- GhciMonad.runStmt stmt input step+ case m_result of+ Nothing -> return Nothing+ Just result -> Just <$> afterRunStmt (const True) result++ -- `x = y` (a declaration) should be treated as `let x = y` (a statement).+ -- The reason is because GHCi wasn't designed to support `x = y`, but then+ -- b98ff3 (#7253) added support for it, except it did not do a good job and+ -- caused problems like:+ --+ -- - not adding the binders defined this way in the necessary places caused+ -- `x = y` to not work in some cases (#12091).+ -- - some GHCi command crashed after `x = y` (#15721)+ -- - warning generation did not work for `x = y` (#11606)+ -- - because `x = y` is a declaration (instead of a statement) differences+ -- in generated code caused confusion (#16089)+ --+ -- Instead of dealing with all these problems individually here we fix this+ -- mess by just treating `x = y` as `let x = y`.+ run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult)+ -- Only turn `FunBind` and `VarBind` into statements, other bindings+ -- (e.g. `PatBind`) need to stay as decls.+ run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt l bind)+ run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt l bind)+ -- Note that any `x = y` declarations below will be run as declarations+ -- instead of statements (e.g. `...; x = y; ...`)+ run_decls decls = do+ -- In the new IO library, read handles buffer data even if the Handle+ -- is set to NoBuffering. This causes problems for GHCi where there+ -- are really two stdin Handles. So we flush any bufferred data in+ -- GHCi's stdin Handle here (only relevant if stdin is attached to+ -- a file, otherwise the read buffer can't be flushed).+ _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runDecls' decls+ forM m_result $ \result ->+ afterRunStmt (const True) (GHC.ExecComplete (Right result) 0)++ mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs+ mk_stmt loc bind =+ let l = L loc+ in l (LetStmt noExtField (l (HsValBinds noExtField (ValBinds noExtField (unitBag (l bind)) []))))++-- | Clean up the GHCi environment after a statement has run+afterRunStmt :: GhciMonad m+ => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult+afterRunStmt step_here run_result = do+ resumes <- GHC.getResumeContext+ case run_result of+ GHC.ExecComplete{..} ->+ case execResult of+ Left ex -> liftIO $ Exception.throwIO ex+ Right names -> do+ show_types <- isOptionSet ShowType+ when show_types $ printTypeOfNames names+ GHC.ExecBreak names mb_info+ | isNothing mb_info ||+ step_here (GHC.resumeSpan $ head resumes) -> do+ mb_id_loc <- toBreakIdAndLocation mb_info+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+ if (null bCmd)+ then printStoppedAtBreakInfo (head resumes) names+ else enqueueCommands [bCmd]+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ return ()+ | otherwise -> resume step_here GHC.SingleStep >>=+ afterRunStmt step_here >> return ()++ flushInterpBuffers+ withSignalHandlers $ do+ b <- isOptionSet RevertCAFs+ when b revertCAFs++ return run_result++runSuccess :: Maybe GHC.ExecResult -> Bool+runSuccess run_result+ | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True+ | otherwise = False++runAllocs :: Maybe GHC.ExecResult -> Maybe Integer+runAllocs m = do+ res <- m+ case res of+ GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)+ _ -> Nothing++toBreakIdAndLocation :: GhciMonad m+ => Maybe GHC.BreakInfo -> m (Maybe (Int, BreakLocation))+toBreakIdAndLocation Nothing = return Nothing+toBreakIdAndLocation (Just inf) = do+ let md = GHC.breakInfo_module inf+ nm = GHC.breakInfo_number inf+ st <- getGHCiState+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),+ breakModule loc == md,+ breakTick loc == nm ]++printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()+printStoppedAtBreakInfo res names = do+ printForUser $ pprStopped res+ -- printTypeOfNames session names+ let namesSorted = sortBy compareNames names+ tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted+ docs <- mapM pprTypeAndContents [i | AnId i <- tythings]+ printForUserPartWay $ vcat docs++printTypeOfNames :: GHC.GhcMonad m => [Name] -> m ()+printTypeOfNames names+ = mapM_ (printTypeOfName ) $ sortBy compareNames names++compareNames :: Name -> Name -> Ordering+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2+ where compareWith n = (getOccString n, getSrcSpan n)++printTypeOfName :: GHC.GhcMonad m => Name -> m ()+printTypeOfName n+ = do maybe_tything <- GHC.lookupName n+ case maybe_tything of+ Nothing -> return ()+ Just thing -> printTyThing thing+++data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand++-- | Entry point for execution a ':<command>' input from user+specialCommand :: String -> InputT GHCi Bool+specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)+specialCommand str = do+ let (cmd,rest) = break isSpace str+ maybe_cmd <- lookupCommand cmd+ htxt <- short_help <$> getGHCiState+ case maybe_cmd of+ GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)+ BadCommand ->+ do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"+ ++ htxt)+ return False+ NoLastCommand ->+ do liftIO $ hPutStr stdout ("there is no last command to perform\n"+ ++ htxt)+ return False++shellEscape :: MonadIO m => String -> m Bool+shellEscape str = liftIO (system str >> return False)++lookupCommand :: GhciMonad m => String -> m (MaybeCommand)+lookupCommand "" = do+ st <- getGHCiState+ case last_command st of+ Just c -> return $ GotCommand c+ Nothing -> return NoLastCommand+lookupCommand str = do+ mc <- lookupCommand' str+ modifyGHCiState (\st -> st { last_command = mc })+ return $ case mc of+ Just c -> GotCommand c+ Nothing -> BadCommand++lookupCommand' :: GhciMonad m => String -> m (Maybe Command)+lookupCommand' ":" = return Nothing+lookupCommand' str' = do+ macros <- ghci_macros <$> getGHCiState+ ghci_cmds <- ghci_commands <$> getGHCiState++ let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds++ let (str, xcmds) = case str' of+ ':' : rest -> (rest, []) -- "::" selects a builtin command+ _ -> (str', macros) -- otherwise include macros in lookup++ lookupExact s = find $ (s ==) . cmdName+ lookupPrefix s = find $ (s `isPrefixOptOf`) . cmdName++ -- hidden commands can only be matched exact+ builtinPfxMatch = lookupPrefix str ghci_cmds_nohide++ -- first, look for exact match (while preferring macros); then, look+ -- for first prefix match (preferring builtins), *unless* a macro+ -- overrides the builtin; see #8305 for motivation+ return $ lookupExact str xcmds <|>+ lookupExact str ghci_cmds <|>+ (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>+ builtinPfxMatch <|>+ lookupPrefix str xcmds++-- This predicate is for prefix match with a command-body and+-- suffix match with an option, such as `!`.+-- The current implementation assumes only the `!` character+-- as the option delimiter.+-- See also #17345+isPrefixOptOf :: String -> String -> Bool+isPrefixOptOf s x = let (body, opt) = break (== '!') s+ in (body `isPrefixOf` x) && (opt `isSuffixOf` x)++getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)+getCurrentBreakSpan = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (Just (GHC.resumeSpan r))+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (Just pan)++getCallStackAtCurrentBreakpoint :: GHC.GhcMonad m => m (Maybe [String])+getCallStackAtCurrentBreakpoint = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ hsc_env <- GHC.getSession+ Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))++getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)+getCurrentBreakModule = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ return $ Just $ GHC.getHistoryModule hist++-----------------------------------------------------------------------------+--+-- Commands+--+-----------------------------------------------------------------------------++noArgs :: MonadIO m => m () -> String -> m ()+noArgs m "" = m+noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"++withSandboxOnly :: GHC.GhcMonad m => String -> m () -> m ()+withSandboxOnly cmd this = do+ dflags <- getDynFlags+ if not (gopt Opt_GhciSandbox dflags)+ then printForUser (text cmd <+>+ ptext (sLit "is not supported with -fno-ghci-sandbox"))+ else this++-----------------------------------------------------------------------------+-- :help++help :: GhciMonad m => String -> m ()+help _ = do+ txt <- long_help `fmap` getGHCiState+ liftIO $ putStr txt++-----------------------------------------------------------------------------+-- :info++info :: GHC.GhcMonad m => Bool -> String -> m ()+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")+info allInfo s = handleSourceError GHC.printException $ do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ sdocs <- mapM (infoThing allInfo) (words s)+ mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs++infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc+infoThing allInfo str = do+ names <- GHC.parseName str+ mb_stuffs <- mapM (GHC.getInfo allInfo) names+ let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)+ (catMaybes mb_stuffs)+ return $ vcat (intersperse (text "") $ map pprInfo filtered)++ -- Filter out names whose parent is also there Good+ -- example is '[]', which is both a type and data+ -- constructor in the same type+filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+ = filterOut has_parent xs+ where+ all_names = mkNameSet (map (getName . get_thing) xs)+ has_parent x = case tyThingParent_maybe (get_thing x) of+ Just p -> getName p `elemNameSet` all_names+ Nothing -> False++pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+pprInfo (thing, fixity, cls_insts, fam_insts, docs)+ = docs+ $$ pprTyThingInContextLoc thing+ $$ show_fixity+ $$ vcat (map GHC.pprInstance cls_insts)+ $$ vcat (map GHC.pprFamInst fam_insts)+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)++-----------------------------------------------------------------------------+-- :main++runMain :: GhciMonad m => String -> m ()+runMain s = case toArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args ->+ do dflags <- getDynFlags+ let main = fromMaybe "main" (mainFunIs dflags)+ -- Wrap the main function in 'void' to discard its value instead+ -- of printing it (#9086). See Haskell 2010 report Chapter 5.+ doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"++-----------------------------------------------------------------------------+-- :run++runRun :: GhciMonad m => String -> m ()+runRun s = case toCmdArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: GhciMonad m => [String] -> String -> m ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++ show args ++ " (" ++ cmd ++ ")"]++-----------------------------------------------------------------------------+-- :cd++changeDirectory :: GhciMonad m => String -> m ()+changeDirectory "" = do+ -- :cd on its own changes to the user's home directory+ either_dir <- liftIO $ tryIO getHomeDirectory+ case either_dir of+ Left _e -> return ()+ Right dir -> changeDirectory dir+changeDirectory dir = do+ graph <- GHC.getModuleGraph+ when (not (null $ GHC.mgModSummaries graph)) $+ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."+ -- delete targets and all eventually defined breakpoints (#1620)+ clearAllTargets+ setContextAfterLoad False []+ GHC.workingDirectoryChanged+ dir' <- expandPath dir+ liftIO $ setCurrentDirectory dir'+ dflags <- getDynFlags+ -- With -fexternal-interpreter, we have to change the directory of the subprocess too.+ -- (this gives consistent behaviour with and without -fexternal-interpreter)+ when (gopt Opt_ExternalInterpreter dflags) $ do+ hsc_env <- GHC.getSession+ fhv <- compileGHCiExpr $+ "System.Directory.setCurrentDirectory " ++ show dir'+ liftIO $ evalIO hsc_env fhv++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+ handleSourceError (\e -> do GHC.printException e+ return Failed) $ do+ act++-----------------------------------------------------------------------------+-- :edit++editFile :: GhciMonad m => String -> m ()+editFile str =+ do file <- if null str then chooseEditFile else expandPath str+ st <- getGHCiState+ errs <- liftIO $ readIORef $ lastErrorLocations st+ let cmd = editor st+ when (null cmd)+ $ throwGhcException (CmdLineError "editor not set, use :set editor")+ lineOpt <- liftIO $ do+ let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)+ `catchIO` (\_ -> return False)++ curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs+ return $ case curFileErrs of+ (_, line):_ -> " +" ++ show line+ _ -> ""+ let cmdArgs = ' ':(file ++ lineOpt)+ code <- liftIO $ system (cmd ++ cmdArgs)++ when (code == ExitSuccess)+ $ reloadModule ""++-- The user didn't specify a file so we pick one for them.+-- Our strategy is to pick the first module that failed to load,+-- or otherwise the first target.+--+-- XXX: Can we figure out what happened if the depndecy analysis fails+-- (e.g., because the porgrammeer mistyped the name of a module)?+-- XXX: Can we figure out the location of an error to pass to the editor?+-- XXX: if we could figure out the list of errors that occured during the+-- last load/reaload, then we could start the editor focused on the first+-- of those.+chooseEditFile :: GHC.GhcMonad m => m String+chooseEditFile =+ do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x++ graph <- GHC.getModuleGraph+ failed_graph <-+ GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries graph)+ let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing+ pick xs = case xs of+ x : _ -> GHC.ml_hs_file (GHC.ms_location x)+ _ -> Nothing++ case pick (order failed_graph) of+ Just file -> return file+ Nothing ->+ do targets <- GHC.getTargets+ case msum (map fromTarget targets) of+ Just file -> return file+ Nothing -> throwGhcException (CmdLineError "No files to edit.")++ where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f+ fromTarget _ = Nothing -- when would we get a module target?+++-----------------------------------------------------------------------------+-- :def++defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()+defineMacro _ (':':_) = liftIO $ putStrLn+ "macro name cannot start with a colon"+defineMacro _ ('!':_) = liftIO $ putStrLn+ "macro name cannot start with an exclamation mark"+ -- little code duplication allows to grep error msg+defineMacro overwrite s = do+ let (macro_name, definition) = break isSpace s+ macros <- ghci_macros <$> getGHCiState+ let defined = map cmdName macros+ if null macro_name+ then if null defined+ then liftIO $ putStrLn "no macros defined"+ else liftIO $ putStr ("the following macros are defined:\n" +++ unlines defined)+ else do+ isCommand <- isJust <$> lookupCommand' macro_name+ let check_newname+ | macro_name `elem` defined = throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is already defined. " ++ hint))+ | isCommand = throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint))+ | otherwise = return ()+ hint = " Use ':def!' to overwrite."++ unless overwrite check_newname+ -- compile the expression+ handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr definition+ -- > ghciStepIO . definition :: String -> IO String+ let stringTy = nlHsTyVar stringTy_RDR+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)+ `mkHsApp` (nlHsPar expr)+ tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)+ new_expr = L (getLoc expr) $ ExprWithTySig noExtField body tySig+ hv <- GHC.compileParsedExprRemote new_expr++ let newCmd = Command { cmdName = macro_name+ , cmdAction = lift . runMacro hv+ , cmdHidden = False+ , cmdCompletionFunc = noCompletion+ }++ -- later defined macros have precedence+ modifyGHCiState $ \s ->+ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]+ in s { ghci_macros = newCmd : filtered }++runMacro+ :: GhciMonad m+ => GHC.ForeignHValue -- String -> IO String+ -> String+ -> m Bool+runMacro fun s = do+ hsc_env <- GHC.getSession+ str <- liftIO $ evalStringToIOString hsc_env fun s+ enqueueCommands (lines str)+ return False+++-----------------------------------------------------------------------------+-- :undef++undefineMacro :: GhciMonad m => String -> m ()+undefineMacro str = mapM_ undef (words str)+ where undef macro_name = do+ cmds <- ghci_macros <$> getGHCiState+ if (macro_name `notElem` map cmdName cmds)+ then throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is not defined"))+ else do+ -- This is a tad racy but really, it's a shell+ modifyGHCiState $ \s ->+ s { ghci_macros = filter ((/= macro_name) . cmdName)+ (ghci_macros s) }+++-----------------------------------------------------------------------------+-- :cmd++cmdCmd :: GhciMonad m => String -> m ()+cmdCmd str = handleSourceError GHC.printException $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr str+ -- > ghciStepIO str :: IO String+ let new_expr = step `mkHsApp` expr+ hv <- GHC.compileParsedExprRemote new_expr++ hsc_env <- GHC.getSession+ cmds <- liftIO $ evalString hsc_env hv+ enqueueCommands (lines cmds)++-- | Generate a typed ghciStepIO expression+-- @ghciStepIO :: Ty String -> IO String@.+getGhciStepIO :: GHC.GhcMonad m => m (LHsExpr GhcPs)+getGhciStepIO = do+ ghciTyConName <- GHC.getGHCiMonad+ let stringTy = nlHsTyVar stringTy_RDR+ ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy+ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar (getRdrName ghciStepIoMName)+ tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)+ return $ noLoc $ ExprWithTySig noExtField body tySig++-----------------------------------------------------------------------------+-- :check++checkModule :: GhciMonad m => String -> m ()+checkModule m = do+ let modl = GHC.mkModuleName m+ ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl+ dflags <- getDynFlags+ liftIO $ putStrLn $ showSDoc dflags $+ case GHC.moduleInfo r of+ cm | Just scope <- GHC.modInfoTopLevelScope cm ->+ let+ (loc, glob) = ASSERT( all isExternalName scope )+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope+ in+ (text "global names: " <+> ppr glob) $$+ (text "local names: " <+> ppr loc)+ _ -> empty+ return True+ afterLoad (successIf ok) False++-----------------------------------------------------------------------------+-- :doc++docCmd :: GHC.GhcMonad m => String -> m ()+docCmd "" =+ throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")+docCmd s = do+ -- TODO: Maybe also get module headers for module names+ names <- GHC.parseName s+ e_docss <- mapM GHC.getDocs names+ sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss+ let sdocs' = vcat (intersperse (text "") sdocs)+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'++-- TODO: also print arg docs.+pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc+pprDocs (mb_decl_docs, _arg_docs) =+ maybe+ (text "<has no documentation>")+ (text . unpackHDS)+ mb_decl_docs++handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc+handleGetDocsFailure no_docs = do+ dflags <- getDynFlags+ let msg = showPpr dflags no_docs+ throwGhcException $ case no_docs of+ NameHasNoModule {} -> Sorry msg+ NoDocsInIface {} -> InstallationError msg+ InteractiveName -> ProgramError msg++-----------------------------------------------------------------------------+-- :instances++instancesCmd :: String -> InputT GHCi ()+instancesCmd "" =+ throwGhcException (CmdLineError "syntax: ':instances <type-you-want-instances-for>'")+instancesCmd s = do+ handleSourceError GHC.printException $ do+ ty <- GHC.parseInstanceHead s+ res <- GHC.getInstancesForType ty++ printForUser $ vcat $ map ppr res++-----------------------------------------------------------------------------+-- :load, :add, :reload++-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets+-- '-fdefer-type-errors' again if it has not been set before.+wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a+wrapDeferTypeErrors load =+ gbracket+ (do+ -- Force originalFlags to avoid leaking the associated HscEnv+ !originalFlags <- getDynFlags+ void $ GHC.setProgramDynFlags $+ setGeneralFlag' Opt_DeferTypeErrors originalFlags+ return originalFlags)+ (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)+ (\_ -> load)++loadModule :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag+loadModule fs = do+ (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)+ either (liftIO . Exception.throwIO) return result++-- | @:load@ command+loadModule_ :: GhciMonad m => [FilePath] -> m ()+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))++loadModuleDefer :: GhciMonad m => [FilePath] -> m ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag+loadModule' files = do+ let (filenames, phases) = unzip files+ exp_filenames <- mapM expandPath filenames+ let files' = zip exp_filenames phases+ targets <- mapM (uncurry GHC.guessTarget) files'++ -- NOTE: we used to do the dependency anal first, so that if it+ -- fails we didn't throw away the current set of modules. This would+ -- require some re-working of the GHC interface, so we'll leave it+ -- as a ToDo for now.++ hsc_env <- GHC.getSession++ -- Grab references to the currently loaded modules so that we can+ -- see if they leak.+ let !dflags = hsc_dflags hsc_env+ leak_indicators <- if gopt Opt_GhciLeakCheck dflags+ then liftIO $ getLeakIndicators hsc_env+ else return (panic "no leak indicators")++ -- unload first+ _ <- GHC.abandonAll+ clearAllTargets++ GHC.setTargets targets+ success <- doLoadAndCollectInfo False LoadAllTargets+ when (gopt Opt_GhciLeakCheck dflags) $+ liftIO $ checkLeakIndicators dflags leak_indicators+ return success++-- | @:add@ command+addModule :: GhciMonad m => [FilePath] -> m ()+addModule files = do+ revertCAFs -- always revert CAFs on load/add.+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+ targets' <- filterM checkTarget targets+ -- remove old targets with the same id; e.g. for :add *M+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ]+ mapM_ GHC.addTarget targets'+ _ <- doLoadAndCollectInfo False LoadAllTargets+ return ()+ where+ checkTarget :: GHC.GhcMonad m => Target -> m Bool+ checkTarget (Target (TargetModule m) _ _) = checkTargetModule m+ checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f++ checkTargetModule :: GHC.GhcMonad m => ModuleName -> m Bool+ checkTargetModule m = do+ hsc_env <- GHC.getSession+ result <- liftIO $+ Finder.findImportedModule hsc_env m (Just (fsLit "this"))+ case result of+ Found _ _ -> return True+ _ -> (liftIO $ putStrLn $+ "Module " ++ moduleNameString m ++ " not found") >> return False++ checkTargetFile :: String -> IO Bool+ checkTargetFile f = do+ exists <- (doesFileExist f) :: IO Bool+ unless exists $ putStrLn $ "File " ++ f ++ " not found"+ return exists++-- | @:unadd@ command+unAddModule :: GhciMonad m => [FilePath] -> m ()+unAddModule files = do+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]+ _ <- doLoadAndCollectInfo False LoadAllTargets+ return ()++-- | @:reload@ command+reloadModule :: GhciMonad m => String -> m ()+reloadModule m = void $ doLoadAndCollectInfo True loadTargets+ where+ loadTargets | null m = LoadAllTargets+ | otherwise = LoadUpTo (GHC.mkModuleName m)++reloadModuleDefer :: GhciMonad m => String -> m ()+reloadModuleDefer = wrapDeferTypeErrors . reloadModule++-- | Load/compile targets and (optionally) collect module-info+--+-- This collects the necessary SrcSpan annotated type information (via+-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,+-- and @:uses@ commands.+--+-- Meta-info collection is not enabled by default and needs to be+-- enabled explicitly via @:set +c@. The reason is that collecting+-- the type-information for all sub-spans can be quite expensive, and+-- since those commands are designed to be used by editors and+-- tooling, it's useless to collect this data for normal GHCi+-- sessions.+doLoadAndCollectInfo :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag+doLoadAndCollectInfo retain_context howmuch = do+#if MIN_VERSION_GLASGOW_HASKELL(8,10,3,0)+ resetOptByteCodeIfUnboxed -- #18955+#endif+ doCollectInfo <- isOptionSet CollectInfo++ doLoad retain_context howmuch >>= \case+ Succeeded | doCollectInfo -> do+ mod_summaries <- GHC.mgModSummaries <$> getModuleGraph+ loaded <- filterM GHC.isLoaded $ map GHC.ms_mod_name mod_summaries+ v <- mod_infos <$> getGHCiState+ !newInfos <- collectInfo v loaded+ modifyGHCiState (\st -> st { mod_infos = newInfos })+ return Succeeded+ flag -> return flag+++#if MIN_VERSION_GLASGOW_HASKELL(8,10,3,0)+-- An `OPTIONS_GHC -fbyte-code` pragma at the beginning of a module sets the+-- flag `Opt_ByteCodeIfUnboxed` locally for this module. This stops automatic+-- compilation of this module to object code, if the module uses (or depends+-- on a module using) the UnboxedSums/Tuples extensions.+-- However a GHCi `:set -fbyte-code` command sets the flag Opt_ByteCodeIfUnboxed+-- globally to all modules. This triggered #18955. This function unsets the+-- flag from the global DynFlags before they are copied to the module-specific+-- DynFlags.+-- This is a temporary workaround until GHC 9.0.1, which allows disabling+-- this feature at a finer-grained level by way of the+-- -fno-object-code-if-unboxed flag. See !4531.+resetOptByteCodeIfUnboxed :: GhciMonad m => m ()+resetOptByteCodeIfUnboxed = do+ dflags <- getDynFlags+ when (gopt Opt_ByteCodeIfUnboxed dflags) $ do+ _ <- GHC.setProgramDynFlags $ gopt_unset dflags Opt_ByteCodeIfUnboxed+ pure ()+ pure ()+#endif++doLoad :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag+doLoad retain_context howmuch = do+ -- turn off breakpoints before we load: we can't turn them off later, because+ -- the ModBreaks will have gone away.+ discardActiveBreakPoints++ resetLastErrorLocations+ -- Enable buffering stdout and stderr as we're compiling. Keeping these+ -- handles unbuffered will just slow the compilation down, especially when+ -- compiling in parallel.+ gbracket (liftIO $ do hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering)+ (\_ ->+ liftIO $ do hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering) $ \_ -> do+ ok <- trySuccess $ GHC.load howmuch+ afterLoad ok retain_context+ return ok+++afterLoad+ :: GhciMonad m+ => SuccessFlag+ -> Bool -- keep the remembered_ctx, as far as possible (:reload)+ -> m ()+afterLoad ok retain_context = do+ revertCAFs -- always revert CAFs on load.+ discardTickArrays+ loaded_mods <- getLoadedModules+ modulesLoadedMsg ok loaded_mods+ setContextAfterLoad retain_context loaded_mods++setContextAfterLoad :: GhciMonad m => Bool -> [GHC.ModSummary] -> m ()+setContextAfterLoad keep_ctxt [] = do+ setContextKeepingPackageModules keep_ctxt []+setContextAfterLoad keep_ctxt ms = do+ -- load a target if one is available, otherwise load the topmost module.+ targets <- GHC.getTargets+ case [ m | Just m <- map (findTarget ms) targets ] of+ [] ->+ let graph = GHC.mkModuleGraph ms+ graph' = flattenSCCs (GHC.topSortModuleGraph True graph Nothing)+ in load_this (last graph')+ (m:_) ->+ load_this m+ where+ findTarget mds t+ = case filter (`matches` t) mds of+ [] -> Nothing+ (m:_) -> Just m++ summary `matches` Target (TargetModule m) _ _+ = GHC.ms_mod_name summary == m+ summary `matches` Target (TargetFile f _) _ _+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'+ _ `matches` _+ = False++ load_this summary | m <- GHC.ms_mod summary = do+ is_interp <- GHC.moduleIsInterpreted m+ dflags <- getDynFlags+ let star_ok = is_interp && not (safeLanguageOn dflags)+ -- We import the module with a * iff+ -- - it is interpreted, and+ -- - -XSafe is off (it doesn't allow *-imports)+ let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]+ | otherwise = [mkIIDecl (GHC.moduleName m)]+ setContextKeepingPackageModules keep_ctxt new_ctx+++-- | Keep any package modules (except Prelude) when changing the context.+setContextKeepingPackageModules+ :: GhciMonad m+ => Bool -- True <=> keep all of remembered_ctx+ -- False <=> just keep package imports+ -> [InteractiveImport] -- new context+ -> m ()+setContextKeepingPackageModules keep_ctx trans_ctx = do++ st <- getGHCiState+ let rem_ctx = remembered_ctx st+ new_rem_ctx <- if keep_ctx then return rem_ctx+ else keepPackageImports rem_ctx+ setGHCiState st{ remembered_ctx = new_rem_ctx,+ transient_ctx = filterSubsumed new_rem_ctx trans_ctx }+ setGHCContextFromGHCiState++-- | Filters a list of 'InteractiveImport', clearing out any home package+-- imports so only imports from external packages are preserved. ('IIModule'+-- counts as a home package import, because we are only able to bring a+-- full top-level into scope when the source is available.)+keepPackageImports+ :: GHC.GhcMonad m => [InteractiveImport] -> m [InteractiveImport]+keepPackageImports = filterM is_pkg_import+ where+ is_pkg_import :: GHC.GhcMonad m => InteractiveImport -> m Bool+ is_pkg_import (IIModule _) = return False+ is_pkg_import (IIDecl d)+ = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)+ case e :: Either SomeException Module of+ Left _ -> return False+ Right m -> return (not (isHomeModule m))+ where+ mod_name = unLoc (ideclName d)+++modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()+modulesLoadedMsg ok mods = do+ dflags <- getDynFlags+ unqual <- GHC.getPrintUnqual++ msg <- if gopt Opt_ShowLoadedModules dflags+ then do+ mod_names <- mapM mod_name mods+ let mod_commas+ | null mods = text "none."+ | otherwise = hsep (punctuate comma mod_names) <> text "."+ return $ status <> text ", modules loaded:" <+> mod_commas+ else do+ return $ status <> text ","+ <+> speakNOf (length mods) (text "module") <+> "loaded."++ when (verbosity dflags > 0) $+ liftIO $ putStrLn $ showSDocForUser dflags unqual msg+ where+ status = case ok of+ Failed -> text "Failed"+ Succeeded -> text "Ok"++ mod_name mod = do+ is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod+ return $ if is_interpreted+ then ppr (GHC.ms_mod mod)+ else ppr (GHC.ms_mod mod)+ <+> parens (text $ normalise $ msObjFilePath mod)+ -- Fix #9887++-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors+-- and printing 'throwE' strings to 'stderr'+runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()+runExceptGhcMonad act = handleSourceError GHC.printException $+ either handleErr pure =<<+ runExceptT act+ where+ handleErr sdoc = do+ dflags <- getDynFlags+ liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc++-- | Inverse of 'runExceptT' for \"pure\" computations+-- (c.f. 'except' for 'Except')+exceptT :: Applicative m => Either e a -> ExceptT e m a+exceptT = ExceptT . pure++-----------------------------------------------------------------------------+-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.++typeOfExpr :: GHC.GhcMonad m => String -> m ()+typeOfExpr str = handleSourceError GHC.printException $ do+ let (mode, expr_str) = case break isSpace str of+ ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)+ ("+v", rest) -> (GHC.TM_NoInst, dropWhile isSpace rest)+ _ -> (GHC.TM_Inst, str)+ ty <- GHC.exprType mode expr_str+ printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]++-----------------------------------------------------------------------------+-- | @:type-at@ command++typeAtCmd :: GhciMonad m => String -> m ()+typeAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- lift $ mod_infos <$> getGHCiState+ (info, ty) <- findType infos span' sample+ lift $ printForUserModInfo (modinfoInfo info)+ (sep [text sample,nest 2 (dcolon <+> ppr ty)])++-----------------------------------------------------------------------------+-- | @:uses@ command++usesCmd :: GhciMonad m => String -> m ()+usesCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- lift $ mod_infos <$> getGHCiState+ uses <- findNameUses infos span' sample+ forM_ uses (liftIO . putStrLn . showSrcSpan)++-----------------------------------------------------------------------------+-- | @:loc-at@ command++locAtCmd :: GhciMonad m => String -> m ()+locAtCmd str = runExceptGhcMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- lift $ mod_infos <$> getGHCiState+ (_,_,sp) <- findLoc infos span' sample+ liftIO . putStrLn . showSrcSpan $ sp++-----------------------------------------------------------------------------+-- | @:all-types@ command++allTypesCmd :: GhciMonad m => String -> m ()+allTypesCmd _ = runExceptGhcMonad $ do+ infos <- lift $ mod_infos <$> getGHCiState+ forM_ (M.elems infos) $ \mi ->+ forM_ (modinfoSpans mi) (lift . printSpan)+ where+ printSpan span'+ | Just ty <- spaninfoType span' = do+ df <- getDynFlags+ let tyInfo = unwords . words $+ showSDocForUser df alwaysQualify (pprTypeForUser ty)+ liftIO . putStrLn $+ showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo+ | otherwise = return ()++-----------------------------------------------------------------------------+-- Helpers for locAtCmd/typeAtCmd/usesCmd++-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>+parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)+parseSpanArg s = do+ (fp,s0) <- readAsString (skipWs s)+ s0' <- skipWs1 s0+ (sl,s1) <- readAsInt s0'+ s1' <- skipWs1 s1+ (sc,s2) <- readAsInt s1'+ s2' <- skipWs1 s2+ (el,s3) <- readAsInt s2'+ s3' <- skipWs1 s3+ (ec,s4) <- readAsInt s3'++ trailer <- case s4 of+ [] -> Right ""+ _ -> skipWs1 s4++ let fs = mkFastString fp+ span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)+ -- End column of RealSrcSpan is the column+ -- after the end of the span.+ (mkRealSrcLoc fs el (ec + 1))++ return (span',trailer)+ where+ readAsInt :: String -> Either SDoc (Int,String)+ readAsInt "" = Left "Premature end of string while expecting Int"+ readAsInt s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")++ readAsString :: String -> Either SDoc (String,String)+ readAsString s0+ | '"':_ <- s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> leftRes+ | s_rest@(_:_,_) <- breakWs s0 = Right s_rest+ | otherwise = leftRes+ where+ leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")++ skipWs1 :: String -> Either SDoc String+ skipWs1 (c:cs) | isWs c = Right (skipWs cs)+ skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))++ isWs = (`elem` [' ','\t'])+ skipWs = dropWhile isWs+ breakWs = break isWs+++-- | Pretty-print \"real\" 'SrcSpan's as+-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@+-- while simply unpacking 'UnhelpfulSpan's+showSrcSpan :: SrcSpan -> String+showSrcSpan (UnhelpfulSpan s) = unpackFS s+showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn++-- | Variant of 'showSrcSpan' for 'RealSrcSpan's+showRealSrcSpan :: RealSrcSpan -> String+showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc+ , ")-(", show el, ",", show ec, ")"+ ]+ where+ fp = unpackFS (srcSpanFile spn)+ sl = srcSpanStartLine spn+ sc = srcSpanStartCol spn+ el = srcSpanEndLine spn+ -- The end column is the column after the end of the span see the+ -- RealSrcSpan module+ ec = let ec' = srcSpanEndCol spn in if ec' == 0 then 0 else ec' - 1++-----------------------------------------------------------------------------+-- | @:kind@ command++kindOfType :: GHC.GhcMonad m => Bool -> String -> m ()+kindOfType norm str = handleSourceError GHC.printException $ do+ (ty, kind) <- GHC.typeKind norm str+ printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind+ , ppWhen norm $ equals <+> pprTypeForUser ty ]++-----------------------------------------------------------------------------+-- :quit++quit :: Monad m => String -> m Bool+quit _ = return True+++-----------------------------------------------------------------------------+-- :script++-- running a script file #1363++scriptCmd :: String -> InputT GHCi ()+scriptCmd ws = do+ case words ws of+ [s] -> runScript s+ _ -> throwGhcException (CmdLineError "syntax: :script <filename>")++runScript :: String -- ^ filename+ -> InputT GHCi ()+runScript filename = do+ filename' <- expandPath filename+ either_script <- liftIO $ tryIO (openFile filename' ReadMode)+ case either_script of+ Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "+ ++(ioeGetErrorString _err))+ Right script -> do+ st <- getGHCiState+ let prog = progname st+ line = line_number st+ setGHCiState st{progname=filename',line_number=0}+ scriptLoop script+ liftIO $ hClose script+ new_st <- getGHCiState+ setGHCiState new_st{progname=prog,line_number=line}+ where scriptLoop script = do+ res <- runOneCommand handler $ fileLoop script+ case res of+ Nothing -> return ()+ Just s -> if s+ then scriptLoop script+ else return ()++-----------------------------------------------------------------------------+-- :issafe++-- Displaying Safe Haskell properties of a module++isSafeCmd :: GHC.GhcMonad m => String -> m ()+isSafeCmd m =+ case words m of+ [s] | looksLikeModuleName s -> do+ md <- lookupModule s+ isSafeModule md+ [] -> do md <- guessCurrentModule "issafe"+ isSafeModule md+ _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")++isSafeModule :: GHC.GhcMonad m => Module -> m ()+isSafeModule m = do+ mb_mod_info <- GHC.getModuleInfo m+ when (isNothing mb_mod_info)+ (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)++ dflags <- getDynFlags+ let iface = GHC.modInfoIface $ fromJust mb_mod_info+ when (isNothing iface)+ (throwGhcException $ CmdLineError $ "can't load interface file for module: " +++ (GHC.moduleNameString $ GHC.moduleName m))++ (msafe, pkgs) <- GHC.moduleTrustReqs m+ let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface+ pkg = if packageTrusted dflags m then "trusted" else "untrusted"+ (good, bad) = tallyPkgs dflags pkgs++ -- print info to user...+ liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"+ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")+ when (not $ S.null good)+ (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " +++ (intercalate ", " $ map (showPpr dflags) (S.toList good)))+ case msafe && S.null bad of+ True -> liftIO $ putStrLn $ mname ++ " is trusted!"+ False -> do+ when (not $ null bad)+ (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "+ ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))+ liftIO $ putStrLn $ mname ++ " is NOT trusted!"++ where+ mname = GHC.moduleNameString $ GHC.moduleName m++ packageTrusted dflags md+ | thisPackage dflags == moduleUnitId md = True+ | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)++ tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)+ | otherwise = S.partition part deps+ where part pkg = trusted $ getInstalledPackageDetails dflags pkg++-----------------------------------------------------------------------------+-- :browse++-- Browsing a module's contents++browseCmd :: GHC.GhcMonad m => Bool -> String -> m ()+browseCmd bang m =+ case words m of+ ['*':s] | looksLikeModuleName s -> do+ md <- wantInterpretedModule s+ browseModule bang md False+ [s] | looksLikeModuleName s -> do+ md <- lookupModule s+ browseModule bang md True+ [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")+ browseModule bang md True+ _ -> throwGhcException (CmdLineError "syntax: :browse <module>")++guessCurrentModule :: GHC.GhcMonad m => String -> m Module+-- Guess which module the user wants to browse. Pick+-- modules that are interpreted first. The most+-- recently-added module occurs last, it seems.+guessCurrentModule cmd+ = do imports <- GHC.getContext+ when (null imports) $ throwGhcException $+ CmdLineError (':' : cmd ++ ": no current module")+ case (head imports) of+ IIModule m -> GHC.findModule m Nothing+ IIDecl d -> GHC.findModule (unLoc (ideclName d))+ (fmap sl_fs $ ideclPkgQual d)++-- without bang, show items in context of their parents and omit children+-- with bang, show class methods and data constructors separately, and+-- indicate import modules, to aid qualifying unqualified names+-- with sorted, sort items alphabetically+browseModule :: GHC.GhcMonad m => Bool -> Module -> Bool -> m ()+browseModule bang modl exports_only = do+ -- :browse reports qualifiers wrt current context+ unqual <- GHC.getPrintUnqual++ mb_mod_info <- GHC.getModuleInfo modl+ case mb_mod_info of+ Nothing -> throwGhcException (CmdLineError ("unknown module: " +++ GHC.moduleNameString (GHC.moduleName modl)))+ Just mod_info -> do+ dflags <- getDynFlags+ let names+ | exports_only = GHC.modInfoExports mod_info+ | otherwise = GHC.modInfoTopLevelScope mod_info+ `orElse` []++ -- sort alphabetically name, but putting locally-defined+ -- identifiers first. We would like to improve this; see #1799.+ sorted_names = loc_sort local ++ occ_sort external+ where+ (local,external) = ASSERT( all isExternalName names )+ partition ((==modl) . nameModule) names+ occ_sort = sortBy (compare `on` nameOccName)+ -- try to sort by src location. If the first name in our list+ -- has a good source location, then they all should.+ loc_sort ns+ | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)+ = sortBy (compare `on` nameSrcSpan) ns+ | otherwise+ = occ_sort ns++ mb_things <- mapM GHC.lookupName sorted_names+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)++ rdr_env <- GHC.getGRE++ let things | bang = catMaybes mb_things+ | otherwise = filtered_things+ pretty | bang = pprTyThing showToHeader+ | otherwise = pprTyThingInContext showToHeader++ labels [] = text "-- not currently imported"+ labels l = text $ intercalate "\n" $ map qualifier l++ qualifier :: Maybe [ModuleName] -> String+ qualifier = maybe "-- defined locally"+ (("-- imported via "++) . intercalate ", "+ . map GHC.moduleNameString)+ importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env++ modNames :: [[Maybe [ModuleName]]]+ modNames = map (importInfo . GHC.getName) things++ -- annotate groups of imports with their import modules+ -- the default ordering is somewhat arbitrary, so we group+ -- by header and sort groups; the names themselves should+ -- really come in order of source appearance.. (trac #1799)+ annotate mts = concatMap (\(m,ts)->labels m:ts)+ $ sortBy cmpQualifiers $ grp mts+ where cmpQualifiers =+ compare `on` (map (fmap (map moduleNameFS)) . fst)+ grp [] = []+ grp mts@((m,_):_) = (m,map snd g) : grp ng+ where (g,ng) = partition ((==m).fst) mts++ let prettyThings, prettyThings' :: [SDoc]+ prettyThings = map pretty things+ prettyThings' | bang = annotate $ zip modNames prettyThings+ | otherwise = prettyThings+ liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')+ -- ToDo: modInfoInstances currently throws an exception for+ -- package modules. When it works, we can do this:+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))+++-----------------------------------------------------------------------------+-- :module++-- Setting the module context. For details on context handling see+-- "remembered_ctx" and "transient_ctx" in GhciMonad.++moduleCmd :: GhciMonad m => String -> m ()+moduleCmd str+ | all sensible strs = cmd+ | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")+ where+ (cmd, strs) =+ case str of+ '+':stuff -> rest addModulesToContext stuff+ '-':stuff -> rest remModulesFromContext stuff+ stuff -> rest setContext stuff++ rest op stuff = (op as bs, stuffs)+ where (as,bs) = partitionWith starred stuffs+ stuffs = words stuff++ sensible ('*':m) = looksLikeModuleName m+ sensible m = looksLikeModuleName m++ starred ('*':m) = Left (GHC.mkModuleName m)+ starred m = Right (GHC.mkModuleName m)+++-- -----------------------------------------------------------------------------+-- Four ways to manipulate the context:+-- (a) :module +<stuff>: addModulesToContext+-- (b) :module -<stuff>: remModulesFromContext+-- (c) :module <stuff>: setContext+-- (d) import <module>...: addImportToContext++addModulesToContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+addModulesToContext starred unstarred = restoreContextOnFailure $ do+ addModulesToContext_ starred unstarred++addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+addModulesToContext_ starred unstarred = do+ mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)+ setGHCContextFromGHCiState++remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+remModulesFromContext starred unstarred = do+ -- we do *not* call restoreContextOnFailure here. If the user+ -- is trying to fix up a context that contains errors by removing+ -- modules, we don't want GHC to silently put them back in again.+ mapM_ rm (starred ++ unstarred)+ setGHCContextFromGHCiState+ where+ rm :: GhciMonad m => ModuleName -> m ()+ rm str = do+ m <- moduleName <$> lookupModuleName str+ let filt = filter ((/=) m . iiModuleName)+ modifyGHCiState $ \st ->+ st { remembered_ctx = filt (remembered_ctx st)+ , transient_ctx = filt (transient_ctx st) }++setContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+setContext starred unstarred = restoreContextOnFailure $ do+ modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }+ -- delete the transient context+ addModulesToContext_ starred unstarred++addImportToContext :: GhciMonad m => String -> m ()+addImportToContext str = restoreContextOnFailure $ do+ idecl <- GHC.parseImportDecl str+ addII (IIDecl idecl) -- #5836+ setGHCContextFromGHCiState++-- Util used by addImportToContext and addModulesToContext+addII :: GhciMonad m => InteractiveImport -> m ()+addII iidecl = do+ checkAdd iidecl+ modifyGHCiState $ \st ->+ st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)+ , transient_ctx = filter (not . (iidecl `iiSubsumes`))+ (transient_ctx st)+ }++-- Sometimes we can't tell whether an import is valid or not until+-- we finally call 'GHC.setContext'. e.g.+--+-- import System.IO (foo)+--+-- will fail because System.IO does not export foo. In this case we+-- don't want to store the import in the context permanently, so we+-- catch the failure from 'setGHCContextFromGHCiState' and set the+-- context back to what it was.+--+-- See #6007+--+restoreContextOnFailure :: GhciMonad m => m a -> m a+restoreContextOnFailure do_this = do+ st <- getGHCiState+ let rc = remembered_ctx st; tc = transient_ctx st+ do_this `gonException` (modifyGHCiState $ \st' ->+ st' { remembered_ctx = rc, transient_ctx = tc })++-- -----------------------------------------------------------------------------+-- Validate a module that we want to add to the context++checkAdd :: GHC.GhcMonad m => InteractiveImport -> m ()+checkAdd ii = do+ dflags <- getDynFlags+ let safe = safeLanguageOn dflags+ case ii of+ IIModule modname+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"+ | otherwise -> wantInterpretedModuleName modname >> return ()++ IIDecl d -> do+ let modname = unLoc (ideclName d)+ pkgqual = ideclPkgQual d+ m <- GHC.lookupModule modname (fmap sl_fs pkgqual)+ when safe $ do+ t <- GHC.isModuleTrusted m+ when (not t) $ throwGhcException $ ProgramError $ ""++-- -----------------------------------------------------------------------------+-- Update the GHC API's view of the context++-- | Sets the GHC context from the GHCi state. The GHC context is+-- always set this way, we never modify it incrementally.+--+-- We ignore any imports for which the ModuleName does not currently+-- exist. This is so that the remembered_ctx can contain imports for+-- modules that are not currently loaded, perhaps because we just did+-- a :reload and encountered errors.+--+-- Prelude is added if not already present in the list. Therefore to+-- override the implicit Prelude import you can say 'import Prelude ()'+-- at the prompt, just as in Haskell source.+--+setGHCContextFromGHCiState :: GhciMonad m => m ()+setGHCContextFromGHCiState = do+ st <- getGHCiState+ -- re-use checkAdd to check whether the module is valid. If the+ -- module does not exist, we do *not* want to print an error+ -- here, we just want to silently keep the module in the context+ -- until such time as the module reappears again. So we ignore+ -- the actual exception thrown by checkAdd, using tryBool to+ -- turn it into a Bool.+ iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)++ prel_iidecls <- getImplicitPreludeImports iidecls+ valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls++ extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))++ GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls+++getImplicitPreludeImports :: GhciMonad m+ => [InteractiveImport] -> m [InteractiveImport]+getImplicitPreludeImports iidecls = do+ dflags <- GHC.getInteractiveDynFlags+ -- allow :seti to override -XNoImplicitPrelude+ st <- getGHCiState++ -- We add the prelude imports if there are no *-imports, and we also+ -- allow each prelude import to be subsumed by another explicit import+ -- of the same module. This means that you can override the prelude import+ -- with "import Prelude hiding (map)", for example.+ let prel_iidecls =+ if xopt LangExt.ImplicitPrelude dflags && not (any isIIModule iidecls)+ then [ IIDecl imp+ | imp <- prelude_imports st+ , not (any (sameImpModule imp) iidecls) ]+ else []++ return prel_iidecls++-- -----------------------------------------------------------------------------+-- Utils on InteractiveImport++mkIIModule :: ModuleName -> InteractiveImport+mkIIModule = IIModule++mkIIDecl :: ModuleName -> InteractiveImport+mkIIDecl = IIDecl . simpleImportDecl++iiModules :: [InteractiveImport] -> [ModuleName]+iiModules is = [m | IIModule m <- is]++isIIModule :: InteractiveImport -> Bool+isIIModule (IIModule _) = True+isIIModule _ = False++iiModuleName :: InteractiveImport -> ModuleName+iiModuleName (IIModule m) = m+iiModuleName (IIDecl d) = unLoc (ideclName d)++preludeModuleName :: ModuleName+preludeModuleName = GHC.mkModuleName "Prelude"++sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool+sameImpModule _ (IIModule _) = False -- we only care about imports here+sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)++addNotSubsumed :: InteractiveImport+ -> [InteractiveImport] -> [InteractiveImport]+addNotSubsumed i is+ | any (`iiSubsumes` i) is = is+ | otherwise = i : filter (not . (i `iiSubsumes`)) is++-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed+-- by any of @is@.+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]+ -> [InteractiveImport]+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js++-- | Returns True if the left import subsumes the right one. Doesn't+-- need to be 100% accurate, conservatively returning False is fine.+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in+-- plusProv will ensue (#5904))+--+-- Note that an IIModule does not necessarily subsume an IIDecl,+-- because e.g. a module might export a name that is only available+-- qualified within the module itself.+--+-- Note that 'import M' does not necessarily subsume 'import M(foo)',+-- because M might not export foo and we want an error to be produced+-- in that case.+--+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2+iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude+ = unLoc (ideclName d1) == unLoc (ideclName d2)+ && ideclAs d1 == ideclAs d2+ && (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2))+ && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)+ where+ _ `hidingSubsumes` Just (False,L _ []) = True+ Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)+ = all (`elem` xs) ys+ h1 `hidingSubsumes` h2 = h1 == h2+iiSubsumes _ _ = False+++----------------------------------------------------------------------------+-- :set++-- set options in the interpreter. Syntax is exactly the same as the+-- ghc command line, except that certain options aren't available (-C,+-- -E etc.)+--+-- This is pretty fragile: most options won't work as expected. ToDo:+-- figure out which ones & disallow them.++setCmd :: GhciMonad m => String -> m ()+setCmd "" = showOptions False+setCmd "-a" = showOptions True+setCmd str+ = case getCmd str of+ Right ("args", rest) ->+ case toArgs rest of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args -> setArgs args+ Right ("prog", rest) ->+ case toArgs rest of+ Right [prog] -> setProg prog+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")++ Right ("prompt", rest) ->+ setPromptString setPrompt (dropWhile isSpace rest)+ "syntax: set prompt <string>"+ Right ("prompt-function", rest) ->+ setPromptFunc setPrompt $ dropWhile isSpace rest+ Right ("prompt-cont", rest) ->+ setPromptString setPromptCont (dropWhile isSpace rest)+ "syntax: :set prompt-cont <string>"+ Right ("prompt-cont-function", rest) ->+ setPromptFunc setPromptCont $ dropWhile isSpace rest++ Right ("editor", rest) -> setEditor $ dropWhile isSpace rest+ Right ("stop", rest) -> setStop $ dropWhile isSpace rest+ Right ("local-config", rest) ->+ setLocalConfigBehaviour $ dropWhile isSpace rest+ _ -> case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> setOptions wds++setiCmd :: GhciMonad m => String -> m ()+setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str =+ case toArgs str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> newDynFlags True wds++showOptions :: GhciMonad m => Bool -> m ()+showOptions show_all+ = do st <- getGHCiState+ dflags <- getDynFlags+ let opts = options st+ liftIO $ putStrLn (showSDoc dflags (+ text "options currently set: " <>+ if null opts+ then text "none."+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)+ ))+ getDynFlags >>= liftIO . showDynFlags show_all+++showDynFlags :: Bool -> DynFlags -> IO ()+showDynFlags show_all dflags = do+ showLanguages' show_all dflags+ putStrLn $ showSDoc dflags $+ text "GHCi-specific dynamic flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))+ putStrLn $ showSDoc dflags $+ text "other dynamic, non-language, flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))+ putStrLn $ showSDoc dflags $+ text "warning settings:" $$+ nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))+ where+ setting prefix noPrefix test flag+ | quiet = empty+ | is_on = text prefix <> text name+ | otherwise = text noPrefix <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags = defaultDynFlags (settings dflags) (llvmConfig dflags)++ (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)+ DynFlags.fFlags+ flgs = [ Opt_PrintExplicitForalls+ , Opt_PrintExplicitKinds+ , Opt_PrintUnicodeSyntax+ , Opt_PrintBindResult+ , Opt_BreakOnException+ , Opt_BreakOnError+ , Opt_PrintEvldWithShow+ ]++setArgs, setOptions :: GhciMonad m => [String] -> m ()+setProg, setEditor, setStop :: GhciMonad m => String -> m ()+setLocalConfigBehaviour :: GhciMonad m => String -> m ()++setArgs args = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper (progname st) args+ setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }++setProg prog = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper prog (GhciMonad.args st)+ setGHCiState st { progname = prog, evalWrapper = wrapper }++setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })++setLocalConfigBehaviour s+ | s == "source" =+ modifyGHCiState (\st -> st { localConfig = SourceLocalConfig })+ | s == "ignore" =+ modifyGHCiState (\st -> st { localConfig = IgnoreLocalConfig })+ | otherwise = throwGhcException+ (CmdLineError "syntax: :set local-config { source | ignore }")++setStop str@(c:_) | isDigit c+ = do let (nm_str,rest) = break (not.isDigit) str+ nm = read nm_str+ st <- getGHCiState+ let old_breaks = breaks st+ case IntMap.lookup nm old_breaks of+ Nothing -> printForUser (text "Breakpoint" <+> ppr nm <+>+ text "does not exist")+ Just loc -> do+ let new_breaks = IntMap.insert nm+ loc { onBreakCmd = dropWhile isSpace rest }+ old_breaks+ setGHCiState st{ breaks = new_breaks }+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })++setPrompt :: GhciMonad m => PromptFunction -> m ()+setPrompt v = modifyGHCiState (\st -> st {prompt = v})++setPromptCont :: GhciMonad m => PromptFunction -> m ()+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})++setPromptFunc :: GHC.GhcMonad m => (PromptFunction -> m ()) -> String -> m ()+setPromptFunc fSetPrompt s = do+ -- We explicitly annotate the type of the expression to ensure+ -- that unsafeCoerce# is passed the exact type necessary rather+ -- than a more general one+ let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"+ (HValue funValue) <- GHC.compileExpr exprStr+ fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)+ where+ convertToPromptFunction :: ([String] -> Int -> IO String)+ -> PromptFunction+ convertToPromptFunction func = (\mods line -> liftIO $+ liftM text (func mods line))++setPromptString :: MonadIO m+ => (PromptFunction -> m ()) -> String -> String -> m ()+setPromptString fSetPrompt value err = do+ if null value+ then liftIO $ hPutStrLn stderr $ err+ else case value of+ ('\"':_) ->+ case reads value of+ [(value', xs)] | all isSpace xs ->+ setParsedPromptString fSetPrompt value'+ _ -> liftIO $ hPutStrLn stderr+ "Can't parse prompt string. Use Haskell syntax."+ _ ->+ setParsedPromptString fSetPrompt value++setParsedPromptString :: MonadIO m+ => (PromptFunction -> m ()) -> String -> m ()+setParsedPromptString fSetPrompt s = do+ case (checkPromptStringForErrors s) of+ Just err ->+ liftIO $ hPutStrLn stderr err+ Nothing ->+ fSetPrompt $ generatePromptFunctionFromString s++setOptions wds =+ do -- first, deal with the GHCi opts (+s, +t, etc.)+ let (plus_opts, minus_opts) = partitionWith isPlus wds+ mapM_ setOpt plus_opts+ -- then, dynamic flags+ when (not (null minus_opts)) $ newDynFlags False minus_opts++newDynFlags :: GhciMonad m => Bool -> [String] -> m ()+newDynFlags interactive_only minus_opts = do+ let lopts = map noLoc minus_opts++ idflags0 <- GHC.getInteractiveDynFlags+ (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts++ liftIO $ handleFlagWarnings idflags1 warns+ when (not $ null leftovers)+ (throwGhcException . CmdLineError+ $ "Some flags have not been recognized: "+ ++ (concat . intersperse ", " $ map unLoc leftovers))++ when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"+ -- Load any new plugins+ hsc_env0 <- GHC.getSession+ idflags2 <- liftIO (initializePlugins hsc_env0 idflags1)+ GHC.setInteractiveDynFlags idflags2+ installInteractivePrint (interactivePrint idflags1) False++ dflags0 <- getDynFlags++ when (not interactive_only) $ do+ (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts+ new_pkgs <- GHC.setProgramDynFlags dflags1++ -- if the package flags changed, reset the context and link+ -- the new packages.+ hsc_env <- GHC.getSession+ let dflags2 = hsc_dflags hsc_env+ when (packageFlagsChanged dflags2 dflags0) $ do+ when (verbosity dflags2 > 0) $+ liftIO . putStrLn $+ "package flags have changed, resetting and loading new packages..."+ -- delete targets and all eventually defined breakpoints. (#1620)+ clearAllTargets+ liftIO $ linkPackages hsc_env new_pkgs+ -- package flags changed, we can't re-use any of the old context+ setContextAfterLoad False []+ -- and copy the package state to the interactive DynFlags+ idflags <- GHC.getInteractiveDynFlags+ GHC.setInteractiveDynFlags+ idflags{ pkgState = pkgState dflags2+ , pkgDatabase = pkgDatabase dflags2+ , packageFlags = packageFlags dflags2 }++ let ld0length = length $ ldInputs dflags0+ fmrk0length = length $ cmdlineFrameworks dflags0++ newLdInputs = drop ld0length (ldInputs dflags2)+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)++ hsc_env' = hsc_env { hsc_dflags =+ dflags2 { ldInputs = newLdInputs+ , cmdlineFrameworks = newCLFrameworks } }++ when (not (null newLdInputs && null newCLFrameworks)) $+ liftIO $ linkCmdLineLibs hsc_env'++ return ()+++unsetOptions :: GhciMonad m => String -> m ()+unsetOptions str+ = -- first, deal with the GHCi opts (+s, +t, etc.)+ let opts = words str+ (minus_opts, rest1) = partition isMinus opts+ (plus_opts, rest2) = partitionWith isPlus rest1+ (other_opts, rest3) = partition (`elem` map fst defaulters) rest2++ defaulters =+ [ ("args" , setArgs default_args)+ , ("prog" , setProg default_progname)+ , ("prompt" , setPrompt default_prompt)+ , ("prompt-cont", setPromptCont default_prompt_cont)+ , ("editor" , liftIO findEditor >>= setEditor)+ , ("stop" , setStop default_stop)+ ]++ no_flag ('-':'f':rest) = return ("-fno-" ++ rest)+ no_flag ('-':'X':rest) = return ("-XNo" ++ rest)+ no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))++ in if (not (null rest3))+ then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))+ else do+ mapM_ (fromJust.flip lookup defaulters) other_opts++ mapM_ unsetOpt plus_opts++ no_flags <- mapM no_flag minus_opts+ when (not (null no_flags)) $ newDynFlags False no_flags++isMinus :: String -> Bool+isMinus ('-':_) = True+isMinus _ = False++isPlus :: String -> Either String String+isPlus ('+':opt) = Left opt+isPlus other = Right other++setOpt, unsetOpt :: GhciMonad m => String -> m ()++setOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> setOption o++unsetOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> unsetOption o++strToGHCiOpt :: String -> (Maybe GHCiOption)+strToGHCiOpt "m" = Just Multiline+strToGHCiOpt "s" = Just ShowTiming+strToGHCiOpt "t" = Just ShowType+strToGHCiOpt "r" = Just RevertCAFs+strToGHCiOpt "c" = Just CollectInfo+strToGHCiOpt _ = Nothing++optToStr :: GHCiOption -> String+optToStr Multiline = "m"+optToStr ShowTiming = "s"+optToStr ShowType = "t"+optToStr RevertCAFs = "r"+optToStr CollectInfo = "c"+++-- ---------------------------------------------------------------------------+-- :show++showCmd :: forall m. GhciMonad m => String -> m ()+showCmd "" = showOptions False+showCmd "-a" = showOptions True+showCmd str = do+ st <- getGHCiState+ dflags <- getDynFlags+ hsc_env <- GHC.getSession++ let lookupCmd :: String -> Maybe (m ())+ lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds++ -- (show in help?, command name, action)+ action :: String -> m () -> (Bool, String, m ())+ action name m = (True, name, m)++ hidden :: String -> m () -> (Bool, String, m ())+ hidden name m = (False, name, m)++ cmds =+ [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))+ , action "prog" $ liftIO $ putStrLn (show (progname st))+ , action "editor" $ liftIO $ putStrLn (show (editor st))+ , action "stop" $ liftIO $ putStrLn (show (stop st))+ , action "imports" $ showImports+ , action "modules" $ showModules+ , action "bindings" $ showBindings+ , action "linker" $ getDynFlags >>= liftIO . (showLinkerState (hsc_dynLinker hsc_env))+ , action "breaks" $ showBkptTable+ , action "context" $ showContext+ , action "packages" $ showPackages+ , action "paths" $ showPaths+ , action "language" $ showLanguages+ , hidden "languages" $ showLanguages -- backwards compat+ , hidden "lang" $ showLanguages -- useful abbreviation+ , action "targets" $ showTargets+ ]++ case words str of+ [w] | Just action <- lookupCmd w -> action++ _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]+ in throwGhcException $ CmdLineError $ showSDoc dflags+ $ hang (text "syntax:") 4+ $ hang (text ":show") 6+ $ brackets (fsep $ punctuate (text " |") helpCmds)++showiCmd :: GHC.GhcMonad m => String -> m ()+showiCmd str = do+ case words str of+ ["languages"] -> showiLanguages -- backwards compat+ ["language"] -> showiLanguages+ ["lang"] -> showiLanguages -- useful abbreviation+ _ -> throwGhcException (CmdLineError ("syntax: :showi language"))++showImports :: GhciMonad m => m ()+showImports = do+ st <- getGHCiState+ dflags <- getDynFlags+ let rem_ctx = reverse (remembered_ctx st)+ trans_ctx = transient_ctx st++ show_one (IIModule star_m)+ = ":module +*" ++ moduleNameString star_m+ show_one (IIDecl imp) = showPpr dflags imp++ prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)++ let show_prel p = show_one p ++ " -- implicit"+ show_extra p = show_one (IIDecl p) ++ " -- fixed"++ trans_comment s = s ++ " -- added automatically" :: String+ --+ liftIO $ mapM_ putStrLn (map show_one rem_ctx +++ map (trans_comment . show_one) trans_ctx +++ map show_prel prel_iidecls +++ map show_extra (extra_imports st))++showModules :: GHC.GhcMonad m => m ()+showModules = do+ loaded_mods <- getLoadedModules+ -- we want *loaded* modules only, see #1734+ let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)+ mapM_ show_one loaded_mods++getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]+getLoadedModules = do+ graph <- GHC.getModuleGraph+ filterM (GHC.isLoaded . GHC.ms_mod_name) (GHC.mgModSummaries graph)++showBindings :: GHC.GhcMonad m => m ()+showBindings = do+ bindings <- GHC.getBindings+ (insts, finsts) <- GHC.getInsts+ let idocs = map GHC.pprInstanceHdr insts+ fidocs = map GHC.pprFamInst finsts+ binds = filter (not . isDerivedOccName . getOccName) bindings -- #12525+ -- See Note [Filter bindings]+ docs <- mapM makeDoc (reverse binds)+ -- reverse so the new ones come last+ mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)+ where+ makeDoc (AnId i) = pprTypeAndContents i+ makeDoc tt = do+ mb_stuff <- GHC.getInfo False (getName tt)+ return $ maybe (text "") pprTT mb_stuff++ pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+ pprTT (thing, fixity, _cls_insts, _fam_insts, _docs)+ = pprTyThing showToHeader thing+ $$ show_fixity+ where+ show_fixity+ | fixity == GHC.defaultFixity = empty+ | otherwise = ppr fixity <+> ppr (GHC.getName thing)+++printTyThing :: GHC.GhcMonad m => TyThing -> m ()+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)++{-+Note [Filter bindings]+~~~~~~~~~~~~~~~~~~~~~~++If we don't filter the bindings returned by the function GHC.getBindings,+then the :show bindings command will also show unwanted bound names,+internally generated by GHC, eg:+ $tcFoo :: GHC.Types.TyCon = _+ $trModule :: GHC.Types.Module = _ .++The filter was introduced as a fix for #12525 [1]. Comment:1 [2] to this+ticket contains an analysis of the situation and suggests the solution+implemented above.++The same filter was also implemented to fix #11051 [3]. See the+Note [What to show to users] in compiler/main/InteractiveEval.hs++[1] https://gitlab.haskell.org/ghc/ghc/issues/12525+[2] https://gitlab.haskell.org/ghc/ghc/issues/12525#note_123489+[3] https://gitlab.haskell.org/ghc/ghc/issues/11051+-}+++showBkptTable :: GhciMonad m => m ()+showBkptTable = do+ st <- getGHCiState+ printForUser $ prettyLocations (breaks st)++showContext :: GHC.GhcMonad m => m ()+showContext = do+ resumes <- GHC.getResumeContext+ printForUser $ vcat (map pp_resume (reverse resumes))+ where+ pp_resume res =+ ptext (sLit "--> ") <> text (GHC.resumeStmt res)+ $$ nest 2 (pprStopped res)++pprStopped :: GHC.Resume -> SDoc+pprStopped res =+ ptext (sLit "Stopped in")+ <+> ((case mb_mod_name of+ Nothing -> empty+ Just mod_name -> text (moduleNameString mod_name) <> char '.')+ <> text (GHC.resumeDecl res))+ <> char ',' <+> ppr (GHC.resumeSpan res)+ where+ mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res++showPackages :: GHC.GhcMonad m => m ()+showPackages = do+ dflags <- getDynFlags+ let pkg_flags = packageFlags dflags+ liftIO $ putStrLn $ showSDoc dflags $+ text ("active package flags:"++if null pkg_flags then " none" else "") $$+ nest 2 (vcat (map pprFlag pkg_flags))++showPaths :: GHC.GhcMonad m => m ()+showPaths = do+ dflags <- getDynFlags+ liftIO $ do+ cwd <- getCurrentDirectory+ putStrLn $ showSDoc dflags $+ text "current working directory: " $$+ nest 2 (text cwd)+ let ipaths = importPaths dflags+ putStrLn $ showSDoc dflags $+ text ("module import search paths:"++if null ipaths then " none" else "") $$+ nest 2 (vcat (map text ipaths))++showLanguages :: GHC.GhcMonad m => m ()+showLanguages = getDynFlags >>= liftIO . showLanguages' False++showiLanguages :: GHC.GhcMonad m => m ()+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False++showLanguages' :: Bool -> DynFlags -> IO ()+showLanguages' show_all dflags =+ putStrLn $ showSDoc dflags $ vcat+ [ text "base language is: " <>+ case language dflags of+ Nothing -> text "Haskell2010"+ Just Haskell98 -> text "Haskell98"+ Just Haskell2010 -> text "Haskell2010"+ , (if show_all then text "all active language options:"+ else text "with the following modifiers:") $$+ nest 2 (vcat (map (setting xopt) DynFlags.xFlags))+ ]+ where+ setting test flag+ | quiet = empty+ | is_on = text "-X" <> text name+ | otherwise = text "-XNo" <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags =+ defaultDynFlags (settings dflags) (llvmConfig dflags) `lang_set`+ case language dflags of+ Nothing -> Just Haskell2010+ other -> other++showTargets :: GHC.GhcMonad m => m ()+showTargets = mapM_ showTarget =<< GHC.getTargets+ where+ showTarget :: GHC.GhcMonad m => Target -> m ()+ showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)+ showTarget (Target (TargetModule m) _ _) =+ liftIO (putStrLn $ moduleNameString m)++-- -----------------------------------------------------------------------------+-- Completion++completeCmd :: String -> GHCi ()+completeCmd argLine0 = case parseLine argLine0 of+ Just ("repl", resultRange, left) -> do+ (unusedLine,compls) <- ghciCompleteWord (reverse left,"")+ let compls' = takeRange resultRange compls+ liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]+ forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do+ liftIO $ print r+ _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")+ where+ parseLine argLine+ | null argLine = Nothing+ | null rest1 = Nothing+ | otherwise = (,,) dom <$> resRange <*> s+ where+ (dom, rest1) = breakSpace argLine+ (rng, rest2) = breakSpace rest1+ resRange | head rest1 == '"' = parseRange ""+ | otherwise = parseRange rng+ s | head rest1 == '"' = readMaybe rest1 :: Maybe String+ | otherwise = readMaybe rest2+ breakSpace = fmap (dropWhile isSpace) . break isSpace++ takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub++ -- syntax: [n-][m] with semantics "drop (n-1) . take m"+ parseRange :: String -> Maybe (Maybe Int,Maybe Int)+ parseRange s = case span isDigit s of+ (_, "") ->+ -- upper limit only+ Just (Nothing, bndRead s)+ (s1, '-' : s2)+ | all isDigit s2 ->+ Just (bndRead s1, bndRead s2)+ _ ->+ Nothing+ where+ bndRead x = if null x then Nothing else Just (read x)++++completeGhciCommand, completeMacro, completeIdentifier, completeModule,+ completeSetModule, completeSeti, completeShowiOptions,+ completeHomeModule, completeSetOptions, completeShowOptions,+ completeHomeModuleOrFile, completeExpression+ :: GhciMonad m => CompletionFunc m++-- | Provide completions for last word in a given string.+--+-- Takes a tuple of two strings. First string is a reversed line to be+-- completed. Second string is likely unused, 'completeCmd' always passes an+-- empty string as second item in tuple.+ghciCompleteWord :: CompletionFunc GHCi+ghciCompleteWord line@(left,_) = case firstWord of+ -- If given string starts with `:` colon, and there is only one following+ -- word then provide REPL command completions. If there is more than one+ -- word complete either filename or builtin ghci commands or macros.+ ':':cmd | null rest -> completeGhciCommand line+ | otherwise -> do+ completion <- lookupCompletion cmd+ completion line+ -- If given string starts with `import` keyword provide module name+ -- completions+ "import" -> completeModule line+ -- otherwise provide identifier completions+ _ -> completeExpression line+ where+ (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left+ lookupCompletion ('!':_) = return completeFilename+ lookupCompletion c = do+ maybe_cmd <- lookupCommand' c+ case maybe_cmd of+ Just cmd -> return (cmdCompletionFunc cmd)+ Nothing -> return completeFilename++completeGhciCommand = wrapCompleter " " $ \w -> do+ macros <- ghci_macros <$> getGHCiState+ cmds <- ghci_commands `fmap` getGHCiState+ let macro_names = map (':':) . map cmdName $ macros+ let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds+ let{ candidates = case w of+ ':' : ':' : _ -> map (':':) command_names+ _ -> nub $ macro_names ++ command_names }+ return $ filter (w `isPrefixOptOf`) candidates++completeMacro = wrapIdentCompleter $ \w -> do+ cmds <- ghci_macros <$> getGHCiState+ return (filter (w `isPrefixOf`) (map cmdName cmds))++completeIdentifier line@(left, _) =+ -- Note: `left` is a reversed input+ case left of+ (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line+ _ -> wrapIdentCompleter complete line+ where+ complete w = do+ rdrs <- GHC.getRdrNamesInScope+ dflags <- GHC.getSessionDynFlags+ return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))++completeModule = wrapIdentCompleter $ \w -> do+ dflags <- GHC.getSessionDynFlags+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) $ loaded_mods ++ pkg_mods++completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do+ dflags <- GHC.getSessionDynFlags+ modules <- case m of+ Just '-' -> do+ imports <- GHC.getContext+ return $ map iiModuleName imports+ _ -> do+ let pkg_mods = allVisibleModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ loaded_mods ++ pkg_mods+ return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules++completeHomeModule = wrapIdentCompleter listHomeModules++listHomeModules :: GHC.GhcMonad m => String -> m [String]+listHomeModules w = do+ g <- GHC.getModuleGraph+ let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)+ dflags <- getDynFlags+ return $ sort $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) home_mods++completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":+ "prompt-cont-function":"editor":"stop":flagList+ flagList = map head $ group $ sort allNonDeprecatedFlags++completeSeti = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) flagList)+ where flagList = map head $ group $ sort allNonDeprecatedFlags++completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = ["args", "prog", "editor", "stop",+ "modules", "bindings", "linker", "breaks",+ "context", "packages", "paths", "language", "imports"]++completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) ["language"])++completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars+ $ unionComplete (fmap (map simpleCompletion) . listHomeModules)+ listFiles++unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]+unionComplete f1 f2 line = do+ cs1 <- f1 line+ cs2 <- f2 line+ return (cs1 ++ cs2)++wrapCompleter :: Monad m => String -> (String -> m [String]) -> CompletionFunc m+wrapCompleter breakChars fun = completeWord Nothing breakChars+ $ fmap (map simpleCompletion . nubSort) . fun++wrapIdentCompleter :: Monad m => (String -> m [String]) -> CompletionFunc m+wrapIdentCompleter = wrapCompleter word_break_chars++wrapIdentCompleterWithModifier+ :: Monad m+ => String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars+ $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)+ where+ getModifier = find (`elem` modifChars)++-- | Return a list of visible module names for autocompletion.+-- (NB: exposed != visible)+allVisibleModules :: DynFlags -> [ModuleName]+allVisibleModules dflags = listVisibleModuleNames dflags++completeExpression = completeQuotedWord (Just '\\') "\"" listFiles+ completeIdentifier+++-- -----------------------------------------------------------------------------+-- commands for debugger++sprintCmd, printCmd, forceCmd :: GHC.GhcMonad m => String -> m ()+sprintCmd = pprintClosureCommand False False+printCmd = pprintClosureCommand True False+forceCmd = pprintClosureCommand False True++stepCmd :: GhciMonad m => String -> m ()+stepCmd arg = withSandboxOnly ":step" $ step arg+ where+ step [] = doContinue (const True) GHC.SingleStep+ step expression = runStmt expression GHC.SingleStep >> return ()++stepLocalCmd :: GhciMonad m => String -> m ()+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just (UnhelpfulSpan _) -> liftIO $ putStrLn ( -- #14690+ ":steplocal is not possible." +++ "\nCannot determine current top-level binding after " +++ "a break on error / exception.\nUse :stepmodule.")+ Just loc -> do+ md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule+ current_toplevel_decl <- enclosingTickSpan md loc+ doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep++stepModuleCmd :: GhciMonad m => String -> m ()+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just pan -> do+ let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span+ doContinue f GHC.SingleStep++-- | Returns the span of the largest tick containing the srcspan given+enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"+enclosingTickSpan md (RealSrcSpan src) = do+ ticks <- getTickArray md+ let line = srcSpanStartLine src+ ASSERT(inRange (bounds ticks) line) do+ let enclosing_spans = [ pan | (_,pan) <- ticks ! line+ , realSrcSpanEnd pan >= realSrcSpanEnd src]+ return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans+ where++leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering+leftmostLargestRealSrcSpan a b =+ (realSrcSpanStart a `compare` realSrcSpanStart b)+ `thenCmp`+ (realSrcSpanEnd b `compare` realSrcSpanEnd a)++traceCmd :: GhciMonad m => String -> m ()+traceCmd arg+ = withSandboxOnly ":trace" $ tr arg+ where+ tr [] = doContinue (const True) GHC.RunAndLogSteps+ tr expression = runStmt expression GHC.RunAndLogSteps >>= setContinueExecResult >> return () -- DAP added++continueCmd :: GhciMonad m => String -> m ()+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion++doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m ()+doContinue pre step = do+ runResult <- resume pre step+ setContinueExecResult (Just runResult) -- DAP added.+ _ <- afterRunStmt pre runResult+ return ()++abandonCmd :: GhciMonad m => String -> m ()+abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do+ b <- GHC.abandon -- the prompt will change to indicate the new context+ when (not b) $ liftIO $ putStrLn "There is no computation running."++deleteCmd :: GhciMonad m => String -> m ()+deleteCmd argLine = withSandboxOnly ":delete" $ do+ deleteSwitch $ words argLine+ where+ deleteSwitch :: GhciMonad m => [String] -> m ()+ deleteSwitch [] =+ liftIO $ putStrLn "The delete command requires at least one argument."+ -- delete all break points+ deleteSwitch ("*":_rest) = discardActiveBreakPoints+ deleteSwitch idents = do+ mapM_ deleteOneBreak idents+ where+ deleteOneBreak :: GhciMonad m => String -> m ()+ deleteOneBreak str+ | all isDigit str = deleteBreak (read str)+ | otherwise = return ()++enableCmd :: GhciMonad m => String -> m ()+enableCmd argLine = withSandboxOnly ":enable" $ do+ enaDisaSwitch True $ words argLine++disableCmd :: GhciMonad m => String -> m ()+disableCmd argLine = withSandboxOnly ":disable" $ do+ enaDisaSwitch False $ words argLine++enaDisaSwitch :: GhciMonad m => Bool -> [String] -> m ()+enaDisaSwitch enaDisa [] =+ printForUser (text "The" <+> text strCmd <+>+ text "command requires at least one argument.")+ where+ strCmd = if enaDisa then ":enable" else ":disable"+enaDisaSwitch enaDisa ("*" : _) = enaDisaAllBreaks enaDisa+enaDisaSwitch enaDisa idents = do+ mapM_ (enaDisaOneBreak enaDisa) idents+ where+ enaDisaOneBreak :: GhciMonad m => Bool -> String -> m ()+ enaDisaOneBreak enaDisa strId = do+ sdoc_loc <- getBreakLoc enaDisa strId+ case sdoc_loc of+ Left sdoc -> printForUser sdoc+ Right loc -> enaDisaAssoc enaDisa (read strId, loc)++getBreakLoc :: GhciMonad m => Bool -> String -> m (Either SDoc BreakLocation)+getBreakLoc enaDisa strId = do+ st <- getGHCiState+ case readMaybe strId >>= flip IntMap.lookup (breaks st) of+ Nothing -> return $ Left (text "Breakpoint" <+> text strId <+>+ text "not found")+ Just loc ->+ if breakEnabled loc == enaDisa+ then return $ Left+ (text "Breakpoint" <+> text strId <+>+ text "already in desired state")+ else return $ Right loc++enaDisaAssoc :: GhciMonad m => Bool -> (Int, BreakLocation) -> m ()+enaDisaAssoc enaDisa (intId, loc) = do+ st <- getGHCiState+ newLoc <- turnBreakOnOff enaDisa loc+ let new_breaks = IntMap.insert intId newLoc (breaks st)+ setGHCiState $ st { breaks = new_breaks }++enaDisaAllBreaks :: GhciMonad m => Bool -> m()+enaDisaAllBreaks enaDisa = do+ st <- getGHCiState+ mapM_ (enaDisaAssoc enaDisa) $ IntMap.assocs $ breaks st++historyCmd :: GhciMonad m => String -> m () -- DAP Modified+historyCmd arg+ | null arg = history 20+ | all isDigit arg = history (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :history [num]"+ where+ history num = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> liftIO $ putStrLn "Not stopped at a breakpoint"+ (r:_) -> do+ let hist = GHC.resumeHistory r+ (took,rest) = splitAt num hist+ case hist of+ [] -> liftIO $ putStrLn $+ "Empty history. Perhaps you forgot to use :trace?"+ _ -> do+ pans <- mapM GHC.getHistorySpan took+ let nums = map (printf "-%-3d:") [(1::Int)..]+ names = map GHC.historyEnclosingDecls took+ printForUser (vcat(zipWith3+ (\x y z -> x <+> y <+> z)+ (map text nums)+ (map (bold . hcat . punctuate colon . map text) names)+ (map (parens . ppr) pans)))+ liftIO $ putStrLn $ if null rest then "<end of history>" else "..."+ setStackTraceResult r took -- DAP added.++bold :: SDoc -> SDoc+bold c | do_bold = text start_bold <> c <> text end_bold+ | otherwise = c++backCmd :: GhciMonad m => String -> m ()+backCmd arg+ | null arg = back 1+ | all isDigit arg = back (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :back [num]"+ where+ back num = withSandboxOnly ":back" $ do+ (names, _, pan, _) <- GHC.back num+ printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ setBindingNames names -- DAP added.++forwardCmd :: GhciMonad m => String -> m ()+forwardCmd arg+ | null arg = forward 1+ | all isDigit arg = forward (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :forward [num]"+ where+ forward num = withSandboxOnly ":forward" $ do+ (names, ix, pan, _) <- GHC.forward num+ printForUser $ (if (ix == 0)+ then ptext (sLit "Stopped at")+ else ptext (sLit "Logged breakpoint at")) <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ setBindingNames names -- DAP added.++-- handle the "break" command+breakCmd :: GhciMonad m => String -> m ()+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine++breakSwitch :: GhciMonad m => [String] -> m ()+breakSwitch [] = do+ liftIO $ putStrLn "The break command requires at least one argument."+breakSwitch (arg1:rest)+ | looksLikeModuleName arg1 && not (null rest) = do+ md <- wantInterpretedModule arg1+ breakByModule md rest+ | all isDigit arg1 = do+ imports <- GHC.getContext+ case iiModules imports of+ (mn : _) -> do+ md <- lookupModuleName mn+ breakByModuleLine md (read arg1) rest+ [] -> do+ liftIO $ putStrLn "No modules are loaded with debugging support."+ | otherwise = do -- try parsing it as an identifier+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do+ maybe_info <- GHC.getModuleInfo (GHC.nameModule name)+ case maybe_info of+ Nothing -> noCanDo name (ptext (sLit "cannot get module info"))+ Just minf ->+ ASSERT( isExternalName name )+ findBreakAndSet (GHC.nameModule name) $+ findBreakForBind name (GHC.modInfoModBreaks minf)+ where+ noCanDo n why = printForUser $+ text "cannot set breakpoint on " <> ppr n <> text ": " <> why++breakByModule :: GhciMonad m => Module -> [String] -> m ()+breakByModule md (arg1:rest)+ | all isDigit arg1 = do -- looks like a line number+ breakByModuleLine md (read arg1) rest+breakByModule _ _+ = breakSyntax++breakByModuleLine :: GhciMonad m => Module -> Int -> [String] -> m ()+breakByModuleLine md line args+ | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line+ | [col] <- args, all isDigit col =+ findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)+ | otherwise = breakSyntax++breakSyntax :: a+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")++findBreakAndSet :: GhciMonad m+ => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()+findBreakAndSet md lookupTickTree = do+ tickArray <- getTickArray md+ (breakArray, _) <- getModBreak md+ case lookupTickTree tickArray of+ [] -> liftIO $ putStrLn $ "No breakpoints found at that location."+ some -> mapM_ (breakAt breakArray) some+ where+ breakAt breakArray (tick, pan) = do+ setBreakFlag True breakArray tick+ (alreadySet, nm) <-+ recordBreak $ BreakLocation+ { breakModule = md+ , breakLoc = RealSrcSpan pan+ , breakTick = tick+ , onBreakCmd = ""+ , breakEnabled = True+ }+ printForUser $+ text "Breakpoint " <> ppr nm <>+ if alreadySet+ then text " was already set at " <> ppr pan+ else text " activated at " <> ppr pan++-- When a line number is specified, the current policy for choosing+-- the best breakpoint is this:+-- - the leftmost complete subexpression on the specified line, or+-- - the leftmost subexpression starting on the specified line, or+-- - the rightmost subexpression enclosing the specified line+--+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)+findBreakByLine line arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`+ listToMaybe (sortBy (compare `on` snd) incomp) `mplus`+ listToMaybe (sortBy (flip compare `on` snd) ticks)+ where+ ticks = arr ! line++ starts_here = [ (ix,pan) | (ix, pan) <- ticks,+ GHC.srcSpanStartLine pan == line ]++ (comp, incomp) = partition ends_here starts_here+ where ends_here (_,pan) = GHC.srcSpanEndLine pan == line++-- The aim is to find the breakpoints for all the RHSs of the+-- equations corresponding to a binding. So we find all breakpoints+-- for+-- (a) this binder only (not a nested declaration)+-- (b) that do not have an enclosing breakpoint+findBreakForBind :: Name -> GHC.ModBreaks -> TickArray+ -> [(BreakIndex,RealSrcSpan)]+findBreakForBind name modbreaks _ = filter (not . enclosed) ticks+ where+ ticks = [ (index, span)+ | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),+ n == occNameString (nameOccName name),+ RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]+ enclosed (_,sp0) = any subspan ticks+ where subspan (_,sp) = sp /= sp0 &&+ realSrcSpanStart sp <= realSrcSpanStart sp0 &&+ realSrcSpanEnd sp0 <= realSrcSpanEnd sp++findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray+ -> Maybe (BreakIndex,RealSrcSpan)+findBreakByCoord mb_file (line, col) arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (flip compare `on` snd) contains +++ sortBy (compare `on` snd) after_here)+ where+ ticks = arr ! line++ -- the ticks that span this coordinate+ contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),+ is_correct_file pan ]++ is_correct_file pan+ | Just f <- mb_file = GHC.srcSpanFile pan == f+ | otherwise = True++ after_here = [ tick | tick@(_,pan) <- ticks,+ GHC.srcSpanStartLine pan == line,+ GHC.srcSpanStartCol pan >= col ]++-- For now, use ANSI bold on terminals that we know support it.+-- Otherwise, we add a line of carets under the active expression instead.+-- In particular, on Windows and when running the testsuite (which sets+-- TERM to vt100 for other reasons) we get carets.+-- We really ought to use a proper termcap/terminfo library.+do_bold :: Bool+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]+ where mTerm = System.Environment.getEnv "TERM"+ `catchIO` \_ -> return "TERM not set"++start_bold :: String+start_bold = "\ESC[1m"+end_bold :: String+end_bold = "\ESC[0m"++-----------------------------------------------------------------------------+-- :where++whereCmd :: GHC.GhcMonad m => String -> m ()+whereCmd = noArgs $ do+ mstrs <- getCallStackAtCurrentBreakpoint+ case mstrs of+ Nothing -> return ()+ Just strs -> liftIO $ putStrLn (renderStack strs)++-----------------------------------------------------------------------------+-- :list++listCmd :: GhciMonad m => String -> m ()+listCmd "" = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing ->+ printForUser $ text "Not stopped at a breakpoint; nothing to list"+ Just (RealSrcSpan pan) ->+ listAround pan True+ Just pan@(UnhelpfulSpan _) ->+ do resumes <- GHC.getResumeContext+ case resumes of+ [] -> panic "No resumes"+ (r:_) ->+ do let traceIt = case GHC.resumeHistory r of+ [] -> text "rerunning with :trace,"+ _ -> empty+ doWhat = traceIt <+> text ":back then :list"+ printForUser (text "Unable to list source for" <+>+ ppr pan+ $$ text "Try" <+> doWhat)+listCmd str = list2 (words str)++list2 :: GhciMonad m => [String] -> m ()+list2 [arg] | all isDigit arg = do+ imports <- GHC.getContext+ case iiModules imports of+ [] -> liftIO $ putStrLn "No module to list"+ (mn : _) -> do+ md <- lookupModuleName mn+ listModuleLine md (read arg)+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do+ md <- wantInterpretedModule arg1+ listModuleLine md (read arg2)+list2 [arg] = do+ wantNameFromInterpretedModule noCanDo arg $ \name -> do+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+ case loc of+ RealSrcLoc l ->+ do tickArray <- ASSERT( isExternalName name )+ getTickArray (GHC.nameModule name)+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))+ (GHC.srcLocLine l, GHC.srcLocCol l)+ tickArray+ case mb_span of+ Nothing -> listAround (realSrcLocSpan l) False+ Just (_, pan) -> listAround pan False+ UnhelpfulLoc _ ->+ noCanDo name $ text "can't find its location: " <>+ ppr loc+ where+ noCanDo n why = printForUser $+ text "cannot list source code for " <> ppr n <> text ": " <> why+list2 _other =+ liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"++listModuleLine :: GHC.GhcMonad m => Module -> Int -> m ()+listModuleLine modl line = do+ graph <- GHC.getModuleGraph+ let this = GHC.mgLookupModule graph modl+ case this of+ Nothing -> panic "listModuleLine"+ Just summ -> do+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))+ loc = mkRealSrcLoc (mkFastString (filename)) line 0+ listAround (realSrcLocSpan loc) False++-- | list a section of a source file around a particular SrcSpan.+-- If the highlight flag is True, also highlight the span using+-- start_bold\/end_bold.++-- GHC files are UTF-8, so we can implement this by:+-- 1) read the file in as a BS and syntax highlight it as before+-- 2) convert the BS to String using utf-string, and write it out.+-- It would be better if we could convert directly between UTF-8 and the+-- console encoding, of course.+listAround :: MonadIO m => RealSrcSpan -> Bool -> m ()+listAround pan do_highlight = do+ contents <- liftIO $ BS.readFile (unpackFS file)+ -- Drop carriage returns to avoid duplicates, see #9367.+ let ls = BS.split '\n' $ BS.filter (/= '\r') contents+ ls' = take (line2 - line1 + 1 + pad_before + pad_after) $+ drop (line1 - 1 - pad_before) $ ls+ fst_line = max 1 (line1 - pad_before)+ line_nos = [ fst_line .. ]++ highlighted | do_highlight = zipWith highlight line_nos ls'+ | otherwise = [\p -> BS.concat[p,l] | l <- ls']++ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]+ prefixed = zipWith ($) highlighted bs_line_nos+ output = BS.intercalate (BS.pack "\n") prefixed++ let utf8Decoded = utf8DecodeByteString output+ liftIO $ putStrLn utf8Decoded+ where+ file = GHC.srcSpanFile pan+ line1 = GHC.srcSpanStartLine pan+ col1 = GHC.srcSpanStartCol pan - 1+ line2 = GHC.srcSpanEndLine pan+ col2 = GHC.srcSpanEndCol pan - 1++ pad_before | line1 == 1 = 0+ | otherwise = 1+ pad_after = 1++ highlight | do_bold = highlight_bold+ | otherwise = highlight_carets++ highlight_bold no line prefix+ | no == line1 && no == line2+ = let (a,r) = BS.splitAt col1 line+ (b,c) = BS.splitAt (col2-col1) r+ in+ BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]+ | no == line1+ = let (a,b) = BS.splitAt col1 line in+ BS.concat [prefix, a, BS.pack start_bold, b]+ | no == line2+ = let (a,b) = BS.splitAt col2 line in+ BS.concat [prefix, a, BS.pack end_bold, b]+ | otherwise = BS.concat [prefix, line]++ highlight_carets no line prefix+ | no == line1 && no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',+ BS.replicate (col2-col1) '^']+ | no == line1+ = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,+ prefix, line]+ | no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',+ BS.pack "^^"]+ | otherwise = BS.concat [prefix, line]+ where+ indent = BS.pack (" " ++ replicate (length (show no)) ' ')+ nl = BS.singleton '\n'+++-- --------------------------------------------------------------------------+-- Tick arrays++getTickArray :: GhciMonad m => Module -> m TickArray+getTickArray modl = do+ st <- getGHCiState+ let arrmap = tickarrays st+ case lookupModuleEnv arrmap modl of+ Just arr -> return arr+ Nothing -> do+ (_breakArray, ticks) <- getModBreak modl+ let arr = mkTickArray (assocs ticks)+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}+ return arr++discardTickArrays :: GhciMonad m => m ()+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})++mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray+mkTickArray ticks+ = accumArray (flip (:)) [] (1, max_line)+ [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]+ where+ max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]+ srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]++-- don't reset the counter back to zero?+discardActiveBreakPoints :: GhciMonad m => m ()+discardActiveBreakPoints = do+ st <- getGHCiState+ mapM_ (turnBreakOnOff False) $ breaks st+ setGHCiState $ st { breaks = IntMap.empty }++deleteBreak :: GhciMonad m => Int -> m ()+deleteBreak identity = do+ st <- getGHCiState+ let oldLocations = breaks st+ case IntMap.lookup identity oldLocations of+ Nothing -> printForUser (text "Breakpoint" <+> ppr identity <+>+ text "does not exist")+ Just loc -> do+ _ <- (turnBreakOnOff False) loc+ let rest = IntMap.delete identity oldLocations+ setGHCiState $ st { breaks = rest }++turnBreakOnOff :: GHC.GhcMonad m => Bool -> BreakLocation -> m BreakLocation+turnBreakOnOff onOff loc+ | onOff == breakEnabled loc = return loc+ | otherwise = do+ (arr, _) <- getModBreak (breakModule loc)+ hsc_env <- GHC.getSession+ liftIO $ enableBreakpoint hsc_env arr (breakTick loc) onOff+ return loc { breakEnabled = onOff }++getModBreak :: GHC.GhcMonad m+ => Module -> m (ForeignRef BreakArray, Array Int SrcSpan)+getModBreak m = do+ mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m+ let modBreaks = GHC.modInfoModBreaks mod_info+ let arr = GHC.modBreaks_flags modBreaks+ let ticks = GHC.modBreaks_locs modBreaks+ return (arr, ticks)++setBreakFlag :: GHC.GhcMonad m => Bool -> ForeignRef BreakArray -> Int -> m ()+setBreakFlag toggle arr i = do+ hsc_env <- GHC.getSession+ liftIO $ enableBreakpoint hsc_env arr i toggle++-- ---------------------------------------------------------------------------+-- User code exception handling++-- This is the exception handler for exceptions generated by the+-- user's code and exceptions coming from children sessions;+-- it normally just prints out the exception. The+-- handler must be recursive, in case showing the exception causes+-- more exceptions to be raised.+--+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,+-- raising another exception. We therefore don't put the recursive+-- handler arond the flushing operation, so if stderr is closed+-- GHCi will just die gracefully rather than going into an infinite loop.+handler :: GhciMonad m => SomeException -> m Bool+handler exception = do+ flushInterpBuffers+ withSignalHandlers $+ ghciHandle handler (showException exception >> return False)++showException :: MonadIO m => SomeException -> m ()+showException se =+ liftIO $ case fromException se of+ -- omit the location for CmdLineError:+ Just (CmdLineError s) -> putException s+ -- ditto:+ Just other_ghc_ex -> putException (show other_ghc_ex)+ Nothing ->+ case fromException se of+ Just UserInterrupt -> putException "Interrupted."+ _ -> putException ("*** Exception: " ++ show se)+ where+ putException = hPutStrLn stderr+++-----------------------------------------------------------------------------+-- recursive exception handlers++-- Don't forget to unblock async exceptions in the handler, or if we're+-- in an exception loop (eg. let a = error a in a) the ^C exception+-- may never be delivered. Thanks to Marcin for pointing out the bug.++ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a+ghciHandle h m = gmask $ \restore -> do+ -- Force dflags to avoid leaking the associated HscEnv+ !dflags <- getDynFlags+ gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)++ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)+ghciTry m = fmap Right m `gcatch` \e -> return $ Left e++tryBool :: ExceptionMonad m => m a -> m Bool+tryBool m = do+ r <- ghciTry m+ case r of+ Left _ -> return False+ Right _ -> return True++-- ----------------------------------------------------------------------------+-- Utils++lookupModule :: GHC.GhcMonad m => String -> m Module+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)++lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module+lookupModuleName mName = GHC.lookupModule mName Nothing++isHomeModule :: Module -> Bool+isHomeModule m = GHC.moduleUnitId m == mainUnitId++-- TODO: won't work if home dir is encoded.+-- (changeDirectory may not work either in that case.)+expandPath :: MonadIO m => String -> m String+expandPath = liftIO . expandPathIO++expandPathIO :: String -> IO String+expandPathIO p =+ case dropWhile isSpace p of+ ('~':d) -> do+ tilde <- getHomeDirectory -- will fail if HOME not defined+ return (tilde ++ '/':d)+ other ->+ return other++wantInterpretedModule :: GHC.GhcMonad m => String -> m Module+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)++wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module+wantInterpretedModuleName modname = do+ modl <- lookupModuleName modname+ let str = moduleNameString modname+ dflags <- getDynFlags+ when (GHC.moduleUnitId modl /= thisPackage dflags) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))+ is_interpreted <- GHC.moduleIsInterpreted modl+ when (not is_interpreted) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))+ return modl++wantNameFromInterpretedModule :: GHC.GhcMonad m+ => (Name -> SDoc -> m ())+ -> String+ -> (Name -> m ())+ -> m ()+wantNameFromInterpretedModule noCanDo str and_then =+ handleSourceError GHC.printException $ do+ names <- GHC.parseName str+ case names of+ [] -> return ()+ (n:_) -> do+ let modl = ASSERT( isExternalName n ) GHC.nameModule n+ if not (GHC.isExternalName n)+ then noCanDo n $ ppr n <>+ text " is not defined in an interpreted module"+ else do+ is_interpreted <- GHC.moduleIsInterpreted modl+ if not is_interpreted+ then noCanDo n $ text "module " <> ppr modl <>+ text " is not interpreted"+ else and_then n++clearAllTargets :: GhciMonad m => m ()+clearAllTargets = discardActiveBreakPoints+ >> GHC.setTargets []+ >> GHC.load LoadAllTargets+ >> pure ()+++------------------------------------------------------------------------------------------------+-- DAP Utility+------------------------------------------------------------------------------------------------++-- |+--+setStackTraceResult :: GhciMonad m => Resume -> [GHC.History] -> m ()+setStackTraceResult r hs = do+ ctxMVar <- dapContextGHCiState <$> getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {DAP.stackTraceResultDAPContext = Just (r, hs)}+++-- |+--+setBindingNames :: GhciMonad m => [Name] -> m ()+setBindingNames names = do+ ctxMVar <- dapContextGHCiState <$> getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {DAP.bindingNamesDAPContext = names}+++-- |+--+setContinueExecResult :: GhciMonad m => Maybe GHC.ExecResult -> m (Maybe GHC.ExecResult)+setContinueExecResult res = do+ ctxMVar <- dapContextGHCiState <$> getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx{DAP.continueExecResultDAPContext = res}+ return res+
+ app-ghc-8.10/GHCi/UI/Info.hs view
@@ -0,0 +1,382 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++-- | Get information on modules, expressions, and identifiers+module GHCi.UI.Info+ ( ModInfo(..)+ , SpanInfo(..)+ , spanInfoFromRealSrcSpan+ , collectInfo+ , findLoc+ , findNameUses+ , findType+ , getModInfo+ ) where++import Control.Exception+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Data.Data+import Data.Function+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Time+import Prelude hiding (mod,(<>))+import System.Directory++import qualified CoreUtils+import Desugar+import DynFlags (HasDynFlags(..))+import FastString+import GHC+import GhcMonad+import Name+import NameSet+import Outputable+import SrcLoc+import TcHsSyn+import Var++-- | Info about a module. This information is generated every time a+-- module is loaded.+data ModInfo = ModInfo+ { modinfoSummary :: !ModSummary+ -- ^ Summary generated by GHC. Can be used to access more+ -- information about the module.+ , modinfoSpans :: [SpanInfo]+ -- ^ Generated set of information about all spans in the+ -- module that correspond to some kind of identifier for+ -- which there will be type info and/or location info.+ , modinfoInfo :: !ModuleInfo+ -- ^ Again, useful from GHC for accessing information+ -- (exports, instances, scope) from a module.+ , modinfoLastUpdate :: !UTCTime+ -- ^ The timestamp of the file used to generate this record.+ }++-- | Type of some span of source code. Most of these fields are+-- unboxed but Haddock doesn't show that.+data SpanInfo = SpanInfo+ { spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan+ -- ^ The span we associate information with+ , spaninfoType :: !(Maybe Type)+ -- ^ The 'Type' associated with the span+ , spaninfoVar :: !(Maybe Id)+ -- ^ The actual 'Var' associated with the span, if+ -- any. This can be useful for accessing a variety of+ -- information about the identifier such as module,+ -- locality, definition location, etc.+ }++instance Outputable SpanInfo where+ ppr (SpanInfo s t i) = ppr s <+> ppr t <+> ppr i++-- | Test whether second span is contained in (or equal to) first span.+-- This is basically 'containsSpan' for 'SpanInfo'+containsSpanInfo :: SpanInfo -> SpanInfo -> Bool+containsSpanInfo = containsSpan `on` spaninfoSrcSpan++-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'+spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]+spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'++-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a+-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'+-- respectively)+spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo+spanInfoFromRealSrcSpan spn mty mvar =+ SpanInfo spn mty mvar++-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs+-- only a 'RealSrcSpan'+spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo+spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing++-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'+srcSpanFilePath :: RealSrcSpan -> FilePath+srcSpanFilePath = unpackFS . srcSpanFile++-- | Try to find the location of the given identifier at the given+-- position in the module.+findLoc :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo,Name,SrcSpan)+findLoc infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ name' <- findName infos span0 info string++ case getSrcSpan name' of+ UnhelpfulSpan{} -> do+ throwE ("Found a name, but no location information." <+>+ "The module is:" <+>+ maybe "<unknown>" (ppr . moduleName)+ (nameModule_maybe name'))++ span' -> return (info,name',span')++-- | Find any uses of the given identifier in the codebase.+findNameUses :: (GhcMonad m)+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m [SrcSpan]+findNameUses infos span0 string =+ locToSpans <$> findLoc infos span0 string+ where+ locToSpans (modinfo,name',span') =+ stripSurrounding (span' : map toSrcSpan spans)+ where+ toSrcSpan = RealSrcSpan . spaninfoSrcSpan+ spans = filter ((== Just name') . fmap getName . spaninfoVar)+ (modinfoSpans modinfo)++-- | Filter out redundant spans which surround/contain other spans.+stripSurrounding :: [SrcSpan] -> [SrcSpan]+stripSurrounding xs = filter (not . isRedundant) xs+ where+ isRedundant x = any (x `strictlyContains`) xs++ (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)+ = s1 /= s2 && s1 `containsSpan` s2+ _ `strictlyContains` _ = False++-- | Try to resolve the name located at the given position, or+-- otherwise resolve based on the current module's scope.+findName :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> ModInfo+ -> String+ -> ExceptT SDoc m Name+findName infos span0 mi string =+ case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> tryExternalModuleResolution+ Just name ->+ case getSrcSpan name of+ UnhelpfulSpan {} -> tryExternalModuleResolution+ RealSrcSpan {} -> return (getName name)+ where+ tryExternalModuleResolution =+ case find (matchName $ mkFastString string)+ (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of+ Nothing -> throwE "Couldn't resolve to any modules."+ Just imported -> resolveNameFromModule infos imported++ matchName :: FastString -> Name -> Bool+ matchName str name =+ str ==+ occNameFS (getOccName name)++-- | Try to resolve the name from another (loaded) module's exports.+resolveNameFromModule :: GhcMonad m+ => Map ModuleName ModInfo+ -> Name+ -> ExceptT SDoc m Name+resolveNameFromModule infos name = do+ modL <- maybe (throwE $ "No module for" <+> ppr name) return $+ nameModule_maybe name++ info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>+ ppr modL)) return $+ M.lookup (moduleName modL) infos++ maybe (throwE "No matching export in any local modules.") return $+ find (matchName name) (modInfoExports (modinfoInfo info))+ where+ matchName :: Name -> Name -> Bool+ matchName x y = occNameFS (getOccName x) ==+ occNameFS (getOccName y)++-- | Try to resolve the type display from the given span.+resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var+resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $+ reverse spans' `spaninfosWithin` si++-- | Try to find the type of the given span.+findType :: GhcMonad m+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo, Type)+findType infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> (,) info <$> lift (exprType TM_Inst string)+ Just ty -> return (info, ty)+ where+ -- | Try to resolve the type display from the given span.+ resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type+ resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $+ reverse spans' `spaninfosWithin` si++-- | Guess a module name from a file path.+guessModule :: GhcMonad m+ => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName+guessModule infos fp = do+ target <- lift $ guessTarget fp Nothing+ case targetId target of+ TargetModule mn -> return mn+ TargetFile fp' _ -> guessModule' fp'+ where+ guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName+ guessModule' fp' = case findModByFp fp' of+ Just mn -> return mn+ Nothing -> do+ fp'' <- liftIO (makeRelativeToCurrentDirectory fp')++ target' <- lift $ guessTarget fp'' Nothing+ case targetId target' of+ TargetModule mn -> return mn+ _ -> MaybeT . pure $ findModByFp fp''++ findModByFp :: FilePath -> Maybe ModuleName+ findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)+ where+ mifp :: (ModuleName, ModInfo) -> Maybe FilePath+ mifp = ml_hs_file . ms_location . modinfoSummary . snd+++-- | Collect type info data for the loaded modules.+collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]+ -> m (Map ModuleName ModInfo)+collectInfo ms loaded = do+ df <- getDynFlags+ liftIO (filterM cacheInvalid loaded) >>= \case+ [] -> return ms+ invalidated -> do+ liftIO (putStrLn ("Collecting type info for " +++ show (length invalidated) +++ " module(s) ... "))++ foldM (go df) ms invalidated+ where+ go df m name = do { info <- getModInfo name; return (M.insert name info m) }+ `gcatch`+ (\(e :: SomeException) -> do+ liftIO $ putStrLn+ $ showSDocForUser df alwaysQualify+ $ "Error while getting type info from" <+>+ ppr name <> ":" <+> text (show e)+ return m)++ cacheInvalid name = case M.lookup name ms of+ Nothing -> return True+ Just mi -> do+ let fp = srcFilePath (modinfoSummary mi)+ last' = modinfoLastUpdate mi+ current <- getModificationTime fp+ exists <- doesFileExist fp+ if exists+ then return $ current /= last'+ else return True++-- | Get the source file path from a ModSummary.+-- If the .hs file is missing, and the .o file exists,+-- we return the .o file path.+srcFilePath :: ModSummary -> FilePath+srcFilePath modSum = fromMaybe obj_fp src_fp+ where+ src_fp = ml_hs_file ms_loc+ obj_fp = ml_obj_file ms_loc+ ms_loc = ms_location modSum++-- | Get info about the module: summary, types, etc.+getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo+getModInfo name = do+ m <- getModSummary name+ p <- parseModule m+ typechecked <- typecheckModule p+ allTypes <- processAllTypeCheckedModule typechecked+ let i = tm_checked_module_info typechecked+ ts <- liftIO $ getModificationTime $ srcFilePath m+ return (ModInfo m allTypes i ts)++-- | Get ALL source spans in the module.+processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule+ -> m [SpanInfo]+processAllTypeCheckedModule tcm = do+ bts <- mapM getTypeLHsBind $ listifyAllSpans tcs+ ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs+ pts <- mapM getTypeLPat $ listifyAllSpans tcs+ return $ mapMaybe toSpanInfo+ $ sortBy cmpSpan+ $ catMaybes (bts ++ ets ++ pts)+ where+ tcs = tm_typechecked_source tcm++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's+ getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})+ = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))+ getTypeLHsBind _ = pure Nothing++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's+ getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLHsExpr e = do+ hs_env <- getSession+ (_,mbe) <- liftIO $ deSugarExpr hs_env e+ return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe+ where+ mid :: Maybe Id+ mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i+ | otherwise = Nothing++ unwrapVar (HsWrap _ _ var) = var+ unwrapVar e' = e'++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's+ getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+ getTypeLPat (dL->L spn pat) =+ pure (Just (getMaybeId pat,spn,hsPatType pat))+ where+ getMaybeId (VarPat _ (dL->L _ vid)) = Just vid+ getMaybeId _ = Nothing++ -- | Get ALL source spans in the source.+ listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]+ listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))+ where+ p (dL->L spn _) = isGoodSrcSpan spn++ -- | Variant of @syb@'s @everything@ (which summarises all nodes+ -- in top-down, left-to-right order) with a stop-condition on 'NameSet's+ everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r+ everythingAllSpans k z f x+ | (False `mkQ` (const True :: NameSet -> Bool)) x = z+ | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)++ cmpSpan (_,a,_) (_,b,_)+ | a `isSubspanOf` b = LT+ | b `isSubspanOf` a = GT+ | otherwise = EQ++ -- | Pretty print the types into a 'SpanInfo'.+ toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo+ toSpanInfo (n,RealSrcSpan spn,typ)+ = Just $ spanInfoFromRealSrcSpan spn (Just typ) n+ toSpanInfo _ = Nothing++-- helper stolen from @syb@ package+type GenericQ r = forall a. Data a => a -> r++mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r+(r `mkQ` br) a = maybe r br (cast a)
+ app-ghc-8.10/GHCi/UI/Monad.hs view
@@ -0,0 +1,620 @@+{-# LANGUAGE CPP, FlexibleInstances, DeriveFunctor #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+--+-- Monadery code used in InteractiveUI+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module GHCi.UI.Monad (+ GHCi(..), startGHCi,+ GHCiState(..), GhciMonad(..),+ GHCiOption(..), isOptionSet, setOption, unsetOption,+ Command(..), CommandResult(..), cmdSuccess,+ LocalConfigBehaviour(..),+ PromptFunction,+ BreakLocation(..),+ TickArray,+ getDynFlags,++ runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,+ ActionStats(..), runAndPrintStats, runWithStats, printStats,++ printForUserNeverQualify, printForUserModInfo,+ printForUser, printForUserPartWay, prettyLocations,++ compileGHCiExpr,+ initInterpBuffering,+ turnOffBuffering, turnOffBuffering_,+ flushInterpBuffers,+ mkEvalWrapper,++ -- DAP added.+ dapLookupMaxBreakLocation+ ) where++-- #include "HsVersions.h" -- DAP Modified++import GHCi.UI.Info (ModInfo)+import qualified GHC+import GhcMonad hiding (liftIO)+import Outputable hiding (printForUser, printForUserPartWay)+import qualified Outputable+import OccName+import DynFlags+import FastString+import HscTypes+import SrcLoc+import Module+import RdrName (mkOrig)+import PrelNames (gHC_GHCI_HELPERS)+import GHCi+import GHCi.RemoteTypes+import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)+import GHC.Hs.Utils+import Util++import Exception hiding (uninterruptibleMask, mask, catch)+import Numeric+import Data.Array+import Data.IORef+import Data.Time+import System.Environment+import System.IO+import Control.Monad+import Prelude hiding ((<>))++import System.Console.Haskeline (CompletionFunc, InputT)+import Control.Monad.Catch+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Data.Map.Strict (Map)+import qualified Data.IntMap.Strict as IntMap+import qualified GHC.LanguageExtensions as LangExt++-- DAP add.+import qualified GHCi.DAP.Type as DAP+import Control.Concurrent+++-----------------------------------------------------------------------------+-- GHCi monad++data GHCiState = GHCiState+ {+ progname :: String,+ args :: [String],+ evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@+ prompt :: PromptFunction,+ prompt_cont :: PromptFunction,+ editor :: String,+ stop :: String,+ localConfig :: LocalConfigBehaviour,+ options :: [GHCiOption],+ line_number :: !Int, -- ^ input line+ break_ctr :: !Int,+ breaks :: !(IntMap.IntMap BreakLocation),+ tickarrays :: ModuleEnv TickArray,+ -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,+ -- so that we don't rebuild it each time the user sets+ -- a breakpoint.+ ghci_commands :: [Command],+ -- ^ available ghci commands+ ghci_macros :: [Command],+ -- ^ user-defined macros+ last_command :: Maybe Command,+ -- ^ @:@ at the GHCi prompt repeats the last command, so we+ -- remember it here+ cmd_wrapper :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool),+ -- ^ The command wrapper is run for each command or statement.+ -- The 'Bool' value denotes whether the command is successful and+ -- 'Nothing' means to exit GHCi.+ cmdqueue :: [String],++ remembered_ctx :: [InteractiveImport],+ -- ^ The imports that the user has asked for, via import+ -- declarations and :module commands. This list is+ -- persistent over :reloads (but any imports for modules+ -- that are not loaded are temporarily ignored). After a+ -- :load, all the home-package imports are stripped from+ -- this list.+ --+ -- See bugs #2049, #1873, #1360++ transient_ctx :: [InteractiveImport],+ -- ^ An import added automatically after a :load, usually of+ -- the most recently compiled module. May be empty if+ -- there are no modules loaded. This list is replaced by+ -- :load, :reload, and :add. In between it may be modified+ -- by :module.++ extra_imports :: [ImportDecl GhcPs],+ -- ^ These are "always-on" imports, added to the+ -- context regardless of what other imports we have.+ -- This is useful for adding imports that are required+ -- by setGHCiMonad. Be careful adding things here:+ -- you can create ambiguities if these imports overlap+ -- with other things in scope.+ --+ -- NB. although this is not currently used by GHCi itself,+ -- it was added to support other front-ends that are based+ -- on the GHCi code. Potentially we could also expose+ -- this functionality via GHCi commands.++ prelude_imports :: [ImportDecl GhcPs],+ -- ^ These imports are added to the context when+ -- -XImplicitPrelude is on and we don't have a *-module+ -- in the context. They can also be overridden by another+ -- import for the same module, e.g.+ -- "import Prelude hiding (map)"++ ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)++ short_help :: String,+ -- ^ help text to display to a user+ long_help :: String,+ lastErrorLocations :: IORef [(FastString, Int)],++ mod_infos :: !(Map ModuleName ModInfo),++ flushStdHandles :: ForeignHValue,+ -- ^ @hFlush stdout; hFlush stderr@ in the interpreter+ noBuffering :: ForeignHValue,+ -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr+ dapContextGHCiState :: DAP.MVarDAPContext+ }++type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]++-- | A GHCi command+data Command+ = Command+ { cmdName :: String+ -- ^ Name of GHCi command (e.g. "exit")+ , cmdAction :: String -> InputT GHCi Bool+ -- ^ The 'Bool' value denotes whether to exit GHCi+ , cmdHidden :: Bool+ -- ^ Commands which are excluded from default completion+ -- and @:help@ summary. This is usually set for commands not+ -- useful for interactive use but rather for IDEs.+ , cmdCompletionFunc :: CompletionFunc GHCi+ -- ^ 'CompletionFunc' for arguments+ }++data CommandResult+ = CommandComplete+ { cmdInput :: String+ , cmdResult :: Either SomeException (Maybe Bool)+ , cmdStats :: ActionStats+ }+ | CommandIncomplete+ -- ^ Unterminated multiline command+ deriving Show++cmdSuccess :: MonadThrow m => CommandResult -> m (Maybe Bool)+cmdSuccess CommandComplete{ cmdResult = Left e } = throwM e+cmdSuccess CommandComplete{ cmdResult = Right r } = return r+cmdSuccess CommandIncomplete = return $ Just True++type PromptFunction = [String]+ -> Int+ -> GHCi SDoc++data GHCiOption+ = ShowTiming -- show time/allocs after evaluation+ | ShowType -- show the type of expressions+ | RevertCAFs -- revert CAFs after every evaluation+ | Multiline -- use multiline commands+ | CollectInfo -- collect and cache information about+ -- modules after load+ deriving Eq++-- | Treatment of ./.ghci files. For now we either load or+-- ignore. But later we could implement a "safe mode" where+-- only safe operations are performed.+--+data LocalConfigBehaviour+ = SourceLocalConfig+ | IgnoreLocalConfig+ deriving (Eq)++data BreakLocation+ = BreakLocation+ { breakModule :: !GHC.Module+ , breakLoc :: !SrcSpan+ , breakTick :: {-# UNPACK #-} !Int+ , breakEnabled:: !Bool+ , onBreakCmd :: String+ }++instance Eq BreakLocation where+ loc1 == loc2 = breakModule loc1 == breakModule loc2 &&+ breakTick loc1 == breakTick loc2++prettyLocations :: IntMap.IntMap BreakLocation -> SDoc+prettyLocations locs =+ case IntMap.null locs of+ True -> text "No active breakpoints."+ False -> vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ IntMap.toAscList locs++instance Outputable BreakLocation where+ ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> pprEnaDisa <+>+ if null (onBreakCmd loc)+ then Outputable.empty+ else doubleQuotes (text (onBreakCmd loc))+ where pprEnaDisa = case breakEnabled loc of+ True -> text "enabled"+ False -> text "disabled"++recordBreak+ :: GhciMonad m => BreakLocation -> m (Bool{- was already present -}, Int)+recordBreak brkLoc = do+ st <- getGHCiState+ let oldmap = breaks st+ oldActiveBreaks = IntMap.assocs oldmap+ -- don't store the same break point twice+ case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of+ (nm:_) -> return (True, nm)+ [] -> do+ let oldCounter = break_ctr st+ newCounter = oldCounter + 1+ setGHCiState $ st { break_ctr = newCounter,+ breaks = IntMap.insert oldCounter brkLoc oldmap+ }+ return (False, oldCounter)++newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }+ deriving (Functor)++reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s++startGHCi :: GHCi a -> GHCiState -> Ghc a+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref++instance Applicative GHCi where+ pure a = GHCi $ \_ -> pure a+ (<*>) = ap++instance Monad GHCi where+ (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s++class GhcMonad m => GhciMonad m where+ getGHCiState :: m GHCiState+ setGHCiState :: GHCiState -> m ()+ modifyGHCiState :: (GHCiState -> GHCiState) -> m ()+ reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> m a++instance GhciMonad GHCi where+ getGHCiState = GHCi $ \r -> liftIO $ readIORef r+ setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s+ modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f+ reifyGHCi f = GHCi $ \r -> reifyGhc $ \s -> f (s, r)++instance GhciMonad (InputT GHCi) where+ getGHCiState = lift getGHCiState+ setGHCiState = lift . setGHCiState+ modifyGHCiState = lift . modifyGHCiState+ reifyGHCi = lift . reifyGHCi++liftGhc :: Ghc a -> GHCi a+liftGhc m = GHCi $ \_ -> m++instance MonadIO GHCi where+ liftIO = liftGhc . liftIO++instance HasDynFlags GHCi where+ getDynFlags = getSessionDynFlags++instance GhcMonad GHCi where+ setSession s' = liftGhc $ setSession s'+ getSession = liftGhc $ getSession++instance HasDynFlags (InputT GHCi) where+ getDynFlags = lift getDynFlags++instance GhcMonad (InputT GHCi) where+ setSession = lift . setSession+ getSession = lift getSession++instance ExceptionMonad GHCi where+ gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)+ gmask f =+ GHCi $ \s -> gmask $ \io_restore ->+ let+ g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')+ in+ unGHCi (f g_restore) s++instance MonadThrow Ghc where+ throwM = liftIO . throwM++instance MonadCatch Ghc where+ catch = gcatch++instance MonadMask Ghc where+ mask f = Ghc $ \s ->+ mask $ \io_restore ->+ let g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)+ in unGhc (f g_restore) s+ uninterruptibleMask f = Ghc $ \s ->+ uninterruptibleMask $ \io_restore ->+ let g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)+ in unGhc (f g_restore) s+ generalBracket acquire release use = Ghc $ \s ->+ generalBracket+ (unGhc acquire s)+ (\resource exitCase -> unGhc (release resource exitCase) s)+ (\resource -> unGhc (use resource) s)++instance MonadThrow GHCi where+ throwM = liftIO . throwM++instance MonadCatch GHCi where+ catch = gcatch++instance MonadMask GHCi where+ mask f = GHCi $ \s ->+ mask $ \io_restore ->+ let g_restore (GHCi m) = GHCi $ \s -> io_restore (m s)+ in unGHCi (f g_restore) s+ uninterruptibleMask f = GHCi $ \s ->+ uninterruptibleMask $ \io_restore ->+ let g_restore (GHCi m) = GHCi $ \s -> io_restore (m s)+ in unGHCi (f g_restore) s+ generalBracket acquire release use = GHCi $ \s ->+ generalBracket+ (unGHCi acquire s)+ (\resource exitCase -> unGHCi (release resource exitCase) s)+ (\resource -> unGHCi (use resource) s)++instance ExceptionMonad (InputT GHCi) where+ gcatch = catch+ gmask = mask++isOptionSet :: GhciMonad m => GHCiOption -> m Bool+isOptionSet opt+ = do st <- getGHCiState+ return (opt `elem` options st)++setOption :: GhciMonad m => GHCiOption -> m ()+setOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = opt : filter (/= opt) (options st) })++unsetOption :: GhciMonad m => GHCiOption -> m ()+unsetOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = filter (/= opt) (options st) })++printForUserNeverQualify :: GhcMonad m => SDoc -> m ()+printForUserNeverQualify doc = do+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout neverQualify doc++printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()+printForUserModInfo info doc = do+ dflags <- getDynFlags+ mUnqual <- GHC.mkPrintUnqualifiedForModule info+ unqual <- maybe GHC.getPrintUnqual return mUnqual+ liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUser :: GhcMonad m => SDoc -> m ()+printForUser doc = do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUserPartWay :: GhcMonad m => SDoc -> m ()+printForUserPartWay doc = do+ unqual <- GHC.getPrintUnqual+ dflags <- getDynFlags+ liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc++-- | Run a single Haskell expression+runStmt+ :: GhciMonad m+ => GhciLStmt GhcPs -> String -> GHC.SingleStep -> m (Maybe GHC.ExecResult)+runStmt stmt stmt_text step = do+ st <- getGHCiState+ GHC.handleSourceError (\e -> do GHC.printException e; dapSaveRunStmtDeclException e; return Nothing) $ do+ let opts = GHC.execOptions+ { GHC.execSourceFile = progname st+ , GHC.execLineNumber = line_number st+ , GHC.execSingleStep = step+ , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))+ (EvalThis fhv) }+ Just <$> GHC.execStmt' stmt stmt_text opts++runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name])+runDecls decls = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.handleSourceError (\e -> do GHC.printException e;+ dapSaveRunStmtDeclException e;+ return Nothing) $ do+ r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls+ return (Just r)++runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name])+runDecls' decls = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $+ GHC.handleSourceError+ (\e -> do GHC.printException e;+ return Nothing)+ (Just <$> GHC.runParsedDecls decls)++resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> m GHC.ExecResult+resume canLogSpan step = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.resumeExec canLogSpan step++-- --------------------------------------------------------------------------+-- timing & statistics++data ActionStats = ActionStats+ { actionAllocs :: Maybe Integer+ , actionElapsedTime :: Double+ } deriving Show++runAndPrintStats+ :: GhciMonad m+ => (a -> Maybe Integer)+ -> m a+ -> m (ActionStats, Either SomeException a)+runAndPrintStats getAllocs action = do+ result <- runWithStats getAllocs action+ case result of+ (stats, Right{}) -> do+ showTiming <- isOptionSet ShowTiming+ when showTiming $ do+ dflags <- getDynFlags+ liftIO $ printStats dflags stats+ _ -> return ()+ return result++runWithStats+ :: ExceptionMonad m+ => (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)+runWithStats getAllocs action = do+ t0 <- liftIO getCurrentTime+ result <- gtry action+ let allocs = either (const Nothing) getAllocs result+ t1 <- liftIO getCurrentTime+ let elapsedTime = realToFrac $ t1 `diffUTCTime` t0+ return (ActionStats allocs elapsedTime, result)++printStats :: DynFlags -> ActionStats -> IO ()+printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}+ = do let secs_str = showFFloat (Just 2) secs+ putStrLn (showSDoc dflags (+ parens (text (secs_str "") <+> text "secs" <> comma <+>+ case mallocs of+ Nothing -> empty+ Just allocs ->+ text (separateThousands allocs) <+> text "bytes")))+ where+ separateThousands n = reverse . sep . reverse . show $ n+ where sep n'+ | n' `lengthAtMost` 3 = n'+ | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')++-----------------------------------------------------------------------------+-- reverting CAFs++revertCAFs :: GhciMonad m => m ()+revertCAFs = do+ hsc_env <- GHC.getSession+ liftIO $ iservCmd hsc_env RtsRevertCAFs+ s <- getGHCiState+ when (not (ghc_e s)) turnOffBuffering+ -- Have to turn off buffering again, because we just+ -- reverted stdout, stderr & stdin to their defaults.+++-----------------------------------------------------------------------------+-- To flush buffers for the *interpreted* computation we need+-- to refer to *its* stdout/stderr handles++-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly+initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)+initInterpBuffering = do+ let mkHelperExpr :: OccName -> Ghc ForeignHValue+ mkHelperExpr occ =+ GHC.compileParsedExprRemote+ $ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS occ+ nobuf <- mkHelperExpr $ mkVarOcc "disableBuffering"+ flush <- mkHelperExpr $ mkVarOcc "flushAll"+ return (nobuf, flush)++-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter+flushInterpBuffers :: GhciMonad m => m ()+flushInterpBuffers = do+ st <- getGHCiState+ hsc_env <- GHC.getSession+ liftIO $ evalIO hsc_env (flushStdHandles st)++-- | Turn off buffering for stdin, stdout, and stderr in the interpreter+turnOffBuffering :: GhciMonad m => m ()+turnOffBuffering = do+ st <- getGHCiState+ turnOffBuffering_ (noBuffering st)++turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()+turnOffBuffering_ fhv = do+ hsc_env <- getSession+ liftIO $ evalIO hsc_env fhv++mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue+mkEvalWrapper progname args =+ runInternal $ GHC.compileParsedExprRemote+ $ evalWrapper `GHC.mkHsApp` nlHsString progname+ `GHC.mkHsApp` nlList (map nlHsString args)+ where+ nlHsString = nlHsLit . mkHsString+ evalWrapper =+ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOcc "evalWrapper")++-- | Run a 'GhcMonad' action to compile an expression for internal usage.+runInternal :: GhcMonad m => m a -> m a+runInternal =+ withTempSession mkTempSession+ where+ mkTempSession hsc_env = hsc_env+ { hsc_dflags = (hsc_dflags hsc_env) {+ -- Running GHCi's internal expression is incompatible with -XSafe.+ -- We temporarily disable any Safe Haskell settings while running+ -- GHCi internal expressions. (see #12509)+ safeHaskell = Sf_None+ }+ -- RebindableSyntax can wreak havoc with GHCi in several ways+ -- (see #13385 and #14342 for examples), so we temporarily+ -- disable it too.+ `xopt_unset` LangExt.RebindableSyntax+ -- We heavily depend on -fimplicit-import-qualified to compile expr+ -- with fully qualified names without imports.+ `gopt_set` Opt_ImplicitImportQualified+ }++compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue+compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr++++------------------------------------------------------------------------------------------------+-- DAP Utility+------------------------------------------------------------------------------------------------++-- |+--+dapSaveRunStmtDeclException :: GhciMonad m => SourceError -> m SourceError+dapSaveRunStmtDeclException res = do+ mvarCtx <- dapContextGHCiState <$> getGHCiState++ ctx <- liftIO $ takeMVar mvarCtx+ liftIO $ putMVar mvarCtx ctx{DAP.runStmtDeclExceptionDAPContext = Just res}++ return res+++-- |+--+dapLookupMaxBreakLocation :: GhciMonad m => m (Maybe (Int, BreakLocation))+dapLookupMaxBreakLocation = do+ newSt <- getGHCiState+ return $ IntMap.lookupMax (breaks newSt)+
+ app-ghc-8.10/GHCi/UI/Tags.hs view
@@ -0,0 +1,216 @@+-----------------------------------------------------------------------------+--+-- GHCi's :ctags and :etags commands+--+-- (c) The GHC Team 2005-2007+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+module GHCi.UI.Tags (+ createCTagsWithLineNumbersCmd,+ createCTagsWithRegExesCmd,+ createETagsFileCmd+) where++import Exception+import GHC+import GHCi.UI.Monad+import Outputable++-- ToDo: figure out whether we need these, and put something appropriate+-- into the GHC API instead+import Name (nameOccName)+import OccName (pprOccName)+import ConLike+import MonadUtils++import Control.Monad+import Data.Function+import Data.List+import Data.Maybe+import Data.Ord+import DriverPhases+import Panic+import Prelude+import System.Directory+import System.IO+import System.IO.Error++-----------------------------------------------------------------------------+-- create tags file for currently loaded modules.++createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,+ createETagsFileCmd :: String -> GHCi ()++createCTagsWithLineNumbersCmd "" =+ ghciCreateTagsFile CTagsWithLineNumbers "tags"+createCTagsWithLineNumbersCmd file =+ ghciCreateTagsFile CTagsWithLineNumbers file++createCTagsWithRegExesCmd "" =+ ghciCreateTagsFile CTagsWithRegExes "tags"+createCTagsWithRegExesCmd file =+ ghciCreateTagsFile CTagsWithRegExes file++createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"+createETagsFileCmd file = ghciCreateTagsFile ETags file++data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes++ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()+ghciCreateTagsFile kind file = do+ createTagsFile kind file++-- ToDo:+-- - remove restriction that all modules must be interpreted+-- (problem: we don't know source locations for entities unless+-- we compiled the module.+--+-- - extract createTagsFile so it can be used from the command-line+-- (probably need to fix first problem before this is useful).+--+createTagsFile :: TagsKind -> FilePath -> GHCi ()+createTagsFile tagskind tagsFile = do+ graph <- GHC.getModuleGraph+ mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)+ either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags+ case either_res of+ Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e+ Right _ -> return ()+++listModuleTags :: GHC.Module -> GHCi [TagInfo]+listModuleTags m = do+ is_interpreted <- GHC.moduleIsInterpreted m+ -- should we just skip these?+ when (not is_interpreted) $+ let mName = GHC.moduleNameString (GHC.moduleName m) in+ throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))+ mbModInfo <- GHC.getModuleInfo m+ case mbModInfo of+ Nothing -> return []+ Just mInfo -> do+ dflags <- getDynFlags+ mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo+ let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual+ let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo+ let localNames = filter ((m==) . nameModule) names+ mbTyThings <- mapM GHC.lookupName localNames+ return $! [ tagInfo dflags unqual exported kind name realLoc+ | tyThing <- catMaybes mbTyThings+ , let name = getName tyThing+ , let exported = GHC.modInfoIsExportedName mInfo name+ , let kind = tyThing2TagKind tyThing+ , let loc = srcSpanStart (nameSrcSpan name)+ , RealSrcLoc realLoc <- [loc]+ ]++ where+ tyThing2TagKind (AnId _) = 'v'+ tyThing2TagKind (AConLike RealDataCon{}) = 'd'+ tyThing2TagKind (AConLike PatSynCon{}) = 'p'+ tyThing2TagKind (ATyCon _) = 't'+ tyThing2TagKind (ACoAxiom _) = 'x'+++data TagInfo = TagInfo+ { tagExported :: Bool -- is tag exported+ , tagKind :: Char -- tag kind+ , tagName :: String -- tag name+ , tagFile :: String -- file name+ , tagLine :: Int -- line number+ , tagCol :: Int -- column number+ , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset+ }+++-- get tag info, for later translation into Vim or Emacs style+tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc+ -> TagInfo+tagInfo dflags unqual exported kind name loc+ = TagInfo exported kind+ (showSDocForUser dflags unqual $ pprOccName (nameOccName name))+ (showSDocForUser dflags unqual $ ftext (srcLocFile loc))+ (srcLocLine loc) (srcLocCol loc) Nothing++-- throw an exception when someone tries to overwrite existing source file (fix for #10989)+writeTagsSafely :: FilePath -> String -> IO ()+writeTagsSafely file str = do+ dfe <- doesFileExist file+ if dfe && isSourceFilename file+ then throwGhcException (CmdLineError (file ++ " is existing source file. " +++ "Please specify another file name to store tags data"))+ else writeFile file str++collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())+-- ctags style with the Ex expression being just the line number, Vim et al+collateAndWriteTags CTagsWithLineNumbers file tagInfos = do+ let tags = unlines $ sort $ map showCTag tagInfos+ tryIO (writeTagsSafely file tags)++-- ctags style with the Ex expression being a regex searching the line, Vim et al+collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al+ tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos+ let tags = unlines $ sort $ map showCTag $concat tagInfoGroups+ tryIO (writeTagsSafely file tags)++collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs+ tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos+ let tagGroups = map processGroup tagInfoGroups+ tryIO (writeTagsSafely file $ concat tagGroups)++ where+ processGroup [] = throwGhcException (CmdLineError "empty tag file group??")+ processGroup group@(tagInfo:_) =+ let tags = unlines $ map showETag group in+ "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags+++makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]+makeTagGroupsWithSrcInfo tagInfos = do+ let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos+ mapM addTagSrcInfo groups++ where+ addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")+ addTagSrcInfo group@(tagInfo:_) = do+ file <- readFile $tagFile tagInfo+ let sortedGroup = sortBy (comparing tagLine) group+ return $ perFile sortedGroup 1 0 $ lines file++ perFile allTags@(tag:tags) cnt pos allLs@(l:ls)+ | tagLine tag > cnt =+ perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls+ | tagLine tag == cnt =+ tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs+ perFile _ _ _ _ = []+++-- ctags format, for Vim et al+showCTag :: TagInfo -> String+showCTag ti =+ tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" +++ tagKind ti : ( if tagExported ti then "" else "\tfile:" )++ where+ tagCmd =+ case tagSrcInfo ti of+ Nothing -> show $tagLine ti+ Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"++ where+ escapeSlashes '/' r = '\\' : '/' : r+ escapeSlashes '\\' r = '\\' : '\\' : r+ escapeSlashes c r = c : r+++-- etags format, for Emacs/XEmacs+showETag :: TagInfo -> String+showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,+ tagSrcInfo = Just (srcLine,charPos) }+ = take (colNo - 1) srcLine ++ tag+ ++ "\x7f" ++ tag+ ++ "\x01" ++ show lineNo+ ++ "," ++ show charPos+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
+ app-ghc-8.10/GHCi/Util.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE MagicHash, UnboxedTuples #-}++-- | Utilities for GHCi.+module GHCi.Util where++-- NOTE: Avoid importing GHC modules here, because the primary purpose+-- of this module is to not use UnboxedTuples in a module that imports+-- lots of other modules. See issue#13101 for more info.++import GHC.Exts+import GHC.Types++anyToPtr :: a -> IO (Ptr ())+anyToPtr x =+ IO (\s -> case anyToAddr# x s of+ (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())
− app-ghc-8.4/GHCMain.hs
@@ -1,946 +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 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 )---- 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<size>---------------------------------------------------------------------------------- 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-- -- Handle GHC-specific character encoding flags, allowing us to control how- -- GHC produces output regardless of OS.- env <- getEnvironment- case lookup "GHC_CHARENC" env of- Just "UTF-8" -> do- hSetEncoding stdout utf8- hSetEncoding stderr utf8- _ -> do- -- Avoid GHC erroring out when trying to display unhandled characters- hSetTranslit stdout- hSetTranslit stderr-- 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 srcs Nothing -- DAP Modified- DoEval exprs -> ghciUI setting srcs $ Just $ reverse exprs -- DAP Modified- DoAbiHash -> abiHash (map fst srcs)- ShowPackages -> liftIO $ showPackages dflags6- DoFrontend f -> doFrontend f srcs- DoBackpack -> doBackpack (map fst srcs)-- liftIO $ dumpFinalStats dflags6--ghciUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () -- DAP Modified-#if !defined(GHCI)-ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use") -- DAP Modified-#else-ghciUI = interactiveUI -- DAP Modified-#endif---- -------------------------------------------------------------------------------- Splitting arguments into source files and object files. This is where we--- interpret the -x <suffix> 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 ()
− app-ghc-8.4/GHCi/UI.hs
@@ -1,3854 +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,- 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 )---- 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 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 )----------------------------------------------------------------------------------- DAP--------------------------------------------------------------------------------import qualified GHCi.DAP.Type as DAP-import qualified GHCi.DAP.UI as DAP----------------------------------------------------------------------------------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),- ("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" ++- " <statement> evaluate/run <statement>\n" ++- " : repeat last command\n" ++- " :{\\n ..lines.. \\n:}\\n multiline command\n" ++- " :add [*]<module> ... add module(s) to the current target set\n" ++- " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++- " (!: more details; *: all top-level names)\n" ++- " :cd <dir> change directory to <dir>\n" ++- " :cmd <expr> run the commands returned by <expr>::IO String\n" ++- " :complete <dom> [<rng>] <s> list completions for partial input string\n" ++- " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" ++- " (!: use regex instead of line number)\n" ++- " :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++- " precedence, ::<cmd> is always a builtin command)\n" ++- " :edit <file> edit file\n" ++- " :edit edit last module\n" ++- " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" ++- " :help, :? display this list of commands\n" ++- " :info[!] [<name> ...] display information about the given names\n" ++- " (!: do not filter instances)\n" ++- " :issafe [<mod>] display safe haskell information of module <mod>\n" ++- " :kind[!] <type> show the kind of <type>\n" ++- " (!: also print the normalised type)\n" ++- " :load[!] [*]<module> ... load module(s) and their dependents\n" ++- " (!: defer type errors)\n" ++- " :main [<arguments> ...] run the main function with the given arguments\n" ++- " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++- " :quit exit GHCi\n" ++- " :reload[!] reload the current module set\n" ++- " (!: defer type errors)\n" ++- " :run function [<arguments> ...] run the function with the given arguments\n" ++- " :script <file> run the script <file>\n" ++- " :type <expr> show the type of <expr>\n" ++- " :type +d <expr> show the type of <expr>, defaulting type variables\n" ++- " :type +v <expr> show the type of <expr>, with its specified tyvars\n" ++- " :unadd <module> ... remove module(s) from the current target set\n" ++- " :undef <cmd> undefine user-defined command :<cmd>\n" ++- " :!<command> run the shell command <command>\n" ++- "\n" ++- " -- Commands for debugging:\n" ++- "\n" ++- " :abandon at a breakpoint, abandon current computation\n" ++- " :back [<n>] go back in the history N steps (after :trace)\n" ++- " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++- " :break <name> set a breakpoint on the specified function\n" ++- " :continue resume after a breakpoint\n" ++- " :delete <number> delete the specified breakpoint\n" ++- " :delete * delete all breakpoints\n" ++- " :force <expr> print <expr>, forcing unevaluated parts\n" ++- " :forward [<n>] go forward in the history N step s(after :back)\n" ++- " :history [<n>] after :trace, show the execution history\n" ++- " :list show the source code around current breakpoint\n" ++- " :list <identifier> show the source code for <identifier>\n" ++- " :list [<module>] <line> show the source code around line number <line>\n" ++- " :print [<name> ...] show a value without forcing its computation\n" ++- " :sprint [<name> ...] simplified version of :print\n" ++- " :step single-step after stopping at a breakpoint\n"++- " :step <expr> single-step into <expr>\n"++- " :steplocal single-step within the current top-level binding\n"++- " :stepmodule single-step restricted to the current module\n"++- " :trace trace after stopping at a breakpoint\n"++- " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++-- "\n" ++- " -- Commands for changing settings:\n" ++- "\n" ++- " :set <option> ... set options\n" ++- " :seti <option> ... set options for interactive evaluation only\n" ++- " :set args <arg> ... set the arguments returned by System.getArgs\n" ++- " :set prog <progname> set the value returned by System.getProgName\n" ++- " :set prompt <prompt> set the prompt used in GHCi\n" ++- " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" ++- " :set prompt-function <expr> set the function to handle the prompt\n" ++- " :set prompt-cont-function <expr>" ++- "set the function to handle the continuation prompt\n" ++- " :set editor <cmd> set the command used for :edit\n" ++- " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++- " :unset <option> ... unset options\n" ++- "\n" ++- " Options for ':set' and ':unset':\n" ++- "\n" ++- " +m allow multiline commands\n" ++- " +r revert top-level expressions after each evaluation\n" ++- " +s print timing/memory stats after each evaluation\n" ++- " +t print type after evaluation\n" ++- " +c collect type/location info after loading modules\n" ++- " -<flags> most GHC command line flags can also be set here\n" ++- " (eg. -v2, -XFlexibleInstances, etc.)\n" ++- " for GHCi-specific flags, see User's Guide,\n"++- " Flag reference, Interactive-mode options\n" ++- "\n" ++- " -- Commands for displaying information:\n" ++- "\n" ++- " :show bindings show the current bindings made at the prompt\n" ++- " :show breaks show the active breakpoints\n" ++- " :show context show the breakpoint context\n" ++- " :show imports show the current imports\n" ++- " :show linker show current linker state\n" ++- " :show modules show the currently loaded modules\n" ++- " :show packages show the currently active package flags\n" ++- " :show paths show the currently active search paths\n" ++- " :show language show the currently active language flags\n" ++- " :show targets show the current set of targets\n" ++- " :show <setting> show value of <setting>, which is one of\n" ++- " [args, prog, editor, stop]\n" ++- " :showi language show language flags for interactive evaluation\n" ++- "\n"--findEditor :: IO String-findEditor = do- getEnv "EDITOR"- `catchIO` \_ -> do-#if defined(mingw32_HOST_OS)- win <- System.Win32.getWindowsDirectory- return (win </> "notepad.exe")-#else- return ""-#endif--default_progname, default_stop :: String-default_progname = "<interactive>"-default_stop = ""--default_prompt, default_prompt_cont :: PromptFunction-default_prompt = generatePromptFunctionFromString "%s> "-default_prompt_cont = generatePromptFunctionFromString "%s| "--default_args :: [String]-default_args = []--interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]- -> Ghc ()-interactiveUI config srcs maybe_exprs = do- -- HACK! If we happen to get into an infinite loop (eg the user- -- types 'let x=x in x' at the prompt), then the thread will block- -- on a blackhole, and become unreachable during GC. The GC will- -- detect that it is unreachable and send it the NonTermination- -- exception. However, since the thread is unreachable, everything- -- it refers to might be finalized, including the standard Handles.- -- This sounds like a bug, but we don't have a good solution right- -- now.- _ <- liftIO $ newStablePtr stdin- _ <- liftIO $ newStablePtr stdout- _ <- liftIO $ newStablePtr stderr-- -- Initialise buffering for the *interpreted* I/O system- (nobuffering, flush) <- initInterpBuffering-- -- The initial set of DynFlags used for interactive evaluation is the same- -- as the global DynFlags, plus -XExtendedDefaultRules and- -- -XNoMonomorphismRestriction.- dflags <- getDynFlags- let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)- . (`xopt_unset` LangExt.MonomorphismRestriction)- $ dflags- GHC.setInteractiveDynFlags dflags'-- lastErrLocationsRef <- liftIO $ newIORef []- progDynFlags <- GHC.getProgramDynFlags- _ <- GHC.setProgramDynFlags $- progDynFlags { log_action = ghciLogAction lastErrLocationsRef }-- when (isNothing maybe_exprs) $ do- -- Only for GHCi (not runghc and ghc -e):-- -- Turn buffering off for the compiled program's stdout/stderr- turnOffBuffering_ nobuffering- -- Turn buffering off for GHCi's stdout- liftIO $ hFlush stdout- liftIO $ hSetBuffering stdout NoBuffering- -- We don't want the cmd line to buffer any input that might be- -- intended for the program, so unbuffer stdin.- liftIO $ hSetBuffering stdin NoBuffering- liftIO $ hSetBuffering stderr NoBuffering-#if defined(mingw32_HOST_OS)- -- On Unix, stdin will use the locale encoding. The IO library- -- doesn't do this on Windows (yet), so for now we use UTF-8,- -- for consistency with GHC 6.10 and to make the tests work.- liftIO $ hSetEncoding stdin utf8-#endif-- default_editor <- liftIO $ findEditor- eval_wrapper <- mkEvalWrapper default_progname default_args- let prelude_import = simpleImportDecl preludeModuleName- startGHCi (runGHCi srcs maybe_exprs)- GHCiState{ progname = default_progname,- args = default_args,- evalWrapper = eval_wrapper,- prompt = default_prompt,- prompt_cont = default_prompt_cont,- stop = default_stop,- editor = default_editor,- options = [],- -- We initialize line number as 0, not 1, because we use- -- current line number while reporting errors which is- -- incremented after reading a line.- line_number = 0,- break_ctr = 0,- breaks = [],- tickarrays = emptyModuleEnv,- ghci_commands = availableCommands config,- ghci_macros = [],- last_command = Nothing,- cmdqueue = [],- remembered_ctx = [],- transient_ctx = [],- extra_imports = [],- prelude_imports = [prelude_import],- ghc_e = isJust maybe_exprs,- short_help = shortHelpText config,- long_help = fullHelpText config,- lastErrorLocations = lastErrLocationsRef,- mod_infos = M.empty,- flushStdHandles = flush,- noBuffering = nobuffering,- dapContextGHCiState = dapContextGhciSettings config- }-- return ()--resetLastErrorLocations :: GHCi ()-resetLastErrorLocations = do- st <- getGHCiState- liftIO $ writeIORef (lastErrorLocations st) []--ghciLogAction :: IORef [(FastString, Int)] -> LogAction-ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do- defaultLogAction dflags flag severity srcSpan style msg- case severity of- SevError -> case srcSpan of- RealSrcSpan rsp -> modifyIORef lastErrLocations- (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])- _ -> return ()- _ -> return ()--withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a-withGhcAppData right left = do- either_dir <- tryIO (getAppUserDataDirectory "ghc")- case either_dir of- Right dir ->- do createDirectoryIfMissing False dir `catchIO` \_ -> return ()- right dir- _ -> left--runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()-runGHCi paths maybe_exprs = do- dflags <- getDynFlags- let- ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags-- current_dir = return (Just ".ghci")-- app_user_dir = liftIO $ withGhcAppData- (\dir -> return (Just (dir </> "ghci.conf")))- (return Nothing)-- home_dir = do- either_dir <- liftIO $ tryIO (getEnv "HOME")- case either_dir of- Right home -> return (Just (home </> ".ghci"))- _ -> return Nothing-- canonicalizePath' :: FilePath -> IO (Maybe FilePath)- canonicalizePath' fp = liftM Just (canonicalizePath fp)- `catchIO` \_ -> return Nothing-- sourceConfigFile :: FilePath -> GHCi ()- sourceConfigFile file = do- exists <- liftIO $ doesFileExist file- when exists $ do- either_hdl <- liftIO $ tryIO (openFile file ReadMode)- case either_hdl of- Left _e -> return ()- -- NOTE: this assumes that runInputT won't affect the terminal;- -- can we assume this will always be the case?- -- This would be a good place for runFileInputT.- Right hdl ->- do runInputTWithPrefs defaultPrefs defaultSettings $- runCommands $ fileLoop hdl- liftIO (hClose hdl `catchIO` \_ -> return ())- -- Don't print a message if this is really ghc -e (#11478).- -- Also, let the user silence the message with -v0- -- (the default verbosity in GHCi is 1).- when (isNothing maybe_exprs && verbosity dflags > 0) $- liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)-- ---- setGHCContextFromGHCiState-- dot_cfgs <- if ignore_dot_ghci then return [] else do- dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]- liftIO $ filterM checkFileAndDirPerms dot_files- mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs-- let arg_cfgs = reverse $ ghciScripts dflags- -- -ghci-script are collected in reverse order- -- We don't require that a script explicitly added by -ghci-script- -- is owned by the current user. (#6017)- mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs- -- nub, because we don't want to read .ghci twice if the CWD is $HOME.-- -- Perform a :load for files given on the GHCi command line- -- When in -e mode, if the load fails then we want to stop- -- immediately rather than going on to evaluate the expression.- when (not (null paths)) $ do- ok <- ghciHandle (\e -> do showException e; return Failed) $- -- TODO: this is a hack.- runInputTWithPrefs defaultPrefs defaultSettings $- loadModule paths- when (isJust maybe_exprs && failed ok) $- liftIO (exitWith (ExitFailure 1))-- installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)-- -- if verbosity is greater than 0, or we are connected to a- -- terminal, display the prompt in the interactive loop.- -- is_tty <- liftIO (hIsTerminalDevice stdin)- is_tty <- liftIO (return True) -- DAP modified.- let show_prompt = verbosity dflags > 0 || is_tty-- -- reset line number- modifyGHCiState $ \st -> st{line_number=0}-- case maybe_exprs of- Nothing ->- do- -- enter the interactive loop- runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty- Just exprs -> do- -- just evaluate the expression we were given- enqueueCommands exprs- let hdle e = do st <- getGHCiState- -- flush the interpreter's stdout/stderr on exit (#3890)- flushInterpBuffers- -- Jump through some hoops to get the- -- current progname in the exception text:- -- <progname>: <exception>- liftIO $ withProgName (progname st)- $ topHandler e- -- this used to be topHandlerFastExit, see #2228- runInputTWithPrefs defaultPrefs defaultSettings $ do- -- make `ghc -e` exit nonzero on invalid input, see Trac #7962- _ <- runCommands' hdle- (Just $ hdle (toException $ ExitFailure 1) >> return ())- (return Nothing)- return ()-- -- and finally, exit- liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."--runGHCiInput :: InputT GHCi a -> GHCi a-runGHCiInput f = do- dflags <- getDynFlags- let ghciHistory = gopt Opt_GhciHistory dflags- let localGhciHistory = gopt Opt_LocalGhciHistory dflags- currentDirectory <- liftIO $ getCurrentDirectory-- histFile <- case (ghciHistory, localGhciHistory) of- (True, True) -> return (Just (currentDirectory </> ".ghci_history"))- (True, _) -> liftIO $ withGhcAppData- (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)- _ -> return Nothing-- runInputT- (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})- f---- | How to get the next input line from the user-nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)-nextInputLine show_prompt is_tty- | is_tty = do- prmpt <- if show_prompt then lift mkPrompt else return ""- r <- getInputLine prmpt- incrementLineNo- return r- | otherwise = do- when show_prompt $ lift mkPrompt >>= liftIO . putStr- fileLoop stdin---- NOTE: We only read .ghci files if they are owned by the current user,--- and aren't world writable (files owned by root are ok, see #9324).--- Otherwise, we could be accidentally running code planted by--- a malicious third party.---- Furthermore, We only read ./.ghci if . is owned by the current user--- and isn't writable by anyone else. I think this is sufficient: we--- don't need to check .. and ../.. etc. because "." always refers to--- the same directory while a process is running.--checkFileAndDirPerms :: FilePath -> IO Bool-checkFileAndDirPerms file = do- file_ok <- checkPerms file- -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will- -- print some confusing and useless warnings in some cases (e.g. in- -- travis). Note that we can't add a test for this, as all ghci tests should- -- run with -ignore-dot-ghci, which means we never get here.- if file_ok then checkPerms (getDirectory file) else return False- where- getDirectory f = case takeDirectory f of- "" -> "."- d -> d--checkPerms :: FilePath -> IO Bool-#if defined(mingw32_HOST_OS)-checkPerms _ = return True-#else-checkPerms file =- handleIO (\_ -> return False) $ do- st <- getFileStatus file- me <- getRealUserID- let mode = System.Posix.fileMode st- ok = (fileOwner st == me || fileOwner st == 0) &&- groupWriteMode /= mode `intersectFileModes` groupWriteMode &&- otherWriteMode /= mode `intersectFileModes` otherWriteMode- unless ok $- -- #8248: Improving warning to include a possible fix.- putStrLn $ "*** WARNING: " ++ file ++- " is writable by someone else, IGNORING!" ++- "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"- return ok-#endif--incrementLineNo :: InputT GHCi ()-incrementLineNo = modifyGHCiState incLineNo- where- incLineNo st = st { line_number = line_number st + 1 }--fileLoop :: Handle -> InputT GHCi (Maybe String)-fileLoop hdl = do- l <- liftIO $ tryIO $ hGetLine hdl- case l of- Left e | isEOFError e -> return Nothing- | -- as we share stdin with the program, the program- -- might have already closed it, so we might get a- -- handle-closed exception. We therefore catch that- -- too.- isIllegalOperation e -> return Nothing- | InvalidArgument <- etype -> return Nothing- | otherwise -> liftIO $ ioError e- where etype = ioeGetErrorType e- -- treat InvalidArgument in the same way as EOF:- -- this can happen if the user closed stdin, or- -- perhaps did getContents which closes stdin at- -- EOF.- Right l' -> do- incrementLineNo- return (Just l')--formatCurrentTime :: String -> IO String-formatCurrentTime format =- getZonedTime >>= return . (formatTime defaultTimeLocale format)--getUserName :: IO String-getUserName = do-#if defined(mingw32_HOST_OS)- getEnv "USERNAME"- `catchIO` \e -> do- putStrLn $ show e- return ""-#else- getLoginName-#endif--getInfoForPrompt :: GHCi (SDoc, [String], Int)-getInfoForPrompt = do- st <- getGHCiState- imports <- GHC.getContext- resumes <- GHC.getResumeContext-- context_bit <-- case resumes of- [] -> return empty- r:_ -> do- let ix = GHC.resumeHistoryIx r- if ix == 0- then return (brackets (ppr (GHC.resumeSpan r)) <> space)- else do- let hist = GHC.resumeHistory r !! (ix-1)- pan <- GHC.getHistorySpan hist- return (brackets (ppr (negate ix) <> char ':'- <+> ppr pan) <> space)-- let- dots | _:rs <- resumes, not (null rs) = text "... "- | otherwise = empty-- rev_imports = reverse imports -- rightmost are the most recent-- myIdeclName d | Just m <- ideclAs d = unLoc m- | otherwise = unLoc (ideclName d)-- modules_names =- ['*':(moduleNameString m) | IIModule m <- rev_imports] ++- [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]- line = 1 + line_number st-- return (dots <> context_bit, modules_names, line)--parseCallEscape :: String -> (String, String)-parseCallEscape s- | not (all isSpace beforeOpen) = ("", "")- | null sinceOpen = ("", "")- | null sinceClosed = ("", "")- | null cmd = ("", "")- | otherwise = (cmd, tail sinceClosed)- where- (beforeOpen, sinceOpen) = span (/='(') s- (cmd, sinceClosed) = span (/=')') (tail sinceOpen)--checkPromptStringForErrors :: String -> Maybe String-checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =- case parseCallEscape xs of- ("", "") -> Just ("Incorrect %call syntax. " ++- "Should be %call(a command and arguments).")- (_, afterClosed) -> checkPromptStringForErrors afterClosed-checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs-checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs-checkPromptStringForErrors "" = Nothing--generatePromptFunctionFromString :: String -> PromptFunction-generatePromptFunctionFromString promptS = \_ _ -> do- (context, modules_names, line) <- getInfoForPrompt-- let- processString :: String -> GHCi SDoc- processString ('%':'s':xs) =- liftM2 (<>) (return modules_list) (processString xs)- where- modules_list = context <> modules_bit- modules_bit = hsep $ map text modules_names- processString ('%':'l':xs) =- liftM2 (<>) (return $ ppr line) (processString xs)- processString ('%':'d':xs) =- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%a %b %d"- processString ('%':'t':xs) =- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"- processString ('%':'T':xs) = do- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"- processString ('%':'@':xs) = do- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%I:%M %P"- processString ('%':'A':xs) = do- liftM2 (<>) (liftM text formatted_time) (processString xs)- where- formatted_time = liftIO $ formatCurrentTime "%H:%M"- processString ('%':'u':xs) =- liftM2 (<>) (liftM text user_name) (processString xs)- where- user_name = liftIO $ getUserName- processString ('%':'w':xs) =- liftM2 (<>) (liftM text current_directory) (processString xs)- where- current_directory = liftIO $ getCurrentDirectory- processString ('%':'o':xs) =- liftM ((text os) <>) (processString xs)- processString ('%':'a':xs) =- liftM ((text arch) <>) (processString xs)- processString ('%':'N':xs) =- liftM ((text compilerName) <>) (processString xs)- processString ('%':'V':xs) =- liftM ((text $ showVersion compilerVersion) <>) (processString xs)- processString ('%':'c':'a':'l':'l':xs) = do- respond <- liftIO $ do- (code, out, err) <-- readProcessWithExitCode- (head list_words) (tail list_words) ""- `catchIO` \e -> return (ExitFailure 1, "", show e)- case code of- ExitSuccess -> return out- _ -> do- hPutStrLn stderr err- return ""- liftM ((text respond) <>) (processString afterClosed)- where- (cmd, afterClosed) = parseCallEscape xs- list_words = words cmd- processString ('%':'%':xs) =- liftM ((char '%') <>) (processString xs)- processString (x:xs) =- liftM (char x <>) (processString xs)- processString "" =- return empty-- processString promptS--mkPrompt :: GHCi String-mkPrompt = do- st <- getGHCiState- dflags <- getDynFlags- (context, modules_names, line) <- getInfoForPrompt-- prompt_string <- (prompt st) modules_names line- let prompt_doc = context <> prompt_string-- return (showSDoc dflags prompt_doc)--queryQueue :: GHCi (Maybe String)-queryQueue = do- st <- getGHCiState- case cmdqueue st of- [] -> return Nothing- c:cs -> do setGHCiState st{ cmdqueue = cs }- return (Just c)---- Reconfigurable pretty-printing Ticket #5461-installInteractivePrint :: Maybe String -> Bool -> GHCi ()-installInteractivePrint Nothing _ = return ()-installInteractivePrint (Just ipFun) exprmode = do- ok <- trySuccess $ do- (name:_) <- GHC.parseName ipFun- modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name- in he{hsc_IC = new_ic})- return Succeeded-- when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))---- | The main read-eval-print loop-runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()-runCommands gCmd = runCommands' handler Nothing gCmd >> return ()--runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler- -> Maybe (GHCi ()) -- ^ Source error handler- -> InputT GHCi (Maybe String)- -> InputT GHCi (Maybe Bool)- -- We want to return () here, but have to return (Maybe Bool)- -- because gmask is not polymorphic enough: we want to use- -- unmask at two different types.-runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do- b <- ghandle (\e -> case fromException e of- Just UserInterrupt -> return $ Just False- _ -> case fromException e of- Just ghce ->- do liftIO (print (ghce :: GhcException))- return Nothing- _other ->- liftIO (Exception.throwIO e))- (unmask $ runOneCommand eh gCmd)- case b of- Nothing -> return Nothing- Just success -> do- unless success $ maybe (return ()) lift sourceErrorHandler- unmask $ runCommands' eh sourceErrorHandler gCmd---- | Evaluate a single line of user input (either :<command> or Haskell code).--- A result of Nothing means there was no more input to process.--- Otherwise the result is Just b where b is True if the command succeeded;--- this is relevant only to ghc -e, which will exit with status 1--- if the command was unsuccessful. GHCi will continue in either case.-runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)- -> InputT GHCi (Maybe Bool)-runOneCommand eh gCmd = do- -- run a previously queued command if there is one, otherwise get new- -- input from user- mb_cmd0 <- noSpace (lift queryQueue)- mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0- case mb_cmd1 of- Nothing -> return Nothing- Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $- handleSourceError printErrorAndFail- (doCommand c)- -- source error's are handled by runStmt- -- is the handler necessary here?- where- printErrorAndFail err = do- GHC.printException err- return $ Just False -- Exit ghc -e, but not GHCi-- noSpace q = q >>= maybe (return Nothing)- (\c -> case removeSpaces c of- "" -> noSpace q- ":{" -> multiLineCmd q- _ -> return (Just c) )- multiLineCmd q = do- st <- getGHCiState- let p = prompt st- setGHCiState st{ prompt = prompt_cont st }- mb_cmd <- collectCommand q "" `GHC.gfinally`- modifyGHCiState (\st' -> st' { prompt = p })- return mb_cmd- -- we can't use removeSpaces for the sublines here, so- -- multiline commands are somewhat more brittle against- -- fileformat errors (such as \r in dos input on unix),- -- we get rid of any extra spaces for the ":}" test;- -- we also avoid silent failure if ":}" is not found;- -- and since there is no (?) valid occurrence of \r (as- -- opposed to its String representation, "\r") inside a- -- ghci command, we replace any such with ' ' (argh:-(- collectCommand q c = q >>=- maybe (liftIO (ioError collectError))- (\l->if removeSpaces l == ":}"- then return (Just c)- else collectCommand q (c ++ "\n" ++ map normSpace l))- where normSpace '\r' = ' '- normSpace x = x- -- SDM (2007-11-07): is userError the one to use here?- collectError = userError "unterminated multiline command :{ .. :}"-- -- | Handle a line of input- doCommand :: String -> InputT GHCi (Maybe Bool)-- -- command- doCommand stmt | (':' : cmd) <- removeSpaces stmt = do- result <- specialCommand cmd- case result of- True -> return Nothing- _ -> return $ Just True-- -- haskell- doCommand stmt = do- -- if 'stmt' was entered via ':{' it will contain '\n's- let stmt_nl_cnt = length [ () | '\n' <- stmt ]- ml <- lift $ isOptionSet Multiline- if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input- then do- fst_line_num <- line_number <$> getGHCiState- mb_stmt <- checkInputForLayout stmt gCmd- case mb_stmt of- Nothing -> return $ Just True- Just ml_stmt -> do- -- temporarily compensate line-number for multi-line input- result <- timeIt runAllocs $ lift $- runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion- return $ Just (runSuccess result)- else do -- single line input and :{ - multiline input- last_line_num <- line_number <$> getGHCiState- -- reconstruct first line num from last line num and stmt- let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)- | otherwise = last_line_num -- single line input- stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]- stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines- -- temporarily compensate line-number for multi-line input- result <- timeIt runAllocs $ lift $- runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion- return $ Just (runSuccess result)-- -- runStmt wrapper for temporarily overridden line-number- runStmtWithLineNum :: Int -> String -> SingleStep- -> GHCi (Maybe GHC.ExecResult)- runStmtWithLineNum lnum stmt step = do- st0 <- getGHCiState- setGHCiState st0 { line_number = lnum }- result <- runStmt stmt step- -- restore original line_number- getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }- return result-- -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'- dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s- , all isSpace l0 = dropLeadingWhiteLines r- | otherwise = s----- #4316--- lex the input. If there is an unclosed layout context, request input-checkInputForLayout :: String -> InputT GHCi (Maybe String)- -> InputT GHCi (Maybe String)-checkInputForLayout stmt getStmt = do- dflags' <- getDynFlags- let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule- st0 <- getGHCiState- let buf' = stringToStringBuffer stmt- loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1- pstate = Lexer.mkPState dflags buf' loc- case Lexer.unP goToEnd pstate of- (Lexer.POk _ False) -> return $ Just stmt- _other -> do- st1 <- getGHCiState- let p = prompt st1- setGHCiState st1{ prompt = prompt_cont st1 }- mb_stmt <- ghciHandle (\ex -> case fromException ex of- Just UserInterrupt -> return Nothing- _ -> case fromException ex of- Just ghce ->- do liftIO (print (ghce :: GhcException))- return Nothing- _other -> liftIO (Exception.throwIO ex))- getStmt- modifyGHCiState (\st' -> st' { prompt = p })- -- the recursive call does not recycle parser state- -- as we use a new string buffer- case mb_stmt of- Nothing -> return Nothing- Just str -> if str == ""- then return $ Just stmt- else do- checkInputForLayout (stmt++"\n"++str) getStmt- where goToEnd = do- eof <- Lexer.nextIsEOF- if eof- then Lexer.activeContext- else Lexer.lexer False return >> goToEnd--enqueueCommands :: [String] -> GHCi ()-enqueueCommands cmds = do- -- make sure we force any exceptions in the commands while we're- -- still inside the exception handler, otherwise bad things will- -- happen (see #10501)- cmds `deepseq` return ()- modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }---- | Entry point to execute some haskell code from user.--- The return value True indicates success, as in `runOneCommand`.-runStmt :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)-runStmt stmt step = do- dflags <- GHC.getInteractiveDynFlags- if | GHC.isStmt dflags stmt -> run_stmt- | GHC.isImport dflags stmt -> run_import- -- Every import declaration should be handled by `run_import`. As GHCi- -- in general only accepts one command at a time, we simply throw an- -- exception when the input contains multiple commands of which at least- -- one is an import command (see #10663).- | GHC.hasImport dflags stmt -> throwGhcException- (CmdLineError "error: expecting a single import declaration")- -- Note: `GHC.isDecl` returns False on input like- -- `data Infix a b = a :@: b; infixl 4 :@:`- -- and should therefore not be used here.- | otherwise -> run_decl-- where- run_import = do- addImportToContext stmt- return (Just (GHC.ExecComplete (Right []) 0))-- run_decl =- do _ <- liftIO $ tryIO $ hFlushAll stdin- m_result <- GhciMonad.runDecls stmt- case m_result of- Nothing -> return Nothing- Just result ->- Just <$> afterRunStmt (const True)- (GHC.ExecComplete (Right result) 0)-- run_stmt =- do -- In the new IO library, read handles buffer data even if the Handle- -- is set to NoBuffering. This causes problems for GHCi where there- -- are really two stdin Handles. So we flush any bufferred data in- -- GHCi's stdin Handle here (only relevant if stdin is attached to- -- a file, otherwise the read buffer can't be flushed).- _ <- liftIO $ tryIO $ hFlushAll stdin- m_result <- GhciMonad.runStmt stmt step- case m_result of- Nothing -> return Nothing- Just result -> Just <$> afterRunStmt (const True) result---- | Clean up the GHCi environment after a statement has run-afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi GHC.ExecResult-afterRunStmt step_here run_result = do- resumes <- GHC.getResumeContext- case run_result of- GHC.ExecComplete{..} ->- case execResult of- Left ex -> liftIO $ Exception.throwIO ex- Right names -> do- show_types <- isOptionSet ShowType- when show_types $ printTypeOfNames names- GHC.ExecBreak names mb_info- | isNothing mb_info ||- step_here (GHC.resumeSpan $ head resumes) -> do- mb_id_loc <- toBreakIdAndLocation mb_info- let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc- if (null bCmd)- then printStoppedAtBreakInfo (head resumes) names- else enqueueCommands [bCmd]- -- run the command set with ":set stop <cmd>"- st <- getGHCiState- enqueueCommands [stop st]- return ()- | otherwise -> resume step_here GHC.SingleStep >>=- afterRunStmt step_here >> return ()-- flushInterpBuffers- withSignalHandlers $ do- b <- isOptionSet RevertCAFs- when b revertCAFs-- return run_result--runSuccess :: Maybe GHC.ExecResult -> Bool-runSuccess run_result- | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True- | otherwise = False--runAllocs :: Maybe GHC.ExecResult -> Maybe Integer-runAllocs m = do- res <- m- case res of- GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)- _ -> Nothing--toBreakIdAndLocation ::- Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))-toBreakIdAndLocation Nothing = return Nothing-toBreakIdAndLocation (Just inf) = do- let md = GHC.breakInfo_module inf- nm = GHC.breakInfo_number inf- st <- getGHCiState- return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,- breakModule loc == md,- breakTick loc == nm ]--printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()-printStoppedAtBreakInfo res names = do- printForUser $ pprStopped res- -- printTypeOfNames session names- let namesSorted = sortBy compareNames names- tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted- docs <- mapM pprTypeAndContents [i | AnId i <- tythings]- printForUserPartWay $ vcat docs--printTypeOfNames :: [Name] -> GHCi ()-printTypeOfNames names- = mapM_ (printTypeOfName ) $ sortBy compareNames names--compareNames :: Name -> Name -> Ordering-n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2- where compareWith n = (getOccString n, getSrcSpan n)--printTypeOfName :: Name -> GHCi ()-printTypeOfName n- = do maybe_tything <- GHC.lookupName n- case maybe_tything of- Nothing -> return ()- Just thing -> printTyThing thing---data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand---- | Entry point for execution a ':<command>' input from user-specialCommand :: String -> InputT GHCi Bool-specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)-specialCommand str = do- let (cmd,rest) = break isSpace str- maybe_cmd <- lift $ lookupCommand cmd- htxt <- short_help <$> getGHCiState- case maybe_cmd of- GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)- BadCommand ->- do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"- ++ htxt)- return False- NoLastCommand ->- do liftIO $ hPutStr stdout ("there is no last command to perform\n"- ++ htxt)- return False--shellEscape :: String -> GHCi Bool-shellEscape str = liftIO (system str >> return False)--lookupCommand :: String -> GHCi (MaybeCommand)-lookupCommand "" = do- st <- getGHCiState- case last_command st of- Just c -> return $ GotCommand c- Nothing -> return NoLastCommand-lookupCommand str = do- mc <- lookupCommand' str- modifyGHCiState (\st -> st { last_command = mc })- return $ case mc of- Just c -> GotCommand c- Nothing -> BadCommand--lookupCommand' :: String -> GHCi (Maybe Command)-lookupCommand' ":" = return Nothing-lookupCommand' str' = do- macros <- ghci_macros <$> getGHCiState- ghci_cmds <- ghci_commands <$> getGHCiState-- let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds-- let (str, xcmds) = case str' of- ':' : rest -> (rest, []) -- "::" selects a builtin command- _ -> (str', macros) -- otherwise include macros in lookup-- lookupExact s = find $ (s ==) . cmdName- lookupPrefix s = find $ (s `isPrefixOf`) . cmdName-- -- hidden commands can only be matched exact- builtinPfxMatch = lookupPrefix str ghci_cmds_nohide-- -- first, look for exact match (while preferring macros); then, look- -- for first prefix match (preferring builtins), *unless* a macro- -- overrides the builtin; see #8305 for motivation- return $ lookupExact str xcmds <|>- lookupExact str ghci_cmds <|>- (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>- builtinPfxMatch <|>- lookupPrefix str xcmds--getCurrentBreakSpan :: GHCi (Maybe SrcSpan)-getCurrentBreakSpan = do- resumes <- GHC.getResumeContext- case resumes of- [] -> return Nothing- (r:_) -> do- let ix = GHC.resumeHistoryIx r- if ix == 0- then return (Just (GHC.resumeSpan r))- else do- let hist = GHC.resumeHistory r !! (ix-1)- pan <- GHC.getHistorySpan hist- return (Just pan)--getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String])-getCallStackAtCurrentBreakpoint = do- resumes <- GHC.getResumeContext- case resumes of- [] -> return Nothing- (r:_) -> do- hsc_env <- GHC.getSession- Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))--getCurrentBreakModule :: GHCi (Maybe Module)-getCurrentBreakModule = do- resumes <- GHC.getResumeContext- case resumes of- [] -> return Nothing- (r:_) -> do- let ix = GHC.resumeHistoryIx r- if ix == 0- then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)- else do- let hist = GHC.resumeHistory r !! (ix-1)- return $ Just $ GHC.getHistoryModule hist------------------------------------------------------------------------------------- Commands-----------------------------------------------------------------------------------noArgs :: GHCi () -> String -> GHCi ()-noArgs m "" = m-noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"--withSandboxOnly :: String -> GHCi () -> GHCi ()-withSandboxOnly cmd this = do- dflags <- getDynFlags- if not (gopt Opt_GhciSandbox dflags)- then printForUser (text cmd <+>- ptext (sLit "is not supported with -fno-ghci-sandbox"))- else this---------------------------------------------------------------------------------- :help--help :: String -> GHCi ()-help _ = do- txt <- long_help `fmap` getGHCiState- liftIO $ putStr txt---------------------------------------------------------------------------------- :info--info :: Bool -> String -> InputT GHCi ()-info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")-info allInfo s = handleSourceError GHC.printException $ do- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- sdocs <- mapM (infoThing allInfo) (words s)- mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs--infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc-infoThing allInfo str = do- names <- GHC.parseName str- mb_stuffs <- mapM (GHC.getInfo allInfo) names- let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)- (catMaybes mb_stuffs)- return $ vcat (intersperse (text "") $ map pprInfo filtered)-- -- Filter out names whose parent is also there Good- -- example is '[]', which is both a type and data- -- constructor in the same type-filterOutChildren :: (a -> TyThing) -> [a] -> [a]-filterOutChildren get_thing xs- = filterOut has_parent xs- where- all_names = mkNameSet (map (getName . get_thing) xs)- has_parent x = case tyThingParent_maybe (get_thing x) of- Just p -> getName p `elemNameSet` all_names- Nothing -> False--pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc-pprInfo (thing, fixity, cls_insts, fam_insts, docs)- = docs- $$ pprTyThingInContextLoc thing- $$ show_fixity- $$ vcat (map GHC.pprInstance cls_insts)- $$ vcat (map GHC.pprFamInst fam_insts)- where- show_fixity- | fixity == GHC.defaultFixity = empty- | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)---------------------------------------------------------------------------------- :main--runMain :: String -> GHCi ()-runMain s = case toArgs s of- Left err -> liftIO (hPutStrLn stderr err)- Right args ->- do dflags <- getDynFlags- let main = fromMaybe "main" (mainFunIs dflags)- -- Wrap the main function in 'void' to discard its value instead- -- of printing it (#9086). See Haskell 2010 report Chapter 5.- doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"---------------------------------------------------------------------------------- :run--runRun :: String -> GHCi ()-runRun s = case toCmdArgs s of- Left err -> liftIO (hPutStrLn stderr err)- Right (cmd, args) -> doWithArgs args cmd--doWithArgs :: [String] -> String -> GHCi ()-doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++- show args ++ " (" ++ cmd ++ ")"]---------------------------------------------------------------------------------- :cd--changeDirectory :: String -> InputT GHCi ()-changeDirectory "" = do- -- :cd on its own changes to the user's home directory- either_dir <- liftIO $ tryIO getHomeDirectory- case either_dir of- Left _e -> return ()- Right dir -> changeDirectory dir-changeDirectory dir = do- graph <- GHC.getModuleGraph- when (not (null $ GHC.mgModSummaries graph)) $- liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."- GHC.setTargets []- _ <- GHC.load LoadAllTargets- lift $ setContextAfterLoad False []- GHC.workingDirectoryChanged- dir' <- expandPath dir- liftIO $ setCurrentDirectory dir'- dflags <- getDynFlags- -- With -fexternal-interpreter, we have to change the directory of the subprocess too.- -- (this gives consistent behaviour with and without -fexternal-interpreter)- when (gopt Opt_ExternalInterpreter dflags) $- lift $ enqueueCommands ["System.Directory.setCurrentDirectory " ++ show dir']--trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag-trySuccess act =- handleSourceError (\e -> do GHC.printException e- return Failed) $ do- act---------------------------------------------------------------------------------- :edit--editFile :: String -> InputT GHCi ()-editFile str =- do file <- if null str then lift chooseEditFile else expandPath str- st <- getGHCiState- errs <- liftIO $ readIORef $ lastErrorLocations st- let cmd = editor st- when (null cmd)- $ throwGhcException (CmdLineError "editor not set, use :set editor")- lineOpt <- liftIO $ do- let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)- `catchIO` (\_ -> return False)-- curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs- return $ case curFileErrs of- (_, line):_ -> " +" ++ show line- _ -> ""- let cmdArgs = ' ':(file ++ lineOpt)- code <- liftIO $ system (cmd ++ cmdArgs)-- when (code == ExitSuccess)- $ reloadModule ""---- The user didn't specify a file so we pick one for them.--- Our strategy is to pick the first module that failed to load,--- or otherwise the first target.------ XXX: Can we figure out what happened if the depndecy analysis fails--- (e.g., because the porgrammeer mistyped the name of a module)?--- XXX: Can we figure out the location of an error to pass to the editor?--- XXX: if we could figure out the list of errors that occured during the--- last load/reaload, then we could start the editor focused on the first--- of those.-chooseEditFile :: GHCi String-chooseEditFile =- do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x-- graph <- GHC.getModuleGraph- failed_graph <-- GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries graph)- let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing- pick xs = case xs of- x : _ -> GHC.ml_hs_file (GHC.ms_location x)- _ -> Nothing-- case pick (order failed_graph) of- Just file -> return file- Nothing ->- do targets <- GHC.getTargets- case msum (map fromTarget targets) of- Just file -> return file- Nothing -> throwGhcException (CmdLineError "No files to edit.")-- where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f- fromTarget _ = Nothing -- when would we get a module target?----------------------------------------------------------------------------------- :def--defineMacro :: Bool{-overwrite-} -> String -> GHCi ()-defineMacro _ (':':_) =- liftIO $ putStrLn "macro name cannot start with a colon"-defineMacro overwrite s = do- let (macro_name, definition) = break isSpace s- macros <- ghci_macros <$> getGHCiState- let defined = map cmdName macros- if null macro_name- then if null defined- then liftIO $ putStrLn "no macros defined"- else liftIO $ putStr ("the following macros are defined:\n" ++- unlines defined)- else do- if (not overwrite && macro_name `elem` defined)- then throwGhcException (CmdLineError- ("macro '" ++ macro_name ++ "' is already defined"))- else do-- -- compile the expression- handleSourceError GHC.printException $ do- step <- getGhciStepIO- expr <- GHC.parseExpr definition- -- > ghciStepIO . definition :: String -> IO String- let stringTy = nlHsTyVar stringTy_RDR- ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy- body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)- `mkHsApp` (nlHsPar expr)- tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)- new_expr = L (getLoc expr) $ ExprWithTySig body tySig- hv <- GHC.compileParsedExprRemote new_expr-- let newCmd = Command { cmdName = macro_name- , cmdAction = lift . runMacro hv- , cmdHidden = False- , cmdCompletionFunc = noCompletion- }-- -- later defined macros have precedence- modifyGHCiState $ \s ->- let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]- in s { ghci_macros = newCmd : filtered }--runMacro :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool-runMacro fun s = do- hsc_env <- GHC.getSession- str <- liftIO $ evalStringToIOString hsc_env fun s- enqueueCommands (lines str)- return False----------------------------------------------------------------------------------- :undef--undefineMacro :: String -> GHCi ()-undefineMacro str = mapM_ undef (words str)- where undef macro_name = do- cmds <- ghci_macros <$> getGHCiState- if (macro_name `notElem` map cmdName cmds)- then throwGhcException (CmdLineError- ("macro '" ++ macro_name ++ "' is not defined"))- else do- -- This is a tad racy but really, it's a shell- modifyGHCiState $ \s ->- s { ghci_macros = filter ((/= macro_name) . cmdName)- (ghci_macros s) }----------------------------------------------------------------------------------- :cmd--cmdCmd :: String -> GHCi ()-cmdCmd str = handleSourceError GHC.printException $ do- step <- getGhciStepIO- expr <- GHC.parseExpr str- -- > ghciStepIO str :: IO String- let new_expr = step `mkHsApp` expr- hv <- GHC.compileParsedExprRemote new_expr-- hsc_env <- GHC.getSession- cmds <- liftIO $ evalString hsc_env hv- enqueueCommands (lines cmds)---- | Generate a typed ghciStepIO expression--- @ghciStepIO :: Ty String -> IO String@.-getGhciStepIO :: GHCi (LHsExpr GhcPs)-getGhciStepIO = do- ghciTyConName <- GHC.getGHCiMonad- let stringTy = nlHsTyVar stringTy_RDR- ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy- ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy- body = nlHsVar (getRdrName ghciStepIoMName)- tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)- return $ noLoc $ ExprWithTySig body tySig---------------------------------------------------------------------------------- :check--checkModule :: String -> InputT GHCi ()-checkModule m = do- let modl = GHC.mkModuleName m- ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do- r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl- dflags <- getDynFlags- liftIO $ putStrLn $ showSDoc dflags $- case GHC.moduleInfo r of- cm | Just scope <- GHC.modInfoTopLevelScope cm ->- let- (loc, glob) = ASSERT( all isExternalName scope )- partition ((== modl) . GHC.moduleName . GHC.nameModule) scope- in- (text "global names: " <+> ppr glob) $$- (text "local names: " <+> ppr loc)- _ -> empty- return True- afterLoad (successIf ok) False----------------------------------------------------------------------------------- :load, :add, :reload---- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets--- '-fdefer-type-errors' again if it has not been set before.-wrapDeferTypeErrors :: InputT GHCi a -> InputT GHCi a-wrapDeferTypeErrors load =- gbracket- (do- -- Force originalFlags to avoid leaking the associated HscEnv- !originalFlags <- getDynFlags- void $ GHC.setProgramDynFlags $- setGeneralFlag' Opt_DeferTypeErrors originalFlags- return originalFlags)- (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)- (\_ -> load)--loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag-loadModule fs = timeIt (const Nothing) (loadModule' fs)---- | @:load@ command-loadModule_ :: [FilePath] -> InputT GHCi ()-loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))--loadModuleDefer :: [FilePath] -> InputT GHCi ()-loadModuleDefer = wrapDeferTypeErrors . loadModule_--loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag-loadModule' files = do- let (filenames, phases) = unzip files- exp_filenames <- mapM expandPath filenames- let files' = zip exp_filenames phases- targets <- mapM (uncurry GHC.guessTarget) files'-- -- NOTE: we used to do the dependency anal first, so that if it- -- fails we didn't throw away the current set of modules. This would- -- require some re-working of the GHC interface, so we'll leave it- -- as a ToDo for now.-- -- unload first- _ <- GHC.abandonAll- lift discardActiveBreakPoints- GHC.setTargets []- _ <- GHC.load LoadAllTargets-- GHC.setTargets targets- doLoadAndCollectInfo False LoadAllTargets---- | @:add@ command-addModule :: [FilePath] -> InputT GHCi ()-addModule files = do- lift revertCAFs -- always revert CAFs on load/add.- files' <- mapM expandPath files- targets <- mapM (\m -> GHC.guessTarget m Nothing) files'- targets' <- filterM checkTarget targets- -- remove old targets with the same id; e.g. for :add *M- mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ]- mapM_ GHC.addTarget targets'- _ <- doLoadAndCollectInfo False LoadAllTargets- return ()- where- checkTarget :: Target -> InputT GHCi Bool- checkTarget (Target (TargetModule m) _ _) = checkTargetModule m- checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f-- checkTargetModule :: ModuleName -> InputT GHCi Bool- checkTargetModule m = do- hsc_env <- GHC.getSession- result <- liftIO $- Finder.findImportedModule hsc_env m (Just (fsLit "this"))- case result of- Found _ _ -> return True- _ -> (liftIO $ putStrLn $- "Module " ++ moduleNameString m ++ " not found") >> return False-- checkTargetFile :: String -> IO Bool- checkTargetFile f = do- exists <- (doesFileExist f) :: IO Bool- unless exists $ putStrLn $ "File " ++ f ++ " not found"- return exists---- | @:unadd@ command-unAddModule :: [FilePath] -> InputT GHCi ()-unAddModule files = do- files' <- mapM expandPath files- targets <- mapM (\m -> GHC.guessTarget m Nothing) files'- mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]- _ <- doLoadAndCollectInfo False LoadAllTargets- return ()---- | @:reload@ command-reloadModule :: String -> InputT GHCi ()-reloadModule m = void $ doLoadAndCollectInfo True loadTargets- where- loadTargets | null m = LoadAllTargets- | otherwise = LoadUpTo (GHC.mkModuleName m)--reloadModuleDefer :: String -> InputT GHCi ()-reloadModuleDefer = wrapDeferTypeErrors . reloadModule---- | Load/compile targets and (optionally) collect module-info------ This collects the necessary SrcSpan annotated type information (via--- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,--- and @:uses@ commands.------ Meta-info collection is not enabled by default and needs to be--- enabled explicitly via @:set +c@. The reason is that collecting--- the type-information for all sub-spans can be quite expensive, and--- since those commands are designed to be used by editors and--- tooling, it's useless to collect this data for normal GHCi--- sessions.-doLoadAndCollectInfo :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag-doLoadAndCollectInfo retain_context howmuch = do- doCollectInfo <- lift (isOptionSet CollectInfo)-- doLoad retain_context howmuch >>= \case- Succeeded | doCollectInfo -> do- mod_summaries <- GHC.mgModSummaries <$> getModuleGraph- loaded <- filterM GHC.isLoaded $ map GHC.ms_mod_name mod_summaries- v <- mod_infos <$> getGHCiState- !newInfos <- collectInfo v loaded- modifyGHCiState (\st -> st { mod_infos = newInfos })- return Succeeded- flag -> return flag--doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag-doLoad retain_context howmuch = do- -- turn off breakpoints before we load: we can't turn them off later, because- -- the ModBreaks will have gone away.- lift discardActiveBreakPoints-- lift resetLastErrorLocations- -- Enable buffering stdout and stderr as we're compiling. Keeping these- -- handles unbuffered will just slow the compilation down, especially when- -- compiling in parallel.- gbracket (liftIO $ do hSetBuffering stdout LineBuffering- hSetBuffering stderr LineBuffering)- (\_ ->- liftIO $ do hSetBuffering stdout NoBuffering- hSetBuffering stderr NoBuffering) $ \_ -> do- ok <- trySuccess $ GHC.load howmuch- afterLoad ok retain_context- return ok---afterLoad :: SuccessFlag- -> Bool -- keep the remembered_ctx, as far as possible (:reload)- -> InputT GHCi ()-afterLoad ok retain_context = do- lift revertCAFs -- always revert CAFs on load.- lift discardTickArrays- loaded_mods <- getLoadedModules- modulesLoadedMsg ok loaded_mods- lift $ setContextAfterLoad retain_context loaded_mods--setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()-setContextAfterLoad keep_ctxt [] = do- setContextKeepingPackageModules keep_ctxt []-setContextAfterLoad keep_ctxt ms = do- -- load a target if one is available, otherwise load the topmost module.- targets <- GHC.getTargets- case [ m | Just m <- map (findTarget ms) targets ] of- [] ->- let graph = GHC.mkModuleGraph ms- graph' = flattenSCCs (GHC.topSortModuleGraph True graph Nothing)- in load_this (last graph')- (m:_) ->- load_this m- where- findTarget mds t- = case filter (`matches` t) mds of- [] -> Nothing- (m:_) -> Just m-- summary `matches` Target (TargetModule m) _ _- = GHC.ms_mod_name summary == m- summary `matches` Target (TargetFile f _) _ _- | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'- _ `matches` _- = False-- load_this summary | m <- GHC.ms_mod summary = do- is_interp <- GHC.moduleIsInterpreted m- dflags <- getDynFlags- let star_ok = is_interp && not (safeLanguageOn dflags)- -- We import the module with a * iff- -- - it is interpreted, and- -- - -XSafe is off (it doesn't allow *-imports)- let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]- | otherwise = [mkIIDecl (GHC.moduleName m)]- setContextKeepingPackageModules keep_ctxt new_ctx----- | Keep any package modules (except Prelude) when changing the context.-setContextKeepingPackageModules- :: Bool -- True <=> keep all of remembered_ctx- -- False <=> just keep package imports- -> [InteractiveImport] -- new context- -> GHCi ()--setContextKeepingPackageModules keep_ctx trans_ctx = do-- st <- getGHCiState- let rem_ctx = remembered_ctx st- new_rem_ctx <- if keep_ctx then return rem_ctx- else keepPackageImports rem_ctx- setGHCiState st{ remembered_ctx = new_rem_ctx,- transient_ctx = filterSubsumed new_rem_ctx trans_ctx }- setGHCContextFromGHCiState---- | Filters a list of 'InteractiveImport', clearing out any home package--- imports so only imports from external packages are preserved. ('IIModule'--- counts as a home package import, because we are only able to bring a--- full top-level into scope when the source is available.)-keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]-keepPackageImports = filterM is_pkg_import- where- is_pkg_import :: InteractiveImport -> GHCi Bool- is_pkg_import (IIModule _) = return False- is_pkg_import (IIDecl d)- = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)- case e :: Either SomeException Module of- Left _ -> return False- Right m -> return (not (isHomeModule m))- where- mod_name = unLoc (ideclName d)---modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()-modulesLoadedMsg ok mods = do- dflags <- getDynFlags- unqual <- GHC.getPrintUnqual-- msg <- if gopt Opt_ShowLoadedModules dflags- then do- mod_names <- mapM mod_name mods- let mod_commas- | null mods = text "none."- | otherwise = hsep (punctuate comma mod_names) <> text "."- return $ status <> text ", modules loaded:" <+> mod_commas- else do- return $ status <> text ","- <+> speakNOf (length mods) (text "module") <+> "loaded."-- when (verbosity dflags > 0) $- liftIO $ putStrLn $ showSDocForUser dflags unqual msg- where- status = case ok of- Failed -> text "Failed"- Succeeded -> text "Ok"-- mod_name mod = do- is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod- return $ if is_interpreted- then ppr (GHC.ms_mod mod)- else ppr (GHC.ms_mod mod)- <+> parens (text $ normalise $ msObjFilePath mod)- -- Fix #9887---- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors--- and printing 'throwE' strings to 'stderr'-runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()-runExceptGhcMonad act = handleSourceError GHC.printException $- either handleErr pure =<<- runExceptT act- where- handleErr sdoc = do- dflags <- getDynFlags- liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc---- | Inverse of 'runExceptT' for \"pure\" computations--- (c.f. 'except' for 'Except')-exceptT :: Applicative m => Either e a -> ExceptT e m a-exceptT = ExceptT . pure---------------------------------------------------------------------------------- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.--typeOfExpr :: String -> InputT GHCi ()-typeOfExpr str = handleSourceError GHC.printException $ do- let (mode, expr_str) = case break isSpace str of- ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)- ("+v", rest) -> (GHC.TM_NoInst, dropWhile isSpace rest)- _ -> (GHC.TM_Inst, str)- ty <- GHC.exprType mode expr_str- printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]---------------------------------------------------------------------------------- | @:type-at@ command--typeAtCmd :: String -> InputT GHCi ()-typeAtCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- mod_infos <$> getGHCiState- (info, ty) <- findType infos span' sample- lift $ printForUserModInfo (modinfoInfo info)- (sep [text sample,nest 2 (dcolon <+> ppr ty)])---------------------------------------------------------------------------------- | @:uses@ command--usesCmd :: String -> InputT GHCi ()-usesCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- mod_infos <$> getGHCiState- uses <- findNameUses infos span' sample- forM_ uses (liftIO . putStrLn . showSrcSpan)---------------------------------------------------------------------------------- | @:loc-at@ command--locAtCmd :: String -> InputT GHCi ()-locAtCmd str = runExceptGhcMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- mod_infos <$> getGHCiState- (_,_,sp) <- findLoc infos span' sample- liftIO . putStrLn . showSrcSpan $ sp---------------------------------------------------------------------------------- | @:all-types@ command--allTypesCmd :: String -> InputT GHCi ()-allTypesCmd _ = runExceptGhcMonad $ do- infos <- mod_infos <$> getGHCiState- forM_ (M.elems infos) $ \mi ->- forM_ (modinfoSpans mi) (lift . printSpan)- where- printSpan span'- | Just ty <- spaninfoType span' = do- df <- getDynFlags- let tyInfo = unwords . words $- showSDocForUser df alwaysQualify (pprTypeForUser ty)- liftIO . putStrLn $- showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo- | otherwise = return ()---------------------------------------------------------------------------------- Helpers for locAtCmd/typeAtCmd/usesCmd---- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>-parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)-parseSpanArg s = do- (fp,s0) <- readAsString (skipWs s)- s0' <- skipWs1 s0- (sl,s1) <- readAsInt s0'- s1' <- skipWs1 s1- (sc,s2) <- readAsInt s1'- s2' <- skipWs1 s2- (el,s3) <- readAsInt s2'- s3' <- skipWs1 s3- (ec,s4) <- readAsInt s3'-- trailer <- case s4 of- [] -> Right ""- _ -> skipWs1 s4-- let fs = mkFastString fp- span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)- (mkRealSrcLoc fs el ec)-- return (span',trailer)- where- readAsInt :: String -> Either SDoc (Int,String)- readAsInt "" = Left "Premature end of string while expecting Int"- readAsInt s0 = case reads s0 of- [s_rest] -> Right s_rest- _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")-- readAsString :: String -> Either SDoc (String,String)- readAsString s0- | '"':_ <- s0 = case reads s0 of- [s_rest] -> Right s_rest- _ -> leftRes- | s_rest@(_:_,_) <- breakWs s0 = Right s_rest- | otherwise = leftRes- where- leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")-- skipWs1 :: String -> Either SDoc String- skipWs1 (c:cs) | isWs c = Right (skipWs cs)- skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))-- isWs = (`elem` [' ','\t'])- skipWs = dropWhile isWs- breakWs = break isWs----- | Pretty-print \"real\" 'SrcSpan's as--- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@--- while simply unpacking 'UnhelpfulSpan's-showSrcSpan :: SrcSpan -> String-showSrcSpan (UnhelpfulSpan s) = unpackFS s-showSrcSpan (RealSrcSpan spn) = showRealSrcSpan spn---- | Variant of 'showSrcSpan' for 'RealSrcSpan's-showRealSrcSpan :: RealSrcSpan -> String-showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc- , ")-(", show el, ",", show ec, ")"- ]- where- fp = unpackFS (srcSpanFile spn)- sl = srcSpanStartLine spn- sc = srcSpanStartCol spn- el = srcSpanEndLine spn- ec = srcSpanEndCol spn---------------------------------------------------------------------------------- | @:kind@ command--kindOfType :: Bool -> String -> InputT GHCi ()-kindOfType norm str = handleSourceError GHC.printException $ do- (ty, kind) <- GHC.typeKind norm str- printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind- , ppWhen norm $ equals <+> pprTypeForUser ty ]---------------------------------------------------------------------------------- :quit--quit :: String -> InputT GHCi Bool-quit _ = return True----------------------------------------------------------------------------------- :script---- running a script file #1363--scriptCmd :: String -> InputT GHCi ()-scriptCmd ws = do- case words ws of- [s] -> runScript s- _ -> throwGhcException (CmdLineError "syntax: :script <filename>")--runScript :: String -- ^ filename- -> InputT GHCi ()-runScript filename = do- filename' <- expandPath filename- either_script <- liftIO $ tryIO (openFile filename' ReadMode)- case either_script of- Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "- ++(ioeGetErrorString _err))- Right script -> do- st <- getGHCiState- let prog = progname st- line = line_number st- setGHCiState st{progname=filename',line_number=0}- scriptLoop script- liftIO $ hClose script- new_st <- getGHCiState- setGHCiState new_st{progname=prog,line_number=line}- where scriptLoop script = do- res <- runOneCommand handler $ fileLoop script- case res of- Nothing -> return ()- Just s -> if s- then scriptLoop script- else return ()---------------------------------------------------------------------------------- :issafe---- Displaying Safe Haskell properties of a module--isSafeCmd :: String -> InputT GHCi ()-isSafeCmd m =- case words m of- [s] | looksLikeModuleName s -> do- md <- lift $ lookupModule s- isSafeModule md- [] -> do md <- guessCurrentModule "issafe"- isSafeModule md- _ -> throwGhcException (CmdLineError "syntax: :issafe <module>")--isSafeModule :: Module -> InputT GHCi ()-isSafeModule m = do- mb_mod_info <- GHC.getModuleInfo m- when (isNothing mb_mod_info)- (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)-- dflags <- getDynFlags- let iface = GHC.modInfoIface $ fromJust mb_mod_info- when (isNothing iface)- (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++- (GHC.moduleNameString $ GHC.moduleName m))-- (msafe, pkgs) <- GHC.moduleTrustReqs m- let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface- pkg = if packageTrusted dflags m then "trusted" else "untrusted"- (good, bad) = tallyPkgs dflags pkgs-- -- print info to user...- liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"- liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")- when (not $ S.null good)- (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++- (intercalate ", " $ map (showPpr dflags) (S.toList good)))- case msafe && S.null bad of- True -> liftIO $ putStrLn $ mname ++ " is trusted!"- False -> do- when (not $ null bad)- (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "- ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))- liftIO $ putStrLn $ mname ++ " is NOT trusted!"-- where- mname = GHC.moduleNameString $ GHC.moduleName m-- packageTrusted dflags md- | thisPackage dflags == moduleUnitId md = True- | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)-- tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)- | otherwise = S.partition part deps- where part pkg = trusted $ getInstalledPackageDetails dflags pkg---------------------------------------------------------------------------------- :browse---- Browsing a module's contents--browseCmd :: Bool -> String -> InputT GHCi ()-browseCmd bang m =- case words m of- ['*':s] | looksLikeModuleName s -> do- md <- lift $ wantInterpretedModule s- browseModule bang md False- [s] | looksLikeModuleName s -> do- md <- lift $ lookupModule s- browseModule bang md True- [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")- browseModule bang md True- _ -> throwGhcException (CmdLineError "syntax: :browse <module>")--guessCurrentModule :: String -> InputT GHCi Module--- Guess which module the user wants to browse. Pick--- modules that are interpreted first. The most--- recently-added module occurs last, it seems.-guessCurrentModule cmd- = do imports <- GHC.getContext- when (null imports) $ throwGhcException $- CmdLineError (':' : cmd ++ ": no current module")- case (head imports) of- IIModule m -> GHC.findModule m Nothing- IIDecl d -> GHC.findModule (unLoc (ideclName d))- (fmap sl_fs $ ideclPkgQual d)---- without bang, show items in context of their parents and omit children--- with bang, show class methods and data constructors separately, and--- indicate import modules, to aid qualifying unqualified names--- with sorted, sort items alphabetically-browseModule :: Bool -> Module -> Bool -> InputT GHCi ()-browseModule bang modl exports_only = do- -- :browse reports qualifiers wrt current context- unqual <- GHC.getPrintUnqual-- mb_mod_info <- GHC.getModuleInfo modl- case mb_mod_info of- Nothing -> throwGhcException (CmdLineError ("unknown module: " ++- GHC.moduleNameString (GHC.moduleName modl)))- Just mod_info -> do- dflags <- getDynFlags- let names- | exports_only = GHC.modInfoExports mod_info- | otherwise = GHC.modInfoTopLevelScope mod_info- `orElse` []-- -- sort alphabetically name, but putting locally-defined- -- identifiers first. We would like to improve this; see #1799.- sorted_names = loc_sort local ++ occ_sort external- where- (local,external) = ASSERT( all isExternalName names )- partition ((==modl) . nameModule) names- occ_sort = sortBy (compare `on` nameOccName)- -- try to sort by src location. If the first name in our list- -- has a good source location, then they all should.- loc_sort ns- | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)- = sortBy (compare `on` nameSrcSpan) ns- | otherwise- = occ_sort ns-- mb_things <- mapM GHC.lookupName sorted_names- let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)-- rdr_env <- GHC.getGRE-- let things | bang = catMaybes mb_things- | otherwise = filtered_things- pretty | bang = pprTyThing showToHeader- | otherwise = pprTyThingInContext showToHeader-- labels [] = text "-- not currently imported"- labels l = text $ intercalate "\n" $ map qualifier l-- qualifier :: Maybe [ModuleName] -> String- qualifier = maybe "-- defined locally"- (("-- imported via "++) . intercalate ", "- . map GHC.moduleNameString)- importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env-- modNames :: [[Maybe [ModuleName]]]- modNames = map (importInfo . GHC.getName) things-- -- annotate groups of imports with their import modules- -- the default ordering is somewhat arbitrary, so we group- -- by header and sort groups; the names themselves should- -- really come in order of source appearance.. (trac #1799)- annotate mts = concatMap (\(m,ts)->labels m:ts)- $ sortBy cmpQualifiers $ grp mts- where cmpQualifiers =- compare `on` (map (fmap (map moduleNameFS)) . fst)- grp [] = []- grp mts@((m,_):_) = (m,map snd g) : grp ng- where (g,ng) = partition ((==m).fst) mts-- let prettyThings, prettyThings' :: [SDoc]- prettyThings = map pretty things- prettyThings' | bang = annotate $ zip modNames prettyThings- | otherwise = prettyThings- liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')- -- ToDo: modInfoInstances currently throws an exception for- -- package modules. When it works, we can do this:- -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))----------------------------------------------------------------------------------- :module---- Setting the module context. For details on context handling see--- "remembered_ctx" and "transient_ctx" in GhciMonad.--moduleCmd :: String -> GHCi ()-moduleCmd str- | all sensible strs = cmd- | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")- where- (cmd, strs) =- case str of- '+':stuff -> rest addModulesToContext stuff- '-':stuff -> rest remModulesFromContext stuff- stuff -> rest setContext stuff-- rest op stuff = (op as bs, stuffs)- where (as,bs) = partitionWith starred stuffs- stuffs = words stuff-- sensible ('*':m) = looksLikeModuleName m- sensible m = looksLikeModuleName m-- starred ('*':m) = Left (GHC.mkModuleName m)- starred m = Right (GHC.mkModuleName m)----- -------------------------------------------------------------------------------- Four ways to manipulate the context:--- (a) :module +<stuff>: addModulesToContext--- (b) :module -<stuff>: remModulesFromContext--- (c) :module <stuff>: setContext--- (d) import <module>...: addImportToContext--addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()-addModulesToContext starred unstarred = restoreContextOnFailure $ do- addModulesToContext_ starred unstarred--addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()-addModulesToContext_ starred unstarred = do- mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)- setGHCContextFromGHCiState--remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()-remModulesFromContext starred unstarred = do- -- we do *not* call restoreContextOnFailure here. If the user- -- is trying to fix up a context that contains errors by removing- -- modules, we don't want GHC to silently put them back in again.- mapM_ rm (starred ++ unstarred)- setGHCContextFromGHCiState- where- rm :: ModuleName -> GHCi ()- rm str = do- m <- moduleName <$> lookupModuleName str- let filt = filter ((/=) m . iiModuleName)- modifyGHCiState $ \st ->- st { remembered_ctx = filt (remembered_ctx st)- , transient_ctx = filt (transient_ctx st) }--setContext :: [ModuleName] -> [ModuleName] -> GHCi ()-setContext starred unstarred = restoreContextOnFailure $ do- modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }- -- delete the transient context- addModulesToContext_ starred unstarred--addImportToContext :: String -> GHCi ()-addImportToContext str = restoreContextOnFailure $ do- idecl <- GHC.parseImportDecl str- addII (IIDecl idecl) -- #5836- setGHCContextFromGHCiState---- Util used by addImportToContext and addModulesToContext-addII :: InteractiveImport -> GHCi ()-addII iidecl = do- checkAdd iidecl- modifyGHCiState $ \st ->- st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)- , transient_ctx = filter (not . (iidecl `iiSubsumes`))- (transient_ctx st)- }---- Sometimes we can't tell whether an import is valid or not until--- we finally call 'GHC.setContext'. e.g.------ import System.IO (foo)------ will fail because System.IO does not export foo. In this case we--- don't want to store the import in the context permanently, so we--- catch the failure from 'setGHCContextFromGHCiState' and set the--- context back to what it was.------ See #6007----restoreContextOnFailure :: GHCi a -> GHCi a-restoreContextOnFailure do_this = do- st <- getGHCiState- let rc = remembered_ctx st; tc = transient_ctx st- do_this `gonException` (modifyGHCiState $ \st' ->- st' { remembered_ctx = rc, transient_ctx = tc })---- -------------------------------------------------------------------------------- Validate a module that we want to add to the context--checkAdd :: InteractiveImport -> GHCi ()-checkAdd ii = do- dflags <- getDynFlags- let safe = safeLanguageOn dflags- case ii of- IIModule modname- | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"- | otherwise -> wantInterpretedModuleName modname >> return ()-- IIDecl d -> do- let modname = unLoc (ideclName d)- pkgqual = ideclPkgQual d- m <- GHC.lookupModule modname (fmap sl_fs pkgqual)- when safe $ do- t <- GHC.isModuleTrusted m- when (not t) $ throwGhcException $ ProgramError $ ""---- -------------------------------------------------------------------------------- Update the GHC API's view of the context---- | Sets the GHC context from the GHCi state. The GHC context is--- always set this way, we never modify it incrementally.------ We ignore any imports for which the ModuleName does not currently--- exist. This is so that the remembered_ctx can contain imports for--- modules that are not currently loaded, perhaps because we just did--- a :reload and encountered errors.------ Prelude is added if not already present in the list. Therefore to--- override the implicit Prelude import you can say 'import Prelude ()'--- at the prompt, just as in Haskell source.----setGHCContextFromGHCiState :: GHCi ()-setGHCContextFromGHCiState = do- st <- getGHCiState- -- re-use checkAdd to check whether the module is valid. If the- -- module does not exist, we do *not* want to print an error- -- here, we just want to silently keep the module in the context- -- until such time as the module reappears again. So we ignore- -- the actual exception thrown by checkAdd, using tryBool to- -- turn it into a Bool.- iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)-- prel_iidecls <- getImplicitPreludeImports iidecls- valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls-- extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))-- GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls---getImplicitPreludeImports :: [InteractiveImport] -> GHCi [InteractiveImport]-getImplicitPreludeImports iidecls = do- dflags <- GHC.getInteractiveDynFlags- -- allow :seti to override -XNoImplicitPrelude- st <- getGHCiState-- -- We add the prelude imports if there are no *-imports, and we also- -- allow each prelude import to be subsumed by another explicit import- -- of the same module. This means that you can override the prelude import- -- with "import Prelude hiding (map)", for example.- let prel_iidecls =- if xopt LangExt.ImplicitPrelude dflags && not (any isIIModule iidecls)- then [ IIDecl imp- | imp <- prelude_imports st- , not (any (sameImpModule imp) iidecls) ]- else []-- return prel_iidecls---- -------------------------------------------------------------------------------- Utils on InteractiveImport--mkIIModule :: ModuleName -> InteractiveImport-mkIIModule = IIModule--mkIIDecl :: ModuleName -> InteractiveImport-mkIIDecl = IIDecl . simpleImportDecl--iiModules :: [InteractiveImport] -> [ModuleName]-iiModules is = [m | IIModule m <- is]--isIIModule :: InteractiveImport -> Bool-isIIModule (IIModule _) = True-isIIModule _ = False--iiModuleName :: InteractiveImport -> ModuleName-iiModuleName (IIModule m) = m-iiModuleName (IIDecl d) = unLoc (ideclName d)--preludeModuleName :: ModuleName-preludeModuleName = GHC.mkModuleName "Prelude"--sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool-sameImpModule _ (IIModule _) = False -- we only care about imports here-sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)--addNotSubsumed :: InteractiveImport- -> [InteractiveImport] -> [InteractiveImport]-addNotSubsumed i is- | any (`iiSubsumes` i) is = is- | otherwise = i : filter (not . (i `iiSubsumes`)) is---- | @filterSubsumed is js@ returns the elements of @js@ not subsumed--- by any of @is@.-filterSubsumed :: [InteractiveImport] -> [InteractiveImport]- -> [InteractiveImport]-filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js---- | Returns True if the left import subsumes the right one. Doesn't--- need to be 100% accurate, conservatively returning False is fine.--- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in--- plusProv will ensue (#5904))------ Note that an IIModule does not necessarily subsume an IIDecl,--- because e.g. a module might export a name that is only available--- qualified within the module itself.------ Note that 'import M' does not necessarily subsume 'import M(foo)',--- because M might not export foo and we want an error to be produced--- in that case.----iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool-iiSubsumes (IIModule m1) (IIModule m2) = m1==m2-iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude- = unLoc (ideclName d1) == unLoc (ideclName d2)- && ideclAs d1 == ideclAs d2- && (not (ideclQualified d1) || ideclQualified d2)- && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)- where- _ `hidingSubsumes` Just (False,L _ []) = True- Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)- = all (`elem` xs) ys- h1 `hidingSubsumes` h2 = h1 == h2-iiSubsumes _ _ = False---------------------------------------------------------------------------------- :set---- set options in the interpreter. Syntax is exactly the same as the--- ghc command line, except that certain options aren't available (-C,--- -E etc.)------ This is pretty fragile: most options won't work as expected. ToDo:--- figure out which ones & disallow them.--setCmd :: String -> GHCi ()-setCmd "" = showOptions False-setCmd "-a" = showOptions True-setCmd str- = case getCmd str of- Right ("args", rest) ->- case toArgs rest of- Left err -> liftIO (hPutStrLn stderr err)- Right args -> setArgs args- Right ("prog", rest) ->- case toArgs rest of- Right [prog] -> setProg prog- _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")-- Right ("prompt", rest) ->- setPromptString setPrompt (dropWhile isSpace rest)- "syntax: set prompt <string>"- Right ("prompt-function", rest) ->- setPromptFunc setPrompt $ dropWhile isSpace rest- Right ("prompt-cont", rest) ->- setPromptString setPromptCont (dropWhile isSpace rest)- "syntax: :set prompt-cont <string>"- Right ("prompt-cont-function", rest) ->- setPromptFunc setPromptCont $ dropWhile isSpace rest-- Right ("editor", rest) -> setEditor $ dropWhile isSpace rest- Right ("stop", rest) -> setStop $ dropWhile isSpace rest- _ -> case toArgs str of- Left err -> liftIO (hPutStrLn stderr err)- Right wds -> setOptions wds--setiCmd :: String -> GHCi ()-setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False-setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True-setiCmd str =- case toArgs str of- Left err -> liftIO (hPutStrLn stderr err)- Right wds -> newDynFlags True wds--showOptions :: Bool -> GHCi ()-showOptions show_all- = do st <- getGHCiState- dflags <- getDynFlags- let opts = options st- liftIO $ putStrLn (showSDoc dflags (- text "options currently set: " <>- if null opts- then text "none."- else hsep (map (\o -> char '+' <> text (optToStr o)) opts)- ))- getDynFlags >>= liftIO . showDynFlags show_all---showDynFlags :: Bool -> DynFlags -> IO ()-showDynFlags show_all dflags = do- showLanguages' show_all dflags- putStrLn $ showSDoc dflags $- text "GHCi-specific dynamic flag settings:" $$- nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))- putStrLn $ showSDoc dflags $- text "other dynamic, non-language, flag settings:" $$- nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))- putStrLn $ showSDoc dflags $- text "warning settings:" $$- nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))- where- setting prefix noPrefix test flag- | quiet = empty- | is_on = text prefix <> text name- | otherwise = text noPrefix <> text name- where name = flagSpecName flag- f = flagSpecFlag flag- is_on = test f dflags- quiet = not show_all && test f default_dflags == is_on-- default_dflags = defaultDynFlags (settings dflags) (llvmTargets dflags)-- (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)- DynFlags.fFlags- flgs = [ Opt_PrintExplicitForalls- , Opt_PrintExplicitKinds- , Opt_PrintUnicodeSyntax- , Opt_PrintBindResult- , Opt_BreakOnException- , Opt_BreakOnError- , Opt_PrintEvldWithShow- ]--setArgs, setOptions :: [String] -> GHCi ()-setProg, setEditor, setStop :: String -> GHCi ()--setArgs args = do- st <- getGHCiState- wrapper <- mkEvalWrapper (progname st) args- setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }--setProg prog = do- st <- getGHCiState- wrapper <- mkEvalWrapper prog (GhciMonad.args st)- setGHCiState st { progname = prog, evalWrapper = wrapper }--setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })--setStop str@(c:_) | isDigit c- = do let (nm_str,rest) = break (not.isDigit) str- nm = read nm_str- st <- getGHCiState- let old_breaks = breaks st- if all ((/= nm) . fst) old_breaks- then printForUser (text "Breakpoint" <+> ppr nm <+>- text "does not exist")- else do- let new_breaks = map fn old_breaks- fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })- | otherwise = (i,loc)- setGHCiState st{ breaks = new_breaks }-setStop cmd = modifyGHCiState (\st -> st { stop = cmd })--setPrompt :: PromptFunction -> GHCi ()-setPrompt v = modifyGHCiState (\st -> st {prompt = v})--setPromptCont :: PromptFunction -> GHCi ()-setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})--setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()-setPromptFunc fSetPrompt s = do- -- We explicitly annotate the type of the expression to ensure- -- that unsafeCoerce# is passed the exact type necessary rather- -- than a more general one- let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"- (HValue funValue) <- GHC.compileExpr exprStr- fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)- where- convertToPromptFunction :: ([String] -> Int -> IO String)- -> PromptFunction- convertToPromptFunction func = (\mods line -> liftIO $- liftM text (func mods line))--setPromptString :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()-setPromptString fSetPrompt value err = do- if null value- then liftIO $ hPutStrLn stderr $ err- else case value of- ('\"':_) ->- case reads value of- [(value', xs)] | all isSpace xs ->- setParsedPromptString fSetPrompt value'- _ -> liftIO $ hPutStrLn stderr- "Can't parse prompt string. Use Haskell syntax."- _ ->- setParsedPromptString fSetPrompt value--setParsedPromptString :: (PromptFunction -> GHCi ()) -> String -> GHCi ()-setParsedPromptString fSetPrompt s = do- case (checkPromptStringForErrors s) of- Just err ->- liftIO $ hPutStrLn stderr err- Nothing ->- fSetPrompt $ generatePromptFunctionFromString s--setOptions wds =- do -- first, deal with the GHCi opts (+s, +t, etc.)- let (plus_opts, minus_opts) = partitionWith isPlus wds- mapM_ setOpt plus_opts- -- then, dynamic flags- when (not (null minus_opts)) $ newDynFlags False minus_opts--newDynFlags :: Bool -> [String] -> GHCi ()-newDynFlags interactive_only minus_opts = do- let lopts = map noLoc minus_opts-- idflags0 <- GHC.getInteractiveDynFlags- (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts-- liftIO $ handleFlagWarnings idflags1 warns- when (not $ null leftovers)- (throwGhcException . CmdLineError- $ "Some flags have not been recognized: "- ++ (concat . intersperse ", " $ map unLoc leftovers))-- when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do- liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"- GHC.setInteractiveDynFlags idflags1- installInteractivePrint (interactivePrint idflags1) False-- dflags0 <- getDynFlags- when (not interactive_only) $ do- (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts- new_pkgs <- GHC.setProgramDynFlags dflags1-- -- if the package flags changed, reset the context and link- -- the new packages.- hsc_env <- GHC.getSession- let dflags2 = hsc_dflags hsc_env- when (packageFlagsChanged dflags2 dflags0) $ do- when (verbosity dflags2 > 0) $- liftIO . putStrLn $- "package flags have changed, resetting and loading new packages..."- GHC.setTargets []- _ <- GHC.load LoadAllTargets- liftIO $ linkPackages hsc_env new_pkgs- -- package flags changed, we can't re-use any of the old context- setContextAfterLoad False []- -- and copy the package state to the interactive DynFlags- idflags <- GHC.getInteractiveDynFlags- GHC.setInteractiveDynFlags- idflags{ pkgState = pkgState dflags2- , pkgDatabase = pkgDatabase dflags2- , packageFlags = packageFlags dflags2 }-- let ld0length = length $ ldInputs dflags0- fmrk0length = length $ cmdlineFrameworks dflags0-- newLdInputs = drop ld0length (ldInputs dflags2)- newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)-- hsc_env' = hsc_env { hsc_dflags =- dflags2 { ldInputs = newLdInputs- , cmdlineFrameworks = newCLFrameworks } }-- when (not (null newLdInputs && null newCLFrameworks)) $- liftIO $ linkCmdLineLibs hsc_env'-- return ()---unsetOptions :: String -> GHCi ()-unsetOptions str- = -- first, deal with the GHCi opts (+s, +t, etc.)- let opts = words str- (minus_opts, rest1) = partition isMinus opts- (plus_opts, rest2) = partitionWith isPlus rest1- (other_opts, rest3) = partition (`elem` map fst defaulters) rest2-- defaulters =- [ ("args" , setArgs default_args)- , ("prog" , setProg default_progname)- , ("prompt" , setPrompt default_prompt)- , ("prompt-cont", setPromptCont default_prompt_cont)- , ("editor" , liftIO findEditor >>= setEditor)- , ("stop" , setStop default_stop)- ]-- no_flag ('-':'f':rest) = return ("-fno-" ++ rest)- no_flag ('-':'X':rest) = return ("-XNo" ++ rest)- no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))-- in if (not (null rest3))- then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))- else do- mapM_ (fromJust.flip lookup defaulters) other_opts-- mapM_ unsetOpt plus_opts-- no_flags <- mapM no_flag minus_opts- when (not (null no_flags)) $ newDynFlags False no_flags--isMinus :: String -> Bool-isMinus ('-':_) = True-isMinus _ = False--isPlus :: String -> Either String String-isPlus ('+':opt) = Left opt-isPlus other = Right other--setOpt, unsetOpt :: String -> GHCi ()--setOpt str- = case strToGHCiOpt str of- Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))- Just o -> setOption o--unsetOpt str- = case strToGHCiOpt str of- Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))- Just o -> unsetOption o--strToGHCiOpt :: String -> (Maybe GHCiOption)-strToGHCiOpt "m" = Just Multiline-strToGHCiOpt "s" = Just ShowTiming-strToGHCiOpt "t" = Just ShowType-strToGHCiOpt "r" = Just RevertCAFs-strToGHCiOpt "c" = Just CollectInfo-strToGHCiOpt _ = Nothing--optToStr :: GHCiOption -> String-optToStr Multiline = "m"-optToStr ShowTiming = "s"-optToStr ShowType = "t"-optToStr RevertCAFs = "r"-optToStr CollectInfo = "c"----- ------------------------------------------------------------------------------ :show--showCmd :: String -> GHCi ()-showCmd "" = showOptions False-showCmd "-a" = showOptions True-showCmd str = do- st <- getGHCiState- dflags <- getDynFlags-- let lookupCmd :: String -> Maybe (GHCi ())- lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds-- -- (show in help?, command name, action)- action :: String -> GHCi () -> (Bool, String, GHCi ())- action name m = (True, name, m)-- hidden :: String -> GHCi () -> (Bool, String, GHCi ())- hidden name m = (False, name, m)-- cmds =- [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))- , action "prog" $ liftIO $ putStrLn (show (progname st))- , action "editor" $ liftIO $ putStrLn (show (editor st))- , action "stop" $ liftIO $ putStrLn (show (stop st))- , action "imports" $ showImports- , action "modules" $ showModules- , action "bindings" $ showBindings- , action "linker" $ getDynFlags >>= liftIO . showLinkerState- , action "breaks" $ showBkptTable- , action "context" $ showContext- , action "packages" $ showPackages- , action "paths" $ showPaths- , action "language" $ showLanguages- , hidden "languages" $ showLanguages -- backwards compat- , hidden "lang" $ showLanguages -- useful abbreviation- , action "targets" $ showTargets- ]-- case words str of- [w] | Just action <- lookupCmd w -> action-- _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]- in throwGhcException $ CmdLineError $ showSDoc dflags- $ hang (text "syntax:") 4- $ hang (text ":show") 6- $ brackets (fsep $ punctuate (text " |") helpCmds)--showiCmd :: String -> GHCi ()-showiCmd str = do- case words str of- ["languages"] -> showiLanguages -- backwards compat- ["language"] -> showiLanguages- ["lang"] -> showiLanguages -- useful abbreviation- _ -> throwGhcException (CmdLineError ("syntax: :showi language"))--showImports :: GHCi ()-showImports = do- st <- getGHCiState- dflags <- getDynFlags- let rem_ctx = reverse (remembered_ctx st)- trans_ctx = transient_ctx st-- show_one (IIModule star_m)- = ":module +*" ++ moduleNameString star_m- show_one (IIDecl imp) = showPpr dflags imp-- prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)-- let show_prel p = show_one p ++ " -- implicit"- show_extra p = show_one (IIDecl p) ++ " -- fixed"-- trans_comment s = s ++ " -- added automatically" :: String- --- liftIO $ mapM_ putStrLn (map show_one rem_ctx ++- map (trans_comment . show_one) trans_ctx ++- map show_prel prel_iidecls ++- map show_extra (extra_imports st))--showModules :: GHCi ()-showModules = do- loaded_mods <- getLoadedModules- -- we want *loaded* modules only, see #1734- let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)- mapM_ show_one loaded_mods--getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]-getLoadedModules = do- graph <- GHC.getModuleGraph- filterM (GHC.isLoaded . GHC.ms_mod_name) (GHC.mgModSummaries graph)--showBindings :: GHCi ()-showBindings = do- bindings <- GHC.getBindings- (insts, finsts) <- GHC.getInsts- docs <- mapM makeDoc (reverse bindings)- -- reverse so the new ones come last- let idocs = map GHC.pprInstanceHdr insts- fidocs = map GHC.pprFamInst finsts- mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)- where- makeDoc (AnId i) = pprTypeAndContents i- makeDoc tt = do- mb_stuff <- GHC.getInfo False (getName tt)- return $ maybe (text "") pprTT mb_stuff-- pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc- pprTT (thing, fixity, _cls_insts, _fam_insts, _docs)- = pprTyThing showToHeader thing- $$ show_fixity- where- show_fixity- | fixity == GHC.defaultFixity = empty- | otherwise = ppr fixity <+> ppr (GHC.getName thing)---printTyThing :: TyThing -> GHCi ()-printTyThing tyth = printForUser (pprTyThing showToHeader tyth)--showBkptTable :: GHCi ()-showBkptTable = do- st <- getGHCiState- printForUser $ prettyLocations (breaks st)--showContext :: GHCi ()-showContext = do- resumes <- GHC.getResumeContext- printForUser $ vcat (map pp_resume (reverse resumes))- where- pp_resume res =- ptext (sLit "--> ") <> text (GHC.resumeStmt res)- $$ nest 2 (pprStopped res)--pprStopped :: GHC.Resume -> SDoc-pprStopped res =- ptext (sLit "Stopped in")- <+> ((case mb_mod_name of- Nothing -> empty- Just mod_name -> text (moduleNameString mod_name) <> char '.')- <> text (GHC.resumeDecl res))- <> char ',' <+> ppr (GHC.resumeSpan res)- where- mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res--showPackages :: GHCi ()-showPackages = do- dflags <- getDynFlags- let pkg_flags = packageFlags dflags- liftIO $ putStrLn $ showSDoc dflags $- text ("active package flags:"++if null pkg_flags then " none" else "") $$- nest 2 (vcat (map pprFlag pkg_flags))--showPaths :: GHCi ()-showPaths = do- dflags <- getDynFlags- liftIO $ do- cwd <- getCurrentDirectory- putStrLn $ showSDoc dflags $- text "current working directory: " $$- nest 2 (text cwd)- let ipaths = importPaths dflags- putStrLn $ showSDoc dflags $- text ("module import search paths:"++if null ipaths then " none" else "") $$- nest 2 (vcat (map text ipaths))--showLanguages :: GHCi ()-showLanguages = getDynFlags >>= liftIO . showLanguages' False--showiLanguages :: GHCi ()-showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False--showLanguages' :: Bool -> DynFlags -> IO ()-showLanguages' show_all dflags =- putStrLn $ showSDoc dflags $ vcat- [ text "base language is: " <>- case language dflags of- Nothing -> text "Haskell2010"- Just Haskell98 -> text "Haskell98"- Just Haskell2010 -> text "Haskell2010"- , (if show_all then text "all active language options:"- else text "with the following modifiers:") $$- nest 2 (vcat (map (setting xopt) DynFlags.xFlags))- ]- where- setting test flag- | quiet = empty- | is_on = text "-X" <> text name- | otherwise = text "-XNo" <> text name- where name = flagSpecName flag- f = flagSpecFlag flag- is_on = test f dflags- quiet = not show_all && test f default_dflags == is_on-- default_dflags =- defaultDynFlags (settings dflags) (llvmTargets dflags) `lang_set`- case language dflags of- Nothing -> Just Haskell2010- other -> other--showTargets :: GHCi ()-showTargets = mapM_ showTarget =<< GHC.getTargets- where- showTarget :: Target -> GHCi ()- showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)- showTarget (Target (TargetModule m) _ _) =- liftIO (putStrLn $ moduleNameString m)---- -------------------------------------------------------------------------------- Completion--completeCmd :: String -> GHCi ()-completeCmd argLine0 = case parseLine argLine0 of- Just ("repl", resultRange, left) -> do- (unusedLine,compls) <- ghciCompleteWord (reverse left,"")- let compls' = takeRange resultRange compls- liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]- forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do- liftIO $ print r- _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")- where- parseLine argLine- | null argLine = Nothing- | null rest1 = Nothing- | otherwise = (,,) dom <$> resRange <*> s- where- (dom, rest1) = breakSpace argLine- (rng, rest2) = breakSpace rest1- resRange | head rest1 == '"' = parseRange ""- | otherwise = parseRange rng- s | head rest1 == '"' = readMaybe rest1 :: Maybe String- | otherwise = readMaybe rest2- breakSpace = fmap (dropWhile isSpace) . break isSpace-- takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub-- -- syntax: [n-][m] with semantics "drop (n-1) . take m"- parseRange :: String -> Maybe (Maybe Int,Maybe Int)- parseRange s = case span isDigit s of- (_, "") ->- -- upper limit only- Just (Nothing, bndRead s)- (s1, '-' : s2)- | all isDigit s2 ->- Just (bndRead s1, bndRead s2)- _ ->- Nothing- where- bndRead x = if null x then Nothing else Just (read x)----completeGhciCommand, completeMacro, completeIdentifier, completeModule,- completeSetModule, completeSeti, completeShowiOptions,- completeHomeModule, completeSetOptions, completeShowOptions,- completeHomeModuleOrFile, completeExpression- :: CompletionFunc GHCi---- | Provide completions for last word in a given string.------ Takes a tuple of two strings. First string is a reversed line to be--- completed. Second string is likely unused, 'completeCmd' always passes an--- empty string as second item in tuple.-ghciCompleteWord :: CompletionFunc GHCi-ghciCompleteWord line@(left,_) = case firstWord of- -- If given string starts with `:` colon, and there is only one following- -- word then provide REPL command completions. If there is more than one- -- word complete either filename or builtin ghci commands or macros.- ':':cmd | null rest -> completeGhciCommand line- | otherwise -> do- completion <- lookupCompletion cmd- completion line- -- If given string starts with `import` keyword provide module name- -- completions- "import" -> completeModule line- -- otherwise provide identifier completions- _ -> completeExpression line- where- (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left- lookupCompletion ('!':_) = return completeFilename- lookupCompletion c = do- maybe_cmd <- lookupCommand' c- case maybe_cmd of- Just cmd -> return (cmdCompletionFunc cmd)- Nothing -> return completeFilename--completeGhciCommand = wrapCompleter " " $ \w -> do- macros <- ghci_macros <$> getGHCiState- cmds <- ghci_commands `fmap` getGHCiState- let macro_names = map (':':) . map cmdName $ macros- let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds- let{ candidates = case w of- ':' : ':' : _ -> map (':':) command_names- _ -> nub $ macro_names ++ command_names }- return $ filter (w `isPrefixOf`) candidates--completeMacro = wrapIdentCompleter $ \w -> do- cmds <- ghci_macros <$> getGHCiState- return (filter (w `isPrefixOf`) (map cmdName cmds))--completeIdentifier line@(left, _) =- -- Note: `left` is a reversed input- case left of- (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line- _ -> wrapIdentCompleter complete line- where- complete w = do- rdrs <- GHC.getRdrNamesInScope- dflags <- GHC.getSessionDynFlags- return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))--completeModule = wrapIdentCompleter $ \w -> do- dflags <- GHC.getSessionDynFlags- let pkg_mods = allVisibleModules dflags- loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules- return $ filter (w `isPrefixOf`)- $ map (showPpr dflags) $ loaded_mods ++ pkg_mods--completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do- dflags <- GHC.getSessionDynFlags- modules <- case m of- Just '-' -> do- imports <- GHC.getContext- return $ map iiModuleName imports- _ -> do- let pkg_mods = allVisibleModules dflags- loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules- return $ loaded_mods ++ pkg_mods- return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules--completeHomeModule = wrapIdentCompleter listHomeModules--listHomeModules :: String -> GHCi [String]-listHomeModules w = do- g <- GHC.getModuleGraph- let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)- dflags <- getDynFlags- return $ sort $ filter (w `isPrefixOf`)- $ map (showPpr dflags) home_mods--completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) opts)- where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":- "prompt-cont-function":"editor":"stop":flagList- flagList = map head $ group $ sort allNonDeprecatedFlags--completeSeti = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) flagList)- where flagList = map head $ group $ sort allNonDeprecatedFlags--completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) opts)- where opts = ["args", "prog", "editor", "stop",- "modules", "bindings", "linker", "breaks",- "context", "packages", "paths", "language", "imports"]--completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do- return (filter (w `isPrefixOf`) ["language"])--completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars- $ unionComplete (fmap (map simpleCompletion) . listHomeModules)- listFiles--unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]-unionComplete f1 f2 line = do- cs1 <- f1 line- cs2 <- f2 line- return (cs1 ++ cs2)--wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi-wrapCompleter breakChars fun = completeWord Nothing breakChars- $ fmap (map simpleCompletion . nubSort) . fun--wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi-wrapIdentCompleter = wrapCompleter word_break_chars--wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi-wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars- $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)- where- getModifier = find (`elem` modifChars)---- | Return a list of visible module names for autocompletion.--- (NB: exposed != visible)-allVisibleModules :: DynFlags -> [ModuleName]-allVisibleModules dflags = listVisibleModuleNames dflags--completeExpression = completeQuotedWord (Just '\\') "\"" listFiles- completeIdentifier----- -------------------------------------------------------------------------------- commands for debugger--sprintCmd, printCmd, forceCmd :: String -> GHCi ()-sprintCmd = pprintCommand False False-printCmd = pprintCommand True False-forceCmd = pprintCommand False True--pprintCommand :: Bool -> Bool -> String -> GHCi ()-pprintCommand bind force str = do- pprintClosureCommand bind force str--stepCmd :: String -> GHCi ()-stepCmd arg = withSandboxOnly ":step" $ step arg- where- step [] = doContinue (const True) GHC.SingleStep- step expression = runStmt expression GHC.SingleStep >> return ()--stepLocalCmd :: String -> GHCi ()-stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg- where- step expr- | not (null expr) = stepCmd expr- | otherwise = do- mb_span <- getCurrentBreakSpan- case mb_span of- Nothing -> stepCmd []- Just loc -> do- Just md <- getCurrentBreakModule- current_toplevel_decl <- enclosingTickSpan md loc- doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep--stepModuleCmd :: String -> GHCi ()-stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg- where- step expr- | not (null expr) = stepCmd expr- | otherwise = do- mb_span <- getCurrentBreakSpan- case mb_span of- Nothing -> stepCmd []- Just pan -> do- let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span- doContinue f GHC.SingleStep---- | Returns the span of the largest tick containing the srcspan given-enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan-enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"-enclosingTickSpan md (RealSrcSpan src) = do- ticks <- getTickArray md- let line = srcSpanStartLine src- ASSERT(inRange (bounds ticks) line) do- let enclosing_spans = [ pan | (_,pan) <- ticks ! line- , realSrcSpanEnd pan >= realSrcSpanEnd src]- return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans- where--leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering-leftmostLargestRealSrcSpan a b =- (realSrcSpanStart a `compare` realSrcSpanStart b)- `thenCmp`- (realSrcSpanEnd b `compare` realSrcSpanEnd a)--traceCmd :: String -> GHCi ()-traceCmd arg- = withSandboxOnly ":trace" $ tr arg- where- tr [] = doContinue (const True) GHC.RunAndLogSteps- tr expression = runStmt expression GHC.RunAndLogSteps >>= DAP.setContinueExecResult >> return ()--continueCmd :: String -> GHCi ()-continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion---- doContinue :: SingleStep -> GHCi ()-doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()-doContinue pre step = do- runResult <- resume pre step- DAP.setContinueExecResult (Just runResult)- _ <- afterRunStmt pre runResult- return ()--abandonCmd :: String -> GHCi ()-abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do- b <- GHC.abandon -- the prompt will change to indicate the new context- when (not b) $ liftIO $ putStrLn "There is no computation running."--deleteCmd :: String -> GHCi ()-deleteCmd argLine = withSandboxOnly ":delete" $ do- deleteSwitch $ words argLine- where- deleteSwitch :: [String] -> GHCi ()- deleteSwitch [] =- liftIO $ putStrLn "The delete command requires at least one argument."- -- delete all break points- deleteSwitch ("*":_rest) = discardActiveBreakPoints- deleteSwitch idents = do- mapM_ deleteOneBreak idents- where- deleteOneBreak :: String -> GHCi ()- deleteOneBreak str- | all isDigit str = deleteBreak (read str)- | otherwise = return ()--historyCmd :: String -> GHCi ()-historyCmd arg- | null arg = history 20- | all isDigit arg = history (read arg)- | otherwise = liftIO $ putStrLn "Syntax: :history [num]"- where- history num = do- resumes <- GHC.getResumeContext- case resumes of- [] -> liftIO $ putStrLn "Not stopped at a breakpoint"- (r:_) -> do- let hist = GHC.resumeHistory r- (took,rest) = splitAt num hist- case hist of- [] -> liftIO $ putStrLn $- "Empty history. Perhaps you forgot to use :trace?"- _ -> do- pans <- mapM GHC.getHistorySpan took- let nums = map (printf "-%-3d:") [(1::Int)..]- names = map GHC.historyEnclosingDecls took- printForUser (vcat(zipWith3- (\x y z -> x <+> y <+> z)- (map text nums)- (map (bold . hcat . punctuate colon . map text) names)- (map (parens . ppr) pans)))- liftIO $ putStrLn $ if null rest then "<end of history>" else "..."-- DAP.setStackTraceResult r took--bold :: SDoc -> SDoc-bold c | do_bold = text start_bold <> c <> text end_bold- | otherwise = c--backCmd :: String -> GHCi ()-backCmd arg- | null arg = back 1- | all isDigit arg = back (read arg)- | otherwise = liftIO $ putStrLn "Syntax: :back [num]"- where- back num = withSandboxOnly ":back" $ do- (names, _, pan, _) <- GHC.back num- printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan- printTypeOfNames names- -- run the command set with ":set stop <cmd>"- st <- getGHCiState- enqueueCommands [stop st]- DAP.setBindingNames names--forwardCmd :: String -> GHCi ()-forwardCmd arg- | null arg = forward 1- | all isDigit arg = forward (read arg)- | otherwise = liftIO $ putStrLn "Syntax: :back [num]"- where- forward num = withSandboxOnly ":forward" $ do- (names, ix, pan, _) <- GHC.forward num- printForUser $ (if (ix == 0)- then ptext (sLit "Stopped at")- else ptext (sLit "Logged breakpoint at")) <+> ppr pan- printTypeOfNames names- -- run the command set with ":set stop <cmd>"- st <- getGHCiState- enqueueCommands [stop st]-- DAP.setBindingNames names----- handle the "break" command-breakCmd :: String -> GHCi ()-breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine--breakSwitch :: [String] -> GHCi ()-breakSwitch [] = do- liftIO $ putStrLn "The break command requires at least one argument."-breakSwitch (arg1:rest)- | looksLikeModuleName arg1 && not (null rest) = do- md <- wantInterpretedModule arg1- breakByModule md rest- | all isDigit arg1 = do- imports <- GHC.getContext- case iiModules imports of- (mn : _) -> do- md <- lookupModuleName mn- breakByModuleLine md (read arg1) rest- [] -> do- liftIO $ putStrLn "No modules are loaded with debugging support."- | otherwise = do -- try parsing it as an identifier- wantNameFromInterpretedModule noCanDo arg1 $ \name -> do- maybe_info <- GHC.getModuleInfo (GHC.nameModule name)- case maybe_info of- Nothing -> noCanDo name (ptext (sLit "cannot get module info"))- Just minf ->- ASSERT( isExternalName name )- findBreakAndSet (GHC.nameModule name) $- findBreakForBind name (GHC.modInfoModBreaks minf)- where- noCanDo n why = printForUser $- text "cannot set breakpoint on " <> ppr n <> text ": " <> why--breakByModule :: Module -> [String] -> GHCi ()-breakByModule md (arg1:rest)- | all isDigit arg1 = do -- looks like a line number- breakByModuleLine md (read arg1) rest-breakByModule _ _- = breakSyntax--breakByModuleLine :: Module -> Int -> [String] -> GHCi ()-breakByModuleLine md line args- | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line- | [col] <- args, all isDigit col =- findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)- | otherwise = breakSyntax--breakSyntax :: a-breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")--findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()-findBreakAndSet md lookupTickTree = do- tickArray <- getTickArray md- (breakArray, _) <- getModBreak md- case lookupTickTree tickArray of- [] -> liftIO $ putStrLn $ "No breakpoints found at that location."- some -> mapM_ (breakAt breakArray) some- where- breakAt breakArray (tick, pan) = do- setBreakFlag True breakArray tick- (alreadySet, nm) <-- recordBreak $ BreakLocation- { breakModule = md- , breakLoc = RealSrcSpan pan- , breakTick = tick- , onBreakCmd = ""- }- printForUser $- text "Breakpoint " <> ppr nm <>- if alreadySet- then text " was already set at " <> ppr pan- else text " activated at " <> ppr pan---- When a line number is specified, the current policy for choosing--- the best breakpoint is this:--- - the leftmost complete subexpression on the specified line, or--- - the leftmost subexpression starting on the specified line, or--- - the rightmost subexpression enclosing the specified line----findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)-findBreakByLine line arr- | not (inRange (bounds arr) line) = Nothing- | otherwise =- listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`- listToMaybe (sortBy (compare `on` snd) incomp) `mplus`- listToMaybe (sortBy (flip compare `on` snd) ticks)- where- ticks = arr ! line-- starts_here = [ (ix,pan) | (ix, pan) <- ticks,- GHC.srcSpanStartLine pan == line ]-- (comp, incomp) = partition ends_here starts_here- where ends_here (_,pan) = GHC.srcSpanEndLine pan == line---- The aim is to find the breakpoints for all the RHSs of the--- equations corresponding to a binding. So we find all breakpoints--- for--- (a) this binder only (not a nested declaration)--- (b) that do not have an enclosing breakpoint-findBreakForBind :: Name -> GHC.ModBreaks -> TickArray- -> [(BreakIndex,RealSrcSpan)]-findBreakForBind name modbreaks _ = filter (not . enclosed) ticks- where- ticks = [ (index, span)- | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),- n == occNameString (nameOccName name),- RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]- enclosed (_,sp0) = any subspan ticks- where subspan (_,sp) = sp /= sp0 &&- realSrcSpanStart sp <= realSrcSpanStart sp0 &&- realSrcSpanEnd sp0 <= realSrcSpanEnd sp--findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray- -> Maybe (BreakIndex,RealSrcSpan)-findBreakByCoord mb_file (line, col) arr- | not (inRange (bounds arr) line) = Nothing- | otherwise =- listToMaybe (sortBy (flip compare `on` snd) contains ++- sortBy (compare `on` snd) after_here)- where- ticks = arr ! line-- -- the ticks that span this coordinate- contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),- is_correct_file pan ]-- is_correct_file pan- | Just f <- mb_file = GHC.srcSpanFile pan == f- | otherwise = True-- after_here = [ tick | tick@(_,pan) <- ticks,- GHC.srcSpanStartLine pan == line,- GHC.srcSpanStartCol pan >= col ]---- For now, use ANSI bold on terminals that we know support it.--- Otherwise, we add a line of carets under the active expression instead.--- In particular, on Windows and when running the testsuite (which sets--- TERM to vt100 for other reasons) we get carets.--- We really ought to use a proper termcap/terminfo library.-do_bold :: Bool-do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]- where mTerm = System.Environment.getEnv "TERM"- `catchIO` \_ -> return "TERM not set"--start_bold :: String-start_bold = "\ESC[1m"-end_bold :: String-end_bold = "\ESC[0m"---------------------------------------------------------------------------------- :where--whereCmd :: String -> GHCi ()-whereCmd = noArgs $ do- mstrs <- getCallStackAtCurrentBreakpoint- case mstrs of- Nothing -> return ()- Just strs -> liftIO $ putStrLn (renderStack strs)---------------------------------------------------------------------------------- :list--listCmd :: String -> InputT GHCi ()-listCmd c = listCmd' c--listCmd' :: String -> InputT GHCi ()-listCmd' "" = do- mb_span <- lift getCurrentBreakSpan- case mb_span of- Nothing ->- printForUser $ text "Not stopped at a breakpoint; nothing to list"- Just (RealSrcSpan pan) ->- listAround pan True- Just pan@(UnhelpfulSpan _) ->- do resumes <- GHC.getResumeContext- case resumes of- [] -> panic "No resumes"- (r:_) ->- do let traceIt = case GHC.resumeHistory r of- [] -> text "rerunning with :trace,"- _ -> empty- doWhat = traceIt <+> text ":back then :list"- printForUser (text "Unable to list source for" <+>- ppr pan- $$ text "Try" <+> doWhat)-listCmd' str = list2 (words str)--list2 :: [String] -> InputT GHCi ()-list2 [arg] | all isDigit arg = do- imports <- GHC.getContext- case iiModules imports of- [] -> liftIO $ putStrLn "No module to list"- (mn : _) -> do- md <- lift $ lookupModuleName mn- listModuleLine md (read arg)-list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do- md <- wantInterpretedModule arg1- listModuleLine md (read arg2)-list2 [arg] = do- wantNameFromInterpretedModule noCanDo arg $ \name -> do- let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)- case loc of- RealSrcLoc l ->- do tickArray <- ASSERT( isExternalName name )- lift $ getTickArray (GHC.nameModule name)- let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))- (GHC.srcLocLine l, GHC.srcLocCol l)- tickArray- case mb_span of- Nothing -> listAround (realSrcLocSpan l) False- Just (_, pan) -> listAround pan False- UnhelpfulLoc _ ->- noCanDo name $ text "can't find its location: " <>- ppr loc- where- noCanDo n why = printForUser $- text "cannot list source code for " <> ppr n <> text ": " <> why-list2 _other =- liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"--listModuleLine :: Module -> Int -> InputT GHCi ()-listModuleLine modl line = do- graph <- GHC.getModuleGraph- let this = GHC.mgLookupModule graph modl- case this of- Nothing -> panic "listModuleLine"- Just summ -> do- let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))- loc = mkRealSrcLoc (mkFastString (filename)) line 0- listAround (realSrcLocSpan loc) False---- | list a section of a source file around a particular SrcSpan.--- If the highlight flag is True, also highlight the span using--- start_bold\/end_bold.---- GHC files are UTF-8, so we can implement this by:--- 1) read the file in as a BS and syntax highlight it as before--- 2) convert the BS to String using utf-string, and write it out.--- It would be better if we could convert directly between UTF-8 and the--- console encoding, of course.-listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()-listAround pan do_highlight = do- contents <- liftIO $ BS.readFile (unpackFS file)- -- Drop carriage returns to avoid duplicates, see #9367.- let ls = BS.split '\n' $ BS.filter (/= '\r') contents- ls' = take (line2 - line1 + 1 + pad_before + pad_after) $- drop (line1 - 1 - pad_before) $ ls- fst_line = max 1 (line1 - pad_before)- line_nos = [ fst_line .. ]-- highlighted | do_highlight = zipWith highlight line_nos ls'- | otherwise = [\p -> BS.concat[p,l] | l <- ls']-- bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]- prefixed = zipWith ($) highlighted bs_line_nos- output = BS.intercalate (BS.pack "\n") prefixed-- let utf8Decoded = utf8DecodeByteString output- liftIO $ putStrLn utf8Decoded- where- file = GHC.srcSpanFile pan- line1 = GHC.srcSpanStartLine pan- col1 = GHC.srcSpanStartCol pan - 1- line2 = GHC.srcSpanEndLine pan- col2 = GHC.srcSpanEndCol pan - 1-- pad_before | line1 == 1 = 0- | otherwise = 1- pad_after = 1-- highlight | do_bold = highlight_bold- | otherwise = highlight_carets-- highlight_bold no line prefix- | no == line1 && no == line2- = let (a,r) = BS.splitAt col1 line- (b,c) = BS.splitAt (col2-col1) r- in- BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]- | no == line1- = let (a,b) = BS.splitAt col1 line in- BS.concat [prefix, a, BS.pack start_bold, b]- | no == line2- = let (a,b) = BS.splitAt col2 line in- BS.concat [prefix, a, BS.pack end_bold, b]- | otherwise = BS.concat [prefix, line]-- highlight_carets no line prefix- | no == line1 && no == line2- = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',- BS.replicate (col2-col1) '^']- | no == line1- = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,- prefix, line]- | no == line2- = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',- BS.pack "^^"]- | otherwise = BS.concat [prefix, line]- where- indent = BS.pack (" " ++ replicate (length (show no)) ' ')- nl = BS.singleton '\n'----- ----------------------------------------------------------------------------- Tick arrays--getTickArray :: Module -> GHCi TickArray-getTickArray modl = do- st <- getGHCiState- let arrmap = tickarrays st- case lookupModuleEnv arrmap modl of- Just arr -> return arr- Nothing -> do- (_breakArray, ticks) <- getModBreak modl- let arr = mkTickArray (assocs ticks)- setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}- return arr--discardTickArrays :: GHCi ()-discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})--mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray-mkTickArray ticks- = accumArray (flip (:)) [] (1, max_line)- [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]- where- max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]- srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]---- don't reset the counter back to zero?-discardActiveBreakPoints :: GHCi ()-discardActiveBreakPoints = do- st <- getGHCiState- mapM_ (turnOffBreak.snd) (breaks st)- setGHCiState $ st { breaks = [] }--deleteBreak :: Int -> GHCi ()-deleteBreak identity = do- st <- getGHCiState- let oldLocations = breaks st- (this,rest) = partition (\loc -> fst loc == identity) oldLocations- if null this- then printForUser (text "Breakpoint" <+> ppr identity <+>- text "does not exist")- else do- mapM_ (turnOffBreak.snd) this- setGHCiState $ st { breaks = rest }--turnOffBreak :: BreakLocation -> GHCi ()-turnOffBreak loc = do- (arr, _) <- getModBreak (breakModule loc)- hsc_env <- GHC.getSession- liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False--getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)-getModBreak m = do- Just mod_info <- GHC.getModuleInfo m- let modBreaks = GHC.modInfoModBreaks mod_info- let arr = GHC.modBreaks_flags modBreaks- let ticks = GHC.modBreaks_locs modBreaks- return (arr, ticks)--setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()-setBreakFlag toggle arr i = do- hsc_env <- GHC.getSession- liftIO $ enableBreakpoint hsc_env arr i toggle---- ------------------------------------------------------------------------------ User code exception handling---- This is the exception handler for exceptions generated by the--- user's code and exceptions coming from children sessions;--- it normally just prints out the exception. The--- handler must be recursive, in case showing the exception causes--- more exceptions to be raised.------ Bugfix: if the user closed stdout or stderr, the flushing will fail,--- raising another exception. We therefore don't put the recursive--- handler arond the flushing operation, so if stderr is closed--- GHCi will just die gracefully rather than going into an infinite loop.-handler :: SomeException -> GHCi Bool--handler exception = do- flushInterpBuffers- withSignalHandlers $- ghciHandle handler (showException exception >> return False)--showException :: SomeException -> GHCi ()-showException se =- liftIO $ case fromException se of- -- omit the location for CmdLineError:- Just (CmdLineError s) -> putException s- -- ditto:- Just other_ghc_ex -> putException (show other_ghc_ex)- Nothing ->- case fromException se of- Just UserInterrupt -> putException "Interrupted."- _ -> putException ("*** Exception: " ++ show se)- where- putException = hPutStrLn stderr----------------------------------------------------------------------------------- recursive exception handlers---- Don't forget to unblock async exceptions in the handler, or if we're--- in an exception loop (eg. let a = error a in a) the ^C exception--- may never be delivered. Thanks to Marcin for pointing out the bug.--ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a-ghciHandle h m = gmask $ \restore -> do- -- Force dflags to avoid leaking the associated HscEnv- !dflags <- getDynFlags- gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)--ghciTry :: GHCi a -> GHCi (Either SomeException a)-ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)--tryBool :: GHCi a -> GHCi Bool-tryBool m = do- r <- ghciTry m- case r of- Left _ -> return False- Right _ -> return True---- ------------------------------------------------------------------------------- Utils--lookupModule :: GHC.GhcMonad m => String -> m Module-lookupModule mName = lookupModuleName (GHC.mkModuleName mName)--lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module-lookupModuleName mName = GHC.lookupModule mName Nothing--isHomeModule :: Module -> Bool-isHomeModule m = GHC.moduleUnitId m == mainUnitId---- TODO: won't work if home dir is encoded.--- (changeDirectory may not work either in that case.)-expandPath :: MonadIO m => String -> InputT m String-expandPath = liftIO . expandPathIO--expandPathIO :: String -> IO String-expandPathIO p =- case dropWhile isSpace p of- ('~':d) -> do- tilde <- getHomeDirectory -- will fail if HOME not defined- return (tilde ++ '/':d)- other ->- return other--wantInterpretedModule :: GHC.GhcMonad m => String -> m Module-wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)--wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module-wantInterpretedModuleName modname = do- modl <- lookupModuleName modname- let str = moduleNameString modname- dflags <- getDynFlags- when (GHC.moduleUnitId modl /= thisPackage dflags) $- throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))- is_interpreted <- GHC.moduleIsInterpreted modl- when (not is_interpreted) $- throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))- return modl--wantNameFromInterpretedModule :: GHC.GhcMonad m- => (Name -> SDoc -> m ())- -> String- -> (Name -> m ())- -> m ()-wantNameFromInterpretedModule noCanDo str and_then =- handleSourceError GHC.printException $ do- names <- GHC.parseName str- case names of- [] -> return ()- (n:_) -> do- let modl = ASSERT( isExternalName n ) GHC.nameModule n- if not (GHC.isExternalName n)- then noCanDo n $ ppr n <>- text " is not defined in an interpreted module"- else do- is_interpreted <- GHC.moduleIsInterpreted modl- if not is_interpreted- then noCanDo n $ text "module " <> ppr modl <>- text " is not interpreted"- else and_then n-
− app-ghc-8.4/GHCi/UI/Info.hs
@@ -1,366 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | Get information on modules, expressions, and identifiers-module GHCi.UI.Info- ( ModInfo(..)- , SpanInfo(..)- , spanInfoFromRealSrcSpan- , collectInfo- , findLoc- , findNameUses- , findType- , getModInfo- ) where--import Control.Exception-import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import Control.Monad.Trans.Maybe-import Data.Data-import Data.Function-import Data.List-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Time-import Prelude hiding (mod,(<>))-import System.Directory--import qualified CoreUtils-import Desugar-import DynFlags (HasDynFlags(..))-import FastString-import GHC-import GhcMonad-import Name-import NameSet-import Outputable-import SrcLoc-import TcHsSyn-import Var---- | Info about a module. This information is generated every time a--- module is loaded.-data ModInfo = ModInfo- { modinfoSummary :: !ModSummary- -- ^ Summary generated by GHC. Can be used to access more- -- information about the module.- , modinfoSpans :: [SpanInfo]- -- ^ Generated set of information about all spans in the- -- module that correspond to some kind of identifier for- -- which there will be type info and/or location info.- , modinfoInfo :: !ModuleInfo- -- ^ Again, useful from GHC for accessing information- -- (exports, instances, scope) from a module.- , modinfoLastUpdate :: !UTCTime- }---- | Type of some span of source code. Most of these fields are--- unboxed but Haddock doesn't show that.-data SpanInfo = SpanInfo- { spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan- -- ^ The span we associate information with- , spaninfoType :: !(Maybe Type)- -- ^ The 'Type' associated with the span- , spaninfoVar :: !(Maybe Id)- -- ^ The actual 'Var' associated with the span, if- -- any. This can be useful for accessing a variety of- -- information about the identifier such as module,- -- locality, definition location, etc.- }---- | Test whether second span is contained in (or equal to) first span.--- This is basically 'containsSpan' for 'SpanInfo'-containsSpanInfo :: SpanInfo -> SpanInfo -> Bool-containsSpanInfo = containsSpan `on` spaninfoSrcSpan---- | Filter all 'SpanInfo' which are contained in 'SpanInfo'-spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]-spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'---- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a--- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'--- respectively)-spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo-spanInfoFromRealSrcSpan spn mty mvar =- SpanInfo spn mty mvar---- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs--- only a 'RealSrcSpan'-spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo-spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing---- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'-srcSpanFilePath :: RealSrcSpan -> FilePath-srcSpanFilePath = unpackFS . srcSpanFile---- | Try to find the location of the given identifier at the given--- position in the module.-findLoc :: GhcMonad m- => Map ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc m (ModInfo,Name,SrcSpan)-findLoc infos span0 string = do- name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $- guessModule infos (srcSpanFilePath span0)-- info <- maybeToExceptT "No module info for current file! Try loading it?" $- MaybeT $ pure $ M.lookup name infos-- name' <- findName infos span0 info string-- case getSrcSpan name' of- UnhelpfulSpan{} -> do- throwE ("Found a name, but no location information." <+>- "The module is:" <+>- maybe "<unknown>" (ppr . moduleName)- (nameModule_maybe name'))-- span' -> return (info,name',span')---- | Find any uses of the given identifier in the codebase.-findNameUses :: (GhcMonad m)- => Map ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc m [SrcSpan]-findNameUses infos span0 string =- locToSpans <$> findLoc infos span0 string- where- locToSpans (modinfo,name',span') =- stripSurrounding (span' : map toSrcSpan spans)- where- toSrcSpan = RealSrcSpan . spaninfoSrcSpan- spans = filter ((== Just name') . fmap getName . spaninfoVar)- (modinfoSpans modinfo)---- | Filter out redundant spans which surround/contain other spans.-stripSurrounding :: [SrcSpan] -> [SrcSpan]-stripSurrounding xs = filter (not . isRedundant) xs- where- isRedundant x = any (x `strictlyContains`) xs-- (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)- = s1 /= s2 && s1 `containsSpan` s2- _ `strictlyContains` _ = False---- | Try to resolve the name located at the given position, or--- otherwise resolve based on the current module's scope.-findName :: GhcMonad m- => Map ModuleName ModInfo- -> RealSrcSpan- -> ModInfo- -> String- -> ExceptT SDoc m Name-findName infos span0 mi string =- case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of- Nothing -> tryExternalModuleResolution- Just name ->- case getSrcSpan name of- UnhelpfulSpan {} -> tryExternalModuleResolution- RealSrcSpan {} -> return (getName name)- where- tryExternalModuleResolution =- case find (matchName $ mkFastString string)- (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of- Nothing -> throwE "Couldn't resolve to any modules."- Just imported -> resolveNameFromModule infos imported-- matchName :: FastString -> Name -> Bool- matchName str name =- str ==- occNameFS (getOccName name)---- | Try to resolve the name from another (loaded) module's exports.-resolveNameFromModule :: GhcMonad m- => Map ModuleName ModInfo- -> Name- -> ExceptT SDoc m Name-resolveNameFromModule infos name = do- modL <- maybe (throwE $ "No module for" <+> ppr name) return $- nameModule_maybe name-- info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>- ppr modL)) return $- M.lookup (moduleName modL) infos-- maybe (throwE "No matching export in any local modules.") return $- find (matchName name) (modInfoExports (modinfoInfo info))- where- matchName :: Name -> Name -> Bool- matchName x y = occNameFS (getOccName x) ==- occNameFS (getOccName y)---- | Try to resolve the type display from the given span.-resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var-resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $- reverse spans' `spaninfosWithin` si---- | Try to find the type of the given span.-findType :: GhcMonad m- => Map ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc m (ModInfo, Type)-findType infos span0 string = do- name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $- guessModule infos (srcSpanFilePath span0)-- info <- maybeToExceptT "No module info for current file! Try loading it?" $- MaybeT $ pure $ M.lookup name infos-- case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of- Nothing -> (,) info <$> lift (exprType TM_Inst string)- Just ty -> return (info, ty)- where- -- | Try to resolve the type display from the given span.- resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type- resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $- reverse spans' `spaninfosWithin` si---- | Guess a module name from a file path.-guessModule :: GhcMonad m- => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName-guessModule infos fp = do- target <- lift $ guessTarget fp Nothing- case targetId target of- TargetModule mn -> return mn- TargetFile fp' _ -> guessModule' fp'- where- guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName- guessModule' fp' = case findModByFp fp' of- Just mn -> return mn- Nothing -> do- fp'' <- liftIO (makeRelativeToCurrentDirectory fp')-- target' <- lift $ guessTarget fp'' Nothing- case targetId target' of- TargetModule mn -> return mn- _ -> MaybeT . pure $ findModByFp fp''-- findModByFp :: FilePath -> Maybe ModuleName- findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)- where- mifp :: (ModuleName, ModInfo) -> Maybe FilePath- mifp = ml_hs_file . ms_location . modinfoSummary . snd----- | Collect type info data for the loaded modules.-collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]- -> m (Map ModuleName ModInfo)-collectInfo ms loaded = do- df <- getDynFlags- liftIO (filterM cacheInvalid loaded) >>= \case- [] -> return ms- invalidated -> do- liftIO (putStrLn ("Collecting type info for " ++- show (length invalidated) ++- " module(s) ... "))-- foldM (go df) ms invalidated- where- go df m name = do { info <- getModInfo name; return (M.insert name info m) }- `gcatch`- (\(e :: SomeException) -> do- liftIO $ putStrLn- $ showSDocForUser df alwaysQualify- $ "Error while getting type info from" <+>- ppr name <> ":" <+> text (show e)- return m)-- cacheInvalid name = case M.lookup name ms of- Nothing -> return True- Just mi -> do- let fp = ml_obj_file (ms_location (modinfoSummary mi))- last' = modinfoLastUpdate mi- exists <- doesFileExist fp- if exists- then (> last') <$> getModificationTime fp- else return True---- | Get info about the module: summary, types, etc.-getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo-getModInfo name = do- m <- getModSummary name- p <- parseModule m- typechecked <- typecheckModule p- allTypes <- processAllTypeCheckedModule typechecked- let i = tm_checked_module_info typechecked- now <- liftIO getCurrentTime- return (ModInfo m allTypes i now)---- | Get ALL source spans in the module.-processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule- -> m [SpanInfo]-processAllTypeCheckedModule tcm = do- bts <- mapM getTypeLHsBind $ listifyAllSpans tcs- ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs- pts <- mapM getTypeLPat $ listifyAllSpans tcs- return $ mapMaybe toSpanInfo- $ sortBy cmpSpan- $ catMaybes (bts ++ ets ++ pts)- where- tcs = tm_typechecked_source tcm-- -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's- getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))- getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _})- = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))- getTypeLHsBind _ = pure Nothing-- -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's- getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))- getTypeLHsExpr e = do- hs_env <- getSession- (_,mbe) <- liftIO $ deSugarExpr hs_env e- return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe- where- mid :: Maybe Id- mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i- | otherwise = Nothing-- unwrapVar (HsWrap _ var) = var- unwrapVar e' = e'-- -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's- getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))- getTypeLPat (L spn pat) =- pure (Just (getMaybeId pat,spn,hsPatType pat))- where- getMaybeId (VarPat (L _ vid)) = Just vid- getMaybeId _ = Nothing-- -- | Get ALL source spans in the source.- listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]- listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))- where- p (L spn _) = isGoodSrcSpan spn-- -- | Variant of @syb@'s @everything@ (which summarises all nodes- -- in top-down, left-to-right order) with a stop-condition on 'NameSet's- everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r- everythingAllSpans k z f x- | (False `mkQ` (const True :: NameSet -> Bool)) x = z- | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)-- cmpSpan (_,a,_) (_,b,_)- | a `isSubspanOf` b = LT- | b `isSubspanOf` a = GT- | otherwise = EQ-- -- | Pretty print the types into a 'SpanInfo'.- toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo- toSpanInfo (n,RealSrcSpan spn,typ)- = Just $ spanInfoFromRealSrcSpan spn (Just typ) n- toSpanInfo _ = Nothing---- helper stolen from @syb@ package-type GenericQ r = forall a. Data a => a -> r--mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r-(r `mkQ` br) a = maybe r br (cast a)
− app-ghc-8.4/GHCi/UI/Monad.hs
@@ -1,493 +0,0 @@-{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}-{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly------------------------------------------------------------------------------------- Monadery code used in InteractiveUI------ (c) The GHC Team 2005-2006-----------------------------------------------------------------------------------module GHCi.UI.Monad (- GHCi(..), startGHCi,- GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,- GHCiOption(..), isOptionSet, setOption, unsetOption,- Command(..),- PromptFunction,- BreakLocation(..),- TickArray,- getDynFlags,-- runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,-- printForUserNeverQualify, printForUserModInfo,- printForUser, printForUserPartWay, prettyLocations,- initInterpBuffering,- turnOffBuffering, turnOffBuffering_,- flushInterpBuffers,- mkEvalWrapper- ) where---- #include "HsVersions.h" -- DAP Modified--import GHCi.UI.Info (ModInfo)-import qualified GHC-import GhcMonad hiding (liftIO)-import Outputable hiding (printForUser, printForUserPartWay)-import qualified Outputable-import DynFlags-import FastString-import HscTypes-import SrcLoc-import Module-import GHCi-import GHCi.RemoteTypes-import HsSyn (ImportDecl, GhcPs)-import Util--import Exception-import Numeric-import Data.Array-import Data.IORef-import Data.Time-import System.Environment-import System.IO-import Control.Monad-import Prelude hiding ((<>))--import System.Console.Haskeline (CompletionFunc, InputT)-import qualified System.Console.Haskeline as Haskeline-import Control.Monad.Trans.Class-import Control.Monad.IO.Class-import Data.Map.Strict (Map)-import qualified GHC.LanguageExtensions as LangExt---- DAP add.-import qualified GHCi.DAP.Type as DAP-import Control.Concurrent----------------------------------------------------------------------------------- GHCi monad--data GHCiState = GHCiState- {- progname :: String,- args :: [String],- evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@- prompt :: PromptFunction,- prompt_cont :: PromptFunction,- editor :: String,- stop :: String,- options :: [GHCiOption],- line_number :: !Int, -- ^ input line- break_ctr :: !Int,- breaks :: ![(Int, BreakLocation)],- tickarrays :: ModuleEnv TickArray,- -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,- -- so that we don't rebuild it each time the user sets- -- a breakpoint.- ghci_commands :: [Command],- -- ^ available ghci commands- ghci_macros :: [Command],- -- ^ user-defined macros- last_command :: Maybe Command,- -- ^ @:@ at the GHCi prompt repeats the last command, so we- -- remember it here- cmdqueue :: [String],-- remembered_ctx :: [InteractiveImport],- -- ^ The imports that the user has asked for, via import- -- declarations and :module commands. This list is- -- persistent over :reloads (but any imports for modules- -- that are not loaded are temporarily ignored). After a- -- :load, all the home-package imports are stripped from- -- this list.- --- -- See bugs #2049, #1873, #1360-- transient_ctx :: [InteractiveImport],- -- ^ An import added automatically after a :load, usually of- -- the most recently compiled module. May be empty if- -- there are no modules loaded. This list is replaced by- -- :load, :reload, and :add. In between it may be modified- -- by :module.-- extra_imports :: [ImportDecl GhcPs],- -- ^ These are "always-on" imports, added to the- -- context regardless of what other imports we have.- -- This is useful for adding imports that are required- -- by setGHCiMonad. Be careful adding things here:- -- you can create ambiguities if these imports overlap- -- with other things in scope.- --- -- NB. although this is not currently used by GHCi itself,- -- it was added to support other front-ends that are based- -- on the GHCi code. Potentially we could also expose- -- this functionality via GHCi commands.-- prelude_imports :: [ImportDecl GhcPs],- -- ^ These imports are added to the context when- -- -XImplicitPrelude is on and we don't have a *-module- -- in the context. They can also be overridden by another- -- import for the same module, e.g.- -- "import Prelude hiding (map)"-- ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)-- short_help :: String,- -- ^ help text to display to a user- long_help :: String,- lastErrorLocations :: IORef [(FastString, Int)],-- mod_infos :: !(Map ModuleName ModInfo),-- flushStdHandles :: ForeignHValue,- -- ^ @hFlush stdout; hFlush stderr@ in the interpreter- noBuffering :: ForeignHValue,- -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr- dapContextGHCiState :: DAP.MVarDAPContext- }--type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]---- | A GHCi command-data Command- = Command- { cmdName :: String- -- ^ Name of GHCi command (e.g. "exit")- , cmdAction :: String -> InputT GHCi Bool- -- ^ The 'Bool' value denotes whether to exit GHCi- , cmdHidden :: Bool- -- ^ Commands which are excluded from default completion- -- and @:help@ summary. This is usually set for commands not- -- useful for interactive use but rather for IDEs.- , cmdCompletionFunc :: CompletionFunc GHCi- -- ^ 'CompletionFunc' for arguments- }--type PromptFunction = [String]- -> Int- -> GHCi SDoc--data GHCiOption- = ShowTiming -- show time/allocs after evaluation- | ShowType -- show the type of expressions- | RevertCAFs -- revert CAFs after every evaluation- | Multiline -- use multiline commands- | CollectInfo -- collect and cache information about- -- modules after load- deriving Eq--data BreakLocation- = BreakLocation- { breakModule :: !GHC.Module- , breakLoc :: !SrcSpan- , breakTick :: {-# UNPACK #-} !Int- , onBreakCmd :: String- }--instance Eq BreakLocation where- loc1 == loc2 = breakModule loc1 == breakModule loc2 &&- breakTick loc1 == breakTick loc2--prettyLocations :: [(Int, BreakLocation)] -> SDoc-prettyLocations [] = text "No active breakpoints."-prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs--instance Outputable BreakLocation where- ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>- if null (onBreakCmd loc)- then Outputable.empty- else doubleQuotes (text (onBreakCmd loc))--recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)-recordBreak brkLoc = do- st <- getGHCiState- let oldActiveBreaks = breaks st- -- don't store the same break point twice- case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of- (nm:_) -> return (True, nm)- [] -> do- let oldCounter = break_ctr st- newCounter = oldCounter + 1- setGHCiState $ st { break_ctr = newCounter,- breaks = (oldCounter, brkLoc) : oldActiveBreaks- }- return (False, oldCounter)--newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }--reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a-reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s--reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a-reifyGHCi f = GHCi f'- where- -- f' :: IORef GHCiState -> Ghc a- f' gs = reifyGhc (f'' gs)- -- f'' :: IORef GHCiState -> Session -> IO a- f'' gs s = f (s, gs)--startGHCi :: GHCi a -> GHCiState -> Ghc a-startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref--instance Functor GHCi where- fmap = liftM--instance Applicative GHCi where- pure a = GHCi $ \_ -> pure a- (<*>) = ap--instance Monad GHCi where- (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s--class HasGhciState m where- getGHCiState :: m GHCiState- setGHCiState :: GHCiState -> m ()- modifyGHCiState :: (GHCiState -> GHCiState) -> m ()--instance HasGhciState GHCi where- getGHCiState = GHCi $ \r -> liftIO $ readIORef r- setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s- modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f--instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where- getGHCiState = lift getGHCiState- setGHCiState = lift . setGHCiState- modifyGHCiState = lift . modifyGHCiState--liftGhc :: Ghc a -> GHCi a-liftGhc m = GHCi $ \_ -> m--instance MonadIO GHCi where- liftIO = liftGhc . liftIO--instance HasDynFlags GHCi where- getDynFlags = getSessionDynFlags--instance GhcMonad GHCi where- setSession s' = liftGhc $ setSession s'- getSession = liftGhc $ getSession--instance HasDynFlags (InputT GHCi) where- getDynFlags = lift getDynFlags--instance GhcMonad (InputT GHCi) where- setSession = lift . setSession- getSession = lift getSession--instance ExceptionMonad GHCi where- gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)- gmask f =- GHCi $ \s -> gmask $ \io_restore ->- let- g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')- in- unGHCi (f g_restore) s--instance Haskeline.MonadException Ghc where- controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let- run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)- in fmap (flip unGhc s) $ f run'--instance Haskeline.MonadException GHCi where- controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let- run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)- in fmap (flip unGHCi s) $ f run'--instance ExceptionMonad (InputT GHCi) where- gcatch = Haskeline.catch- gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)--isOptionSet :: GHCiOption -> GHCi Bool-isOptionSet opt- = do st <- getGHCiState- return (opt `elem` options st)--setOption :: GHCiOption -> GHCi ()-setOption opt- = do st <- getGHCiState- setGHCiState (st{ options = opt : filter (/= opt) (options st) })--unsetOption :: GHCiOption -> GHCi ()-unsetOption opt- = do st <- getGHCiState- setGHCiState (st{ options = filter (/= opt) (options st) })--printForUserNeverQualify :: GhcMonad m => SDoc -> m ()-printForUserNeverQualify doc = do- dflags <- getDynFlags- liftIO $ Outputable.printForUser dflags stdout neverQualify doc--printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()-printForUserModInfo info doc = do- dflags <- getDynFlags- mUnqual <- GHC.mkPrintUnqualifiedForModule info- unqual <- maybe GHC.getPrintUnqual return mUnqual- liftIO $ Outputable.printForUser dflags stdout unqual doc--printForUser :: GhcMonad m => SDoc -> m ()-printForUser doc = do- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- liftIO $ Outputable.printForUser dflags stdout unqual doc--printForUserPartWay :: SDoc -> GHCi ()-printForUserPartWay doc = do- unqual <- GHC.getPrintUnqual- dflags <- getDynFlags- liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc---- | Run a single Haskell expression-runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)-runStmt expr step = do- st <- getGHCiState- GHC.handleSourceError (\e -> do GHC.printException e; dapSaveRunStmtDeclException e; return Nothing) $ do- let opts = GHC.execOptions- { GHC.execSourceFile = progname st- , GHC.execLineNumber = line_number st- , GHC.execSingleStep = step- , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))- (EvalThis fhv) }- Just <$> GHC.execStmt expr opts--runDecls :: String -> GHCi (Maybe [GHC.Name])-runDecls decls = do- st <- getGHCiState- reifyGHCi $ \x ->- withProgName (progname st) $- withArgs (args st) $- reflectGHCi x $ do- GHC.handleSourceError (\e -> do GHC.printException e;- dapSaveRunStmtDeclException e;- return Nothing) $ do- r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls- return (Just r)--resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult-resume canLogSpan step = do- st <- getGHCiState- reifyGHCi $ \x ->- withProgName (progname st) $- withArgs (args st) $- reflectGHCi x $ do- GHC.resumeExec canLogSpan step---- ----------------------------------------------------------------------------- timing & statistics--timeIt :: (a -> Maybe Integer) -> InputT GHCi a -> InputT GHCi a-timeIt getAllocs action- = do b <- lift $ isOptionSet ShowTiming- if not b- then action- else do time1 <- liftIO $ getCurrentTime- a <- action- let allocs = getAllocs a- time2 <- liftIO $ getCurrentTime- dflags <- getDynFlags- let period = time2 `diffUTCTime` time1- liftIO $ printTimes dflags allocs (realToFrac period)- return a--printTimes :: DynFlags -> Maybe Integer -> Double -> IO ()-printTimes dflags mallocs secs- = do let secs_str = showFFloat (Just 2) secs- putStrLn (showSDoc dflags (- parens (text (secs_str "") <+> text "secs" <> comma <+>- case mallocs of- Nothing -> empty- Just allocs ->- text (separateThousands allocs) <+> text "bytes")))- where- separateThousands n = reverse . sep . reverse . show $ n- where sep n'- | n' `lengthAtMost` 3 = n'- | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')---------------------------------------------------------------------------------- reverting CAFs--revertCAFs :: GHCi ()-revertCAFs = do- liftIO rts_revertCAFs- s <- getGHCiState- when (not (ghc_e s)) turnOffBuffering- -- Have to turn off buffering again, because we just- -- reverted stdout, stderr & stdin to their defaults.--foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()- -- Make it "safe", just in case---------------------------------------------------------------------------------- To flush buffers for the *interpreted* computation we need--- to refer to *its* stdout/stderr handles---- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly-initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)-initInterpBuffering = do- nobuf <- compileGHCiExpr $- "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++- " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++- " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"- flush <- compileGHCiExpr $- "do { System.IO.hFlush System.IO.stdout; " ++- " System.IO.hFlush System.IO.stderr }"- return (nobuf, flush)---- | Invoke "hFlush stdout; hFlush stderr" in the interpreter-flushInterpBuffers :: GHCi ()-flushInterpBuffers = do- st <- getGHCiState- hsc_env <- GHC.getSession- liftIO $ evalIO hsc_env (flushStdHandles st)---- | Turn off buffering for stdin, stdout, and stderr in the interpreter-turnOffBuffering :: GHCi ()-turnOffBuffering = do- st <- getGHCiState- turnOffBuffering_ (noBuffering st)--turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()-turnOffBuffering_ fhv = do- hsc_env <- getSession- liftIO $ evalIO hsc_env fhv--mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue-mkEvalWrapper progname args =- compileGHCiExpr $- "\\m -> System.Environment.withProgName " ++ show progname ++- "(System.Environment.withArgs " ++ show args ++ " m)"--compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue-compileGHCiExpr expr = do- hsc_env <- getSession- let dflags = hsc_dflags hsc_env- -- RebindableSyntax can wreak havoc with GHCi in several ways- -- (see #13385 and #14342 for examples), so we take care to disable it- -- for the duration of running expressions that are internal to GHCi.- no_rb_hsc_env =- hsc_env { hsc_dflags = xopt_unset dflags LangExt.RebindableSyntax }- setSession no_rb_hsc_env- res <- GHC.compileExprRemote expr- setSession hsc_env- pure res------------------------------------------------------------------------------------------------------ DAP Utility----------------------------------------------------------------------------------------------------- |----dapSaveRunStmtDeclException :: SourceError -> GHCi SourceError-dapSaveRunStmtDeclException res = do- mvarCtx <- dapContextGHCiState <$> getGHCiState -- ctx <- liftIO $ takeMVar mvarCtx- liftIO $ putMVar mvarCtx ctx{DAP.runStmtDeclExceptionDAPContext = Just res}-- return res
− app-ghc-8.4/GHCi/UI/Tags.hs
@@ -1,215 +0,0 @@------------------------------------------------------------------------------------ GHCi's :ctags and :etags commands------ (c) The GHC Team 2005-2007-----------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-module GHCi.UI.Tags (- createCTagsWithLineNumbersCmd,- createCTagsWithRegExesCmd,- createETagsFileCmd-) where--import Exception-import GHC-import GHCi.UI.Monad-import Outputable---- ToDo: figure out whether we need these, and put something appropriate--- into the GHC API instead-import Name (nameOccName)-import OccName (pprOccName)-import ConLike-import MonadUtils--import Data.Function-import Data.Maybe-import Data.Ord-import DriverPhases-import Panic-import Data.List-import Control.Monad-import System.Directory-import System.IO-import System.IO.Error---------------------------------------------------------------------------------- create tags file for currently loaded modules.--createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,- createETagsFileCmd :: String -> GHCi ()--createCTagsWithLineNumbersCmd "" =- ghciCreateTagsFile CTagsWithLineNumbers "tags"-createCTagsWithLineNumbersCmd file =- ghciCreateTagsFile CTagsWithLineNumbers file--createCTagsWithRegExesCmd "" =- ghciCreateTagsFile CTagsWithRegExes "tags"-createCTagsWithRegExesCmd file =- ghciCreateTagsFile CTagsWithRegExes file--createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"-createETagsFileCmd file = ghciCreateTagsFile ETags file--data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes--ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()-ghciCreateTagsFile kind file = do- createTagsFile kind file---- ToDo:--- - remove restriction that all modules must be interpreted--- (problem: we don't know source locations for entities unless--- we compiled the module.------ - extract createTagsFile so it can be used from the command-line--- (probably need to fix first problem before this is useful).----createTagsFile :: TagsKind -> FilePath -> GHCi ()-createTagsFile tagskind tagsFile = do- graph <- GHC.getModuleGraph- mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)- either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags- case either_res of- Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e- Right _ -> return ()---listModuleTags :: GHC.Module -> GHCi [TagInfo]-listModuleTags m = do- is_interpreted <- GHC.moduleIsInterpreted m- -- should we just skip these?- when (not is_interpreted) $- let mName = GHC.moduleNameString (GHC.moduleName m) in- throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))- mbModInfo <- GHC.getModuleInfo m- case mbModInfo of- Nothing -> return []- Just mInfo -> do- dflags <- getDynFlags- mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo- let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual- let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo- let localNames = filter ((m==) . nameModule) names- mbTyThings <- mapM GHC.lookupName localNames- return $! [ tagInfo dflags unqual exported kind name realLoc- | tyThing <- catMaybes mbTyThings- , let name = getName tyThing- , let exported = GHC.modInfoIsExportedName mInfo name- , let kind = tyThing2TagKind tyThing- , let loc = srcSpanStart (nameSrcSpan name)- , RealSrcLoc realLoc <- [loc]- ]-- where- tyThing2TagKind (AnId _) = 'v'- tyThing2TagKind (AConLike RealDataCon{}) = 'd'- tyThing2TagKind (AConLike PatSynCon{}) = 'p'- tyThing2TagKind (ATyCon _) = 't'- tyThing2TagKind (ACoAxiom _) = 'x'---data TagInfo = TagInfo- { tagExported :: Bool -- is tag exported- , tagKind :: Char -- tag kind- , tagName :: String -- tag name- , tagFile :: String -- file name- , tagLine :: Int -- line number- , tagCol :: Int -- column number- , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset- }----- get tag info, for later translation into Vim or Emacs style-tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc- -> TagInfo-tagInfo dflags unqual exported kind name loc- = TagInfo exported kind- (showSDocForUser dflags unqual $ pprOccName (nameOccName name))- (showSDocForUser dflags unqual $ ftext (srcLocFile loc))- (srcLocLine loc) (srcLocCol loc) Nothing---- throw an exception when someone tries to overwrite existing source file (fix for #10989)-writeTagsSafely :: FilePath -> String -> IO ()-writeTagsSafely file str = do- dfe <- doesFileExist file- if dfe && isSourceFilename file- then throwGhcException (CmdLineError (file ++ " is existing source file. " ++- "Please specify another file name to store tags data"))- else writeFile file str--collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())--- ctags style with the Ex expression being just the line number, Vim et al-collateAndWriteTags CTagsWithLineNumbers file tagInfos = do- let tags = unlines $ sort $ map showCTag tagInfos- tryIO (writeTagsSafely file tags)---- ctags style with the Ex expression being a regex searching the line, Vim et al-collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al- tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos- let tags = unlines $ sort $ map showCTag $concat tagInfoGroups- tryIO (writeTagsSafely file tags)--collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs- tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos- let tagGroups = map processGroup tagInfoGroups- tryIO (writeTagsSafely file $ concat tagGroups)-- where- processGroup [] = throwGhcException (CmdLineError "empty tag file group??")- processGroup group@(tagInfo:_) =- let tags = unlines $ map showETag group in- "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags---makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]-makeTagGroupsWithSrcInfo tagInfos = do- let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos- mapM addTagSrcInfo groups-- where- addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")- addTagSrcInfo group@(tagInfo:_) = do- file <- readFile $tagFile tagInfo- let sortedGroup = sortBy (comparing tagLine) group- return $ perFile sortedGroup 1 0 $ lines file-- perFile allTags@(tag:tags) cnt pos allLs@(l:ls)- | tagLine tag > cnt =- perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls- | tagLine tag == cnt =- tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs- perFile _ _ _ _ = []----- ctags format, for Vim et al-showCTag :: TagInfo -> String-showCTag ti =- tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++- tagKind ti : ( if tagExported ti then "" else "\tfile:" )-- where- tagCmd =- case tagSrcInfo ti of- Nothing -> show $tagLine ti- Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"-- where- escapeSlashes '/' r = '\\' : '/' : r- escapeSlashes '\\' r = '\\' : '\\' : r- escapeSlashes c r = c : r----- etags format, for Emacs/XEmacs-showETag :: TagInfo -> String-showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,- tagSrcInfo = Just (srcLine,charPos) }- = take (colNo - 1) srcLine ++ tag- ++ "\x7f" ++ tag- ++ "\x01" ++ show lineNo- ++ "," ++ show charPos-showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
app-ghc-8.6/GHCi/UI.hs view
@@ -159,8 +159,7 @@ -- DAP ------------------------------------------------------------------------------ import qualified GHCi.DAP.Type as DAP-import qualified GHCi.DAP.UI as DAP-+import Control.Concurrent ----------------------------------------------------------------------------- data GhciSettings = GhciSettings {@@ -3326,7 +3325,7 @@ = withSandboxOnly ":trace" $ tr arg where tr [] = doContinue (const True) GHC.RunAndLogSteps- tr expression = runStmt expression GHC.RunAndLogSteps >>= DAP.setContinueExecResult >> return ()+ tr expression = runStmt expression GHC.RunAndLogSteps >>= setContinueExecResult >> return () -- DAP added. continueCmd :: String -> GHCi () continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion@@ -3335,7 +3334,7 @@ doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pre step = do runResult <- resume pre step- DAP.setContinueExecResult (Just runResult)+ setContinueExecResult (Just runResult) -- DAP added. _ <- afterRunStmt pre runResult return () @@ -3388,7 +3387,7 @@ (map (parens . ppr) pans))) liftIO $ putStrLn $ if null rest then "<end of history>" else "..." - DAP.setStackTraceResult r took+ setStackTraceResult r took -- DAP added bold :: SDoc -> SDoc bold c | do_bold = text start_bold <> c <> text end_bold@@ -3407,7 +3406,7 @@ -- run the command set with ":set stop <cmd>" st <- getGHCiState enqueueCommands [stop st]- DAP.setBindingNames names+ setBindingNames names -- DAP added. forwardCmd :: String -> GHCi () forwardCmd arg@@ -3425,7 +3424,7 @@ st <- getGHCiState enqueueCommands [stop st] - DAP.setBindingNames names+ setBindingNames names -- DAP added. -- handle the "break" command breakCmd :: String -> GHCi ()@@ -3914,3 +3913,33 @@ then noCanDo n $ text "module " <> ppr modl <> text " is not interpreted" else and_then n++------------------------------------------------------------------------------------------------+-- DAP Utility+------------------------------------------------------------------------------------------------++-- |+--+setStackTraceResult :: Resume -> [GHC.History] -> GHCi ()+setStackTraceResult r hs = do+ ctxMVar <- dapContextGHCiState <$> getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {DAP.stackTraceResultDAPContext = Just (r, hs)}+++-- |+--+setBindingNames :: [Name] -> GHCi ()+setBindingNames names = do+ ctxMVar <- dapContextGHCiState <$> getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {DAP.bindingNamesDAPContext = names}++-- |+--+setContinueExecResult :: Maybe GHC.ExecResult -> GHCi (Maybe GHC.ExecResult)+setContinueExecResult res = do+ ctxMVar <- dapContextGHCiState <$> getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx{DAP.continueExecResultDAPContext = res}+ return res
app-ghc-8.6/GHCi/UI/Monad.hs view
@@ -27,7 +27,8 @@ initInterpBuffering, turnOffBuffering, turnOffBuffering_, flushInterpBuffers,- mkEvalWrapper+ mkEvalWrapper,+ dapLookupMaxBreakLocation -- DAP added. ) where -- #include "HsVersions.h" -- DAP Modified@@ -485,9 +486,19 @@ -- dapSaveRunStmtDeclException :: SourceError -> GHCi SourceError dapSaveRunStmtDeclException res = do- mvarCtx <- dapContextGHCiState <$> getGHCiState + mvarCtx <- dapContextGHCiState <$> getGHCiState ctx <- liftIO $ takeMVar mvarCtx liftIO $ putMVar mvarCtx ctx{DAP.runStmtDeclExceptionDAPContext = Just res} return res++-- |+--+dapLookupMaxBreakLocation :: GHCi (Maybe (Int, BreakLocation))+dapLookupMaxBreakLocation = do+ newSt <- getGHCiState+ let l = breaks newSt+ if length l == 0 then return Nothing+ else return $ Just $ head l+
app-ghc-8.8/GHCi/UI.hs view
@@ -160,10 +160,10 @@ -- DAP ------------------------------------------------------------------------------ import qualified GHCi.DAP.Type as DAP-import qualified GHCi.DAP.UI as DAP-+import Control.Concurrent ----------------------------------------------------------------------------- + data GhciSettings = GhciSettings { availableCommands :: [Command], shortHelpText :: String,@@ -3438,7 +3438,7 @@ = withSandboxOnly ":trace" $ tr arg where tr [] = doContinue (const True) GHC.RunAndLogSteps- tr expression = runStmt expression GHC.RunAndLogSteps >>= DAP.setContinueExecResult >> return ()+ tr expression = runStmt expression GHC.RunAndLogSteps >>= setContinueExecResult >> return () -- DAP added. continueCmd :: String -> GHCi () continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion@@ -3447,7 +3447,7 @@ doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pre step = do runResult <- resume pre step- DAP.setContinueExecResult (Just runResult)+ setContinueExecResult (Just runResult) -- DAP added. _ <- afterRunStmt pre runResult return () @@ -3500,7 +3500,7 @@ (map (parens . ppr) pans))) liftIO $ putStrLn $ if null rest then "<end of history>" else "..." - DAP.setStackTraceResult r took+ setStackTraceResult r took -- DAP added. bold :: SDoc -> SDoc bold c | do_bold = text start_bold <> c <> text end_bold@@ -3519,7 +3519,7 @@ -- run the command set with ":set stop <cmd>" st <- getGHCiState enqueueCommands [stop st]- DAP.setBindingNames names+ setBindingNames names -- DAP added. forwardCmd :: String -> GHCi () forwardCmd arg@@ -3537,7 +3537,7 @@ st <- getGHCiState enqueueCommands [stop st] - DAP.setBindingNames names+ setBindingNames names -- DAP added. -- handle the "break" command breakCmd :: String -> GHCi ()@@ -4026,3 +4026,34 @@ then noCanDo n $ text "module " <> ppr modl <> text " is not interpreted" else and_then n+++------------------------------------------------------------------------------------------------+-- DAP Utility+------------------------------------------------------------------------------------------------++-- |+--+setStackTraceResult :: Resume -> [GHC.History] -> GHCi ()+setStackTraceResult r hs = do+ ctxMVar <- dapContextGHCiState <$> getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {DAP.stackTraceResultDAPContext = Just (r, hs)}+++-- |+--+setBindingNames :: [Name] -> GHCi ()+setBindingNames names = do+ ctxMVar <- dapContextGHCiState <$> getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx {DAP.bindingNamesDAPContext = names}++-- |+--+setContinueExecResult :: Maybe GHC.ExecResult -> GHCi (Maybe GHC.ExecResult)+setContinueExecResult res = do+ ctxMVar <- dapContextGHCiState <$> getGHCiState+ ctx <- liftIO $ takeMVar ctxMVar+ liftIO $ putMVar ctxMVar ctx{DAP.continueExecResultDAPContext = res}+ return res
app-ghc-8.8/GHCi/UI/Monad.hs view
@@ -31,7 +31,8 @@ initInterpBuffering, turnOffBuffering, turnOffBuffering_, flushInterpBuffers,- mkEvalWrapper+ mkEvalWrapper,+ dapLookupMaxBreakLocation -- DAP added. ) where -- #include "HsVersions.h" -- DAP Modified@@ -550,10 +551,19 @@ -- dapSaveRunStmtDeclException :: SourceError -> GHCi SourceError dapSaveRunStmtDeclException res = do- mvarCtx <- dapContextGHCiState <$> getGHCiState + mvarCtx <- dapContextGHCiState <$> getGHCiState ctx <- liftIO $ takeMVar mvarCtx liftIO $ putMVar mvarCtx ctx{DAP.runStmtDeclExceptionDAPContext = Just res} return res++-- |+--+dapLookupMaxBreakLocation :: GHCi (Maybe (Int, BreakLocation))+dapLookupMaxBreakLocation = do+ newSt <- getGHCiState+ let l = breaks newSt+ if length l == 0 then return Nothing+ else return $ Just $ head l
app/GHCi/DAP/Command.hs view
@@ -207,22 +207,19 @@ modSums <- Gi.getLoadedModules let modPaths = map takeModPath modSums - case filter (isPathMatch srcPath) modPaths of- ((m, p):[]) -> do- debugL $ "<dapSetBreakpointsCommand> " ++ p ++ " -> " ++ m+ findModule srcPath modPaths >>= \case+ Just (m, p) -> do+ debugL $ "<getModule> " ++ p ++ " -> " ++ m return m - _ -> throwError $ "loaded module can not find from path. <" ++ srcPath ++ "> " ++ show modPaths+ Nothing -> throwError $ "<getModule> loaded module can not find from path. <" ++ srcPath ++ "> " ++ show modPaths + -- | --- takeModPath :: ModSummary -> (String, FilePath)+ takeModPath :: ModSummary -> (ModuleName, FilePath) takeModPath ms = (G.moduleNameString (G.ms_mod_name ms), G.ms_hspp_file ms) - -- |- --- isPathMatch :: FilePath -> (String, FilePath) -> Bool- isPathMatch srcPath (_, p) = (nzPath srcPath) == (nzPath p) -- | --@@ -376,12 +373,13 @@ modSums <- Gi.getLoadedModules let modPaths = map takeModPath modSums - case filter (isPathMatch startup) modPaths of- ((m, p):[]) -> do- debugL $ "<dapSetFuncBreakpointCommand> " ++ p ++ " -> " ++ m+ findModule startup modPaths >>= \case+ Just (m, p) -> do+ debugL $ "<getModuleByFile> " ++ p ++ " -> " ++ m return m- _ -> throwError $ "loaded module can not find from path. <" ++ startup ++ "> " ++ show modPaths + Nothing -> throwError $ "<getModuleByFile> loaded module can not find from path. <" ++ startup ++ "> " ++ show modPaths+ -- | -- updateBpCtx :: (D.FunctionBreakpoint, D.Breakpoint) -> Gi.GHCi ()@@ -839,9 +837,9 @@ -- handleResult :: Gi.GHCi D.StoppedEventBody handleResult = hasBreaked >>= \case- False -> genStoppedEventBody+ False -> genStoppedEventBody "breakpoint" True -> isBreakthrough >>= \case- False -> genStoppedEventBody+ False -> genStoppedEventBody "breakpoint" True -> continue -- |@@ -1048,7 +1046,7 @@ -- ghci maybe throw error cause of force inspecting variable. gcatch (Gi.stepLocalCmd "") unexpectErrHdl - Right <$> genStoppedEventBody+ Right <$> genStoppedEventBody "step" ------------------------------------------------------------------------------------------------@@ -1072,6 +1070,6 @@ -- ghci maybe throw error cause of force inspecting variable. gcatch (Gi.stepCmd "") unexpectErrHdl - Right <$> genStoppedEventBody+ Right <$> genStoppedEventBody "step"
− app/GHCi/DAP/UI.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE LambdaCase #-}--module GHCi.DAP.UI where--import qualified GHC as G-import qualified GHCi.UI.Monad as Gi hiding (runStmt)-import Control.Concurrent-import Control.Monad.IO.Class-import InteractiveEval--import GHCi.DAP.Type---- | ----setStackTraceResult :: G.Resume -> [G.History] -> Gi.GHCi ()-setStackTraceResult r hs = do- ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState- ctx <- liftIO $ takeMVar ctxMVar- liftIO $ putMVar ctxMVar ctx {stackTraceResultDAPContext = Just (r, hs)}----- | ----setBindingNames :: [G.Name] -> Gi.GHCi ()-setBindingNames names = do- ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState- ctx <- liftIO $ takeMVar ctxMVar- liftIO $ putMVar ctxMVar ctx {bindingNamesDAPContext = names}--{---- |----saveTraceCmdExecResult :: Maybe ExecResult -> Gi.GHCi (Maybe ExecResult)-saveTraceCmdExecResult res = do- ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState -- ctx <- liftIO $ takeMVar ctxMVar- let cur = traceCmdExecResultDAPContext ctx-- liftIO $ putMVar ctxMVar ctx{traceCmdExecResultDAPContext = res : cur}-- return res----- |----saveDoContinueExecResult :: ExecResult -> Gi.GHCi ExecResult-saveDoContinueExecResult res = do- ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState -- ctx <- liftIO $ takeMVar ctxMVar- let cur = doContinueExecResultDAPContext ctx-- liftIO $ putMVar ctxMVar ctx{doContinueExecResultDAPContext = res : cur}-- return res--}---- |----setContinueExecResult :: Maybe ExecResult -> Gi.GHCi (Maybe ExecResult)-setContinueExecResult res = do- ctxMVar <- Gi.dapContextGHCiState <$> Gi.getGHCiState - ctx <- liftIO $ takeMVar ctxMVar- liftIO $ putMVar ctxMVar ctx{continueExecResultDAPContext = res}- return res-
app/GHCi/DAP/Utility.hs view
@@ -22,6 +22,7 @@ import DataCon import Debugger import qualified Data.Map as M+import System.Directory import qualified Haskell.DAP as D @@ -94,11 +95,23 @@ -- | ---isPathMatch :: FilePath -> (String, FilePath) -> Bool-isPathMatch srcPath (_, p) = (nzPath srcPath) == (nzPath p)+isPathMatch :: FilePath -> ModuleName -> Gi.GHCi Bool+isPathMatch srcPath modPath = do+ srcAbs <- liftIO $ canonicalizePath srcPath+ modAbs <- liftIO $ canonicalizePath modPath+ return $ srcAbs == modAbs -- |+--+findModule :: FilePath -> [(ModuleName, FilePath)] -> Gi.GHCi (Maybe (ModuleName, FilePath))+findModule _ [] = return Nothing+findModule srcPath ((m, p):xs) = isPathMatch srcPath p >>= \case+ True -> return $ Just (m, p)+ False -> findModule srcPath xs+++-- | -- to lowercase Windows drive letter -- drive2lower :: FilePath -> FilePath@@ -240,9 +253,10 @@ Gi.breakCmd argStr newSt <- Gi.getGHCiState+ newBl <- Gi.dapLookupMaxBreakLocation let newCount = Gi.break_ctr newSt isAdded = (newCount == curCount + 1)- locMay = if isAdded then Just (head (Gi.breaks newSt)) else Nothing+ locMay = if isAdded then newBl else Nothing withBreakLoc locMay @@ -261,7 +275,7 @@ D.nameSource = (Just . G.moduleNameString . G.moduleName . Gi.breakModule) bpLoc , D.pathSource = (unpackFS . G.srcSpanFile) dat , D.sourceReferenceSource = Nothing- , D.origineSource = Nothing+ , D.originSource = Nothing } , D.lineBreakpoint = G.srcSpanStartLine dat , D.columnBreakpoint = G.srcSpanStartCol dat@@ -279,33 +293,33 @@ -- | ---genStoppedEventBody :: Gi.GHCi D.StoppedEventBody-genStoppedEventBody = getContinueExecResult >>= \case+genStoppedEventBody :: String -> Gi.GHCi D.StoppedEventBody+genStoppedEventBody reason = getContinueExecResult >>= \case Nothing -> throwError "ExecResult not found."- Just er -> execResult2StoppedEventBody er+ Just er -> execResult2StoppedEventBody reason er -- | ---execResult2StoppedEventBody :: G.ExecResult -> Gi.GHCi D.StoppedEventBody-execResult2StoppedEventBody (G.ExecComplete { G.execResult = Right _ }) = do+execResult2StoppedEventBody :: String -> G.ExecResult -> Gi.GHCi D.StoppedEventBody+execResult2StoppedEventBody _ (G.ExecComplete { G.execResult = Right _ }) = do return D.defaultStoppedEventBody { D.reasonStoppedEventBody = "complete" } -execResult2StoppedEventBody (G.ExecComplete { G.execResult = Left (SomeException e)}) = do+execResult2StoppedEventBody _ (G.ExecComplete { G.execResult = Left (SomeException e)}) = do return D.defaultStoppedEventBody { D.reasonStoppedEventBody = "complete" , D.descriptionStoppedEventBody = show e , D.textStoppedEventBody = show e } -execResult2StoppedEventBody (G.ExecBreak{G.breakInfo = Just (BreakInfo _ _)}) = do+execResult2StoppedEventBody reason (G.ExecBreak{G.breakInfo = Just (BreakInfo _ _)}) = do return D.defaultStoppedEventBody {- D.reasonStoppedEventBody = "breakpoint"+ D.reasonStoppedEventBody = reason } -execResult2StoppedEventBody (G.ExecBreak{G.breakInfo = Nothing}) = do+execResult2StoppedEventBody _ (G.ExecBreak{G.breakInfo = Nothing}) = do -- have to :force _exception first. -- then can show it. debugL "stopped by exception"
ghci-dap.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: e6755e1213c6a6f165421137256b97d61d59fc8bc401d30aab347e3bba776b51+-- hash: 28fcb94e0e43db8e7a27c706ba124b28ef3d676efd7fd671d5004144a13f1d46 name: ghci-dap-version: 0.0.14.0+version: 0.0.15.0 synopsis: ghci-dap is a GHCi having DAP interface. description: Please see README.md category: Development@@ -15,15 +15,13 @@ bug-reports: https://github.com/phoityne/ghci-dap/issues author: phoityne_hs maintainer: phoityne.hs@gmail.com-copyright: 2017-2020 phoityne_hs+copyright: 2017-2021 phoityne_hs license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: README.md Changelog.md- src-c-8.4/HsVersions.h- src-c-8.4/PosixSource.h src-c-8.6/PosixSource.h src-c-8.8/PosixSource.h @@ -41,6 +39,7 @@ , containers , deepseq , directory+ , exceptions , filepath , ghc , ghc-boot@@ -48,12 +47,12 @@ , ghc-prim , ghci , haskeline- , haskell-dap >=0.0.14.0+ , haskell-dap >=0.0.15.0 , process , text , time , transformers- if impl(ghc < 8.4.0)+ if impl(ghc < 8.6.0) build-depends: unsupported-ghc-version >1 && <1 default-language: Haskell2010@@ -64,13 +63,12 @@ GHCi.DAP.Command GHCi.DAP.Constant GHCi.DAP.Type- GHCi.DAP.UI GHCi.DAP.Utility Paths_ghci_dap hs-source-dirs: app ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing- cpp-options: -DGHCI+ cpp-options: -DGHCI -DHAVE_INTERNAL_INTERPRETER -DGHC_LOADED_INTO_GHCI cc-options: -fPIC build-depends: array@@ -79,6 +77,7 @@ , containers , deepseq , directory+ , exceptions , filepath , ghc , ghc-boot@@ -87,27 +86,14 @@ , ghci , ghci-dap , haskeline- , haskell-dap >=0.0.14.0+ , haskell-dap >=0.0.15.0 , process , text , time , transformers- if impl(ghc < 8.4.0)+ if impl(ghc < 8.6.0) build-depends: unsupported-ghc-version >1 && <1- if (impl(ghc >= 8.4.0)) && (impl(ghc < 8.5.0))- other-modules:- GHCi.UI- GHCi.UI.Info- GHCi.UI.Monad- GHCi.UI.Tags- GHCMain- hs-source-dirs:- app-ghc-8.4- include-dirs:- src-c-8.4/- c-sources:- src-c-8.4/hschooks.c if (impl(ghc >= 8.6.0)) && (impl(ghc < 8.7.0)) other-modules: GHCi.Leak@@ -137,6 +123,17 @@ src-c-8.8/ c-sources: src-c-8.8/hschooks.c+ if (impl(ghc >= 8.10.1)) && (impl(ghc < 8.11.0))+ other-modules:+ GHCi.Leak+ GHCi.UI+ GHCi.UI.Info+ GHCi.UI.Monad+ GHCi.UI.Tags+ GHCi.Util+ GHCMain+ hs-source-dirs:+ app-ghc-8.10 if os(windows) build-depends: Win32
− src-c-8.4/HsVersions.h
@@ -1,65 +0,0 @@-#pragma once--#if 0--IMPORTANT! If you put extra tabs/spaces in these macro definitions,-you will screw up the layout where they are used in case expressions!--(This is cpp-dependent, of course)--#endif--/* Useful in the headers that we share with the RTS */-#define COMPILING_GHC 1--/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */-/* #include "ghc_boot_platform.h" DAP Modified */--/* Pull in the autoconf defines (HAVE_FOO), but don't include- * ghcconfig.h, because that will include ghcplatform.h which has the- * wrong platform settings for the compiler (it has the platform- * settings for the target plat instead). */-/* #include "../includes/ghcautoconf.h" DAP Modified */--#define GLOBAL_VAR(name,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.global (value);--#define GLOBAL_VAR_M(name,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.globalM (value);---#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.sharedGlobal (value) (accessor); \-foreign import ccall unsafe saccessor \- accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));--#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \-{-# NOINLINE name #-}; \-name :: IORef (ty); \-name = Util.sharedGlobalM (value) (accessor); \-foreign import ccall unsafe saccessor \- accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));---#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else-#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else-#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $---- Examples: Assuming flagSet :: String -> m Bool------ do { c <- getChar; MASSERT( isUpper c ); ... }--- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }--- do { str <- getStr; ASSERTM( flagSet str ); .. }--- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. }--- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. }-#define MASSERT(e) ASSERT(e) return ()-#define MASSERT2(e,msg) ASSERT2(e,msg) return ()-#define ASSERTM(e) do { bool <- e; MASSERT(bool) }-#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }-#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () }
− src-c-8.4/PosixSource.h
@@ -1,51 +0,0 @@-/* ------------------------------------------------------------------------------ *- * (c) The GHC Team, 1998-2005- *- * Include this file into sources which should not need any non-Posix services.- * That includes most RTS C sources.- * ---------------------------------------------------------------------------*/--#pragma once--#include <ghcplatform.h>--/* We aim for C99 so we need to define following two defines in a consistent way- with what POSIX/XOPEN provide for C99. Some OSes are particularly picky about- the right versions defined here, e.g. Solaris- We also settle on lowest version of POSIX/XOPEN needed for proper C99 support- here which is POSIX.1-2001 compilation and Open Group Technical Standard,- Issue 6 (XPG6). XPG6 itself is a result of the merge of X/Open and POSIX- specification. It is also referred as IEEE Std. 1003.1-2001 or ISO/IEC- 9945:2002 or UNIX 03 and SUSv3.- Please also see trac ticket #11757 for more information about switch- to C99/C11.-- However, the use of `strnlen`, which is strictly speaking only available in- IEEE Std 1003.1-2008 (XPG7), requires lifting the bounds, to be able to- compile ghc on systems that are strict about enforcing the standard, e.g.- Apples mobile platforms.-- Oracle's Solaris 11 supports only up to XPG6, hence the ifdef.- */--#if defined(solaris2_HOST_OS)-#define _POSIX_C_SOURCE 200112L-#define _XOPEN_SOURCE 600-#else-#define _POSIX_C_SOURCE 200809L-#define _XOPEN_SOURCE 700-#endif--#if defined(mingw32_HOST_OS)-/* Without this gcc will warn about %ull and the like since some msvcrt versions- do not support them. See- https://sourceforge.net/p/mingw-w64/mailman/message/28557333/-- Note that this is implied by _POSIX_C_SOURCE in the msys2 toolchain that we- now use. However, we retain this explicit #define to preserve the ability to- bootstrap GHC with compilers still using msys (e.g. GHC 7.10.1 and 7.10.2).- This can be removed in for GHC 8.4. See #12951.- */-#define __USE_MINGW_ANSI_STDIO 1-#endif
− src-c-8.4/hschooks.c
@@ -1,74 +0,0 @@-/*-These routines customise the error messages-for various bits of the RTS. They are linked-in instead of the defaults.-*/--#include "PosixSource.h" /* DAP modified */--/*- * This should be linked against Rts.h from the compiler which is compiling us.- * For instance, if we are compiling this file to produce the stage1 compiler,- * we should use Rts.h from stage0.- */-#include "Rts.h"--#include "HsFFI.h"--#include <string.h>-#include <stdbool.h>--#if defined(HAVE_UNISTD_H)-#include <unistd.h>-#endif--void-initGCStatistics(void)-{- /* Workaround for #8754: if the GC stats aren't enabled because the- compiler couldn't use -Bsymbolic to link the default hooks, then- initialize them sensibly. See Note [-Bsymbolic and hooks] in- Main.hs. */- if (RtsFlags.GcFlags.giveStats == NO_GC_STATS) {- RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS;- }-}--void-defaultsHook (void)-{- // This helps particularly with large compiles, but didn't work- // very well with earlier GHCs because it caused large amounts of- // fragmentation. See rts/sm/BlockAlloc.c:allocLargeChunk().- RtsFlags.GcFlags.heapSizeSuggestionAuto = true;-- RtsFlags.GcFlags.maxStkSize = 512*1024*1024 / sizeof(W_);-- initGCStatistics();-- // See #3408: the default idle GC time of 0.3s is too short on- // Windows where we receive console events once per second or so.- RtsFlags.GcFlags.idleGCDelayTime = SecondsToTime(5);-}--void-StackOverflowHook (StgWord stack_size) /* in bytes */-{- fprintf(stderr,- "GHC stack-space overflow: current limit is %zu bytes.\n"- "Use the `-K<size>' option to increase it.\n",- (size_t) stack_size);-}--/* DAP modified -int main (int argc, char *argv[])-{- RtsConfig conf = defaultRtsConfig;- conf.defaultsHook = defaultsHook;- conf.rts_opts_enabled = RtsOptsAll;- conf.stackOverflowHook = StackOverflowHook;- extern StgClosure ZCMain_main_closure;-- hs_main(argc, argv, &ZCMain_main_closure, conf);-}-*/