diff options
| -rw-r--r-- | ghc/GhciFind.hs | 260 | ||||
| -rw-r--r-- | ghc/GhciInfo.hs | 156 | ||||
| -rw-r--r-- | ghc/GhciMonad.hs | 18 | ||||
| -rw-r--r-- | ghc/GhciTypes.hs | 57 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 183 | ||||
| -rw-r--r-- | ghc/ghc-bin.cabal.in | 13 |
6 files changed, 680 insertions, 7 deletions
diff --git a/ghc/GhciFind.hs b/ghc/GhciFind.hs new file mode 100644 index 0000000000..61fa036cbe --- /dev/null +++ b/ghc/GhciFind.hs @@ -0,0 +1,260 @@ +{-# 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 -> + do (return (Left (showppr d (modulePackageKey modL) ++ ":" ++ + 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 diff --git a/ghc/GhciInfo.hs b/ghc/GhciInfo.hs new file mode 100644 index 0000000000..9fd5e35756 --- /dev/null +++ b/ghc/GhciInfo.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | 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.List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Time +import Desugar +import GHC +import GhciTypes +import GhcMonad +import NameSet +import Outputable +import Prelude hiding (mod) +import System.Directory +import TcHsSyn +import Var + +-- | 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 + liftIO (filterM cacheInvalid loaded) >>= \case + [] -> return ms + invalidated -> do + liftIO (putStrLn ("Collecting type info for " ++ + show (length invalidated) ++ + " module(s) ... ")) + + foldM (go df) ms invalidated + where + go df m name = do { info <- getModInfo name; return (M.insert name info m) } + `gcatch` + (\(e :: SomeException) -> do + liftIO $ putStrLn + ("Error while getting type info from " ++ + showppr df name ++ ": " ++ show e) + return m) + + cacheInvalid name = case M.lookup name ms of + Nothing -> return True + Just mi -> do + let fp = ml_obj_file (ms_location (modinfoSummary mi)) + last' = modinfoLastUpdate mi + exists <- doesFileExist fp + if exists + then (> last') <$> getModificationTime fp + else return True + +-- | Get info about the module: summary, types, etc. +getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo +getModInfo name = do + m <- getModSummary name + p <- parseModule m + typechecked <- typecheckModule p + allTypes <- processAllTypeCheckedModule typechecked + let i = tm_checked_module_info typechecked + now <- liftIO getCurrentTime + return (ModInfo m allTypes i now) + +-- | Get ALL source spans in the module. +processAllTypeCheckedModule :: GhcMonad m => TypecheckedModule -> m [SpanInfo] +processAllTypeCheckedModule tcm = do + bts <- mapM (getTypeLHsBind tcm) bs + ets <- mapM (getTypeLHsExpr tcm) es + pts <- mapM (getTypeLPat tcm) ps + return (mapMaybe toSpanInfo + (sortBy cmp(concat bts ++ catMaybes (ets ++ pts)))) + where + tcs = tm_typechecked_source tcm + bs = listifyAllSpans tcs :: [LHsBind Id] + es = listifyAllSpans tcs :: [LHsExpr Id] + ps = listifyAllSpans tcs :: [LPat Id] + + cmp (_,a,_) (_,b,_) + | a `isSubspanOf` b = LT + | b `isSubspanOf` a = GT + | otherwise = EQ + +getTypeLHsBind :: (GhcMonad m) => TypecheckedModule -> LHsBind Id + -> m [(Maybe Id,SrcSpan,Type)] +getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _}) = + return (return (Just (unLoc pid),getLoc pid,varType (unLoc pid))) +getTypeLHsBind _ _ = return [] -- TODO: are these all cases we need to handle? + + +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 (mid, getLoc e, CoreUtils.exprType expr) + where + mid | HsVar i <- unwrapVar (unLoc e) = Just i + | otherwise = Nothing + + 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 + + +-- | Pretty print the types into a 'SpanInfo'. +toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo +toSpanInfo (n,RealSrcSpan spn,typ) = + Just (SpanInfo (srcSpanStartLine spn) + (srcSpanStartCol spn - 1) + (srcSpanEndLine spn) + (srcSpanEndCol spn - 1) + (Just typ) + n) +toSpanInfo _ = Nothing + + +-- | Pretty print something to string. +showppr :: Outputable a => DynFlags -> a -> String +showppr dflags = showSDocForUser dflags neverQualify . ppr + + +-- | Get ALL source spans in the source. +listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a] +listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x])) + where + p (L spn _) = isGoodSrcSpan spn + + +everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r +everythingAllSpans k z f x + | (False `mkQ` (const True :: NameSet -> Bool)) x = z + | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x) + +-- aliases from syb +type GenericQ r = forall a. Data a => a -> r + +mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r +(r `mkQ` br) a = maybe r br (cast a) diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 8c755be930..1722122f75 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -20,6 +20,7 @@ module GhciMonad ( getDynFlags, runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs, + printForUserNeverQualify, printForUserModInfo, printForUser, printForUserPartWay, prettyLocations, initInterpBuffering, turnOffBuffering, flushInterpBuffers, @@ -27,6 +28,9 @@ module GhciMonad ( #include "HsVersions.h" +import GhciTypes +import Data.Map.Strict (Map) + import qualified GHC import GhcMonad hiding (liftIO) import Outputable hiding (printForUser, printForUserPartWay) @@ -110,6 +114,7 @@ data GHCiState = GHCiState -- help text to display to a user short_help :: String, long_help :: String, + mod_infos :: !(Map ModuleName ModInfo), lastErrorLocations :: IORef [(FastString, Int)] } @@ -120,6 +125,7 @@ data GHCiOption | 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 @@ -251,6 +257,18 @@ unsetOption opt = do st <- getGHCiState setGHCiState (st{ options = filter (/= opt) (options st) }) +printForUserNeverQualify :: GhcMonad m => SDoc -> m () +printForUserNeverQualify doc = do + dflags <- getDynFlags + liftIO $ Outputable.printForUser dflags stdout neverQualify doc + +printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m () +printForUserModInfo info doc = do + dflags <- getDynFlags + mUnqual <- GHC.mkPrintUnqualifiedForModule info + unqual <- maybe GHC.getPrintUnqual return mUnqual + liftIO $ Outputable.printForUser dflags stdout unqual doc + printForUser :: GhcMonad m => SDoc -> m () printForUser doc = do unqual <- GHC.getPrintUnqual diff --git a/ghc/GhciTypes.hs b/ghc/GhciTypes.hs new file mode 100644 index 0000000000..00f20aefd3 --- /dev/null +++ b/ghc/GhciTypes.hs @@ -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) diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 2dcedb0b0b..4deab1c13f 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1,5 +1,11 @@ -{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, TupleSections, - RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly @@ -25,6 +31,9 @@ module InteractiveUI ( import qualified GhciMonad ( args, runStmt ) import GhciMonad hiding ( args, runStmt ) import GhciTags +import GhciTypes +import GhciInfo +import GhciFind import Debugger -- The GHC interface @@ -33,7 +42,7 @@ import ErrUtils import GhcMonad ( modifySession ) import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), - TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, + TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, getModuleGraph, handleSourceError ) import HsImpExp import HsSyn @@ -80,6 +89,7 @@ import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, partition, sort, sortBy ) import Data.Maybe +import qualified Data.Map as M import Exception hiding (catch) @@ -192,6 +202,10 @@ ghciCommands = [ ("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) @@ -268,6 +282,15 @@ defFullHelpText = " :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" ++ @@ -314,6 +337,7 @@ defFullHelpText = " +r revert top-level expressions after each evaluation\n" ++ " +s print timing/memory stats after each evaluation\n" ++ " +t print type after evaluation\n" ++ + " +c collect type/location info after loading modules\n" ++ " -<flags> most GHC command line flags can also be set here\n" ++ " (eg. -v2, -XFlexibleInstances, etc.)\n" ++ " for GHCi-specific flags, see User's Guide,\n"++ @@ -439,6 +463,7 @@ interactiveUI config srcs maybe_exprs = do ghc_e = isJust maybe_exprs, short_help = shortHelpText config, long_help = fullHelpText config, + mod_infos = M.empty, lastErrorLocations = lastErrLocationsRef } @@ -1463,8 +1488,16 @@ loadModule' files = do _ <- 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 () @@ -1616,6 +1649,144 @@ typeOfExpr str 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 + neverQualify + (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 () @@ -2325,6 +2496,7 @@ strToGHCiOpt "m" = Just Multiline strToGHCiOpt "s" = Just ShowTiming strToGHCiOpt "t" = Just ShowType strToGHCiOpt "r" = Just RevertCAFs +strToGHCiOpt "c" = Just CollectInfo strToGHCiOpt _ = Nothing optToStr :: GHCiOption -> String @@ -2332,6 +2504,7 @@ optToStr Multiline = "m" optToStr ShowTiming = "s" optToStr ShowType = "t" optToStr RevertCAFs = "r" +optToStr CollectInfo = "c" -- --------------------------------------------------------------------------- diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index 30eb7a758d..6c63781b73 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -43,19 +43,28 @@ Executable ghc GHC-Options: -Wall if flag(ghci) - Build-depends: deepseq >= 1.4 && < 1.5 + Build-depends: + containers == 0.5.*, + deepseq == 1.4.*, + time == 1.5.* CPP-Options: -DGHCI GHC-Options: -fno-warn-name-shadowing Other-Modules: - InteractiveUI + GhciFind + GhciInfo GhciMonad GhciTags + GhciTypes + InteractiveUI Build-Depends: transformers, haskeline Other-Extensions: + BangPatterns FlexibleInstances MagicHash + RecordWildCards TupleSections UnboxedTuples + ViewPatterns Other-Extensions: CPP |