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

4 files changed, 607 insertions, 32 deletions

diff --git a/ghc/GhciInfo.hs b/ghc/GhciInfo.hs
new file mode 100644
index 0000000000..2fa9a950e1
--- /dev/null
+++ b/ghc/GhciInfo.hs
@@ -0,0 +1,366 @@
+{-# 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)
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index d8fa0e1146..0b22d1e29d 100644
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -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
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 55df63771e..1742253332 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -1,5 +1,14 @@
-{-# 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,
                    noBuffering        = nobuffering
                  }
@@ -1425,6 +1443,7 @@ deferredLoad defer load = do
 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
 loadModule fs = timeIt (const Nothing) (loadModule' fs)
 
+-- | @:load@ command
 loadModule_ :: Bool -> [FilePath] -> InputT GHCi ()
 loadModule_ defer fs = deferredLoad defer (loadModule (zip fs (repeat Nothing)))
 
@@ -1447,10 +1466,9 @@ loadModule' files = do
   _ <- GHC.load LoadAllTargets
 
   GHC.setTargets targets
-  doLoad False LoadAllTargets
-
+  doLoadAndCollectInfo False LoadAllTargets
 
--- :add
+-- | @:add@ command
 addModule :: [FilePath] -> InputT GHCi ()
 addModule files = do
   lift revertCAFs -- always revert CAFs on load/add.
@@ -1459,15 +1477,41 @@ addModule files = do
   -- remove old targets with the same id; e.g. for :add *M
   mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
   mapM_ GHC.addTarget targets
-  _ <- doLoad False LoadAllTargets
+  _ <- doLoadAndCollectInfo False LoadAllTargets
   return ()
 
-
--- :reload
+-- | @:reload@ command
 reloadModule :: Bool -> String -> InputT GHCi ()
-reloadModule defer m = deferredLoad defer load
-  where load = doLoad True $
-               if null m then LoadAllTargets else LoadUpTo (GHC.mkModuleName m)
+reloadModule defer m = deferredLoad defer $
+                       doLoadAndCollectInfo True loadTargets
+  where
+    loadTargets | null m    = LoadAllTargets
+                | otherwise = LoadUpTo (GHC.mkModuleName m)
+
+-- | Load/compile targets and (optionally) collect module-info
+--
+-- This collects the necessary SrcSpan annotated type information (via
+-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,
+-- and @:uses@ commands.
+--
+-- Meta-info collection is not enabled by default and needs to be
+-- enabled explicitly via @:set +c@.  The reason is that collecting
+-- the type-information for all sub-spans can be quite expensive, and
+-- since those commands are designed to be used by editors and
+-- tooling, it's useless to collect this data for normal GHCi
+-- sessions.
+doLoadAndCollectInfo :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
+doLoadAndCollectInfo retain_context howmuch = do
+  doCollectInfo <- lift (isOptionSet CollectInfo)
+
+  doLoad retain_context howmuch >>= \case
+    Succeeded | doCollectInfo -> do
+      loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name
+      v <- mod_infos <$> getGHCiState
+      !newInfos <- collectInfo v loaded
+      modifyGHCiState (\st -> st { mod_infos = newInfos })
+      return Succeeded
+    flag -> return flag
 
 doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
 doLoad retain_context howmuch = do
@@ -1589,27 +1633,158 @@ modulesLoadedMsg ok mods = do
   when (verbosity dflags > 0) $
      liftIO $ putStrLn $ showSDocForUser dflags unqual msg
 
+
+-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors
+-- and printing 'throwE' strings to 'stderr'
+runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()
+runExceptGhcMonad act = handleSourceError GHC.printException $
+                        either handleErr pure =<<
+                        runExceptT act
+  where
+    handleErr sdoc = do
+        dflags <- getDynFlags
+        liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc
+
+-- | Inverse of 'runExceptT' for \"pure\" computations
+-- (c.f. 'except' for 'Except')
+exceptT :: Applicative m => Either e a -> ExceptT e m a
+exceptT = ExceptT . pure
+
 -----------------------------------------------------------------------------
--- :type
+-- | @:type@ command
 
 typeOfExpr :: String -> InputT GHCi ()
-typeOfExpr str
-  = handleSourceError GHC.printException
-  $ do
-       ty <- GHC.exprType str
-       printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)]
+typeOfExpr str = handleSourceError GHC.printException $ do
+    ty <- GHC.exprType str
+    printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)]
 
 -----------------------------------------------------------------------------
--- :kind
+-- | @:type-at@ command
 
-kindOfType :: Bool -> String -> InputT GHCi ()
-kindOfType norm str
-  = handleSourceError GHC.printException
-  $ do
-       (ty, kind) <- GHC.typeKind norm str
-       printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
-                           , ppWhen norm $ equals <+> pprTypeForUser ty ]
+typeAtCmd :: String -> InputT GHCi ()
+typeAtCmd str = runExceptGhcMonad $ do
+    (span',sample) <- exceptT $ parseSpanArg str
+    infos      <- mod_infos <$> getGHCiState
+    (info, ty) <- findType infos span' sample
+    lift $ printForUserModInfo (modinfoInfo info)
+                               (sep [text sample,nest 2 (dcolon <+> ppr ty)])
+
+-----------------------------------------------------------------------------
+-- | @:uses@ command
+
+usesCmd :: String -> InputT GHCi ()
+usesCmd str = runExceptGhcMonad $ do
+    (span',sample) <- exceptT $ parseSpanArg str
+    infos  <- mod_infos <$> getGHCiState
+    uses   <- findNameUses infos span' sample
+    forM_ uses (liftIO . putStrLn . showSrcSpan)
+
+-----------------------------------------------------------------------------
+-- | @:loc-at@ command
 
+locAtCmd :: String -> InputT GHCi ()
+locAtCmd str = runExceptGhcMonad $ do
+    (span',sample) <- exceptT $ parseSpanArg str
+    infos    <- mod_infos <$> getGHCiState
+    (_,_,sp) <- findLoc infos span' sample
+    liftIO . putStrLn . showSrcSpan $ sp
+
+-----------------------------------------------------------------------------
+-- | @:all-types@ command
+
+allTypesCmd :: String -> InputT GHCi ()
+allTypesCmd _ = runExceptGhcMonad $ do
+    infos <- mod_infos <$> getGHCiState
+    forM_ (M.elems infos) $ \mi ->
+        forM_ (modinfoSpans mi) (lift . printSpan)
+  where
+    printSpan span'
+      | Just ty <- spaninfoType span' = do
+        df <- getDynFlags
+        let tyInfo = unwords . words $
+                     showSDocForUser df alwaysQualify (pprTypeForUser ty)
+        liftIO . putStrLn $
+            showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo
+      | otherwise = return ()
+
+-----------------------------------------------------------------------------
+-- Helpers for locAtCmd/typeAtCmd/usesCmd
+
+-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>
+parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)
+parseSpanArg s = do
+    (fp,s0) <- readAsString (skipWs s)
+    s0'     <- skipWs1 s0
+    (sl,s1) <- readAsInt s0'
+    s1'     <- skipWs1 s1
+    (sc,s2) <- readAsInt s1'
+    s2'     <- skipWs1 s2
+    (el,s3) <- readAsInt s2'
+    s3'     <- skipWs1 s3
+    (ec,s4) <- readAsInt s3'
+
+    trailer <- case s4 of
+        [] -> Right ""
+        _  -> skipWs1 s4
+
+    let fs    = mkFastString fp
+        span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)
+                              (mkRealSrcLoc fs el ec)
+
+    return (span',trailer)
+  where
+    readAsInt :: String -> Either SDoc (Int,String)
+    readAsInt "" = Left "Premature end of string while expecting Int"
+    readAsInt s0 = case reads s0 of
+        [s_rest] -> Right s_rest
+        _        -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")
+
+    readAsString :: String -> Either SDoc (String,String)
+    readAsString s0
+      | '"':_ <- s0 = case reads s0 of
+          [s_rest] -> Right s_rest
+          _        -> leftRes
+      | s_rest@(_:_,_) <- breakWs s0 = Right s_rest
+      | otherwise = leftRes
+      where
+        leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")
+
+    skipWs1 :: String -> Either SDoc String
+    skipWs1 (c:cs) | isWs c = Right (skipWs cs)
+    skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))
+
+    isWs    = (`elem` [' ','\t'])
+    skipWs  = dropWhile isWs
+    breakWs = break isWs
+
+
+-- | Pretty-print \"real\" 'SrcSpan's as
+-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@
+-- while simply unpacking 'UnhelpfulSpan's
+showSrcSpan :: SrcSpan -> String
+showSrcSpan (UnhelpfulSpan s)  = unpackFS s
+showSrcSpan (RealSrcSpan spn)  = showRealSrcSpan spn
+
+-- | Variant of 'showSrcSpan' for 'RealSrcSpan's
+showRealSrcSpan :: RealSrcSpan -> String
+showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc
+                             , ")-(", show el, ",", show ec, ")"
+                             ]
+  where
+    fp = unpackFS (srcSpanFile spn)
+    sl = srcSpanStartLine spn
+    sc = srcSpanStartCol  spn
+    el = srcSpanEndLine   spn
+    ec = srcSpanEndCol    spn
+
+-----------------------------------------------------------------------------
+-- | @:kind@ command
+
+kindOfType :: Bool -> String -> InputT GHCi ()
+kindOfType norm str = handleSourceError GHC.printException $ do
+    (ty, kind) <- GHC.typeKind norm str
+    printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
+                        , ppWhen norm $ equals <+> pprTypeForUser ty ]
 
 -----------------------------------------------------------------------------
 -- :quit
@@ -2307,6 +2482,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
@@ -2314,6 +2490,7 @@ optToStr Multiline  = "m"
 optToStr ShowTiming = "s"
 optToStr ShowType   = "t"
 optToStr RevertCAFs = "r"
+optToStr CollectInfo = "c"
 
 
 -- ---------------------------------------------------------------------------
@@ -2389,7 +2566,7 @@ showImports = do
         | not (xopt LangExt.ImplicitPrelude dflags)      = []
         | otherwise = ["import Prelude -- implicit"]
 
-      trans_comment s = s ++ " -- added automatically"
+      trans_comment s = s ++ " -- added automatically" :: String
   --
   liftIO $ mapM_ putStrLn (prel_imp ++ map show_one rem_ctx
                                     ++ map (trans_comment . show_one) trans_ctx)
diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in
index 45193e36ee..885e587468 100644
--- a/ghc/ghc-bin.cabal.in
+++ b/ghc/ghc-bin.cabal.in
@@ -44,21 +44,34 @@ Executable ghc
 
     GHC-Options: -Wall
     if flag(ghci)
-        Build-depends: deepseq >= 1.4 && < 1.5,
-                       ghci
+        -- NB: this is never built by the bootstrapping GHC+libraries
+        Build-depends:
+            ghci,
+            containers == 0.5.*,
+            deepseq    == 1.4.*,
+            time       == 1.6.*
         CPP-Options: -DGHCI
         GHC-Options: -fno-warn-name-shadowing
         Other-Modules:
-            InteractiveUI
+            GhciInfo
             GhciMonad
             GhciTags
+            InteractiveUI
         Build-Depends: transformers, haskeline
         Other-Extensions:
+            BangPatterns
             FlexibleInstances
+            LambdaCase
             MagicHash
-            TupleSections
+            MultiWayIf
+            OverloadedStrings
+            RankNTypes
+            RecordWildCards
+            ScopedTypeVariables
             UnboxedTuples
+            ViewPatterns
 
     Other-Extensions:
         CPP
         NondecreasingIndentation
+        TupleSections