ghci-haskeline 0.1.1 → 0.2
raw patch · 7 files changed
+4267/−606 lines, 7 filesdep ~arraydep ~basedep ~ghc
Dependency ranges changed: array, base, ghc, mtl
Files
- GhciHaskeline/Main.hs +608/−0
- GhciHaskeline612/GhciMonad.hs +370/−0
- GhciHaskeline612/GhciTags.hs +202/−0
- GhciHaskeline612/InteractiveUI.hs +2282/−0
- GhciHaskeline612/Main.hs +766/−0
- Main.hs +6/−604
- ghci-haskeline.cabal +33/−2
+ GhciHaskeline/Main.hs view
@@ -0,0 +1,608 @@+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module GhciHaskeline.Main (main) where++-- The official GHC API+import qualified GHC+import GHC ( DynFlags(..), HscTarget(..),+ GhcMode(..), GhcLink(..),+ LoadHowMuch(..), dopt, DynFlag(..) )+import CmdLineParser++-- Implementations of the various modes (--show-iface, mkdependHS. etc.)+import LoadIface ( showIface )+import HscMain ( newHscEnv )+import DriverPipeline ( oneShot, compileFile )+import DriverMkDepend ( doMkDependHS )+#ifdef GHCI+import GhciHaskeline.InteractiveUI ( interactiveUI, ghciWelcomeMsg )+#endif++-- Various other random stuff that we need+import Config+import HscTypes+import Packages ( dumpPackages )+import DriverPhases ( Phase(..), isSourceFilename, anyHsc,+ startPhase, isHaskellSrcFilename )+import BasicTypes ( failed )+import StaticFlags+import StaticFlagParser+import DynFlags+import ErrUtils+import FastString+import Outputable+import SrcLoc+import Util+import Panic+import MonadUtils ( liftIO )++-- Standard Haskell libraries+import System.IO+import System.Environment+import System.Exit+import System.FilePath+import Control.Monad+import Data.List+import Data.Maybe++import GHC.Paths++-----------------------------------------------------------------------------+-- ToDo:++-- time commands when run with -v+-- user ways+-- Win32 support: proper signal handling+-- reading the package configuration file is too slow+-- -K<size>++-----------------------------------------------------------------------------+-- GHC's command-line interface++main :: IO ()+main =+ + GHC.defaultErrorHandler defaultDynFlags $ do+ -- 1. extract the -B flag from the args+ argv0 <- getArgs++ let+ (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0+ mbMinusB | null minusB_args = Just libdir+ | otherwise = Just (drop 2 (last minusB_args))++ let argv1' = map (mkGeneralLocated "on the commandline") ("--interactive" : argv1)+ (argv2, staticFlagWarnings) <- parseStaticFlags argv1'++ -- 2. Parse the "mode" flags (--make, --interactive etc.)+ (m_uber_mode, cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2++ -- If all we want to do is to show the version number then do it+ -- now, before we start a GHC session etc.+ -- If we do it later then bootstrapping gets confused as it tries+ -- to find out what version of GHC it's using before package.conf+ -- exists, so starting the session fails.+ case m_uber_mode of+ -- ShowUsage currently has to be handled specially, as it needs to+ -- actually start up GHC so that it can find the usage.txt files+ -- in the libdir. It would be nice to embed the text in the+ -- executable so that we don't have to do that, and things are more+ -- uniform here.+ Just ShowUsage -> return ()+ Just um ->+ do case um of+ ShowInfo -> showInfo+ ShowSupportedLanguages -> showSupportedLanguages+ ShowVersion -> showVersion+ ShowNumVersion -> putStrLn cProjectVersion+ exitWith ExitSuccess+ Nothing -> return ()++ -- start our GHC session+ GHC.runGhc mbMinusB $ do++ dflags0 <- GHC.getSessionDynFlags++ -- set the default GhcMode, HscTarget and GhcLink. The HscTarget+ -- can be further adjusted on a module by module basis, using only+ -- the -fvia-C and -fasm flags. If the default HscTarget is not+ -- HscC or HscAsm, -fvia-C and -fasm have no effect.+ let dflt_target = hscTarget dflags0+ (mode, lang, link)+ = case cli_mode of+ DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)+ DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)+ DoMake -> (CompManager, dflt_target, LinkBinary)+ DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)+ _ -> (OneShot, dflt_target, LinkBinary)++ let dflags1 = dflags0{ ghcMode = mode,+ hscTarget = lang,+ ghcLink = link,+ -- leave out hscOutName for now+ hscOutName = panic "Main.main:hscOutName not set",+ verbosity = case cli_mode of+ DoEval _ -> 0+ _other -> 1+ }++ -- turn on -fimplicit-import-qualified for GHCi now, so that it+ -- can be overriden from the command-line+ dflags1a | DoInteractive <- cli_mode = imp_qual_enabled+ | DoEval _ <- cli_mode = imp_qual_enabled+ | otherwise = dflags1+ where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified++ -- The rest of the arguments are "dynamic"+ -- Leftover ones are presumably files+ (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a argv3++ -- As noted earlier, currently we hvae to handle ShowUsage down here+ case m_uber_mode of+ Just ShowUsage -> liftIO $ showGhcUsage dflags2 cli_mode+ _ -> return ()++ let flagWarnings = staticFlagWarnings+ ++ modeFlagWarnings+ ++ dynamicFlagWarnings+ liftIO $ handleFlagWarnings dflags2 flagWarnings++ -- make sure we clean up after ourselves+ GHC.defaultCleanupHandler dflags2 $ do++ liftIO $ showBanner cli_mode dflags2++ -- we've finished manipulating the DynFlags, update the session+ GHC.setSessionDynFlags dflags2+ dflags3 <- GHC.getSessionDynFlags+ hsc_env <- GHC.getSession++ let+ -- To simplify the handling of filepaths, we normalise all filepaths right + -- away - e.g., for win32 platforms, backslashes are converted+ -- into forward slashes.+ normal_fileish_paths = map (normalise . unLoc) fileish_args+ (srcs, objs) = partition_args normal_fileish_paths [] []++ -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on + -- the command-line.+ liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs)++ ---------------- Display configuration -----------+ when (verbosity dflags3 >= 4) $+ liftIO $ dumpPackages dflags3++ when (verbosity dflags3 >= 3) $ do+ liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)++ ---------------- Final sanity checking -----------+ liftIO $ checkOptions cli_mode dflags3 srcs objs++ ---------------- Do the business -----------+ handleSourceError (\e -> do+ GHC.printExceptionAndWarnings e+ liftIO $ exitWith (ExitFailure 1)) $ do+ case cli_mode of+ PrintLibdir -> liftIO $ putStrLn (topDir dflags3)+ ShowInterface f -> liftIO $ doShowIface dflags3 f+ DoMake -> doMake srcs+ DoMkDependHS -> doMkDependHS (map fst srcs)+ StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings+ DoInteractive -> interactiveUI srcs Nothing+ DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs++ liftIO $ dumpFinalStats dflags3+ liftIO $ exitWith ExitSuccess++#ifndef GHCI+interactiveUI :: b -> c -> Ghc ()+interactiveUI _ _ =+ ghcError (CmdLineError "not built for interactive use")+#endif++-- -----------------------------------------------------------------------------+-- Splitting arguments into source files and object files. This is where we+-- interpret the -x <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 v_Ld_inputs for use by the linker.++ The following things should be considered compilation manager inputs:++ - haskell source files (strings ending in .hs, .lhs or other + haskellish extension),++ - module names (not forgetting hierarchical module names),++ - and finally we consider everything not containing a '.' to be+ a comp manager input, as shorthand for a .hs or .lhs filename.++ Everything else is considered to be a linker object, and passed+ straight through to the linker.+ -}+looks_like_an_input :: String -> Bool+looks_like_an_input m = isSourceFilename m + || looksLikeModuleName m+ || '.' `notElem` m++-- -----------------------------------------------------------------------------+-- Option sanity checks++-- | Ensure sanity of options.+--+-- Throws 'UsageError' or 'CmdLineError' if not.+checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()+ -- Final sanity checking before kicking off a compilation (pipeline).+checkOptions cli_mode dflags srcs objs = do+ -- Complain about any unknown flags+ let unknown_opts = [ f | (f@('-':_), _) <- srcs ]+ when (notNull unknown_opts) (unknownFlagsErr unknown_opts)++ when (notNull (filter isRTSWay (wayNames dflags))+ && isInterpretiveMode cli_mode) $+ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")++ -- -prof and --interactive are not a good combination+ when (notNull (filter (not . isRTSWay) (wayNames dflags))+ && isInterpretiveMode cli_mode) $+ do ghcError (UsageError + "--interactive can't be used with -prof or -unreg.")+ -- -ohi sanity check+ if (isJust (outputHi dflags) && + (isCompManagerMode cli_mode || srcs `lengthExceeds` 1))+ then ghcError (UsageError "-ohi can only be used when compiling a single source file")+ else do++ -- -o sanity checking+ if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)+ && not (isLinkMode cli_mode))+ then ghcError (UsageError "can't apply -o to multiple source files")+ else do++ let not_linking = not (isLinkMode cli_mode) || isNoLink (ghcLink dflags)++ when (not_linking && not (null objs)) $+ hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)++ -- Check that there are some input files+ -- (except in the interactive case)+ if null srcs && (null objs || not_linking) && needsInputsMode cli_mode+ then ghcError (UsageError "no input files")+ else do++ -- Verify that output files point somewhere sensible.+ verifyOutputFiles dflags+++-- Compiler output options++-- called to verify that the output files & directories+-- point somewhere valid. +--+-- The assumption is that the directory portion of these output+-- options will have to exist by the time 'verifyOutputFiles'+-- is invoked.+-- +verifyOutputFiles :: DynFlags -> IO ()+verifyOutputFiles dflags = do+ -- not -odir: we create the directory for -odir if it doesn't exist (#2278).+ let ofile = outputFile dflags+ when (isJust ofile) $ do+ let fn = fromJust ofile+ flg <- doesDirNameExist fn+ when (not flg) (nonExistentDir "-o" fn)+ let ohi = outputHi dflags+ when (isJust ohi) $ do+ let hi = fromJust ohi+ flg <- doesDirNameExist hi+ when (not flg) (nonExistentDir "-ohi" hi)+ where+ nonExistentDir flg dir = + ghcError (CmdLineError ("error: directory portion of " ++ + show dir ++ " does not exist (used with " ++ + show flg ++ " option.)"))++-----------------------------------------------------------------------------+-- GHC modes of operation++data UberMode+ = ShowUsage -- ghc -?+ | ShowVersion -- ghc -V/--version+ | ShowNumVersion -- ghc --numeric-version+ | ShowSupportedLanguages -- ghc --supported-languages+ | ShowInfo -- ghc --info+ deriving (Show)++data CmdLineMode+ = PrintLibdir -- ghc --print-libdir+ | ShowInterface String -- ghc --show-iface+ | DoMkDependHS -- ghc -M+ | StopBefore Phase -- ghc -E | -C | -S+ -- StopBefore StopLn is the default+ | DoMake -- ghc --make+ | DoInteractive -- ghc --interactive+ | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]+ deriving (Show)++#ifdef GHCI+isInteractiveMode :: CmdLineMode -> Bool+isInteractiveMode DoInteractive = True+isInteractiveMode _ = False+#endif++-- isInterpretiveMode: byte-code compiler involved+isInterpretiveMode :: CmdLineMode -> Bool+isInterpretiveMode DoInteractive = True+isInterpretiveMode (DoEval _) = True+isInterpretiveMode _ = False++needsInputsMode :: CmdLineMode -> Bool+needsInputsMode DoMkDependHS = True+needsInputsMode (StopBefore _) = True+needsInputsMode DoMake = True+needsInputsMode _ = False++-- True if we are going to attempt to link in this mode.+-- (we might not actually link, depending on the GhcLink flag)+isLinkMode :: CmdLineMode -> Bool+isLinkMode (StopBefore StopLn) = True+isLinkMode DoMake = True+isLinkMode DoInteractive = True+isLinkMode (DoEval _) = True+isLinkMode _ = False++isCompManagerMode :: CmdLineMode -> Bool+isCompManagerMode DoMake = True+isCompManagerMode DoInteractive = True+isCompManagerMode (DoEval _) = True+isCompManagerMode _ = False+++-- -----------------------------------------------------------------------------+-- Parsing the mode flag++parseModeFlags :: [Located String]+ -> IO (Maybe UberMode,+ CmdLineMode,+ [Located String],+ [Located String])+parseModeFlags args = do+ let ((leftover, errs, warns), (mUberMode, mode, _, flags')) =+ runCmdLine (processArgs mode_flags args)+ (Nothing, StopBefore StopLn, "", [])+ when (not (null errs)) $ ghcError $ errorsToGhcException errs+ return (mUberMode, mode, flags' ++ leftover, warns)++type ModeM = CmdLineP (Maybe UberMode, CmdLineMode, String, [Located String])+ -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)+ -- so we collect the new ones and return them.++mode_flags :: [Flag ModeM]+mode_flags =+ [ ------- help / version ----------------------------------------------+ Flag "?" (NoArg (setUberMode ShowUsage))+ Supported+ , Flag "-help" (NoArg (setUberMode ShowUsage))+ Supported+ , Flag "V" (NoArg (setUberMode ShowVersion))+ Supported+ , Flag "-version" (NoArg (setUberMode ShowVersion))+ Supported+ , Flag "-numeric-version" (NoArg (setUberMode ShowNumVersion))+ Supported+ , Flag "-info" (NoArg (setUberMode ShowInfo))+ Supported+ , Flag "-supported-languages" (NoArg (setUberMode ShowSupportedLanguages))+ Supported+ , Flag "-print-libdir" (PassFlag (setMode PrintLibdir))+ Supported++ ------- interfaces ----------------------------------------------------+ , Flag "-show-iface" (HasArg (\f -> setMode (ShowInterface f)+ "--show-iface"))+ Supported++ ------- primary modes ------------------------------------------------+ , Flag "M" (PassFlag (setMode DoMkDependHS))+ Supported+ , Flag "E" (PassFlag (setMode (StopBefore anyHsc)))+ Supported+ , Flag "C" (PassFlag (\f -> do setMode (StopBefore HCc) f+ addFlag "-fvia-C"))+ Supported+ , Flag "S" (PassFlag (setMode (StopBefore As)))+ Supported+ , Flag "-make" (PassFlag (setMode DoMake))+ Supported+ , Flag "-interactive" (PassFlag (setMode DoInteractive))+ Supported+ , Flag "e" (HasArg (\s -> updateMode (updateDoEval s) "-e"))+ Supported++ -- -fno-code says to stop after Hsc but don't generate any code.+ , Flag "fno-code" (PassFlag (\f -> do setMode (StopBefore HCc) f+ addFlag "-fno-code"+ addFlag "-fforce-recomp"))+ Supported+ ]++setUberMode :: UberMode -> ModeM ()+setUberMode m = do+ (_, cmdLineMode, flag, flags') <- getCmdLineState+ putCmdLineState (Just m, cmdLineMode, flag, flags')++setMode :: CmdLineMode -> String -> ModeM ()+setMode m flag = updateMode (\_ -> m) flag++updateDoEval :: String -> CmdLineMode -> CmdLineMode+updateDoEval expr (DoEval exprs) = DoEval (expr : exprs)+updateDoEval expr _ = DoEval [expr]++updateMode :: (CmdLineMode -> CmdLineMode) -> String -> ModeM ()+updateMode f flag = do+ (m_uber_mode, old_mode, old_flag, flags') <- getCmdLineState+ if null old_flag || flag == old_flag+ then putCmdLineState (m_uber_mode, f old_mode, flag, flags')+ else ghcError (UsageError+ ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))++addFlag :: String -> ModeM ()+addFlag s = do+ (u, m, f, flags') <- getCmdLineState+ -- XXX Can we get a useful Loc?+ putCmdLineState (u, m, f, mkGeneralLocated "addFlag" s : flags')+++-- ----------------------------------------------------------------------------+-- Run --make mode++doMake :: [(String,Maybe Phase)] -> Ghc ()+doMake [] = ghcError (UsageError "no input files")+doMake srcs = do+ let (hs_srcs, non_hs_srcs) = partition haskellish srcs++ haskellish (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f+ haskellish (_,Just phase) = + phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]++ hsc_env <- GHC.getSession+ o_files <- mapM (\x -> do+ f <- compileFile hsc_env StopLn x+ GHC.printWarnings+ return f)+ non_hs_srcs+ liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)++ targets <- mapM (uncurry GHC.guessTarget) hs_srcs+ GHC.setTargets targets+ ok_flag <- GHC.load LoadAllTargets++ when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))+ return ()+++-- ---------------------------------------------------------------------------+-- --show-iface mode++doShowIface :: DynFlags -> FilePath -> IO ()+doShowIface dflags file = do+ hsc_env <- newHscEnv dflags+ showIface hsc_env file++-- ---------------------------------------------------------------------------+-- Various banners and verbosity output.++showBanner :: CmdLineMode -> DynFlags -> IO ()+showBanner _cli_mode dflags = do+ let verb = verbosity dflags++#ifdef GHCI+ -- Show the GHCi banner+ when (isInteractiveMode _cli_mode && verb >= 1) $ putStrLn ghciWelcomeMsg+#endif++ -- Display details of the configuration in verbose mode+ when (verb >= 2) $+ do hPutStr stderr "Glasgow Haskell Compiler, Version "+ hPutStr stderr cProjectVersion+ hPutStr stderr ", for Haskell 98, stage "+ hPutStr stderr cStage+ hPutStr stderr " booted by GHC version "+ hPutStrLn stderr cBooterVersion++-- We print out a Read-friendly string, but a prettier one than the+-- Show instance gives us+showInfo :: IO ()+showInfo = do+ let sq x = " [" ++ x ++ "\n ]"+ putStrLn $ sq $ concat $ intersperse "\n ," $ map show compilerInfo+ exitWith ExitSuccess++showSupportedLanguages :: IO ()+showSupportedLanguages = do mapM_ putStrLn supportedLanguages+ exitWith ExitSuccess++showVersion :: IO ()+showVersion = do+ putStrLn (cProjectName ++ ", version " ++ cProjectVersion)+ exitWith ExitSuccess++showGhcUsage :: DynFlags -> CmdLineMode -> IO ()+showGhcUsage dflags cli_mode = do + let usage_path + | DoInteractive <- cli_mode = ghciUsagePath dflags+ | otherwise = ghcUsagePath dflags+ usage <- readFile usage_path+ dump usage+ exitWith ExitSuccess+ where+ dump "" = return ()+ dump ('$':'$':s) = putStr progName >> dump s+ dump (c:s) = putChar c >> dump s++dumpFinalStats :: DynFlags -> IO ()+dumpFinalStats dflags = + when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags++dumpFastStringStats :: DynFlags -> IO ()+dumpFastStringStats dflags = do+ buckets <- getFastStringTable+ let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets+ msg = text "FastString stats:" $$+ nest 4 (vcat [text "size: " <+> int (length buckets),+ text "entries: " <+> int entries,+ text "longest chain: " <+> int longest,+ text "z-encoded: " <+> (is_z `pcntOf` entries),+ text "has z-encoding: " <+> (has_z `pcntOf` entries)+ ])+ -- we usually get more "has z-encoding" than "z-encoded", because+ -- when we z-encode a string it might hash to the exact same string,+ -- which will is not counted as "z-encoded". Only strings whose+ -- Z-encoding is different from the original string are counted in+ -- the "z-encoded" total.+ putMsg dflags msg+ where+ x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'++countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int)+countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)+countFS entries longest is_z has_z (b:bs) = + let+ len = length b+ longest' = max len longest+ entries' = entries + len+ is_zs = length (filter isZEncoded b)+ has_zs = length (filter hasZEncoding b)+ in+ countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs++-- -----------------------------------------------------------------------------+-- Util++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))
+ GhciHaskeline612/GhciMonad.hs view
@@ -0,0 +1,370 @@+{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- Monadery code used in InteractiveUI+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module GhciHaskeline612.GhciMonad where++import qualified GHC+import Outputable hiding (printForUser, printForUserPartWay)+import qualified Outputable+import Panic hiding (showException)+import Util+import DynFlags+import HscTypes hiding (liftIO)+import SrcLoc+import Module+import ObjLink+import Linker+import StaticFlags+import qualified MonadUtils++import Exception+-- import Data.Maybe+import Numeric+import Data.Array+-- import Data.Char+import Data.Int ( Int64 )+import Data.IORef+-- import Data.List+import System.CPUTime+import System.Environment+import System.IO+import Control.Monad as Monad+import GHC.Exts++import System.Console.Haskeline (CompletionFunc, InputT)+import qualified System.Console.Haskeline as Haskeline+import Control.Monad.Trans as Trans++-- copied from HsVersions.h++#define GLOBAL_VAR(name,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = Util.global (value);+++-----------------------------------------------------------------------------+-- GHCi monad++type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi)++data GHCiState = GHCiState+ { + progname :: String,+ args :: [String],+ prompt :: String,+ editor :: String,+ stop :: String,+ options :: [GHCiOption],+ prelude :: GHC.Module,+ break_ctr :: !Int,+ breaks :: ![(Int, BreakLocation)],+ tickarrays :: ModuleEnv TickArray,+ -- tickarrays caches the TickArray for loaded modules,+ -- so that we don't rebuild it each time the user sets+ -- a breakpoint.+ -- ":" at the GHCi prompt repeats the last command, so we+ -- remember is here:+ last_command :: Maybe Command,+ cmdqueue :: [String],+ remembered_ctx :: [(CtxtCmd, [String], [String])],+ -- we remember the :module commands between :loads, so that+ -- on a :reload we can replay them. See bugs #2049,+ -- \#1873, #1360. Previously we tried to remember modules that+ -- were supposed to be in the context but currently had errors,+ -- but this was complicated. Just replaying the :module commands+ -- seems to be the right thing.+ ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)+ }++data CtxtCmd+ = SetContext+ | AddModules+ | RemModules++type TickArray = Array Int [(BreakIndex,SrcSpan)]++data GHCiOption + = ShowTiming -- show time/allocs after evaluation+ | ShowType -- show the type of expressions+ | RevertCAFs -- revert CAFs after every evaluation+ deriving Eq++data BreakLocation+ = BreakLocation+ { breakModule :: !GHC.Module+ , breakLoc :: !SrcSpan+ , breakTick :: {-# UNPACK #-} !Int+ , onBreakCmd :: String+ } ++instance Eq BreakLocation where+ loc1 == loc2 = breakModule loc1 == breakModule loc2 &&+ breakTick loc1 == breakTick loc2++prettyLocations :: [(Int, BreakLocation)] -> SDoc+prettyLocations [] = text "No active breakpoints." +prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs++instance Outputable BreakLocation where+ ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>+ if null (onBreakCmd loc)+ then empty+ else doubleQuotes (text (onBreakCmd loc))++recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)+recordBreak brkLoc = do+ st <- getGHCiState+ let oldActiveBreaks = breaks st + -- don't store the same break point twice+ case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of+ (nm:_) -> return (True, nm)+ [] -> do+ let oldCounter = break_ctr st+ newCounter = oldCounter + 1+ setGHCiState $ st { break_ctr = newCounter,+ breaks = (oldCounter, brkLoc) : oldActiveBreaks+ }+ return (False, oldCounter)++newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }++reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s++reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a+reifyGHCi f = GHCi f'+ where+ -- f' :: IORef GHCiState -> Ghc a+ f' gs = reifyGhc (f'' gs)+ -- f'' :: IORef GHCiState -> Session -> IO a+ f'' gs s = f (s, gs)++startGHCi :: GHCi a -> GHCiState -> Ghc a+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref++instance Monad GHCi where+ (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s+ return a = GHCi $ \_ -> return a++instance Functor GHCi where+ fmap f m = m >>= return . f++ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a+ghciHandleGhcException = handleGhcException++getGHCiState :: GHCi GHCiState+getGHCiState = GHCi $ \r -> liftIO $ readIORef r+setGHCiState :: GHCiState -> GHCi ()+setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s++liftGhc :: Ghc a -> GHCi a+liftGhc m = GHCi $ \_ -> m++instance MonadUtils.MonadIO GHCi where+ liftIO = liftGhc . MonadUtils.liftIO++instance Trans.MonadIO Ghc where+ liftIO = MonadUtils.liftIO++instance GhcMonad GHCi where+ setSession s' = liftGhc $ setSession s'+ getSession = liftGhc $ getSession++instance GhcMonad (InputT GHCi) where+ setSession = lift . setSession+ getSession = lift getSession++instance MonadUtils.MonadIO (InputT GHCi) where+ liftIO = Trans.liftIO++instance WarnLogMonad (InputT GHCi) where+ setWarnings = lift . setWarnings+ getWarnings = lift getWarnings++instance ExceptionMonad GHCi where+ gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)+ gblock (GHCi m) = GHCi $ \r -> gblock (m r)+ gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)++instance WarnLogMonad GHCi where+ setWarnings warns = liftGhc $ setWarnings warns+ getWarnings = liftGhc $ getWarnings++instance MonadIO GHCi where+ liftIO = io++instance Haskeline.MonadException GHCi where+ catch = gcatch+ block = gblock+ unblock = gunblock++instance ExceptionMonad (InputT GHCi) where+ gcatch = Haskeline.catch+ gblock = Haskeline.block+ gunblock = Haskeline.unblock++-- for convenience...+getPrelude :: GHCi Module+getPrelude = getGHCiState >>= return . prelude++getDynFlags :: GhcMonad m => m DynFlags+getDynFlags = do+ GHC.getSessionDynFlags++setDynFlags :: DynFlags -> GHCi [PackageId]+setDynFlags dflags = do + GHC.setSessionDynFlags dflags++isOptionSet :: GHCiOption -> GHCi Bool+isOptionSet opt+ = do st <- getGHCiState+ return (opt `elem` options st)++setOption :: GHCiOption -> GHCi ()+setOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = opt : filter (/= opt) (options st) })++unsetOption :: GHCiOption -> GHCi ()+unsetOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = filter (/= opt) (options st) })++io :: IO a -> GHCi a+io = MonadUtils.liftIO++printForUser :: GhcMonad m => SDoc -> m ()+printForUser doc = do+ unqual <- GHC.getPrintUnqual+ MonadUtils.liftIO $ Outputable.printForUser stdout unqual doc++printForUserPartWay :: SDoc -> GHCi ()+printForUserPartWay doc = do+ unqual <- GHC.getPrintUnqual+ io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc++runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult+runStmt expr step = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e+ return GHC.RunFailed) $ do+ GHC.runStmt expr step++resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult+resume canLogSpan step = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.resume canLogSpan step++-- --------------------------------------------------------------------------+-- timing & statistics++timeIt :: InputT GHCi a -> InputT GHCi a+timeIt action+ = do b <- lift $ isOptionSet ShowTiming+ if not b + then action + else do allocs1 <- liftIO $ getAllocations+ time1 <- liftIO $ getCPUTime+ a <- action+ allocs2 <- liftIO $ getAllocations+ time2 <- liftIO $ getCPUTime+ liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) + (time2 - time1)+ return a++foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64+ -- defined in ghc/rts/Stats.c++printTimes :: Integer -> Integer -> IO ()+printTimes allocs psecs+ = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float+ secs_str = showFFloat (Just 2) secs+ putStrLn (showSDoc (+ parens (text (secs_str "") <+> text "secs" <> comma <+> + text (show allocs) <+> text "bytes")))++-----------------------------------------------------------------------------+-- reverting CAFs+ +revertCAFs :: GHCi ()+revertCAFs = do+ io $ rts_revertCAFs+ s <- getGHCiState+ when (not (ghc_e s)) $ io turnOffBuffering+ -- Have to turn off buffering again, because we just + -- reverted stdout, stderr & stdin to their defaults.++foreign import ccall "revertCAFs" rts_revertCAFs :: IO () + -- Make it "safe", just in case++-----------------------------------------------------------------------------+-- To flush buffers for the *interpreted* computation we need+-- to refer to *its* stdout/stderr handles++GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())+GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())+GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())++-- After various attempts, I believe this is the least bad way to do+-- what we want. We know look up the address of the static stdin,+-- stdout, and stderr closures in the loaded base package, and each+-- time we need to refer to them we cast the pointer to a Handle.+-- This avoids any problems with the CAF having been reverted, because+-- we'll always get the current value.+--+-- The previous attempt that didn't work was to compile an expression+-- like "hSetBuffering stdout NoBuffering" into an expression of type+-- IO () and run this expression each time we needed it, but the+-- problem is that evaluating the expression might cache the contents+-- of the Handle rather than referring to it from its static address+-- each time. There's no safe workaround for this.++initInterpBuffering :: Ghc ()+initInterpBuffering = do -- make sure these are linked+ dflags <- GHC.getSessionDynFlags+ liftIO $ do+ initDynLinker dflags++ -- ToDo: we should really look up these names properly, but+ -- it's a fiddle and not all the bits are exposed via the GHC+ -- interface.+ mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"+ mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"+ mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"++ let f ref (Just ptr) = writeIORef ref ptr+ f _ Nothing = panic "interactiveUI:setBuffering2"+ zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]+ [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]++flushInterpBuffers :: GHCi ()+flushInterpBuffers+ = io $ do getHandle stdout_ptr >>= hFlush+ getHandle stderr_ptr >>= hFlush++turnOffBuffering :: IO ()+turnOffBuffering+ = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]+ mapM_ (\h -> hSetBuffering h NoBuffering) hdls++getHandle :: IORef (Ptr ()) -> IO Handle+getHandle ref = do+ (Ptr addr) <- readIORef ref+ case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)
+ GhciHaskeline612/GhciTags.hs view
@@ -0,0 +1,202 @@+-----------------------------------------------------------------------------+--+-- GHCi's :ctags and :etags commands+--+-- (c) The GHC Team 2005-2007+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+module GhciHaskeline612.GhciTags (+ createCTagsWithLineNumbersCmd,+ createCTagsWithRegExesCmd,+ createETagsFileCmd+) where++import GHC+import GhciHaskeline612.GhciMonad+import Outputable+import Util++-- ToDo: figure out whether we need these, and put something appropriate+-- into the GHC API instead+import Name (nameOccName)+import OccName (pprOccName)+import MonadUtils++import Data.Maybe+import Panic+import Data.List+import Control.Monad+import System.IO+import System.IO.Error as IO++-----------------------------------------------------------------------------+-- create tags file for currently loaded modules.++createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,+ createETagsFileCmd :: String -> GHCi ()++createCTagsWithLineNumbersCmd "" =+ ghciCreateTagsFile CTagsWithLineNumbers "tags"+createCTagsWithLineNumbersCmd file =+ ghciCreateTagsFile CTagsWithLineNumbers file++createCTagsWithRegExesCmd "" =+ ghciCreateTagsFile CTagsWithRegExes "tags"+createCTagsWithRegExesCmd file =+ ghciCreateTagsFile CTagsWithRegExes file++createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"+createETagsFileCmd file = ghciCreateTagsFile ETags file++data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes++ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()+ghciCreateTagsFile kind file = do+ createTagsFile kind file++-- ToDo: +-- - remove restriction that all modules must be interpreted+-- (problem: we don't know source locations for entities unless+-- we compiled the module.+--+-- - extract createTagsFile so it can be used from the command-line+-- (probably need to fix first problem before this is useful).+--+createTagsFile :: TagsKind -> FilePath -> GHCi ()+createTagsFile tagskind tagsFile = do+ graph <- GHC.getModuleGraph+ mtags <- mapM listModuleTags (map GHC.ms_mod graph)+ either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags+ case either_res of+ Left e -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e+ Right _ -> return ()+++listModuleTags :: GHC.Module -> GHCi [TagInfo]+listModuleTags m = do+ is_interpreted <- GHC.moduleIsInterpreted m+ -- should we just skip these?+ when (not is_interpreted) $+ let mName = GHC.moduleNameString (GHC.moduleName m) in+ ghcError (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))+ mbModInfo <- GHC.getModuleInfo m+ case mbModInfo of+ Nothing -> return []+ Just mInfo -> do+ mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo+ let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual+ let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo+ let localNames = filter ((m==) . nameModule) names+ mbTyThings <- mapM GHC.lookupName localNames+ return $! [ tagInfo unqual exported kind name loc+ | tyThing <- catMaybes mbTyThings+ , let name = getName tyThing+ , let exported = GHC.modInfoIsExportedName mInfo name+ , let kind = tyThing2TagKind tyThing+ , let loc = srcSpanStart (nameSrcSpan name)+ , isGoodSrcLoc loc+ ]++ where+ tyThing2TagKind (AnId _) = 'v'+ tyThing2TagKind (ADataCon _) = 'd'+ tyThing2TagKind (ATyCon _) = 't'+ tyThing2TagKind (AClass _) = 'c'+++data TagInfo = TagInfo+ { tagExported :: Bool -- is tag exported+ , tagKind :: Char -- tag kind+ , tagName :: String -- tag name+ , tagFile :: String -- file name+ , tagLine :: Int -- line number+ , tagCol :: Int -- column number+ , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset+ }+++-- get tag info, for later translation into Vim or Emacs style+tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> SrcLoc -> TagInfo+tagInfo unqual exported kind name loc+ = TagInfo exported kind+ (showSDocForUser unqual $ pprOccName (nameOccName name))+ (showSDocForUser unqual $ ftext (srcLocFile loc))+ (srcLocLine loc) (srcLocCol loc) Nothing+++collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())+-- ctags style with the Ex exresion being just the line number, Vim et al+collateAndWriteTags CTagsWithLineNumbers file tagInfos = do+ let tags = unlines $ sortLe (<=) $ map showCTag tagInfos+ IO.try (writeFile file tags)++-- ctags style with the Ex exresion being a regex searching the line, Vim et al+collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al+ tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos+ let tags = unlines $ sortLe (<=) $ map showCTag $concat tagInfoGroups+ IO.try (writeFile file tags)++collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs+ tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos+ let tagGroups = map processGroup tagInfoGroups+ IO.try (writeFile file $ concat tagGroups)++ where+ processGroup [] = ghcError (CmdLineError "empty tag file group??")+ processGroup group@(tagInfo:_) =+ let tags = unlines $ map showETag group in+ "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags+++makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]+makeTagGroupsWithSrcInfo tagInfos = do+ let byFile op ti0 ti1 = tagFile ti0 `op` tagFile ti1+ groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos+ mapM addTagSrcInfo groups++ where+ addTagSrcInfo [] = ghcError (CmdLineError "empty tag file group??")+ addTagSrcInfo group@(tagInfo:_) = do+ file <- readFile $tagFile tagInfo+ let byLine ti0 ti1 = tagLine ti0 <= tagLine ti1+ sortedGroup = sortLe byLine group+ return $ perFile sortedGroup 1 0 $ lines file++ perFile allTags@(tag:tags) cnt pos allLs@(l:ls)+ | tagLine tag > cnt =+ perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls+ | tagLine tag == cnt =+ tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs+ perFile _ _ _ _ = []+++-- ctags format, for Vim et al+showCTag :: TagInfo -> String+showCTag ti =+ tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" +++ tagKind ti : ( if tagExported ti then "" else "\tfile:" )++ where+ tagCmd =+ case tagSrcInfo ti of+ Nothing -> show $tagLine ti+ Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"++ where+ escapeSlashes '/' r = '\\' : '/' : r+ escapeSlashes '\\' r = '\\' : '\\' : r+ escapeSlashes c r = c : r+++-- etags format, for Emacs/XEmacs+showETag :: TagInfo -> String+showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,+ tagSrcInfo = Just (srcLine,charPos) }+ = take colNo srcLine ++ tag+ ++ "\x7f" ++ tag+ ++ "\x01" ++ show lineNo+ ++ "," ++ show charPos+showETag _ = ghcError (CmdLineError "missing source file info in showETag")+
+ GhciHaskeline612/InteractiveUI.hs view
@@ -0,0 +1,2282 @@+{-# OPTIONS -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+-----------------------------------------------------------------------------+--+-- GHC Interactive User Interface+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module GhciHaskeline612.InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where++import qualified GhciHaskeline612.GhciMonad as GhciMonad+import GhciHaskeline612.GhciMonad hiding (runStmt)+import GhciHaskeline612.GhciTags+import Debugger++-- The GHC interface+import qualified GHC hiding (resume, runStmt)+import GHC ( LoadHowMuch(..), Target(..), TargetId(..),+ TyThing(..), Phase,+ BreakIndex, Resume, SingleStep,+ Ghc, handleSourceError )+import PprTyThing+import DynFlags++import Packages+-- import PackageConfig+import UniqFM++import HscTypes ( implicitTyThings, handleFlagWarnings )+import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?+import Outputable hiding (printForUser, printForUserPartWay)+import Module -- for ModuleEnv+import Name+import SrcLoc++-- Other random utilities+import CmdLineParser+import Digraph+import BasicTypes hiding (isTopLevel)+import Panic hiding (showException)+import Config+import StaticFlags+import Linker+import Util+import NameSet+import Maybes ( orElse, expectJust )+import FastString+import Encoding+import Foreign.C++#ifndef mingw32_HOST_OS+import System.Posix hiding (getEnv)+#else+import qualified System.Win32+#endif++import System.Console.Haskeline as Haskeline+import qualified System.Console.Haskeline.Encoding as Encoding+import Control.Monad.Trans++--import SystemExts++import Exception hiding (catch, block, unblock)++-- import Control.Concurrent++import System.FilePath+import qualified Data.ByteString.Char8 as BS+import Data.List+import Data.Maybe+import System.Cmd+import System.Environment+import System.Exit ( exitWith, ExitCode(..) )+import System.Directory+import System.IO+import System.IO.Error as IO+import Data.Char+import Data.Array+import Control.Monad as Monad+import Text.Printf+import Foreign+import GHC.Exts ( unsafeCoerce# )++#if __GLASGOW_HASKELL__ >= 611+import GHC.IO.Exception ( IOErrorType(InvalidArgument) )+import GHC.IO.Handle ( hFlushAll )+#else+import GHC.IOBase ( IOErrorType(InvalidArgument) )+#endif++import GHC.TopHandler++import Data.IORef ( IORef, readIORef, writeIORef )++-- Copied from HsVersions.h+#define ASSERT(e) if False && (not (e)) then panic "ASSERT" else+#define GLOBAL_VAR(name,value,ty) \+{-# NOINLINE name #-}; \+name :: IORef (ty); \+name = Util.global (value);+++-----------------------------------------------------------------------------++ghciWelcomeMsg :: String+ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion +++ ": http://www.haskell.org/ghc/ :? for help"++cmdName :: Command -> String+cmdName (n,_,_) = n++GLOBAL_VAR(macros_ref, [], [Command])++builtin_commands :: [Command]+builtin_commands = [+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap+ ("?", keepGoing help, noCompletion),+ ("add", keepGoingPaths addModule, completeFilename),+ ("abandon", keepGoing abandonCmd, noCompletion),+ ("break", keepGoing breakCmd, completeIdentifier),+ ("back", keepGoing backCmd, noCompletion),+ ("browse", keepGoing' (browseCmd False), completeModule),+ ("browse!", keepGoing' (browseCmd True), completeModule),+ ("cd", keepGoing' changeDirectory, completeFilename),+ ("check", keepGoing' checkModule, completeHomeModule),+ ("continue", keepGoing continueCmd, noCompletion),+ ("cmd", keepGoing cmdCmd, completeExpression),+ ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),+ ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),+ ("def", keepGoing (defineMacro False), completeExpression),+ ("def!", keepGoing (defineMacro True), completeExpression),+ ("delete", keepGoing deleteCmd, noCompletion),+ ("edit", keepGoing editFile, completeFilename),+ ("etags", keepGoing createETagsFileCmd, completeFilename),+ ("force", keepGoing forceCmd, completeExpression),+ ("forward", keepGoing forwardCmd, noCompletion),+ ("help", keepGoing help, noCompletion),+ ("history", keepGoing historyCmd, noCompletion),+ ("info", keepGoing' info, completeIdentifier),+ ("kind", keepGoing' kindOfType, completeIdentifier),+ ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),+ ("list", keepGoing' listCmd, noCompletion),+ ("module", keepGoing setContext, completeModule),+ ("main", keepGoing runMain, completeFilename),+ ("print", keepGoing printCmd, completeExpression),+ ("quit", quit, noCompletion),+ ("reload", keepGoing' reloadModule, noCompletion),+ ("run", keepGoing runRun, completeFilename),+ ("set", keepGoing setCmd, completeSetOptions),+ ("show", keepGoing showCmd, completeShowOptions),+ ("sprint", keepGoing sprintCmd, completeExpression),+ ("step", keepGoing stepCmd, completeIdentifier),+ ("steplocal", keepGoing stepLocalCmd, completeIdentifier),+ ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),+ ("type", keepGoing' typeOfExpr, completeExpression),+ ("trace", keepGoing traceCmd, completeExpression),+ ("undef", keepGoing undefineMacro, completeMacro),+ ("unset", keepGoing unsetOptions, completeSetOptions)+ ]+++-- We initialize readline (in the interactiveUI function) to use +-- word_break_chars as the default set of completion word break characters.+-- This can be overridden for a particular command (for example, filename+-- expansion shouldn't consider '/' to be a word break) by setting the third+-- entry in the Command tuple above.+-- +-- NOTE: in order for us to override the default correctly, any custom entry+-- must be a SUBSET of word_break_chars.+word_break_chars :: String+word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"+ specials = "(),;[]`{}"+ spaces = " \t\n"+ in spaces ++ specials ++ symbols++flagWordBreakChars :: String+flagWordBreakChars = " \t\n"+++keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)+keepGoing a str = keepGoing' (lift . a) str++keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool+keepGoing' a str = a str >> return False++keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)+keepGoingPaths a str+ = do case toArgs str of+ Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr+ Right args -> a args+ return False++shortHelpText :: String+shortHelpText = "use :? for help.\n"++helpText :: String+helpText =+ " Commands available from the prompt:\n" +++ "\n" +++ " <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" +++ " :ctags[!] [<file>] create tags file for Vi (default: \"tags\")\n" +++ " (!: use regex instead of line number)\n" +++ " :def <cmd> <expr> define a command :<cmd>\n" +++ " :edit <file> edit file\n" +++ " :edit edit last module\n" +++ " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" +++ " :help, :? display this list of commands\n" +++ " :info [<name> ...] display information about the given names\n" +++ " :kind <type> show the kind of <type>\n" +++ " :load [*]<module> ... load module(s) and their dependents\n" +++ " :main [<arguments> ...] run the main function with the given arguments\n" +++ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" +++ " :quit exit GHCi\n" +++ " :reload reload the current module set\n" +++ " :run function [<arguments> ...] run the function with the given arguments\n" +++ " :type <expr> show the type of <expr>\n" +++ " :undef <cmd> undefine user-defined command :<cmd>\n" +++ " :!<command> run the shell command <command>\n" +++ "\n" +++ " -- Commands for debugging:\n" +++ "\n" +++ " :abandon at a breakpoint, abandon current computation\n" +++ " :back go back in the history (after :trace)\n" +++ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" +++ " :break <name> set a breakpoint on the specified function\n" +++ " :continue resume after a breakpoint\n" +++ " :delete <number> delete the specified breakpoint\n" +++ " :delete * delete all breakpoints\n" +++ " :force <expr> print <expr>, forcing unevaluated parts\n" +++ " :forward go forward in the history (after :back)\n" +++ " :history [<n>] after :trace, show the execution history\n" +++ " :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> ...] prints a value without forcing its computation\n" +++ " :sprint [<name> ...] simplifed version of :print\n" +++ " :step single-step after stopping at a breakpoint\n"+++ " :step <expr> single-step into <expr>\n"+++ " :steplocal single-step within the current top-level binding\n"+++ " :stepmodule single-step restricted to the current module\n"+++ " :trace trace after stopping at a breakpoint\n"+++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++++ "\n" +++ " -- Commands for changing settings:\n" +++ "\n" +++ " :set <option> ... set options\n" +++ " :set args <arg> ... set the arguments returned by System.getArgs\n" +++ " :set prog <progname> set the value returned by System.getProgName\n" +++ " :set prompt <prompt> set the prompt used in GHCi\n" +++ " :set editor <cmd> set the command used for :edit\n" +++ " :set stop [<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" +++ " +r revert top-level expressions after each evaluation\n" +++ " +s print timing/memory stats after each evaluation\n" +++ " +t print type after evaluation\n" +++ " -<flags> most GHC command line flags can also be set here\n" +++ " (eg. -v2, -fglasgow-exts, etc.)\n" +++ " for GHCi-specific flags, see User's Guide,\n"+++ " Flag reference, Interactive-mode options\n" +++ "\n" +++ " -- Commands for displaying information:\n" +++ "\n" +++ " :show bindings show the current bindings made at the prompt\n" +++ " :show breaks show the active breakpoints\n" +++ " :show context show the breakpoint context\n" +++ " :show modules show the currently loaded modules\n" +++ " :show packages show the currently active package flags\n" +++ " :show languages show the currently active language flags\n" +++ " :show <setting> show value of <setting>, which is one of\n" +++ " [args, prog, prompt, editor, stop]\n" +++ "\n" ++findEditor :: IO String+findEditor = do+ getEnv "EDITOR" + `IO.catch` \_ -> do+#if mingw32_HOST_OS+ win <- System.Win32.getWindowsDirectory+ return (win </> "notepad.exe")+#else+ return ""+#endif++foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt++interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]+ -> Ghc ()+interactiveUI srcs maybe_exprs = do+ -- although GHCi compiles with -prof, it is not usable: the byte-code+ -- compiler and interpreter don't work with profiling. So we check for+ -- this up front and emit a helpful error message (#2197)+ i <- liftIO $ isProfiled+ when (i /= 0) $ + ghcError (InstallationError "GHCi cannot be used when compiled with -prof")++ -- 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+ initInterpBuffering++ liftIO $ when (isNothing maybe_exprs) $ do+ -- Only for GHCi (not runghc and ghc -e):++ -- Turn buffering off for the compiled program's stdout/stderr+ turnOffBuffering+ -- Turn buffering off for GHCi's stdout+ hFlush stdout+ hSetBuffering stdout NoBuffering+ -- We don't want the cmd line to buffer any input that might be+ -- intended for the program, so unbuffer stdin.+ hSetBuffering stdin NoBuffering+#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611+ -- 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.+ hSetEncoding stdin utf8+#endif++ -- initial context is just the Prelude+ prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing+ GHC.setContext [] [prel_mod]++ default_editor <- liftIO $ findEditor++ startGHCi (runGHCi srcs maybe_exprs)+ GHCiState{ progname = "<interactive>",+ args = [],+ prompt = "%s> ",+ stop = "",+ editor = default_editor,+-- session = session,+ options = [],+ prelude = prel_mod,+ break_ctr = 0,+ breaks = [],+ tickarrays = emptyModuleEnv,+ last_command = Nothing,+ cmdqueue = [],+ remembered_ctx = [],+ ghc_e = isJust maybe_exprs+ }++ return ()++withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a+withGhcAppData right left = do+ either_dir <- IO.try (getAppUserDataDirectory "ghc")+ case either_dir of+ Right dir -> right dir+ _ -> left++runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+ let + read_dot_files = not opt_IgnoreDotGhci++ current_dir = return (Just ".ghci")++ app_user_dir = io $ withGhcAppData + (\dir -> return (Just (dir </> "ghci.conf")))+ (return Nothing)++ home_dir = do+ either_dir <- io $ IO.try (getEnv "HOME")+ case either_dir of+ Right home -> return (Just (home </> ".ghci"))+ _ -> return Nothing++ sourceConfigFile :: FilePath -> GHCi ()+ sourceConfigFile file = do+ exists <- io $ doesFileExist file+ when exists $ do+ dir_ok <- io $ checkPerms (getDirectory file)+ file_ok <- io $ checkPerms file+ when (dir_ok && file_ok) $ do+ either_hdl <- io $ IO.try (openFile file ReadMode)+ case either_hdl of+ Left _e -> return ()+ -- 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 -> runInputTWithPrefs defaultPrefs defaultSettings $ do+ runCommands $ fileLoop hdl+ where+ getDirectory f = case takeDirectory f of "" -> "."; d -> d++ when (read_dot_files) $ do+ cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]+ cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)+ mapM_ sourceConfigFile (nub cfgs)+ -- nub, because we don't want to read .ghci twice if the+ -- CWD is $HOME.++ -- Perform a :load for files given on the GHCi command line+ -- When in -e mode, if the load fails then we want to stop+ -- immediately rather than going on to evaluate the expression.+ when (not (null paths)) $ do+ ok <- ghciHandle (\e -> do showException e; return Failed) $+ -- TODO: this is a hack.+ runInputTWithPrefs defaultPrefs defaultSettings $ do+ let (filePaths, phases) = unzip paths+ filePaths' <- mapM (Encoding.decode . BS.pack) filePaths+ loadModule (zip filePaths' phases)+ when (isJust maybe_exprs && failed ok) $+ io (exitWith (ExitFailure 1))++ -- if verbosity is greater than 0, or we are connected to a+ -- terminal, display the prompt in the interactive loop.+ is_tty <- io (hIsTerminalDevice stdin)+ dflags <- getDynFlags+ let show_prompt = verbosity dflags > 0 || is_tty++ case maybe_exprs of+ Nothing ->+ do+ -- enter the interactive loop+ runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+ Just exprs -> do+ -- just evaluate the expression we were given+ enqueueCommands exprs+ let handle e = do st <- getGHCiState+ -- Jump through some hoops to get the+ -- current progname in the exception text:+ -- <progname>: <exception>+ io $ withProgName (progname st)+ -- this used to be topHandlerFastExit, see #2228+ $ topHandler e+ runInputTWithPrefs defaultPrefs defaultSettings $ do+ runCommands' handle (return Nothing)++ -- and finally, exit+ io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."++runGHCiInput :: InputT GHCi a -> GHCi a+runGHCiInput f = do+ histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))+ (return Nothing)+ let settings = setComplete ghciCompleteWord+ $ defaultSettings {historyFile = histFile}+ runInputT settings f++nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)+nextInputLine show_prompt is_tty+ | is_tty = do+ prompt <- if show_prompt then lift mkPrompt else return ""+ getInputLine prompt+ | 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. Otherwise, we could be accidentally +-- running code planted by a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else. I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "." always refers to+-- the same directory while a process is running.++checkPerms :: String -> IO Bool+#ifdef mingw32_HOST_OS+checkPerms _ =+ return True+#else+checkPerms name =+ handleIO (\_ -> return False) $ do+ st <- getFileStatus name+ me <- getRealUserID+ if fileOwner st /= me then do+ putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"+ return False+ else do+ let mode = fileMode st+ if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))+ || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) + then do+ putStrLn $ "*** WARNING: " ++ name ++ + " is writable by someone else, IGNORING!"+ return False+ else return True+#endif++fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)+fileLoop hdl = do+ l <- liftIO $ IO.try $ hGetLine hdl+ case l of+ Left e | isEOFError 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 -> return (Just l)++mkPrompt :: GHCi String+mkPrompt = do+ (toplevs,exports) <- GHC.getContext+ resumes <- GHC.getResumeContext+ -- st <- getGHCiState++ context_bit <-+ case resumes of+ [] -> return empty+ r:_ -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (brackets (ppr (GHC.resumeSpan r)) <> space)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ span <- GHC.getHistorySpan hist+ return (brackets (ppr (negate ix) <> char ':' + <+> ppr span) <> space)+ let+ dots | _:rs <- resumes, not (null rs) = text "... "+ | otherwise = empty++ ++ modules_bit = + -- ToDo: maybe...+ -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in+ -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>+ -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>+ hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>+ hsep (map (ppr . GHC.moduleName) exports)++ deflt_prompt = dots <> context_bit <> modules_bit++ f ('%':'s':xs) = deflt_prompt <> f xs+ f ('%':'%':xs) = char '%' <> f xs+ f (x:xs) = char x <> f xs+ f [] = empty+ --+ st <- getGHCiState+ return (showSDoc (f (prompt st)))+++queryQueue :: GHCi (Maybe String)+queryQueue = do+ st <- getGHCiState+ case cmdqueue st of+ [] -> return Nothing+ c:cs -> do setGHCiState st{ cmdqueue = cs }+ return (Just c)++runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands = runCommands' handler++runCommands' :: (SomeException -> GHCi Bool) -- Exception handler+ -> InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands' eh getCmd = do+ b <- handleGhcException (\e -> case e of+ Interrupted -> return False+ _other -> liftIO (print e) >> return True)+ (runOneCommand eh getCmd)+ if b then return () else runCommands' eh getCmd++runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)+ -> InputT GHCi Bool+runOneCommand eh getCmd = do+ mb_cmd <- noSpace (lift queryQueue)+ mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd+ case mb_cmd of+ Nothing -> return True+ Just c -> ghciHandle (lift . eh) $+ handleSourceError printErrorAndKeepGoing+ (doCommand c)+ where+ printErrorAndKeepGoing err = do+ GHC.printExceptionAndWarnings err+ return False++ noSpace q = q >>= maybe (return Nothing)+ (\c->case removeSpaces c of + "" -> noSpace q+ ":{" -> multiLineCmd q+ c -> return (Just c) )+ multiLineCmd q = do+ st <- lift getGHCiState+ let p = prompt st+ lift $ setGHCiState st{ prompt = "%s| " }+ mb_cmd <- collectCommand q ""+ lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p }+ return mb_cmd+ -- we can't use removeSpaces for the sublines here, so + -- multiline commands are somewhat more brittle against+ -- fileformat errors (such as \r in dos input on unix), + -- we get rid of any extra spaces for the ":}" test; + -- we also avoid silent failure if ":}" is not found;+ -- and since there is no (?) valid occurrence of \r (as + -- opposed to its String representation, "\r") inside a+ -- ghci command, we replace any such with ' ' (argh:-(+ collectCommand q c = q >>= + maybe (liftIO (ioError collectError))+ (\l->if removeSpaces l == ":}" + then return (Just $ removeSpaces c) + else collectCommand q (c++map normSpace l))+ where normSpace '\r' = ' '+ normSpace c = c+ -- QUESTION: is userError the one to use here?+ collectError = userError "unterminated multiline command :{ .. :}"+ doCommand (':' : cmd) = specialCommand cmd+ doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion+ return False++enqueueCommands :: [String] -> GHCi ()+enqueueCommands cmds = do+ st <- getGHCiState+ setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }+++runStmt :: String -> SingleStep -> GHCi Bool+runStmt stmt step+ | null (filter (not.isSpace) stmt) = return False+ | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)+ | otherwise+ = do+#if __GLASGOW_HASKELL__ >= 611+ -- 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 $ IO.try $ hFlushAll stdin+#endif+ result <- GhciMonad.runStmt stmt step+ afterRunStmt (const True) result++--afterRunStmt :: GHC.RunResult -> GHCi Bool+ -- False <=> the statement failed to compile+afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool+afterRunStmt _ (GHC.RunException e) = throw e+afterRunStmt step_here run_result = do+ resumes <- GHC.getResumeContext+ case run_result of+ GHC.RunOk names -> do+ show_types <- isOptionSet ShowType+ when show_types $ printTypeOfNames names+ GHC.RunBreak _ names mb_info+ | isNothing mb_info ||+ step_here (GHC.resumeSpan $ head resumes) -> do+ mb_id_loc <- toBreakIdAndLocation mb_info+ let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+ if (null breakCmd)+ then printStoppedAtBreakInfo (head resumes) names+ else enqueueCommands [breakCmd]+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ return ()+ | otherwise -> resume step_here GHC.SingleStep >>=+ afterRunStmt step_here >> return ()+ _ -> return ()++ flushInterpBuffers+ io installSignalHandlers+ b <- isOptionSet RevertCAFs+ when b revertCAFs++ return (case run_result of GHC.RunOk _ -> True; _ -> False)++toBreakIdAndLocation ::+ Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))+toBreakIdAndLocation Nothing = return Nothing+toBreakIdAndLocation (Just info) = do+ let mod = GHC.breakInfo_module info+ nm = GHC.breakInfo_number info+ st <- getGHCiState+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,+ breakModule loc == mod,+ breakTick loc == nm ]++printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()+printStoppedAtBreakInfo resume names = do+ printForUser $ ptext (sLit "Stopped at") <+>+ ppr (GHC.resumeSpan resume)+ -- printTypeOfNames session names+ let namesSorted = sortBy compareNames names+ tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted+ docs <- pprTypeAndContents [id | AnId id <- tythings]+ printForUserPartWay 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++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+ case maybe_cmd of+ GotCommand (_,f,_) -> f (dropWhile isSpace rest)+ BadCommand ->+ do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"+ ++ shortHelpText)+ return False+ NoLastCommand ->+ do liftIO $ hPutStr stdout ("there is no last command to perform\n"+ ++ shortHelpText)+ return False++lookupCommand :: String -> GHCi (MaybeCommand)+lookupCommand "" = do+ st <- getGHCiState+ case last_command st of+ Just c -> return $ GotCommand c+ Nothing -> return NoLastCommand+lookupCommand str = do+ mc <- io $ lookupCommand' str+ st <- getGHCiState+ setGHCiState st{ last_command = mc }+ return $ case mc of+ Just c -> GotCommand c+ Nothing -> BadCommand++lookupCommand' :: String -> IO (Maybe Command)+lookupCommand' ":" = return Nothing+lookupCommand' str' = do+ macros <- readIORef macros_ref+ let{ (str, cmds) = case str' of+ ':' : rest -> (rest, builtin_commands)+ _ -> (str', macros ++ builtin_commands) }+ -- look for exact match first, then the first prefix match+ return $ case [ c | c <- cmds, str == cmdName c ] of+ c:_ -> Just c+ [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of+ [] -> Nothing+ c:_ -> Just c++getCurrentBreakSpan :: GHCi (Maybe SrcSpan)+getCurrentBreakSpan = do+ 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)+ span <- GHC.getHistorySpan hist+ return (Just span)++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 _ _ = io $ putStrLn "This command takes no arguments"++help :: String -> GHCi ()+help _ = io (putStr helpText)++info :: String -> InputT GHCi ()+info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")+info s = handleSourceError GHC.printExceptionAndWarnings $ do+ { let names = words s+ ; dflags <- getDynFlags+ ; let pefas = dopt Opt_PrintExplicitForalls dflags+ ; mapM_ (infoThing pefas) names }+ where+ infoThing pefas str = do+ names <- GHC.parseName str+ mb_stuffs <- mapM GHC.getInfo names+ let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)+ unqual <- GHC.getPrintUnqual+ outputStrLn $ showSDocForUser unqual $+ vcat (intersperse (text "") $+ map (pprInfo pefas) filtered)++ -- Filter out names whose parent is also there Good+ -- example is '[]', which is both a type and data+ -- constructor in the same type+filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs + = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]+ where+ implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]++pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc+pprInfo pefas (thing, fixity, insts)+ = pprTyThingInContextLoc pefas thing+ $$ show_fixity fixity+ $$ vcat (map GHC.pprInstance insts)+ where+ show_fixity fix + | fix == GHC.defaultFixity = empty+ | otherwise = ppr fix <+> ppr (GHC.getName thing)++runMain :: String -> GHCi ()+runMain s = case toArgs s of+ Left err -> io (hPutStrLn stderr err)+ Right args ->+ do dflags <- getDynFlags+ case mainFunIs dflags of+ Nothing -> doWithArgs args "main"+ Just f -> doWithArgs args f++runRun :: String -> GHCi ()+runRun s = case toCmdArgs s of+ Left err -> io (hPutStrLn stderr err)+ Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: [String] -> String -> GHCi ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++ show args ++ " (" ++ cmd ++ ")"]++addModule :: [FilePath] -> 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+ -- remove old targets with the same id; e.g. for :add *M+ mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]+ mapM_ GHC.addTarget targets+ prev_context <- GHC.getContext+ ok <- trySuccess $ GHC.load LoadAllTargets+ afterLoad ok False prev_context++changeDirectory :: String -> InputT GHCi ()+changeDirectory "" = do+ -- :cd on its own changes to the user's home directory+ either_dir <- liftIO $ IO.try getHomeDirectory+ case either_dir of+ Left _e -> return ()+ Right dir -> changeDirectory dir+changeDirectory dir = do+ graph <- GHC.getModuleGraph+ when (not (null graph)) $+ outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"+ prev_context <- GHC.getContext+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets+ lift $ setContextAfterLoad prev_context False []+ GHC.workingDirectoryChanged+ dir <- expandPath dir+ liftIO $ setCurrentDirectory dir++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+ handleSourceError (\e -> do GHC.printExceptionAndWarnings e+ return Failed) $ do+ act++editFile :: String -> GHCi ()+editFile str =+ do file <- if null str then chooseEditFile else return str+ st <- getGHCiState+ let cmd = editor st+ when (null cmd) + $ ghcError (CmdLineError "editor not set, use :set editor")+ _ <- io $ system (cmd ++ ' ':file)+ return ()++-- The user didn't specify a file so we pick one for them.+-- Our strategy is to pick the first module that failed to load,+-- or otherwise the first target.+--+-- XXX: Can we figure out what happened if the depndecy analysis fails+-- (e.g., because the porgrammeer mistyped the name of a module)?+-- XXX: Can we figure out the location of an error to pass to the editor?+-- XXX: if we could figure out the list of errors that occured during the+-- last load/reaload, then we could start the editor focused on the first+-- of those.+chooseEditFile :: GHCi String+chooseEditFile =+ do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x++ graph <- GHC.getModuleGraph+ failed_graph <- filterM hasFailed graph+ let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing+ pick xs = case xs of+ x : _ -> GHC.ml_hs_file (GHC.ms_location x)+ _ -> Nothing++ case pick (order failed_graph) of+ Just file -> return file+ Nothing -> + do targets <- GHC.getTargets+ case msum (map fromTarget targets) of+ Just file -> return file+ Nothing -> ghcError (CmdLineError "No files to edit.")+ + where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f+ fromTarget _ = Nothing -- when would we get a module target?++defineMacro :: Bool{-overwrite-} -> String -> GHCi ()+defineMacro _ (':':_) =+ io $ putStrLn "macro name cannot start with a colon"+defineMacro overwrite s = do+ let (macro_name, definition) = break isSpace s+ macros <- io (readIORef macros_ref)+ let defined = map cmdName macros+ if (null macro_name) + then if null defined+ then io $ putStrLn "no macros defined"+ else io $ putStr ("the following macros are defined:\n" +++ unlines defined)+ else do+ if (not overwrite && macro_name `elem` defined)+ then ghcError (CmdLineError + ("macro '" ++ macro_name ++ "' is already defined"))+ else do++ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]++ -- give the expression a type signature, so we can be sure we're getting+ -- something of the right type.+ let new_expr = '(' : definition ++ ") :: String -> IO String"++ -- compile the expression+ handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do+ hv <- GHC.compileExpr new_expr+ io (writeIORef macros_ref --+ (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))++runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool+runMacro fun s = do+ str <- io ((unsafeCoerce# fun :: String -> IO String) s)+ -- make sure we force any exceptions in the result, while we are still+ -- inside the exception handler for commands:+ seqList str (return ())+ enqueueCommands (lines str)+ return False++undefineMacro :: String -> GHCi ()+undefineMacro str = mapM_ undef (words str) + where undef macro_name = do+ cmds <- io (readIORef macros_ref)+ if (macro_name `notElem` map cmdName cmds) + then ghcError (CmdLineError + ("macro '" ++ macro_name ++ "' is not defined"))+ else do+ io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))++cmdCmd :: String -> GHCi ()+cmdCmd str = do+ let expr = '(' : str ++ ") :: IO String"+ handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do+ hv <- GHC.compileExpr expr+ cmds <- io $ (unsafeCoerce# hv :: IO String)+ enqueueCommands (lines cmds)+ return ()++loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule fs = timeIt (loadModule' fs)++loadModule_ :: [FilePath] -> InputT GHCi ()+loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()++loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule' files = do+ prev_context <- GHC.getContext++ -- unload first+ _ <- GHC.abandonAll+ lift discardActiveBreakPoints+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets++ 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.++ GHC.setTargets targets+ doLoad False prev_context LoadAllTargets++checkModule :: String -> InputT GHCi ()+checkModule m = do+ let modl = GHC.mkModuleName m+ prev_context <- GHC.getContext+ ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl+ outputStrLn (showSDoc (+ case GHC.moduleInfo r of+ cm | Just scope <- GHC.modInfoTopLevelScope cm ->+ let+ (local,global) = ASSERT( all isExternalName scope )+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope+ in+ (text "global names: " <+> ppr global) $$+ (text "local names: " <+> ppr local)+ _ -> empty))+ return True+ afterLoad (successIf ok) False prev_context++reloadModule :: String -> InputT GHCi ()+reloadModule m = do+ prev_context <- GHC.getContext+ _ <- doLoad True prev_context $+ if null m then LoadAllTargets + else LoadUpTo (GHC.mkModuleName m)+ return ()++doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag+doLoad retain_context prev_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+ ok <- trySuccess $ GHC.load howmuch+ afterLoad ok retain_context prev_context+ return ok++afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()+afterLoad ok retain_context prev_context = do+ lift revertCAFs -- always revert CAFs on load.+ lift discardTickArrays+ loaded_mod_summaries <- getLoadedModules+ let loaded_mods = map GHC.ms_mod loaded_mod_summaries+ loaded_mod_names = map GHC.moduleName loaded_mods+ modulesLoadedMsg ok loaded_mod_names++ lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries+++setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()+setContextAfterLoad prev keep_ctxt [] = do+ prel_mod <- getPrelude+ setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])+setContextAfterLoad prev 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' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in+ load_this (last graph') + (m:_) -> + load_this m+ where+ findTarget ms t+ = case filter (`matches` t) ms 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+ b <- GHC.moduleIsInterpreted m+ if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])+ else do+ prel_mod <- getPrelude+ setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])++-- | Keep any package modules (except Prelude) when changing the context.+setContextKeepingPackageModules+ :: ([Module],[Module]) -- previous context+ -> Bool -- re-execute :module commands+ -> ([Module],[Module]) -- new context+ -> GHCi ()+setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do+ let (_,bs0) = prev_context+ prel_mod <- getPrelude+ let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0+ let bs1 = if null as then nub (prel_mod : bs) else bs+ GHC.setContext as (nub (bs1 ++ pkg_modules))+ if keep_ctxt+ then do+ st <- getGHCiState+ mapM_ (playCtxtCmd False) (remembered_ctx st)+ else do+ st <- getGHCiState+ setGHCiState st{ remembered_ctx = [] }++isHomeModule :: Module -> Bool+isHomeModule mod = GHC.modulePackageId mod == mainPackageId++modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()+modulesLoadedMsg ok mods = do+ dflags <- getDynFlags+ when (verbosity dflags > 0) $ do+ let mod_commas + | null mods = text "none."+ | otherwise = hsep (+ punctuate comma (map ppr mods)) <> text "."+ case ok of+ Failed ->+ outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))+ Succeeded ->+ outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))+++typeOfExpr :: String -> InputT GHCi ()+typeOfExpr str + = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do+ ty <- GHC.exprType str+ dflags <- getDynFlags+ let pefas = dopt Opt_PrintExplicitForalls dflags+ printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]++kindOfType :: String -> InputT GHCi ()+kindOfType str + = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do+ ty <- GHC.typeKind str+ printForUser $ text str <+> dcolon <+> ppr ty++quit :: String -> InputT GHCi Bool+quit _ = return True++shellEscape :: String -> GHCi Bool+shellEscape str = io (system str >> return False)++-----------------------------------------------------------------------------+-- Browsing a module's contents++browseCmd :: Bool -> String -> InputT GHCi ()+browseCmd bang m = + case words m of+ ['*':s] | looksLikeModuleName s -> do + m <- lift $ wantInterpretedModule s+ browseModule bang m False+ [s] | looksLikeModuleName s -> do+ m <- lift $ lookupModule s+ browseModule bang m True+ [] -> do+ (as,bs) <- GHC.getContext+ -- Guess which module the user wants to browse. Pick+ -- modules that are interpreted first. The most+ -- recently-added module occurs last, it seems.+ case (as,bs) of+ (as@(_:_), _) -> browseModule bang (last as) True+ ([], bs@(_:_)) -> browseModule bang (last bs) True+ ([], []) -> ghcError (CmdLineError ":browse: no current module")+ _ -> ghcError (CmdLineError "syntax: :browse <module>")++-- 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+ current_unqual <- GHC.getPrintUnqual+ -- Temporarily set the context to the module we're interested in,+ -- just so we can get an appropriate PrintUnqualified+ (as,bs) <- GHC.getContext+ prel_mod <- lift getPrelude+ if exports_only then GHC.setContext [] [prel_mod,modl]+ else GHC.setContext [modl] []+ target_unqual <- GHC.getPrintUnqual+ GHC.setContext as bs++ let unqual = if bang then current_unqual else target_unqual++ mb_mod_info <- GHC.getModuleInfo modl+ case mb_mod_info of+ Nothing -> ghcError (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 names+ | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)+ = sortBy (compare `on` nameSrcSpan) names+ | otherwise+ = occ_sort names++ mb_things <- mapM GHC.lookupName sorted_names+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)++ rdr_env <- GHC.getGRE++ let pefas = dopt Opt_PrintExplicitForalls dflags+ things | bang = catMaybes mb_things+ | otherwise = filtered_things+ pretty | bang = pprTyThing+ | otherwise = pprTyThingInContext++ labels [] = text "-- not currently imported"+ labels l = text $ intercalate "\n" $ map qualifier l+ qualifier = maybe "-- defined locally" + (("-- imported via "++) . intercalate ", " + . map GHC.moduleNameString)+ importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env+ 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 $ group mts+ where cmpQualifiers = + compare `on` (map (fmap (map moduleNameFS)) . fst)+ group [] = []+ group mts@((m,_):_) = (m,map snd g) : group ng+ where (g,ng) = partition ((==m).fst) mts++ let prettyThings = map (pretty pefas) things+ prettyThings' | bang = annotate $ zip modNames prettyThings+ | otherwise = prettyThings+ outputStrLn $ showSDocForUser 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))++-----------------------------------------------------------------------------+-- Setting the module context++setContext :: String -> GHCi ()+setContext str+ | all sensible strs = do+ playCtxtCmd True (cmd, as, bs)+ st <- getGHCiState+ setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }+ | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")+ where+ (cmd, strs, as, bs) =+ case str of + '+':stuff -> rest AddModules stuff+ '-':stuff -> rest RemModules stuff+ stuff -> rest SetContext stuff++ rest cmd stuff = (cmd, strs, as, bs)+ where strs = words stuff+ (as,bs) = partitionWith starred strs++ sensible ('*':m) = looksLikeModuleName m+ sensible m = looksLikeModuleName m++ starred ('*':m) = Left m+ starred m = Right m++playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()+playCtxtCmd fail (cmd, as, bs)+ = do+ (as',bs') <- do_checks fail+ (prev_as,prev_bs) <- GHC.getContext+ (new_as, new_bs) <-+ case cmd of+ SetContext -> do+ prel_mod <- getPrelude+ let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'+ else bs'+ return (as',bs'')+ AddModules -> do+ let as_to_add = as' \\ (prev_as ++ prev_bs)+ bs_to_add = bs' \\ (prev_as ++ prev_bs)+ return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)+ RemModules -> do+ let new_as = prev_as \\ (as' ++ bs')+ new_bs = prev_bs \\ (as' ++ bs')+ return (new_as, new_bs)+ GHC.setContext new_as new_bs+ where+ do_checks True = do+ as' <- mapM wantInterpretedModule as+ bs' <- mapM lookupModule bs+ return (as',bs')+ do_checks False = do+ as' <- mapM (trymaybe . wantInterpretedModule) as+ bs' <- mapM (trymaybe . lookupModule) bs+ return (catMaybes as', catMaybes bs')++ trymaybe m = do+ r <- ghciTry m+ case r of+ Left _ -> return Nothing+ Right a -> return (Just a)++----------------------------------------------------------------------------+-- Code for `: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 ""+ = do st <- getGHCiState+ let opts = options st+ io $ putStrLn (showSDoc (+ text "options currently set: " <> + if null opts+ then text "none."+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)+ ))+ dflags <- getDynFlags+ io $ putStrLn (showSDoc (+ vcat (text "GHCi-specific dynamic flag settings:" + :map (flagSetting dflags) ghciFlags)+ ))+ io $ putStrLn (showSDoc (+ vcat (text "other dynamic, non-language, flag settings:" + :map (flagSetting dflags) nonLanguageDynFlags)+ ))+ where flagSetting dflags (str, f, _)+ | dopt f dflags = text " " <> text "-f" <> text str+ | otherwise = text " " <> text "-fno-" <> text str+ (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)+ DynFlags.fFlags+ nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)+ others+ flags = [Opt_PrintExplicitForalls+ ,Opt_PrintBindResult+ ,Opt_BreakOnException+ ,Opt_BreakOnError+ ,Opt_PrintEvldWithShow+ ] +setCmd str+ = case getCmd str of+ Right ("args", rest) ->+ case toArgs rest of+ Left err -> io (hPutStrLn stderr err)+ Right args -> setArgs args+ Right ("prog", rest) ->+ case toArgs rest of+ Right [prog] -> setProg prog+ _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")+ Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest+ Right ("editor", rest) -> setEditor $ dropWhile isSpace rest+ Right ("stop", rest) -> setStop $ dropWhile isSpace rest+ _ -> case toArgs str of+ Left err -> io (hPutStrLn stderr err)+ Right wds -> setOptions wds++setArgs, setOptions :: [String] -> GHCi ()+setProg, setEditor, setStop, setPrompt :: String -> GHCi ()++setArgs args = do+ st <- getGHCiState+ setGHCiState st{ args = args }++setProg prog = do+ st <- getGHCiState+ setGHCiState st{ progname = prog }++setEditor cmd = do+ st <- getGHCiState+ setGHCiState 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 = do+ st <- getGHCiState+ setGHCiState st{ stop = cmd }++setPrompt value = do+ st <- getGHCiState+ if null value+ then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""+ else case value of+ '\"' : _ -> case reads value of+ [(value', xs)] | all isSpace xs ->+ setGHCiState (st { prompt = value' })+ _ ->+ io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."+ _ -> setGHCiState (st { prompt = value })++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+ newDynFlags minus_opts++newDynFlags :: [String] -> GHCi ()+newDynFlags minus_opts = do+ dflags <- getDynFlags+ let pkg_flags = packageFlags dflags+ (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts+ handleFlagWarnings dflags' warns++ if (not (null leftovers))+ then ghcError $ errorsToGhcException leftovers+ else return ()++ new_pkgs <- setDynFlags dflags'++ -- if the package flags changed, we should reset the context+ -- and link the new packages.+ dflags <- getDynFlags+ when (packageFlags dflags /= pkg_flags) $ do+ io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."+ GHC.setTargets []+ _ <- GHC.load LoadAllTargets+ io (linkPackages dflags new_pkgs)+ -- package flags changed, we can't re-use any of the old context+ setContextAfterLoad ([],[]) False []+ return ()+++unsetOptions :: String -> GHCi ()+unsetOptions str+ = do -- 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++ if (not (null rest2)) + then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))+ else do++ mapM_ unsetOpt plus_opts+ + let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)+ no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))++ no_flags <- mapM no_flag minus_opts+ newDynFlags 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 -> io (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> setOption o++unsetOpt str+ = case strToGHCiOpt str of+ Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> unsetOption o++strToGHCiOpt :: String -> (Maybe GHCiOption)+strToGHCiOpt "s" = Just ShowTiming+strToGHCiOpt "t" = Just ShowType+strToGHCiOpt "r" = Just RevertCAFs+strToGHCiOpt _ = Nothing++optToStr :: GHCiOption -> String+optToStr ShowTiming = "s"+optToStr ShowType = "t"+optToStr RevertCAFs = "r"++-- ---------------------------------------------------------------------------+-- code for `:show'++showCmd :: String -> GHCi ()+showCmd str = do+ st <- getGHCiState+ case words str of+ ["args"] -> io $ putStrLn (show (args st))+ ["prog"] -> io $ putStrLn (show (progname st))+ ["prompt"] -> io $ putStrLn (show (prompt st))+ ["editor"] -> io $ putStrLn (show (editor st))+ ["stop"] -> io $ putStrLn (show (stop st))+ ["modules" ] -> showModules+ ["bindings"] -> showBindings+ ["linker"] -> io showLinkerState+ ["breaks"] -> showBkptTable+ ["context"] -> showContext+ ["packages"] -> showPackages+ ["languages"] -> showLanguages+ _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"+++ " | breaks | context | packages | languages ]"))++showModules :: GHCi ()+showModules = do+ loaded_mods <- getLoadedModules+ -- we want *loaded* modules only, see #1734+ let show_one ms = do m <- GHC.showModule ms; io (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) graph++showBindings :: GHCi ()+showBindings = do+ bindings <- GHC.getBindings+ docs <- pprTypeAndContents+ [ id | AnId id <- sortBy compareTyThings bindings]+ printForUserPartWay docs++compareTyThings :: TyThing -> TyThing -> Ordering+t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2++printTyThing :: TyThing -> GHCi ()+printTyThing tyth = do dflags <- getDynFlags+ let pefas = dopt Opt_PrintExplicitForalls dflags+ printForUser (pprTyThing pefas 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 resume =+ ptext (sLit "--> ") <> text (GHC.resumeStmt resume)+ $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume))++showPackages :: GHCi ()+showPackages = do+ pkg_flags <- fmap packageFlags getDynFlags+ io $ putStrLn $ showSDoc $ vcat $+ text ("active package flags:"++if null pkg_flags then " none" else "")+ : map showFlag pkg_flags+ pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags+ io $ putStrLn $ showSDoc $ vcat $+ text "packages currently loaded:" + : map (nest 2 . text . packageIdString) + (sortBy (compare `on` packageIdFS) pkg_ids)+ where showFlag (ExposePackage p) = text $ " -package " ++ p+ showFlag (HidePackage p) = text $ " -hide-package " ++ p+ showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p+ showFlag (ExposePackageId p) = text $ " -package-id " ++ p++showLanguages :: GHCi ()+showLanguages = do+ dflags <- getDynFlags+ io $ putStrLn $ showSDoc $ vcat $+ text "active language flags:" :+ [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]++-- -----------------------------------------------------------------------------+-- Completion++completeCmd, completeMacro, completeIdentifier, completeModule,+ completeHomeModule, completeSetOptions, completeShowOptions,+ completeHomeModuleOrFile, completeExpression+ :: CompletionFunc GHCi++ghciCompleteWord :: CompletionFunc GHCi+ghciCompleteWord line@(left,_) = case firstWord of+ ':':cmd | null rest -> completeCmd line+ | otherwise -> do+ completion <- lookupCompletion cmd+ completion line+ "import" -> completeModule line+ _ -> completeExpression line+ where+ (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left+ lookupCompletion ('!':_) = return completeFilename+ lookupCompletion c = do+ maybe_cmd <- liftIO $ lookupCommand' c+ case maybe_cmd of+ Just (_,_,f) -> return f+ Nothing -> return completeFilename++completeCmd = wrapCompleter " " $ \w -> do+ macros <- liftIO $ readIORef macros_ref+ let macro_names = map (':':) . map cmdName $ macros+ let command_names = map (':':) . map cmdName $ builtin_commands+ let{ candidates = case w of+ ':' : ':' : _ -> map (':':) command_names+ _ -> nub $ macro_names ++ command_names }+ return $ filter (w `isPrefixOf`) candidates++completeMacro = wrapIdentCompleter $ \w -> do+ cmds <- liftIO $ readIORef macros_ref+ return (filter (w `isPrefixOf`) (map cmdName cmds))++completeIdentifier = wrapIdentCompleter $ \w -> do+ rdrs <- GHC.getRdrNamesInScope+ return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))++completeModule = wrapIdentCompleter $ \w -> do+ dflags <- GHC.getSessionDynFlags+ let pkg_mods = allExposedModules dflags+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+ return $ filter (w `isPrefixOf`)+ $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods++completeHomeModule = wrapIdentCompleter listHomeModules++listHomeModules :: String -> GHCi [String]+listHomeModules w = do+ g <- GHC.getModuleGraph+ let home_mods = map GHC.ms_mod_name g+ return $ sort $ filter (w `isPrefixOf`)+ $ map (showSDoc.ppr) home_mods++completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) options)+ where options = "args":"prog":"prompt":"editor":"stop":flagList+ flagList = map head $ group $ sort allFlags++completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) options)+ where options = ["args", "prog", "prompt", "editor", "stop",+ "modules", "bindings", "linker", "breaks",+ "context", "packages", "languages"]++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) . fmap sort . fun++wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleter = wrapCompleter word_break_chars++allExposedModules :: DynFlags -> [ModuleName]+allExposedModules dflags + = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))+ where+ pkg_db = pkgIdMap (pkgState dflags)++completeExpression = completeQuotedWord (Just '\\') "\"" listFiles+ completeIdentifier++-- ---------------------------------------------------------------------------+-- 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+ io installSignalHandlers+ ghciHandle handler (showException exception >> return False)++showException :: SomeException -> GHCi ()+showException se =+ io $ case fromException se of+ Just Interrupted -> putStrLn "Interrupted."+ -- omit the location for CmdLineError:+ Just (CmdLineError s) -> putStrLn s+ -- ditto:+ Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")+ Just other_ghc_ex -> print other_ghc_ex+ Nothing -> putStrLn ("*** Exception: " ++ show se)++-----------------------------------------------------------------------------+-- 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 :: MonadException m => (SomeException -> m a) -> m a -> m a+ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e)++ghciTry :: GHCi a -> GHCi (Either SomeException a)+ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)++-- ----------------------------------------------------------------------------+-- Utils++-- 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 path = do+ exp_path <- liftIO $ expandPathIO path+ enc <- fmap BS.unpack $ Encoding.encode exp_path+ return enc++expandPathIO :: String -> IO String+expandPathIO path = + case dropWhile isSpace path 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 = do+ modl <- lookupModule str+ dflags <- getDynFlags+ when (GHC.modulePackageId modl /= thisPackage dflags) $+ ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))+ is_interpreted <- GHC.moduleIsInterpreted modl+ when (not is_interpreted) $+ ghcError (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.printExceptionAndWarnings) $ 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++-- -----------------------------------------------------------------------------+-- 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 [] = doContinue (const True) GHC.SingleStep+stepCmd expression = runStmt expression GHC.SingleStep >> return ()++stepLocalCmd :: String -> GHCi ()+stepLocalCmd [] = do + mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just loc -> do+ Just mod <- getCurrentBreakModule+ current_toplevel_decl <- enclosingTickSpan mod loc+ doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep++stepLocalCmd expression = stepCmd expression++stepModuleCmd :: String -> GHCi ()+stepModuleCmd [] = do + mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just _ -> do+ Just span <- getCurrentBreakSpan+ let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span+ doContinue f GHC.SingleStep++stepModuleCmd expression = stepCmd expression++-- | Returns the span of the largest tick containing the srcspan given+enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan+enclosingTickSpan mod src = do+ ticks <- getTickArray mod+ let line = srcSpanStartLine src+ ASSERT (inRange (bounds ticks) line) do+ let enclosing_spans = [ span | (_,span) <- ticks ! line+ , srcSpanEnd span >= srcSpanEnd src]+ return . head . sortBy leftmost_largest $ enclosing_spans++traceCmd :: String -> GHCi ()+traceCmd [] = doContinue (const True) GHC.RunAndLogSteps+traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return ()++continueCmd :: String -> GHCi ()+continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion++-- doContinue :: SingleStep -> GHCi ()+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()+doContinue pred step = do + runResult <- resume pred step+ _ <- afterRunStmt pred runResult+ return ()++abandonCmd :: String -> GHCi ()+abandonCmd = noArgs $ do+ b <- GHC.abandon -- the prompt will change to indicate the new context+ when (not b) $ io $ putStrLn "There is no computation running."+ return ()++deleteCmd :: String -> GHCi ()+deleteCmd argLine = do+ deleteSwitch $ words argLine+ where+ deleteSwitch :: [String] -> GHCi ()+ deleteSwitch [] = + io $ 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 = io $ putStrLn "Syntax: :history [num]"+ where+ history num = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> io $ putStrLn "Not stopped at a breakpoint"+ (r:_) -> do+ let hist = GHC.resumeHistory r+ (took,rest) = splitAt num hist+ case hist of+ [] -> io $ putStrLn $ + "Empty history. Perhaps you forgot to use :trace?"+ _ -> do+ spans <- mapM GHC.getHistorySpan took+ let nums = map (printf "-%-3d:") [(1::Int)..]+ names = map GHC.historyEnclosingDecl took+ printForUser (vcat(zipWith3 + (\x y z -> x <+> y <+> z) + (map text nums) + (map (bold . ppr) names)+ (map (parens . ppr) spans)))+ io $ putStrLn $ if null rest then "<end of history>" else "..."++bold :: SDoc -> SDoc+bold c | do_bold = text start_bold <> c <> text end_bold+ | otherwise = c++backCmd :: String -> GHCi ()+backCmd = noArgs $ do+ (names, _, span) <- GHC.back+ printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++forwardCmd :: String -> GHCi ()+forwardCmd = noArgs $ do+ (names, ix, span) <- GHC.forward+ printForUser $ (if (ix == 0)+ then ptext (sLit "Stopped at")+ else ptext (sLit "Logged breakpoint at")) <+> ppr span+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++-- handle the "break" command+breakCmd :: String -> GHCi ()+breakCmd argLine = do+ breakSwitch $ words argLine++breakSwitch :: [String] -> GHCi ()+breakSwitch [] = do+ io $ putStrLn "The break command requires at least one argument."+breakSwitch (arg1:rest)+ | looksLikeModuleName arg1 && not (null rest) = do+ mod <- wantInterpretedModule arg1+ breakByModule mod rest+ | all isDigit arg1 = do+ (toplevel, _) <- GHC.getContext+ case toplevel of+ (mod : _) -> breakByModuleLine mod (read arg1) rest+ [] -> do + io $ putStrLn "Cannot find default module for breakpoint." + io $ putStrLn "Perhaps no modules are loaded for debugging?"+ | otherwise = do -- try parsing it as an identifier+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+ if GHC.isGoodSrcLoc loc+ then ASSERT( isExternalName name ) + findBreakAndSet (GHC.nameModule name) $ + findBreakByCoord (Just (GHC.srcLocFile loc))+ (GHC.srcLocLine loc, + GHC.srcLocCol loc)+ else noCanDo name $ text "can't find its location: " <> ppr loc+ where+ noCanDo n why = printForUser $+ text "cannot set breakpoint on " <> ppr n <> text ": " <> why++breakByModule :: Module -> [String] -> GHCi () +breakByModule mod (arg1:rest)+ | all isDigit arg1 = do -- looks like a line number+ breakByModuleLine mod (read arg1) rest+breakByModule _ _+ = breakSyntax++breakByModuleLine :: Module -> Int -> [String] -> GHCi ()+breakByModuleLine mod line args+ | [] <- args = findBreakAndSet mod $ findBreakByLine line+ | [col] <- args, all isDigit col =+ findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)+ | otherwise = breakSyntax++breakSyntax :: a+breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")++findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()+findBreakAndSet mod lookupTickTree = do + tickArray <- getTickArray mod+ (breakArray, _) <- getModBreak mod+ case lookupTickTree tickArray of + Nothing -> io $ putStrLn $ "No breakpoints found at that location."+ Just (tick, span) -> do+ success <- io $ setBreakFlag True breakArray tick + if success + then do+ (alreadySet, nm) <- + recordBreak $ BreakLocation+ { breakModule = mod+ , breakLoc = span+ , breakTick = tick+ , onBreakCmd = ""+ }+ printForUser $+ text "Breakpoint " <> ppr nm <>+ if alreadySet + then text " was already set at " <> ppr span+ else text " activated at " <> ppr span+ else do+ printForUser $ text "Breakpoint could not be activated at" + <+> ppr span++-- 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,SrcSpan)+findBreakByLine line arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`+ listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`+ listToMaybe (sortBy (rightmost `on` snd) ticks)+ where + ticks = arr ! line++ starts_here = [ tick | tick@(_,span) <- ticks,+ GHC.srcSpanStartLine span == line ]++ (complete,incomplete) = partition ends_here starts_here+ where ends_here (_,span) = GHC.srcSpanEndLine span == line++findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray+ -> Maybe (BreakIndex,SrcSpan)+findBreakByCoord mb_file (line, col) arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (rightmost `on` snd) contains +++ sortBy (leftmost_smallest `on` snd) after_here)+ where + ticks = arr ! line++ -- the ticks that span this coordinate+ contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),+ is_correct_file span ]++ is_correct_file span+ | Just f <- mb_file = GHC.srcSpanFile span == f+ | otherwise = True++ after_here = [ tick | tick@(_,span) <- ticks,+ GHC.srcSpanStartLine span == line,+ GHC.srcSpanStartCol span >= 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"++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 span+ | GHC.isGoodSrcSpan span -> listAround span True+ | otherwise ->+ 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 span+ $$ text "Try" <+> doWhat)+listCmd str = list2 (words str)++list2 :: [String] -> InputT GHCi ()+list2 [arg] | all isDigit arg = do+ (toplevel, _) <- GHC.getContext+ case toplevel of+ [] -> outputStrLn "No module to list"+ (mod : _) -> listModuleLine mod (read arg)+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do+ mod <- wantInterpretedModule arg1+ listModuleLine mod (read arg2)+list2 [arg] = do+ wantNameFromInterpretedModule noCanDo arg $ \name -> do+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+ if GHC.isGoodSrcLoc loc+ then do+ tickArray <- ASSERT( isExternalName name )+ lift $ getTickArray (GHC.nameModule name)+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))+ (GHC.srcLocLine loc, GHC.srcLocCol loc)+ tickArray+ case mb_span of+ Nothing -> listAround (GHC.srcLocSpan loc) False+ Just (_,span) -> listAround span False+ else+ 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 = + outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"++listModuleLine :: Module -> Int -> InputT GHCi ()+listModuleLine modl line = do+ graph <- GHC.getModuleGraph+ let this = filter ((== modl) . GHC.ms_mod) graph+ case this of+ [] -> panic "listModuleLine"+ summ:_ -> do+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))+ loc = GHC.mkSrcLoc (mkFastString (filename)) line 0+ listAround (GHC.srcLocSpan 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 => SrcSpan -> Bool -> InputT m ()+listAround span do_highlight = do+ contents <- liftIO $ BS.readFile (unpackFS file)+ let + lines = BS.split '\n' contents+ these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $ + drop (line1 - 1 - pad_before) $ lines+ fst_line = max 1 (line1 - pad_before)+ line_nos = [ fst_line .. ]++ highlighted | do_highlight = zipWith highlight line_nos these_lines+ | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]++ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]+ prefixed = zipWith ($) highlighted bs_line_nos+ --+ let output = BS.intercalate (BS.pack "\n") prefixed+ utf8Decoded <- liftIO $ BS.useAsCStringLen output+ $ \(p,n) -> utf8DecodeString (castPtr p) n+ outputStrLn utf8Decoded+ where+ file = GHC.srcSpanFile span+ line1 = GHC.srcSpanStartLine span+ col1 = GHC.srcSpanStartCol span+ line2 = GHC.srcSpanEndLine span+ col2 = GHC.srcSpanEndCol span++ 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 = do+ st <- getGHCiState+ setGHCiState st{tickarrays = emptyModuleEnv}++mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray+mkTickArray ticks+ = accumArray (flip (:)) [] (1, max_line) + [ (line, (nm,span)) | (nm,span) <- ticks,+ line <- srcSpanLines span ]+ where+ max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))+ srcSpanLines span = [ GHC.srcSpanStartLine span .. + GHC.srcSpanEndLine span ]++lookupModule :: GHC.GhcMonad m => String -> m Module+lookupModule modName+ = GHC.lookupModule (GHC.mkModuleName modName) Nothing++-- 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 Bool+turnOffBreak loc = do+ (arr, _) <- getModBreak (breakModule loc)+ io $ setBreakFlag False arr (breakTick loc)++getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)+getModBreak mod = do+ Just mod_info <- GHC.getModuleInfo mod+ let modBreaks = GHC.modInfoModBreaks mod_info+ let array = GHC.modBreaks_flags modBreaks+ let ticks = GHC.modBreaks_locs modBreaks+ return (array, ticks)++setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool +setBreakFlag toggle array index+ | toggle = GHC.setBreakOn array index + | otherwise = GHC.setBreakOff array index
+ GhciHaskeline612/Main.hs view
@@ -0,0 +1,766 @@+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module GhciHaskeline612.Main (main) where++-- The official GHC API+import qualified GHC+import GHC ( -- DynFlags(..), HscTarget(..),+ -- GhcMode(..), GhcLink(..),+ LoadHowMuch(..), -- dopt, DynFlag(..),+ defaultCallbacks )+import CmdLineParser++-- Implementations of the various modes (--show-iface, mkdependHS. etc.)+import LoadIface ( showIface )+import HscMain ( newHscEnv )+import DriverPipeline ( oneShot, compileFile )+import DriverMkDepend ( doMkDependHS )+#ifdef GHCI+import GhciHaskeline612.InteractiveUI ( interactiveUI, ghciWelcomeMsg )+#endif+++-- Various other random stuff that we need+import Config+import HscTypes+import Packages ( dumpPackages )+import DriverPhases ( Phase(..), isSourceFilename, anyHsc,+ startPhase, isHaskellSrcFilename )+import BasicTypes ( failed )+import StaticFlags+import StaticFlagParser+import DynFlags+import ErrUtils+import FastString+import Outputable+import SrcLoc+import Util+import Panic+-- import MonadUtils ( liftIO )++-- Imports for --abi-hash+import LoadIface ( loadUserInterface )+import Module ( mkModuleName )+import Finder ( findImportedModule, cannotFindInterface )+import TcRnMonad ( initIfaceCheck )+import Binary ( openBinMem, put_, 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++import GHC.Paths++-----------------------------------------------------------------------------+-- ToDo:++-- time commands when run with -v+-- user ways+-- Win32 support: proper signal handling+-- reading the package configuration file is too slow+-- -K<size>++-----------------------------------------------------------------------------+-- GHC's command-line interface++main :: IO ()+main =+ GHC.defaultErrorHandler defaultDynFlags $ do+ -- 1. extract the -B flag from the args+ argv0 <- getArgs++ let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0+ mbMinusB | null minusB_args = Just libdir+ | otherwise = Just (drop 2 (last minusB_args))++ let argv1' = map (mkGeneralLocated "on the commandline") ("--interactive" : argv1)+ (argv2, staticFlagWarnings) <- parseStaticFlags argv1'++ -- 2. Parse the "mode" flags (--make, --interactive etc.)+ (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2++ let flagWarnings = staticFlagWarnings ++ modeFlagWarnings++ -- 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+ ShowSupportedLanguages -> showSupportedLanguages+ ShowVersion -> showVersion+ ShowNumVersion -> putStrLn cProjectVersion+ Print str -> putStrLn str+ 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' postLoadMode dflags argv3 flagWarnings++main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]+ -> Ghc ()+main' postLoadMode dflags0 args flagWarnings = do+ -- 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)+ DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)+ DoAbiHash -> (OneShot, dflt_target, LinkBinary)+ _ -> (OneShot, dflt_target, LinkBinary)++ let dflags1 = dflags0{ ghcMode = mode,+ hscTarget = lang,+ ghcLink = link,+ -- leave out hscOutName for now+ hscOutName = panic "Main.main:hscOutName not set",+ verbosity = case postLoadMode of+ DoEval _ -> 0+ _other -> 1+ }++ -- turn on -fimplicit-import-qualified for GHCi now, so that it+ -- can be overriden from the command-line+ dflags1a | DoInteractive <- postLoadMode = imp_qual_enabled+ | DoEval _ <- postLoadMode = imp_qual_enabled+ | otherwise = dflags1+ where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified++ -- The rest of the arguments are "dynamic"+ -- Leftover ones are presumably files+ (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a args++ let flagWarnings' = flagWarnings ++ dynamicFlagWarnings++ handleSourceError (\e -> do+ GHC.printExceptionAndWarnings e+ liftIO $ exitWith (ExitFailure 1)) $+ handleFlagWarnings dflags2 flagWarnings'++ -- make sure we clean up after ourselves+ GHC.defaultCleanupHandler dflags2 $ do++ liftIO $ showBanner postLoadMode dflags2++ -- we've finished manipulating the DynFlags, update the session+ _ <- GHC.setSessionDynFlags dflags2+ dflags3 <- GHC.getSessionDynFlags+ hsc_env <- GHC.getSession++ let+ -- To simplify the handling of filepaths, we normalise all filepaths right + -- away - e.g., for win32 platforms, backslashes are converted+ -- into forward slashes.+ normal_fileish_paths = map (normalise . unLoc) fileish_args+ (srcs, objs) = partition_args normal_fileish_paths [] []++ -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on + -- the command-line.+ liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs)++ ---------------- Display configuration -----------+ when (verbosity dflags3 >= 4) $+ liftIO $ dumpPackages dflags3++ when (verbosity dflags3 >= 3) $ do+ liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)++ ---------------- Final sanity checking -----------+ liftIO $ checkOptions postLoadMode dflags3 srcs objs++ ---------------- Do the business -----------+ handleSourceError (\e -> do+ GHC.printExceptionAndWarnings e+ liftIO $ exitWith (ExitFailure 1)) $ do+ case postLoadMode of+ ShowInterface f -> liftIO $ doShowIface dflags3 f+ DoMake -> doMake srcs+ DoMkDependHS -> do doMkDependHS (map fst srcs)+ GHC.printWarnings+ StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings+ DoInteractive -> interactiveUI srcs Nothing+ DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs+ DoAbiHash -> abiHash srcs++ liftIO $ dumpFinalStats dflags3++#ifndef GHCI+interactiveUI :: b -> c -> Ghc ()+interactiveUI _ _ =+ ghcError (CmdLineError "not built for interactive use")+#endif++-- -----------------------------------------------------------------------------+-- Splitting arguments into source files and object files. This is where we+-- interpret the -x <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 v_Ld_inputs for use by the linker.++ The following things should be considered compilation manager inputs:++ - haskell source files (strings ending in .hs, .lhs or other + haskellish extension),++ - module names (not forgetting hierarchical module names),++ - and finally we consider everything not containing a '.' to be+ a comp manager input, as shorthand for a .hs or .lhs filename.++ Everything else is considered to be a linker object, and passed+ straight through to the linker.+ -}+looks_like_an_input :: String -> Bool+looks_like_an_input m = isSourceFilename m + || looksLikeModuleName m+ || '.' `notElem` m++-- -----------------------------------------------------------------------------+-- Option sanity checks++-- | Ensure sanity of options.+--+-- Throws 'UsageError' or 'CmdLineError' if not.+checkOptions :: 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 isRTSWay (wayNames dflags))+ && isInterpretiveMode mode) $+ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")++ -- -prof and --interactive are not a good combination+ when (notNull (filter (not . isRTSWay) (wayNames dflags))+ && isInterpretiveMode mode) $+ do ghcError (UsageError + "--interactive can't be used with -prof or -unreg.")+ -- -ohi sanity check+ if (isJust (outputHi dflags) && + (isCompManagerMode mode || srcs `lengthExceeds` 1))+ then ghcError (UsageError "-ohi can only be used when compiling a single source file")+ else do++ -- -o sanity checking+ if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)+ && not (isLinkMode mode))+ then ghcError (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 ghcError (UsageError "no input files")+ else do++ -- Verify that output files point somewhere sensible.+ verifyOutputFiles dflags+++-- Compiler output options++-- called to verify that the output files & directories+-- point somewhere valid. +--+-- The assumption is that the directory portion of these output+-- options will have to exist by the time 'verifyOutputFiles'+-- is invoked.+-- +verifyOutputFiles :: DynFlags -> IO ()+verifyOutputFiles dflags = do+ -- not -odir: we create the directory for -odir if it doesn't exist (#2278).+ let ofile = outputFile dflags+ when (isJust ofile) $ do+ let fn = fromJust ofile+ flg <- doesDirNameExist fn+ when (not flg) (nonExistentDir "-o" fn)+ let ohi = outputHi dflags+ when (isJust ohi) $ do+ let hi = fromJust ohi+ flg <- doesDirNameExist hi+ when (not flg) (nonExistentDir "-ohi" hi)+ where+ nonExistentDir flg dir = + ghcError (CmdLineError ("error: directory portion of " ++ + show dir ++ " does not exist (used with " ++ + show flg ++ " option.)"))++-----------------------------------------------------------------------------+-- GHC modes of operation++type Mode = Either PreStartupMode PostStartupMode+type PostStartupMode = Either PreLoadMode PostLoadMode++data PreStartupMode+ = ShowVersion -- ghc -V/--version+ | ShowNumVersion -- ghc --numeric-version+ | ShowSupportedLanguages -- ghc --supported-languages+ | Print String -- ghc --print-foo++showVersionMode, showNumVersionMode, showSupportedLanguagesMode :: Mode+showVersionMode = mkPreStartupMode ShowVersion+showNumVersionMode = mkPreStartupMode ShowNumVersion+showSupportedLanguagesMode = mkPreStartupMode ShowSupportedLanguages++printMode :: String -> Mode+printMode str = mkPreStartupMode (Print str)++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++printWithDynFlagsMode :: (DynFlags -> String) -> Mode+printWithDynFlagsMode f = mkPreLoadMode (PrintWithDynFlags f)++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+ | DoInteractive -- ghc --interactive+ | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]+ | DoAbiHash -- ghc --abi-hash++doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode+doMkDependHSMode = mkPostLoadMode DoMkDependHS+doMakeMode = mkPostLoadMode DoMake+doInteractiveMode = mkPostLoadMode DoInteractive+doAbiHashMode = mkPostLoadMode DoAbiHash++showInterfaceMode :: FilePath -> Mode+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)++stopBeforeMode :: Phase -> Mode+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)++doEvalMode :: String -> Mode+doEvalMode str = mkPostLoadMode (DoEval [str])++mkPostLoadMode :: PostLoadMode -> Mode+mkPostLoadMode = Right . Right++isDoInteractiveMode :: Mode -> Bool+isDoInteractiveMode (Right (Right DoInteractive)) = True+isDoInteractiveMode _ = False++#ifdef 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],+ [Located String])+parseModeFlags args = do+ let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =+ runCmdLine (processArgs mode_flags args)+ (Nothing, [], [])+ mode = case mModeFlag of+ Nothing -> stopBeforeMode StopLn+ Just (m, _) -> m+ errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2+ when (not (null errs)) $ ghcError $ errorsToGhcException errs+ 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 ----------------------------------------------+ Flag "?" (PassFlag (setMode showGhcUsageMode))+ Supported+ , Flag "-help" (PassFlag (setMode showGhcUsageMode))+ Supported+ , Flag "V" (PassFlag (setMode showVersionMode))+ Supported+ , Flag "-version" (PassFlag (setMode showVersionMode))+ Supported+ , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))+ Supported+ , Flag "-info" (PassFlag (setMode showInfoMode))+ Supported+ , Flag "-supported-languages" (PassFlag (setMode showSupportedLanguagesMode))+ Supported+ ] +++ [ Flag k' (PassFlag (setMode mode))+ Supported+ | (k, v) <- compilerInfo,+ let k' = "-print-" ++ map (replaceSpace . toLower) k+ replaceSpace ' ' = '-'+ replaceSpace c = c+ mode = case v of+ String str -> printMode str+ FromDynFlags f -> printWithDynFlagsMode f+ ] +++ ------- interfaces ----------------------------------------------------+ [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)+ "--show-iface"))+ Supported++ ------- primary modes ------------------------------------------------+ , Flag "M" (PassFlag (setMode doMkDependHSMode))+ Supported+ , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))+ Supported+ , Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f+ addFlag "-fvia-C" f))+ Supported+ , Flag "S" (PassFlag (setMode (stopBeforeMode As)))+ Supported+ , Flag "-make" (PassFlag (setMode doMakeMode))+ Supported+ , Flag "-interactive" (PassFlag (setMode doInteractiveMode))+ Supported+ , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))+ Supported+ , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))+ Supported++ -- -fno-code says to stop after Hsc but don't generate any code.+ , Flag "fno-code" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f+ addFlag "-fno-code" f+ addFlag "-fforce-recomp" f))+ Supported+ ]++setMode :: Mode -> String -> ModeM ()+setMode newMode newFlag = do+ (mModeFlag, errs, flags') <- getCmdLineState+ let (modeFlag', errs') =+ case mModeFlag of+ Nothing -> ((newMode, newFlag), errs)+ Just (oldMode, oldFlag) ->+ case (oldMode, newMode) of+ -- If we have both --help and --interactive then we+ -- want showGhciUsage+ _ | isShowGhcUsageMode oldMode &&+ isDoInteractiveMode newMode ->+ ((showGhciUsageMode, oldFlag), [])+ | isShowGhcUsageMode newMode &&+ isDoInteractiveMode oldMode ->+ ((showGhciUsageMode, 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)+ -- 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 -> ModeM ()+addFlag s flag = 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 [] = ghcError (UsageError "no input files")+doMake srcs = do+ let (hs_srcs, non_hs_srcs) = partition haskellish srcs++ haskellish (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f+ haskellish (_,Just phase) = + phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]++ hsc_env <- GHC.getSession+ o_files <- mapM (\x -> do+ f <- compileFile hsc_env StopLn x+ GHC.printWarnings+ return f)+ non_hs_srcs+ liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)++ targets <- mapM (uncurry GHC.guessTarget) hs_srcs+ GHC.setTargets targets+ ok_flag <- GHC.load LoadAllTargets++ when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))+ return ()+++-- ---------------------------------------------------------------------------+-- --show-iface mode++doShowIface :: DynFlags -> FilePath -> IO ()+doShowIface dflags file = do+ hsc_env <- newHscEnv defaultCallbacks dflags+ showIface hsc_env file++-- ---------------------------------------------------------------------------+-- Various banners and verbosity output.++showBanner :: PostLoadMode -> DynFlags -> IO ()+showBanner _postLoadMode dflags = do+ let verb = verbosity dflags++#ifdef 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 ", for Haskell 98, stage "+ hPutStr stderr cStage+ hPutStr stderr " booted by GHC version "+ hPutStrLn stderr cBooterVersion++-- We print out a Read-friendly string, but a prettier one than the+-- Show instance gives us+showInfo :: DynFlags -> IO ()+showInfo dflags = do+ let sq x = " [" ++ x ++ "\n ]"+ putStrLn $ sq $ concat $ intersperse "\n ," $ map (show . flatten) compilerInfo+ where flatten (k, String v) = (k, v)+ flatten (k, FromDynFlags f) = (k, f dflags)++showSupportedLanguages :: IO ()+showSupportedLanguages = mapM_ putStrLn supportedLanguages++showVersion :: IO ()+showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)++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 (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags++dumpFastStringStats :: DynFlags -> IO ()+dumpFastStringStats dflags = do+ buckets <- getFastStringTable+ let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets+ msg = text "FastString stats:" $$+ nest 4 (vcat [text "size: " <+> int (length buckets),+ text "entries: " <+> int entries,+ text "longest chain: " <+> int longest,+ text "z-encoded: " <+> (is_z `pcntOf` entries),+ text "has z-encoding: " <+> (has_z `pcntOf` entries)+ ])+ -- we usually get more "has z-encoding" than "z-encoded", because+ -- when we z-encode a string it might hash to the exact same string,+ -- which will is not counted as "z-encoded". Only strings whose+ -- Z-encoding is different from the original string are counted in+ -- the "z-encoded" total.+ putMsg dflags msg+ where+ x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'++countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int)+countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)+countFS entries longest is_z has_z (b:bs) = + let+ len = length b+ longest' = max len longest+ entries' = entries + len+ is_zs = length (filter isZEncoded b)+ has_zs = length (filter hasZEncoding b)+ in+ countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs++-- -----------------------------------------------------------------------------+-- 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 InstalledPackageId for a+package. The InstalledPackageId 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.+-}++abiHash :: [(String, Maybe Phase)] -> 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 -> ghcError $ CmdLineError $ showSDoc $+ cannotFindInterface dflags modname r++ mods <- mapM find_it (map fst strs)++ let get_iface modl = loadUserInterface False (text "abiHash") modl+ ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods++ bh <- openBinMem (3*1024) -- just less than a block+ mapM_ (put_ bh . mi_mod_hash) ifaces+ f <- fingerprintBinMem bh++ putStrLn (showSDoc (ppr f))++-- -----------------------------------------------------------------------------+-- Util++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))
Main.hs view
@@ -1,608 +1,10 @@-{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}------------------------------------------------------------------------------------- GHC Driver program------ (c) The University of Glasgow 2005-----------------------------------------------------------------------------------module Main (main) where---- The official GHC API-import qualified GHC-import GHC ( DynFlags(..), HscTarget(..),- GhcMode(..), GhcLink(..),- LoadHowMuch(..), dopt, DynFlag(..) )-import CmdLineParser+module Main where --- Implementations of the various modes (--show-iface, mkdependHS. etc.)-import LoadIface ( showIface )-import HscMain ( newHscEnv )-import DriverPipeline ( oneShot, compileFile )-import DriverMkDepend ( doMkDependHS )-#ifdef GHCI-import GhciHaskeline.InteractiveUI ( interactiveUI, ghciWelcomeMsg )+#if __GLASGOW_HASKELL__ >= 611+import qualified GhciHaskeline612.Main as G+#else+import qualified GhciHaskeline.Main as G #endif --- Various other random stuff that we need-import Config-import HscTypes-import Packages ( dumpPackages )-import DriverPhases ( Phase(..), isSourceFilename, anyHsc,- startPhase, isHaskellSrcFilename )-import BasicTypes ( failed )-import StaticFlags-import StaticFlagParser-import DynFlags-import ErrUtils-import FastString-import Outputable-import SrcLoc-import Util-import Panic-import MonadUtils ( liftIO )---- Standard Haskell libraries-import System.IO-import System.Environment-import System.Exit-import System.FilePath-import Control.Monad-import Data.List-import Data.Maybe--import GHC.Paths---------------------------------------------------------------------------------- ToDo:---- time commands when run with -v--- user ways--- Win32 support: proper signal handling--- reading the package configuration file is too slow--- -K<size>---------------------------------------------------------------------------------- GHC's command-line interface- main :: IO ()-main =- - GHC.defaultErrorHandler defaultDynFlags $ do- -- 1. extract the -B flag from the args- argv0 <- getArgs-- let- (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0- mbMinusB | null minusB_args = Just libdir- | otherwise = Just (drop 2 (last minusB_args))-- let argv1' = map (mkGeneralLocated "on the commandline") ("--interactive" : argv1)- (argv2, staticFlagWarnings) <- parseStaticFlags argv1'-- -- 2. Parse the "mode" flags (--make, --interactive etc.)- (m_uber_mode, cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2-- -- If all we want to do is to show the version number then do it- -- now, before we start a GHC session etc.- -- If we do it later then bootstrapping gets confused as it tries- -- to find out what version of GHC it's using before package.conf- -- exists, so starting the session fails.- case m_uber_mode of- -- ShowUsage currently has to be handled specially, as it needs to- -- actually start up GHC so that it can find the usage.txt files- -- in the libdir. It would be nice to embed the text in the- -- executable so that we don't have to do that, and things are more- -- uniform here.- Just ShowUsage -> return ()- Just um ->- do case um of- ShowInfo -> showInfo- ShowSupportedLanguages -> showSupportedLanguages- ShowVersion -> showVersion- ShowNumVersion -> putStrLn cProjectVersion- exitWith ExitSuccess- Nothing -> return ()-- -- start our GHC session- GHC.runGhc mbMinusB $ do-- dflags0 <- GHC.getSessionDynFlags-- -- set the default GhcMode, HscTarget and GhcLink. The HscTarget- -- can be further adjusted on a module by module basis, using only- -- the -fvia-C and -fasm flags. If the default HscTarget is not- -- HscC or HscAsm, -fvia-C and -fasm have no effect.- let dflt_target = hscTarget dflags0- (mode, lang, link)- = case cli_mode of- DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)- DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)- DoMake -> (CompManager, dflt_target, LinkBinary)- DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)- _ -> (OneShot, dflt_target, LinkBinary)-- let dflags1 = dflags0{ ghcMode = mode,- hscTarget = lang,- ghcLink = link,- -- leave out hscOutName for now- hscOutName = panic "Main.main:hscOutName not set",- verbosity = case cli_mode of- DoEval _ -> 0- _other -> 1- }-- -- turn on -fimplicit-import-qualified for GHCi now, so that it- -- can be overriden from the command-line- dflags1a | DoInteractive <- cli_mode = imp_qual_enabled- | DoEval _ <- cli_mode = imp_qual_enabled- | otherwise = dflags1- where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified-- -- The rest of the arguments are "dynamic"- -- Leftover ones are presumably files- (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a argv3-- -- As noted earlier, currently we hvae to handle ShowUsage down here- case m_uber_mode of- Just ShowUsage -> liftIO $ showGhcUsage dflags2 cli_mode- _ -> return ()-- let flagWarnings = staticFlagWarnings- ++ modeFlagWarnings- ++ dynamicFlagWarnings- liftIO $ handleFlagWarnings dflags2 flagWarnings-- -- make sure we clean up after ourselves- GHC.defaultCleanupHandler dflags2 $ do-- liftIO $ showBanner cli_mode dflags2-- -- we've finished manipulating the DynFlags, update the session- GHC.setSessionDynFlags dflags2- dflags3 <- GHC.getSessionDynFlags- hsc_env <- GHC.getSession-- let- -- To simplify the handling of filepaths, we normalise all filepaths right - -- away - e.g., for win32 platforms, backslashes are converted- -- into forward slashes.- normal_fileish_paths = map (normalise . unLoc) fileish_args- (srcs, objs) = partition_args normal_fileish_paths [] []-- -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on - -- the command-line.- liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs)-- ---------------- Display configuration ------------ when (verbosity dflags3 >= 4) $- liftIO $ dumpPackages dflags3-- when (verbosity dflags3 >= 3) $ do- liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)-- ---------------- Final sanity checking ------------ liftIO $ checkOptions cli_mode dflags3 srcs objs-- ---------------- Do the business ------------ handleSourceError (\e -> do- GHC.printExceptionAndWarnings e- liftIO $ exitWith (ExitFailure 1)) $ do- case cli_mode of- PrintLibdir -> liftIO $ putStrLn (topDir dflags3)- ShowInterface f -> liftIO $ doShowIface dflags3 f- DoMake -> doMake srcs- DoMkDependHS -> doMkDependHS (map fst srcs)- StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings- DoInteractive -> interactiveUI srcs Nothing- DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs-- liftIO $ dumpFinalStats dflags3- liftIO $ exitWith ExitSuccess--#ifndef GHCI-interactiveUI :: b -> c -> Ghc ()-interactiveUI _ _ =- ghcError (CmdLineError "not built for interactive use")-#endif---- -------------------------------------------------------------------------------- Splitting arguments into source files and object files. This is where we--- interpret the -x <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 v_Ld_inputs for use by the linker.-- The following things should be considered compilation manager inputs:-- - haskell source files (strings ending in .hs, .lhs or other - haskellish extension),-- - module names (not forgetting hierarchical module names),-- - and finally we consider everything not containing a '.' to be- a comp manager input, as shorthand for a .hs or .lhs filename.-- Everything else is considered to be a linker object, and passed- straight through to the linker.- -}-looks_like_an_input :: String -> Bool-looks_like_an_input m = isSourceFilename m - || looksLikeModuleName m- || '.' `notElem` m---- -------------------------------------------------------------------------------- Option sanity checks---- | Ensure sanity of options.------ Throws 'UsageError' or 'CmdLineError' if not.-checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()- -- Final sanity checking before kicking off a compilation (pipeline).-checkOptions cli_mode dflags srcs objs = do- -- Complain about any unknown flags- let unknown_opts = [ f | (f@('-':_), _) <- srcs ]- when (notNull unknown_opts) (unknownFlagsErr unknown_opts)-- when (notNull (filter isRTSWay (wayNames dflags))- && isInterpretiveMode cli_mode) $- hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")-- -- -prof and --interactive are not a good combination- when (notNull (filter (not . isRTSWay) (wayNames dflags))- && isInterpretiveMode cli_mode) $- do ghcError (UsageError - "--interactive can't be used with -prof or -unreg.")- -- -ohi sanity check- if (isJust (outputHi dflags) && - (isCompManagerMode cli_mode || srcs `lengthExceeds` 1))- then ghcError (UsageError "-ohi can only be used when compiling a single source file")- else do-- -- -o sanity checking- if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)- && not (isLinkMode cli_mode))- then ghcError (UsageError "can't apply -o to multiple source files")- else do-- let not_linking = not (isLinkMode cli_mode) || isNoLink (ghcLink dflags)-- when (not_linking && not (null objs)) $- hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)-- -- Check that there are some input files- -- (except in the interactive case)- if null srcs && (null objs || not_linking) && needsInputsMode cli_mode- then ghcError (UsageError "no input files")- else do-- -- Verify that output files point somewhere sensible.- verifyOutputFiles dflags----- Compiler output options---- called to verify that the output files & directories--- point somewhere valid. ------ The assumption is that the directory portion of these output--- options will have to exist by the time 'verifyOutputFiles'--- is invoked.--- -verifyOutputFiles :: DynFlags -> IO ()-verifyOutputFiles dflags = do- -- not -odir: we create the directory for -odir if it doesn't exist (#2278).- let ofile = outputFile dflags- when (isJust ofile) $ do- let fn = fromJust ofile- flg <- doesDirNameExist fn- when (not flg) (nonExistentDir "-o" fn)- let ohi = outputHi dflags- when (isJust ohi) $ do- let hi = fromJust ohi- flg <- doesDirNameExist hi- when (not flg) (nonExistentDir "-ohi" hi)- where- nonExistentDir flg dir = - ghcError (CmdLineError ("error: directory portion of " ++ - show dir ++ " does not exist (used with " ++ - show flg ++ " option.)"))---------------------------------------------------------------------------------- GHC modes of operation--data UberMode- = ShowUsage -- ghc -?- | ShowVersion -- ghc -V/--version- | ShowNumVersion -- ghc --numeric-version- | ShowSupportedLanguages -- ghc --supported-languages- | ShowInfo -- ghc --info- deriving (Show)--data CmdLineMode- = PrintLibdir -- ghc --print-libdir- | ShowInterface String -- ghc --show-iface- | DoMkDependHS -- ghc -M- | StopBefore Phase -- ghc -E | -C | -S- -- StopBefore StopLn is the default- | DoMake -- ghc --make- | DoInteractive -- ghc --interactive- | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]- deriving (Show)--#ifdef GHCI-isInteractiveMode :: CmdLineMode -> Bool-isInteractiveMode DoInteractive = True-isInteractiveMode _ = False-#endif---- isInterpretiveMode: byte-code compiler involved-isInterpretiveMode :: CmdLineMode -> Bool-isInterpretiveMode DoInteractive = True-isInterpretiveMode (DoEval _) = True-isInterpretiveMode _ = False--needsInputsMode :: CmdLineMode -> Bool-needsInputsMode DoMkDependHS = True-needsInputsMode (StopBefore _) = True-needsInputsMode DoMake = True-needsInputsMode _ = False---- True if we are going to attempt to link in this mode.--- (we might not actually link, depending on the GhcLink flag)-isLinkMode :: CmdLineMode -> Bool-isLinkMode (StopBefore StopLn) = True-isLinkMode DoMake = True-isLinkMode DoInteractive = True-isLinkMode (DoEval _) = True-isLinkMode _ = False--isCompManagerMode :: CmdLineMode -> Bool-isCompManagerMode DoMake = True-isCompManagerMode DoInteractive = True-isCompManagerMode (DoEval _) = True-isCompManagerMode _ = False----- -------------------------------------------------------------------------------- Parsing the mode flag--parseModeFlags :: [Located String]- -> IO (Maybe UberMode,- CmdLineMode,- [Located String],- [Located String])-parseModeFlags args = do- let ((leftover, errs, warns), (mUberMode, mode, _, flags')) =- runCmdLine (processArgs mode_flags args)- (Nothing, StopBefore StopLn, "", [])- when (not (null errs)) $ ghcError $ errorsToGhcException errs- return (mUberMode, mode, flags' ++ leftover, warns)--type ModeM = CmdLineP (Maybe UberMode, CmdLineMode, String, [Located String])- -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)- -- so we collect the new ones and return them.--mode_flags :: [Flag ModeM]-mode_flags =- [ ------- help / version ----------------------------------------------- Flag "?" (NoArg (setUberMode ShowUsage))- Supported- , Flag "-help" (NoArg (setUberMode ShowUsage))- Supported- , Flag "V" (NoArg (setUberMode ShowVersion))- Supported- , Flag "-version" (NoArg (setUberMode ShowVersion))- Supported- , Flag "-numeric-version" (NoArg (setUberMode ShowNumVersion))- Supported- , Flag "-info" (NoArg (setUberMode ShowInfo))- Supported- , Flag "-supported-languages" (NoArg (setUberMode ShowSupportedLanguages))- Supported- , Flag "-print-libdir" (PassFlag (setMode PrintLibdir))- Supported-- ------- interfaces ----------------------------------------------------- , Flag "-show-iface" (HasArg (\f -> setMode (ShowInterface f)- "--show-iface"))- Supported-- ------- primary modes ------------------------------------------------- , Flag "M" (PassFlag (setMode DoMkDependHS))- Supported- , Flag "E" (PassFlag (setMode (StopBefore anyHsc)))- Supported- , Flag "C" (PassFlag (\f -> do setMode (StopBefore HCc) f- addFlag "-fvia-C"))- Supported- , Flag "S" (PassFlag (setMode (StopBefore As)))- Supported- , Flag "-make" (PassFlag (setMode DoMake))- Supported- , Flag "-interactive" (PassFlag (setMode DoInteractive))- Supported- , Flag "e" (HasArg (\s -> updateMode (updateDoEval s) "-e"))- Supported-- -- -fno-code says to stop after Hsc but don't generate any code.- , Flag "fno-code" (PassFlag (\f -> do setMode (StopBefore HCc) f- addFlag "-fno-code"- addFlag "-fforce-recomp"))- Supported- ]--setUberMode :: UberMode -> ModeM ()-setUberMode m = do- (_, cmdLineMode, flag, flags') <- getCmdLineState- putCmdLineState (Just m, cmdLineMode, flag, flags')--setMode :: CmdLineMode -> String -> ModeM ()-setMode m flag = updateMode (\_ -> m) flag--updateDoEval :: String -> CmdLineMode -> CmdLineMode-updateDoEval expr (DoEval exprs) = DoEval (expr : exprs)-updateDoEval expr _ = DoEval [expr]--updateMode :: (CmdLineMode -> CmdLineMode) -> String -> ModeM ()-updateMode f flag = do- (m_uber_mode, old_mode, old_flag, flags') <- getCmdLineState- if null old_flag || flag == old_flag- then putCmdLineState (m_uber_mode, f old_mode, flag, flags')- else ghcError (UsageError- ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))--addFlag :: String -> ModeM ()-addFlag s = do- (u, m, f, flags') <- getCmdLineState- -- XXX Can we get a useful Loc?- putCmdLineState (u, m, f, mkGeneralLocated "addFlag" s : flags')----- ------------------------------------------------------------------------------- Run --make mode--doMake :: [(String,Maybe Phase)] -> Ghc ()-doMake [] = ghcError (UsageError "no input files")-doMake srcs = do- let (hs_srcs, non_hs_srcs) = partition haskellish srcs-- haskellish (f,Nothing) = - looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f- haskellish (_,Just phase) = - phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]-- hsc_env <- GHC.getSession- o_files <- mapM (\x -> do- f <- compileFile hsc_env StopLn x- GHC.printWarnings- return f)- non_hs_srcs- liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)-- targets <- mapM (uncurry GHC.guessTarget) hs_srcs- GHC.setTargets targets- ok_flag <- GHC.load LoadAllTargets-- when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))- return ()----- ------------------------------------------------------------------------------ --show-iface mode--doShowIface :: DynFlags -> FilePath -> IO ()-doShowIface dflags file = do- hsc_env <- newHscEnv dflags- showIface hsc_env file---- ------------------------------------------------------------------------------ Various banners and verbosity output.--showBanner :: CmdLineMode -> DynFlags -> IO ()-showBanner _cli_mode dflags = do- let verb = verbosity dflags--#ifdef GHCI- -- Show the GHCi banner- when (isInteractiveMode _cli_mode && verb >= 1) $ putStrLn ghciWelcomeMsg-#endif-- -- Display details of the configuration in verbose mode- when (verb >= 2) $- do hPutStr stderr "Glasgow Haskell Compiler, Version "- hPutStr stderr cProjectVersion- hPutStr stderr ", for Haskell 98, stage "- hPutStr stderr cStage- hPutStr stderr " booted by GHC version "- hPutStrLn stderr cBooterVersion---- We print out a Read-friendly string, but a prettier one than the--- Show instance gives us-showInfo :: IO ()-showInfo = do- let sq x = " [" ++ x ++ "\n ]"- putStrLn $ sq $ concat $ intersperse "\n ," $ map show compilerInfo- exitWith ExitSuccess--showSupportedLanguages :: IO ()-showSupportedLanguages = do mapM_ putStrLn supportedLanguages- exitWith ExitSuccess--showVersion :: IO ()-showVersion = do- putStrLn (cProjectName ++ ", version " ++ cProjectVersion)- exitWith ExitSuccess--showGhcUsage :: DynFlags -> CmdLineMode -> IO ()-showGhcUsage dflags cli_mode = do - let usage_path - | DoInteractive <- cli_mode = ghciUsagePath dflags- | otherwise = ghcUsagePath dflags- usage <- readFile usage_path- dump usage- exitWith ExitSuccess- where- dump "" = return ()- dump ('$':'$':s) = putStr progName >> dump s- dump (c:s) = putChar c >> dump s--dumpFinalStats :: DynFlags -> IO ()-dumpFinalStats dflags = - when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags--dumpFastStringStats :: DynFlags -> IO ()-dumpFastStringStats dflags = do- buckets <- getFastStringTable- let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets- msg = text "FastString stats:" $$- nest 4 (vcat [text "size: " <+> int (length buckets),- text "entries: " <+> int entries,- text "longest chain: " <+> int longest,- text "z-encoded: " <+> (is_z `pcntOf` entries),- text "has z-encoding: " <+> (has_z `pcntOf` entries)- ])- -- we usually get more "has z-encoding" than "z-encoded", because- -- when we z-encode a string it might hash to the exact same string,- -- which will is not counted as "z-encoded". Only strings whose- -- Z-encoding is different from the original string are counted in- -- the "z-encoded" total.- putMsg dflags msg- where- x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'--countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int)-countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)-countFS entries longest is_z has_z (b:bs) = - let- len = length b- longest' = max len longest- entries' = entries + len- is_zs = length (filter isZEncoded b)- has_zs = length (filter hasZEncoding b)- in- countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs---- -------------------------------------------------------------------------------- Util--unknownFlagsErr :: [String] -> a-unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))+main = G.main
ghci-haskeline.cabal view
@@ -1,5 +1,5 @@ Name: ghci-haskeline-Version: 0.1.1+Version: 0.2 Copyright: BSD3 License: BSD3 License-File: LICENSE@@ -19,11 +19,16 @@ flag newer-ghc Description: for GHC >= 6.10.2 +flag ghc-612+ Description: for GHC >= 6.12.1+ Executable ghci-haskeline- Main-Is: Main.hs+ Main-is: Main.hs+ if !flag(ghc-612) { Other-modules: GhciHaskeline.GhciMonad GhciHaskeline.InteractiveUI GhciHaskeline.GhciTags+ GhciHaskeline.Main Build-Depends: base >=4 && < 5, array >= 0.1 && < 0.3,@@ -55,5 +60,31 @@ DeriveDataTypeable GHC-Options: -Wall -fno-warn-orphans -fno-warn-name-shadowing+ } else {+ Other-modules: GhciHaskeline612.GhciMonad+ GhciHaskeline612.InteractiveUI+ GhciHaskeline612.GhciTags+ GhciHaskeline612.Main+ build-depends: base >= 3 && < 5,+ array >= 0.1 && < 0.4,+ bytestring >= 0.9 && < 0.10,+ directory >= 1 && < 1.1,+ process >= 1 && < 1.1,+ ghc == 6.12.*,+ filepath >= 1 && < 1.2,+ mtl == 1.1.*,+ haskeline == 0.6.*,+ ghc-paths + if os(windows) {+ Build-Depends: Win32+ } else {+ Build-Depends: unix+ }+ CPP-Options: -DGHCI+ Extensions: ForeignFunctionInterface,+ UnboxedTuples,+ FlexibleInstances,+ MagicHash, CPP, PatternGuards+ }