Commit c4d98341 authored by Matthías Páll Gissurarson's avatar Matthías Páll Gissurarson Committed by Ben Gamari

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
parent 101e9047
......@@ -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
......
......@@ -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) ]
......
......@@ -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
......
......@@ -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.
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment