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

-}

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

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

import GHC.Prelude

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

import GHC.Core (Tickish (..))
import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC))
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Hs
import GHC.Tc.Gen.Sig
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.Gen.HsType
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv( normaliseType )
import GHC.Tc.Instance.Family( tcGetFamInstEnvs )
import GHC.Core.TyCon
import GHC.Tc.Utils.TcType
import GHC.Core.Type (mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types( mkBoxedTupleTy )
import GHC.Types.Id
import GHC.Types.Var as Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env( TidyEnv )
import GHC.Unit.Module
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Data.Bag
import GHC.Utils.Error
import GHC.Data.Graph.Directed
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Types.Basic
import GHC.Utils.Outputable as Outputable
import GHC.Builtin.Names( ipClassName )
import GHC.Tc.Validity (checkValidType)
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.ConLike

import Control.Monad
import Data.Foldable (find)

#include "HsVersions.h"

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

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

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

The real work is done by @tcBindWithSigsAndThen@.

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

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

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

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

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

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

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

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

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

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

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

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

        ff = f Int dEqInt

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

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

Etc.

NOTE: a bit of arity 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 (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)] -> TcM (TcGblEnv, TcLclEnv)
tcTopBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds [LSig (GhcPass 'Renamed)]
sigs
  = do  { -- Pattern synonym bindings populate the global environment
          ([(RecFlag, LHsBinds (GhcPass 'Typechecked))]
binds', (TcGblEnv
tcg_env, TcLclEnv
tcl_env)) <- TopLevelFlag
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)]
-> TcM (TcGblEnv, TcLclEnv)
-> TcM
     ([(RecFlag, LHsBinds (GhcPass 'Typechecked))],
      (TcGblEnv, TcLclEnv))
forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
tcValBinds TopLevelFlag
TopLevel [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds [LSig (GhcPass 'Renamed)]
sigs (TcM (TcGblEnv, TcLclEnv)
 -> TcM
      ([(RecFlag, LHsBinds (GhcPass 'Typechecked))],
       (TcGblEnv, TcLclEnv)))
-> TcM (TcGblEnv, TcLclEnv)
-> TcM
     ([(RecFlag, LHsBinds (GhcPass 'Typechecked))],
      (TcGblEnv, TcLclEnv))
forall a b. (a -> b) -> a -> b
$
            do { TcGblEnv
gbl <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
               ; TcLclEnv
lcl <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
               ; (TcGblEnv, TcLclEnv) -> TcM (TcGblEnv, TcLclEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl, TcLclEnv
lcl) }
        ; [LTcSpecPrag]
specs <- [LSig (GhcPass 'Renamed)] -> TcM [LTcSpecPrag]
tcImpPrags [LSig (GhcPass 'Renamed)]
sigs   -- SPECIALISE prags for imported Ids

        ; [CompleteMatch]
complete_matches <- (TcGblEnv, TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv [CompleteMatch]
-> TcRnIf TcGblEnv TcLclEnv [CompleteMatch]
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (TcGblEnv
tcg_env, TcLclEnv
tcl_env) (TcRnIf TcGblEnv TcLclEnv [CompleteMatch]
 -> TcRnIf TcGblEnv TcLclEnv [CompleteMatch])
-> TcRnIf TcGblEnv TcLclEnv [CompleteMatch]
-> TcRnIf TcGblEnv TcLclEnv [CompleteMatch]
forall a b. (a -> b) -> a -> b
$ [LSig (GhcPass 'Renamed)]
-> TcRnIf TcGblEnv TcLclEnv [CompleteMatch]
tcCompleteSigs [LSig (GhcPass 'Renamed)]
sigs
        ; String -> SDoc -> TcRn ()
traceTc String
"complete_matches" ([(RecFlag, LHsBinds (GhcPass 'Renamed))] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds SDoc -> SDoc -> SDoc
$$ [LSig (GhcPass 'Renamed)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LSig (GhcPass 'Renamed)]
sigs)
        ; String -> SDoc -> TcRn ()
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 :: [LTcSpecPrag]
tcg_imp_specs
                                      = [LTcSpecPrag]
specs [LTcSpecPrag] -> [LTcSpecPrag] -> [LTcSpecPrag]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [LTcSpecPrag]
tcg_imp_specs TcGblEnv
tcg_env
                                   , tcg_complete_matches :: [CompleteMatch]
tcg_complete_matches
                                      = [CompleteMatch]
complete_matches
                                          [CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [CompleteMatch]
tcg_complete_matches TcGblEnv
tcg_env }
                           TcGblEnv -> [LHsBinds (GhcPass 'Typechecked)] -> TcGblEnv
`addTypecheckedBinds` ((RecFlag, LHsBinds (GhcPass 'Typechecked))
 -> LHsBinds (GhcPass 'Typechecked))
-> [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
-> [LHsBinds (GhcPass 'Typechecked)]
forall a b. (a -> b) -> [a] -> [b]
map (RecFlag, LHsBinds (GhcPass 'Typechecked))
-> LHsBinds (GhcPass 'Typechecked)
forall a b. (a, b) -> b
snd [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
binds' }

        ; (TcGblEnv, TcLclEnv) -> TcM (TcGblEnv, TcLclEnv)
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


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





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

tcCompleteSigs  :: [LSig GhcRn] -> TcM [CompleteMatch]
tcCompleteSigs :: [LSig (GhcPass 'Renamed)]
-> TcRnIf TcGblEnv TcLclEnv [CompleteMatch]
tcCompleteSigs [LSig (GhcPass 'Renamed)]
sigs =
  let
      doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch)
      doOne :: Sig (GhcPass 'Renamed) -> TcM (Maybe CompleteMatch)
doOne c :: Sig (GhcPass 'Renamed)
c@(CompleteMatchSig XCompleteMatchSig (GhcPass 'Renamed)
_ SourceText
_ Located [Located (IdP (GhcPass 'Renamed))]
lns Maybe (Located (IdP (GhcPass 'Renamed)))
mtc)
        = (CompleteMatch -> Maybe CompleteMatch)
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> TcM (Maybe CompleteMatch)
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
$ do
           SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
-> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
text String
"In" SDoc -> SDoc -> SDoc
<+> Sig (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Sig (GhcPass 'Renamed)
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
$
            case Maybe (Located (IdP (GhcPass 'Renamed)))
mtc of
              Maybe (Located (IdP (GhcPass 'Renamed)))
Nothing -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
infer_complete_match
              Just Located (IdP (GhcPass 'Renamed))
tc -> Located Name -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
check_complete_match Located Name
Located (IdP (GhcPass 'Renamed))
tc
        where

          checkCLTypes :: CompleteSigType
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
checkCLTypes CompleteSigType
acc = ((CompleteSigType, [ConLike])
 -> Located Name
 -> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike]))
-> (CompleteSigType, [ConLike])
-> [Located Name]
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (CompleteSigType, [ConLike])
-> Located Name
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
checkCLType (CompleteSigType
acc, []) (GenLocated SrcSpan [Located Name] -> [Located Name]
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan [Located Name]
Located [Located (IdP (GhcPass 'Renamed))]
lns)

          infer_complete_match :: IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
infer_complete_match = do
            (CompleteSigType
res, [ConLike]
cls) <- CompleteSigType
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
checkCLTypes CompleteSigType
AcceptAny
            case CompleteSigType
res of
              CompleteSigType
AcceptAny -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a. SDoc -> TcM a
failWithTc SDoc
ambiguousError
              Fixed Maybe ConLike
_ TyCon
tc  -> CompleteMatch -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall (m :: * -> *) a. Monad m => a -> m a
return (CompleteMatch -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch)
-> CompleteMatch -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a b. (a -> b) -> a -> b
$ [ConLike] -> TyCon -> CompleteMatch
mkMatch [ConLike]
cls TyCon
tc

          check_complete_match :: Located Name -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
check_complete_match Located Name
tc_name = do
            TyCon
ty_con <- Located Name -> TcM TyCon
tcLookupLocatedTyCon Located Name
tc_name
            (CompleteSigType
_, [ConLike]
cls) <- CompleteSigType
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
checkCLTypes (Maybe ConLike -> TyCon -> CompleteSigType
Fixed Maybe ConLike
forall a. Maybe a
Nothing TyCon
ty_con)
            CompleteMatch -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall (m :: * -> *) a. Monad m => a -> m a
return (CompleteMatch -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch)
-> CompleteMatch -> IOEnv (Env TcGblEnv TcLclEnv) CompleteMatch
forall a b. (a -> b) -> a -> b
$ [ConLike] -> TyCon -> CompleteMatch
mkMatch [ConLike]
cls TyCon
ty_con

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

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


      -- See note [Typechecking Complete Matches]
      checkCLType :: (CompleteSigType, [ConLike]) -> Located Name
                  -> TcM (CompleteSigType, [ConLike])
      checkCLType :: (CompleteSigType, [ConLike])
-> Located Name
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
checkCLType (CompleteSigType
cst, [ConLike]
cs) Located Name
n = do
        ConLike
cl <- (Name -> TcM ConLike) -> Located Name -> TcM ConLike
forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM Name -> TcM ConLike
tcLookupConLike Located Name
n
        let   ([TcId]
_,[TcId]
_,[EqSpec]
_,TcThetaType
_,TcThetaType
_,[Scaled Kind]
_, Kind
res_ty) = ConLike
-> ([TcId], [TcId], [EqSpec], TcThetaType, TcThetaType,
    [Scaled Kind], Kind)
conLikeFullSig ConLike
cl
              res_ty_con :: Maybe TyCon
res_ty_con = (TyCon, TcThetaType) -> TyCon
forall a b. (a, b) -> a
fst ((TyCon, TcThetaType) -> TyCon)
-> Maybe (TyCon, TcThetaType) -> Maybe TyCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasDebugCallStack => Kind -> Maybe (TyCon, TcThetaType)
Kind -> Maybe (TyCon, TcThetaType)
splitTyConApp_maybe Kind
res_ty
        case (CompleteSigType
cst, Maybe TyCon
res_ty_con) of
          (CompleteSigType
AcceptAny, Maybe TyCon
Nothing) -> (CompleteSigType, [ConLike])
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
forall (m :: * -> *) a. Monad m => a -> m a
return (CompleteSigType
AcceptAny, ConLike
clConLike -> [ConLike] -> [ConLike]
forall a. a -> [a] -> [a]
:[ConLike]
cs)
          (CompleteSigType
AcceptAny, Just TyCon
tc) -> (CompleteSigType, [ConLike])
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ConLike -> TyCon -> CompleteSigType
Fixed (ConLike -> Maybe ConLike
forall a. a -> Maybe a
Just ConLike
cl) TyCon
tc, ConLike
clConLike -> [ConLike] -> [ConLike]
forall a. a -> [a] -> [a]
:[ConLike]
cs)
          (Fixed Maybe ConLike
mfcl TyCon
tc, Maybe TyCon
Nothing)  -> (CompleteSigType, [ConLike])
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ConLike -> TyCon -> CompleteSigType
Fixed Maybe ConLike
mfcl TyCon
tc, ConLike
clConLike -> [ConLike] -> [ConLike]
forall a. a -> [a] -> [a]
:[ConLike]
cs)
          (Fixed Maybe ConLike
mfcl TyCon
tc, Just TyCon
tc') ->
            if TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc'
              then (CompleteSigType, [ConLike])
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ConLike -> TyCon -> CompleteSigType
Fixed Maybe ConLike
mfcl TyCon
tc, ConLike
clConLike -> [ConLike] -> [ConLike]
forall a. a -> [a] -> [a]
:[ConLike]
cs)
              else case Maybe ConLike
mfcl of
                     Maybe ConLike
Nothing ->
                      SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
text String
"In" SDoc -> SDoc -> SDoc
<+> ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
cl) (IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
 -> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike]))
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
-> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
forall a b. (a -> b) -> a -> b
$
                        SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
forall a. SDoc -> TcM a
failWithTc SDoc
typeSigErrMsg
                     Just ConLike
cl -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (CompleteSigType, [ConLike])
forall a. SDoc -> TcM a
failWithTc (ConLike -> SDoc
errMsg ConLike
cl)
             where
              typeSigErrMsg :: SDoc
              typeSigErrMsg :: SDoc
typeSigErrMsg =
                String -> SDoc
text String
"Couldn't match expected type"
                      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
                      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with"
                      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc')

              errMsg :: ConLike -> SDoc
              errMsg :: ConLike -> SDoc
errMsg ConLike
fcl =
                String -> SDoc
text String
"Cannot form a group of complete patterns from patterns"
                  SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
fcl) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
cl)
                  SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"as they match different type constructors"
                  SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
                               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"resp."
                               SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc'))
  -- For some reason I haven't investigated further, the signatures come in
  -- backwards wrt. declaration order. So we reverse them here, because it makes
  -- a difference for incomplete match suggestions.
  in  (LSig (GhcPass 'Renamed) -> TcM (Maybe CompleteMatch))
-> [LSig (GhcPass 'Renamed)]
-> TcRnIf TcGblEnv TcLclEnv [CompleteMatch]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM ((Sig (GhcPass 'Renamed) -> TcM (Maybe CompleteMatch))
-> LSig (GhcPass 'Renamed) -> TcM (Maybe CompleteMatch)
forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM Sig (GhcPass 'Renamed) -> TcM (Maybe CompleteMatch)
doOne) ([LSig (GhcPass 'Renamed)] -> [LSig (GhcPass 'Renamed)]
forall a. [a] -> [a]
reverse [LSig (GhcPass 'Renamed)]
sigs) -- process in declaration order

tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
-- A hs-boot file has only one BindGroup, and it only has type
-- signatures in it.  The renamer checked all this
tcHsBootSigs :: [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)] -> TcM [TcId]
tcHsBootSigs [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds [LSig (GhcPass 'Renamed)]
sigs
  = do  { Bool -> SDoc -> TcRn ()
checkTc ([(RecFlag, LHsBinds (GhcPass 'Renamed))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds) SDoc
badBootDeclErr
        ; (LSig (GhcPass 'Renamed) -> TcM [TcId])
-> [LSig (GhcPass 'Renamed)] -> TcM [TcId]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((Sig (GhcPass 'Renamed) -> TcM [TcId])
-> LSig (GhcPass 'Renamed) -> TcM [TcId]
forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM Sig (GhcPass 'Renamed) -> TcM [TcId]
tc_boot_sig) ((LSig (GhcPass 'Renamed) -> Bool)
-> [LSig (GhcPass 'Renamed)] -> [LSig (GhcPass 'Renamed)]
forall a. (a -> Bool) -> [a] -> [a]
filter LSig (GhcPass 'Renamed) -> Bool
forall name. LSig name -> Bool
isTypeLSig [LSig (GhcPass 'Renamed)]
sigs) }
  where
    tc_boot_sig :: Sig (GhcPass 'Renamed) -> TcM [TcId]
tc_boot_sig (TypeSig XTypeSig (GhcPass 'Renamed)
_ [Located (IdP (GhcPass 'Renamed))]
lnames LHsSigWcType (GhcPass 'Renamed)
hs_ty) = (Located Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId)
-> [Located Name] -> TcM [TcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId
f [Located Name]
[Located (IdP (GhcPass 'Renamed))]
lnames
      where
        f :: Located Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId
f (L SrcSpan
_ Name
name)
          = do { Kind
sigma_ty <- UserTypeCtxt -> LHsSigWcType (GhcPass 'Renamed) -> TcM Kind
tcHsSigWcType (Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
name Bool
False) LHsSigWcType (GhcPass 'Renamed)
hs_ty
               ; TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Kind -> TcId
mkVanillaGlobal Name
name Kind
sigma_ty) }
        -- Notice that we make GlobalIds, not LocalIds
    tc_boot_sig Sig (GhcPass 'Renamed)
s = String -> SDoc -> TcM [TcId]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcHsBootSigs/tc_boot_sig" (Sig (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Sig (GhcPass 'Renamed)
s)

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

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

tcLocalBinds :: forall thing.
HsLocalBinds (GhcPass 'Renamed)
-> TcM thing -> TcM (HsLocalBinds (GhcPass 'Typechecked), thing)
tcLocalBinds (EmptyLocalBinds XEmptyLocalBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
x) TcM thing
thing_inside
  = do  { thing
thing <- TcM thing
thing_inside
        ; (HsLocalBinds (GhcPass 'Typechecked), thing)
-> TcM (HsLocalBinds (GhcPass 'Typechecked), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XEmptyLocalBinds (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> HsLocalBinds (GhcPass 'Typechecked)
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
XEmptyLocalBinds (GhcPass 'Typechecked) (GhcPass 'Typechecked)
x, thing
thing) }

tcLocalBinds (HsValBinds XHsValBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
x (XValBindsLR (NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds [LSig (GhcPass 'Renamed)]
sigs))) TcM thing
thing_inside
  = do  { ([(RecFlag, LHsBinds (GhcPass 'Typechecked))]
binds', thing
thing) <- TopLevelFlag
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
tcValBinds TopLevelFlag
NotTopLevel [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds [LSig (GhcPass 'Renamed)]
sigs TcM thing
thing_inside
        ; (HsLocalBinds (GhcPass 'Typechecked), thing)
-> TcM (HsLocalBinds (GhcPass 'Typechecked), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsValBinds (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> HsValBindsLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> HsLocalBinds (GhcPass 'Typechecked)
forall idL idR.
XHsValBinds idL idR
-> HsValBindsLR idL idR -> HsLocalBindsLR idL idR
HsValBinds XHsValBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
XHsValBinds (GhcPass 'Typechecked) (GhcPass 'Typechecked)
x (XXValBindsLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> HsValBindsLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
forall idL idR. XXValBindsLR idL idR -> HsValBindsLR idL idR
XValBindsLR ([(RecFlag, LHsBinds (GhcPass 'Typechecked))]
-> [LSig (GhcPass 'Renamed)]
-> NHsValBindsLR (GhcPass 'Typechecked)
forall idL.
[(RecFlag, LHsBinds idL)]
-> [LSig (GhcPass 'Renamed)] -> NHsValBindsLR idL
NValBinds [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
binds' [LSig (GhcPass 'Renamed)]
sigs)), thing
thing) }
tcLocalBinds (HsValBinds XHsValBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
_ (ValBinds {})) TcM thing
_ = String -> TcM (HsLocalBinds (GhcPass 'Typechecked), thing)
forall a. String -> a
panic String
"tcLocalBinds"

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

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

        ; (HsLocalBinds (GhcPass 'Typechecked), thing)
-> TcM (HsLocalBinds (GhcPass 'Typechecked), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsIPBinds (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> HsIPBinds (GhcPass 'Typechecked)
-> HsLocalBinds (GhcPass 'Typechecked)
forall idL idR.
XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR
HsIPBinds XHsIPBinds (GhcPass 'Renamed) (GhcPass 'Renamed)
XHsIPBinds (GhcPass 'Typechecked) (GhcPass 'Typechecked)
x (XIPBinds (GhcPass 'Typechecked)
-> [Located (IPBind (GhcPass 'Typechecked))]
-> HsIPBinds (GhcPass 'Typechecked)
forall id. XIPBinds id -> [LIPBind id] -> HsIPBinds id
IPBinds XIPBinds (GhcPass 'Typechecked)
TcEvBinds
ev_binds [Located (IPBind (GhcPass 'Typechecked))]
ip_binds') , thing
result) }
  where
    ips :: [HsIPName]
ips = [HsIPName
ip | (L SrcSpan
_ (IPBind XCIPBind (GhcPass 'Renamed)
_ (Left (L SrcSpan
_ HsIPName
ip)) LHsExpr (GhcPass 'Renamed)
_)) <- [LIPBind (GhcPass 'Renamed)]
ip_binds]

        -- I wonder if we should do these one at a time
        -- Consider     ?x = 4
        --              ?y = ?x + 1
    tc_ip_bind :: Class
-> IPBind (GhcPass 'Renamed)
-> TcM (TcId, IPBind (GhcPass 'Typechecked))
tc_ip_bind Class
ipClass (IPBind XCIPBind (GhcPass 'Renamed)
_ (Left (L SrcSpan
_ HsIPName
ip)) LHsExpr (GhcPass 'Renamed)
expr)
       = do { Kind
ty <- TcM Kind
newOpenFlexiTyVarTy
            ; 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 ]
            ; LHsExpr (GhcPass 'Typechecked)
expr' <- LHsExpr (GhcPass 'Renamed)
-> Kind -> TcM (LHsExpr (GhcPass 'Typechecked))
tcCheckMonoExpr LHsExpr (GhcPass 'Renamed)
expr Kind
ty
            ; let d :: LHsExpr (GhcPass 'Typechecked)
d = Class
-> Kind
-> Kind
-> HsExpr (GhcPass 'Typechecked)
-> HsExpr (GhcPass 'Typechecked)
toDict Class
ipClass Kind
p Kind
ty (HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked))
-> LHsExpr (GhcPass 'Typechecked) -> LHsExpr (GhcPass 'Typechecked)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` LHsExpr (GhcPass 'Typechecked)
expr'
            ; (TcId, IPBind (GhcPass 'Typechecked))
-> TcM (TcId, IPBind (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (TcId
ip_id, (XCIPBind (GhcPass 'Typechecked)
-> Either (Located HsIPName) (IdP (GhcPass 'Typechecked))
-> LHsExpr (GhcPass 'Typechecked)
-> IPBind (GhcPass 'Typechecked)
forall id.
XCIPBind id
-> Either (Located HsIPName) (IdP id) -> LHsExpr id -> IPBind id
IPBind NoExtField
XCIPBind (GhcPass 'Typechecked)
noExtField (TcId -> Either (Located HsIPName) TcId
forall a b. b -> Either a b
Right TcId
ip_id) LHsExpr (GhcPass 'Typechecked)
d)) }
    tc_ip_bind Class
_ (IPBind XCIPBind (GhcPass 'Renamed)
_ (Right {}) LHsExpr (GhcPass 'Renamed)
_) = String -> TcM (TcId, IPBind (GhcPass 'Typechecked))
forall a. String -> a
panic String
"tc_ip_bind"

    -- Coerces a `t` into a dictionary for `IP "x" t`.
    -- co : t -> IP "x" t
    toDict :: Class
-> Kind
-> Kind
-> HsExpr (GhcPass 'Typechecked)
-> HsExpr (GhcPass 'Typechecked)
toDict Class
ipClass Kind
x Kind
ty = HsWrapper
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
mkHsWrap (HsWrapper
 -> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked))
-> HsWrapper
-> HsExpr (GhcPass 'Typechecked)
-> HsExpr (GhcPass 'Typechecked)
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]

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

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

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

tcValBinds :: forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
tcValBinds TopLevelFlag
top_lvl [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds [LSig (GhcPass 'Renamed)]
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 (GhcPass 'Renamed) (GhcPass 'Renamed)]
-> TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall a.
[PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
-> TcM a -> TcM a
tcAddPatSynPlaceholders [PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
patsyns (TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun))
-> TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall a b. (a -> b) -> a -> b
$
                                [LSig (GhcPass 'Renamed)] -> TcM ([TcId], TcSigFun)
tcTySigs [LSig (GhcPass 'Renamed)]
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, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
forall a. TopLevelFlag -> [TcId] -> TcM a -> TcM a
tcExtendSigIds TopLevelFlag
top_lvl [TcId]
poly_ids (TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
 -> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing))
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
forall a b. (a -> b) -> a -> b
$
     do { ([(RecFlag, LHsBinds (GhcPass 'Typechecked))]
binds', ([(RecFlag, LHsBinds (GhcPass 'Typechecked))]
extra_binds', thing
thing))
              <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM
     ([(RecFlag, LHsBinds (GhcPass 'Typechecked))],
      ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing))
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
tcBindGroups TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds (TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
 -> TcM
      ([(RecFlag, LHsBinds (GhcPass 'Typechecked))],
       ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)))
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM
     ([(RecFlag, LHsBinds (GhcPass 'Typechecked))],
      ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], 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
                    ; [LHsBinds (GhcPass 'Typechecked)]
patsyn_builders <- (PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)
 -> IOEnv (Env TcGblEnv TcLclEnv) (LHsBinds (GhcPass 'Typechecked)))
-> [PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
-> IOEnv (Env TcGblEnv TcLclEnv) [LHsBinds (GhcPass 'Typechecked)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (LHsBinds (GhcPass 'Typechecked))
tcPatSynBuilderBind [PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
patsyns
                    ; let extra_binds :: [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
extra_binds = [ (RecFlag
NonRecursive, LHsBinds (GhcPass 'Typechecked)
builder)
                                        | LHsBinds (GhcPass 'Typechecked)
builder <- [LHsBinds (GhcPass 'Typechecked)]
patsyn_builders ]
                    ; ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag, LHsBinds (GhcPass 'Typechecked))]
extra_binds, thing
thing) }
        ; ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag, LHsBinds (GhcPass 'Typechecked))]
binds' [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
-> [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
-> [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
forall a. [a] -> [a] -> [a]
++ [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
extra_binds', thing
thing) }}
  where
    patsyns :: [PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
patsyns = [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)]
forall id. [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds
    prag_fn :: TcPragEnv
prag_fn = [LSig (GhcPass 'Renamed)]
-> LHsBinds (GhcPass 'Renamed) -> TcPragEnv
mkPragEnv [LSig (GhcPass 'Renamed)]
sigs (((RecFlag, LHsBinds (GhcPass 'Renamed))
 -> LHsBinds (GhcPass 'Renamed) -> LHsBinds (GhcPass 'Renamed))
-> LHsBinds (GhcPass 'Renamed)
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> LHsBinds (GhcPass 'Renamed)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (LHsBinds (GhcPass 'Renamed)
-> LHsBinds (GhcPass 'Renamed) -> LHsBinds (GhcPass 'Renamed)
forall a. Bag a -> Bag a -> Bag a
unionBags (LHsBinds (GhcPass 'Renamed)
 -> LHsBinds (GhcPass 'Renamed) -> LHsBinds (GhcPass 'Renamed))
-> ((RecFlag, LHsBinds (GhcPass 'Renamed))
    -> LHsBinds (GhcPass 'Renamed))
-> (RecFlag, LHsBinds (GhcPass 'Renamed))
-> LHsBinds (GhcPass 'Renamed)
-> LHsBinds (GhcPass 'Renamed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecFlag, LHsBinds (GhcPass 'Renamed))
-> LHsBinds (GhcPass 'Renamed)
forall a b. (a, b) -> b
snd) LHsBinds (GhcPass 'Renamed)
forall a. Bag a
emptyBag [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds)

------------------------
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
             -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
             -> TcM ([(RecFlag, LHsBinds GhcTc)], 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 (GhcPass 'Renamed))]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
tcBindGroups TopLevelFlag
_ TcSigFun
_ TcPragEnv
_ [] TcM thing
thing_inside
  = do  { thing
thing <- TcM thing
thing_inside
        ; ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], thing
thing) }

tcBindGroups TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn ((RecFlag, LHsBinds (GhcPass 'Renamed))
group : [(RecFlag, LHsBinds (GhcPass 'Renamed))]
groups) TcM thing
thing_inside
  = do  { -- See Note [Closed binder groups]
          TcTypeEnv
type_env <- TcM TcTypeEnv
getLclTypeEnv
        ; let closed :: IsGroupClosed
closed = TcTypeEnv -> LHsBinds (GhcPass 'Renamed) -> IsGroupClosed
isClosedBndrGroup TcTypeEnv
type_env ((RecFlag, LHsBinds (GhcPass 'Renamed))
-> LHsBinds (GhcPass 'Renamed)
forall a b. (a, b) -> b
snd (RecFlag, LHsBinds (GhcPass 'Renamed))
group)
        ; ([(RecFlag, LHsBinds (GhcPass 'Typechecked))]
group', ([(RecFlag, LHsBinds (GhcPass 'Typechecked))]
groups', thing
thing))
                <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> (RecFlag, LHsBinds (GhcPass 'Renamed))
-> IsGroupClosed
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM
     ([(RecFlag, LHsBinds (GhcPass 'Typechecked))],
      ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing))
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> (RecFlag, LHsBinds (GhcPass 'Renamed))
-> IsGroupClosed
-> TcM thing
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
tc_group TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn (RecFlag, LHsBinds (GhcPass 'Renamed))
group IsGroupClosed
closed (TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
 -> TcM
      ([(RecFlag, LHsBinds (GhcPass 'Typechecked))],
       ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)))
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM
     ([(RecFlag, LHsBinds (GhcPass 'Typechecked))],
      ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing))
forall a b. (a -> b) -> a -> b
$
                   TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
tcBindGroups TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn [(RecFlag, LHsBinds (GhcPass 'Renamed))]
groups TcM thing
thing_inside
        ; ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag, LHsBinds (GhcPass 'Typechecked))]
group' [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
-> [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
-> [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
forall a. [a] -> [a] -> [a]
++ [(RecFlag, LHsBinds (GhcPass 'Typechecked))]
groups', 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)], 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 (GhcPass 'Renamed))
-> IsGroupClosed
-> TcM thing
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
tc_group TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn (RecFlag
NonRecursive, LHsBinds (GhcPass 'Renamed)
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 :: LHsBind (GhcPass 'Renamed)
bind = case LHsBinds (GhcPass 'Renamed) -> [LHsBind (GhcPass 'Renamed)]
forall a. Bag a -> [a]
bagToList LHsBinds (GhcPass 'Renamed)
binds of
                 [LHsBind (GhcPass 'Renamed)
bind] -> LHsBind (GhcPass 'Renamed)
bind
                 []     -> String -> LHsBind (GhcPass 'Renamed)
forall a. String -> a
panic String
"tc_group: empty list of binds"
                 [LHsBind (GhcPass 'Renamed)]
_      -> String -> LHsBind (GhcPass 'Renamed)
forall a. String -> a
panic String
"tc_group: NonRecursive binds is not a singleton bag"
       ; (LHsBinds (GhcPass 'Typechecked)
bind', thing
thing) <- TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> LHsBind (GhcPass 'Renamed)
-> IsGroupClosed
-> TcM thing
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> LHsBind (GhcPass 'Renamed)
-> IsGroupClosed
-> TcM thing
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
tc_single TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn LHsBind (GhcPass 'Renamed)
bind IsGroupClosed
closed
                                     TcM thing
thing_inside
       ; ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [(RecFlag
NonRecursive, LHsBinds (GhcPass 'Typechecked)
bind')], thing
thing) }

tc_group TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn (RecFlag
Recursive, LHsBinds (GhcPass 'Renamed)
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 -> TcRn ()
traceTc String
"tc_group rec" (LHsBinds (GhcPass 'Renamed) -> SDoc
forall (idL :: Pass) (idR :: Pass).
(OutputableBndrId idL, OutputableBndrId idR) =>
LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds LHsBinds (GhcPass 'Renamed)
binds)
        ; Maybe (LHsBind (GhcPass 'Renamed))
-> (LHsBind (GhcPass 'Renamed) -> TcRn ()) -> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (LHsBind (GhcPass 'Renamed))
mbFirstPatSyn ((LHsBind (GhcPass 'Renamed) -> TcRn ()) -> TcRn ())
-> (LHsBind (GhcPass 'Renamed) -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \LHsBind (GhcPass 'Renamed)
lpat_syn ->
            SrcSpan -> LHsBinds (GhcPass 'Renamed) -> TcRn ()
forall (p :: Pass) a.
(OutputableBndrId p, CollectPass (GhcPass p)) =>
SrcSpan -> LHsBinds (GhcPass p) -> TcM a
recursivePatSynErr (LHsBind (GhcPass 'Renamed) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsBind (GhcPass 'Renamed)
lpat_syn) LHsBinds (GhcPass 'Renamed)
binds
        ; (LHsBinds (GhcPass 'Typechecked)
binds1, thing
thing) <- [SCC (LHsBind (GhcPass 'Renamed))]
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
go [SCC (LHsBind (GhcPass 'Renamed))]
sccs
        ; ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
-> TcM ([(RecFlag, LHsBinds (GhcPass 'Typechecked))], thing)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(RecFlag
Recursive, LHsBinds (GhcPass 'Typechecked)
binds1)], thing
thing) }
                -- Rec them all together
  where
    mbFirstPatSyn :: Maybe (LHsBind (GhcPass 'Renamed))
mbFirstPatSyn = (LHsBind (GhcPass 'Renamed) -> Bool)
-> LHsBinds (GhcPass 'Renamed)
-> Maybe (LHsBind (GhcPass 'Renamed))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed) -> Bool
forall {idL} {idR}. HsBindLR idL idR -> Bool
isPatSyn (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed) -> Bool)
-> (LHsBind (GhcPass 'Renamed)
    -> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> LHsBind (GhcPass 'Renamed)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsBind (GhcPass 'Renamed)
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc) LHsBinds (GhcPass 'Renamed)
binds
    isPatSyn :: HsBindLR idL idR -> Bool
isPatSyn PatSynBind{} = Bool
True
    isPatSyn HsBindLR idL idR
_ = Bool
False

    sccs :: [SCC (LHsBind GhcRn)]
    sccs :: [SCC (LHsBind (GhcPass 'Renamed))]
sccs = [Node BKey (LHsBind (GhcPass 'Renamed))]
-> [SCC (LHsBind (GhcPass 'Renamed))]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq (TcSigFun
-> LHsBinds (GhcPass 'Renamed)
-> [Node BKey (LHsBind (GhcPass 'Renamed))]
mkEdges TcSigFun
sig_fn LHsBinds (GhcPass 'Renamed)
binds)

    go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing)
    go :: [SCC (LHsBind (GhcPass 'Renamed))]
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
go (SCC (LHsBind (GhcPass 'Renamed))
scc:[SCC (LHsBind (GhcPass 'Renamed))]
sccs) = do  { (LHsBinds (GhcPass 'Typechecked)
binds1, [TcId]
ids1) <- SCC (LHsBind (GhcPass 'Renamed))
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tc_scc SCC (LHsBind (GhcPass 'Renamed))
scc
                         -- recursive bindings must be unrestricted
                         -- (the ids added to the environment here are the name of the recursive definitions).
                        ; (LHsBinds (GhcPass 'Typechecked)
binds2, thing
thing) <- TopLevelFlag
-> TcSigFun
-> IsGroupClosed
-> [TcId]
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
forall a.
TopLevelFlag
-> TcSigFun -> IsGroupClosed -> [TcId] -> TcM a -> TcM a
tcExtendLetEnv TopLevelFlag
top_lvl TcSigFun
sig_fn IsGroupClosed
closed [TcId]
ids1
                                                            ([SCC (LHsBind (GhcPass 'Renamed))]
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
go [SCC (LHsBind (GhcPass 'Renamed))]
sccs)
                        ; (LHsBinds (GhcPass 'Typechecked), thing)
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds (GhcPass 'Typechecked)
binds1 LHsBinds (GhcPass 'Typechecked)
-> LHsBinds (GhcPass 'Typechecked)
-> LHsBinds (GhcPass 'Typechecked)
forall a. Bag a -> Bag a -> Bag a
`unionBags` LHsBinds (GhcPass 'Typechecked)
binds2, thing
thing) }
    go []         = do  { thing
thing <- TcM thing
thing_inside; (LHsBinds (GhcPass 'Typechecked), thing)
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds (GhcPass 'Typechecked)
forall a. Bag a
emptyBag, thing
thing) }

    tc_scc :: SCC (LHsBind (GhcPass 'Renamed))
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tc_scc (AcyclicSCC LHsBind (GhcPass 'Renamed)
bind) = RecFlag
-> [LHsBind (GhcPass 'Renamed)]
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tc_sub_group RecFlag
NonRecursive [LHsBind (GhcPass 'Renamed)
bind]
    tc_scc (CyclicSCC [LHsBind (GhcPass 'Renamed)]
binds) = RecFlag
-> [LHsBind (GhcPass 'Renamed)]
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tc_sub_group RecFlag
Recursive    [LHsBind (GhcPass 'Renamed)]
binds

    tc_sub_group :: RecFlag
-> [LHsBind (GhcPass 'Renamed)]
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tc_sub_group RecFlag
rec_tc [LHsBind (GhcPass 'Renamed)]
binds =
      TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBind (GhcPass 'Renamed)]
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tcPolyBinds TcSigFun
sig_fn TcPragEnv
prag_fn RecFlag
Recursive RecFlag
rec_tc IsGroupClosed
closed [LHsBind (GhcPass 'Renamed)]
binds

recursivePatSynErr ::
     (OutputableBndrId p, CollectPass (GhcPass p))
  => SrcSpan -- ^ The location of the first pattern synonym binding
             --   (for error reporting)
  -> LHsBinds (GhcPass p)
  -> TcM a
recursivePatSynErr :: forall (p :: Pass) a.
(OutputableBndrId p, CollectPass (GhcPass p)) =>
SrcSpan -> LHsBinds (GhcPass p) -> TcM a
recursivePatSynErr SrcSpan
loc LHsBinds (GhcPass p)
binds
  = SrcSpan -> SDoc -> TcRn a
forall a. SrcSpan -> SDoc -> TcRn a
failAt SrcSpan
loc (SDoc -> TcRn a) -> SDoc -> TcRn a
forall a b. (a -> b) -> a -> b
$
    SDoc -> BKey -> SDoc -> SDoc
hang (String -> SDoc
text String
"Recursive pattern synonym definition with following bindings:")
       BKey
2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpan (HsBindLR (GhcPass p) (GhcPass p)) -> SDoc)
-> [GenLocated SrcSpan (HsBindLR (GhcPass p) (GhcPass p))]
-> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan (HsBindLR (GhcPass p) (GhcPass p)) -> SDoc
forall {p} {a} {idR}.
(CollectPass p, Outputable (IdP p), Outputable a) =>
GenLocated a (HsBindLR p idR) -> SDoc
pprLBind ([GenLocated SrcSpan (HsBindLR (GhcPass p) (GhcPass p))] -> [SDoc])
-> (LHsBinds (GhcPass p)
    -> [GenLocated SrcSpan (HsBindLR (GhcPass p) (GhcPass p))])
-> LHsBinds (GhcPass p)
-> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsBinds (GhcPass p)
-> [GenLocated SrcSpan (HsBindLR (GhcPass p) (GhcPass p))]
forall a. Bag a -> [a]
bagToList (LHsBinds (GhcPass p) -> [SDoc]) -> LHsBinds (GhcPass p) -> [SDoc]
forall a b. (a -> b) -> a -> b
$ LHsBinds (GhcPass p)
binds)
  where
    pprLoc :: a -> SDoc
pprLoc a
loc  = SDoc -> SDoc
parens (String -> SDoc
text String
"defined at" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
loc)
    pprLBind :: GenLocated a (HsBindLR p idR) -> SDoc
pprLBind (L a
loc HsBindLR p idR
bind) = (IdP p -> SDoc) -> [IdP p] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas IdP p -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsBindLR p idR -> [IdP p]
forall p idR. CollectPass p => HsBindLR p idR -> [IdP p]
collectHsBindBinders HsBindLR p idR
bind)
                                SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
pprLoc a
loc

tc_single :: forall thing.
            TopLevelFlag -> TcSigFun -> TcPragEnv
          -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
          -> TcM (LHsBinds GhcTc, thing)
tc_single :: forall thing.
TopLevelFlag
-> TcSigFun
-> TcPragEnv
-> LHsBind (GhcPass 'Renamed)
-> IsGroupClosed
-> TcM thing
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
tc_single TopLevelFlag
_top_lvl TcSigFun
sig_fn TcPragEnv
_prag_fn
          (L SrcSpan
_ (PatSynBind XPatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)
_ psb :: PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)
psb@PSB{ psb_id :: forall idL idR. PatSynBind idL idR -> Located (IdP idL)
psb_id = L SrcSpan
_ IdP (GhcPass 'Renamed)
name }))
          IsGroupClosed
_ TcM thing
thing_inside
  = do { (LHsBinds (GhcPass 'Typechecked)
aux_binds, TcGblEnv
tcg_env) <- PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)
-> Maybe TcSigInfo
-> TcM (LHsBinds (GhcPass 'Typechecked), TcGblEnv)
tcPatSynDecl PatSynBind (GhcPass 'Renamed) (GhcPass 'Renamed)
psb (TcSigFun
sig_fn Name
IdP (GhcPass 'Renamed)
name)
       ; thing
thing <- TcGblEnv -> TcM thing -> TcM thing
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env TcM thing
thing_inside
       ; (LHsBinds (GhcPass 'Typechecked), thing)
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds (GhcPass 'Typechecked)
aux_binds, thing
thing)
       }

tc_single TopLevelFlag
top_lvl TcSigFun
sig_fn TcPragEnv
prag_fn LHsBind (GhcPass 'Renamed)
lbind IsGroupClosed
closed TcM thing
thing_inside
  = do { (LHsBinds (GhcPass 'Typechecked)
binds1, [TcId]
ids) <- TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBind (GhcPass 'Renamed)]
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tcPolyBinds TcSigFun
sig_fn TcPragEnv
prag_fn
                                      RecFlag
NonRecursive RecFlag
NonRecursive
                                      IsGroupClosed
closed
                                      [LHsBind (GhcPass 'Renamed)
lbind]
         -- since we are defining a non-recursive binding, it is not necessary here
         -- to define an unrestricted binding. But we do so until toplevel linear bindings are supported.
       ; thing
thing <- TopLevelFlag
-> TcSigFun -> IsGroupClosed -> [TcId] -> TcM thing -> TcM thing
forall a.
TopLevelFlag
-> TcSigFun -> IsGroupClosed -> [TcId] -> TcM a -> TcM a
tcExtendLetEnv TopLevelFlag
top_lvl TcSigFun
sig_fn IsGroupClosed
closed [TcId]
ids TcM thing
thing_inside
       ; (LHsBinds (GhcPass 'Typechecked), thing)
-> TcM (LHsBinds (GhcPass 'Typechecked), thing)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds (GhcPass 'Typechecked)
binds1, 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 (GhcPass 'Renamed)
-> [Node BKey (LHsBind (GhcPass 'Renamed))]
mkEdges TcSigFun
sig_fn LHsBinds (GhcPass 'Renamed)
binds
  = [ LHsBind (GhcPass 'Renamed)
-> BKey -> [BKey] -> Node BKey (LHsBind (GhcPass 'Renamed))
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode LHsBind (GhcPass 'Renamed)
bind BKey
key [BKey
key | Name
n <- UniqSet Name -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
forall {idL} {idR}.
(XPatBind idL idR ~ XFunBind idL idR,
 XFunBind idL idR ~ UniqSet Name) =>
HsBindLR idL idR -> XFunBind idL idR
bind_fvs (LHsBind (GhcPass 'Renamed)
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc LHsBind (GhcPass 'Renamed)
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 ]
    | (LHsBind (GhcPass 'Renamed)
bind, BKey
key) <- [(LHsBind (GhcPass 'Renamed), 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 }) = XFunBind idL idR
XPatBind idL idR
fvs
    bind_fvs HsBindLR idL idR
_                           = UniqSet Name
XFunBind idL idR
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 :: [(LHsBind (GhcPass 'Renamed), BKey)]
keyd_binds = LHsBinds (GhcPass 'Renamed) -> [LHsBind (GhcPass 'Renamed)]
forall a. Bag a -> [a]
bagToList LHsBinds (GhcPass 'Renamed)
binds [LHsBind (GhcPass 'Renamed)]
-> [BKey] -> [(LHsBind (GhcPass 'Renamed), 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 SrcSpan
_ HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
bind, BKey
key) <- [(LHsBind (GhcPass 'Renamed), BKey)]
keyd_binds
                                     , Name
bndr <- HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> [IdP (GhcPass 'Renamed)]
forall p idR. CollectPass p => HsBindLR p idR -> [IdP p]
collectHsBindBinders HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
bind ]

------------------------
tcPolyBinds :: TcSigFun -> TcPragEnv
            -> RecFlag         -- Whether the group is really recursive
            -> RecFlag         -- Whether it's recursive after breaking
                               -- dependencies based on type signatures
            -> IsGroupClosed   -- Whether the group is closed
            -> [LHsBind GhcRn]  -- None are PatSynBind
            -> TcM (LHsBinds GhcTc, [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 :: TcSigFun
-> TcPragEnv
-> RecFlag
-> RecFlag
-> IsGroupClosed
-> [LHsBind (GhcPass 'Renamed)]
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tcPolyBinds TcSigFun
sig_fn TcPragEnv
prag_fn RecFlag
rec_group RecFlag
rec_tc IsGroupClosed
closed [LHsBind (GhcPass 'Renamed)]
bind_list
  = SrcSpan
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc                              (TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
 -> TcM (LHsBinds (GhcPass 'Typechecked), [TcId]))
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
forall a b. (a -> b) -> a -> b
$
    TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
forall r. TcRn r -> TcRn r -> TcRn r
recoverM ([Name] -> TcSigFun -> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
recoveryCode [Name]
[IdP (GhcPass 'Renamed)]
binder_names TcSigFun
sig_fn) (TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
 -> TcM (LHsBinds (GhcPass 'Typechecked), [TcId]))
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
forall a b. (a -> b) -> a -> b
$ do
        -- Set up main recover; take advantage of any type sigs

    { String -> SDoc -> TcRn ()
traceTc String
"------------------------------------------------" SDoc
Outputable.empty
    ; String -> SDoc -> TcRn ()
traceTc String
"Bindings for {" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
[IdP (GhcPass 'Renamed)]
binder_names)
    ; DynFlags
dflags   <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    ; let plan :: GeneralisationPlan
plan = DynFlags
-> [LHsBind (GhcPass 'Renamed)]
-> IsGroupClosed
-> TcSigFun
-> GeneralisationPlan
decideGeneralisationPlan DynFlags
dflags [LHsBind (GhcPass 'Renamed)]
bind_list IsGroupClosed
closed TcSigFun
sig_fn
    ; String -> SDoc -> TcRn ()
traceTc String
"Generalisation plan" (GeneralisationPlan -> SDoc
forall a. Outputable a => a -> SDoc
ppr GeneralisationPlan
plan)
    ; result :: (LHsBinds (GhcPass 'Typechecked), [TcId])
result@(LHsBinds (GhcPass 'Typechecked)
_, [TcId]
poly_ids) <- case GeneralisationPlan
plan of
         GeneralisationPlan
NoGen              -> RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBind (GhcPass 'Renamed)]
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tcPolyNoGen RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
sig_fn [LHsBind (GhcPass 'Renamed)]
bind_list
         InferGen Bool
mn        -> RecFlag
-> TcPragEnv
-> TcSigFun
-> Bool
-> [LHsBind (GhcPass 'Renamed)]
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tcPolyInfer RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
sig_fn Bool
mn [LHsBind (GhcPass 'Renamed)]
bind_list
         CheckGen LHsBind (GhcPass 'Renamed)
lbind TcIdSigInfo
sig -> TcPragEnv
-> TcIdSigInfo
-> LHsBind (GhcPass 'Renamed)
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tcPolyCheck TcPragEnv
prag_fn TcIdSigInfo
sig LHsBind (GhcPass 'Renamed)
lbind

    ; String -> SDoc -> TcRn ()
traceTc String
"} End of bindings for" ([SDoc] -> SDoc
vcat [ [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
[IdP (GhcPass 'Renamed)]
binder_names, RecFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecFlag
rec_group
                                            , [SDoc] -> SDoc
vcat [TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
id SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
idType TcId
id) | TcId
id <- [TcId]
poly_ids]
                                          ])

    ; (LHsBinds (GhcPass 'Typechecked), [TcId])
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds (GhcPass 'Typechecked), [TcId])
result }
  where
    binder_names :: [IdP (GhcPass 'Renamed)]
binder_names = [LHsBind (GhcPass 'Renamed)] -> [IdP (GhcPass 'Renamed)]
forall p idR. CollectPass p => [LHsBindLR p idR] -> [IdP p]
collectHsBindListBinders [LHsBind (GhcPass 'Renamed)]
bind_list
    loc :: SrcSpan
loc = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans ((LHsBind (GhcPass 'Renamed) -> SrcSpan)
-> [LHsBind (GhcPass 'Renamed)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map LHsBind (GhcPass 'Renamed) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc [LHsBind (GhcPass 'Renamed)]
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, [Id])
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
recoveryCode [Name]
binder_names TcSigFun
sig_fn
  = do  { String -> SDoc -> TcRn ()
traceTc String
"tcBindsWithSigs: error recovery" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
binder_names)
        ; let poly_ids :: [TcId]
poly_ids = (Name -> TcId) -> [Name] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TcId
mk_dummy [Name]
binder_names
        ; (LHsBinds (GhcPass 'Typechecked), [TcId])
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds (GhcPass 'Typechecked)
forall a. Bag a
emptyBag, [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
Many 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, [TcId])

tcPolyNoGen :: RecFlag
-> TcPragEnv
-> TcSigFun
-> [LHsBind (GhcPass 'Renamed)]
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tcPolyNoGen RecFlag
rec_tc TcPragEnv
prag_fn TcSigFun
tc_sig_fn [LHsBind (GhcPass 'Renamed)]
bind_list
  = do { (LHsBinds (GhcPass 'Typechecked)
binds', [MonoBindInfo]
mono_infos) <- RecFlag
-> TcSigFun
-> LetBndrSpec
-> [LHsBind (GhcPass 'Renamed)]
-> TcM (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo])
tcMonoBinds RecFlag
rec_tc TcSigFun
tc_sig_fn
                                             (TcPragEnv -> LetBndrSpec
LetGblBndr TcPragEnv
prag_fn)
                                             [LHsBind (GhcPass 'Renamed)]
bind_list
       ; [TcId]
mono_ids' <- (MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcId)
-> [MonoBindInfo] -> TcM [TcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcId
tc_mono_info [MonoBindInfo]
mono_infos
       ; (LHsBinds (GhcPass 'Typechecked), [TcId])
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds (GhcPass 'Typechecked)
binds', [TcId]
mono_ids') }
  where
    tc_mono_info :: MonoBindInfo -> IOEnv (Env TcGblEnv TcLclEnv) 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 })
      = do { [LTcSpecPrag]
_specs <- TcId -> [LSig (GhcPass 'Renamed)] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
mono_id (TcPragEnv -> Name -> [LSig (GhcPass 'Renamed)]
lookupPragEnv TcPragEnv
prag_fn Name
name)
           ; TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
forall (m :: * -> *) a. Monad m => a -> m a
return 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
            -> TcIdSigInfo     -- Must be a complete signature
            -> LHsBind GhcRn   -- Must be a FunBind
            -> TcM (LHsBinds GhcTc, [TcId])
-- There is just one binding,
--   it is a FunBind
--   it has a complete type signature,
tcPolyCheck :: TcPragEnv
-> TcIdSigInfo
-> LHsBind (GhcPass 'Renamed)
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
tcPolyCheck TcPragEnv
prag_fn
            (CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr  = TcId
poly_id
                         , sig_ctxt :: TcIdSigInfo -> UserTypeCtxt
sig_ctxt  = UserTypeCtxt
ctxt
                         , sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc   = SrcSpan
sig_loc })
            (L SrcSpan
bind_loc (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = L SrcSpan
nm_loc IdP (GhcPass 'Renamed)
name
                                 , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches }))
  = do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyCheck" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
$$ SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
sig_loc)

       ; Name
mono_name <- OccName -> SrcSpan -> TcM Name
newNameAt (Name -> OccName
nameOccName Name
IdP (GhcPass 'Renamed)
name) SrcSpan
nm_loc
       ; (HsWrapper
wrap_gen, (HsWrapper
wrap_res, MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
matches'))
             <- SrcSpan
-> TcRn
     (HsWrapper,
      (HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
-> TcRn
     (HsWrapper,
      (HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
sig_loc (TcRn
   (HsWrapper,
    (HsWrapper,
     MatchGroup
       (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
 -> TcRn
      (HsWrapper,
       (HsWrapper,
        MatchGroup
          (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))))
-> TcRn
     (HsWrapper,
      (HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
-> TcRn
     (HsWrapper,
      (HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
forall a b. (a -> b) -> a -> b
$ -- Sets the binding location for the skolems
                UserTypeCtxt
-> Kind
-> (Kind
    -> TcM
         (HsWrapper,
          MatchGroup
            (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
-> TcRn
     (HsWrapper,
      (HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
forall result.
UserTypeCtxt
-> Kind -> (Kind -> TcM result) -> TcM (HsWrapper, result)
tcSkolemiseScoped UserTypeCtxt
ctxt (TcId -> Kind
idType TcId
poly_id) ((Kind
  -> TcM
       (HsWrapper,
        MatchGroup
          (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
 -> TcRn
      (HsWrapper,
       (HsWrapper,
        MatchGroup
          (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))))
-> (Kind
    -> TcM
         (HsWrapper,
          MatchGroup
            (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
-> TcRn
     (HsWrapper,
      (HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
forall a b. (a -> b) -> a -> b
$ \Kind
rho_ty ->
                -- Unwraps multiple layers; e.g
                --    f :: forall a. Eq a => forall b. Ord b => blah
                -- NB: tcSkolemise makes fresh type variables
                -- See Note [Instantiate sig with fresh variables]

                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 (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [TcId -> TopLevelFlag -> TcBinder
TcIdBndr TcId
mono_id TopLevelFlag
NotTopLevel] (TcM
   (HsWrapper,
    MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
 -> TcM
      (HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$
                -- Why mono_id in the BinderStack?
                --    See Note [Relevant bindings and the binder stack]

                SrcSpan
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
bind_loc (TcM
   (HsWrapper,
    MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
 -> TcM
      (HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$
                Located Name
-> MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> ExpSigmaType
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
tcMatchesFun (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
nm_loc Name
mono_name) MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches
                             (Kind -> ExpSigmaType
mkCheckExpType Kind
rho_ty)

       -- We make a funny AbsBinds, abstracting over nothing,
       -- just so we haev 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 (GhcPass 'Renamed)]
prag_sigs = TcPragEnv -> Name -> [LSig (GhcPass 'Renamed)]
lookupPragEnv TcPragEnv
prag_fn Name
IdP (GhcPass 'Renamed)
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 (GhcPass 'Renamed)] -> TcM [LTcSpecPrag]
tcSpecPrags    TcId
poly_id [LSig (GhcPass 'Renamed)]
prag_sigs
       ; TcId
poly_id    <- TcId
-> [LSig (GhcPass 'Renamed)] -> IOEnv (Env TcGblEnv TcLclEnv) TcId
addInlinePrags TcId
poly_id [LSig (GhcPass 'Renamed)]
prag_sigs

       ; Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       ; [Tickish TcId]
tick <- SrcSpan
-> TcId
-> Module
-> [LSig (GhcPass 'Renamed)]
-> TcM [Tickish TcId]
funBindTicks SrcSpan
nm_loc TcId
poly_id Module
mod [LSig (GhcPass 'Renamed)]
prag_sigs

       ; let bind' :: HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
bind' = FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> [Tickish TcId]
-> HsBindLR idL idR
FunBind { fun_id :: Located (IdP (GhcPass 'Typechecked))
fun_id      = SrcSpan -> TcId -> GenLocated SrcSpan TcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
nm_loc TcId
poly_id2
                             , fun_matches :: MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
fun_matches = MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
matches'
                             , fun_ext :: XFunBind (GhcPass 'Typechecked) (GhcPass 'Typechecked)
fun_ext     = HsWrapper
wrap_gen HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap_res
                             , fun_tick :: [Tickish TcId]
fun_tick    = [Tickish TcId]
tick }

             export :: ABExport (GhcPass 'Typechecked)
export = ABE :: forall p.
XABE p -> IdP p -> IdP p -> HsWrapper -> TcSpecPrags -> ABExport p
ABE { abe_ext :: XABE (GhcPass 'Typechecked)
abe_ext   = NoExtField
XABE (GhcPass 'Typechecked)
noExtField
                          , abe_wrap :: HsWrapper
abe_wrap  = HsWrapper
idHsWrapper
                          , abe_poly :: IdP (GhcPass 'Typechecked)
abe_poly  = TcId
IdP (GhcPass 'Typechecked)
poly_id
                          , abe_mono :: IdP (GhcPass 'Typechecked)
abe_mono  = TcId
IdP (GhcPass 'Typechecked)
poly_id2
                          , abe_prags :: TcSpecPrags
abe_prags = [LTcSpecPrag] -> TcSpecPrags
SpecPrags [LTcSpecPrag]
spec_prags }

             abs_bind :: GenLocated
  SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
abs_bind = SrcSpan
-> HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> GenLocated
     SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L SrcSpan
bind_loc (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
 -> GenLocated
      SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> GenLocated
     SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$
                        AbsBinds :: forall idL idR.
XAbsBinds idL idR
-> [TcId]
-> [TcId]
-> [ABExport idL]
-> [TcEvBinds]
-> LHsBinds idL
-> Bool
-> HsBindLR idL idR
AbsBinds { abs_ext :: XAbsBinds (GhcPass 'Typechecked) (GhcPass 'Typechecked)
abs_ext      = NoExtField
XAbsBinds (GhcPass 'Typechecked) (GhcPass 'Typechecked)
noExtField
                                 , abs_tvs :: [TcId]
abs_tvs      = []
                                 , abs_ev_vars :: [TcId]
abs_ev_vars  = []
                                 , abs_ev_binds :: [TcEvBinds]
abs_ev_binds = []
                                 , abs_exports :: [ABExport (GhcPass 'Typechecked)]
abs_exports  = [ABExport (GhcPass 'Typechecked)
export]
                                 , abs_binds :: LHsBinds (GhcPass 'Typechecked)
abs_binds    = GenLocated
  SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> LHsBinds (GhcPass 'Typechecked)
forall a. a -> Bag a
unitBag (SrcSpan
-> HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> GenLocated
     SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L SrcSpan
bind_loc HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
bind')
                                 , abs_sig :: Bool
abs_sig      = Bool
True }

       ; (LHsBinds (GhcPass 'Typechecked), [TcId])
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
  SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> LHsBinds (GhcPass 'Typechecked)
forall a. a -> Bag a
unitBag GenLocated
  SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
abs_bind, [TcId
poly_id]) }

tcPolyCheck TcPragEnv
_prag_fn TcIdSigInfo
sig LHsBind (GhcPass 'Renamed)
bind
  = String -> SDoc -> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcPolyCheck" (TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
sig SDoc -> SDoc -> SDoc
$$ LHsBind (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBind (GhcPass 'Renamed)
bind)

funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
             -> TcM [Tickish TcId]
funBindTicks :: SrcSpan
-> TcId
-> Module
-> [LSig (GhcPass 'Renamed)]
-> TcM [Tickish TcId]
funBindTicks SrcSpan
loc TcId
fun_id Module
mod [LSig (GhcPass 'Renamed)]
sigs
  | (Maybe (Located StringLiteral)
mb_cc_str : [Maybe (Located StringLiteral)]
_) <- [ Maybe (Located StringLiteral)
cc_name | L SrcSpan
_ (SCCFunSig XSCCFunSig (GhcPass 'Renamed)
_ SourceText
_ Located (IdP (GhcPass 'Renamed))
_ Maybe (Located StringLiteral)
cc_name) <- [LSig (GhcPass 'Renamed)]
sigs ]
      -- this can only be a singleton list, as duplicate pragmas are rejected
      -- by the renamer
  , let cc_str :: FastString
cc_str
          | Just Located StringLiteral
cc_str <- Maybe (Located StringLiteral)
mb_cc_str
          = StringLiteral -> FastString
sl_fs (StringLiteral -> FastString) -> StringLiteral -> FastString
forall a b. (a -> b) -> a -> b
$ Located StringLiteral -> StringLiteral
forall l e. GenLocated l e -> e
unLoc Located 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 = ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) FastString -> FastString -> FastString
`appendFS` Char -> FastString -> FastString
consFS Char
'.' FastString
cc_str
  = do
      CCFlavour
flavour <- CostCentreIndex -> CCFlavour
DeclCC (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
forall gbl lcl.
ContainsCostCentreState gbl =>
FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM FastString
cc_name
      let cc :: CostCentre
cc = FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC FastString
cc_name Module
mod SrcSpan
loc CCFlavour
flavour
      [Tickish TcId] -> TcM [Tickish TcId]
forall (m :: * -> *) a. Monad m => a -> m a
return [CostCentre -> Bool -> Bool -> Tickish TcId
forall id. CostCentre -> Bool -> Bool -> Tickish id
ProfNote CostCentre
cc Bool
True Bool
True]
  | Bool
otherwise
  = [Tickish TcId] -> TcM [Tickish TcId]
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
*                                                                      *
********************************************************************* -}

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

       ; 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
mono then InferMode
ApplyMR else InferMode
NoRestrictions

       ; (TcIdSigInst -> TcRn ()) -> [TcIdSigInst] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> TcIdSigInst -> TcRn ()
checkOverloadedSig Bool
mono) [TcIdSigInst]
sigs

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

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

       ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
       ; let poly_ids :: [TcId]
poly_ids = (ABExport (GhcPass 'Typechecked) -> TcId)
-> [ABExport (GhcPass 'Typechecked)] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map ABExport (GhcPass 'Typechecked) -> TcId
forall p. ABExport p -> IdP p
abe_poly [ABExport (GhcPass 'Typechecked)]
exports
             abs_bind :: GenLocated
  SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
abs_bind = SrcSpan
-> HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> GenLocated
     SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
 -> GenLocated
      SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> GenLocated
     SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$
                        AbsBinds :: forall idL idR.
XAbsBinds idL idR
-> [TcId]
-> [TcId]
-> [ABExport idL]
-> [TcEvBinds]
-> LHsBinds idL
-> Bool
-> HsBindLR idL idR
AbsBinds { abs_ext :: XAbsBinds (GhcPass 'Typechecked) (GhcPass 'Typechecked)
abs_ext = NoExtField
XAbsBinds (GhcPass 'Typechecked) (GhcPass 'Typechecked)
noExtField
                                 , 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 (GhcPass 'Typechecked)]
abs_exports = [ABExport (GhcPass 'Typechecked)]
exports, abs_binds :: LHsBinds (GhcPass 'Typechecked)
abs_binds = LHsBinds (GhcPass 'Typechecked)
binds'
                                 , abs_sig :: Bool
abs_sig = Bool
False }

       ; String -> SDoc -> TcRn ()
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))
       ; (LHsBinds (GhcPass 'Typechecked), [TcId])
-> TcM (LHsBinds (GhcPass 'Typechecked), [TcId])
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
  SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> LHsBinds (GhcPass 'Typechecked)
forall a. a -> Bag a
unitBag GenLocated
  SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
abs_bind, [TcId]
poly_ids) }
         -- poly_ids are guaranteed zonked by mkExport

--------------
mkExport :: TcPragEnv
         -> Bool                        -- True <=> there was an insoluble type error
                                        --          when typechecking the bindings
         -> [TyVar] -> TcThetaType      -- Both already zonked
         -> MonoBindInfo
         -> TcM (ABExport GhcTc)
-- Only called for generalisation plan InferGen, not by CheckGen or NoGen
--
-- mkExport generates exports with
--      zonked type variables,
--      zonked poly_ids
-- 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
-> Bool
-> [TcId]
-> TcThetaType
-> MonoBindInfo
-> IOEnv (Env TcGblEnv TcLclEnv) (ABExport (GhcPass 'Typechecked))
mkExport TcPragEnv
prag_fn Bool
insoluble [TcId]
qtvs TcThetaType
theta
         mono_info :: MonoBindInfo
mono_info@(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 })
  = do  { Kind
mono_ty <- Kind -> TcM Kind
zonkTcType (TcId -> Kind
idType TcId
mono_id)
        ; TcId
poly_id <- Bool
-> [TcId]
-> TcThetaType
-> Name
-> Maybe TcIdSigInst
-> Kind
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
mkInferredPolyId 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 (GhcPass 'Renamed)] -> IOEnv (Env TcGblEnv TcLclEnv) TcId
addInlinePrags TcId
poly_id [LSig (GhcPass 'Renamed)]
prag_sigs
        ; [LTcSpecPrag]
spec_prags <- TcId -> [LSig (GhcPass 'Renamed)] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
poly_id [LSig (GhcPass 'Renamed)]
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
mkInfSigmaTy [TcId]
qtvs TcThetaType
theta Kind
mono_ty
                -- This type is just going into tcSubType,
                -- so Inferred vs. Specified doesn't matter

        ; HsWrapper
wrap <- if Kind
sel_poly_ty Kind -> Kind -> Bool
`eqType` Kind
poly_ty  -- NB: eqType ignores visibility
                  then HsWrapper -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
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 (TidyEnv -> TcM (TidyEnv, SDoc))
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (MonoBindInfo -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_impedance_match_msg MonoBindInfo
mono_info Kind
sel_poly_ty Kind
poly_ty) (IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
 -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper)
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
forall a b. (a -> b) -> a -> b
$
                       UserTypeCtxt
-> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
tcSubTypeSigma UserTypeCtxt
sig_ctxt Kind
sel_poly_ty Kind
poly_ty

        ; Bool
warn_missing_sigs <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingLocalSignatures
        ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warn_missing_sigs (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
              WarningFlag -> TcId -> Maybe TcIdSigInst -> TcRn ()
localSigWarn WarningFlag
Opt_WarnMissingLocalSignatures TcId
poly_id Maybe TcIdSigInst
mb_sig

        ; ABExport (GhcPass 'Typechecked)
-> IOEnv (Env TcGblEnv TcLclEnv) (ABExport (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return (ABE :: forall p.
XABE p -> IdP p -> IdP p -> HsWrapper -> TcSpecPrags -> ABExport p
ABE { abe_ext :: XABE (GhcPass 'Typechecked)
abe_ext = NoExtField
XABE (GhcPass 'Typechecked)
noExtField
                      , abe_wrap :: HsWrapper
abe_wrap = HsWrapper
wrap
                        -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
                      , abe_poly :: IdP (GhcPass 'Typechecked)
abe_poly  = TcId
IdP (GhcPass 'Typechecked)
poly_id
                      , abe_mono :: IdP (GhcPass 'Typechecked)
abe_mono  = TcId
IdP (GhcPass 'Typechecked)
mono_id
                      , abe_prags :: TcSpecPrags
abe_prags = [LTcSpecPrag] -> TcSpecPrags
SpecPrags [LTcSpecPrag]
spec_prags }) }
  where
    prag_sigs :: [LSig (GhcPass 'Renamed)]
prag_sigs = TcPragEnv -> Name -> [LSig (GhcPass 'Renamed)]
lookupPragEnv TcPragEnv
prag_fn Name
poly_name
    sig_ctxt :: UserTypeCtxt
sig_ctxt  = Name -> UserTypeCtxt
InfSigCtxt Name
poly_name

mkInferredPolyId :: Bool  -- True <=> there was an insoluble error when
                          --          checking the binding group for this Id
                 -> [TyVar] -> TcThetaType
                 -> Name -> Maybe TcIdSigInst -> TcType
                 -> TcM TcId
mkInferredPolyId :: Bool
-> [TcId]
-> TcThetaType
-> Name
-> Maybe TcIdSigInst
-> Kind
-> IOEnv (Env TcGblEnv TcLclEnv) TcId
mkInferredPolyId Bool
insoluble [TcId]
qtvs TcThetaType
inferred_theta Name
poly_name Maybe TcIdSigInst
mb_sig_inst Kind
mono_ty
  | Just (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSigInfo
sig_inst_sig = TcIdSigInfo
sig })  <- Maybe TcIdSigInst
mb_sig_inst
  , CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
poly_id } <- TcIdSigInfo
sig
  = TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
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 (TcCoercionR
_co, Kind
mono_ty') = FamInstEnvs -> Role -> Kind -> (TcCoercionR, Kind)
normaliseType FamInstEnvs
fam_envs Role
Nominal Kind
mono_ty
               -- Unification may not have normalised the type,
               -- (see Note [Lazy flattening] in GHC.Tc.Solver.Flatten) 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

       ; ([InvisTVBinder]
binders, TcThetaType
theta') <- TcThetaType
-> TcTyVarSet
-> [TcId]
-> Maybe TcIdSigInst
-> TcM ([InvisTVBinder], TcThetaType)
chooseInferredQuantifiers TcThetaType
inferred_theta
                                (Kind -> TcTyVarSet
tyCoVarsOfType Kind
mono_ty') [TcId]
qtvs Maybe TcIdSigInst
mb_sig_inst

       ; let inferred_poly_ty :: Kind
inferred_poly_ty = [InvisTVBinder] -> Kind -> Kind
mkInvisForAllTys [InvisTVBinder]
binders (TcThetaType -> Kind -> Kind
mkPhiTy TcThetaType
theta' Kind
mono_ty')

       ; String -> SDoc -> TcRn ()
traceTc String
"mkInferredPolyId" ([SDoc] -> SDoc
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])
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
insoluble (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcRn () -> TcRn ()
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (Name -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_inf_msg Name
poly_name Kind
inferred_poly_ty) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         UserTypeCtxt -> Kind -> TcRn ()
checkValidType (Name -> UserTypeCtxt
InfSigCtxt Name
poly_name) Kind
inferred_poly_ty
         -- See Note [Validity of inferred types]
         -- 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 (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
poly_name Kind
Many Kind
inferred_poly_ty) }


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

chooseInferredQuantifiers TcThetaType
inferred_theta TcTyVarSet
tau_tvs [TcId]
qtvs
                          (Just (TISI { sig_inst_sig :: TcIdSigInst -> TcIdSigInfo
sig_inst_sig   = TcIdSigInfo
sig  -- Always PartialSig
                                      , 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, InvisTVBinder)]
sig_inst_skols = [(Name, InvisTVBinder)]
annotated_tvs }))
  = -- Choose quantifiers for a partial type signature
    do { let ([Name]
psig_qtv_nms, [InvisTVBinder]
psig_qtv_bndrs) = [(Name, InvisTVBinder)] -> ([Name], [InvisTVBinder])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, InvisTVBinder)]
annotated_tvs
       ; [InvisTVBinder]
psig_qtv_bndrs <- (InvisTVBinder -> IOEnv (Env TcGblEnv TcLclEnv) InvisTVBinder)
-> [InvisTVBinder] -> IOEnv (Env TcGblEnv TcLclEnv) [InvisTVBinder]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM InvisTVBinder -> IOEnv (Env TcGblEnv TcLclEnv) InvisTVBinder
forall spec. VarBndr TcId spec -> TcM (VarBndr TcId spec)
zonkInvisTVBinder [InvisTVBinder]
psig_qtv_bndrs
       ; let psig_qtvs :: [TcId]
psig_qtvs    = (InvisTVBinder -> TcId) -> [InvisTVBinder] -> [TcId]
forall a b. (a -> b) -> [a] -> [b]
map InvisTVBinder -> TcId
forall tv argf. VarBndr tv argf -> tv
binderVar [InvisTVBinder]
psig_qtv_bndrs
             psig_qtv_set :: TcTyVarSet
psig_qtv_set = [TcId] -> TcTyVarSet
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


            -- Check whether the quantified variables of the
            -- partial signature have been unified together
            -- See Note [Quantified variables in partial type signatures]
       ; ((Name, Name) -> TcRn ()) -> [(Name, Name)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, Name) -> TcRn ()
report_dup_tyvar_tv_err  ([(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 -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> TcRn ()
report_mono_sig_tv_err [ Name
n | (Name
n,TcId
tv) <- [(Name, TcId)]
psig_qtv_prs
                                          , Bool -> Bool
not (TcId
tv TcId -> [TcId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TcId]
qtvs) ]

       ; TcThetaType
annotated_theta      <- TcThetaType -> TcM TcThetaType
zonkTcTypes TcThetaType
annotated_theta
       ; (TcTyVarSet
free_tvs, TcThetaType
my_theta) <- TcTyVarSet
-> TcThetaType -> Maybe Kind -> TcM (TcTyVarSet, TcThetaType)
choose_psig_context TcTyVarSet
psig_qtv_set TcThetaType
annotated_theta Maybe Kind
wcx

       ; let keep_me :: TcTyVarSet
keep_me    = TcTyVarSet
free_tvs TcTyVarSet -> TcTyVarSet -> TcTyVarSet
`unionVarSet` TcTyVarSet
psig_qtv_set
             final_qtvs :: [InvisTVBinder]
final_qtvs = [ Specificity -> TcId -> InvisTVBinder
forall vis. vis -> TcId -> VarBndr TcId vis
mkTyVarBinder Specificity
vis TcId
tv
                          | TcId
tv <- [TcId]
qtvs -- Pulling from qtvs maintains original order
                          , TcId
tv TcId -> TcTyVarSet -> Bool
`elemVarSet` TcTyVarSet
keep_me
                          , let vis :: Specificity
vis = case TcId -> [InvisTVBinder] -> Maybe Specificity
forall var flag. Eq var => var -> [VarBndr var flag] -> Maybe flag
lookupVarBndr TcId
tv [InvisTVBinder]
psig_qtv_bndrs of
                                  Just Specificity
spec -> Specificity
spec
                                  Maybe Specificity
Nothing   -> Specificity
InferredSpec ]

       ; ([InvisTVBinder], TcThetaType)
-> TcM ([InvisTVBinder], TcThetaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([InvisTVBinder]
final_qtvs, TcThetaType
my_theta) }
  where
    report_dup_tyvar_tv_err :: (Name, Name) -> TcRn ()
report_dup_tyvar_tv_err (Name
n1,Name
n2)
      | PartialSig { psig_name :: TcIdSigInfo -> Name
psig_name = Name
fn_name, psig_hs_ty :: TcIdSigInfo -> LHsSigWcType (GhcPass 'Renamed)
psig_hs_ty = LHsSigWcType (GhcPass 'Renamed)
hs_ty } <- TcIdSigInfo
sig
      = SDoc -> TcRn ()
addErrTc (SDoc -> BKey -> SDoc -> SDoc
hang (String -> SDoc
text String
"Couldn't match" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n1)
                        SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n2))
                     BKey
2 (SDoc -> BKey -> SDoc -> SDoc
hang (String -> SDoc
text String
"both bound by the partial type signature:")
                           BKey
2 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fn_name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LHsSigWcType (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType (GhcPass 'Renamed)
hs_ty)))

      | Bool
otherwise -- Can't happen; by now we know it's a partial sig
      = String -> SDoc -> TcRn ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"report_tyvar_tv_err" (TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
sig)

    report_mono_sig_tv_err :: Name -> TcRn ()
report_mono_sig_tv_err Name
n
      | PartialSig { psig_name :: TcIdSigInfo -> Name
psig_name = Name
fn_name, psig_hs_ty :: TcIdSigInfo -> LHsSigWcType (GhcPass 'Renamed)
psig_hs_ty = LHsSigWcType (GhcPass 'Renamed)
hs_ty } <- TcIdSigInfo
sig
      = SDoc -> TcRn ()
addErrTc (SDoc -> BKey -> SDoc -> SDoc
hang (String -> SDoc
text String
"Can't quantify over" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n))
                     BKey
2 (SDoc -> BKey -> SDoc -> SDoc
hang (String -> SDoc
text String
"bound by the partial type signature:")
                           BKey
2 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fn_name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LHsSigWcType (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType (GhcPass 'Renamed)
hs_ty)))
      | Bool
otherwise -- Can't happen; by now we know it's a partial sig
      = String -> SDoc -> TcRn ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"report_mono_sig_tv_err" (TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
sig)

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

    choose_psig_context TcTyVarSet
psig_qtvs TcThetaType
annotated_theta (Just Kind
wc_var_ty)
      = do { let free_tvs :: TcTyVarSet
free_tvs = TcTyVarSet -> TcTyVarSet
closeOverKinds (TcThetaType -> TcTyVarSet -> TcTyVarSet
growThetaTyVars TcThetaType
inferred_theta TcTyVarSet
seed_tvs)
                            -- growThetaVars just like the no-type-sig case
                            -- Omitting this caused #12844
                 seed_tvs :: TcTyVarSet
seed_tvs = TcThetaType -> TcTyVarSet
tyCoVarsOfTypes TcThetaType
annotated_theta  -- These are put there
                            TcTyVarSet -> TcTyVarSet -> TcTyVarSet
`unionVarSet` TcTyVarSet
tau_tvs            --       by the user

           ; let keep_me :: TcTyVarSet
keep_me  = TcTyVarSet
psig_qtvs TcTyVarSet -> TcTyVarSet -> TcTyVarSet
`unionVarSet` TcTyVarSet
free_tvs
                 my_theta :: TcThetaType
my_theta = TcTyVarSet -> TcThetaType -> TcThetaType
pickCapturedPreds TcTyVarSet
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
           ; let inferred_diff :: TcThetaType
inferred_diff = [ Kind
pred
                                 | Kind
pred <- TcThetaType
my_theta
                                 , (Kind -> Bool) -> TcThetaType -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (Kind -> Bool) -> Kind -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Kind -> Kind -> Bool
`eqType` Kind
pred)) TcThetaType
annotated_theta ]
           ; Kind
ctuple <- TcThetaType -> TcM Kind
forall {m :: * -> *}. Monad m => TcThetaType -> m Kind
mk_ctuple TcThetaType
inferred_diff

           ; case Kind -> Maybe (TcId, TcCoercionR)
tcGetCastedTyVar_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) -> TcId -> Kind -> TcRn ()
writeMetaTyVar TcId
wc_var (Kind
ctuple Kind -> TcCoercionR -> Kind
`mkCastTy` TcCoercionR -> TcCoercionR
mkTcSymCo TcCoercionR
wc_co)
               Maybe (TcId, TcCoercionR)
Nothing              -> String -> SDoc -> TcRn ()
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 -> TcRn ()
traceTc String
"completeTheta" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                [SDoc] -> SDoc
vcat [ TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
sig
                     , TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
annotated_theta, TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
inferred_theta
                     , TcThetaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcThetaType
inferred_diff ]
           ; (TcTyVarSet, TcThetaType) -> TcM (TcTyVarSet, TcThetaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyVarSet
free_tvs, TcThetaType
my_theta) }

    mk_ctuple :: TcThetaType -> m Kind
mk_ctuple TcThetaType
preds = Kind -> m Kind
forall (m :: * -> *) a. Monad m => a -> m a
return (TcThetaType -> Kind
mkBoxedTupleTy TcThetaType
preds)
       -- Hack alert!  See GHC.Tc.Gen.HsType:
       -- Note [Extra-constraint holes in partial type signatures]


mk_impedance_match_msg :: MonoBindInfo
                       -> TcType -> TcType
                       -> TidyEnv -> TcM (TidyEnv, SDoc)
-- This is a rare but rather awkward error messages
mk_impedance_match_msg :: MonoBindInfo -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_impedance_match_msg (MBI { mbi_poly_name :: MonoBindInfo -> Name
mbi_poly_name = Name
name, mbi_sig :: MonoBindInfo -> Maybe TcIdSigInst
mbi_sig = Maybe TcIdSigInst
mb_sig })
                       Kind
inf_ty Kind
sig_ty TidyEnv
tidy_env
 = do { (TidyEnv
tidy_env1, Kind
inf_ty) <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
tidy_env  Kind
inf_ty
      ; (TidyEnv
tidy_env2, Kind
sig_ty) <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
tidy_env1 Kind
sig_ty
      ; let msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"When checking that 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
name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
inf_ty
                       , String -> SDoc
text String
"is as general as its" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"signature"
                       , 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
name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
sig_ty ]
      ; (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
tidy_env2, SDoc
msg) }
  where
    what :: SDoc
what = case Maybe TcIdSigInst
mb_sig of
             Maybe TcIdSigInst
Nothing                     -> String -> SDoc
text String
"inferred"
             Just TcIdSigInst
sig | TcIdSigInst -> Bool
isPartialSig TcIdSigInst
sig -> String -> SDoc
text String
"(partial)"
                      | Bool
otherwise        -> SDoc
empty


mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_inf_msg :: Name -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_inf_msg Name
poly_name Kind
poly_ty TidyEnv
tidy_env
 = do { (TidyEnv
tidy_env1, Kind
poly_ty) <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
tidy_env Kind
poly_ty
      ; let msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ String -> SDoc
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
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
poly_ty ]
      ; (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
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 :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()
localSigWarn :: WarningFlag -> TcId -> Maybe TcIdSigInst -> TcRn ()
localSigWarn WarningFlag
flag TcId
id Maybe TcIdSigInst
mb_sig
  | Just TcIdSigInst
_ <- Maybe TcIdSigInst
mb_sig               = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool -> Bool
not (Kind -> Bool
isSigmaTy (TcId -> Kind
idType TcId
id))    = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise                      = WarningFlag -> SDoc -> TcId -> TcRn ()
warnMissingSignatures WarningFlag
flag SDoc
msg TcId
id
  where
    msg :: SDoc
msg = String -> SDoc
text String
"Polymorphic local binding with no type signature:"

warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()
warnMissingSignatures :: WarningFlag -> SDoc -> TcId -> TcRn ()
warnMissingSignatures WarningFlag
flag SDoc
msg TcId
id
  = do  { TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
        ; let (TidyEnv
env1, Kind
tidy_ty) = TidyEnv -> Kind -> (TidyEnv, Kind)
tidyOpenType TidyEnv
env0 (TcId -> Kind
idType TcId
id)
        ; WarnReason -> (TidyEnv, SDoc) -> TcRn ()
addWarnTcM (WarningFlag -> WarnReason
Reason WarningFlag
flag) (TidyEnv
env1, Kind -> SDoc
mk_msg Kind
tidy_ty) }
  where
    mk_msg :: Kind -> SDoc
mk_msg Kind
ty = [SDoc] -> SDoc
sep [ SDoc
msg, BKey -> SDoc -> SDoc
nest BKey
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. NamedThing a => a -> SDoc
pprPrefixName (TcId -> Name
idName TcId
id) SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
ty ]

checkOverloadedSig :: Bool -> TcIdSigInst -> 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 :: Bool -> TcIdSigInst -> TcRn ()
checkOverloadedSig Bool
monomorphism_restriction_applies TcIdSigInst
sig
  | Bool -> Bool
not (TcThetaType -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TcIdSigInst -> TcThetaType
sig_inst_theta TcIdSigInst
sig))
  , Bool
monomorphism_restriction_applies
  , let orig_sig :: TcIdSigInfo
orig_sig = TcIdSigInst -> TcIdSigInfo
sig_inst_sig TcIdSigInst
sig
  = SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (TcIdSigInfo -> SrcSpan
sig_loc TcIdSigInfo
orig_sig) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    SDoc -> TcRn ()
forall a. SDoc -> TcM a
failWith (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    SDoc -> BKey -> SDoc -> SDoc
hang (String -> SDoc
text String
"Overloaded signature conflicts with monomorphism restriction")
       BKey
2 (TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
orig_sig)
  | Bool
otherwise
  = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{- 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.

We apply the MR if /all/ of the partial signatures lack a context.
In particular (#11016):
   f2 :: (?loc :: Int) => _
   f2 = ?loc
It's stupid to apply the MR here.  This test includes an extra-constraints
wildcard; that is, we don't apply the MR if you write
   f3 :: _ => blah

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 [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 [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, g) -> f
   g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g

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.

Notice that the impedance matcher may do defaulting.  See #7173.

It also cleverly does an ambiguity check; for example, rejecting
   f :: F a -> F a
where F is a non-injective type function.
-}


{-
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 }

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])
tcMonoBinds :: RecFlag
-> TcSigFun
-> LetBndrSpec
-> [LHsBind (GhcPass 'Renamed)]
-> TcM (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo])
tcMonoBinds RecFlag
is_rec TcSigFun
sig_fn LetBndrSpec
no_gen
           [ L SrcSpan
b_loc (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = L SrcSpan
nm_loc IdP (GhcPass 'Renamed)
name
                              , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches })]
                             -- Single function binding,
  | RecFlag
NonRecursive <- RecFlag
is_rec   -- ...binder isn't mentioned in RHS
  , Maybe TcSigInfo
Nothing <- TcSigFun
sig_fn Name
IdP (GhcPass 'Renamed)
name   -- ...with no type signature
  =     -- Note [Single function non-recursive binding special-case]
        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        -- In this very special case 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
    SrcSpan
-> TcM (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo])
-> TcM (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
b_loc    (TcM (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo])
 -> TcM (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo]))
-> TcM (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo])
-> TcM (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo])
forall a b. (a -> b) -> a -> b
$
    do  { ((HsWrapper
co_fn, MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
matches'), Kind
rhs_ty)
            <- (ExpSigmaType
 -> TcM
      (HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
-> TcM
     ((HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))),
      Kind)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, Kind)
tcInfer ((ExpSigmaType
  -> TcM
       (HsWrapper,
        MatchGroup
          (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
 -> TcM
      ((HsWrapper,
        MatchGroup
          (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))),
       Kind))
-> (ExpSigmaType
    -> TcM
         (HsWrapper,
          MatchGroup
            (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
-> TcM
     ((HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))),
      Kind)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
               [TcBinder]
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [Name -> ExpSigmaType -> TopLevelFlag -> TcBinder
TcIdBndr_ExpType Name
IdP (GhcPass 'Renamed)
name ExpSigmaType
exp_ty TopLevelFlag
NotTopLevel] (TcM
   (HsWrapper,
    MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
 -> TcM
      (HsWrapper,
       MatchGroup
         (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
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
               Located Name
-> MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> ExpSigmaType
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
tcMatchesFun (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
nm_loc Name
IdP (GhcPass 'Renamed)
name) MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches ExpSigmaType
exp_ty

        ; TcId
mono_id <- LetBndrSpec
-> Name -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newLetBndr LetBndrSpec
no_gen Name
IdP (GhcPass 'Renamed)
name Kind
Many Kind
rhs_ty
        ; (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo])
-> TcM (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
  SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> LHsBinds (GhcPass 'Typechecked)
forall a. a -> Bag a
unitBag (GenLocated
   SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
 -> LHsBinds (GhcPass 'Typechecked))
-> GenLocated
     SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> LHsBinds (GhcPass 'Typechecked)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> GenLocated
     SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L SrcSpan
b_loc (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
 -> GenLocated
      SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> GenLocated
     SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$
                     FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> [Tickish TcId]
-> HsBindLR idL idR
FunBind { fun_id :: Located (IdP (GhcPass 'Typechecked))
fun_id = SrcSpan -> TcId -> GenLocated SrcSpan TcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
nm_loc TcId
mono_id,
                               fun_matches :: MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
fun_matches = MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
matches',
                               fun_ext :: XFunBind (GhcPass 'Typechecked) (GhcPass 'Typechecked)
fun_ext = XFunBind (GhcPass 'Typechecked) (GhcPass 'Typechecked)
HsWrapper
co_fn, fun_tick :: [Tickish TcId]
fun_tick = [] },
                  [MBI :: Name -> Maybe TcIdSigInst -> TcId -> MonoBindInfo
MBI { mbi_poly_name :: Name
mbi_poly_name = Name
IdP (GhcPass 'Renamed)
name
                       , mbi_sig :: Maybe TcIdSigInst
mbi_sig       = Maybe TcIdSigInst
forall a. Maybe a
Nothing
                       , mbi_mono_id :: TcId
mbi_mono_id   = TcId
mono_id }]) }

tcMonoBinds RecFlag
_ TcSigFun
sig_fn LetBndrSpec
no_gen [LHsBind (GhcPass 'Renamed)]
binds
  = do  { [Located TcMonoBind]
tc_binds <- (LHsBind (GhcPass 'Renamed)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Located TcMonoBind))
-> [LHsBind (GhcPass 'Renamed)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Located TcMonoBind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed) -> TcM TcMonoBind)
-> LHsBind (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (Located TcMonoBind)
forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM (TcSigFun
-> LetBndrSpec
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> TcM TcMonoBind
tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen)) [LHsBind (GhcPass 'Renamed)]
binds

        -- Bring the monomorphic Ids, into scope for the RHSs
        ; let mono_infos :: [MonoBindInfo]
mono_infos = [Located TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo [Located 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 -> TcRn ()
traceTc String
"tcMonoBinds" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
<+> TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
id SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
idType TcId
id)
                                       | (Name
n,TcId
id) <- [(Name, TcId)]
rhs_id_env]
        ; [GenLocated
   SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
binds' <- [(Name, TcId)]
-> TcM
     [GenLocated
        SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
-> TcM
     [GenLocated
        SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
forall a. [(Name, TcId)] -> TcM a -> TcM a
tcExtendRecIds [(Name, TcId)]
rhs_id_env (TcM
   [GenLocated
      SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
 -> TcM
      [GenLocated
         SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))])
-> TcM
     [GenLocated
        SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
-> TcM
     [GenLocated
        SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
forall a b. (a -> b) -> a -> b
$
                    (Located TcMonoBind
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated
         SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))))
-> [Located TcMonoBind]
-> TcM
     [GenLocated
        SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TcMonoBind
 -> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> Located TcMonoBind
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated
        SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM TcMonoBind
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
tcRhs) [Located TcMonoBind]
tc_binds

        ; (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo])
-> TcM (LHsBinds (GhcPass 'Typechecked), [MonoBindInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated
   SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
-> LHsBinds (GhcPass 'Typechecked)
forall a. [a] -> Bag a
listToBag [GenLocated
   SrcSpan (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))]
binds', [MonoBindInfo]
mono_infos) }


------------------------
-- 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 (MatchGroup GhcRn (LHsExpr GhcRn))
  | TcPatBind [MonoBindInfo] (LPat GhcTc) (GRHSs GhcRn (LHsExpr GhcRn))
              TcSigmaType

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
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> TcM TcMonoBind
tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = L SrcSpan
nm_loc IdP (GhcPass 'Renamed)
name
                             , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches })
  | Just (TcIdSig TcIdSigInfo
sig) <- TcSigFun
sig_fn Name
IdP (GhcPass 'Renamed)
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, TcIdSigInfo) -> TcM MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen (Name
IdP (GhcPass 'Renamed)
name, TcIdSigInfo
sig)
       ; TcMonoBind -> TcM TcMonoBind
forall (m :: * -> *) a. Monad m => a -> m a
return (MonoBindInfo
-> SrcSpan
-> MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> TcMonoBind
TcFunBind MonoBindInfo
mono_info SrcSpan
nm_loc MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches) }

  | Bool
otherwise  -- No type signature
  = do { Kind
mono_ty <- TcM Kind
newOpenFlexiTyVarTy
       ; TcId
mono_id <- LetBndrSpec
-> Name -> Kind -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newLetBndr LetBndrSpec
no_gen Name
IdP (GhcPass 'Renamed)
name Kind
Many Kind
mono_ty
          -- This ^ generates a binder with Many multiplicity because all
          -- let/where-binders are unrestricted. When we introduce linear let
          -- binders, we will need to retrieve the multiplicity information.
       ; let mono_info :: MonoBindInfo
mono_info = MBI :: Name -> Maybe TcIdSigInst -> TcId -> MonoBindInfo
MBI { mbi_poly_name :: Name
mbi_poly_name = Name
IdP (GhcPass 'Renamed)
name
                             , mbi_sig :: Maybe TcIdSigInst
mbi_sig       = Maybe TcIdSigInst
forall a. Maybe a
Nothing
                             , mbi_mono_id :: TcId
mbi_mono_id   = TcId
mono_id }
       ; TcMonoBind -> TcM TcMonoBind
forall (m :: * -> *) a. Monad m => a -> m a
return (MonoBindInfo
-> SrcSpan
-> MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> TcMonoBind
TcFunBind MonoBindInfo
mono_info SrcSpan
nm_loc MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches) }

tcLhs TcSigFun
sig_fn LetBndrSpec
no_gen (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat (GhcPass 'Renamed)
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
grhss })
  = -- See Note [Typechecking pattern bindings]
    do  { [MonoBindInfo]
sig_mbis <- ((Name, TcIdSigInfo) -> TcM MonoBindInfo)
-> [(Name, TcIdSigInfo)]
-> IOEnv (Env TcGblEnv TcLclEnv) [MonoBindInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen) [(Name, TcIdSigInfo)]
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 ]

            -- See Note [Existentials in pattern bindings]
        ; ((Located (Pat (GhcPass 'Typechecked))
pat', [MonoBindInfo]
nosig_mbis), Kind
pat_ty)
            <- SDoc
-> TcM
     ((Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]), Kind)
-> TcM
     ((Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]), Kind)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LPat (GhcPass 'Renamed)
-> GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed)) -> SDoc
forall (p :: Pass) body.
(OutputableBndrId p, Outputable body) =>
LPat (GhcPass p) -> GRHSs (GhcPass 'Renamed) body -> SDoc
patMonoBindsCtxt LPat (GhcPass 'Renamed)
pat GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
grhss) (TcM ((Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]), Kind)
 -> TcM
      ((Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]), Kind))
-> TcM
     ((Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]), Kind)
-> TcM
     ((Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]), Kind)
forall a b. (a -> b) -> a -> b
$
               (ExpSigmaType
 -> TcM (Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]))
-> TcM
     ((Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]), Kind)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, Kind)
tcInfer ((ExpSigmaType
  -> TcM (Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]))
 -> TcM
      ((Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]), Kind))
-> (ExpSigmaType
    -> TcM (Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]))
-> TcM
     ((Located (Pat (GhcPass 'Typechecked)), [MonoBindInfo]), Kind)
forall a b. (a -> b) -> a -> b
$ \ ExpSigmaType
exp_ty ->
               (Name -> Maybe TcId)
-> LetBndrSpec
-> LPat (GhcPass 'Renamed)
-> Scaled ExpSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) [MonoBindInfo]
-> TcM (LPat (GhcPass 'Typechecked), [MonoBindInfo])
forall a.
(Name -> Maybe TcId)
-> LetBndrSpec
-> LPat (GhcPass 'Renamed)
-> Scaled ExpSigmaType
-> TcM a
-> TcM (LPat (GhcPass 'Typechecked), a)
tcLetPat Name -> Maybe TcId
inst_sig_fun LetBndrSpec
no_gen LPat (GhcPass 'Renamed)
pat (ExpSigmaType -> Scaled ExpSigmaType
forall a. a -> Scaled a
unrestricted ExpSigmaType
exp_ty) (IOEnv (Env TcGblEnv TcLclEnv) [MonoBindInfo]
 -> TcM (LPat (GhcPass 'Typechecked), [MonoBindInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) [MonoBindInfo]
-> TcM (LPat (GhcPass 'Typechecked), [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 -> TcM MonoBindInfo)
-> [Name] -> IOEnv (Env TcGblEnv TcLclEnv) [MonoBindInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> TcM MonoBindInfo
lookup_info [Name]
nosig_names

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

        ; String -> SDoc -> TcRn ()
traceTc String
"tcLhs" ([SDoc] -> SDoc
vcat [ TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> 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
$$ LetBndrSpec -> SDoc
forall a. Outputable a => a -> SDoc
ppr LetBndrSpec
no_gen)

        ; TcMonoBind -> TcM TcMonoBind
forall (m :: * -> *) a. Monad m => a -> m a
return ([MonoBindInfo]
-> LPat (GhcPass 'Typechecked)
-> GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> Kind
-> TcMonoBind
TcPatBind [MonoBindInfo]
mbis Located (Pat (GhcPass 'Typechecked))
LPat (GhcPass 'Typechecked)
pat' GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
grhss Kind
pat_ty) }
  where
    bndr_names :: [IdP (GhcPass 'Renamed)]
bndr_names = LPat (GhcPass 'Renamed) -> [IdP (GhcPass 'Renamed)]
forall p. CollectPass p => LPat p -> [IdP p]
collectPatBinders LPat (GhcPass 'Renamed)
pat
    ([Name]
nosig_names, [(Name, TcIdSigInfo)]
sig_names) = (Name -> Either Name (Name, TcIdSigInfo))
-> [Name] -> ([Name], [(Name, TcIdSigInfo)])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith Name -> Either Name (Name, TcIdSigInfo)
find_sig [Name]
[IdP (GhcPass 'Renamed)]
bndr_names

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

      -- After typechecking the pattern, look up the binder
      -- names that lack a signature, which the pattern has brought
      -- into scope.
    lookup_info :: Name -> TcM MonoBindInfo
    lookup_info :: Name -> TcM MonoBindInfo
lookup_info Name
name
      = do { TcId
mono_id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId
tcLookupId Name
name
           ; MonoBindInfo -> TcM MonoBindInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (MBI :: Name -> Maybe TcIdSigInst -> TcId -> MonoBindInfo
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 }) }

tcLhs TcSigFun
_ LetBndrSpec
_ HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
other_bind = String -> SDoc -> TcM TcMonoBind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLhs" (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
other_bind)
        -- AbsBind, VarBind impossible

-------------------
tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
tcLhsSigId LetBndrSpec
no_gen (Name
name, TcIdSigInfo
sig)
  = do { TcIdSigInst
inst_sig <- TcIdSigInfo -> TcM TcIdSigInst
tcInstSig TcIdSigInfo
sig
       ; TcId
mono_id <- LetBndrSpec
-> Name -> TcIdSigInst -> IOEnv (Env TcGblEnv TcLclEnv) TcId
newSigLetBndr LetBndrSpec
no_gen Name
name TcIdSigInst
inst_sig
       ; MonoBindInfo -> TcM MonoBindInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (MBI :: Name -> Maybe TcIdSigInst -> TcId -> MonoBindInfo
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 }) }

------------
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 -> TcIdSigInfo
sig_inst_sig = TcIdSigInfo
id_sig })
  | CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
poly_id } <- TcIdSigInfo
id_sig
  = TcId
-> [LSig (GhcPass 'Renamed)] -> IOEnv (Env TcGblEnv TcLclEnv) TcId
addInlinePrags TcId
poly_id (TcPragEnv -> Name -> [LSig (GhcPass 'Renamed)]
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
Many 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 (GhcPass 'Typechecked) (GhcPass 'Typechecked))
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 MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches)
  = [MonoBindInfo]
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall a. [MonoBindInfo] -> TcM a -> TcM a
tcExtendIdBinderStackForRhs [MonoBindInfo
info]  (TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
 -> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$
    Maybe TcIdSigInst
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall a. Maybe TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvForRhs Maybe TcIdSigInst
mb_sig       (TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
 -> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$
    do  { String -> SDoc -> TcRn ()
traceTc String
"tcRhs: fun bind" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
mono_id SDoc -> SDoc -> SDoc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
idType TcId
mono_id))
        ; (HsWrapper
co_fn, MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
matches') <- Located Name
-> MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> ExpSigmaType
-> TcM
     (HsWrapper,
      MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
tcMatchesFun (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (TcId -> Name
idName TcId
mono_id))
                                 MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
matches (Kind -> ExpSigmaType
mkCheckExpType (Kind -> ExpSigmaType) -> Kind -> ExpSigmaType
forall a b. (a -> b) -> a -> b
$ TcId -> Kind
idType TcId
mono_id)
        ; HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return ( FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> [Tickish TcId]
-> HsBindLR idL idR
FunBind { fun_id :: Located (IdP (GhcPass 'Typechecked))
fun_id = SrcSpan -> TcId -> GenLocated SrcSpan TcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc TcId
mono_id
                           , fun_matches :: MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
fun_matches = MatchGroup (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
matches'
                           , fun_ext :: XFunBind (GhcPass 'Typechecked) (GhcPass 'Typechecked)
fun_ext = XFunBind (GhcPass 'Typechecked) (GhcPass 'Typechecked)
HsWrapper
co_fn
                           , fun_tick :: [Tickish TcId]
fun_tick = [] } ) }

tcRhs (TcPatBind [MonoBindInfo]
infos LPat (GhcPass 'Typechecked)
pat' GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
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 (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall a. [MonoBindInfo] -> TcM a -> TcM a
tcExtendIdBinderStackForRhs [MonoBindInfo]
infos        (TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
 -> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)))
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$
    do  { String -> SDoc -> TcRn ()
traceTc String
"tcRhs: pat bind" (Located (Pat (GhcPass 'Typechecked)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (Pat (GhcPass 'Typechecked))
LPat (GhcPass 'Typechecked)
pat' SDoc -> SDoc -> SDoc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
pat_ty)
        ; GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
grhss' <- SDoc
-> TcM
     (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
-> TcM
     (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LPat (GhcPass 'Typechecked)
-> GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed)) -> SDoc
forall (p :: Pass) body.
(OutputableBndrId p, Outputable body) =>
LPat (GhcPass p) -> GRHSs (GhcPass 'Renamed) body -> SDoc
patMonoBindsCtxt LPat (GhcPass 'Typechecked)
pat' GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
grhss) (TcM
   (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
 -> TcM
      (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
-> TcM
     (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
-> TcM
     (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$
                    Kind
-> TcM
     (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
-> TcM
     (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
forall a. Kind -> TcM a -> TcM a
tcScalingUsage Kind
Many (TcM
   (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
 -> TcM
      (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))))
-> TcM
     (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
-> TcM
     (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
forall a b. (a -> b) -> a -> b
$
                    -- Like in tcMatchesFun, this scaling happens because all
                    -- let bindings are unrestricted. A difference, here, is
                    -- that when this is not the case, any more, we will have to
                    -- make sure that the pattern is strict, otherwise this will
                    -- be desugar to incorrect code.
                    GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
-> Kind
-> TcM
     (GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked)))
tcGRHSsPat GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
grhss Kind
pat_ty
        ; HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked)
-> TcM (HsBindLR (GhcPass 'Typechecked) (GhcPass 'Typechecked))
forall (m :: * -> *) a. Monad m => a -> m a
return ( PatBind :: forall idL idR.
XPatBind idL idR
-> LPat idL
-> GRHSs idR (LHsExpr idR)
-> ([Tickish TcId], [[Tickish TcId]])
-> HsBindLR idL idR
PatBind { pat_lhs :: LPat (GhcPass 'Typechecked)
pat_lhs = LPat (GhcPass 'Typechecked)
pat', pat_rhs :: GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
pat_rhs = GRHSs (GhcPass 'Typechecked) (LHsExpr (GhcPass 'Typechecked))
grhss'
                           , pat_ext :: XPatBind (GhcPass 'Typechecked) (GhcPass 'Typechecked)
pat_ext = UniqSet Name -> Kind -> NPatBindTc
NPatBindTc UniqSet Name
emptyNameSet Kind
pat_ty
                           , pat_ticks :: ([Tickish TcId], [[Tickish TcId]])
pat_ticks = ([],[]) } )}

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, InvisTVBinder)]
sig_inst_skols = [(Name, InvisTVBinder)]
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 ((InvisTVBinder -> TcId)
-> [(Name, InvisTVBinder)] -> [(Name, TcId)]
forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd InvisTVBinder -> TcId
forall tv argf. VarBndr tv argf -> tv
binderVar [(Name, InvisTVBinder)]
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 :: [Located TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo [Located TcMonoBind]
tc_binds
  = (Located TcMonoBind -> [MonoBindInfo] -> [MonoBindInfo])
-> [MonoBindInfo] -> [Located TcMonoBind] -> [MonoBindInfo]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TcMonoBind -> [MonoBindInfo] -> [MonoBindInfo]
get_info (TcMonoBind -> [MonoBindInfo] -> [MonoBindInfo])
-> (Located TcMonoBind -> TcMonoBind)
-> Located TcMonoBind
-> [MonoBindInfo]
-> [MonoBindInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located TcMonoBind -> TcMonoBind
forall l e. GenLocated l e -> e
unLoc) [] [Located TcMonoBind]
tc_binds
  where
    get_info :: TcMonoBind -> [MonoBindInfo] -> [MonoBindInfo]
get_info (TcFunBind MonoBindInfo
info SrcSpan
_ MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
_)    [MonoBindInfo]
rest = MonoBindInfo
info MonoBindInfo -> [MonoBindInfo] -> [MonoBindInfo]
forall a. a -> [a] -> [a]
: [MonoBindInfo]
rest
    get_info (TcPatBind [MonoBindInfo]
infos LPat (GhcPass 'Typechecked)
_ GRHSs (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
_ 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 binds 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
       Bool             --   True <=> apply the MR; generalise only unconstrained type vars

  | CheckGen (LHsBind GhcRn) TcIdSigInfo
                        -- One FunBind with a signature
                        -- Explicit generalisation

-- 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
text String
"NoGen"
  ppr (InferGen Bool
b)   = String -> SDoc
text String
"InferGen" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
b
  ppr (CheckGen LHsBind (GhcPass 'Renamed)
_ TcIdSigInfo
s) = String -> SDoc
text String
"CheckGen" SDoc -> SDoc -> SDoc
<+> TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
s

decideGeneralisationPlan
   :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun
   -> GeneralisationPlan
decideGeneralisationPlan :: DynFlags
-> [LHsBind (GhcPass 'Renamed)]
-> IsGroupClosed
-> TcSigFun
-> GeneralisationPlan
decideGeneralisationPlan DynFlags
dflags [LHsBind (GhcPass 'Renamed)]
lbinds IsGroupClosed
closed TcSigFun
sig_fn
  | Bool
has_partial_sigs                         = Bool -> GeneralisationPlan
InferGen ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
partial_sig_mrs)
  | Just (LHsBind (GhcPass 'Renamed)
bind, TcIdSigInfo
sig) <- Maybe (LHsBind (GhcPass 'Renamed), TcIdSigInfo)
one_funbind_with_sig = LHsBind (GhcPass 'Renamed) -> TcIdSigInfo -> GeneralisationPlan
CheckGen LHsBind (GhcPass 'Renamed)
bind TcIdSigInfo
sig
  | IsGroupClosed -> Bool
do_not_generalise IsGroupClosed
closed                 = GeneralisationPlan
NoGen
  | Bool
otherwise                                = Bool -> GeneralisationPlan
InferGen Bool
mono_restriction
  where
    binds :: [HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)]
binds = (LHsBind (GhcPass 'Renamed)
 -> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> [LHsBind (GhcPass 'Renamed)]
-> [HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)]
forall a b. (a -> b) -> [a] -> [b]
map LHsBind (GhcPass 'Renamed)
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc [LHsBind (GhcPass 'Renamed)]
lbinds

    partial_sig_mrs :: [Bool]
    -- One for each partial signature (so empty => no partial sigs)
    -- The Bool is True if the signature has no constraint context
    --      so we should apply the MR
    -- See Note [Partial type signatures and generalisation]
    partial_sig_mrs :: [Bool]
partial_sig_mrs
      = [ [LHsType (GhcPass 'Renamed)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsType (GhcPass 'Renamed)]
theta
        | TcIdSig (PartialSig { psig_hs_ty :: TcIdSigInfo -> LHsSigWcType (GhcPass 'Renamed)
psig_hs_ty = LHsSigWcType (GhcPass 'Renamed)
hs_ty })
            <- TcSigFun -> [Name] -> [TcSigInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TcSigFun
sig_fn ([LHsBind (GhcPass 'Renamed)] -> [IdP (GhcPass 'Renamed)]
forall p idR. CollectPass p => [LHsBindLR p idR] -> [IdP p]
collectHsBindListBinders [LHsBind (GhcPass 'Renamed)]
lbinds)
        , let ([LHsTyVarBndr Specificity (GhcPass 'Renamed)]
_, L SrcSpan
_ [LHsType (GhcPass 'Renamed)]
theta, LHsType (GhcPass 'Renamed)
_) = LHsType (GhcPass 'Renamed)
-> ([LHsTyVarBndr Specificity (GhcPass 'Renamed)],
    GenLocated SrcSpan [LHsType (GhcPass 'Renamed)],
    LHsType (GhcPass 'Renamed))
forall pass.
LHsType pass
-> ([LHsTyVarBndr Specificity pass], LHsContext pass, LHsType pass)
splitLHsSigmaTyInvis (LHsSigWcType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed)
forall pass. LHsSigWcType pass -> LHsType pass
hsSigWcType LHsSigWcType (GhcPass 'Renamed)
hs_ty) ]

    has_partial_sigs :: Bool
has_partial_sigs   = Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Bool]
partial_sig_mrs)

    mono_restriction :: Bool
mono_restriction  = Extension -> DynFlags -> Bool
xopt Extension
LangExt.MonomorphismRestriction DynFlags
dflags
                     Bool -> Bool -> Bool
&& (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed) -> Bool)
-> [HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed) -> Bool
restricted [HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)]
binds

    do_not_generalise :: IsGroupClosed -> Bool
do_not_generalise (IsGroupClosed NameEnv (UniqSet Name)
_ Bool
True) = Bool
False
        -- The 'True' means that all of the group's
        -- free vars have ClosedTypeId=True; so we can ignore
        -- -XMonoLocalBinds, and generalise anyway
    do_not_generalise IsGroupClosed
_ = Extension -> DynFlags -> Bool
xopt Extension
LangExt.MonoLocalBinds DynFlags
dflags

    -- With OutsideIn, all nested bindings are monomorphic
    -- except a single function binding with a signature
    one_funbind_with_sig :: Maybe (LHsBind (GhcPass 'Renamed), TcIdSigInfo)
one_funbind_with_sig
      | [lbind :: LHsBind (GhcPass 'Renamed)
lbind@(L SrcSpan
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = Located (IdP (GhcPass 'Renamed))
v }))] <- [LHsBind (GhcPass 'Renamed)]
lbinds
      , Just (TcIdSig TcIdSigInfo
sig) <- TcSigFun
sig_fn (Located Name -> Name
forall l e. GenLocated l e -> e
unLoc Located Name
Located (IdP (GhcPass 'Renamed))
v)
      = (LHsBind (GhcPass 'Renamed), TcIdSigInfo)
-> Maybe (LHsBind (GhcPass 'Renamed), TcIdSigInfo)
forall a. a -> Maybe a
Just (LHsBind (GhcPass 'Renamed)
lbind, TcIdSigInfo
sig)
      | Bool
otherwise
      = Maybe (LHsBind (GhcPass 'Renamed), TcIdSigInfo)
forall a. Maybe a
Nothing

    -- The Haskell 98 monomorphism restriction
    restricted :: HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed) -> Bool
restricted (PatBind {})                              = Bool
True
    restricted (VarBind { var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP (GhcPass 'Renamed)
v })                  = Name -> Bool
no_sig Name
IdP (GhcPass 'Renamed)
v
    restricted (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = Located (IdP (GhcPass 'Renamed))
v, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
m }) = MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed)) -> Bool
forall {id :: Pass} {body}. MatchGroup (GhcPass id) body -> Bool
restricted_match MatchGroup (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
m
                                                           Bool -> Bool -> Bool
&& Name -> Bool
no_sig (Located Name -> Name
forall l e. GenLocated l e -> e
unLoc Located Name
Located (IdP (GhcPass 'Renamed))
v)
    restricted HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
b = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"isRestrictedGroup/unrestricted" (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
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

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

isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed
isClosedBndrGroup :: TcTypeEnv -> LHsBinds (GhcPass 'Renamed) -> IsGroupClosed
isClosedBndrGroup TcTypeEnv
type_env LHsBinds (GhcPass 'Renamed)
binds
  = NameEnv (UniqSet Name) -> Bool -> IsGroupClosed
IsGroupClosed NameEnv (UniqSet Name)
fv_env Bool
type_closed
  where
    type_closed :: Bool
type_closed = (UniqSet Name -> Bool) -> NameEnv (UniqSet Name) -> Bool
forall elt key. (elt -> Bool) -> UniqFM key elt -> Bool
allUFM ((Name -> Bool) -> UniqSet Name -> Bool
nameSetAll Name -> Bool
is_closed_type_id) NameEnv (UniqSet Name)
fv_env

    fv_env :: NameEnv NameSet
    fv_env :: NameEnv (UniqSet Name)
fv_env = [(Name, UniqSet Name)] -> NameEnv (UniqSet Name)
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, UniqSet Name)] -> NameEnv (UniqSet Name))
-> [(Name, UniqSet Name)] -> NameEnv (UniqSet Name)
forall a b. (a -> b) -> a -> b
$ (LHsBind (GhcPass 'Renamed) -> [(Name, UniqSet Name)])
-> LHsBinds (GhcPass 'Renamed) -> [(Name, UniqSet Name)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> [(Name, UniqSet Name)]
bindFvs (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
 -> [(Name, UniqSet Name)])
-> (LHsBind (GhcPass 'Renamed)
    -> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
-> LHsBind (GhcPass 'Renamed)
-> [(Name, UniqSet Name)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsBind (GhcPass 'Renamed)
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc) LHsBinds (GhcPass 'Renamed)
binds

    bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
    bindFvs :: HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
-> [(Name, UniqSet Name)]
bindFvs (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = L SrcSpan
_ IdP (GhcPass 'Renamed)
f
                     , fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fvs })
       = let open_fvs :: UniqSet Name
open_fvs = UniqSet Name -> UniqSet Name
get_open_fvs UniqSet Name
XFunBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fvs
         in [(Name
IdP (GhcPass 'Renamed)
f, UniqSet Name
open_fvs)]
    bindFvs (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat (GhcPass 'Renamed)
pat, pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = XPatBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fvs })
       = let open_fvs :: UniqSet Name
open_fvs = UniqSet Name -> UniqSet Name
get_open_fvs UniqSet Name
XPatBind (GhcPass 'Renamed) (GhcPass 'Renamed)
fvs
         in [(Name
b, UniqSet Name
open_fvs) | Name
b <- LPat (GhcPass 'Renamed) -> [IdP (GhcPass 'Renamed)]
forall p. CollectPass p => LPat p -> [IdP p]
collectPatBinders LPat (GhcPass 'Renamed)
pat]
    bindFvs HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
_
       = []

    get_open_fvs :: UniqSet Name -> UniqSet Name
get_open_fvs UniqSet Name
fvs = (Name -> Bool) -> UniqSet Name -> UniqSet Name
filterNameSet (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
is_closed) UniqSet Name
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 UniqSet Name
_ 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


{- *********************************************************************
*                                                                      *
               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, Outputable body)
                 => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
patMonoBindsCtxt :: forall (p :: Pass) body.
(OutputableBndrId p, Outputable body) =>
LPat (GhcPass p) -> GRHSs (GhcPass 'Renamed) body -> SDoc
patMonoBindsCtxt LPat (GhcPass p)
pat GRHSs (GhcPass 'Renamed) body
grhss
  = SDoc -> BKey -> SDoc -> SDoc
hang (String -> SDoc
text String
"In a pattern binding:") BKey
2 (LPat (GhcPass p) -> GRHSs (GhcPass 'Renamed) body -> SDoc
forall (bndr :: Pass) (p :: Pass) body.
(OutputableBndrId bndr, OutputableBndrId p, Outputable body) =>
LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
pprPatBind LPat (GhcPass p)
pat GRHSs (GhcPass 'Renamed) body
grhss)