Commit dd56eb1e authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺
Browse files

Merge new commands from ghci-ng (re #10874)

This adds the new commands `:all-types`, `:loc-at`, `:type-at`, and
`:uses` designed for editor-integration (such as Emacs' `haskell-mode`).

This was originally implemented by Chris Done on

  https://github.com/chrisdone/ghci-ng

and has been in use by Emacs' `haskell-mode` for over a year already,
and closely missed the GHC 7.10 release back then.

I've squashed the commits, rebased to GHC HEAD, and heavily refactored and
improved the patch.

Tests will be added in a separate commit.

Reviewed By: bgamari

Differential Revision: https://phabricator.haskell.org/D1240
parent bcc213db
......@@ -249,6 +249,11 @@ GHCi
- Added support for top-level function declarations (#7253).
- The new commands ``:all-types``, ``:loc-at``, ``:type-at``, and
``:uses`` designed for editor-integration
(such as Emacs' ``haskell-mode``) originally premiered by ``ghci-ng``
have been integrated into GHCi (#10874).
Template Haskell
~~~~~~~~~~~~~~~~
......
......@@ -1903,6 +1903,21 @@ commonly used commands.
available, or otherwise the module will be compiled to byte-code.
Using the ``*`` prefix forces the module to be loaded as byte-code.
``:all-types``
.. index::
single: :all-types
List all types collected for expressions and (local) bindings
currently loaded (while :ref:`+c` was active) with their respective
source-code span, e.g.
::
GhciTypes> :all-types
GhciTypes.hs:(38,13)-(38,24): Maybe Id
GhciTypes.hs:(45,10)-(45,29): Outputable SpanInfo
GhciTypes.hs:(45,10)-(45,29): (Rational -> SpanInfo -> SDoc) -> Outputable SpanInfo
``:back ⟨n⟩``
.. index::
single: :back
......@@ -2301,6 +2316,23 @@ commonly used commands.
- ``Prelude`` otherwise.
``:loc-at ⟨module⟩ ⟨line⟩ ⟨col⟩ ⟨end-line⟩ ⟨end-col⟩ [⟨name⟩]``
.. index::
single: :loc-at
Tries to find the definition site of the name at the given
source-code span, e.g.:
::
X> :loc-at X.hs 6 14 6 16 mu
X.hs:(8,7)-(8,9)
This command is useful when integrating GHCi with text editors and
IDEs for providing a goto-definition facility.
The ``:loc-at`` command requires :ref:`+c` to be set.
``:main ⟨arg1⟩ ... ⟨argn⟩``
.. index::
single: :main
......@@ -2599,6 +2631,26 @@ commonly used commands.
restriction is *not* applied to the expression during type
inference.
``:type-at ⟨module⟩ ⟨line⟩ ⟨col⟩ ⟨end-line⟩ ⟨end-col⟩ [⟨name⟩]``
.. index::
single: :type-at
Reports the inferred type at the given span/position in the module, e.g.:
::
*X> :type-at X.hs 6 6 6 7 f
Int -> Int
This command is useful when integrating GHCi with text editors and
IDEs for providing a show-type-under-point facility.
The last string parameter is useful for when the span is out of
date, i.e. the file changed and the code has moved. In which case
``:type-at`` falls back to a general :ref:`:type` like lookup.
The ``:type-at`` command requires :ref:`+c` to be set.
``:undef ⟨name⟩``
.. index::
single: :undef
......@@ -2612,6 +2664,26 @@ commonly used commands.
Unsets certain options. See :ref:`ghci-set` for a list of available
options.
``:uses ⟨module⟩ ⟨line⟩ ⟨col⟩ ⟨end-line⟩ ⟨end-col⟩ [⟨name⟩]``
.. index::
single: :uses
Reports all module-local uses of the thing at the given position
in the module, e.g.:
::
:uses GhciFind.hs 53 66 53 70 name
GhciFind.hs:(46,25)-(46,29)
GhciFind.hs:(47,37)-(47,41)
GhciFind.hs:(53,66)-(53,70)
GhciFind.hs:(57,62)-(57,66)
This command is useful for highlighting and navigating all uses of
an identifier in editors and IDEs.
The ``:type-at`` command requires :ref:`+c` to be set.
``:! ⟨command⟩``
.. index::
single: :!
......@@ -2649,6 +2721,14 @@ GHCi options may be set using ``:set`` and unset using ``:unset``.
The available GHCi options are:
``+c``
.. index::
single: +c
Collect type and location information after loading modules.
The commands :ref:`:all-types`, :ref:`loc-at`, :ref:`type-at`,
and :ref:`uses` require ``+c`` to be active.
``+m``
.. index::
single: +m
......
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Get information on modules, expreesions, and identifiers
module GhciInfo
( ModInfo(..)
, SpanInfo(..)
, spanInfoFromRealSrcSpan
, collectInfo
, findLoc
, findNameUses
, findType
, getModInfo
) where
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Data
import Data.Function
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Time
import Prelude hiding (mod)
import System.Directory
import qualified CoreUtils
import Desugar
import DynFlags (HasDynFlags(..))
import FastString
import GHC
import GhcMonad
import Name
import NameSet
import Outputable
import SrcLoc
import TcHsSyn
import Var
-- | Info about a module. This information is generated every time a
-- module is loaded.
data ModInfo = ModInfo
{ modinfoSummary :: !ModSummary
-- ^ Summary generated by GHC. Can be used to access more
-- information about the module.
, modinfoSpans :: [SpanInfo]
-- ^ Generated set of information about all spans in the
-- module that correspond to some kind of identifier for
-- which there will be type info and/or location info.
, modinfoInfo :: !ModuleInfo
-- ^ Again, useful from GHC for accessing information
-- (exports, instances, scope) from a module.
, modinfoLastUpdate :: !UTCTime
}
-- | Type of some span of source code. Most of these fields are
-- unboxed but Haddock doesn't show that.
data SpanInfo = SpanInfo
{ spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan
-- ^ The span we associate information with
, spaninfoType :: !(Maybe Type)
-- ^ The 'Type' associated with the span
, spaninfoVar :: !(Maybe Id)
-- ^ The actual 'Var' associated with the span, if
-- any. This can be useful for accessing a variety of
-- information about the identifier such as module,
-- locality, definition location, etc.
}
-- | Test whether second span is contained in (or equal to) first span.
-- This is basically 'containsSpan' for 'SpanInfo'
containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
containsSpanInfo = containsSpan `on` spaninfoSrcSpan
-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'
spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]
spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'
-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a
-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'
-- respectively)
spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
spanInfoFromRealSrcSpan spn mty mvar =
SpanInfo spn mty mvar
-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs
-- only a 'RealSrcSpan'
spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo
spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing
-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'
srcSpanFilePath :: RealSrcSpan -> FilePath
srcSpanFilePath = unpackFS . srcSpanFile
-- | Try to find the location of the given identifier at the given
-- position in the module.
findLoc :: GhcMonad m
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
-> ExceptT SDoc m (ModInfo,Name,SrcSpan)
findLoc infos span0 string = do
name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
guessModule infos (srcSpanFilePath span0)
info <- maybeToExceptT "No module info for current file! Try loading it?" $
MaybeT $ pure $ M.lookup name infos
name' <- findName infos span0 info string
case getSrcSpan name' of
UnhelpfulSpan{} -> do
throwE ("Found a name, but no location information." <+>
"The module is:" <+>
maybe "<unknown>" (ppr . moduleName)
(nameModule_maybe name'))
span' -> return (info,name',span')
-- | Find any uses of the given identifier in the codebase.
findNameUses :: (GhcMonad m)
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
-> ExceptT SDoc m [SrcSpan]
findNameUses infos span0 string =
locToSpans <$> findLoc infos span0 string
where
locToSpans (modinfo,name',span') =
stripSurrounding (span' : map toSrcSpan spans)
where
toSrcSpan = RealSrcSpan . spaninfoSrcSpan
spans = filter ((== Just name') . fmap getName . spaninfoVar)
(modinfoSpans modinfo)
-- | Filter out redundant spans which surround/contain other spans.
stripSurrounding :: [SrcSpan] -> [SrcSpan]
stripSurrounding xs = filter (not . isRedundant) xs
where
isRedundant x = any (x `strictlyContains`) xs
(RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)
= s1 /= s2 && s1 `containsSpan` s2
_ `strictlyContains` _ = False
-- | Try to resolve the name located at the given position, or
-- otherwise resolve based on the current module's scope.
findName :: GhcMonad m
=> Map ModuleName ModInfo
-> RealSrcSpan
-> ModInfo
-> String
-> ExceptT SDoc m Name
findName infos span0 mi string =
case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of
Nothing -> tryExternalModuleResolution
Just name ->
case getSrcSpan name of
UnhelpfulSpan {} -> tryExternalModuleResolution
RealSrcSpan {} -> return (getName name)
where
tryExternalModuleResolution =
case find (matchName $ mkFastString string)
(fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of
Nothing -> throwE "Couldn't resolve to any modules."
Just imported -> resolveNameFromModule infos imported
matchName :: FastString -> Name -> Bool
matchName str name =
str ==
occNameFS (getOccName name)
-- | Try to resolve the name from another (loaded) module's exports.
resolveNameFromModule :: GhcMonad m
=> Map ModuleName ModInfo
-> Name
-> ExceptT SDoc m Name
resolveNameFromModule infos name = do
modL <- maybe (throwE $ "No module for" <+> ppr name) return $
nameModule_maybe name
info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>
ppr modL)) return $
M.lookup (moduleName modL) infos
maybe (throwE "No matching export in any local modules.") return $
find (matchName name) (modInfoExports (modinfoInfo info))
where
matchName :: Name -> Name -> Bool
matchName x y = occNameFS (getOccName x) ==
occNameFS (getOccName y)
-- | Try to resolve the type display from the given span.
resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var
resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $
reverse spans' `spaninfosWithin` si
-- | Try to find the type of the given span.
findType :: GhcMonad m
=> Map ModuleName ModInfo
-> RealSrcSpan
-> String
-> ExceptT SDoc m (ModInfo, Type)
findType infos span0 string = do
name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
guessModule infos (srcSpanFilePath span0)
info <- maybeToExceptT "No module info for current file! Try loading it?" $
MaybeT $ pure $ M.lookup name infos
case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of
Nothing -> (,) info <$> lift (exprType string)
Just ty -> return (info, ty)
where
-- | Try to resolve the type display from the given span.
resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type
resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $
reverse spans' `spaninfosWithin` si
-- | Guess a module name from a file path.
guessModule :: GhcMonad m
=> Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
guessModule infos fp = do
target <- lift $ guessTarget fp Nothing
case targetId target of
TargetModule mn -> return mn
TargetFile fp' _ -> guessModule' fp'
where
guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName
guessModule' fp' = case findModByFp fp' of
Just mn -> return mn
Nothing -> do
fp'' <- liftIO (makeRelativeToCurrentDirectory fp')
target' <- lift $ guessTarget fp'' Nothing
case targetId target' of
TargetModule mn -> return mn
_ -> MaybeT . pure $ findModByFp fp''
findModByFp :: FilePath -> Maybe ModuleName
findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)
where
mifp :: (ModuleName, ModInfo) -> Maybe FilePath
mifp = ml_hs_file . ms_location . modinfoSummary . snd
-- | Collect type info data for the loaded modules.
collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
-> m (Map ModuleName ModInfo)
collectInfo ms loaded = do
df <- getDynFlags
liftIO (filterM cacheInvalid loaded) >>= \case
[] -> return ms
invalidated -> do
liftIO (putStrLn ("Collecting type info for " ++
show (length invalidated) ++
" module(s) ... "))
foldM (go df) ms invalidated
where
go df m name = do { info <- getModInfo name; return (M.insert name info m) }
`gcatch`
(\(e :: SomeException) -> do
liftIO $ putStrLn
$ showSDocForUser df alwaysQualify
$ "Error while getting type info from" <+>
ppr name <> ":" <+> text (show e)
return m)
cacheInvalid name = case M.lookup name ms of
Nothing -> return True
Just mi -> do
let fp = ml_obj_file (ms_location (modinfoSummary mi))
last' = modinfoLastUpdate mi
exists <- doesFileExist fp
if exists
then (> last') <$> getModificationTime fp
else return True
-- | Get info about the module: summary, types, etc.
getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
getModInfo name = do
m <- getModSummary name
p <- parseModule m
typechecked <- typecheckModule p
allTypes <- processAllTypeCheckedModule typechecked
let i = tm_checked_module_info typechecked
now <- liftIO getCurrentTime
return (ModInfo m allTypes i now)
-- | Get ALL source spans in the module.
processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule
-> m [SpanInfo]
processAllTypeCheckedModule tcm = do
bts <- mapM getTypeLHsBind $ listifyAllSpans tcs
ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs
pts <- mapM getTypeLPat $ listifyAllSpans tcs
return $ mapMaybe toSpanInfo
$ sortBy cmpSpan
$ catMaybes (bts ++ ets ++ pts)
where
tcs = tm_typechecked_source tcm
-- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's
getTypeLHsBind :: LHsBind Id -> m (Maybe (Maybe Id,SrcSpan,Type))
getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _})
= pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))
getTypeLHsBind _ = pure Nothing
-- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's
getTypeLHsExpr :: LHsExpr Id -> m (Maybe (Maybe Id,SrcSpan,Type))
getTypeLHsExpr e = do
hs_env <- getSession
(_,mbe) <- liftIO $ deSugarExpr hs_env e
return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe
where
mid :: Maybe Id
mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i
| otherwise = Nothing
unwrapVar (HsWrap _ var) = var
unwrapVar e' = e'
-- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
getTypeLPat :: LPat Id -> m (Maybe (Maybe Id,SrcSpan,Type))
getTypeLPat (L spn pat) =
pure (Just (getMaybeId pat,spn,hsPatType pat))
where
getMaybeId (VarPat (L _ vid)) = Just vid
getMaybeId _ = Nothing
-- | Get ALL source spans in the source.
listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]
listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))
where
p (L spn _) = isGoodSrcSpan spn
-- | Variant of @syb@'s @everything@ (which summarises all nodes
-- in top-down, left-to-right order) with a stop-condition on 'NameSet's
everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
everythingAllSpans k z f x
| (False `mkQ` (const True :: NameSet -> Bool)) x = z
| otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)
cmpSpan (_,a,_) (_,b,_)
| a `isSubspanOf` b = LT
| b `isSubspanOf` a = GT
| otherwise = EQ
-- | Pretty print the types into a 'SpanInfo'.
toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
toSpanInfo (n,RealSrcSpan spn,typ)
= Just $ spanInfoFromRealSrcSpan spn (Just typ) n
toSpanInfo _ = Nothing
-- helper stolen from @syb@ package
type GenericQ r = forall a. Data a => a -> r
mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
(r `mkQ` br) a = maybe r br (cast a)
......@@ -21,6 +21,7 @@ module GhciMonad (
runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,
printForUserNeverQualify, printForUserModInfo,
printForUser, printForUserPartWay, prettyLocations,
initInterpBuffering,
turnOffBuffering, turnOffBuffering_,
......@@ -30,6 +31,7 @@ module GhciMonad (
#include "HsVersions.h"
import GhciInfo (ModInfo)
import qualified GHC
import GhcMonad hiding (liftIO)
import Outputable hiding (printForUser, printForUserPartWay)
......@@ -55,6 +57,7 @@ import System.Console.Haskeline (CompletionFunc, InputT)
import qualified System.Console.Haskeline as Haskeline
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Data.Map.Strict (Map)
-----------------------------------------------------------------------------
-- GHCi monad
......@@ -107,6 +110,8 @@ data GHCiState = GHCiState
long_help :: String,
lastErrorLocations :: IORef [(FastString, Int)],
mod_infos :: !(Map ModuleName ModInfo),
-- hFlush stdout; hFlush stderr in the interpreter
flushStdHandles :: ForeignHValue,
-- hSetBuffering NoBuffering for stdin/stdout/stderr
......@@ -135,6 +140,8 @@ 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
......@@ -273,6 +280,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
......
{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, TupleSections,
RecordWildCards, MultiWayIf #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
......@@ -25,6 +34,7 @@ module InteractiveUI (
import qualified GhciMonad ( args, runStmt )
import GhciMonad hiding ( args, runStmt )
import GhciTags
import GhciInfo
import Debugger
-- The GHC interface
......@@ -35,7 +45,7 @@ import GhcMonad ( modifySession )
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
handleSourceError )
getModuleGraph, handleSourceError )
import HsImpExp
import HsSyn
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
......@@ -73,6 +83,7 @@ import Control.DeepSeq (deepseq)
import Control.Monad as Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Data.Array
import qualified Data.ByteString.Char8 as BS
......@@ -82,6 +93,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)
import Foreign
......@@ -187,7 +199,11 @@ ghciCommands = map mkCmd [
("undef", keepGoing undefineMacro, completeMacro),
("unset", keepGoing unsetOptions, completeSetOptions)
] ++ map mkCmdHidden [ -- hidden commands
("complete", keepGoing completeCmd)
("all-types", keepGoing' allTypesCmd),
("complete", keepGoing completeCmd),
("loc-at", keepGoing' locAtCmd),
("type-at", keepGoing' typeAtCmd),
("uses", keepGoing' usesCmd)
]
where
mkCmd (n,a,c) = Command { cmdName = n
......@@ -318,6 +334,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"++
......@@ -437,6 +454,7 @@ interactiveUI config srcs maybe_exprs = do
short_help = shortHelpText config,
long_help = fullHelpText config,
lastErrorLocations = lastErrLocationsRef,
mod_infos = M.empty,
flushStdHandles = flush,