diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs deleted file mode 100644 --- a/ghc/GhciMonad.hs +++ /dev/null @@ -1,383 +0,0 @@ -{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSp --- for details - ------------------------------------------------------------------------------ --- --- Monadery code used in InteractiveUI --- --- (c) The GHC Team 2005-2006 --- ------------------------------------------------------------------------------ - -module GhciMonad where - -#include "HsVersions.h" - -import qualified GHC -import GhcMonad hiding (liftIO) -import Outputable hiding (printForUser, printForUserPartWay) -import qualified Outputable -import Panic hiding (showException) -import Util -import DynFlags -import HscTypes -import SrcLoc -import Module -import ObjLink -import Linker -import StaticFlags -import qualified MonadUtils - -import Exception -import Numeric -import Data.Array -import Data.Int ( Int64 ) -import Data.IORef -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 - ------------------------------------------------------------------------------ --- 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], - line_number :: !Int, -- input line - break_ctr :: !Int, - breaks :: ![(Int, BreakLocation)], - tickarrays :: ModuleEnv TickArray, - -- tickarrays caches the TickArray for loaded modules, - -- so that we don't rebuild it each time the user sets - -- a breakpoint. - -- ":" at the GHCi prompt repeats the last command, so we - -- remember is here: - last_command :: Maybe Command, - cmdqueue :: [String], - - remembered_ctx :: [InteractiveImport], - -- the imports that the user has asked for, via import - -- declarations and :module commands. This list is - -- persistent over :reloads (but any imports for modules - -- that are not loaded are temporarily ignored). After a - -- :load, all the home-package imports are stripped from - -- this list. - - -- See bugs #2049, #1873, #1360 - - transient_ctx :: [InteractiveImport], - -- An import added automatically after a :load, usually of - -- the most recently compiled module. May be empty if - -- there are no modules loaded. This list is replaced by - -- :load, :reload, and :add. In between it may be modified - -- by :module. - - ghc_e :: Bool -- True if this is 'ghc -e' (or runghc) - } - -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 - | Multiline -- use multiline commands - 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 -modifyGHCiState :: (GHCiState -> GHCiState) -> GHCi () -modifyGHCiState f = GHCi $ \r -> liftIO $ readIORef r >>= writeIORef r . f - -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 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) - gmask f = - GHCi $ \s -> gmask $ \io_restore -> - let - g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s') - in - unGHCi (f g_restore) s - -instance MonadIO GHCi where - liftIO = MonadUtils.liftIO - -instance Haskeline.MonadException GHCi where - catch = gcatch - block = gblock - unblock = gunblock - -- XXX when Haskeline's MonadException changes, we can drop our - -- deprecated block/unblock methods - -instance ExceptionMonad (InputT GHCi) where - gcatch = Haskeline.catch - gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong - gblock = Haskeline.block - gunblock = Haskeline.unblock - -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) }) - -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 - liftIO $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc - -runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult) -runStmt expr step = do - st <- getGHCiState - reifyGHCi $ \x -> - withProgName (progname st) $ - withArgs (args st) $ - reflectGHCi x $ do - GHC.handleSourceError (\e -> do GHC.printException e; - return Nothing) $ do - r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step - return (Just r) - -runDecls :: String -> GHCi [GHC.Name] -runDecls decls = do - st <- getGHCiState - reifyGHCi $ \x -> - withProgName (progname st) $ - withArgs (args st) $ - reflectGHCi x $ do - GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do - GHC.runDeclsWithLocation (progname st) (line_number st) decls - -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 - liftIO rts_revertCAFs - s <- getGHCiState - when (not (ghc_e s)) $ liftIO 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 - = liftIO $ 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 addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval) diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs deleted file mode 100644 --- a/ghc/GhciTags.hs +++ /dev/null @@ -1,210 +0,0 @@ ------------------------------------------------------------------------------ --- --- GHCi's :ctags and :etags commands --- --- (c) The GHC Team 2005-2007 --- ------------------------------------------------------------------------------ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSp --- for details - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -module GhciTags ( - createCTagsWithLineNumbersCmd, - createCTagsWithRegExesCmd, - createETagsFileCmd -) where - -import Exception -import GHC -import 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 - ------------------------------------------------------------------------------ --- 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 realLoc - | tyThing <- catMaybes mbTyThings - , let name = getName tyThing - , let exported = GHC.modInfoIsExportedName mInfo name - , let kind = tyThing2TagKind tyThing - , let loc = srcSpanStart (nameSrcSpan name) - , RealSrcLoc realLoc <- [loc] - ] - - where - tyThing2TagKind (AnId _) = 'v' - tyThing2TagKind (ADataCon _) = 'd' - tyThing2TagKind (ATyCon _) = 't' - tyThing2TagKind (ACoAxiom _) = 'x' - - -data TagInfo = TagInfo - { tagExported :: Bool -- is tag exported - , tagKind :: Char -- tag kind - , tagName :: String -- tag name - , tagFile :: String -- file name - , tagLine :: Int -- line number - , tagCol :: Int -- column number - , tagSrcInfo :: Maybe (String,Integer) -- source code line and char offset - } - - --- get tag info, for later translation into Vim or Emacs style -tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc -> 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 - tryIO (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 - tryIO (writeFile file tags) - -collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs - tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos - let tagGroups = map processGroup tagInfoGroups - tryIO (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 - 1) srcLine ++ tag - ++ "\x7f" ++ tag - ++ "\x01" ++ show lineNo - ++ "," ++ show charPos -showETag _ = ghcError (CmdLineError "missing source file info in showETag") - diff --git a/ghc/HsVersions.h b/ghc/HsVersions.h deleted file mode 100644 --- a/ghc/HsVersions.h +++ /dev/null @@ -1,8 +0,0 @@ -/* Hack needed because of http://hackage.haskell.org/trac/ghc/ticket/8040 */ - -#define ASSERT(e) if True && not (e) then (assertPanic __FILE__ __LINE__) else - -#define GLOBAL_VAR(name,value,ty) \ -{-# NOINLINE name #-}; \ -name :: IORef (ty); \ -name = Util.global (value); diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs deleted file mode 100644 --- a/ghc/InteractiveUI.hs +++ /dev/null @@ -1,2878 +0,0 @@ -{-# OPTIONS -fno-cse #-} --- -fno-cse is needed for GLOBAL_VAR's to behave properly - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSp --- for details - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} ------------------------------------------------------------------------------ --- --- GHC Interactive User Interface --- --- (c) The GHC Team 2005-2006 --- ------------------------------------------------------------------------------ - -module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where - -#include "HsVersions.h" - -import qualified Paths_ghci_ng -import Data.Version (showVersion) - -import qualified GhciMonad -import GhciMonad hiding ( runStmt ) -import GhciTags -import Debugger - --- The GHC interface -import qualified GHC -import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), - TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, - handleSourceError ) -import PprTyThing -import DynFlags -import qualified Lexer -import StringBuffer - -import Packages -import UniqFM - -import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs ) -import HsImpExp -import RdrName ( getGRE_NameQualifier_maybes ) -import Outputable hiding ( printForUser, printForUserPartWay, bold ) -import Module -import Name -import SrcLoc - --- Other random utilities -import Digraph -import BasicTypes hiding ( isTopLevel ) -import Panic hiding ( showException ) -import Config -import StaticFlags -import Linker -import Util( on, global, toArgs, toCmdArgs, removeSpaces, getCmd, - filterOut, seqList, looksLikeModuleName, partitionWith ) -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 Exception hiding (catch, block, unblock) - -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.Unsafe ( unsafePerformIO ) -import System.IO.Error -import Data.Char -import Data.Array -import Control.Monad as Monad -import Text.Printf -import Foreign.Safe -import GHC.Exts ( unsafeCoerce# ) -import Control.Applicative hiding (empty) - -import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) -import GHC.IO.Handle ( hFlushAll ) - -import GHC.TopHandler - -import Data.IORef ( IORef, readIORef, writeIORef ) - --- backported (available in base-4.6) -readMaybe :: Read a => String -> Maybe a -readMaybe s = case reads s of - [(x,s')] | all isSpace s' -> Just x - _ -> Nothing - ------------------------------------------------------------------------------ - -ghciWelcomeMsg :: String -ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ - " [NG/" ++ showVersion Paths_ghci_ng.version ++ "]" ++ - ": 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), - ("complete", keepGoing completeCmd', 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), - ("issafe", keepGoing' isSafeCmd, completeModule), - ("kind", keepGoing' (kindOfType False), completeIdentifier), - ("kind!", keepGoing' (kindOfType True), completeIdentifier), - ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), - ("list", keepGoing' listCmd, noCompletion), - ("module", keepGoing moduleCmd, completeSetModule), - ("main", keepGoing runMain, completeFilename), - ("print", keepGoing printCmd, completeExpression), - ("quit", quit, noCompletion), - ("reload", keepGoing' reloadModule, noCompletion), - ("run", keepGoing runRun, completeFilename), - ("script", keepGoing' scriptCmd, completeFilename), - ("set", keepGoing setCmd, completeSetOptions), - ("show", keepGoing showCmd, completeShowOptions), - ("sprint", keepGoing sprintCmd, completeExpression), - ("step", keepGoing stepCmd, completeIdentifier), - ("steplocal", keepGoing stepLocalCmd, completeIdentifier), - ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), - ("type", keepGoing' typeOfExpr, completeExpression), - ("trace", keepGoing traceCmd, completeExpression), - ("undef", keepGoing undefineMacro, completeMacro), - ("unset", keepGoing unsetOptions, completeSetOptions) - ] - - --- We initialize readline (in the interactiveUI function) to use --- word_break_chars as the default set of completion word break characters. --- This can be overridden for a particular command (for example, filename --- expansion shouldn't consider '/' to be a word break) by setting the third --- entry in the Command tuple above. --- --- NOTE: in order for us to override the default correctly, any custom entry --- must be a SUBSET of word_break_chars. -word_break_chars :: String -word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" - specials = "(),;[]`{}" - spaces = " \t\n" - in spaces ++ specials ++ symbols - -flagWordBreakChars :: String -flagWordBreakChars = " \t\n" - - -keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool) -keepGoing a str = keepGoing' (lift . a) str - -keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool -keepGoing' a str = a str >> return False - -keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool) -keepGoingPaths a str - = do case toArgs str of - Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr - Right args -> a args - return False - -shortHelpText :: String -shortHelpText = "use :? for help.\n" - -helpText :: String -helpText = - " Commands available from the prompt:\n" ++ - "\n" ++ - " evaluate/run \n" ++ - " : repeat last command\n" ++ - " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ - " :add [*] ... add module(s) to the current target set\n" ++ - " :browse[!] [[*]] display the names defined by module \n" ++ - " (!: more details; *: all top-level names)\n" ++ - " :cd change directory to \n" ++ - " :cmd run the commands returned by ::IO String\n" ++ - " :complete [] list completions for partial input string\n" ++ - " :ctags[!] [] create tags file for Vi (default: \"tags\")\n" ++ - " (!: use regex instead of line number)\n" ++ - " :def define a command :\n" ++ - " :edit edit file\n" ++ - " :edit edit last module\n" ++ - " :etags [] create tags file for Emacs (default: \"TAGS\")\n" ++ - " :help, :? display this list of commands\n" ++ - " :info [ ...] display information about the given names\n" ++ - " :issafe [] display safe haskell information of module \n" ++ - " :kind show the kind of \n" ++ - " :load [*] ... load module(s) and their dependents\n" ++ - " :main [ ...] run the main function with the given arguments\n" ++ - " :module [+/-] [*] ... set the context for expression evaluation\n" ++ - " :quit exit GHCi\n" ++ - " :reload reload the current module set\n" ++ - " :run function [ ...] run the function with the given arguments\n" ++ - " :script run the script \n" ++ - " :type show the type of \n" ++ - " :undef undefine user-defined command :\n" ++ - " :! run the shell command \n" ++ - "\n" ++ - " -- Commands for debugging:\n" ++ - "\n" ++ - " :abandon at a breakpoint, abandon current computation\n" ++ - " :back go back in the history (after :trace)\n" ++ - " :break [] [] set a breakpoint at the specified location\n" ++ - " :break set a breakpoint on the specified function\n" ++ - " :continue resume after a breakpoint\n" ++ - " :delete delete the specified breakpoint\n" ++ - " :delete * delete all breakpoints\n" ++ - " :force print , forcing unevaluated parts\n" ++ - " :forward go forward in the history (after :back)\n" ++ - " :history [] after :trace, show the execution history\n" ++ - " :list show the source code around current breakpoint\n" ++ - " :list identifier show the source code for \n" ++ - " :list [] show the source code around line number \n" ++ - " :print [ ...] prints a value without forcing its computation\n" ++ - " :sprint [ ...] simplifed version of :print\n" ++ - " :step single-step after stopping at a breakpoint\n"++ - " :step single-step into \n"++ - " :steplocal single-step within the current top-level binding\n"++ - " :stepmodule single-step restricted to the current module\n"++ - " :trace trace after stopping at a breakpoint\n"++ - " :trace evaluate with tracing on (see :history)\n"++ - - "\n" ++ - " -- Commands for changing settings:\n" ++ - "\n" ++ - " :set