{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}

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

-}

module GHC.Tc.Gen.Bind
   ( tcLocalBinds
   , tcTopBinds
   , tcValBinds
   , tcHsBootSigs
   , tcPolyCheck
   , chooseInferredQuantifiers
   )
where

import GHC.Prelude

import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcFunBindMatches )
import {-# SOURCE #-} GHC.Tc.Gen.Expr  ( tcCheckMonoExpr )
import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind )

import GHC.Types.Tickish (CoreTickish, GenTickish (..))
import GHC.Types.CostCentre (mkUserCC, mkDeclCCFlavour)
import GHC.Driver.DynFlags
import GHC.Data.FastString
import GHC.Hs

import GHC.Rename.Bind ( rejectBootDecls )

import GHC.Tc.Errors.Types
import GHC.Tc.Gen.Sig
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Unify
import GHC.Tc.Solver
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
import GHC.Core.Predicate
import GHC.Core.UsageEnv ( bottomUE )
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
import GHC.Tc.Instance.Family( tcGetFamInstEnvs )
import GHC.Tc.Utils.TcType
import GHC.Tc.Validity (checkValidType, checkEscapingKind)
import GHC.Tc.Zonk.TcType
import GHC.Core.Reduction ( Reduction(..) )
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv( normaliseType )
import GHC.Core.Class   ( Class )
import GHC.Core.Coercion( mkSymCo )
import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy)
import GHC.Core.TyCo.Ppr( pprTyVars )

import GHC.Builtin.Types ( mkConstraintTupleTy, multiplicityTy, oneDataConTy  )
import GHC.Builtin.Types.Prim
import GHC.Unit.Module

import GHC.Types.SourceText
import GHC.Types.Id
import GHC.Types.Var as Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env( TidyEnv, TyVarEnv, mkVarEnv, lookupVarEnv )
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.SourceFile
import GHC.Types.SrcLoc

import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Types.Basic
import GHC.Types.CompleteMatch
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Builtin.Names( ipClassName )
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet
import GHC.Types.Unique.Set
import qualified GHC.LanguageExtensions as LangExt

import GHC.Data.Bag
import GHC.Data.Graph.Directed
import GHC.Data.Maybe

import Control.Monad
import Data.Foldable (find)

{-
************************************************************************
*                                                                      *
\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 analysis 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 :: [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn] -> TcM (TcGblEnv, TcLclEnv)
tcTopBinds [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs
  = do  { -- Pattern synonym bindings populate the global environment
          ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds', HsWrapper
wrap, (TcGblEnv
tcg_env, TcLclEnv
tcl_env)) <- TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM (TcGblEnv, TcLclEnv)
-> TcM
     ([(RecFlag, LHsBinds GhcTc)], HsWrapper, (TcGblEnv, TcLclEnv))
forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)
tcValBinds TopLevelFlag
TopLevel [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs TcM (TcGblEnv, TcLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs
        ; Bool -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (HsWrapper -> Bool
isIdHsWrapper HsWrapper
wrap)
                     (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Non-identity multiplicity wrapper at toplevel:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsWrapper -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWrapper
wrap)
          -- The wrapper (`wrap`) is always the identity because toplevel
          -- binders are unrestricted (and `tcSubmult _ ManyTy` returns the
          -- identity wrapper). Therefore it's safe to drop it altogether.
          --
          -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
        ; [LTcSpecPrag]
specs <- [LSig GhcRn] -> TcM [LTcSpecPrag]
tcImpPrags [LSig GhcRn]
sigs   -- SPECIALISE prags for imported Ids

        ; [CompleteMatch]
complete_matches <- (TcGblEnv, TcLclEnv)
-> TcRn [CompleteMatch] -> TcRn [CompleteMatch]
forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRn [CompleteMatch] -> TcRn [CompleteMatch])
-> TcRn [CompleteMatch] -> TcRn [CompleteMatch]
forall a b. (a -> b) -> a -> b
$ [LSig GhcRn] -> TcRn [CompleteMatch]
tcCompleteSigs [LSig GhcRn]
sigs
        ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"complete_matches" ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))]
binds SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [GenLocated SrcSpanAnnA (Sig GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs)
        ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"complete_matches" ([CompleteMatch] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CompleteMatch]
complete_matches)

        ; let { tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env { tcg_imp_specs
                                      = specs ++ tcg_imp_specs tcg_env
                                   , tcg_complete_matches
                                      = complete_matches
                                          ++ tcg_complete_matches tcg_env }
                           TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
 -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall a b. (a -> b) -> [a] -> [b]
map (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a b. (a, b) -> b
snd [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds' }

        ; (TcGblEnv, TcLclEnv) -> TcM (TcGblEnv, TcLclEnv)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env', TcLclEnv
tcl_env) }
        -- The top level bindings are flattened into a giant
        -- implicitly-mutually-recursive LHsBinds

tcCompleteSigs  :: [LSig GhcRn] -> TcM [CompleteMatch]
tcCompleteSigs :: [LSig GhcRn] -> TcRn [CompleteMatch]
tcCompleteSigs [LSig GhcRn]
sigs =
  let
      doOne :: LSig GhcRn -> TcM (Maybe CompleteMatch)
      -- We don't need to "type-check" COMPLETE signatures anymore; if their
      -- combinations are invalid it will be found so at match sites.
      -- There it is also where we consider if the type of the pattern match is
      -- compatible with the result type constructor 'mb_tc'.
      doOne :: LSig GhcRn -> TcM (Maybe CompleteMatch)
doOne (L SrcSpanAnnA
loc c :: Sig GhcRn
c@(CompleteMatchSig ([AddEpAnn]
_ext, SourceText
_src_txt) [LIdP GhcRn]
ns Maybe (LIdP GhcRn)
mb_tc_nm))
        = (CompleteMatch -> Maybe CompleteMatch)
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> TcM (Maybe CompleteMatch)
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompleteMatch -> Maybe CompleteMatch
forall a. a -> Maybe a
Just (IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
 -> TcM (Maybe CompleteMatch))
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> TcM (Maybe CompleteMatch)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
 -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch)
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a b. (a -> b) -> a -> b
$ SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Sig GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr Sig GhcRn
c) (IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
 -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch)
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a b. (a -> b) -> a -> b
$ do
            UniqDSet ConLike
cls   <- [ConLike] -> UniqDSet ConLike
forall a. Uniquable a => [a] -> UniqDSet a
mkUniqDSet ([ConLike] -> UniqDSet ConLike)
-> IOEnv (Env TcGblEnv TcLclEnv) [ConLike]
-> IOEnv (Env TcGblEnv TcLclEnv) (UniqDSet ConLike)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpanAnnN Name
 -> IOEnv (Env TcGblEnv TcLclEnv) ConLike)
-> [GenLocated SrcSpanAnnN Name]
-> IOEnv (Env TcGblEnv TcLclEnv) [ConLike]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Name -> IOEnv (Env TcGblEnv TcLclEnv) ConLike)
-> GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) ConLike
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Name -> IOEnv (Env TcGblEnv TcLclEnv) ConLike
tcLookupConLike) [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
ns
            Maybe TyCon
mb_tc <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse @Maybe GenLocated SrcSpanAnnN Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcLookupLocatedTyCon Maybe (LIdP GhcRn)
Maybe (GenLocated SrcSpanAnnN Name)
mb_tc_nm
            CompleteMatch -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompleteMatch { cmConLikes :: UniqDSet ConLike
cmConLikes = UniqDSet ConLike
cls, cmResultTyCon :: Maybe TyCon
cmResultTyCon = Maybe TyCon
mb_tc }
      doOne LSig GhcRn
_ = Maybe CompleteMatch -> TcM (Maybe CompleteMatch)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CompleteMatch
forall a. Maybe a
Nothing

  -- 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 (GenLocated SrcSpanAnnA (Sig GhcRn) -> TcM (Maybe CompleteMatch))
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcRn [CompleteMatch]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM LSig GhcRn -> TcM (Maybe CompleteMatch)
GenLocated SrcSpanAnnA (Sig GhcRn) -> TcM (Maybe CompleteMatch)
doOne ([GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcRn [CompleteMatch])
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcRn [CompleteMatch]
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. [a] -> [a]
reverse [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs

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 :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [TcId]
tcHsBootSigs [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs
  = do  { Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))]
binds) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
            HsBootOrSig
-> (NonEmpty (GenLocated SrcSpanAnnA (HsBind GhcRn))
    -> BadBootDecls)
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall decl.
HsBootOrSig
-> (NonEmpty (LocatedA decl) -> BadBootDecls)
-> [LocatedA decl]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
rejectBootDecls HsBootOrSig
HsBoot NonEmpty (LHsBindLR GhcRn GhcRn) -> BadBootDecls
NonEmpty (GenLocated SrcSpanAnnA (HsBind GhcRn)) -> BadBootDecls
BootBindsRn (((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
 -> [GenLocated SrcSpanAnnA (HsBind GhcRn)])
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))]
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall a. Bag a -> [a]
bagToList (Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
 -> [GenLocated SrcSpanAnnA (HsBind GhcRn)])
-> ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
    -> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall a b. (a, b) -> b
snd) [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))]
binds)
        ; (GenLocated SrcSpanAnnA (Sig GhcRn) -> TcM [TcId])
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcM [TcId]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM ((Sig GhcRn -> TcM [TcId])
-> GenLocated SrcSpanAnnA (Sig GhcRn) -> TcM [TcId]
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Sig GhcRn -> TcM [TcId]
tc_boot_sig) ((GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter LSig GhcRn -> Bool
GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool
forall p. UnXRec p => LSig p -> Bool
isTypeLSig [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs) }
  where
    tc_boot_sig :: Sig GhcRn -> TcM [TcId]
tc_boot_sig (TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
lnames LHsSigWcType GhcRn
hs_ty) = (GenLocated SrcSpanAnnN Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId)
-> [GenLocated SrcSpanAnnN Name] -> TcM [TcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnN Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId
f [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
lnames
      where
        f :: GenLocated SrcSpanAnnN Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId
f (L SrcSpanAnnN
_ Name
name)
          = do { Kind
sigma_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Kind
tcHsSigWcType (Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
name ReportRedundantConstraints
NoRRC) LHsSigWcType GhcRn
hs_ty
               ; TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => Name -> Kind -> TcId
Name -> Kind -> TcId
mkVanillaGlobal Name
name Kind
sigma_ty) }
        -- Notice that we make GlobalIds, not LocalIds
    tc_boot_sig Sig GhcRn
s = String -> SDoc -> TcM [TcId]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcHsBootSigs/tc_boot_sig" (Sig GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr Sig GhcRn
s)

------------------------

-- Why an HsWrapper? See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing
             -> TcM (HsLocalBinds GhcTc, HsWrapper, thing)

tcLocalBinds :: forall thing.
HsLocalBinds GhcRn
-> TcM thing -> TcM (HsLocalBinds GhcTc, HsWrapper, thing)
tcLocalBinds (EmptyLocalBinds XEmptyLocalBinds GhcRn GhcRn
x) TcM thing
thing_inside
  = do  { thing
thing <- TcM thing
thing_inside
        ; (HsLocalBinds GhcTc, HsWrapper, thing)
-> TcM (HsLocalBinds GhcTc, HsWrapper, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XEmptyLocalBinds GhcTc GhcTc -> HsLocalBinds GhcTc
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcRn GhcRn
XEmptyLocalBinds GhcTc GhcTc
x, HsWrapper
idHsWrapper, thing
thing) }

tcLocalBinds (HsValBinds XHsValBinds GhcRn GhcRn
x (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs))) TcM thing
thing_inside
  = do  { ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds', HsWrapper
wrapper, thing
thing) <- TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)
forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)
tcValBinds TopLevelFlag
NotTopLevel [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs TcM thing
thing_inside
        ; (HsLocalBinds GhcTc, HsWrapper, thing)
-> TcM (HsLocalBinds GhcTc, HsWrapper, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsValBinds GhcTc GhcTc
-> HsValBindsLR GhcTc GhcTc -> HsLocalBinds GhcTc
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds GhcRn GhcRn
XHsValBinds GhcTc GhcTc
x (XXValBindsLR GhcTc GhcTc -> HsValBindsLR GhcTc GhcTc
forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR ([(RecFlag, LHsBinds GhcTc)] -> [LSig GhcRn] -> NHsValBindsLR GhcTc
forall idL.
[(RecFlag, LHsBinds idL)] -> [LSig GhcRn] -> NHsValBindsLR idL
NValBinds [(RecFlag, LHsBinds GhcTc)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds' [LSig GhcRn]
sigs)), HsWrapper
wrapper, thing
thing) }
tcLocalBinds (HsValBinds XHsValBinds GhcRn GhcRn
_ (ValBinds {})) TcM thing
_ = String -> TcM (HsLocalBinds GhcTc, HsWrapper, thing)
forall a. HasCallStack => String -> a
panic String
"tcLocalBinds"

tcLocalBinds (HsIPBinds XHsIPBinds GhcRn GhcRn
x (IPBinds XIPBinds GhcRn
_ [LIPBind GhcRn]
ip_binds)) TcM thing
thing_inside
  = do  { Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
        ; ([TcId]
given_ips, [GenLocated SrcSpanAnnA (IPBind GhcTc)]
ip_binds') <-
            (GenLocated SrcSpanAnnA (IPBind GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (TcId, GenLocated SrcSpanAnnA (IPBind GhcTc)))
-> [GenLocated SrcSpanAnnA (IPBind GhcRn)]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TcId], [GenLocated SrcSpanAnnA (IPBind GhcTc)])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ((IPBind GhcRn -> TcM (TcId, IPBind GhcTc))
-> GenLocated SrcSpanAnnA (IPBind GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (TcId, GenLocated SrcSpanAnnA (IPBind GhcTc))
forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (b, GenLocated (EpAnn ann) c)
wrapLocSndMA (Class -> IPBind GhcRn -> TcM (TcId, IPBind GhcTc)
tc_ip_bind Class
ipClass)) [LIPBind GhcRn]
[GenLocated SrcSpanAnnA (IPBind GhcRn)]
ip_binds

        -- Add all the IP bindings as givens for the body of the 'let'
        ; (TcEvBinds
ev_binds, thing
result) <- SkolemInfoAnon
-> [TcId] -> [TcId] -> TcM thing -> TcM (TcEvBinds, thing)
forall result.
SkolemInfoAnon
-> [TcId] -> [TcId] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints ([HsIPName] -> SkolemInfoAnon
IPSkol [HsIPName]
ips)
                                  [] [TcId]
given_ips TcM thing
thing_inside

        -- We don't have linear implicit parameters, yet. So the wrapper can be
        -- the identity.
        -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
        ; (HsLocalBinds GhcTc, HsWrapper, thing)
-> TcM (HsLocalBinds GhcTc, HsWrapper, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsIPBinds GhcTc GhcTc -> HsIPBinds GhcTc -> HsLocalBinds GhcTc
forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
HsIPBinds XHsIPBinds GhcRn GhcRn
XHsIPBinds GhcTc GhcTc
x (XIPBinds GhcTc -> [LIPBind GhcTc] -> HsIPBinds GhcTc
forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds XIPBinds GhcTc
TcEvBinds
ev_binds [LIPBind GhcTc]
[GenLocated SrcSpanAnnA (IPBind GhcTc)]
ip_binds') , HsWrapper
idHsWrapper, thing
result) }
  where
    ips :: [HsIPName]
ips = [HsIPName
ip | (L SrcSpanAnnA
_ (IPBind XCIPBind GhcRn
_ (L EpAnnCO
_ HsIPName
ip) LHsExpr GhcRn
_)) <- [LIPBind GhcRn]
[GenLocated SrcSpanAnnA (IPBind GhcRn)]
ip_binds]

        -- I wonder if we should do these one at a time
        -- Consider     ?x = 4
        --              ?y = ?x + 1
    tc_ip_bind :: Class -> IPBind GhcRn -> TcM (DictId, IPBind GhcTc)
    tc_ip_bind :: Class -> IPBind GhcRn -> TcM (TcId, IPBind GhcTc)
tc_ip_bind Class
ipClass (IPBind XCIPBind GhcRn
_ l_name :: XRec GhcRn HsIPName
l_name@(L EpAnnCO
_ HsIPName
ip) LHsExpr GhcRn
expr)
       = do { Kind
ty <- Kind -> TcM Kind
newFlexiTyVarTy Kind
liftedTypeKind  -- see #24298
            ; let p :: Kind
p = FastString -> Kind
mkStrLitTy (FastString -> Kind) -> FastString -> Kind
forall a b. (a -> b) -> a -> b
$ HsIPName -> FastString
hsIPNameFS HsIPName
ip
            ; TcId
ip_id <- Class -> TcThetaType -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newDict Class
ipClass [ Kind
p, Kind
ty ]
            ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- LHsExpr GhcRn -> Kind -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr LHsExpr GhcRn
expr Kind
ty
            ; let d :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
d = (HsExpr GhcTc -> HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Class -> Kind -> Kind -> HsExpr GhcTc -> HsExpr GhcTc
toDict Class
ipClass Kind
p Kind
ty) GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr'
            ; (TcId, IPBind GhcTc) -> TcM (TcId, IPBind GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcId
ip_id, (XCIPBind GhcTc
-> XRec GhcTc HsIPName -> LHsExpr GhcTc -> IPBind GhcTc
forall id.
XCIPBind id -> XRec id HsIPName -> LHsExpr id -> IPBind id
IPBind XCIPBind GhcTc
TcId
ip_id XRec GhcRn HsIPName
XRec GhcTc HsIPName
l_name LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
d)) }

    -- Coerces a `t` into a dictionary for `IP "x" t`.
    -- co : t -> IP "x" t
    toDict :: Class  -- IP class
           -> Type   -- type-level string for name of IP
           -> Type   -- type of IP
           -> HsExpr GhcTc   -- def'n of IP variable
           -> HsExpr GhcTc   -- dictionary for IP
    toDict :: Class -> Kind -> Kind -> HsExpr GhcTc -> HsExpr GhcTc
toDict Class
ipClass Kind
x Kind
ty = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc)
-> HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$
                          Kind -> TcCoercionR
wrapIP (Kind -> TcCoercionR) -> Kind -> TcCoercionR
forall a b. (a -> b) -> a -> b
$ Class -> TcThetaType -> Kind
mkClassPred Class
ipClass [Kind
x,Kind
ty]

-- Why an HsWrapper? See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
tcValBinds :: TopLevelFlag
           -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
           -> TcM thing
           -> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)

tcValBinds :: forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)
tcValBinds TopLevelFlag
top_lvl [(RecFlag, LHsBinds GhcRn)]
binds [LSig GhcRn]
sigs TcM thing
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
          ([TcId]
poly_ids, TcSigFun
sig_fn) <- [PatSynBind GhcRn GhcRn]
-> TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall a. [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
tcAddPatSynPlaceholders [PatSynBind GhcRn GhcRn]
patsyns (TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun))
-> TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall a b. (a -> b) -> a -> b
$
                                [LSig GhcRn] -> TcM ([TcId], TcSigFun)
tcTySigs [LSig GhcRn]
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
        --   See Note [Relevant bindings and the binder stack]
        --
        -- For the moment, let bindings and top-level bindings introduce
        -- only unrestricted variables.
        ; TopLevelFlag
-> [TcId]
-> TcM
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      HsWrapper, thing)
-> TcM
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      HsWrapper, thing)
forall a. TopLevelFlag -> [TcId] -> TcM a -> TcM a
tcExtendSigIds TopLevelFlag
top_lvl [TcId]
poly_ids (TcM
   ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
    HsWrapper, thing)
 -> TcM
      ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
       HsWrapper, thing))
-> TcM
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      HsWrapper, thing)
-> TcM
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      HsWrapper, thing)
forall a b. (a -> b) -> a -> b
$
     do { ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds', HsWrapper
wrapper, ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
extra_binds', thing
thing))
              <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      thing)
-> TcM
     ([(RecFlag, LHsBinds GhcTc)], HsWrapper,
      ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
       thing))
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)
tcBindGroups TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn [(RecFlag, LHsBinds GhcRn)]
binds (TcM
   ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
    thing)
 -> TcM
      ([(RecFlag, LHsBinds GhcTc)], HsWrapper,
       ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
        thing)))
-> TcM
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      thing)
-> TcM
     ([(RecFlag, LHsBinds GhcTc)], HsWrapper,
      ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
       thing))
forall a b. (a -> b) -> a -> b
$
                 do { thing
thing <- TcM thing
thing_inside
                       -- See Note [Pattern synonym builders don't yield dependencies]
                       --     in GHC.Rename.Bind
                    ; [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
patsyn_builders <- (PatSynBind GhcRn GhcRn
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))))
-> [PatSynBind GhcRn GhcRn]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TcPragEnv -> PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
tcPatSynBuilderBind TcPragEnv
prag_fn) [PatSynBind GhcRn GhcRn]
patsyns
                    ; let extra_binds :: [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
extra_binds = [ (RecFlag
NonRecursive, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
builder)
                                        | Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
builder <- [Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))]
patsyn_builders ]
                    ; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
 thing)
-> TcM
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
extra_binds, thing
thing) }
        ; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
 HsWrapper, thing)
-> TcM
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      HsWrapper, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
binds' [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
extra_binds', HsWrapper
wrapper, thing
thing) }}
  where
    patsyns :: [PatSynBind GhcRn GhcRn]
patsyns = [(RecFlag, LHsBinds GhcRn)] -> [PatSynBind GhcRn GhcRn]
forall id.
UnXRec id =>
[(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds [(RecFlag, LHsBinds GhcRn)]
binds
    prag_fn :: TcPragEnv
prag_fn = [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
mkPragEnv [LSig GhcRn]
sigs (((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
 -> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
 -> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))]
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall a. Bag a -> Bag a -> Bag a
unionBags (Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
 -> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
 -> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
    -> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall a b. (a, b) -> b
snd) Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall a. Bag a
emptyBag [(RecFlag, LHsBinds GhcRn)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))]
binds)

------------------------

-- Why an HsWrapper? See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
             -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
             -> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
-- Here a "strongly connected component" has the straightforward
-- meaning of a group of bindings that mention each other,
-- ignoring type signatures (that part comes later)

tcBindGroups :: forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)
tcBindGroups TopLevelFlag
_ TcSigFun
_ TcPragEnv
_ [] TcM thing
thing_inside
  = do  { thing
thing <- TcM thing
thing_inside
        ; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
 HsWrapper, thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      HsWrapper, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], HsWrapper
idHsWrapper, thing
thing) }

tcBindGroups TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn ((RecFlag, LHsBinds GhcRn)
group : [(RecFlag, LHsBinds GhcRn)]
groups) TcM thing
thing_inside
  = do  { -- See Note [Closed binder groups]
          TcTypeEnv
type_env <- TcM TcTypeEnv
getLclTypeEnv
        ; let closed :: IsGroupClosed
closed = TcTypeEnv -> LHsBinds GhcRn -> IsGroupClosed
isClosedBndrGroup TcTypeEnv
type_env ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall a b. (a, b) -> b
snd (RecFlag, LHsBinds GhcRn)
(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)))
group)
        ; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
group', HsWrapper
outer_wrapper, ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
groups', HsWrapper
inner_wrapper, thing
thing))
                <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> (RecFlag, LHsBinds GhcRn)
-> IsGroupClosed
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      HsWrapper, thing)
-> TcM
     ([(RecFlag, LHsBinds GhcTc)], HsWrapper,
      ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
       HsWrapper, thing))
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> (RecFlag, LHsBinds GhcRn)
-> IsGroupClosed
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)
tc_group TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn (RecFlag, LHsBinds GhcRn)
group IsGroupClosed
closed (IOEnv
   (Env TcGblEnv TcLclEnv)
   ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
    HsWrapper, thing)
 -> TcM
      ([(RecFlag, LHsBinds GhcTc)], HsWrapper,
       ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
        HsWrapper, thing)))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      HsWrapper, thing)
-> TcM
     ([(RecFlag, LHsBinds GhcTc)], HsWrapper,
      ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
       HsWrapper, thing))
forall a b. (a -> b) -> a -> b
$
                   TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds GhcRn)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)
tcBindGroups TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn [(RecFlag, LHsBinds GhcRn)]
groups TcM thing
thing_inside
        ; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
 HsWrapper, thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      HsWrapper, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
group' [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
groups', HsWrapper
outer_wrapper HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inner_wrapper, thing
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 GhcTc)], HsWrapper, 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 :: forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> (RecFlag, LHsBinds GhcRn)
-> IsGroupClosed
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], HsWrapper, thing)
tc_group TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn (RecFlag
NonRecursive, LHsBinds GhcRn
binds) IsGroupClosed
closed TcM thing
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 :: GenLocated SrcSpanAnnA (HsBind GhcRn)
bind = case Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
binds of
                 [GenLocated SrcSpanAnnA (HsBind GhcRn)
bind] -> GenLocated SrcSpanAnnA (HsBind GhcRn)
bind
                 []     -> String -> GenLocated SrcSpanAnnA (HsBind GhcRn)
forall a. HasCallStack => String -> a
panic String
"tc_group: empty list of binds"
                 [GenLocated SrcSpanAnnA (HsBind GhcRn)]
_      -> String -> GenLocated SrcSpanAnnA (HsBind GhcRn)
forall a. HasCallStack => String -> a
panic String
"tc_group: NonRecursive binds is not a singleton bag"
       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bind', HsWrapper
wrapper, thing
thing) <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> LHsBindLR GhcRn GhcRn
-> IsGroupClosed
-> TcM thing
-> TcM (LHsBinds GhcTc, HsWrapper, thing)
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> LHsBindLR GhcRn GhcRn
-> IsGroupClosed
-> TcM thing
-> TcM (LHsBinds GhcTc, HsWrapper, thing)
tc_single TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn LHsBindLR GhcRn GhcRn
GenLocated SrcSpanAnnA (HsBind GhcRn)
bind IsGroupClosed
closed
                                     TcM thing
thing_inside
       ; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
 HsWrapper, thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      HsWrapper, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [(RecFlag
NonRecursive, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bind')], HsWrapper
wrapper, thing
thing) }

tc_group TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn (RecFlag
Recursive, LHsBinds GhcRn
binds) IsGroupClosed
closed TcM thing
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 "GHC.Hs.Binds".
    do  { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tc_group rec" (LHsBinds GhcRn -> SDoc
forall (idL :: Pass) (idR :: Pass).
(OutputableBndrId idL, OutputableBndrId idR) =>
LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds LHsBinds GhcRn
binds)
        ; Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> (GenLocated SrcSpanAnnA (HsBind GhcRn)
    -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn))
mbFirstPatSyn ((GenLocated SrcSpanAnnA (HsBind GhcRn)
  -> IOEnv (Env TcGblEnv TcLclEnv) ())
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (GenLocated SrcSpanAnnA (HsBind GhcRn)
    -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnA (HsBind GhcRn)
lpat_syn ->
            SrcSpan -> LHsBinds GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. SrcSpan -> LHsBinds GhcRn -> TcM a
recursivePatSynErr (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA (SrcSpanAnnA -> SrcSpan) -> SrcSpanAnnA -> SrcSpan
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsBind GhcRn) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpanAnnA (HsBind GhcRn)
lpat_syn) LHsBinds GhcRn
binds
        ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1, HsWrapper
wrapper, thing
thing) <- [SCC (LHsBindLR GhcRn GhcRn)]
-> TcM (LHsBinds GhcTc, HsWrapper, thing)
go [SCC (LHsBindLR GhcRn GhcRn)]
sccs
        ; ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
 HsWrapper, thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))],
      HsWrapper, thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag
Recursive, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1)], HsWrapper
wrapper, thing
thing) }
                -- Rec them all together
  where
    mbFirstPatSyn :: Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn))
mbFirstPatSyn = (GenLocated SrcSpanAnnA (HsBind GhcRn) -> Bool)
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (HsBind GhcRn -> Bool
forall {idL} {idR}. HsBindLR idL idR -> Bool
isPatSyn (HsBind GhcRn -> Bool)
-> (GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn)
-> GenLocated SrcSpanAnnA (HsBind GhcRn)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
binds
    isPatSyn :: HsBindLR idL idR -> Bool
isPatSyn PatSynBind{} = Bool
True
    isPatSyn HsBindLR idL idR
_ = Bool
False

    sccs :: [SCC (LHsBind GhcRn)]
    sccs :: [SCC (LHsBindLR GhcRn GhcRn)]
sccs = [Node BKey (GenLocated SrcSpanAnnA (HsBind GhcRn))]
-> [SCC (GenLocated SrcSpanAnnA (HsBind GhcRn))]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq (TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBindLR GhcRn GhcRn)]
mkEdges TcSigFun
sig_fn LHsBinds GhcRn
binds)

    go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, HsWrapper, thing)
    go :: [SCC (LHsBindLR GhcRn GhcRn)]
-> TcM (LHsBinds GhcTc, HsWrapper, thing)
go (SCC (LHsBindLR GhcRn GhcRn)
scc:[SCC (LHsBindLR GhcRn GhcRn)]
sccs) = do  { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1, [Scaled TcId]
ids1) <- SCC (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tc_scc SCC (LHsBindLR GhcRn GhcRn)
SCC (GenLocated SrcSpanAnnA (HsBind GhcRn))
scc
                         -- recursive bindings must be unrestricted
                         -- (the ids added to the environment here are the name of the recursive definitions).
                        ; ((Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds2, HsWrapper
inner_wrapper, thing
thing), HsWrapper
outer_wrapper) <-
                              TopLevelFlag
-> TcSigFun
-> IsGroupClosed
-> [Scaled TcId]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), HsWrapper,
      thing)
-> TcM
     ((Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), HsWrapper,
       thing),
      HsWrapper)
forall a.
TopLevelFlag
-> TcSigFun
-> IsGroupClosed
-> [Scaled TcId]
-> TcM a
-> TcM (a, HsWrapper)
tcExtendLetEnv TopLevelFlag
top_lvl TcSigFun
sig_fn IsGroupClosed
closed [Scaled TcId]
ids1
                              ([SCC (LHsBindLR GhcRn GhcRn)]
-> TcM (LHsBinds GhcTc, HsWrapper, thing)
go [SCC (LHsBindLR GhcRn GhcRn)]
sccs)
                        ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), HsWrapper,
 thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), HsWrapper,
      thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1 Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds2, HsWrapper
outer_wrapper HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inner_wrapper, thing
thing) }
    go []         = do  { thing
thing <- TcM thing
thing_inside; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), HsWrapper,
 thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), HsWrapper,
      thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag, HsWrapper
idHsWrapper, thing
thing) }

    tc_scc :: SCC (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tc_scc (AcyclicSCC GenLocated SrcSpanAnnA (HsBind GhcRn)
bind) = RecFlag
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tc_sub_group RecFlag
NonRecursive [GenLocated SrcSpanAnnA (HsBind GhcRn)
bind]
    tc_scc (CyclicSCC [GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds) = RecFlag
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tc_sub_group RecFlag
Recursive    [GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds

    tc_sub_group :: RecFlag
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tc_sub_group RecFlag
rec_tc [GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds = TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBindLR GhcRn GhcRn]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn
                                            RecFlag
Recursive RecFlag
rec_tc IsGroupClosed
closed [LHsBindLR GhcRn GhcRn]
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds

recursivePatSynErr
  :: SrcSpan -- ^ The location of the first pattern synonym binding
             --   (for error reporting)
  -> LHsBinds GhcRn
  -> TcM a
recursivePatSynErr :: forall a. SrcSpan -> LHsBinds GhcRn -> TcM a
recursivePatSynErr SrcSpan
loc LHsBinds GhcRn
binds
  = SrcSpan -> TcRnMessage -> TcRn a
forall a. SrcSpan -> TcRnMessage -> TcRn a
failAt SrcSpan
loc (TcRnMessage -> TcRn a) -> TcRnMessage -> TcRn a
forall a b. (a -> b) -> a -> b
$ LHsBinds GhcRn -> TcRnMessage
TcRnRecursivePatternSynonym LHsBinds GhcRn
binds

tc_single :: forall thing.
            TopLevelFlag -> TcSigFun -> TcPragEnv
          -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
          -> TcM (LHsBinds GhcTc, HsWrapper, thing)
tc_single :: forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> LHsBindLR GhcRn GhcRn
-> IsGroupClosed
-> TcM thing
-> TcM (LHsBinds GhcTc, HsWrapper, thing)
tc_single TopLevelFlag
_top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn
          (L SrcSpanAnnA
loc (PatSynBind XPatSynBind GhcRn GhcRn
_ PatSynBind GhcRn GhcRn
psb))
          IsGroupClosed
_ TcM thing
thing_inside
  = do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
aux_binds, TcGblEnv
tcg_env) <- LocatedA (PatSynBind GhcRn GhcRn)
-> TcSigFun -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
tcPatSynDecl (SrcSpanAnnA
-> PatSynBind GhcRn GhcRn -> LocatedA (PatSynBind GhcRn GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc PatSynBind GhcRn GhcRn
psb) TcSigFun
sig_fn TcPragEnv
prag_fn
       ; thing
thing <- TcGblEnv -> TcM thing -> TcM thing
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env TcM thing
thing_inside
       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), HsWrapper,
 thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), HsWrapper,
      thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
aux_binds, HsWrapper
idHsWrapper, thing
thing)
       }

tc_single TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn LHsBindLR GhcRn GhcRn
lbind IsGroupClosed
closed TcM thing
thing_inside
  = do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1, [Scaled TcId]
ids) <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBindLR GhcRn GhcRn]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn
                                      RecFlag
NonRecursive RecFlag
NonRecursive
                                      IsGroupClosed
closed
                                      [LHsBindLR GhcRn GhcRn
lbind]
       ; (thing
thing, HsWrapper
wrapper) <- TopLevelFlag
-> TcSigFun
-> IsGroupClosed
-> [Scaled TcId]
-> TcM thing
-> TcM (thing, HsWrapper)
forall a.
TopLevelFlag
-> TcSigFun
-> IsGroupClosed
-> [Scaled TcId]
-> TcM a
-> TcM (a, HsWrapper)
tcExtendLetEnv TopLevelFlag
top_lvl TcSigFun
sig_fn IsGroupClosed
closed [Scaled TcId]
ids TcM thing
thing_inside
       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), HsWrapper,
 thing)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)), HsWrapper,
      thing)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds1, HsWrapper
wrapper, thing
thing) }

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

mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
-- See Note [Polymorphic recursion] in "GHC.Hs.Binds".
mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBindLR GhcRn GhcRn)]
mkEdges TcSigFun
sig_fn LHsBinds GhcRn
binds
  = [ GenLocated SrcSpanAnnA (HsBind GhcRn)
-> BKey
-> [BKey]
-> Node BKey (GenLocated SrcSpanAnnA (HsBind GhcRn))
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode GenLocated SrcSpanAnnA (HsBind GhcRn)
bind BKey
key [BKey
key | Name
n <- NameSet -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (HsBind GhcRn -> XFunBind GhcRn GhcRn
forall {idL} {idR}.
(XFunBind idL idR ~ NameSet, XPatBind idL idR ~ NameSet) =>
HsBindLR idL idR -> XFunBind idL idR
bind_fvs (GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsBind GhcRn)
bind)),
                         Just BKey
key <- [NameEnv BKey -> Name -> Maybe BKey
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv BKey
key_map Name
n], Name -> Bool
no_sig Name
n ]
    | (GenLocated SrcSpanAnnA (HsBind GhcRn)
bind, BKey
key) <- [(GenLocated SrcSpanAnnA (HsBind GhcRn), BKey)]
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 GHC.Data.Graph.Directed.
  where
    bind_fvs :: HsBindLR idL idR -> XFunBind idL idR
bind_fvs (FunBind { fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = XFunBind idL idR
fvs }) = XFunBind idL idR
fvs
    bind_fvs (PatBind { pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = XPatBind idL idR
fvs }) = XPatBind idL idR
XFunBind idL idR
fvs
    bind_fvs HsBindLR idL idR
_                           = XFunBind idL idR
NameSet
emptyNameSet

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

    keyd_binds :: [(GenLocated SrcSpanAnnA (HsBind GhcRn), BKey)]
keyd_binds = Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
binds [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> [BKey] -> [(GenLocated SrcSpanAnnA (HsBind GhcRn), BKey)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [BKey
0::BKey ..]

    key_map :: NameEnv BKey     -- Which binding it comes from
    key_map :: NameEnv BKey
key_map = [(Name, BKey)] -> NameEnv BKey
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name
bndr, BKey
key) | (L SrcSpanAnnA
_ HsBind GhcRn
bind, BKey
key) <- [(GenLocated SrcSpanAnnA (HsBind GhcRn), BKey)]
keyd_binds
                                     , Name
bndr <- CollectFlag GhcRn -> HsBind GhcRn -> [IdP GhcRn]
forall p idR.
CollectPass p =>
CollectFlag p -> HsBindLR p idR -> [IdP p]
collectHsBindBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders HsBind GhcRn
bind ]

------------------------
tcPolyBinds :: TopLevelFlag -> 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 GhcTc, [Scaled 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 :: TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBindLR GhcRn GhcRn]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyBinds TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn RecFlag
rec_group RecFlag
rec_tc IsGroupClosed
closed [LHsBindLR GhcRn GhcRn]
bind_list
  = SrcSpan
-> TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc                              (TcM (LHsBinds GhcTc, [Scaled TcId])
 -> TcM (LHsBinds GhcTc, [Scaled TcId]))
-> TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId])
forall a b. (a -> b) -> a -> b
$
    TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId])
forall r. TcRn r -> TcRn r -> TcRn r
recoverM ([Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Scaled TcId])
recoveryCode [IdP GhcRn]
[Name]
binder_names TcSigFun
sig_fn) (TcM (LHsBinds GhcTc, [Scaled TcId])
 -> TcM (LHsBinds GhcTc, [Scaled TcId]))
-> TcM (LHsBinds GhcTc, [Scaled TcId])
-> TcM (LHsBinds GhcTc, [Scaled TcId])
forall a b. (a -> b) -> a -> b
$ do
        -- Set up main recover; take advantage of any type sigs

    { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"------------------------------------------------" SDoc
forall doc. IsOutput doc => doc
Outputable.empty
    ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Bindings for {" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IdP GhcRn]
[Name]
binder_names)
    ; DynFlags
dflags   <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    ; let plan :: GeneralisationPlan
plan = DynFlags
-> TopLevelFlag
-> IsGroupClosed
-> TcSigFun
-> [LHsBindLR GhcRn GhcRn]
-> GeneralisationPlan
decideGeneralisationPlan DynFlags
dflags TopLevelFlag
top_lvl IsGroupClosed
closed TcSigFun
sig_fn [LHsBindLR GhcRn GhcRn]
bind_list
    ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Generalisation plan" (GeneralisationPlan -> SDoc
forall a. Outputable a => a -> SDoc
ppr GeneralisationPlan
plan)
    ; result :: (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [Scaled TcId])
result@(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
_, [Scaled TcId]
scaled_poly_ids) <- case GeneralisationPlan
plan of
         GeneralisationPlan
NoGen              -> RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBindLR GhcRn GhcRn]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyNoGen RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
sig_fn [LHsBindLR GhcRn GhcRn]
bind_list
         GeneralisationPlan
InferGen           -> RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBindLR GhcRn GhcRn]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyInfer RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
sig_fn [LHsBindLR GhcRn GhcRn]
bind_list
         CheckGen LHsBindLR GhcRn GhcRn
lbind TcCompleteSig
sig -> TcPragEnv
-> TcCompleteSig
-> LHsBindLR GhcRn GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyCheck TcPragEnv
prag_fn TcCompleteSig
sig LHsBindLR GhcRn GhcRn
lbind

    ; let poly_ids :: [TcId]
poly_ids = (Scaled TcId -> TcId) -> [Scaled TcId] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcId -> TcId
forall a. Scaled a -> a
scaledThing [Scaled TcId]
scaled_poly_ids

    ; (TcId -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [TcId] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ TcId
poly_id ->
        HasDebugCallStack =>
FixedRuntimeRepContext -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) ()
FixedRuntimeRepContext -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) ()
hasFixedRuntimeRep_syntactic (Name -> FixedRuntimeRepContext
FRRBinder (Name -> FixedRuntimeRepContext) -> Name -> FixedRuntimeRepContext
forall a b. (a -> b) -> a -> b
$ TcId -> Name
idName TcId
poly_id) (TcId -> Kind
idType TcId
poly_id))
        [TcId]
poly_ids

    ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"} End of bindings for" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IdP GhcRn]
[Name]
binder_names, RecFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecFlag
rec_group
                                            , [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
idType TcId
id) | TcId
id <- [TcId]
poly_ids]
                                          ])

    ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [Scaled TcId])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [Scaled TcId])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [Scaled TcId])
result }
  where
    binder_names :: [IdP GhcRn]
binder_names = CollectFlag GhcRn -> [LHsBindLR GhcRn GhcRn] -> [IdP GhcRn]
forall p idR.
CollectPass p =>
CollectFlag p -> [LHsBindLR p idR] -> [IdP p]
collectHsBindListBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders [LHsBindLR GhcRn GhcRn]
bind_list
    loc :: SrcSpan
loc = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans ((GenLocated SrcSpanAnnA (HsBind GhcRn) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA (SrcSpanAnnA -> SrcSpan)
-> (GenLocated SrcSpanAnnA (HsBind GhcRn) -> SrcSpanAnnA)
-> GenLocated SrcSpanAnnA (HsBind GhcRn)
-> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcRn) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc) [LHsBindLR GhcRn GhcRn]
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
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 GhcTc, [Scaled Id])
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Scaled TcId])
recoveryCode [Name]
binder_names TcSigFun
sig_fn
  = do  { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcBindsWithSigs: error recovery" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
binder_names)
        ; let poly_ids :: [Scaled TcId]
poly_ids = (TcId -> Scaled TcId) -> [TcId] -> [Scaled TcId]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> TcId -> Scaled TcId
forall a. Kind -> a -> Scaled a
Scaled Kind
ManyTy) ([TcId] -> [Scaled TcId]) -> [TcId] -> [Scaled TcId]
forall a b. (a -> b) -> a -> b
$ (Name -> TcId) -> [Name] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TcId
mk_dummy [Name]
binder_names
        ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [Scaled TcId])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [Scaled TcId])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. Bag a
emptyBag, [Scaled TcId]
poly_ids) }
  where
    mk_dummy :: Name -> TcId
mk_dummy Name
name
      | Just TcSigInfo
sig <- TcSigFun
sig_fn Name
name
      , Just TcId
poly_id <- TcSigInfo -> Maybe TcId
completeSigPolyId_maybe TcSigInfo
sig
      = TcId
poly_id
      | Bool
otherwise
      = HasDebugCallStack => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
name Kind
ManyTy Kind
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 :: Kind
forall_a_a = [TcId] -> Kind -> Kind
mkSpecForAllTys [TcId
alphaTyVar] Kind
alphaTy

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

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

tcPolyNoGen :: RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBindLR GhcRn GhcRn]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyNoGen RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
tc_sig_fn [LHsBindLR GhcRn GhcRn]
bind_list
  = do { (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', [MonoBindInfo]
mono_infos) <- RecFlag
-> TcSigFun
-> LetBndrSpec
-> [LHsBindLR GhcRn GhcRn]
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
tcMonoBinds RecFlag
rec_tc TcSigFun
tc_sig_fn
                                             (TcPragEnv -> LetBndrSpec
LetGblBndr TcPragEnv
prag_fn)
                                             [LHsBindLR GhcRn GhcRn]
bind_list
       ; [Scaled TcId]
mono_ids' <- (MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcId))
-> [MonoBindInfo] -> IOEnv (Env TcGblEnv TcLclEnv) [Scaled TcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcId)
tc_mono_info [MonoBindInfo]
mono_infos
       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [Scaled TcId])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [Scaled TcId])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', [Scaled TcId]
mono_ids') }
  where
    tc_mono_info :: MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcId)
tc_mono_info (MBI { mbi_poly_name :: MonoBindInfo -> Name
mbi_poly_name = Name
name, mbi_mono_id :: MonoBindInfo -> TcId
mbi_mono_id = TcId
mono_id, mbi_mono_mult :: MonoBindInfo -> Kind
mbi_mono_mult = Kind
mult })
      = do { [LTcSpecPrag]
_specs <- TcId -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
mono_id (TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
name)
           ; Scaled TcId -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcId)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Scaled TcId -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcId))
-> Scaled TcId -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcId)
forall a b. (a -> b) -> a -> b
$ Kind -> TcId -> Scaled TcId
forall a. Kind -> a -> Scaled a
Scaled Kind
mult TcId
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
            -> TcCompleteSig
            -> LHsBind GhcRn   -- Must be a FunBind
            -> TcM (LHsBinds GhcTc, [Scaled TcId])
-- There is just one binding,
--   it is a FunBind
--   it has a complete type signature,
tcPolyCheck :: TcPragEnv
-> TcCompleteSig
-> LHsBindLR GhcRn GhcRn
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyCheck TcPragEnv
prag_fn
            sig :: TcCompleteSig
sig@(CSig { sig_bndr :: TcCompleteSig -> TcId
sig_bndr = TcId
poly_id, sig_ctxt :: TcCompleteSig -> UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt })
            (L SrcSpanAnnA
bind_loc (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
nm_loc Name
name
                                 , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
matches }))
  = do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcPolyCheck" (TcCompleteSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcCompleteSig
sig)

       -- Make a new Name, whose SrcSpan is nm_loc.  For a ClassOp
       -- The original Name, in the FunBind{fun_id}, is bound in the
       -- class declaration, whereas we want a Name bound right here.
       -- We pass mono_name to tcFunBindMatches which in turn puts it in
       -- the BinderStack, whence it shows up in "Relevant bindings.."
       ; Name
mono_name <- OccName -> SrcSpan -> TcM Name
newNameAt (Name -> OccName
nameOccName Name
name) (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
nm_loc)

       ; Kind
mult <- HsMultAnn GhcRn -> TcM Kind
tcMultAnn (XNoMultAnn GhcRn -> HsMultAnn GhcRn
forall pass. XNoMultAnn pass -> HsMultAnn pass
HsNoMultAnn NoExtField
XNoMultAnn GhcRn
noExtField)
       ; (HsWrapper
wrap_gen, (HsWrapper
wrap_res, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches'))
             <- TcCompleteSig
-> ([ExpPatType]
    -> Kind
    -> TcM
         (HsWrapper,
          MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
     (HsWrapper,
      (HsWrapper,
       MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall result.
TcCompleteSig
-> ([ExpPatType] -> Kind -> TcM result) -> TcM (HsWrapper, result)
tcSkolemiseCompleteSig TcCompleteSig
sig (([ExpPatType]
  -> Kind
  -> TcM
       (HsWrapper,
        MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
 -> TcM
      (HsWrapper,
       (HsWrapper,
        MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> ([ExpPatType]
    -> Kind
    -> TcM
         (HsWrapper,
          MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
     (HsWrapper,
      (HsWrapper,
       MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall a b. (a -> b) -> a -> b
$ \[ExpPatType]
invis_pat_tys Kind
rho_ty ->

                let mono_id :: TcId
mono_id = HasDebugCallStack => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
mono_name (TcId -> Kind
varMult TcId
poly_id) Kind
rho_ty in
                [TcBinder]
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [TcId -> TopLevelFlag -> TcBinder
TcIdBndr TcId
mono_id TopLevelFlag
NotTopLevel] (TcM
   (HsWrapper,
    MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
 -> TcM
      (HsWrapper,
       MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM
     (HsWrapper,
      MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$
                -- Why mono_id in the BinderStack?
                -- See Note [Relevant bindings and the binder stack]

                SrcSpanAnnA
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
bind_loc  (TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
 -> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
                UserTypeCtxt
-> Name
-> Kind
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpSigmaType
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcFunBindMatches UserTypeCtxt
ctxt Name
mono_name Kind
mult MatchGroup GhcRn (LHsExpr GhcRn)
matches [ExpPatType]
invis_pat_tys (Kind -> ExpSigmaType
mkCheckExpType Kind
rho_ty)

       -- We make a funny AbsBinds, abstracting over nothing,
       -- just so we have somewhere to put the SpecPrags.
       -- Otherwise we could just use the FunBind
       -- Hence poly_id2 is just a clone of poly_id;
       -- We re-use mono-name, but we could equally well use a fresh one

       ; let prag_sigs :: [LSig GhcRn]
prag_sigs = TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
name
             poly_id2 :: TcId
poly_id2  = HasDebugCallStack => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
mono_name (TcId -> Kind
idMult TcId
poly_id) (TcId -> Kind
idType TcId
poly_id)
       ; [LTcSpecPrag]
spec_prags <- TcId -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags    TcId
poly_id [LSig GhcRn]
prag_sigs
       ; TcId
poly_id    <- TcId -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) TcId
addInlinePrags TcId
poly_id [LSig GhcRn]
prag_sigs

       ; Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       ; [CoreTickish]
tick <- SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [CoreTickish]
funBindTicks (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
nm_loc) TcId
poly_id Module
mod [LSig GhcRn]
prag_sigs

       ; let bind' :: HsBindLR GhcTc GhcTc
bind' = FunBind { fun_id :: LIdP GhcTc
fun_id      = SrcSpanAnnN -> TcId -> GenLocated SrcSpanAnnN TcId
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nm_loc TcId
poly_id2
                             , fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches'
                             , fun_ext :: XFunBind GhcTc GhcTc
fun_ext     = (HsWrapper
wrap_gen HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap_res, [CoreTickish]
tick) }

             export :: ABExport
export = ABE { abe_wrap :: HsWrapper
abe_wrap  = HsWrapper
idHsWrapper
                          , abe_poly :: TcId
abe_poly  = TcId
poly_id
                          , abe_mono :: TcId
abe_mono  = TcId
poly_id2
                          , abe_prags :: TcSpecPrags
abe_prags = [LTcSpecPrag] -> TcSpecPrags
SpecPrags [LTcSpecPrag]
spec_prags }

             abs_bind :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
abs_bind = SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc (HsBindLR GhcTc GhcTc
 -> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR (XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc)
-> XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall a b. (a -> b) -> a -> b
$
                        AbsBinds { abs_tvs :: [TcId]
abs_tvs      = []
                                 , abs_ev_vars :: [TcId]
abs_ev_vars  = []
                                 , abs_ev_binds :: [TcEvBinds]
abs_ev_binds = []
                                 , abs_exports :: [ABExport]
abs_exports  = [ABExport
export]
                                 , abs_binds :: LHsBinds GhcTc
abs_binds    = GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
bind_loc HsBindLR GhcTc GhcTc
bind')
                                 , abs_sig :: Bool
abs_sig      = Bool
True }

       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [Scaled TcId])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [Scaled TcId])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
abs_bind, [Kind -> TcId -> Scaled TcId
forall a. Kind -> a -> Scaled a
Scaled Kind
mult TcId
poly_id]) }

tcPolyCheck TcPragEnv
_prag_fn TcCompleteSig
sig LHsBindLR GhcRn GhcRn
bind
  = String
-> SDoc
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [Scaled TcId])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcPolyCheck" (TcCompleteSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcCompleteSig
sig SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenLocated SrcSpanAnnA (HsBind GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBindLR GhcRn GhcRn
GenLocated SrcSpanAnnA (HsBind GhcRn)
bind)

funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
             -> TcM [CoreTickish]
funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [CoreTickish]
funBindTicks SrcSpan
loc TcId
fun_id Module
mod [LSig GhcRn]
sigs
  | (Maybe (GenLocated EpAnnCO StringLiteral)
mb_cc_str : [Maybe (GenLocated EpAnnCO StringLiteral)]
_) <- [ Maybe (XRec GhcRn StringLiteral)
Maybe (GenLocated EpAnnCO StringLiteral)
cc_name | L SrcSpanAnnA
_ (SCCFunSig XSCCFunSig GhcRn
_ LIdP GhcRn
_ Maybe (XRec GhcRn StringLiteral)
cc_name) <- [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs ]
      -- this can only be a singleton list, as duplicate pragmas are rejected
      -- by the renamer
  , let cc_str :: FastString
cc_str
          | Just GenLocated EpAnnCO StringLiteral
cc_str <- Maybe (GenLocated EpAnnCO StringLiteral)
mb_cc_str
          = StringLiteral -> FastString
sl_fs (StringLiteral -> FastString) -> StringLiteral -> FastString
forall a b. (a -> b) -> a -> b
$ GenLocated EpAnnCO StringLiteral -> StringLiteral
forall l e. GenLocated l e -> e
unLoc GenLocated EpAnnCO StringLiteral
cc_str
          | Bool
otherwise
          = Name -> FastString
forall a. NamedThing a => a -> FastString
getOccFS (TcId -> Name
Var.varName TcId
fun_id)
        cc_name :: FastString
cc_name = [FastString] -> FastString
concatFS [ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod), String -> FastString
fsLit String
".", FastString
cc_str]
  = do
      CCFlavour
flavour <- CostCentreIndex -> CCFlavour
mkDeclCCFlavour (CostCentreIndex -> CCFlavour)
-> IOEnv (Env TcGblEnv TcLclEnv) CostCentreIndex
-> IOEnv (Env TcGblEnv TcLclEnv) CCFlavour
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> IOEnv (Env TcGblEnv TcLclEnv) CostCentreIndex
getCCIndexTcM FastString
cc_name
      let cc :: CostCentre
cc = FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC FastString
cc_name Module
mod SrcSpan
loc CCFlavour
flavour
      [CoreTickish] -> TcM [CoreTickish]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [CostCentre -> Bool -> Bool -> CoreTickish
forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote CostCentre
cc Bool
True Bool
True]
  | Bool
otherwise
  = [CoreTickish] -> TcM [CoreTickish]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
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
*                                                                      *
********************************************************************* -}

{- Note [Non-variable pattern bindings aren't linear]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A fundamental limitation of the typechecking algorithm is that we cannot have a
binding which, at the same time,
- is linear in its rhs
- is a non-variable pattern
- binds variables to polymorphic or qualified types

A detailed explanation can be found at:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst#let-bindings-and-polymorphism

To address this we to do a few things

- (NVP1) When a pattern is annotated with a multiplicity annotation `let %q pat = rhs
  in body` (note: multiplicity-annotated bindings are always parsed as a
  PatBind, see Note [Multiplicity annotations] in Language.Haskell.Syntax.Binds),
  then the let is never generalised (we use the NoGen plan). We do this with a
  dedicated test in decideGeneralisationPlan.
- (NVP2) Whenever the typechecker infers an AbsBind *and* the inner binding is a
  non-variable PatBind, then the multiplicity of the binding is inferred to be
  Many. We do this by calling manyIfPats in tcPolyInfer. This is a little
  infelicitous: sometimes the typechecker infers an AbsBind where it didn't need
  to. This may cause some programs to be spuriously rejected, when
  NoMonoLocalBinds is on.
- (NVP3) LinearLet implies MonoLocalBinds to avoid the AbsBind case altogether.
- (NVP4) Wrinkle: even when other conditions (including MonoLocalBinds), GHC
  will generalise some binders, namely so-called closed binding groups. We need
  to make sure that the test for (NVP1) has priority over the test for closed
  binders.
- (NVP5) Wrinkle: Closed binding groups (NVP4) are usually fine to type with
  multiplicity Many. But there's one exception: when there's no binder at all,
  the binding group is considered closed. Even if the rhs contains arbitrary
  variables.

     f :: () %1 -> Bool
     f x = let !() = x in True

  If we consider `!() = x` as a generalisable group (which does nothing anyway),
  then (NVP2) will infer the pattern as multiplicity Many, and reject the
  function. We don't want that, see also #25428. So we take care not to
  generalise in this case, by excluding the no-binder case from automatic
  generalisation in decideGeneralisationPlan.
-}

tcPolyInfer
  :: RecFlag       -- Whether it's recursive after breaking
                   -- dependencies based on type signatures
  -> TcPragEnv -> TcSigFun
  -> [LHsBind GhcRn]
  -> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyInfer :: RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBindLR GhcRn GhcRn]
-> TcM (LHsBinds GhcTc, [Scaled TcId])
tcPolyInfer RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
tc_sig_fn [LHsBindLR GhcRn GhcRn]
bind_list
  = do { (TcLevel
tclvl, WantedConstraints
wanted, (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds', [MonoBindInfo]
mono_infos))
             <- TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM
     (TcLevel, WantedConstraints, (LHsBinds GhcTc, [MonoBindInfo]))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints  (TcM (LHsBinds GhcTc, [MonoBindInfo])
 -> TcM
      (TcLevel, WantedConstraints, (LHsBinds GhcTc, [MonoBindInfo])))
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM
     (TcLevel, WantedConstraints, (LHsBinds GhcTc, [MonoBindInfo]))
forall a b. (a -> b) -> a -> b
$
                RecFlag
-> TcSigFun
-> LetBndrSpec
-> [LHsBindLR GhcRn GhcRn]
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
tcMonoBinds RecFlag
rec_tc TcSigFun
tc_sig_fn LetBndrSpec
LetLclBndr [LHsBindLR GhcRn GhcRn]
bind_list

       ; Bool
apply_mr <- [MonoBindInfo] -> [LHsBindLR GhcRn GhcRn] -> TcM Bool
checkMonomorphismRestriction [MonoBindInfo]
mono_infos [LHsBindLR GhcRn GhcRn]
bind_list

       -- AbsBinds which are PatBinds can't be linear.
       -- See (NVP2) in Note [Non-variable pattern bindings aren't linear]
       ; Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds' <- Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
forall {idR} {b} {t :: * -> *} {l}.
(XPatBind GhcTc idR ~ (Kind, b), Traversable t) =>
t (GenLocated l (HsBindLR GhcTc idR))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (t (GenLocated l (HsBindLR GhcTc idR)))
manyIfPats Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds'

       ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcPolyInfer" (Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
apply_mr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Maybe TcIdSigInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((MonoBindInfo -> Maybe TcIdSigInst)
-> [MonoBindInfo] -> [Maybe TcIdSigInst]
forall a b. (a -> b) -> [a] -> [b]
map MonoBindInfo -> Maybe TcIdSigInst
mbi_sig [MonoBindInfo]
mono_infos))

       ; let name_taus :: [(Name, Kind)]
name_taus  = [ (MonoBindInfo -> Name
mbi_poly_name MonoBindInfo
info, TcId -> Kind
idType (MonoBindInfo -> TcId
mbi_mono_id MonoBindInfo
info))
                          | MonoBindInfo
info <- [MonoBindInfo]
mono_infos ]
             sigs :: [TcIdSigInst]
sigs       = [ TcIdSigInst
sig | MBI { mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Just TcIdSigInst
sig } <- [MonoBindInfo]
mono_infos ]
             infer_mode :: InferMode
infer_mode = if Bool
apply_mr then InferMode
ApplyMR else InferMode
NoRestrictions

       ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"simplifyInfer call" (TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [(Name, Kind)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, Kind)]
name_taus SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wanted)
       ; (([TcId]
qtvs, [TcId]
givens, TcEvBinds
ev_binds, Bool
insoluble), WantedConstraints
residual)
            <- TcM ([TcId], [TcId], TcEvBinds, Bool)
-> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM ([TcId], [TcId], TcEvBinds, Bool)
 -> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints))
-> TcM ([TcId], [TcId], TcEvBinds, Bool)
-> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints)
forall a b. (a -> b) -> a -> b
$ TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, Kind)]
-> WantedConstraints
-> TcM ([TcId], [TcId], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
infer_mode [TcIdSigInst]
sigs [(Name, Kind)]
name_taus WantedConstraints
wanted

       ; let inferred_theta :: TcThetaType
inferred_theta = (TcId -> Kind) -> [TcId] -> TcThetaType
forall a b. (a -> b) -> [a] -> [b]
map TcId -> Kind
evVarPred [TcId]
givens
       ; [Scaled ABExport]
scaled_exports <- TcM [Scaled ABExport] -> TcM [Scaled ABExport]
forall r. TcM r -> TcM r
checkNoErrs (TcM [Scaled ABExport] -> TcM [Scaled ABExport])
-> TcM [Scaled ABExport] -> TcM [Scaled ABExport]
forall a b. (a -> b) -> a -> b
$
                    (MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled ABExport))
-> [MonoBindInfo] -> TcM [Scaled ABExport]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TcPragEnv
-> WantedConstraints
-> Bool
-> [TcId]
-> TcThetaType
-> MonoBindInfo
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled ABExport)
mkExport TcPragEnv
prag_fn WantedConstraints
residual Bool
insoluble [TcId]
qtvs TcThetaType
inferred_theta) [MonoBindInfo]
mono_infos
       ; let exports :: [ABExport]
exports = (Scaled ABExport -> ABExport) -> [Scaled ABExport] -> [ABExport]
forall a b. (a -> b) -> [a] -> [b]
map Scaled ABExport -> ABExport
forall a. Scaled a -> a
scaledThing [Scaled ABExport]
scaled_exports

         -- NB: *after* the checkNoErrs call above. This ensures that we don't get an error
         -- cascade in case mkExport runs into trouble. In particular, this avoids duplicate
         -- errors when a partial type signature cannot be quantified in chooseInferredQuantifiers.
         -- See Note [Quantification and partial signatures] in GHC.Tc.Solver, Wrinkle 4.
         -- Tested in partial-sigs/should_fail/NamedWilcardExplicitForall.
       ; WantedConstraints -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitConstraints WantedConstraints
residual

       ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
       ; let scaled_poly_ids :: [Scaled TcId]
scaled_poly_ids = [ Kind -> TcId -> Scaled TcId
forall a. Kind -> a -> Scaled a
Scaled Kind
p (ABExport -> TcId
abe_poly ABExport
export) | Scaled Kind
p ABExport
export <- [Scaled ABExport]
scaled_exports]
             poly_ids :: [TcId]
poly_ids = (Scaled TcId -> TcId) -> [Scaled TcId] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcId -> TcId
forall a. Scaled a -> a
scaledThing [Scaled TcId]
scaled_poly_ids
             abs_bind :: GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
abs_bind = SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) (HsBindLR GhcTc GhcTc
 -> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$ XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall idL idR. XXHsBindsLR idL idR -> HsBindLR idL idR
XHsBindsLR (XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc)
-> XXHsBindsLR GhcTc GhcTc -> HsBindLR GhcTc GhcTc
forall a b. (a -> b) -> a -> b
$
                        AbsBinds { abs_tvs :: [TcId]
abs_tvs = [TcId]
qtvs
                                 , abs_ev_vars :: [TcId]
abs_ev_vars = [TcId]
givens, abs_ev_binds :: [TcEvBinds]
abs_ev_binds = [TcEvBinds
ev_binds]
                                 , abs_exports :: [ABExport]
abs_exports = [ABExport]
exports, abs_binds :: LHsBinds GhcTc
abs_binds = LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds'
                                 , abs_sig :: Bool
abs_sig = Bool
False }

       ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"Binding:" ([(TcId, Kind)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([TcId]
poly_ids [TcId] -> TcThetaType -> [(TcId, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (TcId -> Kind) -> [TcId] -> TcThetaType
forall a b. (a -> b) -> [a] -> [b]
map TcId -> Kind
idType [TcId]
poly_ids))
       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [Scaled TcId])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [Scaled TcId])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
abs_bind, [Scaled TcId]
scaled_poly_ids) }
         -- poly_ids are guaranteed zonked by mkExport
  where
    manyIfPat :: GenLocated l (HsBindLR GhcTc idR)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsBindLR GhcTc idR))
manyIfPat bind :: GenLocated l (HsBindLR GhcTc idR)
bind@(L l
_ (PatBind{pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs=(L SrcSpanAnnA
_ (VarPat{}))}))
      = GenLocated l (HsBindLR GhcTc idR)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsBindLR GhcTc idR))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated l (HsBindLR GhcTc idR)
bind
    manyIfPat (L l
loc pat :: HsBindLR GhcTc idR
pat@(PatBind {pat_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_mult=HsMultAnn GhcTc
mult_ann, pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs=LPat GhcTc
lhs, pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext =(Kind
pat_ty,b
_)}))
      = do { HsWrapper
mult_co_wrap <- CtOrigin -> Kind -> Kind -> TcM HsWrapper
tcSubMult (NonLinearPatternReason -> XRec GhcRn (Pat GhcRn) -> CtOrigin
NonLinearPatternOrigin NonLinearPatternReason
GeneralisedPatternReason XRec GhcRn (Pat GhcRn)
nlWildPatName) Kind
ManyTy (HsMultAnn GhcTc -> Kind
getTcMultAnn HsMultAnn GhcTc
mult_ann)
           -- The wrapper checks for correct multiplicities.
           -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
           ; let lhs' :: LPat GhcTc
lhs' = HsWrapper -> LPat GhcTc -> Kind -> LPat GhcTc
mkLHsWrapPat HsWrapper
mult_co_wrap LPat GhcTc
lhs Kind
pat_ty
           ; GenLocated l (HsBindLR GhcTc idR)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsBindLR GhcTc idR))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated l (HsBindLR GhcTc idR)
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (GenLocated l (HsBindLR GhcTc idR)))
-> GenLocated l (HsBindLR GhcTc idR)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsBindLR GhcTc idR))
forall a b. (a -> b) -> a -> b
$ l -> HsBindLR GhcTc idR -> GenLocated l (HsBindLR GhcTc idR)
forall l e. l -> e -> GenLocated l e
L l
loc HsBindLR GhcTc idR
pat {pat_lhs=lhs'}
           }
    manyIfPat GenLocated l (HsBindLR GhcTc idR)
bind = GenLocated l (HsBindLR GhcTc idR)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsBindLR GhcTc idR))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated l (HsBindLR GhcTc idR)
bind
    manyIfPats :: t (GenLocated l (HsBindLR GhcTc idR))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (t (GenLocated l (HsBindLR GhcTc idR)))
manyIfPats t (GenLocated l (HsBindLR GhcTc idR))
binds' = (GenLocated l (HsBindLR GhcTc idR)
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (GenLocated l (HsBindLR GhcTc idR)))
-> t (GenLocated l (HsBindLR GhcTc idR))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (t (GenLocated l (HsBindLR GhcTc idR)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse GenLocated l (HsBindLR GhcTc idR)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsBindLR GhcTc idR))
forall {idR} {b} {l}.
(XPatBind GhcTc idR ~ (Kind, b)) =>
GenLocated l (HsBindLR GhcTc idR)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated l (HsBindLR GhcTc idR))
manyIfPat t (GenLocated l (HsBindLR GhcTc idR))
binds'

checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool
-- True <=> apply the MR
-- See Note [When the MR applies]
checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBindLR GhcRn GhcRn] -> TcM Bool
checkMonomorphismRestriction [MonoBindInfo]
mbis [LHsBindLR GhcRn GhcRn]
lbinds
  = do { Bool
mr_on <- Extension -> TcM Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.MonomorphismRestriction
       ; let mr_applies :: Bool
mr_applies = Bool
mr_on Bool -> Bool -> Bool
&& (GenLocated SrcSpanAnnA (HsBind GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HsBind GhcRn -> Bool
restricted (HsBind GhcRn -> Bool)
-> (GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn)
-> GenLocated SrcSpanAnnA (HsBind GhcRn)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn
forall l e. GenLocated l e -> e
unLoc) [LHsBindLR GhcRn GhcRn]
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
lbinds
       ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mr_applies (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ (MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [MonoBindInfo] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkOverloadedSig [MonoBindInfo]
mbis
       ; Bool -> TcM Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
mr_applies }
  where
    no_mr_bndrs :: NameSet
    no_mr_bndrs :: NameSet
no_mr_bndrs = [Name] -> NameSet
mkNameSet ((MonoBindInfo -> Maybe Name) -> [MonoBindInfo] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MonoBindInfo -> Maybe Name
no_mr_name [MonoBindInfo]
mbis)

    no_mr_name :: MonoBindInfo -> Maybe Name
    -- Just n for binders that have a signature that says "no MR needed for me"
    no_mr_name :: MonoBindInfo -> Maybe Name
no_mr_name (MBI { mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Just TcIdSigInst
sig })
       | TISI { sig_inst_sig :: TcIdSigInst -> TcIdSig
sig_inst_sig = TcIdSig
info, sig_inst_theta :: TcIdSigInst -> TcThetaType
sig_inst_theta = TcThetaType
theta, sig_inst_wcx :: TcIdSigInst -> Maybe Kind
sig_inst_wcx = Maybe Kind
wcx } <- TcIdSigInst
sig
       = case TcIdSig
info of
           TcCompleteSig (CSig { sig_bndr :: TcCompleteSig -> TcId
sig_bndr = TcId
bndr }) -> Name -> Maybe Name
forall a. a -> Maybe a
Just (TcId -> Name
idName TcId
bndr)
           TcPartialSig (PSig { psig_name :: TcPartialSig -> Name
psig_name = Name
nm })
             | TcThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TcThetaType
theta, Maybe Kind -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Kind
wcx   -> Maybe Name
forall a. Maybe a
Nothing  -- f :: _ -> _
             | Bool
otherwise                   -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
nm  -- f :: Num a => a -> _
             -- For the latter case, we don't want the MR:
             -- the user has explicitly specified a type-class context
    no_mr_name MonoBindInfo
_ = Maybe Name
forall a. Maybe a
Nothing

    -- The Haskell 98 monomorphism restriction
    restricted :: HsBindLR GhcRn GhcRn -> Bool
    restricted :: HsBind GhcRn -> Bool
restricted (PatBind {})                              = Bool
True
    restricted (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcRn
v, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
m }) = MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> Bool
forall {id :: Pass} {body}. MatchGroup (GhcPass id) body -> Bool
restricted_match MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
m
                                                           Bool -> Bool -> Bool
&& Name -> Bool
mr_needed_for (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
v)
    restricted (VarBind { var_ext :: forall idL idR. HsBindLR idL idR -> XVarBind idL idR
var_ext = XVarBind GhcRn GhcRn
x })                 = DataConCantHappen -> Bool
forall a. DataConCantHappen -> a
dataConCantHappen XVarBind GhcRn GhcRn
DataConCantHappen
x
    restricted b :: HsBind GhcRn
b@(PatSynBind {}) = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isRestrictedGroup/unrestricted" (HsBind GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBind GhcRn
b)

    restricted_match :: MatchGroup (GhcPass id) body -> Bool
restricted_match MatchGroup (GhcPass id) body
mg = MatchGroup (GhcPass id) body -> BKey
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> BKey
matchGroupArity MatchGroup (GhcPass id) body
mg BKey -> BKey -> Bool
forall a. Eq a => a -> a -> Bool
== BKey
0
        -- No args => like a pattern binding
        -- Some args => a function binding

    mr_needed_for :: Name -> Bool
mr_needed_for Name
nm = Bool -> Bool
not (Name
nm Name -> NameSet -> Bool
`elemNameSet` NameSet
no_mr_bndrs)

checkOverloadedSig :: MonoBindInfo -> TcM ()
-- Example:
--   f :: Eq a => a -> a
--   K f = e
-- The MR applies, but the signature is overloaded, and it's
-- best to complain about this directly
-- c.f #11339
checkOverloadedSig :: MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkOverloadedSig (MBI { mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Just TcIdSigInst
sig })
  | TISI { sig_inst_sig :: TcIdSigInst -> TcIdSig
sig_inst_sig = TcIdSig
orig_sig, sig_inst_theta :: TcIdSigInst -> TcThetaType
sig_inst_theta = TcThetaType
theta, sig_inst_wcx :: TcIdSigInst -> Maybe Kind
sig_inst_wcx = Maybe Kind
wcx } <- TcIdSigInst
sig
  , Bool -> Bool
not (TcThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TcThetaType
theta Bool -> Bool -> Bool
&& Maybe Kind -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Kind
wcx)
  = SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (TcIdSig -> SrcSpan
tcIdSigLoc TcIdSig
orig_sig) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ TcIdSig -> TcRnMessage
TcRnOverloadedSig TcIdSig
orig_sig
checkOverloadedSig MonoBindInfo
_ = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{- Note [When the MR applies]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Monomorphism Restriction (MR) applies as specifies in the Haskell Report:

* If -XMonomorphismRestriction is on, and
* Any binding is restricted

A binding is restricted if:
* It is a pattern binding e.g. (x,y) = e
* Or it is a FunBind with no arguments e.g. f = rhs
     and the binder `f` lacks a No-MR signature

A binder f has a No-MR signature if

* It has a complete type signature
    e.g. f :: Num a => a -> a

* Or it has a /partial/ type signature with a /context/
    e.g.  f :: (_) => a -> _
          g :: Num a => a -> _
          h :: (Num a, _) => a -> _
   All of f,g,h have a No-MR signature.  They say that the function is overloaded
   so it's silly to try to apply the MR. This means that #19106 works out
   fine.  Ditto #11016, which looked like
      f4 :: (?loc :: Int) => _
      f4 = ?loc

   This partial-signature stuff is a bit ad-hoc but seems to match our
   use-cases.  See also Note [Constraints in partial type signatures]
   in GHC.Tc.Solver.

Example: the MR does apply to
   k :: _ -> _
   k = rhs
because k's binding has no arguments, and `k` does not have
a No-MR signature.

All of this checking takes place after synonym expansion.  For example:
   type Wombat a = forall b. Eq [b] => ...b...a...
   f5 :: Wombat _
This (and does) behave just like
   f5 :: forall b. Eq [b] => ...b..._...

-}

--------------
mkExport :: TcPragEnv
         -> WantedConstraints  -- residual constraints, already emitted (for errors only)
         -> Bool                        -- True <=> there was an insoluble type error
                                        --          when typechecking the bindings
         -> [TyVar] -> TcThetaType      -- Both already zonked
         -> MonoBindInfo
         -> TcM (Scaled ABExport)
-- Only called for generalisation plan InferGen, not by CheckGen or NoGen
--
-- mkExport generates exports with
--      zonked type variables,
--      zonked poly_ids
-- The former is just because no further unifications will change
-- the quantified type variables, so we can fix their final form
-- right now.
-- The latter is needed because the poly_ids are used to extend the
-- type environment; see the invariant on GHC.Tc.Utils.Env.tcExtendIdEnv

-- Pre-condition: the qtvs and theta are already zonked

mkExport :: TcPragEnv
-> WantedConstraints
-> Bool
-> [TcId]
-> TcThetaType
-> MonoBindInfo
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled ABExport)
mkExport TcPragEnv
prag_fn WantedConstraints
residual Bool
insoluble [TcId]
qtvs TcThetaType
theta
         (MBI { mbi_poly_name :: MonoBindInfo -> Name
mbi_poly_name = Name
poly_name
              , mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig       = Maybe TcIdSigInst
mb_sig
              , mbi_mono_id :: MonoBindInfo -> TcId
mbi_mono_id   = TcId
mono_id
              , mbi_mono_mult :: MonoBindInfo -> Kind
mbi_mono_mult = Kind
mono_mult })
  = do  { Kind
mono_ty <- ZonkM Kind -> TcM Kind
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM Kind -> TcM Kind) -> ZonkM Kind -> TcM Kind
forall a b. (a -> b) -> a -> b
$ Kind -> ZonkM Kind
zonkTcType (TcId -> Kind
idType TcId
mono_id)
        ; TcId
poly_id <- WantedConstraints
-> Bool
-> [TcId]
-> TcThetaType
-> Name
-> Maybe TcIdSigInst
-> Kind
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
mkInferredPolyId WantedConstraints
residual Bool
insoluble [TcId]
qtvs TcThetaType
theta Name
poly_name Maybe TcIdSigInst
mb_sig Kind
mono_ty

        -- NB: poly_id has a zonked type
        ; TcId
poly_id <- TcId -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) TcId
addInlinePrags TcId
poly_id [LSig GhcRn]
prag_sigs
        ; [LTcSpecPrag]
spec_prags <- TcId -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
poly_id [LSig GhcRn]
prag_sigs
                -- tcPrags requires a zonked poly_id

        -- See Note [Impedance matching]
        -- NB: we have already done checkValidType, including an ambiguity check,
        --     on the type; either when we checked the sig or in mkInferredPolyId
        ; let poly_ty :: Kind
poly_ty     = TcId -> Kind
idType TcId
poly_id
              sel_poly_ty :: Kind
sel_poly_ty = [TcId] -> TcThetaType -> Kind -> Kind
HasDebugCallStack => [TcId] -> TcThetaType -> Kind -> Kind
mkInfSigmaTy [TcId]
qtvs TcThetaType
theta Kind
mono_ty
                -- This type is just going into tcSubType,
                -- so Inferred vs. Specified doesn't matter

        ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"mkExport" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
poly_ty
                                   , Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
sel_poly_ty ])

        ; HsWrapper
wrap <- if Kind
sel_poly_ty Kind -> Kind -> Bool
`eqType` Kind
poly_ty  -- NB: eqType ignores visibility
                  then HsWrapper -> TcM HsWrapper
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper  -- Fast path; also avoids complaint when we infer
                                           -- an ambiguous type and have AllowAmbiguousType
                                           -- e..g infer  x :: forall a. F a -> Int
                  else CtOrigin -> UserTypeCtxt -> Kind -> Kind -> TcM HsWrapper
tcSubTypeSigma (TcId -> CtOrigin
ImpedanceMatching TcId
poly_id)
                                      UserTypeCtxt
sig_ctxt Kind
sel_poly_ty Kind
poly_ty
                       -- See Note [Impedance matching]

        ; TcId -> Maybe TcIdSigInst -> IOEnv (Env TcGblEnv TcLclEnv) ()
localSigWarn TcId
poly_id Maybe TcIdSigInst
mb_sig

        ; Scaled ABExport -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled ABExport)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> ABExport -> Scaled ABExport
forall a. Kind -> a -> Scaled a
Scaled Kind
mono_mult (ABExport -> Scaled ABExport) -> ABExport -> Scaled ABExport
forall a b. (a -> b) -> a -> b
$
                  ABE { abe_wrap :: HsWrapper
abe_wrap = HsWrapper
wrap
                        -- abe_wrap :: (forall qtvs. theta => mono_ty) ~ idType poly_id
                      , abe_poly :: TcId
abe_poly  = TcId
poly_id
                      , abe_mono :: TcId
abe_mono  = TcId
mono_id
                      , abe_prags :: TcSpecPrags
abe_prags = [LTcSpecPrag] -> TcSpecPrags
SpecPrags [LTcSpecPrag]
spec_prags }) }
  where
    prag_sigs :: [LSig GhcRn]
prag_sigs = TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
poly_name
    sig_ctxt :: UserTypeCtxt
sig_ctxt  = Name -> UserTypeCtxt
InfSigCtxt Name
poly_name

mkInferredPolyId :: WantedConstraints   -- the residual constraints, already emitted
                 -> Bool  -- True <=> there was an insoluble error when
                          --          checking the binding group for this Id
                 -> [TyVar] -> TcThetaType
                 -> Name -> Maybe TcIdSigInst -> TcType
                 -> TcM TcId
mkInferredPolyId :: WantedConstraints
-> Bool
-> [TcId]
-> TcThetaType
-> Name
-> Maybe TcIdSigInst
-> Kind
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
mkInferredPolyId WantedConstraints
residual Bool
insoluble [TcId]
qtvs TcThetaType
inferred_theta Name
poly_name Maybe TcIdSigInst
mb_sig_inst Kind
mono_ty
  | Just (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSig
sig_inst_sig = TcIdSig
sig })  <- Maybe TcIdSigInst
mb_sig_inst
  , TcCompleteSig (CSig { sig_bndr :: TcCompleteSig -> TcId
sig_bndr = TcId
poly_id }) <- TcIdSig
sig
  = TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcId
poly_id

  | Bool
otherwise  -- Either no type sig or partial type sig
  = IOEnv (Env TcGblEnv TcLclEnv) TcId
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall r. TcM r -> TcM r
checkNoErrs (IOEnv (Env TcGblEnv TcLclEnv) TcId
 -> IOEnv (Env TcGblEnv TcLclEnv) TcId)
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall a b. (a -> b) -> a -> b
$  -- The checkNoErrs ensures that if the type is ambiguous
                   -- we don't carry on to the impedance matching, and generate
                   -- a duplicate ambiguity error.  There is a similar
                   -- checkNoErrs for complete type signatures too.
    do { FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
       ; let mono_ty' :: Kind
mono_ty' = Reduction -> Kind
reductionReducedType (Reduction -> Kind) -> Reduction -> Kind
forall a b. (a -> b) -> a -> b
$ FamInstEnvs -> Role -> Kind -> Reduction
normaliseType FamInstEnvs
fam_envs Role
Nominal Kind
mono_ty
               -- Unification may not have normalised the type,
               -- so do it here to make it as uncomplicated as possible.
               -- Example: f :: [F Int] -> Bool
               -- should be rewritten to f :: [Char] -> Bool, if possible
               --
               -- We can discard the coercion _co, because we'll reconstruct
               -- it in the call to tcSubType below

       ; ([VarBndr TcId Specificity]
binders, TcThetaType
theta') <- WantedConstraints
-> TcThetaType
-> VarSet
-> [TcId]
-> Maybe TcIdSigInst
-> TcM ([VarBndr TcId Specificity], TcThetaType)
chooseInferredQuantifiers WantedConstraints
residual TcThetaType
inferred_theta
                                (Kind -> VarSet
tyCoVarsOfType Kind
mono_ty') [TcId]
qtvs Maybe TcIdSigInst
mb_sig_inst

       ; let inferred_poly_ty :: Kind
inferred_poly_ty = [VarBndr TcId Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr TcId Specificity]
binders (TcThetaType -> Kind -> Kind
HasDebugCallStack => TcThetaType -> Kind -> Kind
mkPhiTy TcThetaType
theta' Kind
mono_ty')

       ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"mkInferredPolyId" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
poly_name, [TcId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcId]
qtvs, TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
theta'
                                          , Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
inferred_poly_ty
                                          , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"insoluble" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
insoluble ])

       ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
insoluble (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
         (TidyEnv -> ZonkM (TidyEnv, SDoc))
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (Name -> Kind -> TidyEnv -> ZonkM (TidyEnv, SDoc)
mk_inf_msg Name
poly_name Kind
inferred_poly_ty) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
         do { Kind -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkEscapingKind Kind
inferred_poly_ty
                 -- See Note [Inferred type with escaping kind]
            ; UserTypeCtxt -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkValidType (Name -> UserTypeCtxt
InfSigCtxt Name
poly_name) Kind
inferred_poly_ty }
                 -- See Note [Validity of inferred types]
         -- unless insoluble: if we found an insoluble error in the
         -- function definition, don't do this check; otherwise
         -- (#14000) we may report an ambiguity error for a rather
         -- bogus type.

       ; TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
poly_name Kind
ManyTy Kind
inferred_poly_ty) }


chooseInferredQuantifiers :: WantedConstraints  -- residual constraints
                          -> TcThetaType   -- inferred
                          -> TcTyVarSet    -- tvs free in tau type
                          -> [TcTyVar]     -- inferred quantified tvs
                          -> Maybe TcIdSigInst
                          -> TcM ([InvisTVBinder], TcThetaType)
chooseInferredQuantifiers :: WantedConstraints
-> TcThetaType
-> VarSet
-> [TcId]
-> Maybe TcIdSigInst
-> TcM ([VarBndr TcId Specificity], TcThetaType)
chooseInferredQuantifiers WantedConstraints
_residual TcThetaType
inferred_theta VarSet
tau_tvs [TcId]
qtvs Maybe TcIdSigInst
Nothing
  = -- No type signature (partial or complete) for this binder,
    do { let free_tvs :: VarSet
free_tvs = VarSet -> VarSet
closeOverKinds (TcThetaType -> VarSet -> VarSet
growThetaTyVars TcThetaType
inferred_theta VarSet
tau_tvs)
                        -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver
                        -- Include kind variables!  #7916
             my_theta :: TcThetaType
my_theta = VarSet -> TcThetaType -> TcThetaType
pickCapturedPreds VarSet
free_tvs TcThetaType
inferred_theta
             binders :: [VarBndr TcId Specificity]
binders  = [ Specificity -> TcId -> VarBndr TcId Specificity
forall vis. vis -> TcId -> VarBndr TcId vis
mkTyVarBinder Specificity
InferredSpec TcId
tv
                        | TcId
tv <- [TcId]
qtvs
                        , TcId
tv TcId -> VarSet -> Bool
`elemVarSet` VarSet
free_tvs ]
       ; ([VarBndr TcId Specificity], TcThetaType)
-> TcM ([VarBndr TcId Specificity], TcThetaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([VarBndr TcId Specificity]
binders, TcThetaType
my_theta) }

chooseInferredQuantifiers WantedConstraints
residual TcThetaType
inferred_theta VarSet
tau_tvs [TcId]
qtvs
    (Just (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSig
sig_inst_sig = TcIdSig
sig, sig_inst_wcx :: TcIdSigInst -> Maybe Kind
sig_inst_wcx = Maybe Kind
wcx
                , sig_inst_theta :: TcIdSigInst -> TcThetaType
sig_inst_theta = TcThetaType
annotated_theta, sig_inst_skols :: TcIdSigInst -> [(Name, VarBndr TcId Specificity)]
sig_inst_skols = [(Name, VarBndr TcId Specificity)]
annotated_tvs }))
  | TcPartialSig (PSig { psig_name :: TcPartialSig -> Name
psig_name = Name
fn_name, psig_hs_ty :: TcPartialSig -> LHsSigWcType GhcRn
psig_hs_ty = LHsSigWcType GhcRn
hs_ty }) <- TcIdSig
sig
  = -- Choose quantifiers for a partial type signature
    do { let ([Name]
psig_qtv_nms, [VarBndr TcId Specificity]
psig_qtv_bndrs) = [(Name, VarBndr TcId Specificity)]
-> ([Name], [VarBndr TcId Specificity])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, VarBndr TcId Specificity)]
annotated_tvs
       ; [VarBndr TcId Specificity]
psig_qtv_bndrs <- ZonkM [VarBndr TcId Specificity] -> TcM [VarBndr TcId Specificity]
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM [VarBndr TcId Specificity]
 -> TcM [VarBndr TcId Specificity])
-> ZonkM [VarBndr TcId Specificity]
-> TcM [VarBndr TcId Specificity]
forall a b. (a -> b) -> a -> b
$ (VarBndr TcId Specificity -> ZonkM (VarBndr TcId Specificity))
-> [VarBndr TcId Specificity] -> ZonkM [VarBndr TcId Specificity]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM VarBndr TcId Specificity -> ZonkM (VarBndr TcId Specificity)
forall spec. VarBndr TcId spec -> ZonkM (VarBndr TcId spec)
zonkInvisTVBinder [VarBndr TcId Specificity]
psig_qtv_bndrs
       ; let psig_qtvs :: [TcId]
psig_qtvs    = (VarBndr TcId Specificity -> TcId)
-> [VarBndr TcId Specificity] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map VarBndr TcId Specificity -> TcId
forall tv argf. VarBndr tv argf -> tv
binderVar [VarBndr TcId Specificity]
psig_qtv_bndrs
             psig_qtv_set :: VarSet
psig_qtv_set = [TcId] -> VarSet
mkVarSet [TcId]
psig_qtvs
             psig_qtv_prs :: [(Name, TcId)]
psig_qtv_prs = [Name]
psig_qtv_nms [Name] -> [TcId] -> [(Name, TcId)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcId]
psig_qtvs
             psig_bndr_map :: TyVarEnv InvisTVBinder
             psig_bndr_map :: TyVarEnv (VarBndr TcId Specificity)
psig_bndr_map = [(TcId, VarBndr TcId Specificity)]
-> TyVarEnv (VarBndr TcId Specificity)
forall a. [(TcId, a)] -> VarEnv a
mkVarEnv [ (VarBndr TcId Specificity -> TcId
forall tv argf. VarBndr tv argf -> tv
binderVar VarBndr TcId Specificity
tvb, VarBndr TcId Specificity
tvb) | VarBndr TcId Specificity
tvb <- [VarBndr TcId Specificity]
psig_qtv_bndrs ]

            -- Check whether the quantified variables of the
            -- partial signature have been unified together
            -- See Note [Quantified variables in partial type signatures]
       ; ((Name, Name) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [(Name, Name)] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> (Name, Name)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
report_dup_tyvar_tv_err Name
fn_name LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
hs_ty) ([(Name, Name)] -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [(Name, Name)] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
         [(Name, TcId)] -> [(Name, Name)]
findDupTyVarTvs [(Name, TcId)]
psig_qtv_prs

            -- Check whether a quantified variable of the partial type
            -- signature is not actually quantified.  How can that happen?
            -- See Note [Quantification and partial signatures] Wrinkle 4
            --     in GHC.Tc.Solver
       ; ((Name, TcId) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [(Name, TcId)] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> (Name, TcId)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
report_mono_sig_tv_err Name
fn_name LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
hs_ty)
         [ (Name, TcId)
pr | pr :: (Name, TcId)
pr@(Name
_,TcId
tv) <- [(Name, TcId)]
psig_qtv_prs, Bool -> Bool
not (TcId
tv TcId -> [TcId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TcId]
qtvs) ]

       ; TcThetaType
annotated_theta      <- ZonkM TcThetaType -> TcM TcThetaType
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM TcThetaType -> TcM TcThetaType)
-> ZonkM TcThetaType -> TcM TcThetaType
forall a b. (a -> b) -> a -> b
$ TcThetaType -> ZonkM TcThetaType
zonkTcTypes TcThetaType
annotated_theta
       ; (VarSet
free_tvs, TcThetaType
my_theta) <- VarSet -> TcThetaType -> Maybe Kind -> TcM (VarSet, TcThetaType)
choose_psig_context VarSet
psig_qtv_set TcThetaType
annotated_theta Maybe Kind
wcx
                                 -- NB: free_tvs includes tau_tvs

       ; let (VarSet
_,[VarBndr TcId Specificity]
final_qtvs) = (TcId
 -> (VarSet, [VarBndr TcId Specificity])
 -> (VarSet, [VarBndr TcId Specificity]))
-> (VarSet, [VarBndr TcId Specificity])
-> [TcId]
-> (VarSet, [VarBndr TcId Specificity])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TyVarEnv (VarBndr TcId Specificity)
-> TcId
-> (VarSet, [VarBndr TcId Specificity])
-> (VarSet, [VarBndr TcId Specificity])
choose_qtv TyVarEnv (VarBndr TcId Specificity)
psig_bndr_map) (VarSet
free_tvs, []) [TcId]
qtvs
                              -- Pulling from qtvs maintains original order
                              -- NB: qtvs is already in dependency order

       ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"chooseInferredQuantifiers" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"qtvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TcId] -> SDoc
pprTyVars [TcId]
qtvs
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"psig_qtv_bndrs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [VarBndr TcId Specificity] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [VarBndr TcId Specificity]
psig_qtv_bndrs
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"free_tvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarSet
free_tvs
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"final_tvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [VarBndr TcId Specificity] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [VarBndr TcId Specificity]
final_qtvs ]

       ; ([VarBndr TcId Specificity], TcThetaType)
-> TcM ([VarBndr TcId Specificity], TcThetaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([VarBndr TcId Specificity]
final_qtvs, TcThetaType
my_theta) }
  where
    choose_qtv :: TyVarEnv InvisTVBinder -> TcTyVar
             -> (TcTyVarSet, [InvisTVBinder]) -> (TcTyVarSet, [InvisTVBinder])
    -- Pick which of the original qtvs should be retained
    -- Keep it if (a) it is mentioned in the body of the type (free_tvs)
    --            (b) it is a forall'd variable of the partial signature (psig_qtv_bndrs)
    --            (c) it is mentioned in the kind of a retained qtv (#22065)
    choose_qtv :: TyVarEnv (VarBndr TcId Specificity)
-> TcId
-> (VarSet, [VarBndr TcId Specificity])
-> (VarSet, [VarBndr TcId Specificity])
choose_qtv TyVarEnv (VarBndr TcId Specificity)
psig_bndr_map TcId
tv (VarSet
free_tvs, [VarBndr TcId Specificity]
qtvs)
       | Just VarBndr TcId Specificity
psig_bndr <- TyVarEnv (VarBndr TcId Specificity)
-> TcId -> Maybe (VarBndr TcId Specificity)
forall a. VarEnv a -> TcId -> Maybe a
lookupVarEnv TyVarEnv (VarBndr TcId Specificity)
psig_bndr_map TcId
tv
       = (VarSet
free_tvs', VarBndr TcId Specificity
psig_bndr VarBndr TcId Specificity
-> [VarBndr TcId Specificity] -> [VarBndr TcId Specificity]
forall a. a -> [a] -> [a]
: [VarBndr TcId Specificity]
qtvs)
       | TcId
tv TcId -> VarSet -> Bool
`elemVarSet` VarSet
free_tvs
       = (VarSet
free_tvs', Specificity -> TcId -> VarBndr TcId Specificity
forall vis. vis -> TcId -> VarBndr TcId vis
mkTyVarBinder Specificity
InferredSpec TcId
tv VarBndr TcId Specificity
-> [VarBndr TcId Specificity] -> [VarBndr TcId Specificity]
forall a. a -> [a] -> [a]
: [VarBndr TcId Specificity]
qtvs)
       | Bool
otherwise  -- Do not pick it
       = (VarSet
free_tvs, [VarBndr TcId Specificity]
qtvs)
       where
         free_tvs' :: VarSet
free_tvs' = VarSet
free_tvs VarSet -> VarSet -> VarSet
`unionVarSet` Kind -> VarSet
tyCoVarsOfType (TcId -> Kind
tyVarKind TcId
tv)

    choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
                        -> TcM (VarSet, TcThetaType)
    choose_psig_context :: VarSet -> TcThetaType -> Maybe Kind -> TcM (VarSet, TcThetaType)
choose_psig_context VarSet
_ TcThetaType
annotated_theta Maybe Kind
Nothing
      = do { let free_tvs :: VarSet
free_tvs = VarSet -> VarSet
closeOverKinds (TcThetaType -> VarSet
tyCoVarsOfTypes TcThetaType
annotated_theta
                                            VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
tau_tvs)
           ; (VarSet, TcThetaType) -> TcM (VarSet, TcThetaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarSet
free_tvs, TcThetaType
annotated_theta) }

    choose_psig_context VarSet
psig_qtvs TcThetaType
annotated_theta (Just Kind
wc_var_ty)
      = do { let free_tvs :: VarSet
free_tvs = VarSet -> VarSet
closeOverKinds (TcThetaType -> VarSet -> VarSet
growThetaTyVars TcThetaType
inferred_theta VarSet
seed_tvs)
                            -- growThetaTyVars just like the no-type-sig case
                            -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver
                            -- Omitting this caused #12844
                 seed_tvs :: VarSet
seed_tvs = TcThetaType -> VarSet
tyCoVarsOfTypes TcThetaType
annotated_theta  -- These are put there
                            VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
tau_tvs            --       by the user

           ; let keep_me :: VarSet
keep_me  = VarSet
psig_qtvs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
free_tvs
                 my_theta :: TcThetaType
my_theta = VarSet -> TcThetaType -> TcThetaType
pickCapturedPreds VarSet
keep_me TcThetaType
inferred_theta

           -- Fill in the extra-constraints wildcard hole with inferred_theta,
           -- so that the Hole constraint we have already emitted
           -- (in tcHsPartialSigType) can report what filled it in.
           -- NB: my_theta already includes all the annotated constraints
           ; TcThetaType
diff_theta <- TcThetaType -> TcThetaType -> TcM TcThetaType
findInferredDiff TcThetaType
annotated_theta TcThetaType
my_theta

           ; case Kind -> Maybe (TcId, TcCoercionR)
getCastedTyVar_maybe Kind
wc_var_ty of
               -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it
               -- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc.
               -- So, to make the kinds work out, we reverse the cast here.
               Just (TcId
wc_var, TcCoercionR
wc_co) -> ZonkM () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> ZonkM () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
                                       HasDebugCallStack => TcId -> Kind -> ZonkM ()
TcId -> Kind -> ZonkM ()
writeMetaTyVar TcId
wc_var (TcThetaType -> Kind
mkConstraintTupleTy TcThetaType
diff_theta
                                                              Kind -> TcCoercionR -> Kind
`mkCastTy` TcCoercionR -> TcCoercionR
mkSymCo TcCoercionR
wc_co)
               Maybe (TcId, TcCoercionR)
Nothing              -> String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"chooseInferredQuantifiers 1" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
wc_var_ty)

           ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"completeTheta" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
                [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ TcIdSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSig
sig
                     , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"annotated_theta:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
annotated_theta
                     , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"inferred_theta:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
inferred_theta
                     , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"my_theta:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
my_theta
                     , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"diff_theta:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
diff_theta ]
           ; (VarSet, TcThetaType) -> TcM (VarSet, TcThetaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarSet
free_tvs, TcThetaType
annotated_theta TcThetaType -> TcThetaType -> TcThetaType
forall a. [a] -> [a] -> [a]
++ TcThetaType
diff_theta) }
             -- Return (annotated_theta ++ diff_theta)
             -- See Note [Extra-constraints wildcards]

    report_dup_tyvar_tv_err :: Name
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> (Name, Name)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
report_dup_tyvar_tv_err Name
fn_name HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
hs_ty (Name
n1,Name
n2)
      = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (Name -> Name -> Name -> LHsSigWcType GhcRn -> TcRnMessage
TcRnPartialTypeSigTyVarMismatch Name
n1 Name
n2 Name
fn_name LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
hs_ty)

    report_mono_sig_tv_err :: Name
-> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> (Name, TcId)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
report_mono_sig_tv_err Name
fn_name HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
hs_ty (Name
n,TcId
tv)
      = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc (Name -> Name -> Maybe Kind -> LHsSigWcType GhcRn -> TcRnMessage
TcRnPartialTypeSigBadQuantifier Name
n Name
fn_name Maybe Kind
m_unif_ty LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
hs_ty)
      where
        m_unif_ty :: Maybe Kind
m_unif_ty = TcThetaType -> Maybe Kind
forall a. [a] -> Maybe a
listToMaybe
                      [ Kind
rhs
                      -- recall that residuals are always implications
                      | Implication
residual_implic <- Bag Implication -> [Implication]
forall a. Bag a -> [a]
bagToList (Bag Implication -> [Implication])
-> Bag Implication -> [Implication]
forall a b. (a -> b) -> a -> b
$ WantedConstraints -> Bag Implication
wc_impl WantedConstraints
residual
                      , Ct
residual_ct <- Bag Ct -> [Ct]
forall a. Bag a -> [a]
bagToList (Bag Ct -> [Ct]) -> Bag Ct -> [Ct]
forall a b. (a -> b) -> a -> b
$ WantedConstraints -> Bag Ct
wc_simple (Implication -> WantedConstraints
ic_wanted Implication
residual_implic)
                      , let residual_pred :: Kind
residual_pred = Ct -> Kind
ctPred Ct
residual_ct
                      , Just (Role
Nominal, Kind
lhs, Kind
rhs) <- [ Kind -> Maybe (Role, Kind, Kind)
getEqPredTys_maybe Kind
residual_pred ]
                      , Just TcId
lhs_tv <- [ Kind -> Maybe TcId
getTyVar_maybe Kind
lhs ]
                      , TcId
lhs_tv TcId -> TcId -> Bool
forall a. Eq a => a -> a -> Bool
== TcId
tv ]

chooseInferredQuantifiers WantedConstraints
_ TcThetaType
_ VarSet
_ [TcId]
_ (Just TcIdSigInst
sig)
  = String -> SDoc -> TcM ([VarBndr TcId Specificity], TcThetaType)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"chooseInferredQuantifiers" (TcIdSigInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInst
sig)

mk_inf_msg :: Name -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc)
mk_inf_msg :: Name -> Kind -> TidyEnv -> ZonkM (TidyEnv, SDoc)
mk_inf_msg Name
poly_name Kind
poly_ty TidyEnv
tidy_env
 = do { (TidyEnv
tidy_env1, Kind
poly_ty) <- TidyEnv -> Kind -> ZonkM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
tidy_env Kind
poly_ty
      ; let msg :: SDoc
msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"When checking the inferred type"
                       , BKey -> SDoc -> SDoc
nest BKey
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
poly_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
poly_ty ]
      ; (TidyEnv, SDoc) -> ZonkM (TidyEnv, SDoc)
forall a. a -> ZonkM a
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
tidy_env1, SDoc
msg) }

-- | Warn the user about polymorphic local binders that lack type signatures.
localSigWarn :: Id -> Maybe TcIdSigInst -> TcM ()
localSigWarn :: TcId -> Maybe TcIdSigInst -> IOEnv (Env TcGblEnv TcLclEnv) ()
localSigWarn TcId
id Maybe TcIdSigInst
mb_sig
  | Just TcIdSigInst
_ <- Maybe TcIdSigInst
mb_sig               = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool -> Bool
not (Kind -> Bool
isSigmaTy (TcId -> Kind
idType TcId
id))    = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise                      = TcId -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnMissingSignatures TcId
id

warnMissingSignatures :: Id -> TcM ()
warnMissingSignatures :: TcId -> IOEnv (Env TcGblEnv TcLclEnv) ()
warnMissingSignatures TcId
id
  = do  { TidyEnv
env0 <- ZonkM TidyEnv -> TcM TidyEnv
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM TidyEnv -> TcM TidyEnv) -> ZonkM TidyEnv -> TcM TidyEnv
forall a b. (a -> b) -> a -> b
$ ZonkM TidyEnv
tcInitTidyEnv
        ; let (TidyEnv
env1, Kind
tidy_ty) = TidyEnv -> Kind -> (TidyEnv, Kind)
tidyOpenType TidyEnv
env0 (TcId -> Kind
idType TcId
id)
        ; let dia :: TcRnMessage
dia = Name -> Kind -> TcRnMessage
TcRnPolymorphicBinderMissingSig (TcId -> Name
idName TcId
id) Kind
tidy_ty
        ; (TidyEnv, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticTcM (TidyEnv
env1, TcRnMessage
dia) }

{- Note [Partial type signatures and generalisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If /any/ of the signatures in the group is a partial type signature
   f :: _ -> Int
then we *always* use the InferGen plan, and hence tcPolyInfer.
We do this even for a local binding with -XMonoLocalBinds, when
we normally use NoGen.

Reasons:
  * The TcSigInfo for 'f' has a unification variable for the '_',
    whose TcLevel is one level deeper than the current level.
    (See pushTcLevelM in tcTySig.)  But NoGen doesn't increase
    the TcLevel like InferGen, so we lose the level invariant.

  * The signature might be   f :: forall a. _ -> a
    so it really is polymorphic.  It's not clear what it would
    mean to use NoGen on this, and indeed the ASSERT in tcLhs,
    in the (Just sig) case, checks that if there is a signature
    then we are using LetLclBndr, and hence a nested AbsBinds with
    increased TcLevel

It might be possible to fix these difficulties somehow, but there
doesn't seem much point.  Indeed, adding a partial type signature is a
way to get per-binding inferred generalisation.

Note [Quantified variables in partial type signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  f :: forall a. a -> a -> _
  f x y = g x y
  g :: forall b. b -> b -> _
  g x y = [x, y]

Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b'
together, which is fine.  So we bind 'a' and 'b' to TyVarTvs, which can then
unify with each other.

But now consider:
  f :: forall a b. a -> b -> _
  f x y = [x, y]

We want to get an error from this, because 'a' and 'b' get unified.
So we make a test, one per partial signature, to check that the
explicitly-quantified type variables have not been unified together.
#14449 showed this up.

Note [Extra-constraints wildcards]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this from #18646
    class Foo x where
      foo :: x

    bar :: (Foo (), _) => f ()
    bar = pure foo

We get [W] Foo (), [W] Applicative f.   When we do pickCapturedPreds in
choose_psig_context, we'll discard Foo ()!  Usually would not quantify over
such (closed) predicates.  So my_theta will be (Applicative f). But we really
do want to quantify over (Foo ()) -- it was specified by the programmer.
Solution: always return annotated_theta (user-specified) plus the extra piece
diff_theta.

Note [Validity of inferred types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to check inferred type for validity, in case it uses language
extensions that are not turned on.  The principle is that if the user
simply adds the inferred type to the program source, it'll compile fine.
See #8883.

Examples that might fail:
 - the type might be ambiguous

 - an inferred theta that requires type equalities e.g. (F a ~ G b)
                                or multi-parameter type classes
 - an inferred type that includes unboxed tuples

Note [Inferred type with escaping kind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Check for an inferred type with an escaping kind; e.g. #23051
   forall {k} {f :: k -> RuntimeRep} {g :: k} {a :: TYPE (f g)}. a
where the kind of the body of the forall mentions `f` and `g` which
are bound by the forall.  No no no.

This check, mkInferredPolyId, is really in the wrong place:
`inferred_poly_ty` doesn't obey the PKTI and it would be better not to
generalise it in the first place; see #20686.  But for now it works.

I considered adjusting the generalisation in GHC.Tc.Solver to directly check for
escaping kind variables; instead, promoting or defaulting them. But that
gets into the defaulting swamp and is a non-trivial and unforced
change, so I have left it alone for now.

Note [Impedance matching]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   f 0 x = x
   f n x = g [] (not x)

   g [] y = f 10 y
   g _  y = f 9  y

After typechecking we'll get
  f_mono_ty :: a -> Bool -> Bool
  g_mono_ty :: [b] -> Bool -> Bool
with constraints
  (Eq a, Num a)

Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
The types we really want for f and g are
   f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
   g :: forall b. [b] -> Bool -> Bool

We can get these by "impedance matching":
   tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
   tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)

   f a d1 d2 = case tuple a Any d1 d2 of (f_mono, g_mono) -> f_mono
   g b = case tuple Integer b dEqInteger dNumInteger of (f_mono,g_mono) -> g_mono

Suppose the shared quantified tyvars are qtvs and constraints theta.
Then we want to check that
     forall qtvs. theta => f_mono_ty   is more polymorphic than   f's polytype
and the proof is the impedance matcher.

The impedance matcher can do defaulting: in the above example, we default
to Integer because of Num. See #7173. If we're dealing with a nondefaultable
class, impedance matching can fail. See #23427.

Note [SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~
There is no point in a SPECIALISE pragma for a non-overloaded function:
   reverse :: [a] -> [a]
   {-# SPECIALISE reverse :: [Int] -> [Int] #-}

But SPECIALISE INLINE *can* make sense for GADTS:
   data Arr e where
     ArrInt :: !Int -> ByteArray# -> Arr Int
     ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)

   (!:) :: Arr e -> Int -> e
   {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
   {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
   (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)
   (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)

When (!:) is specialised it becomes non-recursive, and can usefully
be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE
for a non-overloaded function.

************************************************************************
*                                                                      *
                         tcMonoBinds
*                                                                      *
************************************************************************

@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
The signatures have been dealt with already.
-}

data MonoBindInfo = MBI { MonoBindInfo -> Name
mbi_poly_name :: Name
                        , MonoBindInfo -> Maybe TcIdSigInst
mbi_sig       :: Maybe TcIdSigInst
                        , MonoBindInfo -> TcId
mbi_mono_id   :: TcId
                        , MonoBindInfo -> Kind
mbi_mono_mult :: Mult }

tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking purposes
                        -- i.e. the binders are mentioned in their RHSs, and
                        --      we are not rescued by a type signature
            -> TcSigFun -> LetBndrSpec
            -> [LHsBind GhcRn]
            -> TcM (LHsBinds GhcTc, [MonoBindInfo])

-- SPECIAL CASE 1: see Note [Special case for non-recursive function bindings]
tcMonoBinds :: RecFlag
-> TcSigFun
-> LetBndrSpec
-> [LHsBindLR GhcRn GhcRn]
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
tcMonoBinds RecFlag
is_rec TcSigFun
sig_fn LetBndrSpec
no_gen
           [ L SrcSpanAnnA
b_loc (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
nm_loc Name
name
                              , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
matches })]
                             -- Single function binding,
  | RecFlag
NonRecursive <- RecFlag
is_rec   -- ...binder isn't mentioned in RHS
  , Maybe TcSigInfo
Nothing <- TcSigFun
sig_fn Name
name   -- ...with no type signature
  = SrcSpanAnnA
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
b_loc    (TcM (LHsBinds GhcTc, [MonoBindInfo])
 -> TcM (LHsBinds GhcTc, [MonoBindInfo]))
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
forall a b. (a -> b) -> a -> b
$
    do  { Kind
mult <- HsMultAnn GhcRn -> TcM Kind
tcMultAnn (XNoMultAnn GhcRn -> HsMultAnn GhcRn
forall pass. XNoMultAnn pass -> HsMultAnn pass
HsNoMultAnn NoExtField
XNoMultAnn GhcRn
noExtField)

        ; ((HsWrapper
co_fn, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches'), Kind
rhs_ty')
            <- FixedRuntimeRepContext
-> (ExpSigmaType
    -> TcM
         (HsWrapper,
          MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
     ((HsWrapper,
       MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
      Kind)
forall a.
FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, Kind)
tcInferFRR (Name -> FixedRuntimeRepContext
FRRBinder Name
name) ((ExpSigmaType
  -> TcM
       (HsWrapper,
        MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
 -> TcM
      ((HsWrapper,
        MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
       Kind))
-> (ExpSigmaType
    -> TcM
         (HsWrapper,
          MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM
     ((HsWrapper,
       MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))),
      Kind)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
                 -- tcInferFRR: the type of a let-binder must have
                 -- a fixed runtime rep. See #23176
               [TcBinder]
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [Name -> ExpSigmaType -> TopLevelFlag -> TcBinder
TcIdBndr_ExpType Name
name ExpSigmaType
exp_ty TopLevelFlag
NotTopLevel] (TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
 -> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
                 -- We extend the error context even for a non-recursive
                 -- function so that in type error messages we show the
                 -- type of the thing whose rhs we are type checking.
                 -- See Note [Relevant bindings and the binder stack]
               UserTypeCtxt
-> Name
-> Kind
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpSigmaType
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcFunBindMatches (Name -> UserTypeCtxt
InfSigCtxt Name
name) Name
name Kind
mult MatchGroup GhcRn (LHsExpr GhcRn)
matches [] ExpSigmaType
exp_ty
       ; TcId
mono_id <- LetBndrSpec
-> Name -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newLetBndr LetBndrSpec
no_gen Name
name Kind
mult Kind
rhs_ty'

        ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [MonoBindInfo])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [MonoBindInfo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
 -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
b_loc (HsBindLR GhcTc GhcTc
 -> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$
                     FunBind { fun_id :: LIdP GhcTc
fun_id      = SrcSpanAnnN -> TcId -> GenLocated SrcSpanAnnN TcId
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nm_loc TcId
mono_id,
                               fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches',
                               fun_ext :: XFunBind GhcTc GhcTc
fun_ext     = (HsWrapper
co_fn, []) },
                  [MBI { mbi_poly_name :: Name
mbi_poly_name = Name
name
                       , mbi_sig :: Maybe TcIdSigInst
mbi_sig       = Maybe TcIdSigInst
forall a. Maybe a
Nothing
                       , mbi_mono_id :: TcId
mbi_mono_id   = TcId
mono_id
                       , mbi_mono_mult :: Kind
mbi_mono_mult = Kind
mult }]) }

-- SPECIAL CASE 2: see Note [Special case for non-recursive pattern bindings]
tcMonoBinds RecFlag
is_rec TcSigFun
sig_fn LetBndrSpec
no_gen
           [L SrcSpanAnnA
b_loc (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = XRec GhcRn (Pat GhcRn)
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcRn (LHsExpr GhcRn)
grhss, pat_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_mult = HsMultAnn GhcRn
mult_ann })]
  | RecFlag
NonRecursive <- RecFlag
is_rec   -- ...binder isn't mentioned in RHS
  , (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe TcSigInfo -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe TcSigInfo -> Bool) -> TcSigFun -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcSigFun
sig_fn) [IdP GhcRn]
[Name]
bndrs
  = SDoc
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (XRec GhcRn (Pat GhcRn) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt XRec GhcRn (Pat GhcRn)
pat GRHSs GhcRn (LHsExpr GhcRn)
grhss) (TcM (LHsBinds GhcTc, [MonoBindInfo])
 -> TcM (LHsBinds GhcTc, [MonoBindInfo]))
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
-> TcM (LHsBinds GhcTc, [MonoBindInfo])
forall a b. (a -> b) -> a -> b
$
    do { Kind
mult <- HsMultAnn GhcRn -> TcM Kind
tcMultAnn HsMultAnn GhcRn
mult_ann

       ; (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss', Kind
pat_ty) <- FixedRuntimeRepContext
-> (ExpSigmaType
    -> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), Kind)
forall a.
FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, Kind)
tcInferFRR FixedRuntimeRepContext
FRRPatBind ((ExpSigmaType
  -> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
 -> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), Kind))
-> (ExpSigmaType
    -> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> TcM (GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)), Kind)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
                          -- tcInferFRR: the type of each let-binder must have
                          -- a fixed runtime rep. See #23176
                             Kind
-> GRHSs GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat Kind
mult GRHSs GhcRn (LHsExpr GhcRn)
grhss ExpSigmaType
exp_ty

       ; let exp_pat_ty :: Scaled ExpSigmaTypeFRR
             exp_pat_ty :: Scaled ExpSigmaType
exp_pat_ty = Kind -> ExpSigmaType -> Scaled ExpSigmaType
forall a. Kind -> a -> Scaled a
Scaled Kind
mult (Kind -> ExpSigmaType
mkCheckExpType Kind
pat_ty)
       ; (UsageEnv
_, (GenLocated SrcSpanAnnA (Pat GhcTc)
pat', [MonoBindInfo]
mbis)) <- TcM (GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo])
-> TcM
     (UsageEnv, (GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]))
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo])
 -> TcM
      (UsageEnv, (GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo])))
-> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo])
-> TcM
     (UsageEnv, (GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]))
forall a b. (a -> b) -> a -> b
$
                         (Name -> Maybe TcId)
-> LetBndrSpec
-> XRec GhcRn (Pat GhcRn)
-> Scaled ExpSigmaType
-> TcM [MonoBindInfo]
-> TcM (LPat GhcTc, [MonoBindInfo])
forall a.
(Name -> Maybe TcId)
-> LetBndrSpec
-> XRec GhcRn (Pat GhcRn)
-> Scaled ExpSigmaType
-> TcM a
-> TcM (LPat GhcTc, a)
tcLetPat (Maybe TcId -> Name -> Maybe TcId
forall a b. a -> b -> a
const Maybe TcId
forall a. Maybe a
Nothing) LetBndrSpec
no_gen XRec GhcRn (Pat GhcRn)
pat Scaled ExpSigmaType
exp_pat_ty (TcM [MonoBindInfo] -> TcM (LPat GhcTc, [MonoBindInfo]))
-> TcM [MonoBindInfo] -> TcM (LPat GhcTc, [MonoBindInfo])
forall a b. (a -> b) -> a -> b
$ do
                           UsageEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcEmitBindingUsage UsageEnv
bottomUE
                           (Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo)
-> [Name] -> TcM [MonoBindInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
lookupMBI [IdP GhcRn]
[Name]
bndrs
            -- What's happening here? Typing pattern-matching (either from case
            -- expression or equation) and typing bindings (let or where) have a
            -- different control flow: for pattern-matching, the rhs is typed
            -- within the `thing_inside` argument. The type-checker walks down
            -- the pattern, and when finally it is done, all variables have been
            -- added to the environment, thing_inside is called. So, when
            -- type-checking patterns, the check for the correctness of
            -- multiplicity is generated in the VarPat case. This is quite
            -- natural.
            --
            -- Bindings, however, have a more complex control flow for our
            -- purpose: we collect all the variables as we go down, then return
            -- them (here as `mapM lookupMBI bndrs`), and in a subsequent
            -- computation (rather than an inner computation), the rhs is
            -- type-checked. This poses a problem here: we're calling
            -- `tcLetPat`, which will verify the proper usage of the introduced
            -- variable when reaching the `VarPat` case. But there is no actual
            -- usage of variable in the `thing_inside`. This would always
            -- fail. So we emit a `bottomUE`, which is compatible with every
            -- usage. So that we can bypass the check in VarPat. Then we use
            -- `tcCollectingUsage` to throw the `bottomUE` away, since it would
            -- let us bypass many linearity checks.

       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [MonoBindInfo])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [MonoBindInfo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. a -> Bag a
unitBag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
 -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
b_loc (HsBindLR GhcTc GhcTc
 -> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> HsBindLR GhcTc GhcTc
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$
                     PatBind { pat_lhs :: LPat GhcTc
pat_lhs = LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat', pat_rhs :: GRHSs GhcTc (LHsExpr GhcTc)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss'
                             , pat_ext :: XPatBind GhcTc GhcTc
pat_ext = (Kind
pat_ty, ([],[]))
                             , pat_mult :: HsMultAnn GhcTc
pat_mult = Kind -> HsMultAnn GhcRn -> HsMultAnn GhcTc
setTcMultAnn Kind
mult HsMultAnn GhcRn
mult_ann }

                , [MonoBindInfo]
mbis ) }
  where
    bndrs :: [IdP GhcRn]
bndrs = CollectFlag GhcRn -> XRec GhcRn (Pat GhcRn) -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders XRec GhcRn (Pat GhcRn)
pat

-- GENERAL CASE
tcMonoBinds RecFlag
_ TcSigFun
sig_fn LetBndrSpec
no_gen [LHsBindLR GhcRn GhcRn]
binds
  = do  { [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds <- (GenLocated SrcSpanAnnA (HsBind GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA TcMonoBind))
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [GenLocated SrcSpanAnnA TcMonoBind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((HsBind GhcRn -> TcM TcMonoBind)
-> GenLocated SrcSpanAnnA (HsBind GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA TcMonoBind)
forall a b ann.
(a -> TcM b)
-> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA (TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen)) [LHsBindLR GhcRn GhcRn]
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
binds

        -- Bring the monomorphic Ids, into scope for the RHSs
        ; let mono_infos :: [MonoBindInfo]
mono_infos = [GenLocated SrcSpanAnnA TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds
              rhs_id_env :: [(Name, TcId)]
rhs_id_env = [ (Name
name, TcId
mono_id)
                           | MBI { mbi_poly_name :: MonoBindInfo -> Name
mbi_poly_name = Name
name
                                 , mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig       = Maybe TcIdSigInst
mb_sig
                                 , mbi_mono_id :: MonoBindInfo -> TcId
mbi_mono_id   = TcId
mono_id } <- [MonoBindInfo]
mono_infos
                           , case Maybe TcIdSigInst
mb_sig of
                               Just TcIdSigInst
sig -> TcIdSigInst -> Bool
isPartialSig TcIdSigInst
sig
                               Maybe TcIdSigInst
Nothing  -> Bool
True ]
                -- A monomorphic binding for each term variable that lacks
                -- a complete type sig.  (Ones with a sig are already in scope.)

        ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcMonoBinds" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
idType TcId
id)
                                       | (Name
n,TcId
id) <- [(Name, TcId)]
rhs_id_env]
        ; [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds' <- [(Name, TcId)]
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. [(Name, TcId)] -> TcM a -> TcM a
tcExtendRecIds [(Name, TcId)]
rhs_id_env (TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
 -> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)])
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a b. (a -> b) -> a -> b
$
                    (GenLocated SrcSpanAnnA TcMonoBind
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> [GenLocated SrcSpanAnnA TcMonoBind]
-> TcM [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((TcMonoBind -> TcM (HsBindLR GhcTc GhcTc))
-> GenLocated SrcSpanAnnA TcMonoBind
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a b ann.
(a -> TcM b)
-> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA TcMonoBind -> TcM (HsBindLR GhcTc GhcTc)
tcRhs) [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds

        ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
 [MonoBindInfo])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
      [MonoBindInfo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds', [MonoBindInfo]
mono_infos) }

{- Note [Special case for non-recursive function bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the special case of
* A non-recursive FunBind
* With no type signature
we infer the type of the right hand side first (it may have a
higher-rank type) and *then* make the monomorphic Id for the LHS e.g.
   f = \(x::forall a. a->a) -> <body>

We want to infer a higher-rank type for f

Note [Special case for non-recursive pattern bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the special case of
* A pattern binding
* With no type signature for any of the binders
we can /infer/ the type of the RHS, and /check/ the pattern
against that type.  For example (#18323)

  ids :: [forall a. a -> a]
  combine :: (forall a . [a] -> a) -> [forall a. a -> a]
          -> ((forall a . [a] -> a), [forall a. a -> a])

  (x,y) = combine head ids

with -XImpredicativeTypes we can infer a good type for
(combine head ids), and use that to tell us the polymorphic
types of x and y.

We don't need to check -XImpredicativeTypes because without it
these types like [forall a. a->a] are illegal anyway, so this
special case code only really has an effect if -XImpredicativeTypes
is on.  Small exception:
  (x) = e
is currently treated as a pattern binding so, even absent
-XImpredicativeTypes, we will get a small improvement in behaviour.
But I don't think it's worth an extension flag.

Why do we require no type signatures on /any/ of the binders?
Consider
   x :: forall a. a->a
   y :: forall a. a->a
   (x,y) = (id,id)

Here we should /check/ the RHS with expected type
  (forall a. a->a, forall a. a->a).

If we have no signatures, we can the approach of this Note
to /infer/ the type of the RHS.

But what if we have some signatures, but not all? Say this:
  p :: forall a. a->a
  (p,q) = (id,  (\(x::forall b. b->b). x True))

Here we want to push p's signature inwards, i.e. /checking/, to
correctly elaborate 'id'. But we want to /infer/ q's higher rank
type.  There seems to be no way to do this.  So currently we only
switch to inference when we have no signature for any of the binders.

-}


------------------------
-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
-- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
--      if there's a signature for it, use the instantiated signature type
--      otherwise invent a type variable
-- You see that quite directly in the FunBind case.
--
-- But there's a complication for pattern bindings:
--      data T = MkT (forall a. a->a)
--      MkT f = e
-- Here we can guess a type variable for the entire LHS (which will be refined to T)
-- but we want to get (f::forall a. a->a) as the RHS environment.
-- The simplest way to do this is to typecheck the pattern, and then look up the
-- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't

data TcMonoBind         -- Half completed; LHS done, RHS not done
  = TcFunBind  MonoBindInfo  SrcSpan Mult (MatchGroup GhcRn (LHsExpr GhcRn))
  | TcPatBind [MonoBindInfo] (LPat GhcTc) Mult (HsMultAnn GhcRn) (GRHSs GhcRn (LHsExpr GhcRn))
              TcSigmaTypeFRR

tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
-- Only called with plan InferGen (LetBndrSpec = LetLclBndr)
--                    or NoGen    (LetBndrSpec = LetGblBndr)
-- CheckGen is used only for functions with a complete type signature,
--          and tcPolyCheck doesn't use tcMonoBinds at all

tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
nm_loc Name
name
                             , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
matches })
  | Just (TcIdSig TcIdSig
sig) <- TcSigFun
sig_fn Name
name
  = -- There is a type signature.
    -- It must be partial; if complete we'd be in tcPolyCheck!
    --    e.g.   f :: _ -> _
    --           f x = ...g...
    --           Just g = ...f...
    -- Hence always typechecked with InferGen
    do { MonoBindInfo
mono_info <- LetBndrSpec
-> (Name, TcIdSig) -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen (Name
name, TcIdSig
sig)
       ; Kind
mult <- HsMultAnn GhcRn -> TcM Kind
tcMultAnn (XNoMultAnn GhcRn -> HsMultAnn GhcRn
forall pass. XNoMultAnn pass -> HsMultAnn pass
HsNoMultAnn NoExtField
XNoMultAnn GhcRn
noExtField)
       ; TcMonoBind -> TcM TcMonoBind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MonoBindInfo
-> SrcSpan
-> Kind
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> TcMonoBind
TcFunBind MonoBindInfo
mono_info (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
nm_loc) Kind
mult MatchGroup GhcRn (LHsExpr GhcRn)
matches) }

  | Bool
otherwise  -- No type signature
  = do { Kind
mono_ty <- TcM Kind
newOpenFlexiTyVarTy
       ; Kind
mult <- HsMultAnn GhcRn -> TcM Kind
tcMultAnn (XNoMultAnn GhcRn -> HsMultAnn GhcRn
forall pass. XNoMultAnn pass -> HsMultAnn pass
HsNoMultAnn NoExtField
XNoMultAnn GhcRn
noExtField)
       ; TcId
mono_id <- LetBndrSpec
-> Name -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newLetBndr LetBndrSpec
no_gen Name
name Kind
mult Kind
mono_ty
       ; let mono_info :: MonoBindInfo
mono_info = MBI { mbi_poly_name :: Name
mbi_poly_name = Name
name
                             , mbi_sig :: Maybe TcIdSigInst
mbi_sig       = Maybe TcIdSigInst
forall a. Maybe a
Nothing
                             , mbi_mono_id :: TcId
mbi_mono_id   = TcId
mono_id
                             , mbi_mono_mult :: Kind
mbi_mono_mult = Kind
mult}
       ; TcMonoBind -> TcM TcMonoBind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MonoBindInfo
-> SrcSpan
-> Kind
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> TcMonoBind
TcFunBind MonoBindInfo
mono_info (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
nm_loc) Kind
mult MatchGroup GhcRn (LHsExpr GhcRn)
matches) }

tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = XRec GhcRn (Pat GhcRn)
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcRn (LHsExpr GhcRn)
grhss, pat_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_mult = HsMultAnn GhcRn
mult_ann })
  = -- See Note [Typechecking pattern bindings]
    do  { [MonoBindInfo]
sig_mbis <- ((Name, TcIdSig) -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo)
-> [(Name, TcIdSig)] -> TcM [MonoBindInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (LetBndrSpec
-> (Name, TcIdSig) -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen) [(Name, TcIdSig)]
sig_names

        ; let inst_sig_fun :: Name -> Maybe TcId
inst_sig_fun = NameEnv TcId -> Name -> Maybe TcId
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (NameEnv TcId -> Name -> Maybe TcId)
-> NameEnv TcId -> Name -> Maybe TcId
forall a b. (a -> b) -> a -> b
$ [(Name, TcId)] -> NameEnv TcId
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, TcId)] -> NameEnv TcId) -> [(Name, TcId)] -> NameEnv TcId
forall a b. (a -> b) -> a -> b
$
                             [ (MonoBindInfo -> Name
mbi_poly_name MonoBindInfo
mbi, MonoBindInfo -> TcId
mbi_mono_id MonoBindInfo
mbi)
                             | MonoBindInfo
mbi <- [MonoBindInfo]
sig_mbis ]
        ; Kind
mult <- HsMultAnn GhcRn -> TcM Kind
tcMultAnn HsMultAnn GhcRn
mult_ann
            -- See Note [Typechecking pattern bindings]
        ; ((GenLocated SrcSpanAnnA (Pat GhcTc)
pat', [MonoBindInfo]
nosig_mbis), Kind
pat_ty)
            <- SDoc
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (XRec GhcRn (Pat GhcRn) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt XRec GhcRn (Pat GhcRn)
pat GRHSs GhcRn (LHsExpr GhcRn)
grhss) (TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
 -> TcM
      ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
forall a b. (a -> b) -> a -> b
$
               FixedRuntimeRepContext
-> (ExpSigmaType
    -> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
forall a.
FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, Kind)
tcInferFRR FixedRuntimeRepContext
FRRPatBind ((ExpSigmaType
  -> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]))
 -> TcM
      ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind))
-> (ExpSigmaType
    -> TcM (GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]))
-> TcM ((GenLocated SrcSpanAnnA (Pat GhcTc), [MonoBindInfo]), Kind)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
               (Name -> Maybe TcId)
-> LetBndrSpec
-> XRec GhcRn (Pat GhcRn)
-> Scaled ExpSigmaType
-> TcM [MonoBindInfo]
-> TcM (LPat GhcTc, [MonoBindInfo])
forall a.
(Name -> Maybe TcId)
-> LetBndrSpec
-> XRec GhcRn (Pat GhcRn)
-> Scaled ExpSigmaType
-> TcM a
-> TcM (LPat GhcTc, a)
tcLetPat Name -> Maybe TcId
inst_sig_fun LetBndrSpec
no_gen XRec GhcRn (Pat GhcRn)
pat (Kind -> ExpSigmaType -> Scaled ExpSigmaType
forall a. Kind -> a -> Scaled a
Scaled Kind
mult ExpSigmaType
exp_ty) (TcM [MonoBindInfo] -> TcM (LPat GhcTc, [MonoBindInfo]))
-> TcM [MonoBindInfo] -> TcM (LPat GhcTc, [MonoBindInfo])
forall a b. (a -> b) -> a -> b
$
                 -- The above inferred type get an unrestricted multiplicity. It may be
                 -- worth it to try and find a finer-grained multiplicity here
                 -- if examples warrant it.
               (Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo)
-> [Name] -> TcM [MonoBindInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
lookupMBI [Name]
nosig_names

        ; let mbis :: [MonoBindInfo]
mbis = [MonoBindInfo]
sig_mbis [MonoBindInfo] -> [MonoBindInfo] -> [MonoBindInfo]
forall a. [a] -> [a] -> [a]
++ [MonoBindInfo]
nosig_mbis

        ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcLhs" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
idType TcId
id)
                                | MonoBindInfo
mbi <- [MonoBindInfo]
mbis, let id :: TcId
id = MonoBindInfo -> TcId
mbi_mono_id MonoBindInfo
mbi ]
                           SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ LetBndrSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr LetBndrSpec
no_gen)

        ; TcMonoBind -> TcM TcMonoBind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([MonoBindInfo]
-> LPat GhcTc
-> Kind
-> HsMultAnn GhcRn
-> GRHSs GhcRn (LHsExpr GhcRn)
-> Kind
-> TcMonoBind
TcPatBind [MonoBindInfo]
mbis LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' Kind
mult HsMultAnn GhcRn
mult_ann GRHSs GhcRn (LHsExpr GhcRn)
grhss Kind
pat_ty) }
  where
    bndr_names :: [IdP GhcRn]
bndr_names = CollectFlag GhcRn -> XRec GhcRn (Pat GhcRn) -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders XRec GhcRn (Pat GhcRn)
pat
    ([Name]
nosig_names, [(Name, TcIdSig)]
sig_names) = (Name -> Either Name (Name, TcIdSig))
-> [Name] -> ([Name], [(Name, TcIdSig)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith Name -> Either Name (Name, TcIdSig)
find_sig [IdP GhcRn]
[Name]
bndr_names

    find_sig :: Name -> Either Name (Name, TcIdSig)
    find_sig :: Name -> Either Name (Name, TcIdSig)
find_sig Name
name = case TcSigFun
sig_fn Name
name of
                      Just (TcIdSig TcIdSig
sig) -> (Name, TcIdSig) -> Either Name (Name, TcIdSig)
forall a b. b -> Either a b
Right (Name
name, TcIdSig
sig)
                      Maybe TcSigInfo
_                  -> Name -> Either Name (Name, TcIdSig)
forall a b. a -> Either a b
Left Name
name

tcLhs TcSigFun
_ LetBndrSpec
_ b :: HsBind GhcRn
b@(PatSynBind {}) = String -> SDoc -> TcM TcMonoBind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLhs: PatSynBind" (HsBind GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBind GhcRn
b)
  -- pattern synonyms are handled separately; see tc_single

tcLhs TcSigFun
_ LetBndrSpec
_ (VarBind { var_ext :: forall idL idR. HsBindLR idL idR -> XVarBind idL idR
var_ext = XVarBind GhcRn GhcRn
x }) = DataConCantHappen -> TcM TcMonoBind
forall a. DataConCantHappen -> a
dataConCantHappen XVarBind GhcRn GhcRn
DataConCantHappen
x

lookupMBI :: Name -> TcM MonoBindInfo
-- After typechecking the pattern, look up the binder
-- names that lack a signature, which the pattern has brought
-- into scope.
lookupMBI :: Name -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
lookupMBI Name
name
  = do { TcId
mono_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId
tcLookupId Name
name
       ; MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MBI { mbi_poly_name :: Name
mbi_poly_name = Name
name
                     , mbi_sig :: Maybe TcIdSigInst
mbi_sig       = Maybe TcIdSigInst
forall a. Maybe a
Nothing
                     , mbi_mono_id :: TcId
mbi_mono_id   = TcId
mono_id
                     , mbi_mono_mult :: Kind
mbi_mono_mult = TcId -> Kind
idMult TcId
mono_id }) }

-------------------
tcLhsSigId :: LetBndrSpec -> (Name, TcIdSig) -> TcM MonoBindInfo
tcLhsSigId :: LetBndrSpec
-> (Name, TcIdSig) -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen (Name
name, TcIdSig
sig)
  = do { TcIdSigInst
inst_sig <- TcIdSig -> TcM TcIdSigInst
tcInstSig TcIdSig
sig
       ; TcId
mono_id <- LetBndrSpec
-> Name -> TcIdSigInst -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newSigLetBndr LetBndrSpec
no_gen Name
name TcIdSigInst
inst_sig
       ; MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) MonoBindInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MBI { mbi_poly_name :: Name
mbi_poly_name = Name
name
                     , mbi_sig :: Maybe TcIdSigInst
mbi_sig       = TcIdSigInst -> Maybe TcIdSigInst
forall a. a -> Maybe a
Just TcIdSigInst
inst_sig
                     , mbi_mono_id :: TcId
mbi_mono_id   = TcId
mono_id
                     , mbi_mono_mult :: Kind
mbi_mono_mult = TcId -> Kind
idMult TcId
mono_id }) }

------------
newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
newSigLetBndr :: LetBndrSpec
-> Name -> TcIdSigInst -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newSigLetBndr (LetGblBndr TcPragEnv
prags) Name
name (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSig
sig_inst_sig = TcIdSig
id_sig })
  | TcCompleteSig (CSig { sig_bndr :: TcCompleteSig -> TcId
sig_bndr = TcId
poly_id }) <- TcIdSig
id_sig
  = TcId -> [LSig GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) TcId
addInlinePrags TcId
poly_id (TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prags Name
name)
newSigLetBndr LetBndrSpec
no_gen Name
name (TISI { sig_inst_tau :: TcIdSigInst -> Kind
sig_inst_tau = Kind
tau })
  = LetBndrSpec
-> Name -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newLetBndr LetBndrSpec
no_gen Name
name Kind
ManyTy Kind
tau
    -- Binders with a signature are currently always of multiplicity
    -- Many. Because they come either from toplevel, let, or where
    -- declarations. Which are all unrestricted currently.

-------------------
tcRhs :: TcMonoBind -> TcM (HsBind GhcTc)
tcRhs :: TcMonoBind -> TcM (HsBindLR GhcTc GhcTc)
tcRhs (TcFunBind info :: MonoBindInfo
info@(MBI { mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Maybe TcIdSigInst
mb_sig, mbi_mono_id :: MonoBindInfo -> TcId
mbi_mono_id = TcId
mono_id })
                 SrcSpan
loc Kind
mult MatchGroup GhcRn (LHsExpr GhcRn)
matches)
  = [MonoBindInfo]
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a. [MonoBindInfo] -> TcM a -> TcM a
tcExtendIdBinderStackForRhs [MonoBindInfo
info]  (TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc))
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$
    Maybe TcIdSigInst
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a. Maybe TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvForRhs Maybe TcIdSigInst
mb_sig       (TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc))
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { let mono_ty :: Kind
mono_ty = TcId -> Kind
idType TcId
mono_id
              mono_name :: Name
mono_name = TcId -> Name
idName TcId
mono_id
        ; String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcRhs: fun bind" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
mono_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
mono_ty)
        ; (HsWrapper
co_fn, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches') <- UserTypeCtxt
-> Name
-> Kind
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> [ExpPatType]
-> ExpSigmaType
-> TcRn (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcFunBindMatches (Name -> UserTypeCtxt
InfSigCtxt Name
mono_name) Name
mono_name Kind
mult
                                                MatchGroup GhcRn (LHsExpr GhcRn)
matches [] (Kind -> ExpSigmaType
mkCheckExpType Kind
mono_ty)
        ; HsBindLR GhcTc GhcTc -> TcM (HsBindLR GhcTc GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( FunBind { fun_id :: LIdP GhcTc
fun_id      = SrcSpanAnnN -> TcId -> GenLocated SrcSpanAnnN TcId
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) TcId
mono_id
                           , fun_matches :: MatchGroup GhcTc (LHsExpr GhcTc)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches'
                           , fun_ext :: XFunBind GhcTc GhcTc
fun_ext     = (HsWrapper
co_fn, [])
                           } ) }

tcRhs (TcPatBind [MonoBindInfo]
infos LPat GhcTc
pat' Kind
mult HsMultAnn GhcRn
mult_ann GRHSs GhcRn (LHsExpr GhcRn)
grhss Kind
pat_ty)
  = -- When we are doing pattern bindings we *don't* bring any scoped
    -- type variables into scope unlike function bindings
    -- Wny not?  They are not completely rigid.
    -- That's why we have the special case for a single FunBind in tcMonoBinds
    [MonoBindInfo]
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a. [MonoBindInfo] -> TcM a -> TcM a
tcExtendIdBinderStackForRhs [MonoBindInfo]
infos        (TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc))
-> TcM (HsBindLR GhcTc GhcTc) -> TcM (HsBindLR GhcTc GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcRhs: pat bind" (GenLocated SrcSpanAnnA (Pat GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat' SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
pat_ty)
        ; GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss' <- SDoc
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LPat GhcTc -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt LPat GhcTc
pat' GRHSs GhcRn (LHsExpr GhcRn)
grhss) (TcM (GRHSs GhcTc (LHsExpr GhcTc))
 -> TcM (GRHSs GhcTc (LHsExpr GhcTc)))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
                    Kind
-> GRHSs GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
tcGRHSsPat Kind
mult GRHSs GhcRn (LHsExpr GhcRn)
grhss (Kind -> ExpSigmaType
mkCheckExpType Kind
pat_ty)

        ; HsBindLR GhcTc GhcTc -> TcM (HsBindLR GhcTc GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( PatBind { pat_lhs :: LPat GhcTc
pat_lhs = LPat GhcTc
pat', pat_rhs :: GRHSs GhcTc (LHsExpr GhcTc)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss'
                           , pat_ext :: XPatBind GhcTc GhcTc
pat_ext = (Kind
pat_ty, ([],[]))
                           , pat_mult :: HsMultAnn GhcTc
pat_mult = Kind -> HsMultAnn GhcRn -> HsMultAnn GhcTc
setTcMultAnn Kind
mult HsMultAnn GhcRn
mult_ann } )}


-- | @'tcMultAnn' ann@ takes an optional multiplicity annotation. If
-- present the multiplicity is returned, otherwise a fresh unification variable
-- is generated so that multiplicity can be inferred.
tcMultAnn :: HsMultAnn GhcRn -> TcM Mult
tcMultAnn :: HsMultAnn GhcRn -> TcM Kind
tcMultAnn (HsPct1Ann XPct1Ann GhcRn
_) = Kind -> TcM Kind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
oneDataConTy
tcMultAnn (HsMultAnn XMultAnn GhcRn
_ LHsType (NoGhcTc GhcRn)
p) = LHsType GhcRn -> ContextKind -> TcM Kind
tcCheckLHsType LHsType (NoGhcTc GhcRn)
LHsType GhcRn
p (Kind -> ContextKind
TheKind Kind
multiplicityTy)
tcMultAnn (HsNoMultAnn XNoMultAnn GhcRn
_) = Kind -> TcM Kind
newFlexiTyVarTy Kind
multiplicityTy

tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvForRhs :: forall a. Maybe TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvForRhs Maybe TcIdSigInst
Nothing TcM a
thing_inside
  = TcM a
thing_inside
tcExtendTyVarEnvForRhs (Just TcIdSigInst
sig) TcM a
thing_inside
  = TcIdSigInst -> TcM a -> TcM a
forall a. TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvFromSig TcIdSigInst
sig TcM a
thing_inside

tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvFromSig :: forall a. TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvFromSig TcIdSigInst
sig_inst TcM a
thing_inside
  | TISI { sig_inst_skols :: TcIdSigInst -> [(Name, VarBndr TcId Specificity)]
sig_inst_skols = [(Name, VarBndr TcId Specificity)]
skol_prs, sig_inst_wcs :: TcIdSigInst -> [(Name, TcId)]
sig_inst_wcs = [(Name, TcId)]
wcs } <- TcIdSigInst
sig_inst
  = [(Name, TcId)] -> TcM a -> TcM a
forall a. [(Name, TcId)] -> TcM a -> TcM a
tcExtendNameTyVarEnv [(Name, TcId)]
wcs (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    [(Name, TcId)] -> TcM a -> TcM a
forall a. [(Name, TcId)] -> TcM a -> TcM a
tcExtendNameTyVarEnv ((VarBndr TcId Specificity -> TcId)
-> [(Name, VarBndr TcId Specificity)] -> [(Name, TcId)]
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a, b) -> f (a, c)
mapSnd VarBndr TcId Specificity -> TcId
forall tv argf. VarBndr tv argf -> tv
binderVar [(Name, VarBndr TcId Specificity)]
skol_prs) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    TcM a
thing_inside

tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
-- See Note [Relevant bindings and the binder stack]
tcExtendIdBinderStackForRhs :: forall a. [MonoBindInfo] -> TcM a -> TcM a
tcExtendIdBinderStackForRhs [MonoBindInfo]
infos TcM a
thing_inside
  = [TcBinder] -> TcM a -> TcM a
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [ TcId -> TopLevelFlag -> TcBinder
TcIdBndr TcId
mono_id TopLevelFlag
NotTopLevel
                        | MBI { mbi_mono_id :: MonoBindInfo -> TcId
mbi_mono_id = TcId
mono_id } <- [MonoBindInfo]
infos ]
                        TcM a
thing_inside
    -- NotTopLevel: it's a monomorphic binding

---------------------
getMonoBindInfo :: [LocatedA TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo :: [GenLocated SrcSpanAnnA TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds
  = (GenLocated SrcSpanAnnA TcMonoBind
 -> [MonoBindInfo] -> [MonoBindInfo])
-> [MonoBindInfo]
-> [GenLocated SrcSpanAnnA TcMonoBind]
-> [MonoBindInfo]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TcMonoBind -> [MonoBindInfo] -> [MonoBindInfo]
get_info (TcMonoBind -> [MonoBindInfo] -> [MonoBindInfo])
-> (GenLocated SrcSpanAnnA TcMonoBind -> TcMonoBind)
-> GenLocated SrcSpanAnnA TcMonoBind
-> [MonoBindInfo]
-> [MonoBindInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA TcMonoBind -> TcMonoBind
forall l e. GenLocated l e -> e
unLoc) [] [GenLocated SrcSpanAnnA TcMonoBind]
tc_binds
  where
    get_info :: TcMonoBind -> [MonoBindInfo] -> [MonoBindInfo]
get_info (TcFunBind MonoBindInfo
info SrcSpan
_ Kind
_ MatchGroup GhcRn (LHsExpr GhcRn)
_)    [MonoBindInfo]
rest = MonoBindInfo
info MonoBindInfo -> [MonoBindInfo] -> [MonoBindInfo]
forall a. a -> [a] -> [a]
: [MonoBindInfo]
rest
    get_info (TcPatBind [MonoBindInfo]
infos LPat GhcTc
_ Kind
_ HsMultAnn GhcRn
_ GRHSs GhcRn (LHsExpr GhcRn)
_ Kind
_) [MonoBindInfo]
rest = [MonoBindInfo]
infos [MonoBindInfo] -> [MonoBindInfo] -> [MonoBindInfo]
forall a. [a] -> [a] -> [a]
++ [MonoBindInfo]
rest


{- Note [Relevant bindings and the binder stack]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When typecking a binding we extend the TcBinderStack for the RHS of
the binding, with the /monomorphic/ Id.  That way, if we have, say
    f = \x -> blah
and something goes wrong in 'blah', we get a "relevant binding"
looking like  f :: alpha -> beta
This applies if 'f' has a type signature too:
   f :: forall a. [a] -> [a]
   f x = True
We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
If we had the *polymorphic* version of f in the TcBinderStack, it
would not be reported as relevant, because its type is closed.
(See TcErrors.relevantBindings.)

Note [Typechecking pattern bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Look at:
   - typecheck/should_compile/ExPat
   - #12427, typecheck/should_compile/T12427{a,b}

  data T where
    MkT :: Integral a => a -> Int -> T

and suppose t :: T.  Which of these pattern bindings are ok?

  E1. let { MkT p _ = t } in <body>

  E2. let { MkT _ q = t } in <body>

  E3. let { MkT (toInteger -> r) _ = t } in <body>

* (E1) is clearly wrong because the existential 'a' escapes.
  What type could 'p' possibly have?

* (E2) is fine, despite the existential pattern, because
  q::Int, and nothing escapes.

* Even (E3) is fine.  The existential pattern bindings a dictionary
  for (Integral a) which the view pattern can use to convert the
  a-valued field to an Integer, so r :: Integer.

An easy way to see all three is to imagine the desugaring.
For (E2) it would look like
    let q = case t of MkT _ q' -> q'
    in <body>


We typecheck pattern bindings as follows.  First tcLhs does this:

  1. Take each type signature q :: ty, partial or complete, and
     instantiate it (with tcLhsSigId) to get a MonoBindInfo.  This
     gives us a fresh "mono_id" qm :: instantiate(ty), where qm has
     a fresh name.

     Any fresh unification variables in instantiate(ty) born here, not
     deep under implications as would happen if we allocated them when
     we encountered q during tcPat.

  2. Build a little environment mapping "q" -> "qm" for those Ids
     with signatures (inst_sig_fun)

  3. Invoke tcLetPat to typecheck the pattern.

     - We pass in the current TcLevel.  This is captured by
       GHC.Tc.Gen.Pat.tcLetPat, and put into the pc_lvl field of PatCtxt, in
       PatEnv.

     - When tcPat finds an existential constructor, it binds fresh
       type variables and dictionaries as usual, increments the TcLevel,
       and emits an implication constraint.

     - When we come to a binder (GHC.Tc.Gen.Pat.tcPatBndr), it looks it up
       in the little environment (the pc_sig_fn field of PatCtxt).

         Success => There was a type signature, so just use it,
                    checking compatibility with the expected type.

         Failure => No type signature.
             Infer case: (happens only outside any constructor pattern)
                         use a unification variable
                         at the outer level pc_lvl

             Check case: use promoteTcType to promote the type
                         to the outer level pc_lvl.  This is the
                         place where we emit a constraint that'll blow
                         up if existential capture takes place

       Result: the type of the binder is always at pc_lvl. This is
       crucial.

  4. Throughout, when we are making up an Id for the pattern-bound variables
     (newLetBndr), we have two cases:

     - If we are generalising (generalisation plan is InferGen or
       CheckGen), then the let_bndr_spec will be LetLclBndr.  In that case
       we want to bind a cloned, local version of the variable, with the
       type given by the pattern context, *not* by the signature (even if
       there is one; see #7268). The mkExport part of the
       generalisation step will do the checking and impedance matching
       against the signature.

     - If for some reason we are not generalising (plan = NoGen), the
       LetBndrSpec will be LetGblBndr.  In that case we must bind the
       global version of the Id, and do so with precisely the type given
       in the signature.  (Then we unify with the type from the pattern
       context type.)


And that's it!  The implication constraints check for the skolem
escape.  It's quite simple and neat, and more expressive than before
e.g. GHC 8.0 rejects (E2) and (E3).

Example for (E1), starting at level 1.  We generate
     p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta)
The (a~beta) can't float (because of the 'a'), nor be solved (because
beta is untouchable.)

Example for (E2), we generate
     q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)
The beta is untouchable, but floats out of the constraint and can
be solved absolutely fine.


************************************************************************
*                                                                      *
                Generalisation
*                                                                      *
********************************************************************* -}

data GeneralisationPlan
  = NoGen               -- No generalisation, no AbsBinds

  | InferGen            -- Implicit generalisation; there is an AbsBinds

  | CheckGen            -- One FunBind with a complete signature:
       (LHsBind GhcRn)  --   do explicit generalisation
       TcCompleteSig

-- A consequence of the no-AbsBinds choice (NoGen) is that there is
-- no "polymorphic Id" and "monmomorphic Id"; there is just the one

instance Outputable GeneralisationPlan where
  ppr :: GeneralisationPlan -> SDoc
ppr GeneralisationPlan
NoGen          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NoGen"
  ppr GeneralisationPlan
InferGen       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"InferGen"
  ppr (CheckGen LHsBindLR GhcRn GhcRn
_ TcCompleteSig
s) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CheckGen" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcCompleteSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcCompleteSig
s

decideGeneralisationPlan
   :: DynFlags -> TopLevelFlag -> IsGroupClosed -> TcSigFun
   -> [LHsBind GhcRn] -> GeneralisationPlan
decideGeneralisationPlan :: DynFlags
-> TopLevelFlag
-> IsGroupClosed
-> TcSigFun
-> [LHsBindLR GhcRn GhcRn]
-> GeneralisationPlan
decideGeneralisationPlan DynFlags
dflags TopLevelFlag
top_lvl IsGroupClosed
closed TcSigFun
sig_fn [LHsBindLR GhcRn GhcRn]
lbinds
  | Just (GenLocated SrcSpanAnnA (HsBind GhcRn)
bind, TcCompleteSig
sig) <- Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn), TcCompleteSig)
one_funbind_with_sig = LHsBindLR GhcRn GhcRn -> TcCompleteSig -> GeneralisationPlan
CheckGen LHsBindLR GhcRn GhcRn
GenLocated SrcSpanAnnA (HsBind GhcRn)
bind TcCompleteSig
sig
  | Bool
generalise_binds                         = GeneralisationPlan
InferGen
  | Bool
otherwise                                = GeneralisationPlan
NoGen
  where
    generalise_binds :: Bool
generalise_binds
      | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl             = Bool
True
        -- See Note [Always generalise top-level bindings]

      | Bool
has_mult_anns_and_pats = Bool
False
        -- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear]

      | IsGroupClosed NameEnv NameSet
_ Bool
True <- IsGroupClosed
closed
      , Bool -> Bool
not ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IdP GhcRn]
[Name]
binders) = Bool
True
        -- The 'True' means that all of the group's
        -- free vars have ClosedTypeId=True; so we can ignore
        -- -XMonoLocalBinds, and generalise anyway.
        -- Except if 'fv' is empty: there is no binder to generalise, so
        -- generalising does nothing. And trying to generalise hurts linear
        -- types (see #25428). So we don't force it.
        -- See (NVP5) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind.

      | Bool
has_partial_sigs = Bool
True
        -- See Note [Partial type signatures and generalisation]

      | Bool
otherwise = Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.MonoLocalBinds DynFlags
dflags)

    -- With OutsideIn, all nested bindings are monomorphic
    -- except a single function binding with a complete signature
    one_funbind_with_sig :: Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn), TcCompleteSig)
one_funbind_with_sig
      | [lbind :: LHsBindLR GhcRn GhcRn
lbind@(L SrcSpanAnnA
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcRn
v }))] <- [LHsBindLR GhcRn GhcRn]
lbinds
      , Just (TcIdSig (TcCompleteSig TcCompleteSig
sig)) <- TcSigFun
sig_fn (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
v)
      = (GenLocated SrcSpanAnnA (HsBind GhcRn), TcCompleteSig)
-> Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn), TcCompleteSig)
forall a. a -> Maybe a
Just (LHsBindLR GhcRn GhcRn
GenLocated SrcSpanAnnA (HsBind GhcRn)
lbind, TcCompleteSig
sig)
      | Bool
otherwise
      = Maybe (GenLocated SrcSpanAnnA (HsBind GhcRn), TcCompleteSig)
forall a. Maybe a
Nothing

    binders :: [IdP GhcRn]
binders          = CollectFlag GhcRn -> [LHsBindLR GhcRn GhcRn] -> [IdP GhcRn]
forall p idR.
CollectPass p =>
CollectFlag p -> [LHsBindLR p idR] -> [IdP p]
collectHsBindListBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders [LHsBindLR GhcRn GhcRn]
lbinds
    has_partial_sigs :: Bool
has_partial_sigs = (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Name -> Bool
has_partial_sig [IdP GhcRn]
[Name]
binders
    has_partial_sig :: Name -> Bool
has_partial_sig Name
nm = case TcSigFun
sig_fn Name
nm of
      Just (TcIdSig (TcPartialSig {})) -> Bool
True
      Maybe TcSigInfo
_                                -> Bool
False
    has_mult_anns_and_pats :: Bool
has_mult_anns_and_pats = (GenLocated SrcSpanAnnA (HsBind GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated SrcSpanAnnA (HsBind GhcRn) -> Bool
forall {idL} {l} {l} {idR}.
(XRec idL (Pat idL) ~ GenLocated l (Pat idL)) =>
GenLocated l (HsBindLR idL idR) -> Bool
has_mult_ann_and_pat [LHsBindLR GhcRn GhcRn]
[GenLocated SrcSpanAnnA (HsBind GhcRn)]
lbinds
    has_mult_ann_and_pat :: GenLocated l (HsBindLR idL idR) -> Bool
has_mult_ann_and_pat (L l
_ (PatBind{pat_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_mult=HsNoMultAnn{}})) = Bool
False
    has_mult_ann_and_pat (L l
_ (PatBind{pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs=(L l
_ (VarPat{}))})) = Bool
False
    has_mult_ann_and_pat (L l
_ (PatBind{})) = Bool
True
    has_mult_ann_and_pat GenLocated l (HsBindLR idL idR)
_ = Bool
False

isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed
isClosedBndrGroup :: TcTypeEnv -> LHsBinds GhcRn -> IsGroupClosed
isClosedBndrGroup TcTypeEnv
type_env LHsBinds GhcRn
binds
  = NameEnv NameSet -> Bool -> IsGroupClosed
IsGroupClosed NameEnv NameSet
fv_env Bool
type_closed
  where
    type_closed :: Bool
type_closed = (NameSet -> Bool) -> NameEnv NameSet -> Bool
forall {k} elt (key :: k). (elt -> Bool) -> UniqFM key elt -> Bool
allUFM ((Name -> Bool) -> NameSet -> Bool
nameSetAll Name -> Bool
is_closed_type_id) NameEnv NameSet
fv_env

    fv_env :: NameEnv NameSet
    fv_env :: NameEnv NameSet
fv_env = [(Name, NameSet)] -> NameEnv NameSet
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, NameSet)] -> NameEnv NameSet)
-> [(Name, NameSet)] -> NameEnv NameSet
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsBind GhcRn) -> [(Name, NameSet)])
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcRn)) -> [(Name, NameSet)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HsBind GhcRn -> [(Name, NameSet)]
bindFvs (HsBind GhcRn -> [(Name, NameSet)])
-> (GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn)
-> GenLocated SrcSpanAnnA (HsBind GhcRn)
-> [(Name, NameSet)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcRn) -> HsBind GhcRn
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
binds

    bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
    bindFvs :: HsBind GhcRn -> [(Name, NameSet)]
bindFvs (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
_ Name
f
                     , fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = XFunBind GhcRn GhcRn
fvs })
       = let open_fvs :: NameSet
open_fvs = NameSet -> NameSet
get_open_fvs XFunBind GhcRn GhcRn
NameSet
fvs
         in [(Name
f, NameSet
open_fvs)]
    bindFvs (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = XRec GhcRn (Pat GhcRn)
pat, pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = XPatBind GhcRn GhcRn
fvs })
       = let open_fvs :: NameSet
open_fvs = NameSet -> NameSet
get_open_fvs XPatBind GhcRn GhcRn
NameSet
fvs
         in [(Name
b, NameSet
open_fvs) | Name
b <- CollectFlag GhcRn -> XRec GhcRn (Pat GhcRn) -> [IdP GhcRn]
forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p]
collectPatBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders XRec GhcRn (Pat GhcRn)
pat]
    bindFvs HsBind GhcRn
_
       = []

    get_open_fvs :: NameSet -> NameSet
get_open_fvs NameSet
fvs = (Name -> Bool) -> NameSet -> NameSet
filterNameSet (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
is_closed) NameSet
fvs

    is_closed :: Name -> ClosedTypeId
    is_closed :: Name -> Bool
is_closed Name
name
      | Just TcTyThing
thing <- TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
type_env Name
name
      = case TcTyThing
thing of
          AGlobal {}                     -> Bool
True
          ATcId { tct_info :: TcTyThing -> IdBindingInfo
tct_info = IdBindingInfo
ClosedLet } -> Bool
True
          TcTyThing
_                              -> Bool
False

      | Bool
otherwise
      = Bool
True  -- The free-var set for a top level binding mentions


    is_closed_type_id :: Name -> Bool
    -- We're already removed Global and ClosedLet Ids
    is_closed_type_id :: Name -> Bool
is_closed_type_id Name
name
      | Just TcTyThing
thing <- TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
type_env Name
name
      = case TcTyThing
thing of
          ATcId { tct_info :: TcTyThing -> IdBindingInfo
tct_info = NonClosedLet NameSet
_ Bool
cl } -> Bool
cl
          ATcId { tct_info :: TcTyThing -> IdBindingInfo
tct_info = IdBindingInfo
NotLetBound }       -> Bool
False
          ATyVar {}                              -> Bool
False
               -- In-scope type variables are not closed!
          TcTyThing
_ -> String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"is_closed_id" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)

      | Bool
otherwise
      = Bool
True   -- The free-var set for a top level binding mentions
               -- imported things too, so that we can report unused imports
               -- These won't be in the local type env.
               -- Ditto class method etc from the current module

{- Note [Always generalise top-level bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It is very confusing to apply NoGen to a top level binding. Consider (#20123):
   module M where
     x = 5
     f y = (x, y)

The MR means that x=5 is not generalise, so f's binding is no Closed.  So we'd
be tempted to use NoGen. But that leads to f :: Any -> (Integer, Any), which
is plain stupid.

NoGen is good when we have call sites, but not at top level, where the
function may be exported.  And it's easier to grok "MonoLocalBinds" as
applying to, well, local bindings.
-}

{- *********************************************************************
*                                                                      *
               Error contexts and messages
*                                                                      *
********************************************************************* -}

-- This one is called on LHS, when pat and grhss are both Name
-- and on RHS, when pat is TcId and grhss is still Name
patMonoBindsCtxt :: (OutputableBndrId p)
                 => LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt :: forall (p :: Pass).
OutputableBndrId p =>
LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
patMonoBindsCtxt LPat (GhcPass p)
pat GRHSs GhcRn (LHsExpr GhcRn)
grhss
  = SDoc -> BKey -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In a pattern binding:") BKey
2 (LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
forall (bndr :: Pass) (p :: Pass).
(OutputableBndrId bndr, OutputableBndrId p) =>
LPat (GhcPass bndr)
-> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc
pprPatBind LPat (GhcPass p)
pat GRHSs GhcRn (LHsExpr GhcRn)
grhss)