TcBinds.hs

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

\section[TcBinds]{TcBinds}
-}

{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds,
                 tcHsBootSigs, tcPolyCheck,
                 chooseInferredQuantifiers,
                 badBootDeclErr ) where

import GhcPrelude

import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
import CoreSyn (Tickish (..))
import CostCentre (mkUserCC, CCFlavour(DeclCC))
import DynFlags
import FastString
import GHC.Hs
import TcSigs
import TcRnMonad
import TcOrigin
import TcEnv
import TcUnify
import TcSimplify
import TcEvidence
import TcHsType
import TcPat
import TcMType
import FamInstEnv( normaliseType )
import FamInst( tcGetFamInstEnvs )
import TyCon
import TcType
import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)
import TysPrim
import TysWiredIn( mkBoxedTupleTy )
import Id
import Var
import VarSet
import VarEnv( TidyEnv )
import Module
import Name
import NameSet
import NameEnv
import SrcLoc
import Bag
import ErrUtils
import Digraph
import Maybes
import Util
import BasicTypes
import Outputable
import PrelNames( ipClassName )
import TcValidity (checkValidType)
import UniqFM
import UniqSet
import qualified GHC.LanguageExtensions as LangExt
import ConLike

import Control.Monad
import Data.Foldable (find)

#include "HsVersions.h"

{-
************************************************************************
*                                                                      *
\subsection{Type-checking bindings}
*                                                                      *
************************************************************************

@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
it needs to know something about the {\em usage} of the things bound,
so that it can create specialisations of them.  So @tcBindsAndThen@
takes a function which, given an extended environment, E, typechecks
the scope of the bindings returning a typechecked thing and (most
important) an LIE.  It is this LIE which is then used as the basis for
specialising the things bound.

@tcBindsAndThen@ also takes a "combiner" which glues together the
bindings and the "thing" to make a new "thing".

The real work is done by @tcBindWithSigsAndThen@.

Recursive and non-recursive binds are handled in essentially the same
way: because of uniques there are no scoping issues left.  The only
difference is that non-recursive bindings can bind primitive values.

Even for non-recursive binding groups we add typings for each binder
to the LVE for the following reason.  When each individual binding is
checked the type of its LHS is unified with that of its RHS; and
type-checking the LHS of course requires that the binder is in scope.

At the top-level the LIE is sure to contain nothing but constant
dictionaries, which we resolve at the module level.

Note [Polymorphic recursion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The game plan for polymorphic recursion in the code above is

        * Bind any variable for which we have a type signature
          to an Id with a polymorphic type.  Then when type-checking
          the RHSs we'll make a full polymorphic call.

This fine, but if you aren't a bit careful you end up with a horrendous
amount of partial application and (worse) a huge space leak. For example:

        f :: Eq a => [a] -> [a]
        f xs = ...f...

If we don't take care, after typechecking we get

        f = /\a -> \d::Eq a -> let f' = f a d
                               in
                               \ys:[a] -> ...f'...

Notice the stupid construction of (f a d), which is of course
identical to the function we're executing.  In this case, the
polymorphic recursion isn't being used (but that's a very common case).
This can lead to a massive space leak, from the following top-level defn
(post-typechecking)

        ff :: [Int] -> [Int]
        ff = f Int dEqInt

Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
f' is another thunk which evaluates to the same thing... and you end
up with a chain of identical values all hung onto by the CAF ff.

        ff = f Int dEqInt

           = let f' = f Int dEqInt in \ys. ...f'...

           = let f' = let f' = f Int dEqInt in \ys. ...f'...
                      in \ys. ...f'...

Etc.

NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
which would make the space leak go away in this case

Solution: when typechecking the RHSs we always have in hand the
*monomorphic* Ids for each binding.  So we just need to make sure that
if (Method f a d) shows up in the constraints emerging from (...f...)
we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
to the "givens" when simplifying constraints.  That's what the "lies_avail"
is doing.

Then we get

        f = /\a -> \d::Eq a -> letrec
                                 fm = \ys:[a] -> ...fm...
                               in
                               fm
-}

tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
           -> TcM (TcGblEnv, TcLclEnv)
-- The TcGblEnv contains the new tcg_binds and tcg_spects
-- The TcLclEnv has an extended type envt for the new bindings
tcTopBinds binds sigs
  = do  { -- Pattern synonym bindings populate the global environment
          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
            do { gbl <- getGblEnv
               ; lcl <- getLclEnv
               ; return (gbl, lcl) }
        ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids

        ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs
        ; traceTc "complete_matches" (ppr binds $$ ppr sigs)
        ; traceTc "complete_matches" (ppr complete_matches)

        ; let { tcg_env' = tcg_env { tcg_imp_specs
                                      = specs ++ tcg_imp_specs tcg_env
                                   , tcg_complete_matches
                                      = complete_matches
                                          ++ tcg_complete_matches tcg_env }
                           `addTypecheckedBinds` map snd binds' }

        ; return (tcg_env', tcl_env) }
        -- The top level bindings are flattened into a giant
        -- implicitly-mutually-recursive LHsBinds


-- Note [Typechecking Complete Matches]
-- Much like when a user bundled a pattern synonym, the result types of
-- all the constructors in the match pragma must be consistent.
--
-- If we allowed pragmas with inconsistent types then it would be
-- impossible to ever match every constructor in the list and so
-- the pragma would be useless.





-- This is only used in `tcCompleteSig`. We fold over all the conlikes,
-- this accumulator keeps track of the first `ConLike` with a concrete
-- return type. After fixing the return type, all other constructors with
-- a fixed return type must agree with this.
--
-- The fields of `Fixed` cache the first conlike and its return type so
-- that that we can compare all the other conlikes to it. The conlike is
-- stored for error messages.
--
-- `Nothing` in the case that the type is fixed by a type signature
data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon

tcCompleteSigs  :: [LSig GhcRn] -> TcM [CompleteMatch]
tcCompleteSigs sigs =
  let
      doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch)
      doOne c@(CompleteMatchSig _ _ lns mtc)
        = fmap Just $ do
           addErrCtxt (text "In" <+> ppr c) $
            case mtc of
              Nothing -> infer_complete_match
              Just tc -> check_complete_match tc
        where

          checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns)

          infer_complete_match = do
            (res, cls) <- checkCLTypes AcceptAny
            case res of
              AcceptAny -> failWithTc ambiguousError
              Fixed _ tc  -> return $ mkMatch cls tc

          check_complete_match tc_name = do
            ty_con <- tcLookupLocatedTyCon tc_name
            (_, cls) <- checkCLTypes (Fixed Nothing ty_con)
            return $ mkMatch cls ty_con

          mkMatch :: [ConLike] -> TyCon -> CompleteMatch
          mkMatch cls ty_con = CompleteMatch {
            -- foldM is a left-fold and will have accumulated the ConLikes in
            -- the reverse order. foldrM would accumulate in the correct order,
            -- but would type-check the last ConLike first, which might also be
            -- confusing from the user's perspective. Hence reverse here.
            completeMatchConLikes = reverse (map conLikeName cls),
            completeMatchTyCon = tyConName ty_con
            }
      doOne _ = return Nothing

      ambiguousError :: SDoc
      ambiguousError =
        text "A type signature must be provided for a set of polymorphic"
          <+> text "pattern synonyms."


      -- See note [Typechecking Complete Matches]
      checkCLType :: (CompleteSigType, [ConLike]) -> Located Name
                  -> TcM (CompleteSigType, [ConLike])
      checkCLType (cst, cs) n = do
        cl <- addLocM tcLookupConLike n
        let   (_,_,_,_,_,_, res_ty) = conLikeFullSig cl
              res_ty_con = fst <$> splitTyConApp_maybe res_ty
        case (cst, res_ty_con) of
          (AcceptAny, Nothing) -> return (AcceptAny, cl:cs)
          (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs)
          (Fixed mfcl tc, Nothing)  -> return (Fixed mfcl tc, cl:cs)
          (Fixed mfcl tc, Just tc') ->
            if tc == tc'
              then return (Fixed mfcl tc, cl:cs)
              else case mfcl of
                     Nothing ->
                      addErrCtxt (text "In" <+> ppr cl) $
                        failWithTc typeSigErrMsg
                     Just cl -> failWithTc (errMsg cl)
             where
              typeSigErrMsg :: SDoc
              typeSigErrMsg =
                text "Couldn't match expected type"
                      <+> quotes (ppr tc)
                      <+> text "with"
                      <+> quotes (ppr tc')

              errMsg :: ConLike -> SDoc
              errMsg fcl =
                text "Cannot form a group of complete patterns from patterns"
                  <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl)
                  <+> text "as they match different type constructors"
                  <+> parens (quotes (ppr tc)
                               <+> text "resp."
                               <+> quotes (ppr tc'))
  -- For some reason I haven't investigated further, the signatures come in
  -- backwards wrt. declaration order. So we reverse them here, because it makes
  -- a difference for incomplete match suggestions.
  in  mapMaybeM (addLocM doOne) (reverse sigs) -- process in declaration order

tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
-- A hs-boot file has only one BindGroup, and it only has type
-- signatures in it.  The renamer checked all this
tcHsBootSigs binds sigs
  = do  { checkTc (null binds) badBootDeclErr
        ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
  where
    tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
      where
        f (dL->L _ name)
          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty
               ; return (mkVanillaGlobal name sigma_ty) }
        -- Notice that we make GlobalIds, not LocalIds
    tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)

badBootDeclErr :: MsgDoc
badBootDeclErr = text "Illegal declarations in an hs-boot file"

------------------------
tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing
             -> TcM (HsLocalBinds GhcTcId, thing)

tcLocalBinds (EmptyLocalBinds x) thing_inside
  = do  { thing <- thing_inside
        ; return (EmptyLocalBinds x, thing) }

tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
  = do  { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
        ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"

tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
  = do  { ipClass <- tcLookupClass ipClassName
        ; (given_ips, ip_binds') <-
            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds

        -- If the binding binds ?x = E, we  must now
        -- discharge any ?x constraints in expr_lie
        -- See Note [Implicit parameter untouchables]
        ; (ev_binds, result) <- checkConstraints (IPSkol ips)
                                  [] given_ips thing_inside

        ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }
  where
    ips = [ip | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds]

        -- I wonder if we should do these one at a time
        -- Consider     ?x = 4
        --              ?y = ?x + 1
    tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr)
       = do { ty <- newOpenFlexiTyVarTy
            ; let p = mkStrLitTy $ hsIPNameFS ip
            ; ip_id <- newDict ipClass [ p, ty ]
            ; expr' <- tcMonoExpr expr (mkCheckExpType ty)
            ; let d = toDict ipClass p ty `fmap` expr'
            ; return (ip_id, (IPBind noExtField (Right ip_id) d)) }
    tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"
    tc_ip_bind _ (XIPBind nec) = noExtCon nec

    -- Coerces a `t` into a dictionry for `IP "x" t`.
    -- co : t -> IP "x" t
    toDict ipClass x ty = mkHsWrap $ mkWpCastR $
                          wrapIP $ mkClassPred ipClass [x,ty]

tcLocalBinds (HsIPBinds _ (XHsIPBinds nec)) _ = noExtCon nec
tcLocalBinds (XHsLocalBindsLR nec)          _ = noExtCon nec

{- Note [Implicit parameter untouchables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We add the type variables in the types of the implicit parameters
as untouchables, not so much because we really must not unify them,
but rather because we otherwise end up with constraints like this
    Num alpha, Implic { wanted = alpha ~ Int }
The constraint solver solves alpha~Int by unification, but then
doesn't float that solved constraint out (it's not an unsolved
wanted).  Result disaster: the (Num alpha) is again solved, this
time by defaulting.  No no no.

However [Oct 10] this is all handled automatically by the
untouchable-range idea.
-}

tcValBinds :: TopLevelFlag
           -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
           -> TcM thing
           -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)

tcValBinds top_lvl binds sigs thing_inside
  = do  {   -- Typecheck the signatures
            -- It's easier to do so now, once for all the SCCs together
            -- because a single signature  f,g :: <type>
            -- might relate to more than one SCC
        ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
                                tcTySigs sigs

                -- Extend the envt right away with all the Ids
                -- declared with complete type signatures
                -- Do not extend the TcBinderStack; instead
                -- we extend it on a per-rhs basis in tcExtendForRhs
        ; tcExtendSigIds top_lvl poly_ids $ do
            { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
                   { thing <- thing_inside
                     -- See Note [Pattern synonym builders don't yield dependencies]
                     --     in RnBinds
                   ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
                   ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
                   ; return (extra_binds, thing) }
            ; return (binds' ++ extra_binds', thing) }}
  where
    patsyns = getPatSynBinds binds
    prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)

------------------------
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
             -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
             -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
-- Here a "strongly connected component" has the strightforward
-- meaning of a group of bindings that mention each other,
-- ignoring type signatures (that part comes later)

tcBindGroups _ _ _ [] thing_inside
  = do  { thing <- thing_inside
        ; return ([], thing) }

tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
  = do  { -- See Note [Closed binder groups]
          type_env <- getLclTypeEnv
        ; let closed = isClosedBndrGroup type_env (snd group)
        ; (group', (groups', thing))
                <- tc_group top_lvl sig_fn prag_fn group closed $
                   tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
        ; return (group' ++ groups', thing) }

-- Note [Closed binder groups]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
--  A mutually recursive group is "closed" if all of the free variables of
--  the bindings are closed. For example
--
-- >  h = \x -> let f = ...g...
-- >                g = ....f...x...
-- >             in ...
--
-- Here @g@ is not closed because it mentions @x@; and hence neither is @f@
-- closed.
--
-- So we need to compute closed-ness on each strongly connected components,
-- before we sub-divide it based on what type signatures it has.
--

------------------------
tc_group :: forall thing.
            TopLevelFlag -> TcSigFun -> TcPragEnv
         -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing
         -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)

-- Typecheck one strongly-connected component of the original program.
-- We get a list of groups back, because there may
-- be specialisations etc as well

tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside
        -- A single non-recursive binding
        -- We want to keep non-recursive things non-recursive
        -- so that we desugar unlifted bindings correctly
  = do { let bind = case bagToList binds of
                 [bind] -> bind
                 []     -> panic "tc_group: empty list of binds"
                 _      -> panic "tc_group: NonRecursive binds is not a singleton bag"
       ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
                                     thing_inside
       ; return ( [(NonRecursive, bind')], thing) }

tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
  =     -- To maximise polymorphism, we do a new
        -- strongly-connected-component analysis, this time omitting
        -- any references to variables with type signatures.
        -- (This used to be optional, but isn't now.)
        -- See Note [Polymorphic recursion] in HsBinds.
    do  { traceTc "tc_group rec" (pprLHsBinds binds)
        ; whenIsJust mbFirstPatSyn $ \lpat_syn ->
            recursivePatSynErr (getLoc lpat_syn) binds
        ; (binds1, thing) <- go sccs
        ; return ([(Recursive, binds1)], thing) }
                -- Rec them all together
  where
    mbFirstPatSyn = find (isPatSyn . unLoc) binds
    isPatSyn PatSynBind{} = True
    isPatSyn _ = False

    sccs :: [SCC (LHsBind GhcRn)]
    sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)

    go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing)
    go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc
                        ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn
                                                            closed ids1 $
                                             go sccs
                        ; return (binds1 `unionBags` binds2, thing) }
    go []         = do  { thing <- thing_inside; return (emptyBag, thing) }

    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds

    tc_sub_group rec_tc binds =
      tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds

recursivePatSynErr ::
     OutputableBndrId p =>
     SrcSpan -- ^ The location of the first pattern synonym binding
             --   (for error reporting)
  -> LHsBinds (GhcPass p)
  -> TcM a
recursivePatSynErr loc binds
  = failAt loc $
    hang (text "Recursive pattern synonym definition with following bindings:")
       2 (vcat $ map pprLBind . bagToList $ binds)
  where
    pprLoc loc  = parens (text "defined at" <+> ppr loc)
    pprLBind (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind)
                                <+> pprLoc loc

tc_single :: forall thing.
            TopLevelFlag -> TcSigFun -> TcPragEnv
          -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
          -> TcM (LHsBinds GhcTcId, thing)
tc_single _top_lvl sig_fn _prag_fn
          (dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->L _ name) }))
          _ thing_inside
  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name)
       ; thing <- setGblEnv tcg_env thing_inside
       ; return (aux_binds, thing)
       }

tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
  = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn
                                      NonRecursive NonRecursive
                                      closed
                                      [lbind]
       ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside
       ; return (binds1, thing) }

------------------------
type BKey = Int -- Just number off the bindings

mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
-- See Note [Polymorphic recursion] in HsBinds.
mkEdges sig_fn binds
  = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
                         Just key <- [lookupNameEnv key_map n], no_sig n ]
    | (bind, key) <- keyd_binds
    ]
    -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
    -- is still deterministic even if the edges are in nondeterministic order
    -- as explained in Note [Deterministic SCC] in Digraph.
  where
    bind_fvs (FunBind { fun_ext = fvs }) = fvs
    bind_fvs (PatBind { pat_ext = fvs }) = fvs
    bind_fvs _                           = emptyNameSet

    no_sig :: Name -> Bool
    no_sig n = not (hasCompleteSig sig_fn n)

    keyd_binds = bagToList binds `zip` [0::BKey ..]

    key_map :: NameEnv BKey     -- Which binding it comes from
    key_map = mkNameEnv [(bndr, key) | (dL->L _ bind, key) <- keyd_binds
                                     , bndr <- collectHsBindBinders bind ]

------------------------
tcPolyBinds :: TcSigFun -> TcPragEnv
            -> RecFlag         -- Whether the group is really recursive
            -> RecFlag         -- Whether it's recursive after breaking
                               -- dependencies based on type signatures
            -> IsGroupClosed   -- Whether the group is closed
            -> [LHsBind GhcRn]  -- None are PatSynBind
            -> TcM (LHsBinds GhcTcId, [TcId])

-- Typechecks a single bunch of values bindings all together,
-- and generalises them.  The bunch may be only part of a recursive
-- group, because we use type signatures to maximise polymorphism
--
-- Returns a list because the input may be a single non-recursive binding,
-- in which case the dependency order of the resulting bindings is
-- important.
--
-- Knows nothing about the scope of the bindings
-- None of the bindings are pattern synonyms

tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list
  = setSrcSpan loc                              $
    recoverM (recoveryCode binder_names sig_fn) $ do
        -- Set up main recover; take advantage of any type sigs

    { traceTc "------------------------------------------------" Outputable.empty
    ; traceTc "Bindings for {" (ppr binder_names)
    ; dflags   <- getDynFlags
    ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
    ; traceTc "Generalisation plan" (ppr plan)
    ; result@(_, poly_ids) <- case plan of
         NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
         InferGen mn        -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
         CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind

    ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
                                            , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
                                          ])

    ; return result }
  where
    binder_names = collectHsBindListBinders bind_list
    loc = foldr1 combineSrcSpans (map getLoc bind_list)
         -- The mbinds have been dependency analysed and
         -- may no longer be adjacent; so find the narrowest
         -- span that includes them all

--------------
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise
-- subsequent error messages
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTcId, [Id])
recoveryCode binder_names sig_fn
  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
        ; let poly_ids = map mk_dummy binder_names
        ; return (emptyBag, poly_ids) }
  where
    mk_dummy name
      | Just sig <- sig_fn name
      , Just poly_id <- completeSigPolyId_maybe sig
      = poly_id
      | otherwise
      = mkLocalId name forall_a_a

forall_a_a :: TcType
-- At one point I had (forall r (a :: TYPE r). a), but of course
-- that type is ill-formed: its mentions 'r' which escapes r's scope.
-- Another alternative would be (forall (a :: TYPE kappa). a), where
-- kappa is a unification variable. But I don't think we need that
-- complication here. I'm going to just use (forall (a::*). a).
-- See #15276
forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy

{- *********************************************************************
*                                                                      *
                         tcPolyNoGen
*                                                                      *
********************************************************************* -}

tcPolyNoGen     -- No generalisation whatsoever
  :: RecFlag       -- Whether it's recursive after breaking
                   -- dependencies based on type signatures
  -> TcPragEnv -> TcSigFun
  -> [LHsBind GhcRn]
  -> TcM (LHsBinds GhcTcId, [TcId])

tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
  = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
                                             (LetGblBndr prag_fn)
                                             bind_list
       ; mono_ids' <- mapM tc_mono_info mono_infos
       ; return (binds', mono_ids') }
  where
    tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
      = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name)
           ; return mono_id }
           -- NB: tcPrags generates error messages for
           --     specialisation pragmas for non-overloaded sigs
           -- Indeed that is why we call it here!
           -- So we can safely ignore _specs


{- *********************************************************************
*                                                                      *
                         tcPolyCheck
*                                                                      *
********************************************************************* -}

tcPolyCheck :: TcPragEnv
            -> TcIdSigInfo     -- Must be a complete signature
            -> LHsBind GhcRn   -- Must be a FunBind
            -> TcM (LHsBinds GhcTcId, [TcId])
-- There is just one binding,
--   it is a Funbind
--   it has a complete type signature,
tcPolyCheck prag_fn
            (CompleteSig { sig_bndr  = poly_id
                         , sig_ctxt  = ctxt
                         , sig_loc   = sig_loc })
            (dL->L loc (FunBind { fun_id = (dL->L nm_loc name)
                                , fun_matches = matches }))
  = setSrcSpan sig_loc $
    do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
       ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id
                -- See Note [Instantiate sig with fresh variables]

       ; mono_name <- newNameAt (nameOccName name) nm_loc
       ; ev_vars   <- newEvVars theta
       ; let mono_id   = mkLocalId mono_name tau
             skol_info = SigSkol ctxt (idType poly_id) tv_prs
             skol_tvs  = map snd tv_prs

       ; (ev_binds, (co_fn, matches'))
            <- checkConstraints skol_info skol_tvs ev_vars $
               tcExtendBinderStack [TcIdBndr mono_id NotTopLevel]  $
               tcExtendNameTyVarEnv tv_prs $
               setSrcSpan loc           $
               tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau)

       ; let prag_sigs = lookupPragEnv prag_fn name
       ; spec_prags <- tcSpecPrags poly_id prag_sigs
       ; poly_id    <- addInlinePrags poly_id prag_sigs

       ; mod <- getModule
       ; tick <- funBindTicks nm_loc mono_id mod prag_sigs
       ; let bind' = FunBind { fun_id      = cL nm_loc mono_id
                             , fun_matches = matches'
                             , fun_co_fn   = co_fn
                             , fun_ext     = placeHolderNamesTc
                             , fun_tick    = tick }

             export = ABE { abe_ext   = noExtField
                          , abe_wrap  = idHsWrapper
                          , abe_poly  = poly_id
                          , abe_mono  = mono_id
                          , abe_prags = SpecPrags spec_prags }

             abs_bind = cL loc $
                        AbsBinds { abs_ext      = noExtField
                                 , abs_tvs      = skol_tvs
                                 , abs_ev_vars  = ev_vars
                                 , abs_ev_binds = [ev_binds]
                                 , abs_exports  = [export]
                                 , abs_binds    = unitBag (cL loc bind')
                                 , abs_sig      = True }

       ; return (unitBag abs_bind, [poly_id]) }

tcPolyCheck _prag_fn sig bind
  = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)

funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
             -> TcM [Tickish TcId]
funBindTicks loc fun_id mod sigs
  | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ]
      -- this can only be a singleton list, as duplicate pragmas are rejected
      -- by the renamer
  , let cc_str
          | Just cc_str <- mb_cc_str
          = sl_fs $ unLoc cc_str
          | otherwise
          = getOccFS (Var.varName fun_id)
        cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
  = do
      flavour <- DeclCC <$> getCCIndexM cc_name
      let cc = mkUserCC cc_name mod loc flavour
      return [ProfNote cc True True]
  | otherwise
  = return []

{- Note [Instantiate sig with fresh variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's vital to instantiate a type signature with fresh variables.
For example:
      type T = forall a. [a] -> [a]
      f :: T;
      f = g where { g :: T; g = <rhs> }

 We must not use the same 'a' from the defn of T at both places!!
(Instantiation is only necessary because of type synonyms.  Otherwise,
it's all cool; each signature has distinct type variables from the renamer.)
-}


{- *********************************************************************
*                                                                      *
                         tcPolyInfer
*                                                                      *
********************************************************************* -}

tcPolyInfer
  :: RecFlag       -- Whether it's recursive after breaking
                   -- dependencies based on type signatures
  -> TcPragEnv -> TcSigFun
  -> Bool         -- True <=> apply the monomorphism restriction
  -> [LHsBind GhcRn]
  -> TcM (LHsBinds GhcTcId, [TcId])
tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
  = do { (tclvl, wanted, (binds', mono_infos))
             <- pushLevelAndCaptureConstraints  $
                tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list

       ; let name_taus  = [ (mbi_poly_name info, idType (mbi_mono_id info))
                          | info <- mono_infos ]
             sigs       = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
             infer_mode = if mono then ApplyMR else NoRestrictions

       ; mapM_ (checkOverloadedSig mono) sigs

       ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
       ; (qtvs, givens, ev_binds, residual, insoluble)
                 <- simplifyInfer tclvl infer_mode sigs name_taus wanted
       ; emitConstraints residual

       ; let inferred_theta = map evVarPred givens
       ; exports <- checkNoErrs $
                    mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos

       ; loc <- getSrcSpanM
       ; let poly_ids = map abe_poly exports
             abs_bind = cL loc $
                        AbsBinds { abs_ext = noExtField
                                 , abs_tvs = qtvs
                                 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
                                 , abs_exports = exports, abs_binds = binds'
                                 , abs_sig = False }

       ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
       ; return (unitBag abs_bind, poly_ids) }
         -- poly_ids are guaranteed zonked by mkExport

--------------
mkExport :: TcPragEnv
         -> Bool                        -- True <=> there was an insoluble type error
                                        --          when typechecking the bindings
         -> [TyVar] -> TcThetaType      -- Both already zonked
         -> MonoBindInfo
         -> TcM (ABExport GhcTc)
-- Only called for generalisation plan InferGen, not by CheckGen or NoGen
--
-- mkExport generates exports with
--      zonked type variables,
--      zonked poly_ids