ghci-ng 7.6.3.5 → 10.0.0
raw patch · 9 files changed
+1329/−393 lines, 9 filesdep +containersdep +sybdep +timedep ~arraydep ~basedep ~bytestringnew-uploader
Dependencies added: containers, syb, time
Dependency ranges changed: array, base, bytestring, directory, filepath, ghc, ghc-paths, process, transformers, unix
Files
- ghc/GhciFind.hs +264/−0
- ghc/GhciInfo.hs +210/−0
- ghc/GhciMonad.hs +36/−26
- ghc/GhciTags.hs +10/−8
- ghc/GhciTypes.hs +57/−0
- ghc/InteractiveUI.hs +475/−170
- ghc/Main.hs +199/−116
- ghc/hschooks.c +23/−2
- ghci-ng.cabal +55/−71
+ ghc/GhciFind.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE BangPatterns #-}++-- | Find type/location information.++module GhciFind+ (findType,findLoc,findNameUses)+ where++import Control.Monad+import Data.List+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe++import FastString+import GHC+import GhcMonad+import GhciInfo (showppr)+import GhciTypes+import Name+import SrcLoc+import System.Directory+import Var++-- | Find any uses of the given identifier in the codebase.+findNameUses :: (GhcMonad m)+ => Map ModuleName ModInfo+ -> FilePath+ -> String+ -> Int+ -> Int+ -> Int+ -> Int+ -> m (Either String [SrcSpan])+findNameUses infos fp string sl sc el ec =+ do mname <- guessModule infos fp+ case mname of+ Nothing ->+ return (Left "Couldn't guess that module name. Does it exist?")+ Just name ->+ case M.lookup name infos of+ Nothing ->+ return (Left ("No module info for the current file! Try loading it?"))+ Just info ->+ do mname' <- findName infos info string sl sc el ec+ case mname' of+ Left e -> return (Left e)+ Right name' ->+ case getSrcSpan name' of+ UnhelpfulSpan{} ->+ do d <- getSessionDynFlags+ return (Left ("Found a name, but no location information. The module is: " +++ maybe "<unknown>"+ (showppr d . moduleName)+ (nameModule_maybe name')))+ span' ->+ return (Right (stripSurrounding+ (span' :+ map makeSrcSpan+ (filter ((== Just name') .+ fmap getName .+ spaninfoVar)+ (modinfoSpans info)))))+ where makeSrcSpan (SpanInfo sl' sc' el' ec' _ _) =+ RealSrcSpan+ (mkRealSrcSpan+ (mkRealSrcLoc (mkFastString fp)+ sl'+ (1 + sc'))+ (mkRealSrcLoc (mkFastString fp)+ el'+ (1 + ec')))++-- | Strip out spans which surrounding other spans in a parent->child+-- fashion. Those are useless.+stripSurrounding :: [SrcSpan] -> [SrcSpan]+stripSurrounding xs =+ mapMaybe (\x -> if any (\y -> overlaps x y && x /= y) xs+ then Nothing+ else Just x)+ xs++-- | Does x overlap y in x `overlaps` y?+overlaps :: SrcSpan -> SrcSpan -> Bool+overlaps y x =+ case (x,y) of+ (RealSrcSpan x',RealSrcSpan y') ->+ realSrcSpanStart y' <= realSrcSpanStart x' &&+ realSrcSpanEnd y' >= realSrcSpanEnd x'+ _ -> False++-- | Try to find the location of the given identifier at the given+-- position in the module.+findLoc :: (GhcMonad m)+ => Map ModuleName ModInfo+ -> FilePath+ -> String+ -> Int+ -> Int+ -> Int+ -> Int+ -> m (Either String SrcSpan)+findLoc infos fp string sl sc el ec =+ do mname <- guessModule infos fp+ case mname of+ Nothing ->+ return (Left "Couldn't guess that module name. Does it exist?")+ Just name ->+ case M.lookup name infos of+ Nothing ->+ return (Left ("No module info for the current file! Try loading it?"))+ Just info ->+ do mname' <- findName infos info string sl sc el ec+ d <- getSessionDynFlags+ case mname' of+ Left reason ->+ return (Left reason)+ Right name' ->+ case getSrcSpan name' of+ UnhelpfulSpan{} ->+ return (Left ("Found a name, but no location information. The module is: " +++ maybe "<unknown>"+ (showppr d . moduleName)+ (nameModule_maybe name')))+ span' ->+ return (Right span')++-- | Try to resolve the name located at the given position, or+-- otherwise resolve based on the current module's scope.+findName :: GhcMonad m+ => Map ModuleName ModInfo+ -> ModInfo+ -> String+ -> Int+ -> Int+ -> Int+ -> Int+ -> m (Either String Name)+findName infos mi string sl sc el ec =+ case resolveName (modinfoSpans mi)+ sl+ sc+ el+ ec of+ Nothing -> tryExternalModuleResolution+ Just name ->+ case getSrcSpan name of+ UnhelpfulSpan{} -> tryExternalModuleResolution+ _ -> return (Right (getName name))+ where tryExternalModuleResolution =+ case find (matchName string)+ (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of+ Nothing ->+ return (Left "Couldn't resolve to any modules.")+ Just imported -> resolveNameFromModule infos imported+ matchName :: String -> Name -> Bool+ matchName str name =+ str ==+ occNameString (getOccName name)++-- | Try to resolve the name from another (loaded) module's exports.+resolveNameFromModule :: GhcMonad m+ => Map ModuleName ModInfo+ -> Name+ -> m (Either String Name)+resolveNameFromModule infos name =+ do d <- getSessionDynFlags+ case nameModule_maybe name of+ Nothing ->+ return (Left ("No module for " +++ showppr d name))+ Just modL ->+ do case M.lookup (moduleName modL) infos of+ Nothing ->+#if __GLASGOW_HASKELL__ >= 709+ do (return (Left (showppr d (modulePackageKey modL) ++ ":" +++#else+ do (return (Left (showppr d (modulePackageId modL) ++ ":" +++#endif+ showppr d modL)))+ Just info ->+ case find (matchName name)+ (modInfoExports (modinfoInfo info)) of+ Just name' ->+ return (Right name')+ Nothing ->+ return (Left "No matching export in any local modules.")+ where matchName :: Name -> Name -> Bool+ matchName x y =+ occNameString (getOccName x) ==+ occNameString (getOccName y)++-- | Try to resolve the type display from the given span.+resolveName :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe Var+resolveName spans' sl sc el ec =+ listToMaybe (mapMaybe spaninfoVar (filter inside (reverse spans')))+ where inside (SpanInfo sl' sc' el' ec' _ _) =+ ((sl' == sl && sc' >= sc) || (sl' > sl)) &&+ ((el' == el && ec' <= ec) || (el' < el))++-- | Try to find the type of the given span.+findType :: GhcMonad m+ => Map ModuleName ModInfo+ -> FilePath+ -> String+ -> Int+ -> Int+ -> Int+ -> Int+ -> m (Either String (ModInfo, Type))+findType infos fp string sl sc el ec =+ do mname <- guessModule infos fp+ case mname of+ Nothing ->+ return (Left "Couldn't guess that module name. Does it exist?")+ Just name ->+ case M.lookup name infos of+ Nothing ->+ return (Left ("Couldn't guess the module nameIs this module loaded?"))+ Just info ->+ do let !mty =+ resolveType (modinfoSpans info)+ sl+ sc+ el+ ec+ case mty of+ Just ty -> return (Right (info, ty))+ Nothing ->+ fmap (Right . (,) info) (exprType string)++-- | Try to resolve the type display from the given span.+resolveType :: [SpanInfo] -> Int -> Int -> Int -> Int -> Maybe Type+resolveType spans' sl sc el ec =+ join (fmap spaninfoType (find inside (reverse spans')))+ where inside (SpanInfo sl' sc' el' ec' _ _) =+ ((sl' == sl && sc' >= sc) || (sl' > sl)) &&+ ((el' == el && ec' <= ec) || (el' < el))++-- | Guess a module name from a file path.+guessModule :: GhcMonad m+ => Map ModuleName ModInfo -> FilePath -> m (Maybe ModuleName)+guessModule infos fp =+ do target <- guessTarget fp Nothing+ case targetId target of+ TargetModule mn -> return (Just mn)+ TargetFile fp' _ ->+ case find ((Just fp' ==) .+ ml_hs_file . ms_location . modinfoSummary . snd)+ (M.toList infos) of+ Just (mn,_) -> return (Just mn)+ Nothing ->+ do fp'' <- liftIO (makeRelativeToCurrentDirectory fp')+ target' <- guessTarget fp'' Nothing+ case targetId target' of+ TargetModule mn ->+ return (Just mn)+ _ ->+ case find ((Just fp'' ==) .+ ml_hs_file . ms_location . modinfoSummary . snd)+ (M.toList infos) of+ Just (mn,_) ->+ return (Just mn)+ Nothing -> return Nothing
+ ghc/GhciInfo.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++-- | Get information on modules, identifiers, etc.++module GhciInfo (collectInfo,getModInfo,showppr) where++import Control.Exception+import Control.Monad+import qualified CoreUtils+import Data.Data+import Data.Generics (GenericQ, mkQ, extQ)+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Time+import Desugar+import GHC+import GhcMonad+import GhciTypes+import NameSet+import Outputable+import Prelude hiding (mod)+import System.Directory+import TcHsSyn+import Var++#if MIN_VERSION_ghc(7,8,3)+#else+import Bag+#endif++-- | Collect type info data for the loaded modules.+collectInfo :: (GhcMonad m)+ => Map ModuleName ModInfo -> [ModuleName] -> m (Map ModuleName ModInfo)+collectInfo ms loaded =+ do df <- getSessionDynFlags+ invalidated <- liftIO (filterM cacheInvalid loaded)+ if null invalidated+ then return ms+ else do liftIO (putStrLn ("Collecting type info for " +++ show (length invalidated) +++ " module(s) ... "))+ foldM (\m name ->+ gcatch (do info <- getModInfo name+ return (M.insert name info m))+ (\(e :: SomeException) ->+ do liftIO (putStrLn ("Error while getting type info from " +++ showppr df name +++ ": " ++ show e))+ return m))+ ms+ invalidated+ where cacheInvalid name =+ case M.lookup name ms of+ Nothing -> return True+ Just mi ->+ do let fp =+ ml_obj_file (ms_location (modinfoSummary mi))+ last' = modinfoLastUpdate mi+ exists <- doesFileExist fp+ if exists+ then do mod <- getModificationTime fp+ return (mod > last')+ else return True++-- | Get info about the module: summary, types, etc.+getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo+getModInfo name =+ do m <- getModSummary name+ p <- parseModule m+ typechecked <- typecheckModule p+ allTypes <- processAllTypeCheckedModule typechecked+ let i = tm_checked_module_info typechecked+ now <- liftIO getCurrentTime+ return (ModInfo m allTypes i now)++-- | Get ALL source spans in the module.+processAllTypeCheckedModule :: GhcMonad m+ => TypecheckedModule -> m [SpanInfo]+processAllTypeCheckedModule tcm =+ do let tcs = tm_typechecked_source tcm+ bs = listifyAllSpans tcs :: [LHsBind Id]+ es = listifyAllSpans tcs :: [LHsExpr Id]+ ps = listifyAllSpans tcs :: [LPat Id]+ bts <- mapM (getTypeLHsBind tcm) bs+ ets <- mapM (getTypeLHsExpr tcm) es+ pts <- mapM (getTypeLPat tcm) ps+ return (mapMaybe toSpanInfo (sortBy cmp (concat bts ++ catMaybes (concat [ets,pts]))))+ where cmp (_,a,_) (_,b,_)+ | a `isSubspanOf` b = LT+ | b `isSubspanOf` a = GT+ | otherwise = EQ++getTypeLHsBind :: (GhcMonad m)+ => TypecheckedModule+ -> LHsBind Id+ -> m [(Maybe Id,SrcSpan,Type)]+#if MIN_VERSION_ghc(7,8,3)+getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _}) =+ return (return (Just (unLoc pid),getLoc pid,varType (unLoc pid)))+#else+getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ}) =+ return (return (Just (unLoc pid),getLoc pid,varType (unLoc pid)))+#endif+#if MIN_VERSION_ghc(7,8,3)+#else+getTypeLHsBind m (L _spn AbsBinds{abs_binds = binds}) =+ fmap concat+ (mapM (getTypeLHsBind m)+ (map snd (bagToList binds)))+#endif+getTypeLHsBind _ _ = return []+-- getTypeLHsBind _ x =+-- do df <- getSessionDynFlags+-- error ("getTypeLHsBind: unhandled case: " +++-- showppr df x)++getTypeLHsExpr :: (GhcMonad m)+ => TypecheckedModule+ -> LHsExpr Id+ -> m (Maybe (Maybe Id,SrcSpan,Type))+getTypeLHsExpr _ e =+ do hs_env <- getSession+ (_,mbe) <- liftIO (deSugarExpr hs_env e)+ case mbe of+ Nothing -> return Nothing+ Just expr ->+ return (Just (case unwrapVar (unLoc e) of+ HsVar i -> Just i+ _ -> Nothing+ ,getLoc e+ ,CoreUtils.exprType expr))+ where unwrapVar (HsWrap _ var) = var+ unwrapVar e' = e'++-- | Get id and type for patterns.+getTypeLPat :: (GhcMonad m)+ => TypecheckedModule -> LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type))+getTypeLPat _ (L spn pat) =+ return (Just (getMaybeId pat,spn,hsPatType pat))+ where getMaybeId (VarPat vid) = Just vid+ getMaybeId _ = Nothing++-- | Get ALL source spans in the source.+listifyAllSpans :: Typeable a+ => TypecheckedSource -> [Located a]+listifyAllSpans tcs =+ listifyStaged TypeChecker p tcs+ where p (L spn _) = isGoodSrcSpan spn++listifyStaged :: Typeable r+ => Stage -> (r -> Bool) -> GenericQ [r]+listifyStaged s p =+ everythingStaged+ s+ (++)+ []+ ([] `mkQ`+ (\x -> [x | p x]))++------------------------------------------------------------------------------+-- The following was taken from 'ghc-syb-utils'+--+-- ghc-syb-utils:+-- https://github.com/nominolo/ghc-syb++-- | Ghc Ast types tend to have undefined holes, to be filled+-- by later compiler phases. We tag Asts with their source,+-- so that we can avoid such holes based on who generated the Asts.+data Stage+ = Parser+ | Renamer+ | TypeChecker+ deriving (Eq,Ord,Show)++-- | Like 'everything', but avoid known potholes, based on the 'Stage' that+-- generated the Ast.+everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r+everythingStaged stage k z f x+ | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z+ | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)+ where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool+#if __GLASGOW_HASKELL__ >= 709+ postTcType = const (stage<TypeChecker) :: PostTc Id Type -> Bool+#else+ postTcType = const (stage<TypeChecker) :: PostTcType -> Bool+#endif+ fixity = const (stage<Renamer) :: GHC.Fixity -> Bool++-- | Pretty print the types into a 'SpanInfo'.+toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo+toSpanInfo (n,mspan,typ) =+ case mspan of+ RealSrcSpan spn ->+ Just (SpanInfo (srcSpanStartLine spn)+ (srcSpanStartCol spn - 1)+ (srcSpanEndLine spn)+ (srcSpanEndCol spn - 1)+ (Just typ)+ n)+ _ -> Nothing++-- | Pretty print something to string.+showppr :: Outputable a+ => DynFlags -> a -> String+showppr dflags =+ showSDocForUser dflags neverQualify .+ ppr
ghc/GhciMonad.hs view
@@ -19,6 +19,7 @@ getDynFlags, runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,+ printForUserNeverQualify, printForUserModInfo, printForUser, printForUserPartWay, prettyLocations, initInterpBuffering, turnOffBuffering, flushInterpBuffers,@@ -26,6 +27,10 @@ #include "HsVersions.h" +-- ghci-ng+import GhciTypes+import Data.Map.Strict (Map)+ import qualified GHC import GhcMonad hiding (liftIO) import Outputable hiding (printForUser, printForUserPartWay)@@ -37,7 +42,6 @@ import Module import ObjLink import Linker-import qualified MonadUtils import Exception import Numeric@@ -47,13 +51,16 @@ import System.CPUTime import System.Environment import System.IO-import Control.Monad as Monad+#if __GLASGOW_HASKELL__ < 709+import Control.Applicative (Applicative(..))+#endif+import Control.Monad import GHC.Exts import System.Console.Haskeline (CompletionFunc, InputT) import qualified System.Console.Haskeline as Haskeline-import Control.Monad.Trans.Class as Trans-import Control.Monad.IO.Class as Trans+import Control.Monad.Trans.Class+import Control.Monad.IO.Class ----------------------------------------------------------------------------- -- GHCi monad@@ -104,7 +111,8 @@ -- help text to display to a user short_help :: String,- long_help :: String+ long_help :: String,+ mod_infos :: !(Map ModuleName ModInfo) } type TickArray = Array Int [(BreakIndex,SrcSpan)]@@ -114,6 +122,7 @@ | ShowType -- show the type of expressions | RevertCAFs -- revert CAFs after every evaluation | Multiline -- use multiline commands+ | CollectInfo -- collect and cache information about modules after load deriving Eq data BreakLocation@@ -169,13 +178,17 @@ startGHCi :: GHCi a -> GHCiState -> Ghc a startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref +instance Functor GHCi where+ fmap = liftM++instance Applicative GHCi where+ pure = return+ (<*>) = ap+ 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- getGHCiState :: GHCi GHCiState getGHCiState = GHCi $ \r -> liftIO $ readIORef r setGHCiState :: GHCiState -> GHCi ()@@ -186,11 +199,8 @@ 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 MonadIO GHCi where+ liftIO = liftGhc . liftIO instance HasDynFlags GHCi where getDynFlags = getSessionDynFlags@@ -206,13 +216,8 @@ 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@@ -220,9 +225,6 @@ in unGHCi (f g_restore) s -instance MonadIO GHCi where- liftIO = MonadUtils.liftIO- instance Haskeline.MonadException Ghc where controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)@@ -237,9 +239,6 @@ gcatch = Haskeline.catch gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_) - gblock = Haskeline.liftIOOp_ gblock- gunblock = Haskeline.liftIOOp_ gunblock- isOptionSet :: GHCiOption -> GHCi Bool isOptionSet opt = do st <- getGHCiState@@ -255,11 +254,23 @@ = do st <- getGHCiState setGHCiState (st{ options = filter (/= opt) (options st) }) +printForUserNeverQualify :: GhcMonad m => SDoc -> m ()+printForUserNeverQualify doc = do+ dflags <- getDynFlags+ liftIO $ Outputable.printForUser dflags stdout neverQualify doc++printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()+printForUserModInfo info doc = do+ dflags <- getDynFlags+ mUnqual <- GHC.mkPrintUnqualifiedForModule info+ unqual <- maybe GHC.getPrintUnqual return mUnqual+ liftIO $ Outputable.printForUser dflags stdout unqual doc+ printForUser :: GhcMonad m => SDoc -> m () printForUser doc = do unqual <- GHC.getPrintUnqual dflags <- getDynFlags- MonadUtils.liftIO $ Outputable.printForUser dflags stdout unqual doc+ liftIO $ Outputable.printForUser dflags stdout unqual doc printForUserPartWay :: SDoc -> GHCi () printForUserPartWay doc = do@@ -396,4 +407,3 @@ getHandle ref = do (Ptr addr) <- readIORef ref case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval)-
ghc/GhciTags.hs view
@@ -22,6 +22,7 @@ -- into the GHC API instead import Name (nameOccName) import OccName (pprOccName)+import ConLike import MonadUtils import Data.Function@@ -82,7 +83,7 @@ -- should we just skip these? when (not is_interpreted) $ let mName = GHC.moduleNameString (GHC.moduleName m) in- ghcError (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))+ throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted")) mbModInfo <- GHC.getModuleInfo m case mbModInfo of Nothing -> return []@@ -103,10 +104,11 @@ ] where- tyThing2TagKind (AnId _) = 'v'- tyThing2TagKind (ADataCon _) = 'd'- tyThing2TagKind (ATyCon _) = 't'- tyThing2TagKind (ACoAxiom _) = 'x'+ tyThing2TagKind (AnId _) = 'v'+ tyThing2TagKind (AConLike RealDataCon{}) = 'd'+ tyThing2TagKind (AConLike PatSynCon{}) = 'p'+ tyThing2TagKind (ATyCon _) = 't'+ tyThing2TagKind (ACoAxiom _) = 'x' data TagInfo = TagInfo@@ -148,7 +150,7 @@ tryIO (writeFile file $ concat tagGroups) where- processGroup [] = ghcError (CmdLineError "empty tag file group??")+ processGroup [] = throwGhcException (CmdLineError "empty tag file group??") processGroup group@(tagInfo:_) = let tags = unlines $ map showETag group in "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags@@ -160,7 +162,7 @@ mapM addTagSrcInfo groups where- addTagSrcInfo [] = ghcError (CmdLineError "empty tag file group??")+ addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??") addTagSrcInfo group@(tagInfo:_) = do file <- readFile $tagFile tagInfo let sortedGroup = sortBy (comparing tagLine) group@@ -200,5 +202,5 @@ ++ "\x7f" ++ tag ++ "\x01" ++ show lineNo ++ "," ++ show charPos-showETag _ = ghcError (CmdLineError "missing source file info in showETag")+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
+ ghc/GhciTypes.hs view
@@ -0,0 +1,57 @@+-- | Types used separate to GHCi vanilla.++module GhciTypes where++import Data.Time+import GHC+import Outputable++-- | Info about a module. This information is generated every time a+-- module is loaded.+data ModInfo =+ ModInfo {modinfoSummary :: !ModSummary+ -- ^ Summary generated by GHC. Can be used to access more+ -- information about the module.+ ,modinfoSpans :: ![SpanInfo]+ -- ^ Generated set of information about all spans in the+ -- module that correspond to some kind of identifier for+ -- which there will be type info and/or location info.+ ,modinfoInfo :: !ModuleInfo+ -- ^ Again, useful from GHC for accessing information+ -- (exports, instances, scope) from a module.+ ,modinfoLastUpdate :: !UTCTime+ }++-- | Type of some span of source code. Most of these fields are+-- unboxed but Haddock doesn't show that.+data SpanInfo =+ SpanInfo {spaninfoStartLine :: {-# UNPACK #-} !Int+ -- ^ Start line of the span.+ ,spaninfoStartCol :: {-# UNPACK #-} !Int+ -- ^ Start column of the span.+ ,spaninfoEndLine :: {-# UNPACK #-} !Int+ -- ^ End line of the span (absolute).+ ,spaninfoEndCol :: {-# UNPACK #-} !Int+ -- ^ End column of the span (absolute).+ ,spaninfoType :: !(Maybe Type)+ -- ^ A pretty-printed representation fo the type.+ ,spaninfoVar :: !(Maybe Id)+ -- ^ The actual 'Var' associated with the span, if+ -- any. This can be useful for accessing a variety of+ -- information about the identifier such as module,+ -- locality, definition location, etc.+ }++instance Outputable SpanInfo where+ ppr (SpanInfo sl sc el ec ty v) =+ (int sl <>+ text ":" <>+ int sc <>+ text "-") <>+ (int el <>+ text ":" <>+ int ec <>+ text ": ") <>+ (ppr v <>+ text " :: " <>+ ppr ty)
ghc/InteractiveUI.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}+ {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly @@ -21,7 +24,12 @@ -- GHCi-ng import qualified Paths_ghci_ng-import Data.Version (showVersion)+import Data.Version (showVersion)+import qualified Data.Map as M+import GhciInfo+import GhciTypes+import GhciFind+import GHC (getModuleGraph) -- GHCi import qualified GhciMonad ( args, runStmt )@@ -37,18 +45,24 @@ TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, handleSourceError ) import HsImpExp-import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, +import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, setInteractivePrintName ) import Module import Name+#if __GLASGOW_HASKELL__ < 709 import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap )+#else+import Packages ( trusted, getPackageDetails, listVisibleModuleNames )+#endif import PprTyThing import RdrName ( getGRE_NameQualifier_maybes ) import SrcLoc import qualified Lexer import StringBuffer+#if __GLASGOW_HASKELL__ < 709 import UniqFM ( eltsUFM )+#endif import Outputable hiding ( printForUser, printForUserPartWay, bold ) -- Other random utilities@@ -83,9 +97,12 @@ import Exception hiding (catch) import Foreign.C+#if __GLASGOW_HASKELL__ < 709 import Foreign.Safe+#else+import Foreign+#endif -import System.Cmd import System.Directory import System.Environment import System.Exit ( exitWith, ExitCode(..) )@@ -93,6 +110,7 @@ import System.IO import System.IO.Error import System.IO.Unsafe ( unsafePerformIO )+import System.Process import Text.Printf import Text.Read ( readMaybe ) @@ -107,6 +125,17 @@ import GHC.IO.Handle ( hFlushAll ) import GHC.TopHandler ( topHandler ) +#if __GLASGOW_HASKELL__ < 709+packageString :: PackageId -> String+packageString = packageIdString+modulePackage :: Module -> PackageId+modulePackage = modulePackageId+#else+packageString :: PackageKey -> String+packageString = packageKeyString+modulePackage :: Module -> PackageKey+modulePackage = modulePackageKey+#endif ----------------------------------------------------------------------------- @@ -129,7 +158,7 @@ } ghciWelcomeMsg :: String-ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion +++ghciWelcomeMsg = "GHCi-ng, version " ++ cProjectVersion ++ " [NG/" ++ showVersion Paths_ghci_ng.version ++ "]" ++ ": http://www.haskell.org/ghc/ :? for help" @@ -151,7 +180,7 @@ ("cd", keepGoing' changeDirectory, completeFilename), ("check", keepGoing' checkModule, completeHomeModule), ("continue", keepGoing continueCmd, noCompletion),- ("complete", keepGoing completeCmd', noCompletion),+ ("complete", keepGoing completeCmd, noCompletion), ("cmd", keepGoing cmdCmd, completeExpression), ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename), ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),@@ -164,7 +193,8 @@ ("forward", keepGoing forwardCmd, noCompletion), ("help", keepGoing help, noCompletion), ("history", keepGoing historyCmd, noCompletion),- ("info", keepGoing' info, completeIdentifier),+ ("info", keepGoing' (info False), completeIdentifier),+ ("info!", keepGoing' (info True), completeIdentifier), ("issafe", keepGoing' isSafeCmd, completeModule), ("kind", keepGoing' (kindOfType False), completeIdentifier), ("kind!", keepGoing' (kindOfType True), completeIdentifier),@@ -186,6 +216,10 @@ ("steplocal", keepGoing stepLocalCmd, completeIdentifier), ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), ("type", keepGoing' typeOfExpr, completeExpression),+ ("type-at", keepGoing' typeAt, completeExpression),+ ("all-types", keepGoing' allTypes, completeExpression),+ ("uses", keepGoing' findAllUses, completeExpression),+ ("loc-at", keepGoing' locationAt, completeExpression), ("trace", keepGoing traceCmd, completeExpression), ("undef", keepGoing undefineMacro, completeMacro), ("unset", keepGoing unsetOptions, completeSetOptions)@@ -247,9 +281,11 @@ " :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" +++ " :info[!] [<name> ...] display information about the given names\n" +++ " (!: do not filter instances)\n" ++ " :issafe [<mod>] display safe haskell information of module <mod>\n" ++- " :kind <type> show the kind of <type>\n" +++ " :kind[!] <type> show the kind of <type>\n" +++ " (!: also print the normalised 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" ++@@ -258,7 +294,16 @@ " :run function [<arguments> ...] run the function with the given arguments\n" ++ " :script <filename> run the script <filename>\n" ++ " :type <expr> show the type of <expr>\n" +++ " :type-at <loc> show the type of <loc> of format: \n" +++ " <filename> <line> <col> <end-line> <end-col> <text>\n" +++ " text is used for when the span is out of date\n" ++ " :undef <cmd> undefine user-defined command :<cmd>\n" +++ " :loc-at <loc> return the location of the identifier at <loc> of format: \n" +++ " <filename> <line> <col> <end-line> <end-col> <text>\n" +++ " text is used for when the span is out of date\n" +++ " :all-types return a list of all types in the project including\n" +++ " sub-expressions and local bindings\n" +++ " :undef <cmd> undefine user-defined command :<cmd>\n" ++ " :!<command> run the shell command <command>\n" ++ "\n" ++ " -- Commands for debugging:\n" ++@@ -274,7 +319,7 @@ " :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 <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" ++@@ -304,8 +349,9 @@ " +r revert top-level expressions after each evaluation\n" ++ " +s print timing/memory stats after each evaluation\n" ++ " +t print type after evaluation\n" +++ " +c collect type/location info after loading modules\n" ++ " -<flags> most GHC command line flags can also be set here\n" ++- " (eg. -v2, -fglasgow-exts, etc.)\n" +++ " (eg. -v2, -XFlexibleInstances, etc.)\n" ++ " for GHCi-specific flags, see User's Guide,\n"++ " Flag reference, Interactive-mode options\n" ++ "\n" ++@@ -355,7 +401,7 @@ -- 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")+ throwGhcException (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@@ -373,9 +419,13 @@ initInterpBuffering -- The initial set of DynFlags used for interactive evaluation is the same- -- as the global DynFlags, plus -XExtendedDefaultRules+ -- as the global DynFlags, plus -XExtendedDefaultRules and+ -- -XNoMonomorphismRestriction. dflags <- getDynFlags- GHC.setInteractiveDynFlags (xopt_set dflags Opt_ExtendedDefaultRules)+ let dflags' = (`xopt_set` Opt_ExtendedDefaultRules)+ . (`xopt_unset` Opt_MonomorphismRestriction)+ $ dflags+ GHC.setInteractiveDynFlags dflags' liftIO $ when (isNothing maybe_exprs) $ do -- Only for GHCi (not runghc and ghc -e):@@ -388,6 +438,7 @@ -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering+ hSetBuffering stderr NoBuffering #if defined(mingw32_HOST_OS) -- On Unix, stdin will use the locale encoding. The IO library -- doesn't do this on Windows (yet), so for now we use UTF-8,@@ -416,7 +467,8 @@ transient_ctx = [], ghc_e = isJust maybe_exprs, short_help = shortHelpText config,- long_help = fullHelpText config+ long_help = fullHelpText config,+ mod_infos = M.empty } return ()@@ -434,7 +486,7 @@ runGHCi paths maybe_exprs = do dflags <- getDynFlags let- read_dot_files = not (dopt Opt_IgnoreDotGhci dflags)+ read_dot_files = not (gopt Opt_IgnoreDotGhci dflags) current_dir = return (Just ".ghci") @@ -521,7 +573,8 @@ $ topHandler e -- this used to be topHandlerFastExit, see #2228 runInputTWithPrefs defaultPrefs defaultSettings $ do- runCommands' hdle (return Nothing)+ -- make `ghc -e` exit nonzero on invalid input, see Trac #7962+ runCommands' hdle (Just $ hdle (toException $ ExitFailure 1) >> return ()) (return Nothing) -- and finally, exit liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."@@ -529,7 +582,7 @@ runGHCiInput :: InputT GHCi a -> GHCi a runGHCiInput f = do dflags <- getDynFlags- histFile <- if dopt Opt_GhciHistory dflags+ histFile <- if gopt Opt_GhciHistory dflags then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing) else return Nothing@@ -591,6 +644,11 @@ l <- liftIO $ tryIO $ hGetLine hdl case l of Left e | isEOFError e -> return Nothing+ | -- as we share stdin with the program, the program+ -- might have already closed it, so we might get a+ -- handle-closed exception. We therefore catch that+ -- too.+ isIllegalOperation e -> return Nothing | InvalidArgument <- etype -> return Nothing | otherwise -> liftIO $ ioError e where etype = ioeGetErrorType e@@ -659,7 +717,7 @@ installInteractivePrint (Just ipFun) exprmode = do ok <- trySuccess $ do (name:_) <- GHC.parseName ipFun- modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name + modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name in he{hsc_IC = new_ic}) return Succeeded @@ -667,11 +725,12 @@ -- | The main read-eval-print loop runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()-runCommands = runCommands' handler+runCommands = runCommands' handler Nothing runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+ -> Maybe (GHCi ()) -- ^ Source error handler -> InputT GHCi (Maybe String) -> InputT GHCi ()-runCommands' eh gCmd = do+runCommands' eh sourceErrorHandler gCmd = do b <- ghandle (\e -> case fromException e of Just UserInterrupt -> return $ Just False _ -> case fromException e of@@ -683,7 +742,9 @@ (runOneCommand eh gCmd) case b of Nothing -> return ()- Just _ -> runCommands' eh gCmd+ Just success -> do+ when (not success) $ maybe (return ()) lift sourceErrorHandler+ runCommands' eh sourceErrorHandler gCmd -- | Evaluate a single line of user input (either :<command> or Haskell code) runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)@@ -709,13 +770,12 @@ (\c -> case removeSpaces c of "" -> noSpace q ":{" -> multiLineCmd q- c' -> return (Just c') )+ _ -> return (Just c) ) multiLineCmd q = do st <- lift getGHCiState let p = prompt st lift $ setGHCiState st{ prompt = prompt2 st }- mb_cmd <- collectCommand q ""- lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }+ mb_cmd <- collectCommand q "" `GHC.gfinally` 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@@ -739,7 +799,7 @@ doCommand :: String -> InputT GHCi (Maybe Bool) -- command- doCommand (':' : cmd) = do+ doCommand stmt | (':' : cmd) <- removeSpaces stmt = do result <- specialCommand cmd case result of True -> return Nothing@@ -758,19 +818,35 @@ Nothing -> return $ Just True Just ml_stmt -> do -- temporarily compensate line-number for multi-line input- saved_line_num <- lift (line_number <$> getGHCiState)- lift $ getGHCiState >>= \st' -> setGHCiState st'{ line_number = fst_line_num }- result <- timeIt $ lift $ runStmt ml_stmt GHC.RunToCompletion- lift $ getGHCiState >>= \st' -> setGHCiState st'{ line_number = saved_line_num }+ result <- timeIt $ lift $ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion return $ Just result- else do- let line_ofs = if stmt_nl_cnt > 0 then stmt_nl_cnt + 1 else 0+ else do -- single line input and :{-multiline input+ last_line_num <- lift (line_number <$> getGHCiState)+ -- reconstruct first line num from last line num and stmt+ let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)+ | otherwise = last_line_num -- single line input+ stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]+ stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines -- temporarily compensate line-number for multi-line input- lift $ getGHCiState >>= \st' -> setGHCiState st'{ line_number = line_number st' - line_ofs }- result <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion- lift $ getGHCiState >>= \st' -> setGHCiState st'{ line_number = line_number st' + line_ofs }+ result <- timeIt $ lift $ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion return $ Just result + -- runStmt wrapper for temporarily overridden line-number+ runStmtWithLineNum :: Int -> String -> SingleStep -> GHCi Bool+ runStmtWithLineNum lnum stmt step = do+ st0 <- getGHCiState+ setGHCiState st0 { line_number = lnum }+ result <- runStmt stmt step+ -- restore original line_number+ getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }+ return result++ -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'+ dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s+ , all isSpace l0 = dropLeadingWhiteLines r+ | otherwise = s++ -- #4316 -- lex the input. If there is an unclosed layout context, request input checkInputForLayout :: String -> InputT GHCi (Maybe String)@@ -809,7 +885,13 @@ eof <- Lexer.nextIsEOF if eof then Lexer.activeContext+#if __GLASGOW_HASKELL__ < 709 else Lexer.lexer return >> goToEnd+#else+-- In 7.10 GHC API a bool "queueComments" was added.+-- @see https://downloads.haskell.org/~ghc/latest/docs/html/libraries/ghc-7.10.1/src/Lexer.html#lexer+ else Lexer.lexer True return >> goToEnd+#endif enqueueCommands :: [String] -> GHCi () enqueueCommands cmds = do@@ -853,7 +935,7 @@ -- | Clean up the GHCi environment after a statement has run afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool-afterRunStmt _ (GHC.RunException e) = throw e+afterRunStmt _ (GHC.RunException e) = liftIO $ Exception.throwIO e afterRunStmt step_here run_result = do resumes <- GHC.getResumeContext case run_result of@@ -962,16 +1044,24 @@ lookupCommand' str' = do macros <- liftIO $ readIORef macros_ref ghci_cmds <- ghci_commands `fmap` getGHCiState- let{ (str, cmds) = case str' of- ':' : rest -> (rest, ghci_cmds) -- "::" selects a builtin command- _ -> (str', macros ++ ghci_cmds) } -- otherwise prefer macros- -- 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+ let (str, xcmds) = case str' of+ ':' : rest -> (rest, []) -- "::" selects a builtin command+ _ -> (str', macros) -- otherwise include macros in lookup + lookupExact s = find $ (s ==) . cmdName+ lookupPrefix s = find $ (s `isPrefixOf`) . cmdName++ builtinPfxMatch = lookupPrefix str ghci_cmds++ -- first, look for exact match (while preferring macros); then, look+ -- for first prefix match (preferring builtins), *unless* a macro+ -- overrides the builtin; see #8305 for motivation+ return $ lookupExact str xcmds <|>+ lookupExact str ghci_cmds <|>+ (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>+ builtinPfxMatch <|>+ lookupPrefix str xcmds+ getCurrentBreakSpan :: GHCi (Maybe SrcSpan) getCurrentBreakSpan = do resumes <- GHC.getResumeContext@@ -1012,7 +1102,7 @@ withSandboxOnly :: String -> GHCi () -> GHCi () withSandboxOnly cmd this = do dflags <- getDynFlags- if not (dopt Opt_GhciSandbox dflags)+ if not (gopt Opt_GhciSandbox dflags) then printForUser (text cmd <+> ptext (sLit "is not supported with -fno-ghci-sandbox")) else this@@ -1028,22 +1118,20 @@ ----------------------------------------------------------------------------- -- :info -info :: String -> InputT GHCi ()-info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")-info s = handleSourceError GHC.printException $ do+info :: Bool -> String -> InputT GHCi ()+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")+info allInfo s = handleSourceError GHC.printException $ do unqual <- GHC.getPrintUnqual dflags <- getDynFlags- sdocs <- mapM infoThing (words s)+ sdocs <- mapM (infoThing allInfo) (words s) mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs -infoThing :: GHC.GhcMonad m => String -> m SDoc-infoThing str = do- dflags <- getDynFlags- let pefas = dopt Opt_PrintExplicitForalls dflags+infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc+infoThing allInfo str = do names <- GHC.parseName str- mb_stuffs <- mapM GHC.getInfo names- let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)- return $ vcat (intersperse (text "") $ map (pprInfo pefas) filtered)+ mb_stuffs <- mapM (GHC.getInfo allInfo) names+ let filtered = filterOutChildren (\(t,_f,_ci,_fi) -> t) (catMaybes mb_stuffs)+ return $ vcat (intersperse (text "") $ map pprInfo filtered) -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data@@ -1057,11 +1145,12 @@ Just p -> getName p `elemNameSet` all_names Nothing -> False -pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.ClsInst]) -> SDoc-pprInfo pefas (thing, fixity, insts)- = pprTyThingInContextLoc pefas thing+pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc+pprInfo (thing, fixity, cls_insts, fam_insts)+ = pprTyThingInContextLoc thing $$ show_fixity- $$ vcat (map GHC.pprInstance insts)+ $$ vcat (map GHC.pprInstance cls_insts)+ $$ vcat (map GHC.pprFamInst fam_insts) where show_fixity | fixity == GHC.defaultFixity = empty@@ -1123,11 +1212,11 @@ editFile :: String -> InputT GHCi () editFile str =- do file <- if null str then lift chooseEditFile else return str+ do file <- if null str then lift chooseEditFile else expandPath str st <- lift getGHCiState let cmd = editor st when (null cmd)- $ ghcError (CmdLineError "editor not set, use :set editor")+ $ throwGhcException (CmdLineError "editor not set, use :set editor") code <- liftIO $ system (cmd ++ ' ':file) when (code == ExitSuccess) $ reloadModule ""@@ -1159,7 +1248,7 @@ do targets <- GHC.getTargets case msum (map fromTarget targets) of Just file -> return file- Nothing -> ghcError (CmdLineError "No files to edit.")+ Nothing -> throwGhcException (CmdLineError "No files to edit.") where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f fromTarget _ = Nothing -- when would we get a module target?@@ -1182,7 +1271,7 @@ unlines defined) else do if (not overwrite && macro_name `elem` defined)- then ghcError (CmdLineError+ then throwGhcException (CmdLineError ("macro '" ++ macro_name ++ "' is already defined")) else do @@ -1217,7 +1306,7 @@ where undef macro_name = do cmds <- liftIO (readIORef macros_ref) if (macro_name `notElem` map cmdName cmds)- then ghcError (CmdLineError+ then throwGhcException (CmdLineError ("macro '" ++ macro_name ++ "' is not defined")) else do liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))@@ -1288,8 +1377,16 @@ _ <- GHC.load LoadAllTargets GHC.setTargets targets- doLoad False LoadAllTargets-+ flag <- doLoad False LoadAllTargets+ doCollectInfo <- lift (isOptionSet CollectInfo)+ case flag of+ Succeeded | doCollectInfo -> do+ loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name+ v <- lift (fmap mod_infos getGHCiState)+ !newInfos <- collectInfo v loaded+ lift (modifyGHCiState (\s -> s { mod_infos = newInfos }))+ _ -> return ()+ return flag -- :add addModule :: [FilePath] -> InputT GHCi ()@@ -1318,11 +1415,20 @@ -- 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- return ok + -- Enable buffering stdout and stderr as we're compiling. Keeping these+ -- handles unbuffered will just slow the compilation down, especially when+ -- compiling in parallel.+ gbracket (liftIO $ do hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering)+ (\_ ->+ liftIO $ do hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering) $ \_ -> do+ ok <- trySuccess $ GHC.load howmuch+ afterLoad ok retain_context+ return ok + afterLoad :: SuccessFlag -> Bool -- keep the remembered_ctx, as far as possible (:reload) -> InputT GHCi ()@@ -1331,8 +1437,7 @@ 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+ modulesLoadedMsg ok loaded_mods lift $ setContextAfterLoad retain_context loaded_mod_summaries @@ -1405,21 +1510,23 @@ mod_name = unLoc (ideclName d) -modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()+modulesLoadedMsg :: SuccessFlag -> [Module] -> InputT GHCi () modulesLoadedMsg ok mods = do dflags <- getDynFlags- when (verbosity dflags > 0) $ do- let mod_commas+ unqual <- GHC.getPrintUnqual+ let mod_commas | null mods = text "none." | otherwise = hsep ( punctuate comma (map ppr mods)) <> text "."- case ok of- Failed ->- liftIO $ putStrLn $ showSDoc dflags (text "Failed, modules loaded: " <> mod_commas)- Succeeded ->- liftIO $ putStrLn $ showSDoc dflags (text "Ok, modules loaded: " <> mod_commas)+ status = case ok of+ Failed -> text "Failed"+ Succeeded -> text "Ok" + msg = status <> text ", modules loaded:" <+> mod_commas + when (verbosity dflags > 0) $+ liftIO $ putStrLn $ showSDocForUser dflags unqual msg+ ----------------------------------------------------------------------------- -- :type @@ -1428,11 +1535,151 @@ = handleSourceError GHC.printException $ do ty <- GHC.exprType str- dflags <- getDynFlags- let pefas = dopt Opt_PrintExplicitForalls dflags- printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]+ printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)] -----------------------------------------------------------------------------+-- :type-at++typeAt :: String -> InputT GHCi ()+typeAt str =+ handleSourceError+ GHC.printException+ (case parseSpan str of+ Left err -> liftIO (putStr err)+ Right (fp,sl,sc,el,ec,sample) ->+ do infos <- fmap mod_infos (lift getGHCiState)+ result <- findType infos fp sample sl sc el ec+ case result of+ Left err -> liftIO (putStrLn err)+ Right (info, ty) ->+ printForUserModInfo (modinfoInfo info)+ (sep [text sample,nest 2 (dcolon <+> ppr ty)]))++-----------------------------------------------------------------------------+-- :uses++findAllUses :: String -> InputT GHCi ()+findAllUses str =+ handleSourceError GHC.printException $+ case parseSpan str of+ Left err -> liftIO (putStr err)+ Right (fp,sl,sc,el,ec,sample) ->+ do infos <- fmap mod_infos (lift getGHCiState)+ result <- findNameUses infos fp sample sl sc el ec+ case result of+ Left err -> liftIO (putStrLn err)+ Right uses ->+ forM_ uses+ (\sp ->+ case sp of+ RealSrcSpan rs ->+ liftIO (putStrLn (showSpan rs))+ UnhelpfulSpan fs ->+ liftIO (putStrLn (unpackFS fs)))+ where showSpan span' =+ unpackFS (srcSpanFile span') +++ ":(" +++ show (srcSpanStartLine span') +++ "," +++ show (srcSpanStartCol span') +++ ")-(" +++ show (srcSpanEndLine span') +++ "," +++ show (srcSpanEndCol span') +++ ")"++-----------------------------------------------------------------------------+-- :all-types++allTypes :: String -> InputT GHCi ()+allTypes _ =+ handleSourceError+ GHC.printException+ (do infos <- fmap mod_infos (lift getGHCiState)+ forM_ (M.elems infos)+ (\mi ->+ forM_ (modinfoSpans mi) (printSpan mi)))+ where printSpan mi (SpanInfo sl sc el ec mty _) =+ do df <- GHC.getSessionDynFlags+ case (ml_hs_file (GHC.ms_location (modinfoSummary mi))) of+ Just fp ->+ case mty of+ Nothing -> return ()+ Just ty ->+ liftIO+ (putStrLn+ (concat [fp ++":"+ -- GHC exposes a 1-based column number because reasons.+ ,"(" ++ show sl ++ "," ++ show (1+sc) ++ ")-(" +++ show el ++ "," ++ show (1+ec) ++ "): "+ ,flatten (showSDocForUser+ df+#if __GLASGOW_HASKELL__ < 709+ (neverQualifyNames,neverQualifyModules)+#else+ neverQualify+#endif+ (pprTypeForUser ty))]))+ Nothing -> return ()+ where flatten = unwords . words++-----------------------------------------------------------------------------+-- :loc-at++locationAt :: String -> InputT GHCi ()+locationAt str =+ handleSourceError GHC.printException $+ case parseSpan str of+ Left err -> liftIO (putStr err)+ Right (fp,sl,sc,el,ec,sample) ->+ do infos <- fmap mod_infos (lift getGHCiState)+ result <- findLoc infos fp sample sl sc el ec+ case result of+ Left err -> liftIO (putStrLn err)+ Right sp ->+ case sp of+ RealSrcSpan rs ->+ liftIO (putStrLn (showSpan rs))+ UnhelpfulSpan fs ->+ liftIO (putStrLn (unpackFS fs))+ where showSpan span' =+ unpackFS (srcSpanFile span') ++ ":(" +++ show (srcSpanStartLine span') ++ "," +++ show (srcSpanStartCol span') +++ ")-(" +++ show (srcSpanEndLine span') ++ "," +++ show (srcSpanEndCol span') ++ ")"++-----------------------------------------------------------------------------+-- Helpers for locationAt/typeAt++-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>+parseSpan :: String -> Either String (FilePath,Int,Int,Int,Int,String)+parseSpan s =+ case result of+ Left err -> Left err+ Right r -> Right r+ where result =+ case span (/= ' ') s of+ (fp,s') ->+ do (sl,s1) <- extractInt s'+ (sc,s2) <- extractInt s1+ (el,s3) <- extractInt s2+ (ec,st) <- extractInt s3+ -- GHC exposes a 1-based column number because reasons.+ Right (fp,sl,sc-1,el,ec-1,st)+ extractInt s' =+ case span (/= ' ') (dropWhile1 (== ' ') s') of+ (reads -> [(i,_)],s'') ->+ Right (i,dropWhile1 (== ' ') s'')+ _ ->+ Left ("Expected integer in " ++ s')+ where dropWhile1 _ [] = []+ dropWhile1 p xs@(x:xs')+ | p x = xs'+ | otherwise = xs++----------------------------------------------------------------------------- -- :kind kindOfType :: Bool -> String -> InputT GHCi ()@@ -1440,7 +1687,7 @@ = handleSourceError GHC.printException $ do (ty, kind) <- GHC.typeKind norm str- printForUser $ vcat [ text str <+> dcolon <+> ppr kind+ printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind , ppWhen norm $ equals <+> ppr ty ] @@ -1460,20 +1707,21 @@ scriptCmd ws = do case words ws of [s] -> runScript s- _ -> ghcError (CmdLineError "syntax: :script <filename>")+ _ -> throwGhcException (CmdLineError "syntax: :script <filename>") runScript :: String -- ^ filename -> InputT GHCi () runScript filename = do- either_script <- liftIO $ tryIO (openFile filename ReadMode)+ filename' <- expandPath filename+ either_script <- liftIO $ tryIO (openFile filename' ReadMode) case either_script of- Left _err -> ghcError (CmdLineError $ "IO error: \""++filename++"\" "+ Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" " ++(ioeGetErrorString _err)) Right script -> do st <- lift $ getGHCiState let prog = progname st line = line_number st- lift $ setGHCiState st{progname=filename,line_number=0}+ lift $ setGHCiState st{progname=filename',line_number=0} scriptLoop script liftIO $ hClose script new_st <- lift $ getGHCiState@@ -1499,18 +1747,18 @@ isSafeModule md [] -> do md <- guessCurrentModule "issafe" isSafeModule md- _ -> ghcError (CmdLineError "syntax: :issafe <module>")+ _ -> throwGhcException (CmdLineError "syntax: :issafe <module>") isSafeModule :: Module -> InputT GHCi () isSafeModule m = do mb_mod_info <- GHC.getModuleInfo m when (isNothing mb_mod_info)- (ghcError $ CmdLineError $ "unknown module: " ++ mname)+ (throwGhcException $ CmdLineError $ "unknown module: " ++ mname) dflags <- getDynFlags let iface = GHC.modInfoIface $ fromJust mb_mod_info when (isNothing iface)- (ghcError $ CmdLineError $ "can't load interface file for module: " +++ (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++ (GHC.moduleNameString $ GHC.moduleName m)) (msafe, pkgs) <- GHC.moduleTrustReqs m@@ -1523,26 +1771,35 @@ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off") when (not $ null good) (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++- (intercalate ", " $ map packageIdString good))+ (intercalate ", " $ map packageString good)) case msafe && null bad of True -> liftIO $ putStrLn $ mname ++ " is trusted!" False -> do when (not $ null bad) (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "- ++ (intercalate ", " $ map packageIdString bad))+ ++ (intercalate ", " $ map packageString bad)) liftIO $ putStrLn $ mname ++ " is NOT trusted!" where mname = GHC.moduleNameString $ GHC.moduleName m packageTrusted dflags md- | thisPackage dflags == modulePackageId md = True- | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackageId md)+ | thisPackage dflags == modulePackage md = True+#if __GLASGOW_HASKELL__ < 709+ | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackage md)+#else+ | otherwise = trusted $ getPackageDetails dflags (modulePackage md)+#endif tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], []) | otherwise = partition part deps- where state = pkgState dflags+ where+#if __GLASGOW_HASKELL__ < 709 part pkg = trusted $ getPackageDetails state pkg+ state = pkgState dflags+#else+ part pkg = trusted $ getPackageDetails dflags pkg+#endif ----------------------------------------------------------------------------- -- :browse@@ -1560,7 +1817,7 @@ browseModule bang md True [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "") browseModule bang md True- _ -> ghcError (CmdLineError "syntax: :browse <module>")+ _ -> throwGhcException (CmdLineError "syntax: :browse <module>") guessCurrentModule :: String -> InputT GHCi Module -- Guess which module the user wants to browse. Pick@@ -1568,7 +1825,7 @@ -- recently-added module occurs last, it seems. guessCurrentModule cmd = do imports <- GHC.getContext- when (null imports) $ ghcError $+ when (null imports) $ throwGhcException $ CmdLineError (':' : cmd ++ ": no current module") case (head imports) of IIModule m -> GHC.findModule m Nothing@@ -1585,7 +1842,7 @@ mb_mod_info <- GHC.getModuleInfo modl case mb_mod_info of- Nothing -> ghcError (CmdLineError ("unknown module: " +++ Nothing -> throwGhcException (CmdLineError ("unknown module: " ++ GHC.moduleNameString (GHC.moduleName modl))) Just mod_info -> do dflags <- getDynFlags@@ -1614,8 +1871,7 @@ rdr_env <- GHC.getGRE - let pefas = dopt Opt_PrintExplicitForalls dflags- things | bang = catMaybes mb_things+ let things | bang = catMaybes mb_things | otherwise = filtered_things pretty | bang = pprTyThing | otherwise = pprTyThingInContext@@ -1645,7 +1901,7 @@ where (g,ng) = partition ((==m).fst) mts let prettyThings, prettyThings' :: [SDoc]- prettyThings = map (pretty pefas) things+ prettyThings = map pretty things prettyThings' | bang = annotate $ zip modNames prettyThings | otherwise = prettyThings liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')@@ -1663,7 +1919,7 @@ moduleCmd :: String -> GHCi () moduleCmd str | all sensible strs = cmd- | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")+ | otherwise = throwGhcException (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where (cmd, strs) = case str of@@ -1760,11 +2016,11 @@ checkAdd :: InteractiveImport -> GHCi () checkAdd ii = do- dflags <- getDynFlags + dflags <- getDynFlags let safe = safeLanguageOn dflags case ii of IIModule modname- | safe -> ghcError $ CmdLineError "can't use * imports with Safe Haskell"+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell" | otherwise -> wantInterpretedModuleName modname >> return () IIDecl d -> do@@ -1773,7 +2029,7 @@ m <- GHC.lookupModule modname pkgqual when safe $ do t <- GHC.isModuleTrusted m- when (not t) $ ghcError $ ProgramError $ ""+ when (not t) $ throwGhcException $ ProgramError $ "" -- ----------------------------------------------------------------------------- -- Update the GHC API's view of the context@@ -1865,8 +2121,16 @@ = unLoc (ideclName d1) == unLoc (ideclName d2) && ideclAs d1 == ideclAs d2 && (not (ideclQualified d1) || ideclQualified d2)- && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)+ && (idhd1 `hidingSubsumes` idhd2) where+-- I'm not so sure about this fix here...+#if __GLASGOW_HASKELL__ < 709+ idhd2 = ideclHiding d2+ idhd1 = ideclHiding d1+#else+ idhd2 = fmap (fmap unLoc) $ ideclHiding d2+ idhd1 = fmap (fmap unLoc) $ ideclHiding d1+#endif _ `hidingSubsumes` Just (False,[]) = True Just (False, xs) `hidingSubsumes` Just (False,ys) = all (`elem` xs) ys h1 `hidingSubsumes` h2 = h1 == h2@@ -1888,18 +2152,18 @@ setCmd "-a" = showOptions True setCmd str = case getCmd str of- Right ("args", rest) ->+ Right ("args", rest) -> case toArgs rest of Left err -> liftIO (hPutStrLn stderr err) Right args -> setArgs args- Right ("prog", rest) ->+ Right ("prog", rest) -> case toArgs rest of Right [prog] -> setProg prog _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")- Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest+ Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest Right ("prompt2", rest) -> setPrompt2 $ dropWhile isSpace rest- Right ("editor", rest) -> setEditor $ dropWhile isSpace rest- Right ("stop", rest) -> setStop $ dropWhile isSpace rest+ Right ("editor", rest) -> setEditor $ dropWhile isSpace rest+ Right ("stop", rest) -> setStop $ dropWhile isSpace rest _ -> case toArgs str of Left err -> liftIO (hPutStrLn stderr err) Right wds -> setOptions wds@@ -1931,15 +2195,19 @@ showLanguages' show_all dflags putStrLn $ showSDoc dflags $ text "GHCi-specific dynamic flag settings:" $$- nest 2 (vcat (map (setting dopt) ghciFlags))+ nest 2 (vcat (map (setting gopt) ghciFlags)) putStrLn $ showSDoc dflags $ text "other dynamic, non-language, flag settings:" $$- nest 2 (vcat (map (setting dopt) others))+ nest 2 (vcat (map (setting gopt) others)) putStrLn $ showSDoc dflags $ text "warning settings:" $$ nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags)) where+#if __GLASGOW_HASKELL__ < 709 setting test (str, f, _)+#else+ setting test (FlagSpec str f _ _)+#endif | quiet = empty | is_on = fstr str | otherwise = fnostr str@@ -1951,14 +2219,19 @@ fstr str = text "-f" <> text str fnostr str = text "-fno-" <> text str +#if __GLASGOW_HASKELL__ < 709 (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flgs)+#else+ (ghciFlags,others) = partition (\(FlagSpec _ f _ _) -> f `elem` flgs)+#endif DynFlags.fFlags- flgs = [Opt_PrintExplicitForalls- ,Opt_PrintBindResult- ,Opt_BreakOnException- ,Opt_BreakOnError- ,Opt_PrintEvldWithShow- ]+ flgs = [ Opt_PrintExplicitForalls+ , Opt_PrintExplicitKinds+ , Opt_PrintBindResult+ , Opt_BreakOnException+ , Opt_BreakOnError+ , Opt_PrintEvldWithShow+ ] setArgs, setOptions :: [String] -> GHCi () setProg, setEditor, setStop :: String -> GHCi ()@@ -2033,7 +2306,7 @@ liftIO $ handleFlagWarnings idflags1 warns when (not $ null leftovers)- (ghcError . CmdLineError+ (throwGhcException . CmdLineError $ "Some flags have not been recognized: " ++ (concat . intersperse ", " $ map unLoc leftovers)) @@ -2052,7 +2325,9 @@ -- the new packages. dflags2 <- getDynFlags when (packageFlags dflags2 /= packageFlags dflags0) $ do- liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."+ when (verbosity dflags2 > 0) $+ liftIO . putStrLn $+ "package flags have changed, resetting and loading new packages..." GHC.setTargets [] _ <- GHC.load LoadAllTargets liftIO $ linkPackages dflags2 new_pkgs@@ -2077,16 +2352,16 @@ (other_opts, rest3) = partition (`elem` map fst defaulters) rest2 defaulters =- [ ("args" , setArgs default_args)- , ("prog" , setProg default_progname)- , ("prompt", setPrompt default_prompt)+ [ ("args" , setArgs default_args)+ , ("prog" , setProg default_progname)+ , ("prompt" , setPrompt default_prompt) , ("prompt2", setPrompt2 default_prompt2)- , ("editor", liftIO findEditor >>= setEditor)- , ("stop" , setStop default_stop)+ , ("editor" , liftIO findEditor >>= setEditor)+ , ("stop" , setStop default_stop) ] no_flag ('-':'f':rest) = return ("-fno-" ++ rest)- no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))+ no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f)) in if (not (null rest3)) then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))@@ -2123,6 +2398,7 @@ strToGHCiOpt "s" = Just ShowTiming strToGHCiOpt "t" = Just ShowType strToGHCiOpt "r" = Just RevertCAFs+strToGHCiOpt "c" = Just CollectInfo strToGHCiOpt _ = Nothing optToStr :: GHCiOption -> String@@ -2130,6 +2406,7 @@ optToStr ShowTiming = "s" optToStr ShowType = "t" optToStr RevertCAFs = "r"+optToStr CollectInfo = "c" -- ---------------------------------------------------------------------------@@ -2160,8 +2437,8 @@ ["languages"] -> showLanguages -- backwards compat ["language"] -> showLanguages ["lang"] -> showLanguages -- useful abbreviation- _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | prompt2 | editor | stop | modules | bindings\n"++- " | breaks | context | packages | language ]"))+ _ -> throwGhcException (CmdLineError ("syntax: :show [ args | prog | prompt | prompt2 | editor | stop | modules\n" +++ " | bindings | breaks | context | packages | language ]")) showiCmd :: String -> GHCi () showiCmd str = do@@ -2169,7 +2446,7 @@ ["languages"] -> showiLanguages -- backwards compat ["language"] -> showiLanguages ["lang"] -> showiLanguages -- useful abbreviation- _ -> ghcError (CmdLineError ("syntax: :showi language"))+ _ -> throwGhcException (CmdLineError ("syntax: :showi language")) showImports :: GHCi () showImports = do@@ -2184,6 +2461,7 @@ prel_imp | any isPreludeImport (rem_ctx ++ trans_ctx) = []+ | not (xopt Opt_ImplicitPrelude dflags) = [] | otherwise = ["import Prelude -- implicit"] trans_comment s = s ++ " -- added automatically"@@ -2210,18 +2488,17 @@ docs <- mapM makeDoc (reverse bindings) -- reverse so the new ones come last let idocs = map GHC.pprInstanceHdr insts- fidocs = map GHC.pprFamInstHdr finsts+ fidocs = map GHC.pprFamInst finsts mapM_ printForUserPartWay (docs ++ idocs ++ fidocs) where makeDoc (AnId i) = pprTypeAndContents i makeDoc tt = do- dflags <- getDynFlags- let pefas = dopt Opt_PrintExplicitForalls dflags- mb_stuff <- GHC.getInfo (getName tt)- return $ maybe (text "") (pprTT pefas) mb_stuff- pprTT :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.ClsInst]) -> SDoc- pprTT pefas (thing, fixity, _insts) =- pprTyThing pefas thing+ mb_stuff <- GHC.getInfo False (getName tt)+ return $ maybe (text "") pprTT mb_stuff++ pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc+ pprTT (thing, fixity, _cls_insts, _fam_insts)+ = pprTyThing thing $$ show_fixity where show_fixity@@ -2230,9 +2507,7 @@ printTyThing :: TyThing -> GHCi ()-printTyThing tyth = do dflags <- getDynFlags- let pefas = dopt Opt_PrintExplicitForalls dflags- printForUser (pprTyThing pefas tyth)+printTyThing tyth = printForUser (pprTyThing tyth) showBkptTable :: GHCi () showBkptTable = do@@ -2255,10 +2530,21 @@ liftIO $ putStrLn $ showSDoc dflags $ vcat $ text ("active package flags:"++if null pkg_flags then " none" else "") : map showFlag pkg_flags- where showFlag (ExposePackage p) = text $ " -package " ++ p+ where+#if __GLASGOW_HASKELL__ < 709+ showFlag (ExposePackage p) = text $ " -package " ++ p+#else+-- This flag now has more info about module renaming.+-- @see+-- https://downloads.haskell.org/~ghc/latest/docs/html/libraries/ghc-7.10.1/DynFlags.html#v:ExposePackage+ showFlag (ExposePackage arg mr) = text $ " -package " ++ show arg ++ " " ++ show mr+#endif showFlag (HidePackage p) = text $ " -hide-package " ++ p showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p+#if __GLASGOW_HASKELL__ < 709+-- This flag just isn't in the 7.10 API showFlag (ExposePackageId p) = text $ " -package-id " ++ p+#endif showFlag (TrustPackage p) = text $ " -trust " ++ p showFlag (DistrustPackage p) = text $ " -distrust " ++ p @@ -2266,10 +2552,10 @@ showPaths = do dflags <- getDynFlags liftIO $ do- cwd <- getCurrentDirectory+ cwd' <- getCurrentDirectory putStrLn $ showSDoc dflags $ text "current working directory: " $$- nest 2 (text cwd)+ nest 2 (text cwd') let ipaths = importPaths dflags putStrLn $ showSDoc dflags $ text ("module import search paths:"++if null ipaths then " none" else "") $$@@ -2294,7 +2580,11 @@ nest 2 (vcat (map (setting xopt) DynFlags.xFlags)) ] where+#if __GLASGOW_HASKELL__ < 709 setting test (str, f, _)+#else+ setting test (FlagSpec str f _ _)+#endif | quiet = empty | is_on = text "-X" <> text str | otherwise = text "-XNo" <> text str@@ -2310,8 +2600,8 @@ -- ----------------------------------------------------------------------------- -- Completion -completeCmd' :: String -> GHCi ()-completeCmd' argLine0 = case parseLine argLine0 of+completeCmd :: String -> GHCi ()+completeCmd argLine0 = case parseLine argLine0 of Just ("repl", resultRange, left) -> do (unusedLine,compls) <- ghciCompleteWord (reverse left,"") let compls' = takeRange resultRange compls@@ -2337,18 +2627,21 @@ -- syntax: [n-][m] with semantics "drop (n-1) . take m" parseRange :: String -> Maybe (Maybe Int,Maybe Int)- parseRange s- | all isDigit s = Just (Nothing, bndRead s) -- upper limit only- | not (null n1), sep == '-', all isDigit n1, all isDigit n2 =- Just (bndRead n1, bndRead n2) -- lower limit and maybe upper limit- | otherwise = Nothing+ parseRange s = case span isDigit s of+ (_, "") ->+ -- upper limit only+ Just (Nothing, bndRead s)+ (s1, '-' : s2)+ | all isDigit s2 ->+ Just (bndRead s1, bndRead s2)+ _ ->+ Nothing where- (n1,sep:n2) = span isDigit s- bndRead s = if null s then Nothing else Just (read s)+ bndRead x = if null x then Nothing else Just (read x) -completeCmd, completeMacro, completeIdentifier, completeModule,+completeGhciCommand, completeMacro, completeIdentifier, completeModule, completeSetModule, completeSeti, completeShowiOptions, completeHomeModule, completeSetOptions, completeShowOptions, completeHomeModuleOrFile, completeExpression@@ -2356,7 +2649,7 @@ ghciCompleteWord :: CompletionFunc GHCi ghciCompleteWord line@(left,_) = case firstWord of- ':':cmd | null rest -> completeCmd line+ ':':cmd | null rest -> completeGhciCommand line | otherwise -> do completion <- lookupCompletion cmd completion line@@ -2371,7 +2664,7 @@ Just (_,_,f) -> return f Nothing -> return completeFilename -completeCmd = wrapCompleter " " $ \w -> do+completeGhciCommand = wrapCompleter " " $ \w -> do macros <- liftIO $ readIORef macros_ref cmds <- ghci_commands `fmap` getGHCiState let macro_names = map (':':) . map cmdName $ macros@@ -2461,10 +2754,14 @@ getModifier = find (`elem` modifChars) allExposedModules :: DynFlags -> [ModuleName]+#if __GLASGOW_HASKELL__ < 709 allExposedModules dflags = concat (map exposedModules (filter exposed (eltsUFM pkg_db))) where pkg_db = pkgIdMap (pkgState dflags)+#else+allExposedModules = listVisibleModuleNames+#endif completeExpression = completeQuotedWord (Just '\\') "\"" listFiles completeIdentifier@@ -2668,16 +2965,17 @@ | otherwise = breakSyntax breakSyntax :: a-breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () findBreakAndSet md lookupTickTree = do+ dflags <- getDynFlags tickArray <- getTickArray md (breakArray, _) <- getModBreak md case lookupTickTree tickArray of Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location." Just (tick, pan) -> do- success <- liftIO $ setBreakFlag True breakArray tick+ success <- liftIO $ setBreakFlag dflags True breakArray tick if success then do (alreadySet, nm) <-@@ -2960,8 +3258,9 @@ turnOffBreak :: BreakLocation -> GHCi Bool turnOffBreak loc = do+ dflags <- getDynFlags (arr, _) <- getModBreak (breakModule loc)- liftIO $ setBreakFlag False arr (breakTick loc)+ liftIO $ setBreakFlag dflags False arr (breakTick loc) getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) getModBreak m = do@@ -2971,10 +3270,10 @@ let ticks = GHC.modBreaks_locs modBreaks return (arr, ticks) -setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool-setBreakFlag toggle arr i- | toggle = GHC.setBreakOn arr i- | otherwise = GHC.setBreakOff arr i+setBreakFlag :: DynFlags -> Bool -> GHC.BreakArray -> Int -> IO Bool+setBreakFlag dflags toggle arr i+ | toggle = GHC.setBreakOn dflags arr i+ | otherwise = GHC.setBreakOff dflags arr i -- ---------------------------------------------------------------------------@@ -3020,8 +3319,10 @@ -- 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 :: ExceptionMonad m => (SomeException -> m a) -> m a -> m a-ghciHandle h m = gcatch m $ \e -> gunblock (h e)+ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a+ghciHandle h m = gmask $ \restore -> do+ dflags <- getDynFlags+ gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e) ghciTry :: GHCi a -> GHCi (Either SomeException a) ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)@@ -3043,7 +3344,11 @@ lookupModuleName mName = GHC.lookupModule mName Nothing isHomeModule :: Module -> Bool-isHomeModule m = GHC.modulePackageId m == mainPackageId+#if __GLASGOW_HASKELL__ < 709+isHomeModule m = modulePackage m == mainPackageId+#else+isHomeModule m = modulePackage m == mainPackageKey+#endif -- TODO: won't work if home dir is encoded. -- (changeDirectory may not work either in that case.)@@ -3067,11 +3372,11 @@ modl <- lookupModuleName modname let str = moduleNameString modname dflags <- getDynFlags- when (GHC.modulePackageId modl /= thisPackage dflags) $- ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))+ when (modulePackage modl /= thisPackage dflags) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) is_interpreted <- GHC.moduleIsInterpreted modl when (not is_interpreted) $- ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) return modl wantNameFromInterpretedModule :: GHC.GhcMonad m
ghc/Main.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}+{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- --@@ -18,7 +19,7 @@ LoadHowMuch(..) ) import CmdLineParser --- ghc-paths+-- ghci-ng import qualified GHC.Paths -- Implementations of the various modes (--show-iface, mkdependHS. etc.)@@ -35,12 +36,14 @@ import Config import Constants import HscTypes+#if __GLASGOW_HASKELL__ < 709 import Packages ( dumpPackages )-import DriverPhases ( Phase(..), isSourceFilename, anyHsc,- startPhase, isHaskellSrcFilename )+#else+import Packages ( pprPackages )+#endif+import DriverPhases import BasicTypes ( failed ) import StaticFlags-import StaticFlagParser import DynFlags import ErrUtils import FastString@@ -81,8 +84,9 @@ main :: IO () main = do- hSetBuffering stdout NoBuffering- hSetBuffering stderr NoBuffering+ initGCStatistics -- See Note [-Bsymbolic and hooks]+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do -- 1. extract the -B flag from the args argv00 <- getArgs@@ -117,7 +121,7 @@ ShowSupportedExtensions -> showSupportedExtensions ShowVersion -> showVersion ShowNumVersion -> putStrLn cProjectVersion- Print str -> putStrLn str+ ShowOptions -> showOptions Right postStartupMode -> -- start our GHC session GHC.runGhc mbMinusB $ do@@ -152,11 +156,22 @@ DoAbiHash -> (OneShot, dflt_target, LinkBinary) _ -> (OneShot, dflt_target, LinkBinary) - let dflags1 = dflags0{ ghcMode = mode,+ let dflags1 = case lang of+ HscInterpreted ->+ let platform = targetPlatform dflags0+ dflags0a = updateWays $ dflags0 { ways = interpWays }+ dflags0b = foldl gopt_set dflags0a+ $ concatMap (wayGeneralFlags platform)+ interpWays+ dflags0c = foldl gopt_unset dflags0b+ $ concatMap (wayUnsetGeneralFlags platform)+ interpWays+ in dflags0c+ _ ->+ dflags0+ dflags2 = dflags1{ 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@@ -166,33 +181,28 @@ -- can be overriden from the command-line -- XXX: this should really be in the interactive DynFlags, but -- we don't set that until later in interactiveUI- dflags1a | DoInteractive <- postLoadMode = imp_qual_enabled+ dflags3 | DoInteractive <- postLoadMode = imp_qual_enabled | DoEval _ <- postLoadMode = imp_qual_enabled- | otherwise = dflags1- where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified+ | otherwise = dflags2+ where imp_qual_enabled = dflags2 `gopt_set` Opt_ImplicitImportQualified -- The rest of the arguments are "dynamic" -- Leftover ones are presumably files- (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a args+ (dflags4, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags3 args - GHC.prettyPrintGhcErrors dflags2 $ do+ GHC.prettyPrintGhcErrors dflags4 $ do let flagWarnings' = flagWarnings ++ dynamicFlagWarnings handleSourceError (\e -> do GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do- liftIO $ handleFlagWarnings dflags2 flagWarnings'+ liftIO $ handleFlagWarnings dflags4 flagWarnings' -- make sure we clean up after ourselves- GHC.defaultCleanupHandler dflags2 $ do-- liftIO $ showBanner postLoadMode dflags2+ GHC.defaultCleanupHandler dflags4 $ do - -- we've finished manipulating the DynFlags, update the session- _ <- GHC.setSessionDynFlags dflags2- dflags3 <- GHC.getSessionDynFlags- hsc_env <- GHC.getSession+ liftIO $ showBanner postLoadMode dflags4 let -- To simplify the handling of filepaths, we normalise all filepaths right@@ -201,26 +211,35 @@ 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)+ dflags5 = dflags4 { ldInputs = map (FileOption "") objs+ ++ ldInputs dflags4 } + -- we've finished manipulating the DynFlags, update the session+ _ <- GHC.setSessionDynFlags dflags5+ dflags6 <- GHC.getSessionDynFlags+ hsc_env <- GHC.getSession+ ---------------- Display configuration ------------ when (verbosity dflags3 >= 4) $- liftIO $ dumpPackages dflags3+ when (verbosity dflags6 >= 4) $+#if __GLASGOW_HASKELL__ >= 709+ let dumpPackages flags = putStrLn $ show $ runSDoc (pprPackages flags) ctx+ where ctx = initSDocContext flags defaultDumpStyle+ in+#endif+ liftIO $ dumpPackages dflags6 - when (verbosity dflags3 >= 3) $ do+ when (verbosity dflags6 >= 3) $ do liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) ---------------- Final sanity checking ------------ liftIO $ checkOptions postLoadMode dflags3 srcs objs+ liftIO $ checkOptions postLoadMode dflags6 srcs objs ---------------- Do the business ----------- handleSourceError (\e -> do GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do case postLoadMode of- ShowInterface f -> liftIO $ doShowIface dflags3 f+ ShowInterface f -> liftIO $ doShowIface dflags6 f DoMake -> doMake srcs DoMkDependHS -> doMkDependHS (map fst srcs) StopBefore p -> liftIO (oneShot hsc_env p srcs)@@ -228,11 +247,11 @@ DoEval exprs -> ghciUI srcs $ Just $ reverse exprs DoAbiHash -> abiHash srcs - liftIO $ dumpFinalStats dflags3+ liftIO $ dumpFinalStats dflags6 ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () #ifndef GHCI-ghciUI _ _ = ghcError (CmdLineError "not built for interactive use")+ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use") #else ghciUI = interactiveUI defaultGhciSettings #endif@@ -258,7 +277,7 @@ {- We split out the object files (.o, .dll) and add them- to v_Ld_inputs for use by the linker.+ to ldInputs for use by the linker. The following things should be considered compilation manager inputs: @@ -296,25 +315,25 @@ let unknown_opts = [ f | (f@('-':_), _) <- srcs ] when (notNull unknown_opts) (unknownFlagsErr unknown_opts) - when (notNull (filter isRTSWay (wayNames dflags))+ when (notNull (filter wayRTSOnly (ways dflags)) && isInterpretiveMode mode) $ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") -- -prof and --interactive are not a good combination- when (notNull (filter (not . isRTSWay) (wayNames dflags))+ when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays) && isInterpretiveMode mode) $- do ghcError (UsageError+ do throwGhcException (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")+ then throwGhcException (UsageError "-ohi can only be used when compiling a single source file") else do -- -o sanity checking if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) && not (isLinkMode mode))- then ghcError (UsageError "can't apply -o to multiple source files")+ then throwGhcException (UsageError "can't apply -o to multiple source files") else do let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)@@ -325,7 +344,7 @@ -- 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")+ then throwGhcException (UsageError "no input files") else do -- Verify that output files point somewhere sensible.@@ -356,7 +375,7 @@ when (not flg) (nonExistentDir "-ohi" hi) where nonExistentDir flg dir =- ghcError (CmdLineError ("error: directory portion of " +++ throwGhcException (CmdLineError ("error: directory portion of " ++ show dir ++ " does not exist (used with " ++ show flg ++ " option.)")) @@ -370,12 +389,13 @@ = ShowVersion -- ghc -V/--version | ShowNumVersion -- ghc --numeric-version | ShowSupportedExtensions -- ghc --supported-extensions- | Print String -- ghc --print-foo+ | ShowOptions -- ghc --show-options -showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode+showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode showVersionMode = mkPreStartupMode ShowVersion showNumVersionMode = mkPreStartupMode ShowNumVersion showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions+showOptionsMode = mkPreStartupMode ShowOptions mkPreStartupMode :: PreStartupMode -> Mode mkPreStartupMode = Left@@ -503,7 +523,12 @@ Nothing -> doMakeMode Just (m, _) -> m errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2- when (not (null errs)) $ ghcError $ errorsToGhcException errs+ when (not (null errs)) $ throwGhcException+#if __GLASGOW_HASKELL__ < 709+ $ errorsToGhcException errs+#else+ $ errorsToGhcException $ map (\(L sp e) -> (show sp, e)) errs+#endif return (mode, flags' ++ leftover, warns) type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])@@ -511,66 +536,68 @@ -- so we collect the new ones and return them. mode_flags :: [Flag ModeM]-mode_flags =- [ ------- help / version ----------------------------------------------- Flag "?" (PassFlag (setMode showGhcUsageMode))- , Flag "-help" (PassFlag (setMode showGhcUsageMode))- , Flag "V" (PassFlag (setMode showVersionMode))- , Flag "-version" (PassFlag (setMode showVersionMode))- , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))- , Flag "-info" (PassFlag (setMode showInfoMode))- , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))- , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))- ] ++- [ Flag k' (PassFlag (setMode (printSetting k)))- | k <- ["Project version",- "Booter version",- "Stage",- "Build platform",- "Host platform",- "Target platform",- "Have interpreter",- "Object splitting supported",- "Have native code generator",- "Support SMP",- "Unregisterised",- "Tables next to code",- "RTS ways",- "Leading underscore",- "Debug on",- "LibDir",- "Global Package DB",- "C compiler flags",- "Gcc Linker flags",- "Ld Linker flags"],- let k' = "-print-" ++ map (replaceSpace . toLower) k- replaceSpace ' ' = '-'- replaceSpace c = c- ] ++- ------- interfaces ----------------------------------------------------- [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)- "--show-iface"))-- ------- primary modes ------------------------------------------------- , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f- addFlag "-no-link" f))- , Flag "M" (PassFlag (setMode doMkDependHSMode))- , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))- , Flag "C" (PassFlag setGenerateC)- , Flag "S" (PassFlag (setMode (stopBeforeMode As)))- , Flag "-make" (PassFlag (setMode doMakeMode))- , Flag "-interactive" (PassFlag (setMode doInteractiveMode))- , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))- , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))- ]+#if __GLASGOW_HASKELL__ < 709+mode_flags = flags+#else+mode_flags = zipWith ($) flags ghcModes+#endif+ where flags = concat [help, othr, prim]+ ------- help / version -------------------------------------------------+ help = [+ Flag "?" (PassFlag (setMode showGhcUsageMode))+ , Flag "-help" (PassFlag (setMode showGhcUsageMode))+ , Flag "V" (PassFlag (setMode showVersionMode))+ , Flag "-version" (PassFlag (setMode showVersionMode))+ , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))+ , Flag "-info" (PassFlag (setMode showInfoMode))+ , Flag "-show-options" (PassFlag (setMode showOptionsMode))+ , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))+ , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))+ ]+ othr = [ Flag k' (PassFlag (setMode (printSetting k)))+ | k <- ["Project version",+ "Booter version",+ "Stage",+ "Build platform",+ "Host platform",+ "Target platform",+ "Have interpreter",+ "Object splitting supported",+ "Have native code generator",+ "Support SMP",+ "Unregisterised",+ "Tables next to code",+ "RTS ways",+ "Leading underscore",+ "Debug on",+ "LibDir",+ "Global Package DB",+ "C compiler flags",+ "Gcc Linker flags",+ "Ld Linker flags"],+ let k' = "-print-" ++ map (replaceSpace . toLower) k+ replaceSpace ' ' = '-'+ replaceSpace c = c+ ]+ ------- interfaces -----------------------------------------------------+ prim = [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)+ "--show-iface")) -setGenerateC :: String -> EwM ModeM ()-setGenerateC f- | cGhcUnregisterised /= "YES" = do- addWarn ("Compiler not unregisterised, so ignoring " ++ f)- | otherwise = do- setMode (stopBeforeMode HCc) f- addFlag "-fvia-C" f+ ------- primary modes --------------------------------------------------+ , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f+ addFlag "-no-link" f))+ , Flag "M" (PassFlag (setMode doMkDependHSMode))+ , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))+ , Flag "C" (PassFlag (setMode (stopBeforeMode HCc)))+ , Flag "S" (PassFlag (setMode (stopBeforeMode (as False))))+ , Flag "-make" (PassFlag (setMode doMakeMode))+ , Flag "-interactive" (PassFlag (setMode doInteractiveMode))+ , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))+ , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))+ ]+#if __GLASGOW_HASKELL__ >= 709+ ghcModes = cycle [AllModes]+#endif setMode :: Mode -> String -> EwM ModeM () setMode newMode newFlag = liftEwM $ do@@ -630,9 +657,9 @@ let (hs_srcs, non_hs_srcs) = partition haskellish srcs haskellish (f,Nothing) =- looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f+ looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f haskellish (_,Just phase) =- phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]+ phase `notElem` [as True, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] hsc_env <- GHC.getSession @@ -646,7 +673,10 @@ o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) non_hs_srcs- liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)+ dflags <- GHC.getSessionDynFlags+ let dflags' = dflags { ldInputs = map (FileOption "") o_files+ ++ ldInputs dflags }+ _ <- GHC.setSessionDynFlags dflags' targets <- mapM (uncurry GHC.guessTarget) hs_srcs GHC.setTargets targets@@ -698,6 +728,25 @@ showVersion :: IO () showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion) +showOptions :: IO ()+showOptions = putStr (unlines availableOptions)+ where+ availableOptions = map ((:) '-') $+ getFlagNames mode_flags +++ getFlagNames flagsDynamic +++ (filterUnwantedStatic . getFlagNames $ flagsStatic) +++ flagsStaticNames+ getFlagNames opts = map getFlagName opts+#if __GLASGOW_HASKELL__ < 709+ getFlagName (Flag name _) = name+#else+ getFlagName (Flag name _ _) = name+#endif+ -- this is a hack to get rid of two unwanted entries that get listed+ -- as static flags. Hopefully this hack will disappear one day together+ -- with static flags+ filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"]))+ showGhcUsage :: DynFlags -> IO () showGhcUsage = showUsage False @@ -717,17 +766,16 @@ dumpFinalStats :: DynFlags -> IO () dumpFinalStats dflags =- when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags+ when (gopt 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+ let (entries, longest, has_z) = countFS 0 0 0 buckets msg = text "FastString stats:" $$ nest 4 (vcat [text "size: " <+> int (length buckets), text "entries: " <+> int entries, text "longest chain: " <+> int longest,- text "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@@ -739,17 +787,16 @@ 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) =+countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)+countFS entries longest has_z [] = (entries, longest, has_z)+countFS entries longest has_z (b:bs) = let len = length b longest' = max len longest entries' = entries + len- 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+ countFS entries' longest' (has_z + has_zs) bs -- ----------------------------------------------------------------------------- -- ABI hash support@@ -779,7 +826,7 @@ r <- findImportedModule hsc_env modname Nothing case r of Found _ m -> return m- _error -> ghcError $ CmdLineError $ showSDoc dflags $+ _error -> throwGhcException $ CmdLineError $ showSDoc dflags $ cannotFindInterface dflags modname r mods <- mapM find_it (map fst strs)@@ -800,5 +847,41 @@ -- Util unknownFlagsErr :: [String] -> a-unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs+ where+ oneError f =+ "unrecognised flag: " ++ f ++ "\n" +++ (case fuzzyMatch f (nub allFlags) of+ [] -> ""+ suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs)) +{- Note [-Bsymbolic and hooks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-Bsymbolic is a flag that prevents the binding of references to global+symbols to symbols outside the shared library being compiled (see `man+ld`). When dynamically linking, we don't use -Bsymbolic on the RTS+package: that is because we want hooks to be overridden by the user,+we don't want to constrain them to the RTS package.++Unfortunately this seems to have broken somehow on OS X: as a result,+defaultHooks (in hschooks.c) is not called, which does not initialize+the GC stats. As a result, this breaks things like `:set +s` in GHCi+(#8754). As a hacky workaround, we instead call 'defaultHooks'+directly to initalize the flags in the RTS.++A biproduct of this, I believe, is that hooks are likely broken on OS+X when dynamically linking. But this probably doesn't affect most+people since we're linking GHC dynamically, but most things themselves+link statically.+-}++foreign import ccall safe "initGCStatistics"+ initGCStatistics :: IO ()++-- | Compatibility between GHC 7.8.2 -> GHC 7.8.3.+as :: Bool -> Phase+#if MIN_VERSION_ghc(7,8,3)+as = As+#else+as _ = As+#endif
ghc/hschooks.c view
@@ -16,12 +16,33 @@ #endif void+initGCStatistics(void)+{+ /* Workaround for #8754: if the GC stats aren't enabled because the+ compiler couldn't use -Bsymbolic to link the default hooks, then+ initialize them sensibly. See Note [-Bsymbolic and hooks] in+ Main.hs. */+ if (RtsFlags.GcFlags.giveStats == NO_GC_STATS) {+ RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS;+ }+}++void defaultsHook (void) {+#if __GLASGOW_HASKELL__ >= 707+ // This helps particularly with large compiles, but didn't work+ // very well with earlier GHCs because it caused large amounts of+ // fragmentation. See rts/sm/BlockAlloc.c:allocLargeChunk().+ RtsFlags.GcFlags.heapSizeSuggestionAuto = rtsTrue;+#else RtsFlags.GcFlags.heapSizeSuggestion = 6*1024*1024 / BLOCK_SIZE;+#endif+ RtsFlags.GcFlags.maxStkSize = 512*1024*1024 / sizeof(W_);- RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS; + initGCStatistics();+ // See #3408: the default idle GC time of 0.3s is too short on // Windows where we receive console events once per second or so. #if __GLASGOW_HASKELL__ >= 703@@ -32,7 +53,7 @@ } void-StackOverflowHook (lnat stack_size) /* in bytes */+StackOverflowHook (StgWord stack_size) /* in bytes */ { fprintf(stderr, "GHC stack-space overflow: current limit is %zu bytes.\nUse the `-K<size>' option to increase it.\n", (size_t)stack_size); }
ghci-ng.cabal view
@@ -1,80 +1,64 @@-name: ghci-ng-version: 7.6.3.5-license: BSD3-license-file: LICENSE-author: The GHC Team-copyright: © 2005 The University of Glasgow-maintainer: hvr@gnu.org-homepage: https://github.com/hvr/ghci-ng-category: Development-build-type: Simple+name: ghci-ng+version: 10.0.0+synopsis: Next generation GHCi+description: GHCi plus extra goodies. See README for feature list: https://github.com/chrisdone/ghci-ng#features+license: BSD3+homepage: https://github.com/chrisdone/ghci-ng+license-file: LICENSE+author: The GHC Team, Chris Done+maintainer: chrisdone@gmail.com+copyright: 2005 The University of Glasgow, 2008 Claus Reinke, 2012 Kazu Yamamoto, 2014 Chris Done+category: Development+build-type: Simple+stability: Experimental cabal-version: >= 1.14-synopsis: Extended GHCi fork-description:- This provides an augmented version of @ghci-7.6.3@ installed under- the name @ghci-ng@ containing backported, proposed and- experimental features.- .- Currently, @ghci-ng@ has the following additional features- compared to the vanilla @ghci-7.6.3@ program:- .- * backported @:complete@ command for non-interactive completion- (see <http://ghc.haskell.org/trac/ghc/ticket/5687 GHC#5687>)- .- * backported customizable continuation prompt (@:set prompt2@)- and bugfix for @:set +m@-style completion- (see <http://ghc.haskell.org/trac/ghc/ticket/8076 GHC#8076>)- .- * Support for @%l@ line-number prompt substitution- (proposed for GHC 7.8, <http://ghc.haskell.org/trac/ghc/ticket/8047 GHC#8047>)- .- * Add @:show linker@ command to @:help@ output- (<http://ghc.haskell.org/trac/ghc/ticket/8074 GHC#8074>)- .- * Add missing @:show imports@ to completion table- (<http://ghc.haskell.org/trac/ghc/ticket/8075 GHC#7075>)- .- * Fix GHCi macros not shadowing builtins- (<http://ghc.haskell.org/trac/ghc/ticket/8113 GHC#8113>)- .- * Supports being used via @cabal repl --with-ghc=ghci-ng@- .- * backported @:show paths@ support- (<http://ghc.haskell.org/trac/ghc/ticket/8172 GHC#8172>) extra-source-files: ghc/HsVersions.h rts/PosixSource.h executable ghci-ng- default-language: Haskell2010- hs-source-dirs: ghc- main-is: Main.hs- c-sources: ghc/hschooks.c- other-modules: InteractiveUI, GhciMonad, GhciTags-- build-depends: array >= 0.4 && < 0.5,- base >= 4.6 && < 4.7,- bytestring >= 0.10 && < 0.11,- directory >= 1.2 && < 1.3,- filepath >= 1.3 && < 1.4,- ghc >= 7.6.1 && < 7.7,- ghc-paths >= 0.1.0.9 && < 0.2,- haskeline >= 0.7 && < 0.8,- process >= 1.1 && < 1.2,- transformers >= 0.3 && < 0.4-- if os(windows)- build-depends: Win32- else- build-depends: unix+ main-is: Main.hs+ hs-source-dirs: ghc/+ ghc-options: -Wall -O2+ c-sources: ghc/hschooks.c+ other-modules: InteractiveUI+ GhciMonad+ GhciTags+ GhciTypes+ GhciInfo+ GhciFind+ ghc-options: -Wall -fno-warn-name-shadowing -threaded -dynamic+ cpp-options: -DGHCI+ default-language: Haskell2010+ default-extensions:+ CPP+ FlexibleInstances+ MagicHash+ NondecreasingIndentation+ UnboxedTuples - cpp-options: -DGHCI- ghc-options: -Wall -fno-warn-name-shadowing -threaded- default-extensions: CPP,- FlexibleInstances,- MagicHash,- NondecreasingIndentation,- UnboxedTuples+ -- In other words, demand at least version 7.8.+ if impl(ghc<7.8)+ build-depends: ghc >= 7.8+ if impl(ghc>=7.8)+ build-depends:+ base,+ array,+ bytestring,+ directory,+ filepath,+ ghc >= 7.8,+ ghc-paths,+ haskeline,+ process,+ transformers,+ syb,+ containers,+ time+ if os(windows)+ build-depends: Win32+ else+ build-depends: unix source-repository head type: git- location: git://github.com/hvr/ghci-ng.git+ location: git://github.com/chrisdone/ghci-ng.git