Add flag to show docs of valid hole fits

One issue with valid hole fits is that the function names can often be
opaque for the uninitiated, such as `($)`. This diff adds a new flag,
`-fshow-docs-of-hole-fits` that adds the documentation of the identifier
in question to the message, using the same mechanism as the `:doc`
command.

As an example, with this flag enabled, the valid hole fits for `_ ::
[Int] -> Int` will include:

```
Valid hole fits include
  head :: forall a. [a] -> a
    {-^ Extract the first element of a list, which must be non-empty.-}
    with head @Int
    (imported from ‘Prelude’ (and originally defined in ‘GHC.List’))
```

And one of the refinement hole fits, `($) _`, will read:

```
Valid refinement hole fits include
  ...
  ($) (_ :: [Int] -> Int)
      where ($) :: forall a b. (a -> b) -> a -> b
      {-^ Application operator.  This operator is redundant, since ordinary
          application @(f x)@ means the same as @(f '$' x)@. However, '$' has
          low, right-associative binding precedence, so it sometimes allows
          parentheses to be omitted; for example:

          > f $ g $ h x  =  f (g (h x))

          It is also useful in higher-order situations, such as @'map' ('$' 0) xs@,
          or @'Data.List.zipWith' ('$') fs xs@.

          Note that @($)@ is levity-polymorphic in its result type, so that
              foo $ True    where  foo :: Bool -> Int#
          is well-typed-}
      with ($) @'GHC.Types.LiftedRep @[Int] @Int
      (imported from ‘Prelude’ (and originally defined in ‘GHC.Base’))

```

Another example of where documentation can come in very handy, is when
working with the `lens` library.

When you compile
```
{-# OPTIONS_GHC -fno-show-provenance-of-hole-fits -fshow-docs-of-hole-fits #-}
module LensDemo where

import Control.Lens
import Control.Monad.State

newtype Test = Test { _value :: Int } deriving (Show)

value :: Lens' Test Int
value f (Test i) = Test <$> f i

updTest :: Test -> Test
updTest t = t &~ do
    _ value (1 :: Int)
```

You get:
```
  Valid hole fits include
    (#=) :: forall s (m :: * -> *) a b.
            MonadState s m =>
            ALens s s a b -> b -> m ()
      {-^ A version of ('Control.Lens.Setter..=') that works on 'ALens'.-}
      with (#=) @Test @(StateT Test Identity) @Int @Int
    (<#=) :: forall s (m :: * -> *) a b.
             MonadState s m =>
             ALens s s a b -> b -> m b
      {-^ A version of ('Control.Lens.Setter.<.=') that works on 'ALens'.-}
      with (<#=) @Test @(StateT Test Identity) @Int @Int
    (<*=) :: forall s (m :: * -> *) a.
             (MonadState s m, Num a) =>
             LensLike' ((,) a) s a -> a -> m a
      {-^ Multiply the target of a numerically valued 'Lens' into your 'Monad''s
          state and return the result.

          When you do not need the result of the multiplication,
          ('Control.Lens.Setter.*=') is more flexible.

          @
          ('<*=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m a
          ('<*=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Iso.Iso'' s a -> a -> m a
          @-}
      with (<*=) @Test @(StateT Test Identity) @Int
    (<+=) :: forall s (m :: * -> *) a.
             (MonadState s m, Num a) =>
             LensLike' ((,) a) s a -> a -> m a
      {-^ Add to the target of a numerically valued 'Lens' into your 'Monad''s state
          and return the result.

          When you do not need the result of the addition,
          ('Control.Lens.Setter.+=') is more flexible.

          @
          ('<+=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m a
          ('<+=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Iso.Iso'' s a -> a -> m a
          @-}
      with (<+=) @Test @(StateT Test Identity) @Int
    (<-=) :: forall s (m :: * -> *) a.
             (MonadState s m, Num a) =>
             LensLike' ((,) a) s a -> a -> m a
      {-^ Subtract from the target of a numerically valued 'Lens' into your 'Monad''s
          state and return the result.

          When you do not need the result of the subtraction,
          ('Control.Lens.Setter.-=') is more flexible.

          @
          ('<-=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m a
          ('<-=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Iso.Iso'' s a -> a -> m a
          @-}
      with (<-=) @Test @(StateT Test Identity) @Int
    (<<*=) :: forall s (m :: * -> *) a.
              (MonadState s m, Num a) =>
              LensLike' ((,) a) s a -> a -> m a
      {-^ Modify the target of a 'Lens' into your 'Monad''s state by multipling a value
          and return the /old/ value that was replaced.

          When you do not need the result of the operation,
          ('Control.Lens.Setter.*=') is more flexible.

          @
          ('<<*=') :: ('MonadState' s m, 'Num' a) => 'Lens'' s a -> a -> m a
          ('<<*=') :: ('MonadState' s m, 'Num' a) => 'Iso'' s a -> a -> m a
          @-}
      with (<<*=) @Test @(StateT Test Identity) @Int
    (Some hole fits suppressed; use -fmax-valid-hole-fits=N or -fno-max-valid-hole-fits)

```

Which allows you to see at a glance what opaque operators like `(<<*=)`
and `(<#=)` do.

Reviewers: bgamari, sjakobi

Reviewed By: sjakobi

Subscribers: sjakobi, alexbiehl, rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4848

4 files changed, 89 insertions, 22 deletions

diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 20928d6ba5..4524402985 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -16,7 +16,7 @@ module LoadIface (
         -- RnM/TcM functions
         loadModuleInterface, loadModuleInterfaces,
         loadSrcInterface, loadSrcInterface_maybe,
-        loadInterfaceForName, loadInterfaceForModule,
+        loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,
 
         -- IfM functions
         loadInterface,
@@ -313,6 +313,15 @@ loadInterfaceForName doc name
       ; ASSERT2( isExternalName name, ppr name )
         initIfaceTcRn $ loadSysInterface doc (nameModule name) }
 
+-- | Only loads the interface for external non-local names.
+loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)
+loadInterfaceForNameMaybe doc name
+  = do { this_mod <- getModule
+       ; if nameIsLocalOrFrom this_mod name || not (isExternalName name)
+         then return Nothing
+         else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))
+       }
+
 -- | Loads the interface for a given Module.
 loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface
 loadInterfaceForModule doc m
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3957879436..acdecf26bb 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -583,6 +583,7 @@ data GeneralFlag
    | Opt_UnclutterValidHoleFits
    | Opt_ShowTypeAppOfHoleFits
    | Opt_ShowTypeAppVarsOfHoleFits
+   | Opt_ShowDocsOfHoleFits
    | Opt_ShowTypeOfHoleFits
    | Opt_ShowProvOfHoleFits
    | Opt_ShowMatchesOfHoleFits
@@ -4025,6 +4026,7 @@ fHoleFlags = [
   flagSpec "show-type-of-hole-fits"           Opt_ShowTypeOfHoleFits,
   flagSpec "show-type-app-of-hole-fits"       Opt_ShowTypeAppOfHoleFits,
   flagSpec "show-type-app-vars-of-hole-fits"  Opt_ShowTypeAppVarsOfHoleFits,
+  flagSpec "show-docs-of-hole-fits"           Opt_ShowDocsOfHoleFits,
   flagSpec "unclutter-valid-hole-fits"        Opt_UnclutterValidHoleFits
   ]
 
@@ -4306,6 +4308,7 @@ validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]
 validHoleFitsImpliedGFlags
   = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)
     , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits)
+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits)
     , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)
     , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ]
 
diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs
index ee4d617502..16429fb692 100644
--- a/compiler/typecheck/TcHoleErrors.hs
+++ b/compiler/typecheck/TcHoleErrors.hs
@@ -37,6 +37,12 @@ import Data.Function    ( on )
 import TcSimplify    ( simpl_top, runTcSDeriveds )
 import TcUnify       ( tcSubType_NC )
 
+import ExtractDocs ( extractDocs )
+import qualified Data.Map as Map
+import HsDoc           ( HsDocString, unpackHDS, DeclDocMap(..) )
+import HscTypes        ( ModIface(..) )
+import LoadIface       ( loadInterfaceForNameMaybe )
+
 {-
 Note [Valid hole fits include ...]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -424,9 +430,19 @@ data HoleFit = HoleFit { hfElem :: Maybe GlobalRdrElt -- The element that was
                        , hfType :: TcType -- The type of the id, possibly zonked
                        , hfRefLvl :: Int  -- The number of holes in this fit
                        , hfWrap :: [TcType] -- The wrapper for the match
-                       , hfMatches :: [TcType] } -- What the refinement
-                                                 -- variables got matched with,
-                                                 -- if anything
+                       , hfMatches :: [TcType]  -- What the refinement
+                                                -- variables got matched with,
+                                                -- if anything
+                       , hfDoc :: Maybe HsDocString } -- Documentation of this
+                                                      -- HoleFit, if available.
+
+hfName :: HoleFit -> Name
+hfName = idName . hfId
+
+hfIsLcl :: HoleFit -> Bool
+hfIsLcl hf = case hfElem hf of
+               Just gre -> gre_lcl gre
+               Nothing -> True
 
 -- We define an Eq and Ord instance to be able to build a graph.
 instance Eq HoleFit where
@@ -439,7 +455,7 @@ instance Eq HoleFit where
 instance Ord HoleFit where
   compare a b = cmp a b
     where cmp  = if hfRefLvl a == hfRefLvl b
-                 then compare `on` (idName . hfId)
+                 then compare `on` hfName
                  else compare `on` hfRefLvl
 
 instance Outputable HoleFit where
@@ -451,6 +467,26 @@ instance (HasOccName a, HasOccName b) => HasOccName (Either a b) where
 instance HasOccName GlobalRdrElt where
     occName = occName . gre_name
 
+-- If enabled, we go through the fits and add any associated documentation,
+--  by looking it up in the module or the environment (for local fits)
+addDocs :: [HoleFit] -> TcM [HoleFit]
+addDocs fits =
+  do { showDocs <- goptM Opt_ShowDocsOfHoleFits
+     ; if showDocs
+       then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv
+               ; mapM (upd lclDocs) fits }
+       else return fits }
+  where
+   msg = text "TcHoleErrors addDocs"
+   lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })
+     = Map.lookup name dmap
+   upd lclDocs fit =
+     let name = hfName fit in
+     do { doc <- if hfIsLcl fit
+                 then pure (Map.lookup name lclDocs)
+                 else do { mbIface <- loadInterfaceForNameMaybe msg name
+                         ; return $ mbIface >>= lookupInIface name }
+        ; return $ fit {hfDoc = doc} }
 
 -- For pretty printing hole fits, we display the name and type of the fit,
 -- with added '_' to represent any extra arguments in case of a non-zero
@@ -459,7 +495,7 @@ pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
 pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) hf = hang display 2 provenance
     where name = case hfElem hf of
                       Just gre -> gre_name gre
-                      Nothing -> idName (hfId hf)
+                      Nothing -> hfName hf
           ty = hfType hf
           matches =  hfMatches hf
           wrap = hfWrap hf
@@ -488,12 +524,17 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) hf = hang display 2 provenance
                       $ text "with" <+> if sWrp || not sTy
                                         then occDisp <+> tyApp
                                         else tyAppVars
+          docs = case hfDoc hf of
+                   Just d ->
+                     text "{-^" <>
+                     (vcat . map text . lines . unpackHDS) d
+                     <> text "-}"
+                   _ -> empty
           funcInfo = ppWhen (has matches && sTy) $
                        text "where" <+> occDisp <+> tyDisp
           subDisp = occDisp <+> if has matches then holeDisp else tyDisp
-          display =  subDisp $$ nest 2 (funcInfo $+$ wrapDisp)
-          provenance = ppWhen sProv $
-            parens $
+          display =  subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)
+          provenance = ppWhen sProv $ parens $
                 case hfElem hf of
                     Just gre -> pprNameProvenance gre
                     Nothing -> text "bound at" <+> ppr (getSrcLoc name)
@@ -549,9 +590,10 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
      ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs
      ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs tidy_sorted_subs
            vDiscards = pVDisc || searchDiscards
-     ; let vMsg = ppUnless (null limited_subs) $
+     ; subs_with_docs <- addDocs limited_subs
+     ; let vMsg = ppUnless (null subs_with_docs) $
                     hang (text "Valid hole fits include") 2 $
-                      vcat (map (pprHoleFit hfdc) limited_subs)
+                      vcat (map (pprHoleFit hfdc) subs_with_docs)
                         $$ ppWhen vDiscards subsDiscardMsg
      -- Refinement hole fits. See Note [Valid refinement hole fits include ...]
      ; (tidy_env, refMsg) <- if refLevel >= Just 0 then
@@ -576,10 +618,11 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
                   (pRDisc, exact_last_rfits) =
                     possiblyDiscard maxRSubs $ not_exact ++ exact
                   rDiscards = pRDisc || any fst refDs
+            ; rsubs_with_docs <- addDocs exact_last_rfits
             ; return (tidy_env,
-                ppUnless (null tidy_sorted_rsubs) $
+                ppUnless (null rsubs_with_docs) $
                   hang (text "Valid refinement hole fits include") 2 $
-                  vcat (map (pprHoleFit hfdc) exact_last_rfits)
+                  vcat (map (pprHoleFit hfdc) rsubs_with_docs)
                     $$ ppWhen rDiscards refSubsDiscardMsg) }
        else return (tidy_env, empty)
      ; traceTc "findingValidHoleFitsFor }" empty
@@ -612,7 +655,7 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
     sortFits BySize subs
         = (++) <$> sortBySize (sort lclFits)
                <*> sortBySize (sort gblFits)
-        where (lclFits, gblFits) = span isLocalHoleFit subs
+        where (lclFits, gblFits) = span hfIsLcl subs
 
     -- To sort by subsumption, we invoke the sortByGraph function, which
     -- builds the subsumption graph for the fits and then sorts them using a
@@ -623,12 +666,8 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
     sortFits BySubsumption subs
         = (++) <$> sortByGraph (sort lclFits)
                <*> sortByGraph (sort gblFits)
-        where (lclFits, gblFits) = span isLocalHoleFit subs
+        where (lclFits, gblFits) = span hfIsLcl subs
 
-    isLocalHoleFit :: HoleFit -> Bool
-    isLocalHoleFit hf = case hfElem hf of
-                          Just gre -> gre_lcl gre
-                          Nothing -> True
 
     -- See Note [Relevant Constraints]
     relevantCts :: [Ct]
@@ -787,7 +826,7 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
             go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]
             go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar
                              ; return $ uncurry (++)
-                                         $ partition isLocalHoleFit topSorted }
+                                         $ partition hfIsLcl topSorted }
               where toV (hf, adjs) = (hf, hfId hf, map hfId adjs)
                     (graph, fromV, _) = graphFromEdges $ map toV sofar
                     topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph
@@ -841,10 +880,11 @@ findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
           where discard_it = go subs seen maxleft ty elts
                 keep_it id wrp ms = go (fit:subs) (extendVarSet seen id)
                                   ((\n -> n - 1) <$> maxleft) ty elts
-                  where fit = HoleFit { hfElem = mbel , hfId = id
+                  where fit = HoleFit { hfElem = mbel, hfId = id
                                       , hfType = idType id
                                       , hfRefLvl = length (snd ty)
-                                      , hfWrap = wrp , hfMatches = ms }
+                                      , hfWrap = wrp, hfMatches = ms
+                                      , hfDoc = Nothing }
                         mbel = either (const Nothing) Just el
                 -- We want to filter out undefined and the likes from GHC.Err
                 not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index c3322b7b4b..14d01f6123 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -11595,6 +11595,21 @@ configurable by a few flags.
     ``mempty @(Int -> [Int])``. This can be toggled off with
     the reverse of this flag.
 
+.. ghc-flag:: -fshow-docs-of-hole-fits
+    :shortdesc: Toggles whether to show the documentation of the valid
+       hole fits in the output.
+    :type: dynamic
+    :category: verbosity
+    :reverse: -fno-show-docs-of-hole-fits
+
+    :default: off
+
+    It can sometime be the case that the name and type of a valid hole
+    fit is not enough to realize what the fit stands for. This flag
+    adds the documentation of the fit to the message, if the 
+    documentation is available (and the module from which the function
+    comes was compiled with the ``-haddock`` flag).
+
 .. ghc-flag:: -fshow-type-app-vars-of-hole-fits
     :shortdesc: Toggles whether to show what type each quantified
        variable takes in a valid hole fit.