{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.Errors.Hole
   ( findValidHoleFits
   , tcCheckHoleFit
   , withoutUnification
   , tcSubsumes
   , isFlexiTyVar
   , tcFilterHoleFits
   , getLocalBindings
   , pprHoleFit
   , addHoleFitDocs
   , getHoleFitSortingAlg
   , getHoleFitDispConfig
   , HoleFitDispConfig (..)
   , HoleFitSortingAlg (..)
   , relevantCts
   , zonkSubs

   , sortHoleFitsByGraph
   , sortHoleFitsBySize


   -- Re-exported from GHC.Tc.Errors.Hole.FitTypes
   , HoleFitPlugin (..), HoleFitPluginR (..)
   )
where

import GHC.Prelude

import GHC.Tc.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..)
                             , globalRdrEnvElts, greMangledName, grePrintableName )
import GHC.Builtin.Names ( gHC_ERR )
import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.TyThing
import GHC.Data.Bag
import GHC.Core.ConLike ( ConLike(..) )
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Tc.Utils.Env (tcLookup)
import GHC.Utils.Outputable
import GHC.Driver.Session
import GHC.Data.Maybe
import GHC.Utils.FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV )

import Control.Arrow ( (&&&) )

import Control.Monad    ( filterM, replicateM, foldM )
import Data.List        ( partition, sort, sortOn, nubBy )
import Data.Graph       ( graphFromEdges, topSort )


import GHC.Tc.Solver    ( simplifyTopWanteds, runTcSDeriveds )
import GHC.Tc.Utils.Unify ( tcSubTypeSigma )

import GHC.HsToCore.Docs ( extractDocs )
import qualified Data.Map as Map
import GHC.Hs.Doc      ( unpackHDS, DeclDocMap(..) )
import GHC.Unit.Module.ModIface ( ModIface_(..) )
import GHC.Iface.Load  ( loadInterfaceForNameMaybe )

import GHC.Builtin.Utils (knownKeyNames)

import GHC.Tc.Errors.Hole.FitTypes


{-
Note [Valid hole fits include ...]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
`findValidHoleFits` returns the "Valid hole fits include ..." message.
For example, look at the following definitions in a file called test.hs:

   import Data.List (inits)

   f :: [String]
   f = _ "hello, world"

The hole in `f` would generate the message:

  • Found hole: _ :: [Char] -> [String]
  • In the expression: _
    In the expression: _ "hello, world"
    In an equation for ‘f’: f = _ "hello, world"
  • Relevant bindings include f :: [String] (bound at test.hs:6:1)
    Valid hole fits include
      lines :: String -> [String]
        (imported from ‘Prelude’ at mpt.hs:3:8-9
          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
      words :: String -> [String]
        (imported from ‘Prelude’ at mpt.hs:3:8-9
          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
      inits :: forall a. [a] -> [[a]]
        with inits @Char
        (imported from ‘Data.List’ at mpt.hs:4:19-23
          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
      repeat :: forall a. a -> [a]
        with repeat @String
        (imported from ‘Prelude’ at mpt.hs:3:8-9
          (and originally defined in ‘GHC.List’))
      fail :: forall (m :: * -> *). Monad m => forall a. String -> m a
        with fail @[] @String
        (imported from ‘Prelude’ at mpt.hs:3:8-9
          (and originally defined in ‘GHC.Base’))
      return :: forall (m :: * -> *). Monad m => forall a. a -> m a
        with return @[] @String
        (imported from ‘Prelude’ at mpt.hs:3:8-9
          (and originally defined in ‘GHC.Base’))
      pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a
        with pure @[] @String
        (imported from ‘Prelude’ at mpt.hs:3:8-9
          (and originally defined in ‘GHC.Base’))
      read :: forall a. Read a => String -> a
        with read @[String]
        (imported from ‘Prelude’ at mpt.hs:3:8-9
          (and originally defined in ‘Text.Read’))
      mempty :: forall a. Monoid a => a
        with mempty @([Char] -> [String])
        (imported from ‘Prelude’ at mpt.hs:3:8-9
          (and originally defined in ‘GHC.Base’))

Valid hole fits are found by checking top level identifiers and local bindings
in scope for whether their type can be instantiated to the type of the hole.
Additionally, we also need to check whether all relevant constraints are solved
by choosing an identifier of that type as well, see Note [Relevant constraints]

Since checking for subsumption results in the side-effect of type variables
being unified by the simplifier, we need to take care to restore them after
to being flexible type variables after we've checked for subsumption.
This is to avoid affecting the hole and later checks by prematurely having
unified one of the free unification variables.

When outputting, we sort the hole fits by the size of the types we'd need to
apply by type application to the type of the fit to make it fit. This is done
in order to display "more relevant" suggestions first. Another option is to
sort by building a subsumption graph of fits, i.e. a graph of which fits subsume
what other fits, and then outputting those fits which are subsumed by other
fits (i.e. those more specific than other fits) first. This results in the ones
"closest" to the type of the hole to be displayed first.

To help users understand how the suggested fit works, we also display the values
that the quantified type variables would take if that fit is used, like
`mempty @([Char] -> [String])` and `pure @[] @String` in the example above.
If -XTypeApplications is enabled, this can even be copied verbatim as a
replacement for the hole.

Note [Checking hole fits]
~~~~~~~~~~~~~~~~~~~~~~~~~
If we have a hole of type hole_ty, we want to know whether a variable
of type ty is a valid fit for the whole. This is a subsumption check:
we wish to know whether ty <: hole_ty. But, of course, the check
must take into account any givens and relevant constraints.
(See also Note [Relevant constraints]).

For the simplifier to be able to use any givens present in the enclosing
implications to solve relevant constraints, we nest the wanted subsumption
constraints and relevant constraints within the enclosing implications.

As an example, let's look at the following code:

  f :: Show a => a -> String
  f x = show _

Suppose the hole is assigned type a0_a1pd[tau:2].
Here the nested implications are just one level deep, namely:

  [Implic {
      TcLevel = 2
      Skolems = a_a1pa[sk:2]
      No-eqs = True
      Status = Unsolved
      Given = $dShow_a1pc :: Show a_a1pa[sk:2]
      Wanted =
        WC {wc_simple =
              [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))}
      Binds = EvBindsVar<a1pi>
      Needed inner = []
      Needed outer = []
      the type signature for:
        f :: forall a. Show a => a -> String }]

As we can see, the givens say that the skolem
`a_a1pa[sk:2]` fulfills the Show constraint, and that we must prove
the [W] Show a0_a1pd[tau:2] constraint -- that is, whatever fills the
hole must have a Show instance.

When we now check whether `x :: a_a1pa[sk:2]` fits the hole in
`tcCheckHoleFit`, the call to `tcSubType` will end up unifying the meta type
variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted constraints
needed by tcSubType_NC and the relevant constraints (see Note [Relevant
Constraints] for more details) in the nested implications, we can pass the
information in the givens along to the simplifier. For our example, we end up
needing to check whether the following constraints are soluble.

  WC {wc_impl =
        Implic {
          TcLevel = 2
          Skolems = a_a1pa[sk:2]
          No-eqs = True
          Status = Unsolved
          Given = $dShow_a1pc :: Show a_a1pa[sk:2]
          Wanted =
            WC {wc_simple =
                  [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)}
          Binds = EvBindsVar<a1pl>
          Needed inner = []
          Needed outer = []
          the type signature for:
            f :: forall a. Show a => a -> String }}

But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested
implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up
with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match.

To avoid side-effects on the nested implications, we create a new EvBindsVar so
that any changes to the ev binds during a check remains localised to that check.
In addition, we call withoutUnification to reset any unified metavariables; this
call is actually done outside tcCheckHoleFit so that the results can be formatted
for the user before resetting variables.

Note [Valid refinement hole fits include ...]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When the `-frefinement-level-hole-fits=N` flag is given, we additionally look
for "valid refinement hole fits"", i.e. valid hole fits with up to N
additional holes in them.

With `-frefinement-level-hole-fits=0` (the default), GHC will find all
identifiers 'f' (top-level or nested) that will fit in the hole.

With `-frefinement-level-hole-fits=1`, GHC will additionally find all
applications 'f _' that will fit in the hole, where 'f' is an in-scope
identifier, applied to single argument.  It will also report the type of the
needed argument (a new hole).

And similarly as the number of arguments increases

As an example, let's look at the following code:

  f :: [Integer] -> Integer
  f = _

with `-frefinement-level-hole-fits=1`, we'd get:

  Valid refinement hole fits include

    foldl1 (_ :: Integer -> Integer -> Integer)
      with foldl1 @[] @Integer
      where foldl1 :: forall (t :: * -> *).
                      Foldable t =>
                      forall a. (a -> a -> a) -> t a -> a
    foldr1 (_ :: Integer -> Integer -> Integer)
      with foldr1 @[] @Integer
      where foldr1 :: forall (t :: * -> *).
                      Foldable t =>
                      forall a. (a -> a -> a) -> t a -> a
    const (_ :: Integer)
      with const @Integer @[Integer]
      where const :: forall a b. a -> b -> a
    ($) (_ :: [Integer] -> Integer)
      with ($) @'GHC.Types.LiftedRep @[Integer] @Integer
      where ($) :: forall a b. (a -> b) -> a -> b
    fail (_ :: String)
      with fail @((->) [Integer]) @Integer
      where fail :: forall (m :: * -> *).
                    Monad m =>
                    forall a. String -> m a
    return (_ :: Integer)
      with return @((->) [Integer]) @Integer
      where return :: forall (m :: * -> *). Monad m => forall a. a -> m a
    (Some refinement hole fits suppressed;
      use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits)

Which are hole fits with holes in them. This allows e.g. beginners to
discover the fold functions and similar, but also allows for advanced users
to figure out the valid functions in the Free monad, e.g.

  instance Functor f => Monad (Free f) where
      Pure a >>= f = f a
      Free f >>= g = Free (fmap _a f)

Will output (with -frefinment-level-hole-fits=1):
    Found hole: _a :: Free f a -> Free f b
          Where: ‘a’, ‘b’ are rigid type variables bound by
                  the type signature for:
                    (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b
                  at fms.hs:25:12-14
                ‘f’ is a rigid type variable bound by
    ...
    Relevant bindings include
      g :: a -> Free f b (bound at fms.hs:27:16)
      f :: f (Free f a) (bound at fms.hs:27:10)
      (>>=) :: Free f a -> (a -> Free f b) -> Free f b
        (bound at fms.hs:25:12)
    ...
    Valid refinement hole fits include
      ...
      (=<<) (_ :: a -> Free f b)
        with (=<<) @(Free f) @a @b
        where (=<<) :: forall (m :: * -> *) a b.
                      Monad m =>
                      (a -> m b) -> m a -> m b
        (imported from ‘Prelude’ at fms.hs:5:18-22
        (and originally defined in ‘GHC.Base’))
      ...

Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`).

We find these refinement suggestions by considering hole fits that don't
fit the type of the hole, but ones that would fit if given an additional
argument. We do this by creating a new type variable with `newOpenFlexiTyVar`
(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type
`t_a1/m[tau:1] -> v` where `v` is the type of the hole.

Since the simplifier is free to unify this new type variable with any type, we
can discover any identifiers that would fit if given another identifier of a
suitable type. This is then generalized so that we can consider any number of
additional arguments by setting the `-frefinement-level-hole-fits` flag to any
number, and then considering hole fits like e.g. `foldl _ _` with two additional
arguments.

To make sure that the refinement hole fits are useful, we check that the types
of the additional holes have a concrete value and not just an invented type
variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`,
and limits the number of less than useful refinement hole fits.

Additionally, to further aid the user in their implementation, we show the
types of the holes the binding would have to be applied to in order to work.
In the free monad example above, this is demonstrated with
`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to
be applied to an expression of type `a -> Free f b` in order to match.
If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim.

Note [Relevant constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
As highlighted by #14273, we need to check any relevant constraints as well
as checking for subsumption. Relevant constraints are the simple constraints
whose free unification variables are mentioned in the type of the hole.

In the simplest case, these are all non-hole constraints in the simples, such
as is the case in

  f :: String
  f = show _

Here, the hole is given type a0_a1kv[tau:1]. Then, the emitted constraint is:

  [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)

However, when there are multiple holes, we need to be more careful. As an
example, Let's take a look at the following code:

  f :: Show a => a -> String
  f x = show (_b (show _a))

Here there are two holes, `_a` and `_b`. Suppose _a :: a0_a1pd[tau:2] and
_b :: a1_a1po[tau:2]. Then, the simple constraints passed to
findValidHoleFits are:

  [[WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),
    [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)]

When we are looking for a match for the hole `_a`, we filter the simple
constraints to the "Relevant constraints", by throwing out any constraints
which do not mention a variable mentioned in the type of the hole. For hole
`_a`, we will then only require that the `$dShow_a1pe` constraint is solved,
since that is the only constraint that mentions any free type variables
mentioned in the hole constraint for `_a`, namely `a_a1pd[tau:2]`, and
similarly for the hole `_b` we only require that the `$dShow_a1pe` constraint
is solved.

Note [Leaking errors]
~~~~~~~~~~~~~~~~~~~~~
When considering candidates, GHC believes that we're checking for validity in
actual source. However, As evidenced by #15321, #15007 and #15202, this can
cause bewildering error messages. The solution here is simple: if a candidate
would cause the type checker to error, it is not a valid hole fit, and thus it
is discarded.

-}

data HoleFitDispConfig = HFDC { HoleFitDispConfig -> Bool
showWrap :: Bool
                              , HoleFitDispConfig -> Bool
showWrapVars :: Bool
                              , HoleFitDispConfig -> Bool
showType :: Bool
                              , HoleFitDispConfig -> Bool
showProv :: Bool
                              , HoleFitDispConfig -> Bool
showMatches :: Bool }

-- We read the various -no-show-*-of-hole-fits flags
-- and set the display config accordingly.
getHoleFitDispConfig :: TcM HoleFitDispConfig
getHoleFitDispConfig :: TcM HoleFitDispConfig
getHoleFitDispConfig
  = do { Bool
sWrap <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ShowTypeAppOfHoleFits
       ; Bool
sWrapVars <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ShowTypeAppVarsOfHoleFits
       ; Bool
sType <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ShowTypeOfHoleFits
       ; Bool
sProv <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ShowProvOfHoleFits
       ; Bool
sMatc <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ShowMatchesOfHoleFits
       ; forall (m :: * -> *) a. Monad m => a -> m a
return HFDC{ showWrap :: Bool
showWrap = Bool
sWrap, showWrapVars :: Bool
showWrapVars = Bool
sWrapVars
                    , showProv :: Bool
showProv = Bool
sProv, showType :: Bool
showType = Bool
sType
                    , showMatches :: Bool
showMatches = Bool
sMatc } }

-- Which sorting algorithm to use
data HoleFitSortingAlg = HFSNoSorting      -- Do not sort the fits at all
                       | HFSBySize         -- Sort them by the size of the match
                       | HFSBySubsumption  -- Sort by full subsumption
                deriving (HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
$c/= :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
== :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
$c== :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
Eq, Eq HoleFitSortingAlg
HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
HoleFitSortingAlg -> HoleFitSortingAlg -> Ordering
HoleFitSortingAlg -> HoleFitSortingAlg -> HoleFitSortingAlg
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HoleFitSortingAlg -> HoleFitSortingAlg -> HoleFitSortingAlg
$cmin :: HoleFitSortingAlg -> HoleFitSortingAlg -> HoleFitSortingAlg
max :: HoleFitSortingAlg -> HoleFitSortingAlg -> HoleFitSortingAlg
$cmax :: HoleFitSortingAlg -> HoleFitSortingAlg -> HoleFitSortingAlg
>= :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
$c>= :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
> :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
$c> :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
<= :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
$c<= :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
< :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
$c< :: HoleFitSortingAlg -> HoleFitSortingAlg -> Bool
compare :: HoleFitSortingAlg -> HoleFitSortingAlg -> Ordering
$ccompare :: HoleFitSortingAlg -> HoleFitSortingAlg -> Ordering
Ord)

getHoleFitSortingAlg :: TcM HoleFitSortingAlg
getHoleFitSortingAlg :: TcM HoleFitSortingAlg
getHoleFitSortingAlg =
    do { Bool
shouldSort <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_SortValidHoleFits
       ; Bool
subsumSort <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_SortBySubsumHoleFits
       ; Bool
sizeSort <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_SortBySizeHoleFits
       -- We default to sizeSort unless it has been explicitly turned off
       -- or subsumption sorting has been turned on.
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not Bool
shouldSort
                    then HoleFitSortingAlg
HFSNoSorting
                    else if Bool
subsumSort
                         then HoleFitSortingAlg
HFSBySubsumption
                         else if Bool
sizeSort
                              then HoleFitSortingAlg
HFSBySize
                              else HoleFitSortingAlg
HFSNoSorting }

-- 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)
addHoleFitDocs :: [HoleFit] -> TcM [HoleFit]
addHoleFitDocs :: [HoleFit] -> TcM [HoleFit]
addHoleFitDocs [HoleFit]
fits =
  do { Bool
showDocs <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ShowDocsOfHoleFits
     ; if Bool
showDocs
       then do { (Maybe HsDocString
_, DeclDocMap Map Name HsDocString
lclDocs, ArgDocMap
_) <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
TcGblEnv -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)
extractDocs
               ; forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map Name HsDocString
-> HoleFit -> IOEnv (Env TcGblEnv TcLclEnv) HoleFit
upd Map Name HsDocString
lclDocs) [HoleFit]
fits }
       else forall (m :: * -> *) a. Monad m => a -> m a
return [HoleFit]
fits }
  where
   msg :: SDoc
msg = String -> SDoc
text String
"GHC.Tc.Errors.Hole addHoleFitDocs"
   lookupInIface :: Name -> ModIface_ phase -> Maybe HsDocString
lookupInIface Name
name (ModIface { mi_decl_docs :: forall (phase :: ModIfacePhase). ModIface_ phase -> DeclDocMap
mi_decl_docs = DeclDocMap Map Name HsDocString
dmap })
     = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name HsDocString
dmap
   upd :: Map Name HsDocString
-> HoleFit -> IOEnv (Env TcGblEnv TcLclEnv) HoleFit
upd Map Name HsDocString
lclDocs fit :: HoleFit
fit@(HoleFit {hfCand :: HoleFit -> HoleFitCandidate
hfCand = HoleFitCandidate
cand}) =
        do { let name :: Name
name = forall a. NamedThing a => a -> Name
getName HoleFitCandidate
cand
           ; Maybe HsDocString
doc <- if HoleFit -> Bool
hfIsLcl HoleFit
fit
                    then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name HsDocString
lclDocs)
                    else do { Maybe ModIface
mbIface <- SDoc -> Name -> TcRn (Maybe ModIface)
loadInterfaceForNameMaybe SDoc
msg Name
name
                            ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe ModIface
mbIface forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {phase :: ModIfacePhase}.
Name -> ModIface_ phase -> Maybe HsDocString
lookupInIface Name
name }
           ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HoleFit
fit {hfDoc :: Maybe HsDocString
hfDoc = Maybe HsDocString
doc} }
   upd Map Name HsDocString
_ HoleFit
fit = forall (m :: * -> *) a. Monad m => a -> m a
return HoleFit
fit

-- 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
-- refinement level.
pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
pprHoleFit HoleFitDispConfig
_ (RawHoleFit SDoc
sd) = SDoc
sd
pprHoleFit (HFDC Bool
sWrp Bool
sWrpVars Bool
sTy Bool
sProv Bool
sMs) (HoleFit {Int
[TcType]
Maybe HsDocString
Id
TcType
HoleFitCandidate
hfWrap :: HoleFit -> [TcType]
hfType :: HoleFit -> TcType
hfRefLvl :: HoleFit -> Int
hfMatches :: HoleFit -> [TcType]
hfId :: HoleFit -> Id
hfDoc :: Maybe HsDocString
hfMatches :: [TcType]
hfWrap :: [TcType]
hfRefLvl :: Int
hfType :: TcType
hfCand :: HoleFitCandidate
hfId :: Id
hfDoc :: HoleFit -> Maybe HsDocString
hfCand :: HoleFit -> HoleFitCandidate
..}) =
 SDoc -> Int -> SDoc -> SDoc
hang SDoc
display Int
2 SDoc
provenance
 where tyApp :: SDoc
tyApp = [SDoc] -> SDoc
sep forall a b. (a -> b) -> a -> b
$ forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"pprHoleFit" forall {tv}. Outputable tv => VarBndr tv ArgFlag -> TcType -> SDoc
pprArg [TyCoVarBinder]
vars [TcType]
hfWrap
         where pprArg :: VarBndr tv ArgFlag -> TcType -> SDoc
pprArg VarBndr tv ArgFlag
b TcType
arg = case forall tv argf. VarBndr tv argf -> argf
binderArgFlag VarBndr tv ArgFlag
b of
                                -- See Note [Explicit Case Statement for Specificity]
                                (Invisible Specificity
spec) -> case Specificity
spec of
                                  Specificity
SpecifiedSpec -> String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> TcType -> SDoc
pprParendType TcType
arg
                                  -- Do not print type application for inferred
                                  -- variables (#16456)
                                  Specificity
InferredSpec  -> SDoc
empty
                                ArgFlag
Required  -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pprHoleFit: bad Required"
                                                         (forall a. Outputable a => a -> SDoc
ppr VarBndr tv ArgFlag
b SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TcType
arg)
       tyAppVars :: SDoc
tyAppVars = [SDoc] -> SDoc
sep forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma forall a b. (a -> b) -> a -> b
$
           forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"pprHoleFit" (\TyCoVarBinder
v TcType
t -> forall a. Outputable a => a -> SDoc
ppr (forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
v) SDoc -> SDoc -> SDoc
<+>
                                               String -> SDoc
text String
"~" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
pprParendType TcType
t)
           [TyCoVarBinder]
vars [TcType]
hfWrap

       vars :: [TyCoVarBinder]
vars = TcType -> [TyCoVarBinder]
unwrapTypeVars TcType
hfType
         where
           -- Attempts to get all the quantified type variables in a type,
           -- e.g.
           -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a)
           -- into [m, a]
           unwrapTypeVars :: Type -> [TyCoVarBinder]
           unwrapTypeVars :: TcType -> [TyCoVarBinder]
unwrapTypeVars TcType
t = [TyCoVarBinder]
vars forall a. [a] -> [a] -> [a]
++ case TcType -> Maybe (TcType, TcType, TcType)
splitFunTy_maybe TcType
unforalled of
                               Just (TcType
_, TcType
_, TcType
unfunned) -> TcType -> [TyCoVarBinder]
unwrapTypeVars TcType
unfunned
                               Maybe (TcType, TcType, TcType)
_ -> []
             where ([TyCoVarBinder]
vars, TcType
unforalled) = TcType -> ([TyCoVarBinder], TcType)
splitForAllTyCoVarBinders TcType
t
       holeVs :: SDoc
holeVs = [SDoc] -> SDoc
sep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
parens forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SDoc
text String
"_" SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr) [TcType]
hfMatches
       holeDisp :: SDoc
holeDisp = if Bool
sMs then SDoc
holeVs
                  else [SDoc] -> SDoc
sep forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TcType]
hfMatches) forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"_"
       occDisp :: SDoc
occDisp = case HoleFitCandidate
hfCand of
                   GreHFCand GlobalRdrElt
gre   -> forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc (GlobalRdrElt -> Name
grePrintableName GlobalRdrElt
gre)
                   NameHFCand Name
name -> forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Name
name
                   IdHFCand Id
id_    -> forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Id
id_
       tyDisp :: SDoc
tyDisp = Bool -> SDoc -> SDoc
ppWhen Bool
sTy forall a b. (a -> b) -> a -> b
$ SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TcType
hfType
       has :: [a] -> Bool
has = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null
       wrapDisp :: SDoc
wrapDisp = Bool -> SDoc -> SDoc
ppWhen (forall {a}. [a] -> Bool
has [TcType]
hfWrap Bool -> Bool -> Bool
&& (Bool
sWrp Bool -> Bool -> Bool
|| Bool
sWrpVars))
                   forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"with" SDoc -> SDoc -> SDoc
<+> if Bool
sWrp Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
sTy
                                     then SDoc
occDisp SDoc -> SDoc -> SDoc
<+> SDoc
tyApp
                                     else SDoc
tyAppVars
       docs :: SDoc
docs = case Maybe HsDocString
hfDoc of
                Just HsDocString
d -> String -> SDoc
text String
"{-^" SDoc -> SDoc -> SDoc
<>
                          ([SDoc] -> SDoc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDocString -> String
unpackHDS) HsDocString
d
                          SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"-}"
                Maybe HsDocString
_ -> SDoc
empty
       funcInfo :: SDoc
funcInfo = Bool -> SDoc -> SDoc
ppWhen (forall {a}. [a] -> Bool
has [TcType]
hfMatches Bool -> Bool -> Bool
&& Bool
sTy) forall a b. (a -> b) -> a -> b
$
                    String -> SDoc
text String
"where" SDoc -> SDoc -> SDoc
<+> SDoc
occDisp SDoc -> SDoc -> SDoc
<+> SDoc
tyDisp
       subDisp :: SDoc
subDisp = SDoc
occDisp SDoc -> SDoc -> SDoc
<+> if forall {a}. [a] -> Bool
has [TcType]
hfMatches then SDoc
holeDisp else SDoc
tyDisp
       display :: SDoc
display =  SDoc
subDisp SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
2 (SDoc
funcInfo SDoc -> SDoc -> SDoc
$+$ SDoc
docs SDoc -> SDoc -> SDoc
$+$ SDoc
wrapDisp)
       provenance :: SDoc
provenance = Bool -> SDoc -> SDoc
ppWhen Bool
sProv forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
parens forall a b. (a -> b) -> a -> b
$
             case HoleFitCandidate
hfCand of
                 GreHFCand GlobalRdrElt
gre -> GlobalRdrElt -> SDoc
pprNameProvenance GlobalRdrElt
gre
                 NameHFCand Name
name -> String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
name)
                 IdHFCand Id
id_ -> String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. NamedThing a => a -> SrcLoc
getSrcLoc Id
id_)

getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id]
getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id]
getLocalBindings TidyEnv
tidy_orig CtLoc
ct_loc
 = do { (TidyEnv
env1, CtOrigin
_) <- TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
zonkTidyOrigin TidyEnv
tidy_orig (CtLoc -> CtOrigin
ctLocOrigin CtLoc
ct_loc)
      ; TidyEnv -> [Id] -> [TcBinder] -> TcM [Id]
go TidyEnv
env1 [] (forall a. HasOccName a => [a] -> [a]
removeBindingShadowing forall a b. (a -> b) -> a -> b
$ TcLclEnv -> [TcBinder]
tcl_bndrs TcLclEnv
lcl_env) }
  where
    lcl_env :: TcLclEnv
lcl_env = CtLoc -> TcLclEnv
ctLocEnv CtLoc
ct_loc

    go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id]
    go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id]
go TidyEnv
_ [Id]
sofar [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [Id]
sofar)
    go TidyEnv
env [Id]
sofar (TcBinder
tc_bndr : [TcBinder]
tc_bndrs) =
        case TcBinder
tc_bndr of
          TcIdBndr Id
id TopLevelFlag
_ -> Id -> TcM [Id]
keep_it Id
id
          TcBinder
_ -> TcM [Id]
discard_it
     where
        discard_it :: TcM [Id]
discard_it = TidyEnv -> [Id] -> [TcBinder] -> TcM [Id]
go TidyEnv
env [Id]
sofar [TcBinder]
tc_bndrs
        keep_it :: Id -> TcM [Id]
keep_it Id
id = TidyEnv -> [Id] -> [TcBinder] -> TcM [Id]
go TidyEnv
env (Id
idforall a. a -> [a] -> [a]
:[Id]
sofar) [TcBinder]
tc_bndrs



-- See Note [Valid hole fits include ...]
findValidHoleFits :: TidyEnv        -- ^ The tidy_env for zonking
                  -> [Implication]  -- ^ Enclosing implications for givens
                  -> [Ct]
                  -- ^ The  unsolved simple constraints in the implication for
                  -- the hole.
                  -> Hole
                  -> TcM (TidyEnv, SDoc)
findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Hole -> TcM (TidyEnv, SDoc)
findValidHoleFits TidyEnv
tidy_env [Implication]
implics [Ct]
simples h :: Hole
h@(Hole { hole_sort :: Hole -> HoleSort
hole_sort = ExprHole HoleExprRef
_
                                                   , hole_loc :: Hole -> CtLoc
hole_loc  = CtLoc
ct_loc
                                                   , hole_ty :: Hole -> TcType
hole_ty   = TcType
hole_ty }) =
  do { GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
     ; [Id]
lclBinds <- TidyEnv -> CtLoc -> TcM [Id]
getLocalBindings TidyEnv
tidy_env CtLoc
ct_loc
     ; Maybe Int
maxVSubs <- DynFlags -> Maybe Int
maxValidHoleFits forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     ; HoleFitDispConfig
hfdc <- TcM HoleFitDispConfig
getHoleFitDispConfig
     ; HoleFitSortingAlg
sortingAlg <- TcM HoleFitSortingAlg
getHoleFitSortingAlg
     ; DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
     ; [HoleFitPlugin]
hfPlugs <- TcGblEnv -> [HoleFitPlugin]
tcg_hf_plugins forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
     ; let findVLimit :: Maybe Int
findVLimit = if HoleFitSortingAlg
sortingAlg forall a. Ord a => a -> a -> Bool
> HoleFitSortingAlg
HFSNoSorting then forall a. Maybe a
Nothing else Maybe Int
maxVSubs
           refLevel :: Maybe Int
refLevel = DynFlags -> Maybe Int
refLevelHoleFits DynFlags
dflags
           hole :: TypedHole
hole = TypedHole { th_relevant_cts :: Cts
th_relevant_cts =
                                forall a. [a] -> Bag a
listToBag (TcType -> [Ct] -> [Ct]
relevantCts TcType
hole_ty [Ct]
simples)
                            , th_implics :: [Implication]
th_implics      = [Implication]
implics
                            , th_hole :: Maybe Hole
th_hole         = forall a. a -> Maybe a
Just Hole
h }
           ([[HoleFitCandidate] -> TcM [HoleFitCandidate]]
candidatePlugins, [[HoleFit] -> TcM [HoleFit]]
fitPlugins) =
             forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\HoleFitPlugin
p-> ((HoleFitPlugin -> CandPlugin
candPlugin HoleFitPlugin
p) TypedHole
hole, (HoleFitPlugin -> FitPlugin
fitPlugin HoleFitPlugin
p) TypedHole
hole)) [HoleFitPlugin]
hfPlugs
     ; String -> SDoc -> TcRn ()
traceTc String
"findingValidHoleFitsFor { " forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr TypedHole
hole
     ; String -> SDoc -> TcRn ()
traceTc String
"hole_lvl is:" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr TcLevel
hole_lvl
     ; String -> SDoc -> TcRn ()
traceTc String
"simples are: " forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr [Ct]
simples
     ; String -> SDoc -> TcRn ()
traceTc String
"locals are: " forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr [Id]
lclBinds
     ; let ([GlobalRdrElt]
lcl, [GlobalRdrElt]
gbl) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition GlobalRdrElt -> Bool
gre_lcl (GlobalRdrEnv -> [GlobalRdrElt]
globalRdrEnvElts GlobalRdrEnv
rdr_env)
           -- We remove binding shadowings here, but only for the local level.
           -- this is so we e.g. suggest the global fmap from the Functor class
           -- even though there is a local definition as well, such as in the
           -- Free monad example.
           locals :: [HoleFitCandidate]
locals = forall a. HasOccName a => [a] -> [a]
removeBindingShadowing forall a b. (a -> b) -> a -> b
$
                      forall a b. (a -> b) -> [a] -> [b]
map Id -> HoleFitCandidate
IdHFCand [Id]
lclBinds forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> HoleFitCandidate
GreHFCand [GlobalRdrElt]
lcl
           globals :: [HoleFitCandidate]
globals = forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> HoleFitCandidate
GreHFCand [GlobalRdrElt]
gbl
           syntax :: [HoleFitCandidate]
syntax = forall a b. (a -> b) -> [a] -> [b]
map Name -> HoleFitCandidate
NameHFCand [Name]
builtIns
           to_check :: [HoleFitCandidate]
to_check = [HoleFitCandidate]
locals forall a. [a] -> [a] -> [a]
++ [HoleFitCandidate]
syntax forall a. [a] -> [a] -> [a]
++ [HoleFitCandidate]
globals
     ; [HoleFitCandidate]
cands <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)) [HoleFitCandidate]
to_check [[HoleFitCandidate] -> TcM [HoleFitCandidate]]
candidatePlugins
     ; String -> SDoc -> TcRn ()
traceTc String
"numPlugins are:" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[HoleFitCandidate] -> TcM [HoleFitCandidate]]
candidatePlugins)
     ; (Bool
searchDiscards, [HoleFit]
subs) <-
        Maybe Int
-> TypedHole
-> (TcType, [Id])
-> [HoleFitCandidate]
-> TcM (Bool, [HoleFit])
tcFilterHoleFits Maybe Int
findVLimit TypedHole
hole (TcType
hole_ty, []) [HoleFitCandidate]
cands
     ; (TidyEnv
tidy_env, [HoleFit]
tidy_subs) <- TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
zonkSubs TidyEnv
tidy_env [HoleFit]
subs
     ; [HoleFit]
tidy_sorted_subs <- HoleFitSortingAlg -> [HoleFit] -> TcM [HoleFit]
sortFits HoleFitSortingAlg
sortingAlg [HoleFit]
tidy_subs
     ; [HoleFit]
plugin_handled_subs <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)) [HoleFit]
tidy_sorted_subs [[HoleFit] -> TcM [HoleFit]]
fitPlugins
     ; let (Bool
pVDisc, [HoleFit]
limited_subs) = Maybe Int -> [HoleFit] -> (Bool, [HoleFit])
possiblyDiscard Maybe Int
maxVSubs [HoleFit]
plugin_handled_subs
           vDiscards :: Bool
vDiscards = Bool
pVDisc Bool -> Bool -> Bool
|| Bool
searchDiscards
     ; [HoleFit]
subs_with_docs <- [HoleFit] -> TcM [HoleFit]
addHoleFitDocs [HoleFit]
limited_subs
     ; let vMsg :: SDoc
vMsg = Bool -> SDoc -> SDoc
ppUnless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HoleFit]
subs_with_docs) forall a b. (a -> b) -> a -> b
$
                    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Valid hole fits include") Int
2 forall a b. (a -> b) -> a -> b
$
                      [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (HoleFitDispConfig -> HoleFit -> SDoc
pprHoleFit HoleFitDispConfig
hfdc) [HoleFit]
subs_with_docs)
                        SDoc -> SDoc -> SDoc
$$ Bool -> SDoc -> SDoc
ppWhen Bool
vDiscards SDoc
subsDiscardMsg
     -- Refinement hole fits. See Note [Valid refinement hole fits include ...]
     ; (TidyEnv
tidy_env, SDoc
refMsg) <- if Maybe Int
refLevel forall a. Ord a => a -> a -> Bool
>= forall a. a -> Maybe a
Just Int
0 then
         do { Maybe Int
maxRSubs <- DynFlags -> Maybe Int
maxRefHoleFits forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            -- We can use from just, since we know that Nothing >= _ is False.
            ; let refLvls :: [Int]
refLvls = [Int
1..(forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
refLevel)]
            -- We make a new refinement type for each level of refinement, where
            -- the level of refinement indicates number of additional arguments
            -- to allow.
            ; [(TcType, [Id])]
ref_tys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> TcM (TcType, [Id])
mkRefTy [Int]
refLvls
            ; String -> SDoc -> TcRn ()
traceTc String
"ref_tys are" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr [(TcType, [Id])]
ref_tys
            ; let findRLimit :: Maybe Int
findRLimit = if HoleFitSortingAlg
sortingAlg forall a. Ord a => a -> a -> Bool
> HoleFitSortingAlg
HFSNoSorting then forall a. Maybe a
Nothing
                                                            else Maybe Int
maxRSubs
            ; [(Bool, [HoleFit])]
refDs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe Int
-> TypedHole
-> (TcType, [Id])
-> [HoleFitCandidate]
-> TcM (Bool, [HoleFit])
tcFilterHoleFits Maybe Int
findRLimit TypedHole
hole)
                              [HoleFitCandidate]
cands) [(TcType, [Id])]
ref_tys
            ; (TidyEnv
tidy_env, [HoleFit]
tidy_rsubs) <- TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
zonkSubs TidyEnv
tidy_env forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Bool, [HoleFit])]
refDs
            ; [HoleFit]
tidy_sorted_rsubs <- HoleFitSortingAlg -> [HoleFit] -> TcM [HoleFit]
sortFits HoleFitSortingAlg
sortingAlg [HoleFit]
tidy_rsubs
            -- For refinement substitutions we want matches
            -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t),
            -- and others in that vein to appear last, since these are
            -- unlikely to be the most relevant fits.
            ; (TidyEnv
tidy_env, TcType
tidy_hole_ty) <- TidyEnv -> TcType -> TcM (TidyEnv, TcType)
zonkTidyTcType TidyEnv
tidy_env TcType
hole_ty
            ; let hasExactApp :: HoleFit -> Bool
hasExactApp = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HasDebugCallStack => TcType -> TcType -> Bool
tcEqType TcType
tidy_hole_ty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. HoleFit -> [TcType]
hfWrap
                  ([HoleFit]
exact, [HoleFit]
not_exact) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition HoleFit -> Bool
hasExactApp [HoleFit]
tidy_sorted_rsubs
            ; [HoleFit]
plugin_handled_rsubs <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($))
                                        ([HoleFit]
not_exact forall a. [a] -> [a] -> [a]
++ [HoleFit]
exact) [[HoleFit] -> TcM [HoleFit]]
fitPlugins
            ; let (Bool
pRDisc, [HoleFit]
exact_last_rfits) =
                    Maybe Int -> [HoleFit] -> (Bool, [HoleFit])
possiblyDiscard Maybe Int
maxRSubs forall a b. (a -> b) -> a -> b
$ [HoleFit]
plugin_handled_rsubs
                  rDiscards :: Bool
rDiscards = Bool
pRDisc Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. (a, b) -> a
fst [(Bool, [HoleFit])]
refDs
            ; [HoleFit]
rsubs_with_docs <- [HoleFit] -> TcM [HoleFit]
addHoleFitDocs [HoleFit]
exact_last_rfits
            ; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
tidy_env,
                Bool -> SDoc -> SDoc
ppUnless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HoleFit]
rsubs_with_docs) forall a b. (a -> b) -> a -> b
$
                  SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Valid refinement hole fits include") Int
2 forall a b. (a -> b) -> a -> b
$
                  [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (HoleFitDispConfig -> HoleFit -> SDoc
pprHoleFit HoleFitDispConfig
hfdc) [HoleFit]
rsubs_with_docs)
                    SDoc -> SDoc -> SDoc
$$ Bool -> SDoc -> SDoc
ppWhen Bool
rDiscards SDoc
refSubsDiscardMsg) }
       else forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
tidy_env, SDoc
empty)
     ; String -> SDoc -> TcRn ()
traceTc String
"findingValidHoleFitsFor }" SDoc
empty
     ; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
tidy_env, SDoc
vMsg SDoc -> SDoc -> SDoc
$$ SDoc
refMsg) }
  where
    -- We extract the TcLevel from the constraint.
    hole_lvl :: TcLevel
hole_lvl = CtLoc -> TcLevel
ctLocLevel CtLoc
ct_loc

    -- BuiltInSyntax names like (:) and []
    builtIns :: [Name]
    builtIns :: [Name]
builtIns = forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
isBuiltInSyntax [Name]
knownKeyNames

    -- We make a refinement type by adding a new type variable in front
    -- of the type of t h hole, going from e.g. [Integer] -> Integer
    -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier
    -- to unify the new type variable with any type, allowing us
    -- to suggest a "refinement hole fit", like `(foldl1 _)` instead
    -- of only concrete hole fits like `sum`.
    mkRefTy :: Int -> TcM (TcType, [TcTyVar])
    mkRefTy :: Int -> TcM (TcType, [Id])
mkRefTy Int
refLvl = ([Id] -> TcType
wrapWithVars forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcM [Id]
newTyVars
      where newTyVars :: TcM [Id]
newTyVars = forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
refLvl forall a b. (a -> b) -> a -> b
$ Id -> Id
setLvl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            (TcM TcType
newOpenTypeKind forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TcType -> IOEnv (Env TcGblEnv TcLclEnv) Id
newFlexiTyVar)
            setLvl :: Id -> Id
setLvl = forall a b c. (a -> b -> c) -> b -> a -> c
flip Id -> TcLevel -> Id
setMetaTyVarTcLevel TcLevel
hole_lvl
            wrapWithVars :: [Id] -> TcType
wrapWithVars [Id]
vars = [TcType] -> TcType -> TcType
mkVisFunTysMany (forall a b. (a -> b) -> [a] -> [b]
map Id -> TcType
mkTyVarTy [Id]
vars) TcType
hole_ty

    sortFits :: HoleFitSortingAlg    -- How we should sort the hole fits
             -> [HoleFit]     -- The subs to sort
             -> TcM [HoleFit]
    sortFits :: HoleFitSortingAlg -> [HoleFit] -> TcM [HoleFit]
sortFits HoleFitSortingAlg
HFSNoSorting [HoleFit]
subs = forall (m :: * -> *) a. Monad m => a -> m a
return [HoleFit]
subs
    sortFits HoleFitSortingAlg
HFSBySize [HoleFit]
subs
        = forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HoleFit] -> TcM [HoleFit]
sortHoleFitsBySize (forall a. Ord a => [a] -> [a]
sort [HoleFit]
lclFits)
               forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [HoleFit] -> TcM [HoleFit]
sortHoleFitsBySize (forall a. Ord a => [a] -> [a]
sort [HoleFit]
gblFits)
        where ([HoleFit]
lclFits, [HoleFit]
gblFits) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span HoleFit -> Bool
hfIsLcl [HoleFit]
subs
    -- To sort by subsumption, we invoke the sortByGraph function, which
    -- builds the subsumption graph for the fits and then sorts them using a
    -- graph sort.  Since we want locals to come first anyway, we can sort
    -- them separately. The substitutions are already checked in local then
    -- global order, so we can get away with using span here.
    -- We use (<*>) to expose the parallelism, in case it becomes useful later.
    sortFits HoleFitSortingAlg
HFSBySubsumption [HoleFit]
subs
        = forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HoleFit] -> TcM [HoleFit]
sortHoleFitsByGraph (forall a. Ord a => [a] -> [a]
sort [HoleFit]
lclFits)
               forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [HoleFit] -> TcM [HoleFit]
sortHoleFitsByGraph (forall a. Ord a => [a] -> [a]
sort [HoleFit]
gblFits)
        where ([HoleFit]
lclFits, [HoleFit]
gblFits) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span HoleFit -> Bool
hfIsLcl [HoleFit]
subs

    subsDiscardMsg :: SDoc
    subsDiscardMsg :: SDoc
subsDiscardMsg =
        String -> SDoc
text String
"(Some hole fits suppressed;" SDoc -> SDoc -> SDoc
<+>
        String -> SDoc
text String
"use -fmax-valid-hole-fits=N" SDoc -> SDoc -> SDoc
<+>
        String -> SDoc
text String
"or -fno-max-valid-hole-fits)"

    refSubsDiscardMsg :: SDoc
    refSubsDiscardMsg :: SDoc
refSubsDiscardMsg =
        String -> SDoc
text String
"(Some refinement hole fits suppressed;" SDoc -> SDoc -> SDoc
<+>
        String -> SDoc
text String
"use -fmax-refinement-hole-fits=N" SDoc -> SDoc -> SDoc
<+>
        String -> SDoc
text String
"or -fno-max-refinement-hole-fits)"


    -- Based on the flags, we might possibly discard some or all the
    -- fits we've found.
    possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit])
    possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit])
possiblyDiscard (Just Int
max) [HoleFit]
fits = ([HoleFit]
fits forall a. [a] -> Int -> Bool
`lengthExceeds` Int
max, forall a. Int -> [a] -> [a]
take Int
max [HoleFit]
fits)
    possiblyDiscard Maybe Int
Nothing [HoleFit]
fits = (Bool
False, [HoleFit]
fits)


-- We don't (as of yet) handle holes in types, only in expressions.
findValidHoleFits TidyEnv
env [Implication]
_ [Ct]
_ Hole
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, SDoc
empty)

-- See Note [Relevant constraints]
relevantCts :: Type -> [Ct] -> [Ct]
relevantCts :: TcType -> [Ct] -> [Ct]
relevantCts TcType
hole_ty [Ct]
simples = if VarSet -> Bool
isEmptyVarSet (FV -> VarSet
fvVarSet FV
hole_fvs) then []
                              else forall a. (a -> Bool) -> [a] -> [a]
filter Ct -> Bool
isRelevant [Ct]
simples
  where ctFreeVarSet :: Ct -> VarSet
        ctFreeVarSet :: Ct -> VarSet
ctFreeVarSet = FV -> VarSet
fvVarSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcType -> FV
tyCoFVsOfType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ct -> TcType
ctPred
        hole_fvs :: FV
hole_fvs = TcType -> FV
tyCoFVsOfType TcType
hole_ty
        hole_fv_set :: VarSet
hole_fv_set = FV -> VarSet
fvVarSet FV
hole_fvs
        anyFVMentioned :: Ct -> Bool
        anyFVMentioned :: Ct -> Bool
anyFVMentioned Ct
ct = Ct -> VarSet
ctFreeVarSet Ct
ct VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
hole_fv_set
        -- We filter out those constraints that have no variables (since
        -- they won't be solved by finding a type for the type variable
        -- representing the hole) and also other holes, since we're not
        -- trying to find hole fits for many holes at once.
        isRelevant :: Ct -> Bool
isRelevant Ct
ct = Bool -> Bool
not (VarSet -> Bool
isEmptyVarSet (Ct -> VarSet
ctFreeVarSet Ct
ct))
                        Bool -> Bool -> Bool
&& Ct -> Bool
anyFVMentioned Ct
ct

-- We zonk the hole fits so that the output aligns with the rest
-- of the typed hole error message output.
zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
zonkSubs = [HoleFit] -> TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
zonkSubs' []
  where zonkSubs' :: [HoleFit] -> TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
zonkSubs' [HoleFit]
zs TidyEnv
env [] = forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, forall a. [a] -> [a]
reverse [HoleFit]
zs)
        zonkSubs' [HoleFit]
zs TidyEnv
env (HoleFit
hf:[HoleFit]
hfs) = do { (TidyEnv
env', HoleFit
z) <- TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit)
zonkSub TidyEnv
env HoleFit
hf
                                        ; [HoleFit] -> TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
zonkSubs' (HoleFit
zforall a. a -> [a] -> [a]
:[HoleFit]
zs) TidyEnv
env' [HoleFit]
hfs }

        zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit)
        zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit)
zonkSub TidyEnv
env hf :: HoleFit
hf@RawHoleFit{} = forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, HoleFit
hf)
        zonkSub TidyEnv
env hf :: HoleFit
hf@HoleFit{hfType :: HoleFit -> TcType
hfType = TcType
ty, hfMatches :: HoleFit -> [TcType]
hfMatches = [TcType]
m, hfWrap :: HoleFit -> [TcType]
hfWrap = [TcType]
wrp}
            = do { (TidyEnv
env, TcType
ty') <- TidyEnv -> TcType -> TcM (TidyEnv, TcType)
zonkTidyTcType TidyEnv
env TcType
ty
                ; (TidyEnv
env, [TcType]
m') <- TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType])
zonkTidyTcTypes TidyEnv
env [TcType]
m
                ; (TidyEnv
env, [TcType]
wrp') <- TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType])
zonkTidyTcTypes TidyEnv
env [TcType]
wrp
                ; let zFit :: HoleFit
zFit = HoleFit
hf {hfType :: TcType
hfType = TcType
ty', hfMatches :: [TcType]
hfMatches = [TcType]
m', hfWrap :: [TcType]
hfWrap = [TcType]
wrp'}
                ; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, HoleFit
zFit ) }

-- | Sort by size uses as a measure for relevance the sizes of the different
-- types needed to instantiate the fit to the type of the hole.
-- This is much quicker than sorting by subsumption, and gives reasonable
-- results in most cases.
sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit]
sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit]
sortHoleFitsBySize = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn HoleFit -> TypeSize
sizeOfFit
  where sizeOfFit :: HoleFit -> TypeSize
        sizeOfFit :: HoleFit -> TypeSize
sizeOfFit = [TcType] -> TypeSize
sizeTypes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy HasDebugCallStack => TcType -> TcType -> Bool
tcEqType forall b c a. (b -> c) -> (a -> b) -> a -> c
.  HoleFit -> [TcType]
hfWrap

-- Based on a suggestion by phadej on #ghc, we can sort the found fits
-- by constructing a subsumption graph, and then do a topological sort of
-- the graph. This makes the most specific types appear first, which are
-- probably those most relevant. This takes a lot of work (but results in
-- much more useful output), and can be disabled by
-- '-fno-sort-valid-hole-fits'.
sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]
sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]
sortHoleFitsByGraph [HoleFit]
fits = [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]
go [] [HoleFit]
fits
  where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool
        tcSubsumesWCloning :: TcType -> TcType -> TcM Bool
tcSubsumesWCloning TcType
ht TcType
ty = forall a. FV -> TcM a -> TcM a
withoutUnification FV
fvs (TcType -> TcType -> TcM Bool
tcSubsumes TcType
ht TcType
ty)
          where fvs :: FV
fvs = [TcType] -> FV
tyCoFVsOfTypes [TcType
ht,TcType
ty]
        go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]
        go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]
go [(HoleFit, [HoleFit])]
sofar [] = do { String -> SDoc -> TcRn ()
traceTc String
"subsumptionGraph was" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr [(HoleFit, [HoleFit])]
sofar
                         ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> ([a], [a])
partition HoleFit -> Bool
hfIsLcl [HoleFit]
topSorted }
          where toV :: (HoleFit, [HoleFit]) -> (HoleFit, Id, [Id])
toV (HoleFit
hf, [HoleFit]
adjs) = (HoleFit
hf, HoleFit -> Id
hfId HoleFit
hf, forall a b. (a -> b) -> [a] -> [b]
map HoleFit -> Id
hfId [HoleFit]
adjs)
                (Graph
graph, Int -> (HoleFit, Id, [Id])
fromV, Id -> Maybe Int
_) = forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
graphFromEdges forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (HoleFit, [HoleFit]) -> (HoleFit, Id, [Id])
toV [(HoleFit, [HoleFit])]
sofar
                topSorted :: [HoleFit]
topSorted = forall a b. (a -> b) -> [a] -> [b]
map ((\(HoleFit
h,Id
_,[Id]
_) -> HoleFit
h) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (HoleFit, Id, [Id])
fromV) forall a b. (a -> b) -> a -> b
$ Graph -> [Int]
topSort Graph
graph
        go [(HoleFit, [HoleFit])]
sofar (HoleFit
hf:[HoleFit]
hfs) =
          do { [HoleFit]
adjs <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (TcType -> TcType -> TcM Bool
tcSubsumesWCloning (HoleFit -> TcType
hfType HoleFit
hf) forall b c a. (b -> c) -> (a -> b) -> a -> c
. HoleFit -> TcType
hfType) [HoleFit]
fits
             ; [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]
go ((HoleFit
hf, [HoleFit]
adjs)forall a. a -> [a] -> [a]
:[(HoleFit, [HoleFit])]
sofar) [HoleFit]
hfs }

-- | tcFilterHoleFits filters the candidates by whether, given the implications
-- and the relevant constraints, they can be made to match the type by
-- running the type checker. Stops after finding limit matches.
tcFilterHoleFits :: Maybe Int
               -- ^ How many we should output, if limited
               -> TypedHole -- ^ The hole to filter against
               -> (TcType, [TcTyVar])
               -- ^ The type to check for fits and a list of refinement
               -- variables (free type variables in the type) for emulating
               -- additional holes.
               -> [HoleFitCandidate]
               -- ^ The candidates to check whether fit.
               -> TcM (Bool, [HoleFit])
               -- ^ We return whether or not we stopped due to hitting the limit
               -- and the fits we found.
tcFilterHoleFits :: Maybe Int
-> TypedHole
-> (TcType, [Id])
-> [HoleFitCandidate]
-> TcM (Bool, [HoleFit])
tcFilterHoleFits (Just Int
0) TypedHole
_ (TcType, [Id])
_ [HoleFitCandidate]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, []) -- Stop right away on 0
tcFilterHoleFits Maybe Int
limit TypedHole
typed_hole ht :: (TcType, [Id])
ht@(TcType
hole_ty, [Id]
_) [HoleFitCandidate]
candidates =
  do { String -> SDoc -> TcRn ()
traceTc String
"checkingFitsFor {" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr TcType
hole_ty
     ; (Bool
discards, [HoleFit]
subs) <- [HoleFit]
-> VarSet
-> Maybe Int
-> (TcType, [Id])
-> [HoleFitCandidate]
-> TcM (Bool, [HoleFit])
go [] VarSet
emptyVarSet Maybe Int
limit (TcType, [Id])
ht [HoleFitCandidate]
candidates
     ; String -> SDoc -> TcRn ()
traceTc String
"checkingFitsFor }" SDoc
empty
     ; forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
discards, [HoleFit]
subs) }
  where
    hole_fvs :: FV
    hole_fvs :: FV
hole_fvs = TcType -> FV
tyCoFVsOfType TcType
hole_ty
    -- Kickoff the checking of the elements.
    -- We iterate over the elements, checking each one in turn for whether
    -- it fits, and adding it to the results if it does.
    go :: [HoleFit]           -- What we've found so far.
       -> VarSet              -- Ids we've already checked
       -> Maybe Int           -- How many we're allowed to find, if limited
       -> (TcType, [TcTyVar]) -- The type, and its refinement variables.
       -> [HoleFitCandidate]  -- The elements we've yet to check.
       -> TcM (Bool, [HoleFit])
    go :: [HoleFit]
-> VarSet
-> Maybe Int
-> (TcType, [Id])
-> [HoleFitCandidate]
-> TcM (Bool, [HoleFit])
go [HoleFit]
subs VarSet
_ Maybe Int
_ (TcType, [Id])
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, forall a. [a] -> [a]
reverse [HoleFit]
subs)
    go [HoleFit]
subs VarSet
_ (Just Int
0) (TcType, [Id])
_ [HoleFitCandidate]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, forall a. [a] -> [a]
reverse [HoleFit]
subs)
    go [HoleFit]
subs VarSet
seen Maybe Int
maxleft (TcType, [Id])
ty (HoleFitCandidate
el:[HoleFitCandidate]
elts) =
        -- See Note [Leaking errors]
        forall r. TcM r -> TcM r -> TcM r
tryTcDiscardingErrs TcM (Bool, [HoleFit])
discard_it forall a b. (a -> b) -> a -> b
$
        do { String -> SDoc -> TcRn ()
traceTc String
"lookingUp" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr HoleFitCandidate
el
           ; Maybe (Id, TcType)
maybeThing <- HoleFitCandidate -> TcM (Maybe (Id, TcType))
lookup HoleFitCandidate
el
           ; case Maybe (Id, TcType)
maybeThing of
               Just (Id
id, TcType
id_ty) | Id -> Bool
not_trivial Id
id ->
                       do { Maybe ([TcType], [TcType])
fits <- (TcType, [Id]) -> TcType -> TcM (Maybe ([TcType], [TcType]))
fitsHole (TcType, [Id])
ty TcType
id_ty
                          ; case Maybe ([TcType], [TcType])
fits of
                              Just ([TcType]
wrp, [TcType]
matches) -> Id -> TcType -> [TcType] -> [TcType] -> TcM (Bool, [HoleFit])
keep_it Id
id TcType
id_ty [TcType]
wrp [TcType]
matches
                              Maybe ([TcType], [TcType])
_ -> TcM (Bool, [HoleFit])
discard_it }
               Maybe (Id, TcType)
_ -> TcM (Bool, [HoleFit])
discard_it }
        where
          -- We want to filter out undefined and the likes from GHC.Err
          not_trivial :: Id -> Bool
not_trivial Id
id = Name -> Maybe Module
nameModule_maybe (Id -> Name
idName Id
id) forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Module
gHC_ERR

          lookup :: HoleFitCandidate -> TcM (Maybe (Id, Type))
          lookup :: HoleFitCandidate -> TcM (Maybe (Id, TcType))
lookup (IdHFCand Id
id) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Id
id, Id -> TcType
idType Id
id))
          lookup HoleFitCandidate
hfc = do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
name
                          ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case TcTyThing
thing of
                                       ATcId {tct_id :: TcTyThing -> Id
tct_id = Id
id} -> forall a. a -> Maybe a
Just (Id
id, Id -> TcType
idType Id
id)
                                       AGlobal (AnId Id
id)   -> forall a. a -> Maybe a
Just (Id
id, Id -> TcType
idType Id
id)
                                       AGlobal (AConLike (RealDataCon DataCon
con)) ->
                                           forall a. a -> Maybe a
Just (DataCon -> Id
dataConWrapId DataCon
con, DataCon -> TcType
dataConNonlinearType DataCon
con)
                                       TcTyThing
_ -> forall a. Maybe a
Nothing }
            where name :: Name
name = case HoleFitCandidate
hfc of
#if __GLASGOW_HASKELL__ < 901
                           IdHFCand id -> idName id
#endif
                           GreHFCand GlobalRdrElt
gre -> GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre
                           NameHFCand Name
name -> Name
name
          discard_it :: TcM (Bool, [HoleFit])
discard_it = [HoleFit]
-> VarSet
-> Maybe Int
-> (TcType, [Id])
-> [HoleFitCandidate]
-> TcM (Bool, [HoleFit])
go [HoleFit]
subs VarSet
seen Maybe Int
maxleft (TcType, [Id])
ty [HoleFitCandidate]
elts
          keep_it :: Id -> TcType -> [TcType] -> [TcType] -> TcM (Bool, [HoleFit])
keep_it Id
eid TcType
eid_ty [TcType]
wrp [TcType]
ms = [HoleFit]
-> VarSet
-> Maybe Int
-> (TcType, [Id])
-> [HoleFitCandidate]
-> TcM (Bool, [HoleFit])
go (HoleFit
fitforall a. a -> [a] -> [a]
:[HoleFit]
subs) (VarSet -> Id -> VarSet
extendVarSet VarSet
seen Id
eid)
                                 ((\Int
n -> Int
n forall a. Num a => a -> a -> a
- Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
maxleft) (TcType, [Id])
ty [HoleFitCandidate]
elts
            where
              fit :: HoleFit
fit = HoleFit { hfId :: Id
hfId = Id
eid, hfCand :: HoleFitCandidate
hfCand = HoleFitCandidate
el, hfType :: TcType
hfType = TcType
eid_ty
                            , hfRefLvl :: Int
hfRefLvl = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a b. (a, b) -> b
snd (TcType, [Id])
ty)
                            , hfWrap :: [TcType]
hfWrap = [TcType]
wrp, hfMatches :: [TcType]
hfMatches = [TcType]
ms
                            , hfDoc :: Maybe HsDocString
hfDoc = forall a. Maybe a
Nothing }




    unfoldWrapper :: HsWrapper -> [Type]
    unfoldWrapper :: HsWrapper -> [TcType]
unfoldWrapper = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsWrapper -> [TcType]
unfWrp'
      where unfWrp' :: HsWrapper -> [TcType]
unfWrp' (WpTyApp TcType
ty) = [TcType
ty]
            unfWrp' (WpCompose HsWrapper
w1 HsWrapper
w2) = HsWrapper -> [TcType]
unfWrp' HsWrapper
w1 forall a. [a] -> [a] -> [a]
++ HsWrapper -> [TcType]
unfWrp' HsWrapper
w2
            unfWrp' HsWrapper
_ = []


    -- The real work happens here, where we invoke the type checker using
    -- tcCheckHoleFit to see whether the given type fits the hole.
    fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the
                                    -- refinement variables created to simulate
                                    -- additional holes (if any), and the list
                                    -- of those variables (possibly empty).
                                    -- As an example: If the actual type of the
                                    -- hole (as specified by the hole
                                    -- constraint CHoleExpr passed to
                                    -- findValidHoleFits) is t and we want to
                                    -- simulate N additional holes, h_ty will
                                    -- be  r_1 -> ... -> r_N -> t, and
                                    -- ref_vars will be [r_1, ... , r_N].
                                    -- In the base case with no additional
                                    -- holes, h_ty will just be t and ref_vars
                                    -- will be [].
             -> TcType -- The type we're checking to whether it can be
                       -- instantiated to the type h_ty.
             -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we
                                                 -- return Nothing. Otherwise,
                                                 -- we Just return the list of
                                                 -- types that quantified type
                                                 -- variables in ty would take
                                                 -- if used in place of h_ty,
                                                 -- and the list types of any
                                                 -- additional holes simulated
                                                 -- with the refinement
                                                 -- variables in ref_vars.
    fitsHole :: (TcType, [Id]) -> TcType -> TcM (Maybe ([TcType], [TcType]))
fitsHole (TcType
h_ty, [Id]
ref_vars) TcType
ty =
    -- We wrap this with the withoutUnification to avoid having side-effects
    -- beyond the check, but we rely on the side-effects when looking for
    -- refinement hole fits, so we can't wrap the side-effects deeper than this.
      forall a. FV -> TcM a -> TcM a
withoutUnification FV
fvs forall a b. (a -> b) -> a -> b
$
      do { String -> SDoc -> TcRn ()
traceTc String
"checkingFitOf {" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr TcType
ty
         ; (Bool
fits, HsWrapper
wrp) <- TypedHole -> TcType -> TcType -> TcM (Bool, HsWrapper)
tcCheckHoleFit TypedHole
hole TcType
h_ty TcType
ty
         ; String -> SDoc -> TcRn ()
traceTc String
"Did it fit?" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr Bool
fits
         ; String -> SDoc -> TcRn ()
traceTc String
"wrap is: " forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr HsWrapper
wrp
         ; String -> SDoc -> TcRn ()
traceTc String
"checkingFitOf }" SDoc
empty
         ; [TcType]
z_wrp_tys <- [TcType] -> TcM [TcType]
zonkTcTypes (HsWrapper -> [TcType]
unfoldWrapper HsWrapper
wrp)
         -- We'd like to avoid refinement suggestions like `id _ _` or
         -- `head _ _`, and only suggest refinements where our all phantom
         -- variables got unified during the checking. This can be disabled
         -- with the `-fabstract-refinement-hole-fits` flag.
         -- Here we do the additional handling when there are refinement
         -- variables, i.e. zonk them to read their final value to check for
         -- abstract refinements, and to report what the type of the simulated
         -- holes must be for this to be a match.
         ; if Bool
fits
           then if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
ref_vars
                then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ([TcType]
z_wrp_tys, []))
                else do { let -- To be concrete matches, matches have to
                              -- be more than just an invented type variable.
                              fvSet :: VarSet
fvSet = FV -> VarSet
fvVarSet FV
fvs
                              notAbstract :: TcType -> Bool
                              notAbstract :: TcType -> Bool
notAbstract TcType
t = case TcType -> Maybe Id
getTyVar_maybe TcType
t of
                                                Just Id
tv -> Id
tv Id -> VarSet -> Bool
`elemVarSet` VarSet
fvSet
                                                Maybe Id
_ -> Bool
True
                              allConcrete :: Bool
allConcrete = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TcType -> Bool
notAbstract [TcType]
z_wrp_tys
                        ; [TcType]
z_vars  <- [Id] -> TcM [TcType]
zonkTcTyVars [Id]
ref_vars
                        ; let z_mtvs :: [Id]
z_mtvs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TcType -> Maybe Id
tcGetTyVar_maybe [TcType]
z_vars
                        ; Bool
allFilled <- Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM Id -> TcM Bool
isFlexiTyVar [Id]
z_mtvs
                        ; Bool
allowAbstract <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_AbstractRefHoleFits
                        ; if Bool
allowAbstract Bool -> Bool -> Bool
|| (Bool
allFilled Bool -> Bool -> Bool
&& Bool
allConcrete )
                          then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([TcType]
z_wrp_tys, [TcType]
z_vars)
                          else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
           else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
     where fvs :: FV
fvs = [Id] -> FV
mkFVs [Id]
ref_vars FV -> FV -> FV
`unionFV` FV
hole_fvs FV -> FV -> FV
`unionFV` TcType -> FV
tyCoFVsOfType TcType
ty
           hole :: TypedHole
hole = TypedHole
typed_hole { th_hole :: Maybe Hole
th_hole = forall a. Maybe a
Nothing }



-- | Checks whether a MetaTyVar is flexible or not.
isFlexiTyVar :: TcTyVar -> TcM Bool
isFlexiTyVar :: Id -> TcM Bool
isFlexiTyVar Id
tv | Id -> Bool
isMetaTyVar Id
tv = MetaDetails -> Bool
isFlexi forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> TcM MetaDetails
readMetaTyVar Id
tv
isFlexiTyVar Id
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Takes a list of free variables and restores any Flexi type variables in
-- free_vars after the action is run.
withoutUnification :: FV -> TcM a -> TcM a
withoutUnification :: forall a. FV -> TcM a -> TcM a
withoutUnification FV
free_vars TcM a
action =
  do { [Id]
flexis <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Id -> TcM Bool
isFlexiTyVar [Id]
fuvs
     ; a
result <- TcM a
action
          -- Reset any mutated free variables
     ; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Id -> TcRn ()
restore [Id]
flexis
     ; forall (m :: * -> *) a. Monad m => a -> m a
return a
result }
  where restore :: Id -> TcRn ()
restore Id
tv = do { String -> SDoc -> TcRn ()
traceTc String
"withoutUnification: restore flexi" (forall a. Outputable a => a -> SDoc
ppr Id
tv)
                        ; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (Id -> IORef MetaDetails
metaTyVarRef Id
tv) MetaDetails
Flexi }
        fuvs :: [Id]
fuvs = FV -> [Id]
fvVarList FV
free_vars

-- | Reports whether first type (ty_a) subsumes the second type (ty_b),
-- discarding any errors. Subsumption here means that the ty_b can fit into the
-- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a.
tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool
tcSubsumes :: TcType -> TcType -> TcM Bool
tcSubsumes TcType
ty_a TcType
ty_b = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypedHole -> TcType -> TcType -> TcM (Bool, HsWrapper)
tcCheckHoleFit TypedHole
dummyHole TcType
ty_a TcType
ty_b
  where dummyHole :: TypedHole
dummyHole = TypedHole { th_relevant_cts :: Cts
th_relevant_cts = forall a. Bag a
emptyBag
                              , th_implics :: [Implication]
th_implics      = []
                              , th_hole :: Maybe Hole
th_hole         = forall a. Maybe a
Nothing }

-- | A tcSubsumes which takes into account relevant constraints, to fix trac
-- #14273. This makes sure that when checking whether a type fits the hole,
-- the type has to be subsumed by type of the hole as well as fulfill all
-- constraints on the type of the hole.
tcCheckHoleFit :: TypedHole   -- ^ The hole to check against
               -> TcSigmaType
               -- ^ The type to check against (possibly modified, e.g. refined)
               -> TcSigmaType -- ^ The type to check whether fits.
               -> TcM (Bool, HsWrapper)
               -- ^ Whether it was a match, and the wrapper from hole_ty to ty.
tcCheckHoleFit :: TypedHole -> TcType -> TcType -> TcM (Bool, HsWrapper)
tcCheckHoleFit TypedHole
_ TcType
hole_ty TcType
ty | TcType
hole_ty TcType -> TcType -> Bool
`eqType` TcType
ty
    = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, HsWrapper
idHsWrapper)
tcCheckHoleFit (TypedHole {[Implication]
Maybe Hole
Cts
th_hole :: Maybe Hole
th_implics :: [Implication]
th_relevant_cts :: Cts
th_hole :: TypedHole -> Maybe Hole
th_implics :: TypedHole -> [Implication]
th_relevant_cts :: TypedHole -> Cts
..}) TcType
hole_ty TcType
ty = forall a. TcRn a -> TcRn a
discardErrs forall a b. (a -> b) -> a -> b
$
  do { -- We wrap the subtype constraint in the implications to pass along the
       -- givens, and so we must ensure that any nested implications and skolems
       -- end up with the correct level. The implications are ordered so that
       -- the innermost (the one with the highest level) is first, so it
       -- suffices to get the level of the first one (or the current level, if
       -- there are no implications involved).
       TcLevel
innermost_lvl <- case [Implication]
th_implics of
                          [] -> IOEnv (Env TcGblEnv TcLclEnv) TcLevel
getTcLevel
                          -- imp is the innermost implication
                          (Implication
imp:[Implication]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Implication -> TcLevel
ic_tclvl Implication
imp)
     ; (HsWrapper
wrap, WantedConstraints
wanted) <- forall a. TcLevel -> TcM a -> TcM a
setTcLevel TcLevel
innermost_lvl forall a b. (a -> b) -> a -> b
$ forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints forall a b. (a -> b) -> a -> b
$
                         CtOrigin -> UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
tcSubTypeSigma CtOrigin
orig UserTypeCtxt
ExprSigCtxt TcType
ty TcType
hole_ty
     ; String -> SDoc -> TcRn ()
traceTc String
"Checking hole fit {" SDoc
empty
     ; String -> SDoc -> TcRn ()
traceTc String
"wanteds are: " forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanted
     ; if WantedConstraints -> Bool
isEmptyWC WantedConstraints
wanted Bool -> Bool -> Bool
&& forall a. Bag a -> Bool
isEmptyBag Cts
th_relevant_cts
       then do { String -> SDoc -> TcRn ()
traceTc String
"}" SDoc
empty
               ; forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, HsWrapper
wrap) }
       else do { EvBindsVar
fresh_binds <- TcM EvBindsVar
newTcEvBinds
                -- The relevant constraints may contain HoleDests, so we must
                -- take care to clone them as well (to avoid #15370).
               ; Cts
cloned_relevants <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM Ct -> TcM Ct
cloneWanted Cts
th_relevant_cts
                 -- We wrap the WC in the nested implications, see
                 -- Note [Checking hole fits]
               ; let outermost_first :: [Implication]
outermost_first = forall a. [a] -> [a]
reverse [Implication]
th_implics
                    -- We add the cloned relevants to the wanteds generated by
                    -- the call to tcSubType_NC, see Note [Relevant constraints]
                    -- There's no need to clone the wanteds, because they are
                    -- freshly generated by `tcSubtype_NC`.
                     w_rel_cts :: WantedConstraints
w_rel_cts = WantedConstraints -> Cts -> WantedConstraints
addSimples WantedConstraints
wanted Cts
cloned_relevants
                     final_wc :: WantedConstraints
final_wc  = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (EvBindsVar -> Implication -> WantedConstraints -> WantedConstraints
setWCAndBinds EvBindsVar
fresh_binds) WantedConstraints
w_rel_cts [Implication]
outermost_first
               ; String -> SDoc -> TcRn ()
traceTc String
"final_wc is: " forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr WantedConstraints
final_wc
               ; WantedConstraints
rem <- forall a. TcS a -> TcM a
runTcSDeriveds forall a b. (a -> b) -> a -> b
$ WantedConstraints -> TcS WantedConstraints
simplifyTopWanteds WantedConstraints
final_wc
               -- We don't want any insoluble or simple constraints left, but
               -- solved implications are ok (and necessary for e.g. undefined)
               ; String -> SDoc -> TcRn ()
traceTc String
"rems was:" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr WantedConstraints
rem
               ; String -> SDoc -> TcRn ()
traceTc String
"}" SDoc
empty
               ; forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints -> Bool
isSolvedWC WantedConstraints
rem, HsWrapper
wrap) } }
     where
       orig :: CtOrigin
orig = Maybe OccName -> CtOrigin
ExprHoleOrigin (Hole -> OccName
hole_occ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Hole
th_hole)
       setWCAndBinds :: EvBindsVar         -- Fresh ev binds var.
                     -> Implication        -- The implication to put WC in.
                     -> WantedConstraints  -- The WC constraints to put implic.
                     -> WantedConstraints  -- The new constraints.
       setWCAndBinds :: EvBindsVar -> Implication -> WantedConstraints -> WantedConstraints
setWCAndBinds EvBindsVar
binds Implication
imp WantedConstraints
wc
         = Bag Implication -> WantedConstraints
mkImplicWC forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ Implication
imp { ic_wanted :: WantedConstraints
ic_wanted = WantedConstraints
wc , ic_binds :: EvBindsVar
ic_binds = EvBindsVar
binds }