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

This was for the major part implemented by Chris Done on

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

and has been in use by Emacs's `haskell-mode` for about a year already.

I've squashed the commits, rebased to GHC HEAD, and cleaned up the patch.

-----

The new commands this commit adds are (description copied from [1]):

* The `:set +c` command: collect information about modules after
  they've been loaded, and remember it between loads (including failed
  ones). I recommend adding this line to your `~/.ghci` file.

* The `:type-at` command (requires `+c`): show the type at the given position in the
  module. Example:

  ``` haskell
  *X> :type-at X.hs 6 6 6 7 f
  Int -> Int
  ```

  This can be useful to get the type of a pattern variable or an
  arbitrary selected expression.

  The parameters are:

        <filename> <line> <col> <end-line> <end-col> <text>

  `text` is used for when the span is out of date, i.e. the file
  changed and the code has moved, text can be used to confirm the
  contents of the span matches, and to fallback to a general :t-like
  lookup.

* The `:loc-at` command (requires `+c`): get the location of the thing at the given
  position in the module. Example:

  ``` haskell
  *X> :loc-at X.hs 6 14 6 16 mu
  X.hs:(8,7)-(8,9)
  ```

  This is useful for goto-definition features of editors and IDEs.

  Parameters are the same as for `:type-at`.

* The `:uses` command (requires `+c`): gets all module-local uses of
  the thing at the given position in the module. Example:

  ``` haskell
  > :uses /home/chris/Projects/ghci-ng/ghc/GhciFind.hs 53 66 53 70 name
  /home/chris/Projects/ghci-ng/ghc/GhciFind.hs:(46,25)-(46,29)
  /home/chris/Projects/ghci-ng/ghc/GhciFind.hs:(47,37)-(47,41)
  /home/chris/Projects/ghci-ng/ghc/GhciFind.hs:(53,66)-(53,70)
  /home/chris/Projects/ghci-ng/ghc/GhciFind.hs:(57,62)-(57,66)
  ```

  This is useful for highlighting and navigating all uses of an
  identifier in editors and IDEs.

  Parameters are the same as for `:type-at`.

* The `:all-types` command (requires `+c`): list *all* types in the project:
  expressions, bindings top-level and local. Sort of like `:browse` on
  steroids.

  ``` haskell
  > :all-types
  ghc/GhciTypes.hs:(38,13)-(38,24): Maybe Id
  ghc/GhciTypes.hs:(45,10)-(45,29): Outputable SpanInfo
  ghc/GhciTypes.hs:(45,10)-(45,29): (Rational -> SpanInfo -> SDoc) -> Outputable SpanInfo
  ```

[1]: https://github.com/chrisdone/ghci-ng/blob/master/README.md

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