Add GHCi :instances command

This commit adds the `:instances` command to ghci following proosal
number 41.

This makes it possible to query which instances are available to a given
type.

The output of this command is all the possible instances with type
variables and constraints instantiated.

12 files changed, 314 insertions, 6 deletions

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 9fa8911d76..d89ccf8dea 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -219,6 +219,8 @@ module GHC (
         Kind,
         PredType,
         ThetaType, pprForAll, pprThetaArrowTy,
+        parseInstanceHead,
+        getInstancesForType,
 
         -- ** Entities
         TyThing(..),
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 90b5ef594e..a99fde706e 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -67,6 +67,7 @@ module HscMain
     , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
     , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
     , hscParseExpr
+    , hscParseType
     , hscCompileCoreExpr
     -- * Low-level exports for hooks
     , hscCompileCoreExpr'
@@ -113,6 +114,7 @@ import SrcLoc
 import TcRnDriver
 import TcIface          ( typecheckIface )
 import TcRnMonad
+import TcHsSyn          ( ZonkFlexi (DefaultFlexi) )
 import NameCache        ( initNameCache )
 import LoadIface        ( ifaceStats, initExternalPackageState )
 import PrelInfo
@@ -1761,7 +1763,7 @@ hscKcType
 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
     hsc_env <- getHscEnv
     ty <- hscParseType str
-    ioMsgMaybe $ tcRnType hsc_env normalise ty
+    ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty
 
 hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
 hscParseExpr expr = do
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 5f322006eb..091efb37fd 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -30,6 +30,8 @@ module InteractiveEval (
         exprType,
         typeKind,
         parseName,
+        parseInstanceHead,
+        getInstancesForType,
         getDocs,
         GetDocsFailure(..),
         showModule,
@@ -102,6 +104,19 @@ import GHC.Exts
 import Data.Array
 import Exception
 
+import TcRnDriver ( runTcInteractive, tcRnType )
+import TcHsSyn          ( ZonkFlexi (SkolemiseFlexi) )
+
+import TcEnv (tcGetInstEnvs)
+
+import Inst (instDFunType)
+import TcSimplify (solveWanteds)
+import TcRnMonad
+import TcEvidence
+import Data.Bifunctor (second)
+
+import TcSMonad (runTcS)
+
 -- -----------------------------------------------------------------------------
 -- running a statement interactively
 
@@ -937,6 +952,161 @@ typeKind  :: GhcMonad m => Bool -> String -> m (Type, Kind)
 typeKind normalise str = withSession $ \hsc_env -> do
    liftIO $ hscKcType hsc_env normalise str
 
+-- ----------------------------------------------------------------------------
+-- Getting the class instances for a type
+
+{-
+  Note [Querying instances for a type]
+
+  Here is the implementation of GHC proposal 41.
+  (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst)
+
+  The objective is to take a query string representing a (partial) type, and
+  report all the class single-parameter class instances available to that type.
+  Extending this feature to multi-parameter typeclasses is left as future work.
+
+  The general outline of how we solve this is:
+
+  1. Parse the type, leaving skolems in the place of type-holes.
+  2. For every class, get a list of all instances that match with the query type.
+  3. For every matching instance, ask GHC for the context the instance dictionary needs.
+  4. Format and present the results, substituting our query into the instance
+     and simplifying the context.
+
+  For example, given the query "Maybe Int", we want to return:
+
+  instance Show (Maybe Int)
+  instance Read (Maybe Int)
+  instance Eq   (Maybe Int)
+  ....
+
+  [Holes in queries]
+
+  Often times we want to know what instances are available for a polymorphic type,
+  like `Maybe a`, and we'd like to return instances such as:
+
+  instance Show a => Show (Maybe a)
+  ....
+
+  These queries are expressed using type holes, so instead of `Maybe a` the user writes
+  `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes
+  with (un-named) type variables.
+
+  When zonking the type holes we have two real choices: replace them with Any or replace
+  them with skolem typevars. Using skolem type variables ensures that the output is more
+  intuitive to end users, and there is no difference in the results between Any and skolems.
+
+-}
+
+-- Find all instances that match a provided type
+getInstancesForType :: GhcMonad m => Type -> m [ClsInst]
+getInstancesForType ty = withSession $ \hsc_env -> do
+  liftIO $ runInteractiveHsc hsc_env $ do
+    ioMsgMaybe $ runTcInteractive hsc_env $ do
+      matches <- findMatchingInstances ty
+      fmap catMaybes . forM matches $ uncurry checkForExistence
+
+-- Parse a type string and turn any holes into skolems
+parseInstanceHead :: GhcMonad m => String -> m Type
+parseInstanceHead str = withSession $ \hsc_env0 -> do
+  (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do
+    hsc_env <- getHscEnv
+    ty <- hscParseType str
+    ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty
+
+  return ty
+
+-- Get all the constraints required of a dictionary binding
+getDictionaryBindings :: PredType -> TcM WantedConstraints
+getDictionaryBindings theta = do
+  dictName <- newName (mkDictOcc (mkVarOcc "magic"))
+  let dict_var = mkVanillaGlobal dictName theta
+  loc <- getCtLocM (GivenOrigin UnkSkol) Nothing
+  let wCs = mkSimpleWC [CtDerived
+          { ctev_pred = varType dict_var
+          , ctev_loc = loc
+          }]
+
+  return wCs
+
+{-
+  When we've found an instance that a query matches against, we still need to
+  check that all the instance's constraints are satisfiable. checkForExistence
+  creates an instance dictionary and verifies that any unsolved constraints
+  mention a type-hole, meaning it is blocked on an unknown.
+
+  If the instance satisfies this condition, then we return it with the query
+  substituted into the instance and all constraints simplified, for example given:
+
+  instance D a => C (MyType a b) where
+
+  and the query `MyType _ String`
+
+  the unsolved constraints will be [D _] so we apply the substitution:
+
+  { a -> _; b -> String}
+
+  and return the instance:
+
+  instance D _ => C (MyType _ String)
+
+-}
+
+checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst)
+checkForExistence res mb_inst_tys = do
+  (tys, thetas) <- instDFunType (is_dfun res) mb_inst_tys
+
+  wanteds <- forM thetas getDictionaryBindings
+  (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds))
+
+  let all_residual_constraints = bagToList $ wc_simple residuals
+  let preds = map ctPred all_residual_constraints
+  if all isSatisfiablePred preds && (null $ wc_impl residuals)
+  then return . Just $ substInstArgs tys preds res
+  else return Nothing
+
+  where
+
+  -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least
+  -- one argument or for the head to be a TyVar. The reason is that we want to ensure
+  -- that all residual constraints mention a type-hole somewhere in the constraint,
+  -- meaning that with the correct choice of a concrete type it could be possible for
+  -- the constraint to be discharged.
+  isSatisfiablePred :: PredType -> Bool
+  isSatisfiablePred ty = case getClassPredTys_maybe ty of
+      Just (_, tys@(_:_)) -> all isTyVarTy tys
+      _                   -> isTyVarTy ty
+
+  empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun res)))
+
+  {- Create a ClsInst with instantiated arguments and constraints.
+
+     The thetas are the list of constraints that couldn't be solved because
+     they mention a type-hole.
+  -}
+  substInstArgs ::  [Type] -> [PredType] -> ClsInst -> ClsInst
+  substInstArgs tys thetas inst = let
+      subst = foldl' (\a b -> uncurry (extendTvSubstAndInScope a) b) empty_subst (zip dfun_tvs tys)
+      -- Build instance head with arguments substituted in
+      tau   = mkClassPred cls (substTheta subst args)
+      -- Constrain the instance with any residual constraints
+      phi   = mkPhiTy thetas tau
+      sigma = mkForAllTys (map (\v -> Bndr v Inferred) dfun_tvs) phi
+
+    in inst { is_dfun = (is_dfun inst) { varType = sigma }}
+    where
+    (dfun_tvs, _, cls, args) = instanceSig inst
+
+-- Find instances where the head unifies with the provided type
+findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])]
+findMatchingInstances ty = do
+  ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs
+  let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local
+
+  concat <$> mapM (\cls -> do
+    let (matches, _, _) = lookupInstEnv True ies cls [ty]
+    return matches) allClasses
+
 -----------------------------------------------------------------------------
 -- Compile an expression, run it, and deliver the result
 
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index e3869d2711..d3033694d9 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -2418,10 +2418,11 @@ tcRnImportDecls hsc_env import_decls
 
 -- tcRnType just finds the kind of a type
 tcRnType :: HscEnv
+         -> ZonkFlexi
          -> Bool        -- Normalise the returned type
          -> LHsType GhcPs
          -> IO (Messages, Maybe (Type, Kind))
-tcRnType hsc_env normalise rdr_type
+tcRnType hsc_env flexi normalise rdr_type
   = runTcInteractive hsc_env $
     setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]
     do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs)
@@ -2444,7 +2445,9 @@ tcRnType hsc_env normalise rdr_type
        -- Do kind generalisation; see Note [Kind-generalise in tcRnType]
        ; kind <- zonkTcType kind
        ; kvs <- kindGeneralize kind
-       ; ty  <- zonkTcTypeToType ty
+       ; e <- mkEmptyZonkEnv flexi
+
+       ; ty  <- zonkTcTypeToTypeX e ty
 
        -- Do validity checking on type
        ; checkValidType (GhciCtxt True) ty
diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs
index ebfd1213ca..debced8dba 100644
--- a/compiler/types/InstEnv.hs
+++ b/compiler/types/InstEnv.hs
@@ -21,7 +21,7 @@ module InstEnv (
         emptyInstEnv, extendInstEnv,
         deleteFromInstEnv, deleteDFunFromInstEnv,
         identicalClsInstHead,
-        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts,
+        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses,
         memberInstEnv,
         instIsVisible,
         classInstances, instanceBindFun,
@@ -427,6 +427,9 @@ instEnvElts :: InstEnv -> [ClsInst]
 instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts]
   -- See Note [InstEnv determinism]
 
+instEnvClasses :: InstEnv -> [Class]
+instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie]
+
 -- | Test if an instance is visible, by checking that its origin module
 -- is in 'VisibleOrphanModules'.
 -- See Note [Instance lookup and orphan instances]
diff --git a/docs/users_guide/8.10.1-notes.rst b/docs/users_guide/8.10.1-notes.rst
index 40241746a8..af6e177b2b 100644
--- a/docs/users_guide/8.10.1-notes.rst
+++ b/docs/users_guide/8.10.1-notes.rst
@@ -107,6 +107,11 @@ Compiler
   only convenient workaround was to enable `-fobject-code` for all
   modules.
 
+GHCi
+~~~~
+
+- Added a command `:instances` to show the class instances available for a type.
+
 Runtime system
 ~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/ghci.rst b/docs/users_guide/ghci.rst
index 4b01724d9c..5f4b26eeb6 100644
--- a/docs/users_guide/ghci.rst
+++ b/docs/users_guide/ghci.rst
@@ -2539,6 +2539,38 @@ commonly used commands.
 
     The ``:loc-at`` command requires :ghci-cmd:`:set +c` to be set.
 
+.. ghci-cmd:: :instances ⟨type⟩
+
+    Displays all the class instances available to the argument ⟨type⟩.
+    The command will match ⟨type⟩ with the first parameter of every
+    instance and then check that all constraints are satisfiable.
+
+    When combined with ``-XPartialTypeSignatures``, a user can insert
+    wildcards into a query and learn the constraints required of each
+    wildcard for ⟨type⟩ match with an instance.
+
+    The output is a listing of all matching instances, simplified and
+    instantiated as much as possible.
+
+    For example:
+
+    .. code-block:: none
+      >:instances Maybe (Maybe Int)
+      instance Eq (Maybe (Maybe Int)) -- Defined in ‘GHC.Maybe’
+      instance Ord (Maybe (Maybe Int)) -- Defined in ‘GHC.Maybe’
+      instance Show (Maybe (Maybe Int)) -- Defined in ‘GHC.Show’
+      instance Read (Maybe (Maybe Int)) -- Defined in ‘GHC.Read’
+
+      >:set -XPartialTypeSignatures -fno-warn-partial-type-signatures
+
+      >:instances Maybe _
+      instance Eq _ => Eq (Maybe _) -- Defined in ‘GHC.Maybe’
+      instance Semigroup _ => Monoid (Maybe _) -- Defined in ‘GHC.Base’
+      instance Ord _ => Ord (Maybe _) -- Defined in ‘GHC.Maybe’
+      instance Semigroup _ => Semigroup (Maybe _) -- Defined in ‘GHC.Base’
+      instance Show _ => Show (Maybe _) -- Defined in ‘GHC.Show’
+      instance Read _ => Read (Maybe _) -- Defined in ‘GHC.Read’
+
 .. ghci-cmd:: :main; ⟨arg1⟩ ... ⟨argn⟩
 
     When a program is compiled and executed, it can use the ``getArgs``
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 5dc3aa7d4d..6929ee8a32 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -223,7 +223,8 @@ ghciCommands = map mkCmd [
   ("unadd",     keepGoingPaths unAddModule,     completeFilename),
   ("undef",     keepGoing undefineMacro,        completeMacro),
   ("unset",     keepGoing unsetOptions,         completeSetOptions),
-  ("where",     keepGoing whereCmd,             noCompletion)
+  ("where",     keepGoing whereCmd,             noCompletion),
+  ("instances", keepGoing' instancesCmd,        completeExpression)
   ] ++ map mkCmdHidden [ -- hidden commands
   ("all-types", keepGoing' allTypesCmd),
   ("complete",  keepGoing completeCmd),
@@ -1780,6 +1781,19 @@ handleGetDocsFailure no_docs = do
     InteractiveName -> ProgramError msg
 
 -----------------------------------------------------------------------------
+-- :instances
+
+instancesCmd :: String -> InputT GHCi ()
+instancesCmd "" =
+  throwGhcException (CmdLineError "syntax: ':instances <type-you-want-instances-for>'")
+instancesCmd s = do
+  handleSourceError GHC.printException $ do
+    ty <- GHC.parseInstanceHead s
+    res <- GHC.getInstancesForType ty
+
+    printForUser $ vcat $ map ppr res
+
+-----------------------------------------------------------------------------
 -- :load, :add, :reload
 
 -- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 53b4f26cb6..5dd56ca46c 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -106,7 +106,7 @@ test('ghci062', [extra_files(['ghci062/', 'ghci062/Test.hs']),
                  when(config.have_ext_interp, extra_ways(['ghci-ext']))],
 		ghci_script, ['ghci062.script'])
 test('ghci063', normal, ghci_script, ['ghci063.script'])
-
+test('ghci064', normal, ghci_script, ['ghci064.script'])
 test('T2452', [extra_hc_opts("-fno-implicit-import-qualified")],
     ghci_script, ['T2452.script'])
 test('T2766', normal, ghci_script, ['T2766.script'])
diff --git a/testsuite/tests/ghci/scripts/ghci064.hs b/testsuite/tests/ghci/scripts/ghci064.hs
new file mode 100644
index 0000000000..152836d270
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/ghci064.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE FlexibleInstances, TypeFamilies #-}
+import Data.Kind (Type)
+
+class MyShow a where
+  myshow :: a -> String
+
+instance MyShow a => MyShow [a] where
+  myshow xs = concatMap myshow xs
+
+data T = MkT
+
+instance MyShow T where
+  myshow x = "Used generic instance"
+
+instance MyShow [T] where
+  myshow xs = "Used more specific instance"
+
+
+type family F a :: Type
+type instance F [a] = a -> F a
+type instance F Int = Bool
diff --git a/testsuite/tests/ghci/scripts/ghci064.script b/testsuite/tests/ghci/scripts/ghci064.script
new file mode 100644
index 0000000000..4f14ab8cd0
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/ghci064.script
@@ -0,0 +1,21 @@
+-- Test :instances
+:instances Maybe
+
+:set -XPartialTypeSignatures -fno-warn-partial-type-signatures
+-- Test queries with holes
+:instances Maybe _
+
+:load ghci064
+
+-- Test that overlapping instances are all reported in the results
+:instances [_]
+:instances [T]
+
+-- Test that we can find instances for type families
+
+:instances F Int
+
+-- Test to make sure that the constraints of returned instances are all properly verified
+-- We don't want the command to return an Applicative or Monad instance for tuple because
+-- there is no Int Monoid instance.
+:instances (,) Int
diff --git a/testsuite/tests/ghci/scripts/ghci064.stdout b/testsuite/tests/ghci/scripts/ghci064.stdout
new file mode 100644
index 0000000000..afe039c9ea
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/ghci064.stdout
@@ -0,0 +1,35 @@
+instance GHC.Base.Alternative Maybe -- Defined in ‘GHC.Base’
+instance Applicative Maybe -- Defined in ‘GHC.Base’
+instance Functor Maybe -- Defined in ‘GHC.Base’
+instance Monad Maybe -- Defined in ‘GHC.Base’
+instance GHC.Base.MonadPlus Maybe -- Defined in ‘GHC.Base’
+instance Eq _ => Eq (Maybe _) -- Defined in ‘GHC.Maybe’
+instance Semigroup _ => Monoid (Maybe _) -- Defined in ‘GHC.Base’
+instance Ord _ => Ord (Maybe _) -- Defined in ‘GHC.Maybe’
+instance Semigroup _ => Semigroup (Maybe _)
+  -- Defined in ‘GHC.Base’
+instance Show _ => Show (Maybe _) -- Defined in ‘GHC.Show’
+instance Read _ => Read (Maybe _) -- Defined in ‘GHC.Read’
+instance Eq _ => Eq [_] -- Defined in ‘GHC.Classes’
+instance Monoid [_] -- Defined in ‘GHC.Base’
+instance Ord _ => Ord [_] -- Defined in ‘GHC.Classes’
+instance Semigroup [_] -- Defined in ‘GHC.Base’
+instance Show _ => Show [_] -- Defined in ‘GHC.Show’
+instance Read _ => Read [_] -- Defined in ‘GHC.Read’
+instance [safe] MyShow _ => MyShow [_]
+  -- Defined at ghci064.hs:7:10
+instance Monoid [T] -- Defined in ‘GHC.Base’
+instance Semigroup [T] -- Defined in ‘GHC.Base’
+instance [safe] MyShow [T] -- Defined at ghci064.hs:7:10
+instance [safe] MyShow [T] -- Defined at ghci064.hs:15:10
+instance Eq Bool -- Defined in ‘GHC.Classes’
+instance Ord Bool -- Defined in ‘GHC.Classes’
+instance Show Bool -- Defined in ‘GHC.Show’
+instance Read Bool -- Defined in ‘GHC.Read’
+instance Enum Bool -- Defined in ‘GHC.Enum’
+instance Bounded Bool -- Defined in ‘GHC.Enum’
+instance Data.Bits.Bits Bool -- Defined in ‘Data.Bits’
+instance Data.Bits.FiniteBits Bool -- Defined in ‘Data.Bits’
+instance GHC.Arr.Ix Bool -- Defined in ‘GHC.Arr’
+instance Functor ((,) Int) -- Defined in ‘GHC.Base’
+instance Foldable ((,) Int) -- Defined in ‘Data.Foldable’