{-
(c) The University of Glasgow 2006-2012
(c) The GRASP Project, Glasgow University, 1992-2002

-}


{-# LANGUAGE TypeFamilies #-}

module GHC.Tc.Gen.Sig(
       TcSigInfo(..),
       TcIdSigInfo(..), TcIdSigInst,
       TcPatSynInfo(..),
       TcSigFun,

       isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,
       completeSigPolyId_maybe, isCompleteHsSig,
       lhsSigWcTypeContextSpan, lhsSigTypeContextSpan,

       tcTySigs, tcUserTypeSig, completeSigFromId,
       tcInstSig,

       TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,
       mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags,
       addInlinePrags, addInlinePragArity
   ) where

import GHC.Prelude
import GHC.Data.FastString

import GHC.Driver.Session
import GHC.Driver.Backend

import GHC.Hs


import GHC.Tc.Errors.Types ( FixedRuntimeRepProvenance(..), TcRnMessage(..) )
import GHC.Tc.Gen.HsType
import GHC.Tc.Types
import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep )
import GHC.Tc.Utils.Zonk
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Tc.Validity ( checkValidType )
import GHC.Tc.Utils.Unify( tcTopSkolemise, unifyType )
import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs )
import GHC.Tc.Utils.Env( tcLookupId )
import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )

import GHC.Core( hasSomeUnfolding )
import GHC.Core.Type ( mkTyVarBinders )
import GHC.Core.Multiplicity
import GHC.Core.TyCo.Rep( mkNakedFunTy )

import GHC.Types.Error
import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars, invisArgTypeLike )
import GHC.Types.Id  ( Id, idName, idType, setInlinePragma
                     , mkLocalId, realIdUnfolding )
import GHC.Types.Basic
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.SrcLoc

import GHC.Builtin.Names( mkUnboundName )
import GHC.Unit.Module( getModule )

import GHC.Utils.Misc as Utils ( singleton )
import GHC.Utils.Outputable
import GHC.Utils.Panic

import GHC.Data.Maybe( orElse, whenIsJust )

import Data.Maybe( mapMaybe )
import qualified Data.List.NonEmpty as NE
import Control.Monad( unless )


{- -------------------------------------------------------------
          Note [Overview of type signatures]
----------------------------------------------------------------
Type signatures, including partial signatures, are jolly tricky,
especially on value bindings.  Here's an overview.

    f :: forall a. [a] -> [a]
    g :: forall b. _ -> b

    f = ...g...
    g = ...f...

* HsSyn: a signature in a binding starts off as a TypeSig, in
  type HsBinds.Sig

* When starting a mutually recursive group, like f/g above, we
  call tcTySig on each signature in the group.

* tcTySig: Sig -> TcIdSigInfo
  - For a /complete/ signature, like 'f' above, tcTySig kind-checks
    the HsType, producing a Type, and wraps it in a CompleteSig, and
    extend the type environment with this polymorphic 'f'.

  - For a /partial/signature, like 'g' above, tcTySig does nothing
    Instead it just wraps the pieces in a PartialSig, to be handled
    later.

* tcInstSig: TcIdSigInfo -> TcIdSigInst
  In tcMonoBinds, when looking at an individual binding, we use
  tcInstSig to instantiate the signature forall's in the signature,
  and attribute that instantiated (monomorphic) type to the
  binder.  You can see this in GHC.Tc.Gen.Bind.tcLhsId.

  The instantiation does the obvious thing for complete signatures,
  but for /partial/ signatures it starts from the HsSyn, so it
  has to kind-check it etc: tcHsPartialSigType.  It's convenient
  to do this at the same time as instantiation, because we can
  make the wildcards into unification variables right away, rather
  than somehow quantifying over them.  And the "TcLevel" of those
  unification variables is correct because we are in tcMonoBinds.


Note [Binding scoped type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The type variables *brought into lexical scope* by a type signature
may be a subset of the *quantified type variables* of the signatures,
for two reasons:

* With kind polymorphism a signature like
    f :: forall f a. f a -> f a
  may actually give rise to
    f :: forall k. forall (f::k -> *) (a:k). f a -> f a
  So the sig_tvs will be [k,f,a], but only f,a are scoped.
  NB: the scoped ones are not necessarily the *initial* ones!

* Even aside from kind polymorphism, there may be more instantiated
  type variables than lexically-scoped ones.  For example:
        type T a = forall b. b -> (a,b)
        f :: forall c. T c
  Here, the signature for f will have one scoped type variable, c,
  but two instantiated type variables, c' and b'.

However, all of this only applies to the renamer.  The typechecker
just puts all of them into the type environment; any lexical-scope
errors were dealt with by the renamer.

-}


{- *********************************************************************
*                                                                      *
             Utility functions for TcSigInfo
*                                                                      *
********************************************************************* -}

tcIdSigName :: TcIdSigInfo -> Name
tcIdSigName :: TcIdSigInfo -> Name
tcIdSigName (CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
id }) = TcId -> Name
idName TcId
id
tcIdSigName (PartialSig { psig_name :: TcIdSigInfo -> Name
psig_name = Name
n })  = Name
n

tcSigInfoName :: TcSigInfo -> Name
tcSigInfoName :: TcSigInfo -> Name
tcSigInfoName (TcIdSig     TcIdSigInfo
idsi) = TcIdSigInfo -> Name
tcIdSigName TcIdSigInfo
idsi
tcSigInfoName (TcPatSynSig TcPatSynInfo
tpsi) = TcPatSynInfo -> Name
patsig_name TcPatSynInfo
tpsi

completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
completeSigPolyId_maybe TcSigInfo
sig
  | TcIdSig TcIdSigInfo
sig_info <- TcSigInfo
sig
  , CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
id } <- TcIdSigInfo
sig_info = TcId -> Maybe TcId
forall a. a -> Maybe a
Just TcId
id
  | Bool
otherwise                                 = Maybe TcId
forall a. Maybe a
Nothing


{- *********************************************************************
*                                                                      *
               Typechecking user signatures
*                                                                      *
********************************************************************* -}

tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun)
tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun)
tcTySigs [LSig GhcRn]
hs_sigs
  = TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall r. TcM r -> TcM r
checkNoErrs (TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun))
-> TcM ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall a b. (a -> b) -> a -> b
$
    do { -- Fail if any of the signatures is duff
         -- Hence mapAndReportM
         -- See Note [Fail eagerly on bad signatures]
         [[TcSigInfo]]
ty_sigs_s <- (GenLocated SrcSpanAnnA (Sig GhcRn) -> TcRn [TcSigInfo])
-> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> TcRn [[TcSigInfo]]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM LSig GhcRn -> TcRn [TcSigInfo]
GenLocated SrcSpanAnnA (Sig GhcRn) -> TcRn [TcSigInfo]
tcTySig [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
hs_sigs

       ; let ty_sigs :: [TcSigInfo]
ty_sigs = [[TcSigInfo]] -> [TcSigInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TcSigInfo]]
ty_sigs_s
             poly_ids :: [TcId]
poly_ids = (TcSigInfo -> Maybe TcId) -> [TcSigInfo] -> [TcId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TcSigInfo -> Maybe TcId
completeSigPolyId_maybe [TcSigInfo]
ty_sigs
                        -- The returned [TcId] are the ones for which we have
                        -- a complete type signature.
                        -- See Note [Complete and partial type signatures]
             env :: NameEnv TcSigInfo
env = [(Name, TcSigInfo)] -> NameEnv TcSigInfo
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(TcSigInfo -> Name
tcSigInfoName TcSigInfo
sig, TcSigInfo
sig) | TcSigInfo
sig <- [TcSigInfo]
ty_sigs]

       ; ([TcId], TcSigFun) -> TcM ([TcId], TcSigFun)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TcId]
poly_ids, NameEnv TcSigInfo -> TcSigFun
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TcSigInfo
env) }

tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
tcTySig :: LSig GhcRn -> TcRn [TcSigInfo]
tcTySig (L SrcSpanAnnA
_ (XSig (IdSig TcId
id)))
  = do { let ctxt :: UserTypeCtxt
ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt (TcId -> Name
idName TcId
id) ReportRedundantConstraints
NoRRC
                    -- NoRRC: do not report redundant constraints
                    -- The user has no control over the signature!
             sig :: TcIdSigInfo
sig = UserTypeCtxt -> TcId -> TcIdSigInfo
completeSigFromId UserTypeCtxt
ctxt TcId
id
       ; [TcSigInfo] -> TcRn [TcSigInfo]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [TcIdSigInfo -> TcSigInfo
TcIdSig TcIdSigInfo
sig] }

tcTySig (L SrcSpanAnnA
loc (TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
names LHsSigWcType GhcRn
sig_ty))
  = SrcSpanAnnA -> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn [TcSigInfo] -> TcRn [TcSigInfo])
-> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall a b. (a -> b) -> a -> b
$
    do { [TcIdSigInfo]
sigs <- [IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcIdSigInfo]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ SrcSpan
-> LHsSigWcType GhcRn
-> Maybe Name
-> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
tcUserTypeSig (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) LHsSigWcType GhcRn
sig_ty (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name)
                          | L SrcSpanAnnN
_ Name
name <- [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
names ]
       ; [TcSigInfo] -> TcRn [TcSigInfo]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TcIdSigInfo -> TcSigInfo) -> [TcIdSigInfo] -> [TcSigInfo]
forall a b. (a -> b) -> [a] -> [b]
map TcIdSigInfo -> TcSigInfo
TcIdSig [TcIdSigInfo]
sigs) }

tcTySig (L SrcSpanAnnA
loc (PatSynSig XPatSynSig GhcRn
_ [LIdP GhcRn]
names LHsSigType GhcRn
sig_ty))
  = SrcSpanAnnA -> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn [TcSigInfo] -> TcRn [TcSigInfo])
-> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall a b. (a -> b) -> a -> b
$
    do { [TcPatSynInfo]
tpsigs <- [IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo]
-> IOEnv (Env TcGblEnv TcLclEnv) [TcPatSynInfo]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name
-> LHsSigType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo
tcPatSynSig Name
name LHsSigType GhcRn
sig_ty
                            | L SrcSpanAnnN
_ Name
name <- [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
names ]
       ; [TcSigInfo] -> TcRn [TcSigInfo]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TcPatSynInfo -> TcSigInfo) -> [TcPatSynInfo] -> [TcSigInfo]
forall a b. (a -> b) -> [a] -> [b]
map TcPatSynInfo -> TcSigInfo
TcPatSynSig [TcPatSynInfo]
tpsigs) }

tcTySig LSig GhcRn
_ = [TcSigInfo] -> TcRn [TcSigInfo]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []


tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name
              -> TcM TcIdSigInfo
-- A function or expression type signature
-- Returns a fully quantified type signature; even the wildcards
-- are quantified with ordinary skolems that should be instantiated
--
-- The SrcSpan is what to declare as the binding site of the
-- any skolems in the signature. For function signatures we
-- use the whole `f :: ty' signature; for expression signatures
-- just the type part.
--
-- Just n  => Function type signature       name :: type
-- Nothing => Expression type signature   <expr> :: type
tcUserTypeSig :: SrcSpan
-> LHsSigWcType GhcRn
-> Maybe Name
-> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType GhcRn
hs_sig_ty Maybe Name
mb_name
  | LHsSigWcType GhcRn -> Bool
isCompleteHsSig LHsSigWcType GhcRn
hs_sig_ty
  = do { Kind
sigma_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Kind
tcHsSigWcType UserTypeCtxt
ctxt_no_rrc LHsSigWcType GhcRn
hs_sig_ty
       ; String -> SDoc -> TcRn ()
traceTc String
"tcuser" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
sigma_ty)
       ; TcIdSigInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcIdSigInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo)
-> TcIdSigInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
forall a b. (a -> b) -> a -> b
$
         CompleteSig { sig_bndr :: TcId
sig_bndr  = (() :: Constraint) => Name -> Kind -> Kind -> TcId
Name -> Kind -> Kind -> TcId
mkLocalId Name
name Kind
ManyTy Kind
sigma_ty
                                   -- We use `Many' as the multiplicity here,
                                   -- as if this identifier corresponds to
                                   -- anything, it is a top-level
                                   -- definition. Which are all unrestricted in
                                   -- the current implementation.
                     , sig_ctxt :: UserTypeCtxt
sig_ctxt  = UserTypeCtxt
ctxt_rrc  -- Report redundant constraints
                     , sig_loc :: SrcSpan
sig_loc   = SrcSpan
loc } }
                       -- Location of the <type> in   f :: <type>

  -- Partial sig with wildcards
  | Bool
otherwise
  = TcIdSigInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (PartialSig { psig_name :: Name
psig_name = Name
name, psig_hs_ty :: LHsSigWcType GhcRn
psig_hs_ty = LHsSigWcType GhcRn
hs_sig_ty
                       , sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt_no_rrc, sig_loc :: SrcSpan
sig_loc = SrcSpan
loc })
  where
    name :: Name
name   = case Maybe Name
mb_name of
               Just Name
n  -> Name
n
               Maybe Name
Nothing -> OccName -> Name
mkUnboundName (FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"<expression>"))

    ctxt_rrc :: UserTypeCtxt
ctxt_rrc    = ReportRedundantConstraints -> UserTypeCtxt
ctxt_fn (LHsSigWcType GhcRn -> ReportRedundantConstraints
lhsSigWcTypeContextSpan LHsSigWcType GhcRn
hs_sig_ty)
    ctxt_no_rrc :: UserTypeCtxt
ctxt_no_rrc = ReportRedundantConstraints -> UserTypeCtxt
ctxt_fn ReportRedundantConstraints
NoRRC

    ctxt_fn :: ReportRedundantConstraints -> UserTypeCtxt
    ctxt_fn :: ReportRedundantConstraints -> UserTypeCtxt
ctxt_fn ReportRedundantConstraints
rcc = case Maybe Name
mb_name of
               Just Name
n  -> Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
n ReportRedundantConstraints
rcc
               Maybe Name
Nothing -> ReportRedundantConstraints -> UserTypeCtxt
ExprSigCtxt ReportRedundantConstraints
rcc

lhsSigWcTypeContextSpan :: LHsSigWcType GhcRn -> ReportRedundantConstraints
-- | Find the location of the top-level context of a HsType.  For example:
--
-- @
--   forall a b. (Eq a, Ord b) => blah
--               ^^^^^^^^^^^^^
-- @
-- If there is none, return Nothing
lhsSigWcTypeContextSpan :: LHsSigWcType GhcRn -> ReportRedundantConstraints
lhsSigWcTypeContextSpan (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = LHsSigType GhcRn
sigType }) = LHsSigType GhcRn -> ReportRedundantConstraints
lhsSigTypeContextSpan LHsSigType GhcRn
sigType

lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints
lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints
lhsSigTypeContextSpan (L SrcSpanAnnA
_ HsSig { sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = XRec GhcRn (HsType GhcRn)
sig_ty }) = GenLocated SrcSpanAnnA (HsType GhcRn) -> ReportRedundantConstraints
forall {pass} {l} {a}.
(XRec pass (HsType pass) ~ GenLocated l (HsType pass),
 XRec pass [GenLocated l (HsType pass)]
 ~ GenLocated (SrcSpanAnn' a) [GenLocated l (HsType pass)]) =>
GenLocated l (HsType pass) -> ReportRedundantConstraints
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
sig_ty
  where
    go :: GenLocated l (HsType pass) -> ReportRedundantConstraints
go (L l
_ (HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = L SrcSpanAnn' a
span [XRec pass (HsType pass)]
_ })) = SrcSpan -> ReportRedundantConstraints
WantRRC (SrcSpan -> ReportRedundantConstraints)
-> SrcSpan -> ReportRedundantConstraints
forall a b. (a -> b) -> a -> b
$ SrcSpanAnn' a -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
span -- Found it!
    go (L l
_ (HsForAllTy { hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = XRec pass (HsType pass)
hs_ty })) = GenLocated l (HsType pass) -> ReportRedundantConstraints
go XRec pass (HsType pass)
GenLocated l (HsType pass)
hs_ty  -- Look under foralls
    go (L l
_ (HsParTy XParTy pass
_ XRec pass (HsType pass)
hs_ty)) = GenLocated l (HsType pass) -> ReportRedundantConstraints
go XRec pass (HsType pass)
GenLocated l (HsType pass)
hs_ty  -- Look under parens
    go GenLocated l (HsType pass)
_ = ReportRedundantConstraints
NoRRC  -- Did not find it

completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo
-- Used for instance methods and record selectors
completeSigFromId :: UserTypeCtxt -> TcId -> TcIdSigInfo
completeSigFromId UserTypeCtxt
ctxt TcId
id
  = CompleteSig { sig_bndr :: TcId
sig_bndr = TcId
id
                , sig_ctxt :: UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
                , sig_loc :: SrcSpan
sig_loc  = TcId -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TcId
id }

isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
-- ^ If there are no wildcards, return a LHsSigWcType
isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
isCompleteHsSig (HsWC { hswc_ext :: forall pass thing. HsWildCardBndrs pass thing -> XHsWC pass thing
hswc_ext = XHsWC GhcRn (LHsSigType GhcRn)
wcs, hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = LHsSigType GhcRn
hs_sig_ty })
   = [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
XHsWC GhcRn (LHsSigType GhcRn)
wcs Bool -> Bool -> Bool
&& LHsSigType GhcRn -> Bool
no_anon_wc_sig_ty LHsSigType GhcRn
hs_sig_ty

no_anon_wc_sig_ty :: LHsSigType GhcRn -> Bool
no_anon_wc_sig_ty :: LHsSigType GhcRn -> Bool
no_anon_wc_sig_ty (L SrcSpanAnnA
_ (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = XRec GhcRn (HsType GhcRn)
body}))
  =  (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTyVarBndr Specificity GhcRn -> Bool
GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn) -> Bool
forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb (HsOuterSigTyVarBndrs GhcRn
-> [LHsTyVarBndr Specificity (NoGhcTc GhcRn)]
forall flag (p :: Pass).
HsOuterTyVarBndrs flag (GhcPass p)
-> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
hsOuterExplicitBndrs HsOuterSigTyVarBndrs GhcRn
outer_bndrs)
  Bool -> Bool -> Bool
&& XRec GhcRn (HsType GhcRn) -> Bool
no_anon_wc_ty XRec GhcRn (HsType GhcRn)
body

no_anon_wc_ty :: LHsType GhcRn -> Bool
no_anon_wc_ty :: XRec GhcRn (HsType GhcRn) -> Bool
no_anon_wc_ty XRec GhcRn (HsType GhcRn)
lty = GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
lty
  where
    go :: GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go (L SrcSpanAnnA
_ HsType GhcRn
ty) = case HsType GhcRn
ty of
      HsWildCardTy XWildCardTy GhcRn
_                 -> Bool
False
      HsAppTy XAppTy GhcRn
_ XRec GhcRn (HsType GhcRn)
ty1 XRec GhcRn (HsType GhcRn)
ty2              -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2
      HsAppKindTy XAppKindTy GhcRn
_ XRec GhcRn (HsType GhcRn)
ty XRec GhcRn (HsType GhcRn)
ki            -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ki
      HsFunTy XFunTy GhcRn
_ HsArrow GhcRn
w XRec GhcRn (HsType GhcRn)
ty1 XRec GhcRn (HsType GhcRn)
ty2            -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go (HsArrow GhcRn -> XRec GhcRn (HsType GhcRn)
arrowToHsType HsArrow GhcRn
w)
      HsListTy XListTy GhcRn
_ XRec GhcRn (HsType GhcRn)
ty                  -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
      HsTupleTy XTupleTy GhcRn
_ HsTupleSort
_ [XRec GhcRn (HsType GhcRn)]
tys              -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [XRec GhcRn (HsType GhcRn)]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
      HsSumTy XSumTy GhcRn
_ [XRec GhcRn (HsType GhcRn)]
tys                  -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [XRec GhcRn (HsType GhcRn)]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
      HsOpTy XOpTy GhcRn
_ PromotionFlag
_ XRec GhcRn (HsType GhcRn)
ty1 LIdP GhcRn
_ XRec GhcRn (HsType GhcRn)
ty2           -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty1 Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty2
      HsParTy XParTy GhcRn
_ XRec GhcRn (HsType GhcRn)
ty                   -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
      HsIParamTy XIParamTy GhcRn
_ XRec GhcRn HsIPName
_ XRec GhcRn (HsType GhcRn)
ty              -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
      HsKindSig XKindSig GhcRn
_ XRec GhcRn (HsType GhcRn)
ty XRec GhcRn (HsType GhcRn)
kind            -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
kind
      HsDocTy XDocTy GhcRn
_ XRec GhcRn (HsType GhcRn)
ty LHsDoc GhcRn
_                 -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
      HsBangTy XBangTy GhcRn
_ HsSrcBang
_ XRec GhcRn (HsType GhcRn)
ty                -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
      HsRecTy XRecTy GhcRn
_ [LConDeclField GhcRn]
flds                 -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos ([GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
 -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (ConDeclField GhcRn -> XRec GhcRn (HsType GhcRn)
ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
    -> ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> ConDeclField GhcRn
forall l e. GenLocated l e -> e
unLoc) [LConDeclField GhcRn]
[GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds
      HsExplicitListTy XExplicitListTy GhcRn
_ PromotionFlag
_ [XRec GhcRn (HsType GhcRn)]
tys       -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [XRec GhcRn (HsType GhcRn)]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
      HsExplicitTupleTy XExplicitTupleTy GhcRn
_ [XRec GhcRn (HsType GhcRn)]
tys        -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos [XRec GhcRn (HsType GhcRn)]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
      HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcRn
tele
                 , hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = XRec GhcRn (HsType GhcRn)
ty } -> HsForAllTelescope GhcRn -> Bool
no_anon_wc_tele HsForAllTelescope GhcRn
tele
                                        Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
      HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = LHsContext GhcRn
ctxt
               , hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = XRec GhcRn (HsType GhcRn)
ty }  -> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos (GenLocated
  (SrcSpanAnn' (EpAnn AnnContext))
  [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall l e. GenLocated l e -> e
unLoc LHsContext GhcRn
GenLocated
  (SrcSpanAnn' (EpAnn AnnContext))
  [GenLocated SrcSpanAnnA (HsType GhcRn)]
ctxt) Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go XRec GhcRn (HsType GhcRn)
GenLocated SrcSpanAnnA (HsType GhcRn)
ty
      HsSpliceTy (HsUntypedSpliceTop ThModFinalizers
_ GenLocated SrcSpanAnnA (HsType GhcRn)
ty) HsUntypedSplice GhcRn
_ -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go GenLocated SrcSpanAnnA (HsType GhcRn)
ty
      HsSpliceTy (HsUntypedSpliceNested Name
_) HsUntypedSplice GhcRn
_ -> Bool
True
      HsTyLit{} -> Bool
True
      HsTyVar{} -> Bool
True
      HsStarTy{} -> Bool
True
      XHsType{} -> Bool
True       -- HsCoreTy, which does not have any wildcard

    gos :: [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
gos = (GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GenLocated SrcSpanAnnA (HsType GhcRn) -> Bool
go

no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool
no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool
no_anon_wc_tele HsForAllTelescope GhcRn
tele = case HsForAllTelescope GhcRn
tele of
  HsForAllVis   { hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass]
hsf_vis_bndrs   = [LHsTyVarBndr () GhcRn]
ltvs } -> (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTyVarBndr () GhcRn -> Bool
GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> Bool
forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb [LHsTyVarBndr () GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
ltvs
  HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcRn]
ltvs } -> (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTyVarBndr Specificity GhcRn -> Bool
GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn) -> Bool
forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb [LHsTyVarBndr Specificity GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
ltvs

no_anon_wc_tvb :: LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb :: forall flag. LHsTyVarBndr flag GhcRn -> Bool
no_anon_wc_tvb (L SrcSpanAnnA
_ HsTyVarBndr flag GhcRn
tvb) = case HsTyVarBndr flag GhcRn
tvb of
  UserTyVar XUserTyVar GhcRn
_ flag
_ LIdP GhcRn
_      -> Bool
True
  KindedTyVar XKindedTyVar GhcRn
_ flag
_ LIdP GhcRn
_ XRec GhcRn (HsType GhcRn)
ki -> XRec GhcRn (HsType GhcRn) -> Bool
no_anon_wc_ty XRec GhcRn (HsType GhcRn)
ki

{- Note [Fail eagerly on bad signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If a type signature is wrong, fail immediately:

 * the type sigs may bind type variables, so proceeding without them
   can lead to a cascade of errors

 * the type signature might be ambiguous, in which case checking
   the code against the signature will give a very similar error
   to the ambiguity error.

ToDo: this means we fall over if any top-level type signature in the
module is wrong, because we typecheck all the signatures together
(see GHC.Tc.Gen.Bind.tcValBinds).  Moreover, because of top-level
captureTopConstraints, only insoluble constraints will be reported.
We typecheck all signatures at the same time because a signature
like   f,g :: blah   might have f and g from different SCCs.

So it's a bit awkward to get better error recovery, and no one
has complained!
-}

{- *********************************************************************
*                                                                      *
        Type checking a pattern synonym signature
*                                                                      *
************************************************************************

Note [Pattern synonym signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Pattern synonym signatures are surprisingly tricky (see #11224 for example).
In general they look like this:

   pattern P :: forall univ_tvs. req_theta
             => forall ex_tvs. prov_theta
             => arg1 -> .. -> argn -> res_ty

For parsing and renaming we treat the signature as an ordinary LHsSigType.

Once we get to type checking, we decompose it into its parts, in tcPatSynSig.

* Note that 'forall univ_tvs' and 'req_theta =>'
        and 'forall ex_tvs'   and 'prov_theta =>'
  are all optional.  We gather the pieces at the top of tcPatSynSig

* Initially the implicitly-bound tyvars (added by the renamer) include both
  universal and existential vars.

* After we kind-check the pieces and convert to Types, we do kind generalisation.

Note [Report unsolved equalities in tcPatSynSig]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's important that we solve /all/ the equalities in a pattern
synonym signature, because we are going to zonk the signature to
a Type (not a TcType), in GHC.Tc.TyCl.PatSyn.tc_patsyn_finish, and that
fails if there are un-filled-in coercion variables mentioned
in the type (#15694).

So we solve all the equalities we can, and report any unsolved ones,
rather than leaving them in the ambient constraints to be solved
later.  Pattern synonyms are top-level, so there's no problem with
completely solving them.
-}

tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo
-- See Note [Pattern synonym signatures]
-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType
tcPatSynSig :: Name
-> LHsSigType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo
tcPatSynSig Name
name sig_ty :: LHsSigType GhcRn
sig_ty@(L SrcSpanAnnA
_ (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = XRec GhcRn (HsType GhcRn)
hs_ty}))
  | (Maybe (LHsContext GhcRn)
hs_req, XRec GhcRn (HsType GhcRn)
hs_ty1) <- XRec GhcRn (HsType GhcRn)
-> (Maybe (LHsContext GhcRn), XRec GhcRn (HsType GhcRn))
forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy XRec GhcRn (HsType GhcRn)
hs_ty
  , ([LHsTyVarBndr Specificity GhcRn]
ex_hs_tvbndrs, Maybe (LHsContext GhcRn)
hs_prov, XRec GhcRn (HsType GhcRn)
hs_body_ty) <- XRec GhcRn (HsType GhcRn)
-> ([LHsTyVarBndr Specificity GhcRn], Maybe (LHsContext GhcRn),
    XRec GhcRn (HsType GhcRn))
forall (p :: Pass).
LHsType (GhcPass p)
-> ([LHsTyVarBndr Specificity (GhcPass p)],
    Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))
splitLHsSigmaTyInvis XRec GhcRn (HsType GhcRn)
hs_ty1
  = do { String -> SDoc -> TcRn ()
traceTc String
"tcPatSynSig 1" (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
sig_ty)

       ; SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (Name -> SkolemInfoAnon
DataConSkol Name
name)
       ; (TcLevel
tclvl, WantedConstraints
wanted, (HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs, ([VarBndr TcId Specificity]
ex_bndrs, ([Kind]
req, [Kind]
prov, Kind
body_ty))))
           <- String
-> TcM
     (HsOuterTyVarBndrs Specificity GhcTc,
      ([VarBndr TcId Specificity], ([Kind], [Kind], Kind)))
-> TcM
     (TcLevel, WantedConstraints,
      (HsOuterTyVarBndrs Specificity GhcTc,
       ([VarBndr TcId Specificity], ([Kind], [Kind], Kind))))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcPatSynSig"           (TcM
   (HsOuterTyVarBndrs Specificity GhcTc,
    ([VarBndr TcId Specificity], ([Kind], [Kind], Kind)))
 -> TcM
      (TcLevel, WantedConstraints,
       (HsOuterTyVarBndrs Specificity GhcTc,
        ([VarBndr TcId Specificity], ([Kind], [Kind], Kind)))))
-> TcM
     (HsOuterTyVarBndrs Specificity GhcTc,
      ([VarBndr TcId Specificity], ([Kind], [Kind], Kind)))
-> TcM
     (TcLevel, WantedConstraints,
      (HsOuterTyVarBndrs Specificity GhcTc,
       ([VarBndr TcId Specificity], ([Kind], [Kind], Kind))))
forall a b. (a -> b) -> a -> b
$
                     -- See Note [Report unsolved equalities in tcPatSynSig]
              SkolemInfo
-> HsOuterSigTyVarBndrs GhcRn
-> TcM ([VarBndr TcId Specificity], ([Kind], [Kind], Kind))
-> TcM
     (HsOuterTyVarBndrs Specificity GhcTc,
      ([VarBndr TcId Specificity], ([Kind], [Kind], Kind)))
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrs SkolemInfo
skol_info HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs   (TcM ([VarBndr TcId Specificity], ([Kind], [Kind], Kind))
 -> TcM
      (HsOuterTyVarBndrs Specificity GhcTc,
       ([VarBndr TcId Specificity], ([Kind], [Kind], Kind))))
-> TcM ([VarBndr TcId Specificity], ([Kind], [Kind], Kind))
-> TcM
     (HsOuterTyVarBndrs Specificity GhcTc,
      ([VarBndr TcId Specificity], ([Kind], [Kind], Kind)))
forall a b. (a -> b) -> a -> b
$
              SkolemInfo
-> [LHsTyVarBndr Specificity GhcRn]
-> TcM ([Kind], [Kind], Kind)
-> TcM ([VarBndr TcId Specificity], ([Kind], [Kind], Kind))
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TcId flag], a)
tcExplicitTKBndrs SkolemInfo
skol_info [LHsTyVarBndr Specificity GhcRn]
ex_hs_tvbndrs (TcM ([Kind], [Kind], Kind)
 -> TcM ([VarBndr TcId Specificity], ([Kind], [Kind], Kind)))
-> TcM ([Kind], [Kind], Kind)
-> TcM ([VarBndr TcId Specificity], ([Kind], [Kind], Kind))
forall a b. (a -> b) -> a -> b
$
              do { [Kind]
req     <- Maybe (LHsContext GhcRn) -> TcM [Kind]
tcHsContext Maybe (LHsContext GhcRn)
hs_req
                 ; [Kind]
prov    <- Maybe (LHsContext GhcRn) -> TcM [Kind]
tcHsContext Maybe (LHsContext GhcRn)
hs_prov
                 ; Kind
body_ty <- XRec GhcRn (HsType GhcRn) -> TcM Kind
tcHsOpenType XRec GhcRn (HsType GhcRn)
hs_body_ty
                     -- A (literal) pattern can be unlifted;
                     -- e.g. pattern Zero <- 0#   (#12094)
                 ; ([Kind], [Kind], Kind) -> TcM ([Kind], [Kind], Kind)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Kind]
req, [Kind]
prov, Kind
body_ty) }

       ; let implicit_tvs :: [TcTyVar]
             univ_bndrs   :: [TcInvisTVBinder]
             ([TcId]
implicit_tvs, [VarBndr TcId Specificity]
univ_bndrs) = case HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs of
               HsOuterImplicit{hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit = XHsOuterImplicit GhcTc
implicit_tvs} -> ([TcId]
XHsOuterImplicit GhcTc
implicit_tvs, [])
               HsOuterExplicit{hso_xexplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterExplicit pass flag
hso_xexplicit = XHsOuterExplicit GhcTc Specificity
univ_bndrs}   -> ([], [VarBndr TcId Specificity]
XHsOuterExplicit GhcTc Specificity
univ_bndrs)

       ; [TcId]
implicit_tvs <- [TcId] -> TcM [TcId]
zonkAndScopedSort [TcId]
implicit_tvs
       ; let implicit_bndrs :: [VarBndr TcId Specificity]
implicit_bndrs = Specificity -> [TcId] -> [VarBndr TcId Specificity]
forall vis. vis -> [TcId] -> [VarBndr TcId vis]
mkTyVarBinders Specificity
SpecifiedSpec [TcId]
implicit_tvs

       -- Kind generalisation
       ; let ungen_patsyn_ty :: Kind
ungen_patsyn_ty = [VarBndr TcId Specificity]
-> [VarBndr TcId Specificity]
-> [Kind]
-> [VarBndr TcId Specificity]
-> [Kind]
-> Kind
-> Kind
build_patsyn_type [VarBndr TcId Specificity]
implicit_bndrs [VarBndr TcId Specificity]
univ_bndrs
                                                 [Kind]
req [VarBndr TcId Specificity]
ex_bndrs [Kind]
prov Kind
body_ty
       ; String -> SDoc -> TcRn ()
traceTc String
"tcPatSynSig" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
ungen_patsyn_ty)
       ; [TcId]
kvs <- SkolemInfo -> Kind -> TcM [TcId]
kindGeneralizeAll SkolemInfo
skol_info Kind
ungen_patsyn_ty
       ; SkolemInfo -> [TcId] -> TcLevel -> WantedConstraints -> TcRn ()
reportUnsolvedEqualities SkolemInfo
skol_info [TcId]
kvs TcLevel
tclvl WantedConstraints
wanted
               -- See Note [Report unsolved equalities in tcPatSynSig]

       -- These are /signatures/ so we zonk to squeeze out any kind
       -- unification variables.  Do this after kindGeneralizeAll which may
       -- default kind variables to *.
       ; ZonkEnv
ze                   <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
       ; (ZonkEnv
ze, [VarBndr TcId Specificity]
kv_bndrs)       <- ZonkEnv
-> [VarBndr TcId Specificity]
-> TcM (ZonkEnv, [VarBndr TcId Specificity])
forall vis.
ZonkEnv -> [VarBndr TcId vis] -> TcM (ZonkEnv, [VarBndr TcId vis])
zonkTyVarBindersX   ZonkEnv
ze (Specificity -> [TcId] -> [VarBndr TcId Specificity]
forall vis. vis -> [TcId] -> [VarBndr TcId vis]
mkTyVarBinders Specificity
InferredSpec [TcId]
kvs)
       ; (ZonkEnv
ze, [VarBndr TcId Specificity]
implicit_bndrs) <- ZonkEnv
-> [VarBndr TcId Specificity]
-> TcM (ZonkEnv, [VarBndr TcId Specificity])
forall vis.
ZonkEnv -> [VarBndr TcId vis] -> TcM (ZonkEnv, [VarBndr TcId vis])
zonkTyVarBindersX   ZonkEnv
ze [VarBndr TcId Specificity]
implicit_bndrs
       ; (ZonkEnv
ze, [VarBndr TcId Specificity]
univ_bndrs)     <- ZonkEnv
-> [VarBndr TcId Specificity]
-> TcM (ZonkEnv, [VarBndr TcId Specificity])
forall vis.
ZonkEnv -> [VarBndr TcId vis] -> TcM (ZonkEnv, [VarBndr TcId vis])
zonkTyVarBindersX   ZonkEnv
ze [VarBndr TcId Specificity]
univ_bndrs
       ; (ZonkEnv
ze, [VarBndr TcId Specificity]
ex_bndrs)       <- ZonkEnv
-> [VarBndr TcId Specificity]
-> TcM (ZonkEnv, [VarBndr TcId Specificity])
forall vis.
ZonkEnv -> [VarBndr TcId vis] -> TcM (ZonkEnv, [VarBndr TcId vis])
zonkTyVarBindersX   ZonkEnv
ze [VarBndr TcId Specificity]
ex_bndrs
       ; [Kind]
req                  <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [Kind]
req
       ; [Kind]
prov                 <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [Kind]
prov
       ; Kind
body_ty              <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX   ZonkEnv
ze Kind
body_ty

       -- Now do validity checking
       ; UserTypeCtxt -> Kind -> TcRn ()
checkValidType UserTypeCtxt
ctxt (Kind -> TcRn ()) -> Kind -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [VarBndr TcId Specificity]
-> [VarBndr TcId Specificity]
-> [Kind]
-> [VarBndr TcId Specificity]
-> [Kind]
-> Kind
-> Kind
build_patsyn_type [VarBndr TcId Specificity]
implicit_bndrs [VarBndr TcId Specificity]
univ_bndrs [Kind]
req [VarBndr TcId Specificity]
ex_bndrs [Kind]
prov Kind
body_ty

       -- Neither argument types nor the return type may be representation polymorphic.
       -- This is because, when creating a matcher:
       --   - the argument types become the binder types (see test RepPolyPatySynArg),
       --   - the return type becomes the scrutinee type (see test RepPolyPatSynRes).
       ; let ([Scaled Kind]
arg_tys, Kind
res_ty) = Kind -> ([Scaled Kind], Kind)
tcSplitFunTys Kind
body_ty
       ; (Scaled Kind -> TcRn ()) -> [Scaled Kind] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
           (\(Scaled Kind
_ Kind
arg_ty) -> FixedRuntimeRepProvenance -> Kind -> TcRn ()
checkTypeHasFixedRuntimeRep FixedRuntimeRepProvenance
FixedRuntimeRepPatSynSigArg Kind
arg_ty)
           [Scaled Kind]
arg_tys
       ; FixedRuntimeRepProvenance -> Kind -> TcRn ()
checkTypeHasFixedRuntimeRep FixedRuntimeRepProvenance
FixedRuntimeRepPatSynSigRes Kind
res_ty

       ; String -> SDoc -> TcRn ()
traceTc String
"tcTySig }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"kvs"          SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TcId] -> SDoc
ppr_tvs ([VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
kv_bndrs)
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"implicit_tvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TcId] -> SDoc
ppr_tvs ([VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
implicit_bndrs)
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"univ_tvs"     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TcId] -> SDoc
ppr_tvs ([VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
univ_bndrs)
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"req" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Kind] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Kind]
req
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ex_tvs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TcId] -> SDoc
ppr_tvs ([VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
ex_bndrs)
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"prov" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Kind] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Kind]
prov
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"body_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
body_ty ]
       ; TcPatSynInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TPSI { patsig_name :: Name
patsig_name = Name
name
                      , patsig_implicit_bndrs :: [VarBndr TcId Specificity]
patsig_implicit_bndrs = [VarBndr TcId Specificity]
kv_bndrs [VarBndr TcId Specificity]
-> [VarBndr TcId Specificity] -> [VarBndr TcId Specificity]
forall a. [a] -> [a] -> [a]
++ [VarBndr TcId Specificity]
implicit_bndrs
                      , patsig_univ_bndrs :: [VarBndr TcId Specificity]
patsig_univ_bndrs     = [VarBndr TcId Specificity]
univ_bndrs
                      , patsig_req :: [Kind]
patsig_req            = [Kind]
req
                      , patsig_ex_bndrs :: [VarBndr TcId Specificity]
patsig_ex_bndrs       = [VarBndr TcId Specificity]
ex_bndrs
                      , patsig_prov :: [Kind]
patsig_prov           = [Kind]
prov
                      , patsig_body_ty :: Kind
patsig_body_ty        = Kind
body_ty }) }
  where
    ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
PatSynCtxt Name
name

    build_patsyn_type :: [VarBndr TcId Specificity]
-> [VarBndr TcId Specificity]
-> [Kind]
-> [VarBndr TcId Specificity]
-> [Kind]
-> Kind
-> Kind
build_patsyn_type [VarBndr TcId Specificity]
implicit_bndrs [VarBndr TcId Specificity]
univ_bndrs [Kind]
req [VarBndr TcId Specificity]
ex_bndrs [Kind]
prov Kind
body
      = [VarBndr TcId Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr TcId Specificity]
implicit_bndrs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
        [VarBndr TcId Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr TcId Specificity]
univ_bndrs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
        [Kind] -> Kind -> Kind
mk_naked_phi_ty [Kind]
req (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
        [VarBndr TcId Specificity] -> Kind -> Kind
mkInvisForAllTys [VarBndr TcId Specificity]
ex_bndrs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
        [Kind] -> Kind -> Kind
mk_naked_phi_ty [Kind]
prov (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
        Kind
body

    -- Use mk_naked_phi_ty because we call build_patsyn_type /before zonking/
    -- just before kindGeneraliseAll, and the invariants that mkPhiTy checks
    -- don't hold of the un-zonked types.  #22521 was a case in point.
    -- (We also called build_patsyn_type on the fully zonked type, so mkPhiTy
    --  would work; but it doesn't seem worth duplicating the code.)
    mk_naked_phi_ty :: [TcPredType] -> TcType -> TcType
    mk_naked_phi_ty :: [Kind] -> Kind -> Kind
mk_naked_phi_ty [Kind]
theta Kind
body = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FunTyFlag -> Kind -> Kind -> Kind
mkNakedFunTy FunTyFlag
invisArgTypeLike) Kind
body [Kind]
theta

ppr_tvs :: [TyVar] -> SDoc
ppr_tvs :: [TcId] -> SDoc
ppr_tvs [TcId]
tvs = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
tv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Kind
tyVarKind TcId
tv)
                           | TcId
tv <- [TcId]
tvs])


{- *********************************************************************
*                                                                      *
               Instantiating user signatures
*                                                                      *
********************************************************************* -}


tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst
-- Instantiate a type signature; only used with plan InferGen
tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst
tcInstSig sig :: TcIdSigInfo
sig@(CompleteSig { sig_bndr :: TcIdSigInfo -> TcId
sig_bndr = TcId
poly_id, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
  = SrcSpan -> TcM TcIdSigInst -> TcM TcIdSigInst
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM TcIdSigInst -> TcM TcIdSigInst)
-> TcM TcIdSigInst -> TcM TcIdSigInst
forall a b. (a -> b) -> a -> b
$  -- Set the binding site of the tyvars
    do { ([(Name, VarBndr TcId Specificity)]
tv_prs, [Kind]
theta, Kind
tau) <- Kind -> TcM ([(Name, VarBndr TcId Specificity)], [Kind], Kind)
tcInstTypeBndrs (TcId -> Kind
idType TcId
poly_id)
              -- See Note [Pattern bindings and complete signatures]

       ; TcIdSigInst -> TcM TcIdSigInst
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TISI { sig_inst_sig :: TcIdSigInfo
sig_inst_sig   = TcIdSigInfo
sig
                      , sig_inst_skols :: [(Name, VarBndr TcId Specificity)]
sig_inst_skols = [(Name, VarBndr TcId Specificity)]
tv_prs
                      , sig_inst_wcs :: [(Name, TcId)]
sig_inst_wcs   = []
                      , sig_inst_wcx :: Maybe Kind
sig_inst_wcx   = Maybe Kind
forall a. Maybe a
Nothing
                      , sig_inst_theta :: [Kind]
sig_inst_theta = [Kind]
theta
                      , sig_inst_tau :: Kind
sig_inst_tau   = Kind
tau }) }

tcInstSig hs_sig :: TcIdSigInfo
hs_sig@(PartialSig { psig_hs_ty :: TcIdSigInfo -> LHsSigWcType GhcRn
psig_hs_ty = LHsSigWcType GhcRn
hs_ty
                             , sig_ctxt :: TcIdSigInfo -> UserTypeCtxt
sig_ctxt = UserTypeCtxt
ctxt
                             , sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
  = SrcSpan -> TcM TcIdSigInst -> TcM TcIdSigInst
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM TcIdSigInst -> TcM TcIdSigInst)
-> TcM TcIdSigInst -> TcM TcIdSigInst
forall a b. (a -> b) -> a -> b
$  -- Set the binding site of the tyvars
    do { String -> SDoc -> TcRn ()
traceTc String
"Staring partial sig {" (TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
hs_sig)
       ; ([(Name, TcId)]
wcs, Maybe Kind
wcx, [(Name, VarBndr TcId Specificity)]
tv_prs, [Kind]
theta, Kind
tau) <- UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM
     ([(Name, TcId)], Maybe Kind, [(Name, VarBndr TcId Specificity)],
      [Kind], Kind)
tcHsPartialSigType UserTypeCtxt
ctxt LHsSigWcType GhcRn
hs_ty
         -- See Note [Checking partial type signatures] in GHC.Tc.Gen.HsType

       ; let inst_sig :: TcIdSigInst
inst_sig = TISI { sig_inst_sig :: TcIdSigInfo
sig_inst_sig   = TcIdSigInfo
hs_sig
                             , sig_inst_skols :: [(Name, VarBndr TcId Specificity)]
sig_inst_skols = [(Name, VarBndr TcId Specificity)]
tv_prs
                             , sig_inst_wcs :: [(Name, TcId)]
sig_inst_wcs   = [(Name, TcId)]
wcs
                             , sig_inst_wcx :: Maybe Kind
sig_inst_wcx   = Maybe Kind
wcx
                             , sig_inst_theta :: [Kind]
sig_inst_theta = [Kind]
theta
                             , sig_inst_tau :: Kind
sig_inst_tau   = Kind
tau }
       ; String -> SDoc -> TcRn ()
traceTc String
"End partial sig }" (TcIdSigInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInst
inst_sig)
       ; TcIdSigInst -> TcM TcIdSigInst
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcIdSigInst
inst_sig }


{- Note [Pattern bindings and complete signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
      data T a = MkT a a
      f :: forall a. a->a
      g :: forall b. b->b
      MkT f g = MkT (\x->x) (\y->y)
Here we'll infer a type from the pattern of 'T a', but if we feed in
the signature types for f and g, we'll end up unifying 'a' and 'b'

So we instantiate f and g's signature with TyVarTv skolems
(newMetaTyVarTyVars) that can unify with each other.  If too much
unification takes place, we'll find out when we do the final
impedance-matching check in GHC.Tc.Gen.Bind.mkExport

See Note [TyVarTv] in GHC.Tc.Utils.TcMType

None of this applies to a function binding with a complete
signature, which doesn't use tcInstSig.  See GHC.Tc.Gen.Bind.tcPolyCheck.
-}

{- *********************************************************************
*                                                                      *
                   Pragmas and PragEnv
*                                                                      *
********************************************************************* -}

type TcPragEnv = NameEnv [LSig GhcRn]

emptyPragEnv :: TcPragEnv
emptyPragEnv :: TcPragEnv
emptyPragEnv = TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. NameEnv a
emptyNameEnv

lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn]
lookupPragEnv TcPragEnv
prag_fn Name
n = NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> Name -> Maybe [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
prag_fn Name
n Maybe [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. Maybe a -> a -> a
`orElse` []

extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv
extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv
extendPragEnv TcPragEnv
prag_fn (Name
n, LSig GhcRn
sig) = (GenLocated SrcSpanAnnA (Sig GhcRn)
 -> [GenLocated SrcSpanAnnA (Sig GhcRn)]
 -> [GenLocated SrcSpanAnnA (Sig GhcRn)])
-> (GenLocated SrcSpanAnnA (Sig GhcRn)
    -> [GenLocated SrcSpanAnnA (Sig GhcRn)])
-> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> Name
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a b.
(a -> b -> b) -> (a -> b) -> NameEnv b -> Name -> a -> NameEnv b
extendNameEnv_Acc (:) GenLocated SrcSpanAnnA (Sig GhcRn)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. a -> [a]
Utils.singleton TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
prag_fn Name
n LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig

---------------
mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
mkPragEnv [LSig GhcRn]
sigs LHsBinds GhcRn
binds
  = (NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
 -> (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
 -> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)])
-> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [(Name, GenLocated SrcSpanAnnA (Sig GhcRn))]
-> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv
NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
extendPragEnv NameEnv [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. NameEnv a
emptyNameEnv [(Name, GenLocated SrcSpanAnnA (Sig GhcRn))]
prs
  where
    prs :: [(Name, GenLocated SrcSpanAnnA (Sig GhcRn))]
prs = (GenLocated SrcSpanAnnA (Sig GhcRn)
 -> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn)))
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [(Name, GenLocated SrcSpanAnnA (Sig GhcRn))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LSig GhcRn -> Maybe (Name, LSig GhcRn)
GenLocated SrcSpanAnnA (Sig GhcRn)
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
get_sig [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs

    get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
    get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
get_sig sig :: LSig GhcRn
sig@(L SrcSpanAnnA
_ (SpecSig XSpecSig GhcRn
_ (L SrcSpanAnnN
_ Name
nm) [LHsSigType GhcRn]
_ InlinePragma
_))   = (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. a -> Maybe a
Just (Name
nm, Name
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
add_arity Name
nm LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig)
    get_sig sig :: LSig GhcRn
sig@(L SrcSpanAnnA
_ (InlineSig XInlineSig GhcRn
_ (L SrcSpanAnnN
_ Name
nm) InlinePragma
_))   = (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. a -> Maybe a
Just (Name
nm, Name
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> GenLocated SrcSpanAnnA (Sig GhcRn)
add_arity Name
nm LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig)
    get_sig sig :: LSig GhcRn
sig@(L SrcSpanAnnA
_ (SCCFunSig XSCCFunSig GhcRn
_ (L SrcSpanAnnN
_ Name
nm) Maybe (XRec GhcRn StringLiteral)
_)) = (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
-> Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. a -> Maybe a
Just (Name
nm, LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig)
    get_sig LSig GhcRn
_ = Maybe (Name, LSig GhcRn)
Maybe (Name, GenLocated SrcSpanAnnA (Sig GhcRn))
forall a. Maybe a
Nothing

    add_arity :: Name -> GenLocated SrcSpanAnnA (Sig GhcRn) -> LSig GhcRn
add_arity Name
n GenLocated SrcSpanAnnA (Sig GhcRn)
sig  -- Adjust inl_sat field to match visible arity of function
      = case NameEnv Arity -> Name -> Maybe Arity
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Arity
ar_env Name
n of
          Just Arity
ar -> Arity -> LSig GhcRn -> LSig GhcRn
addInlinePragArity Arity
ar LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig
          Maybe Arity
Nothing -> LSig GhcRn
GenLocated SrcSpanAnnA (Sig GhcRn)
sig -- See Note [Pattern synonym inline arity]

    -- ar_env maps a local to the arity of its definition
    ar_env :: NameEnv Arity
    ar_env :: NameEnv Arity
ar_env = (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
 -> NameEnv Arity -> NameEnv Arity)
-> NameEnv Arity
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
-> NameEnv Arity
forall a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)
-> NameEnv Arity -> NameEnv Arity
lhsBindArity NameEnv Arity
forall a. NameEnv a
emptyNameEnv LHsBinds GhcRn
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn))
binds

addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn
addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn
addInlinePragArity Arity
ar (L SrcSpanAnnA
l (InlineSig XInlineSig GhcRn
x LIdP GhcRn
nm InlinePragma
inl))  = SrcSpanAnnA -> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XInlineSig GhcRn -> LIdP GhcRn -> InlinePragma -> Sig GhcRn
forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig XInlineSig GhcRn
x LIdP GhcRn
nm (Arity -> InlinePragma -> InlinePragma
add_inl_arity Arity
ar InlinePragma
inl))
addInlinePragArity Arity
ar (L SrcSpanAnnA
l (SpecSig XSpecSig GhcRn
x LIdP GhcRn
nm [LHsSigType GhcRn]
ty InlinePragma
inl)) = SrcSpanAnnA -> Sig GhcRn -> GenLocated SrcSpanAnnA (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XSpecSig GhcRn
-> LIdP GhcRn -> [LHsSigType GhcRn] -> InlinePragma -> Sig GhcRn
forall pass.
XSpecSig pass
-> LIdP pass -> [LHsSigType pass] -> InlinePragma -> Sig pass
SpecSig XSpecSig GhcRn
x LIdP GhcRn
nm [LHsSigType GhcRn]
ty (Arity -> InlinePragma -> InlinePragma
add_inl_arity Arity
ar InlinePragma
inl))
addInlinePragArity Arity
_ LSig GhcRn
sig = LSig GhcRn
sig

add_inl_arity :: Arity -> InlinePragma -> InlinePragma
add_inl_arity :: Arity -> InlinePragma -> InlinePragma
add_inl_arity Arity
ar prag :: InlinePragma
prag@(InlinePragma { inl_inline :: InlinePragma -> InlineSpec
inl_inline = InlineSpec
inl_spec })
  | Inline {} <- InlineSpec
inl_spec  -- Add arity only for real INLINE pragmas, not INLINABLE
  = InlinePragma
prag { inl_sat = Just ar }
  | Bool
otherwise
  = InlinePragma
prag

lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity (L SrcSpanAnnA
_ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = LIdP GhcRn
id, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
ms })) NameEnv Arity
env
  = NameEnv Arity -> Name -> Arity -> NameEnv Arity
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv Arity
env (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc LIdP GhcRn
GenLocated SrcSpanAnnN Name
id) (MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> Arity
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
MatchGroup GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
ms)
lhsBindArity LHsBind GhcRn
_ NameEnv Arity
env = NameEnv Arity
env        -- PatBind/VarBind


-----------------
addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId
addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId
addInlinePrags TcId
poly_id [LSig GhcRn]
prags_for_me
  | inl :: GenLocated SrcSpanAnnA InlinePragma
inl@(L SrcSpanAnnA
_ InlinePragma
prag) : [GenLocated SrcSpanAnnA InlinePragma]
inls <- [GenLocated SrcSpanAnnA InlinePragma]
inl_prags
  = do { String -> SDoc -> TcRn ()
traceTc String
"addInlinePrag" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ InlinePragma -> SDoc
forall a. Outputable a => a -> SDoc
ppr InlinePragma
prag)
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenLocated SrcSpanAnnA InlinePragma] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA InlinePragma]
inls) (GenLocated SrcSpanAnnA InlinePragma
-> [GenLocated SrcSpanAnnA InlinePragma] -> TcRn ()
warn_multiple_inlines GenLocated SrcSpanAnnA InlinePragma
inl [GenLocated SrcSpanAnnA InlinePragma]
inls)
       ; TcId -> TcM TcId
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcId
poly_id TcId -> InlinePragma -> TcId
`setInlinePragma` InlinePragma
prag) }
  | Bool
otherwise
  = TcId -> TcM TcId
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcId
poly_id
  where
    inl_prags :: [GenLocated SrcSpanAnnA InlinePragma]
inl_prags = [SrcSpanAnnA -> InlinePragma -> GenLocated SrcSpanAnnA InlinePragma
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc InlinePragma
prag | L SrcSpanAnnA
loc (InlineSig XInlineSig GhcRn
_ LIdP GhcRn
_ InlinePragma
prag) <- [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
prags_for_me]

    warn_multiple_inlines :: GenLocated SrcSpanAnnA InlinePragma
-> [GenLocated SrcSpanAnnA InlinePragma] -> TcRn ()
warn_multiple_inlines GenLocated SrcSpanAnnA InlinePragma
_ [] = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    warn_multiple_inlines inl1 :: GenLocated SrcSpanAnnA InlinePragma
inl1@(L SrcSpanAnnA
loc InlinePragma
prag1) (inl2 :: GenLocated SrcSpanAnnA InlinePragma
inl2@(L SrcSpanAnnA
_ InlinePragma
prag2) : [GenLocated SrcSpanAnnA InlinePragma]
inls)
       | InlinePragma -> Activation
inlinePragmaActivation InlinePragma
prag1 Activation -> Activation -> Bool
forall a. Eq a => a -> a -> Bool
== InlinePragma -> Activation
inlinePragmaActivation InlinePragma
prag2
       , InlineSpec -> Bool
noUserInlineSpec (InlinePragma -> InlineSpec
inlinePragmaSpec InlinePragma
prag1)
       =    -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop
            -- and inl2 is a user NOINLINE pragma; we don't want to complain
         GenLocated SrcSpanAnnA InlinePragma
-> [GenLocated SrcSpanAnnA InlinePragma] -> TcRn ()
warn_multiple_inlines GenLocated SrcSpanAnnA InlinePragma
inl2 [GenLocated SrcSpanAnnA InlinePragma]
inls
       | Bool
otherwise
       = SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         let dia :: TcRnMessage
dia = TcId
-> GenLocated SrcSpanAnnA InlinePragma
-> NonEmpty (GenLocated SrcSpanAnnA InlinePragma)
-> TcRnMessage
TcRnMultipleInlinePragmas TcId
poly_id GenLocated SrcSpanAnnA InlinePragma
inl1 (GenLocated SrcSpanAnnA InlinePragma
inl2 GenLocated SrcSpanAnnA InlinePragma
-> [GenLocated SrcSpanAnnA InlinePragma]
-> NonEmpty (GenLocated SrcSpanAnnA InlinePragma)
forall a. a -> [a] -> NonEmpty a
NE.:| [GenLocated SrcSpanAnnA InlinePragma]
inls)
         in TcRnMessage -> TcRn ()
addDiagnosticTc TcRnMessage
dia


{- Note [Pattern synonym inline arity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
    {-# INLINE P #-}
    pattern P x = (x, True)

The INLINE pragma attaches to both the /matcher/ and the /builder/ for
the pattern synonym; see Note [Pragmas for pattern synonyms] in
GHC.Tc.TyCl.PatSyn.  But they have different inline arities (i.e. number
of binders to which we apply the function before inlining), and we don't
know what those arities are yet.  So for pattern synonyms we don't set
the inl_sat field yet; instead we do so (via addInlinePragArity) in
GHC.Tc.TyCl.PatSyn.tcPatSynMatcher and tcPatSynBuilderBind.

It's a bit messy that we set the arities in different ways.  Perhaps we
should add the arity later for all binders.  But it works fine like this.
-}


{- *********************************************************************
*                                                                      *
                   SPECIALISE pragmas
*                                                                      *
************************************************************************

Note [Handling SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The basic idea is this:

   foo :: Num a => a -> b -> a
   {-# SPECIALISE foo :: Int -> b -> Int #-}

We check that
   (forall a b. Num a => a -> b -> a)
      is more polymorphic than
   forall b. Int -> b -> Int
(for which we could use tcSubType, but see below), generating a HsWrapper
to connect the two, something like
      wrap = /\b. <hole> Int b dNumInt
This wrapper is put in the TcSpecPrag, in the ABExport record of
the AbsBinds.


        f :: (Eq a, Ix b) => a -> b -> Bool
        {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
        f = <poly_rhs>

From this the typechecker generates

    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds

    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])

From these we generate:

    Rule:       forall p, q, (dp:Ix p), (dq:Ix q).
                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq

    Spec bind:  f_spec = wrap_fn <poly_rhs>

Note that

  * The LHS of the rule may mention dictionary *expressions* (eg
    $dfIxPair dp dq), and that is essential because the dp, dq are
    needed on the RHS.

  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
    can fully specialise it.

From the TcSpecPrag, in GHC.HsToCore.Binds we generate a binding for f_spec and a RULE:

   f_spec :: Int -> b -> Int
   f_spec = wrap<f rhs>

   RULE: forall b (d:Num b). f b d = f_spec b

The RULE is generated by taking apart the HsWrapper, which is a little
delicate, but works.

Some wrinkles

1. In tcSpecWrapper, rather than calling tcSubType, we directly call
   skolemise/instantiate.  That is mainly because of wrinkle (2).

   Historical note: in the past, tcSubType did co/contra stuff, which
   could generate too complex a LHS for the RULE, which was another
   reason for not using tcSubType.  But that reason has gone away
   with simple subsumption (#17775).

2. We need to take care with type families (#5821).  Consider
      type instance F Int = Bool
      f :: Num a => a -> F a
      {-# SPECIALISE foo :: Int -> Bool #-}

  We *could* try to generate an f_spec with precisely the declared type:
      f_spec :: Int -> Bool
      f_spec = <f rhs> Int dNumInt |> co

      RULE: forall d. f Int d = f_spec |> sym co

  but the 'co' and 'sym co' are (a) playing no useful role, and (b) are
  hard to generate.  At all costs we must avoid this:
      RULE: forall d. f Int d |> co = f_spec
  because the LHS will never match (indeed it's rejected in
  decomposeRuleLhs).

  So we simply do this:
    - Generate a constraint to check that the specialised type (after
      skolemisation) is equal to the instantiated function type.
    - But *discard* the evidence (coercion) for that constraint,
      so that we ultimately generate the simpler code
          f_spec :: Int -> F Int
          f_spec = <f rhs> Int dNumInt

          RULE: forall d. f Int d = f_spec
      You can see this discarding happening in tcSpecPrag

3. Note that the HsWrapper can transform *any* function with the right
   type prefix
       forall ab. (Eq a, Ix b) => XXX
   regardless of XXX.  It's sort of polymorphic in XXX.  This is
   useful: we use the same wrapper to transform each of the class ops, as
   well as the dict.  That's what goes on in GHC.Tc.TyCl.Instance.mk_meth_spec_prags
-}

tcSpecPrags :: Id -> [LSig GhcRn]
            -> TcM [LTcSpecPrag]
-- Add INLINE and SPECIALSE pragmas
--    INLINE prags are added to the (polymorphic) Id directly
--    SPECIALISE prags are passed to the desugarer via TcSpecPrags
-- Pre-condition: the poly_id is zonked
-- Reason: required by tcSubExp
tcSpecPrags :: TcId -> [LSig GhcRn] -> TcM [LTcSpecPrag]
tcSpecPrags TcId
poly_id [LSig GhcRn]
prag_sigs
  = do { String -> SDoc -> TcRn ()
traceTc String
"tcSpecPrags" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_sigs)
       ; Maybe (NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn)))
-> (NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn)) -> TcRn ())
-> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust ([GenLocated SrcSpanAnnA (Sig GhcRn)]
-> Maybe (NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn)))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [GenLocated SrcSpanAnnA (Sig GhcRn)]
bad_sigs) NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn)) -> TcRn ()
warn_discarded_sigs
       ; [GenLocated SrcSpanAnnA [TcSpecPrag]]
pss <- (GenLocated SrcSpanAnnA (Sig GhcRn)
 -> TcRn (GenLocated SrcSpanAnnA [TcSpecPrag]))
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> TcRn [GenLocated SrcSpanAnnA [TcSpecPrag]]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM ((Sig GhcRn -> TcM [TcSpecPrag])
-> GenLocated SrcSpanAnnA (Sig GhcRn)
-> TcRn (GenLocated SrcSpanAnnA [TcSpecPrag])
forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag TcId
poly_id)) [GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_sigs
       ; [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LTcSpecPrag] -> TcM [LTcSpecPrag])
-> [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA [TcSpecPrag] -> [LTcSpecPrag])
-> [GenLocated SrcSpanAnnA [TcSpecPrag]] -> [LTcSpecPrag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(L SrcSpanAnnA
l [TcSpecPrag]
ps) -> (TcSpecPrag -> LTcSpecPrag) -> [TcSpecPrag] -> [LTcSpecPrag]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> TcSpecPrag -> LTcSpecPrag
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)) [TcSpecPrag]
ps) [GenLocated SrcSpanAnnA [TcSpecPrag]]
pss }
  where
    spec_sigs :: [GenLocated SrcSpanAnnA (Sig GhcRn)]
spec_sigs = (GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter LSig GhcRn -> Bool
GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool
forall p. UnXRec p => LSig p -> Bool
isSpecLSig [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
prag_sigs
    bad_sigs :: [GenLocated SrcSpanAnnA (Sig GhcRn)]
bad_sigs  = (GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool)
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
-> [GenLocated SrcSpanAnnA (Sig GhcRn)]
forall a. (a -> Bool) -> [a] -> [a]
filter LSig GhcRn -> Bool
GenLocated SrcSpanAnnA (Sig GhcRn) -> Bool
forall p. UnXRec p => LSig p -> Bool
is_bad_sig [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
prag_sigs
    is_bad_sig :: XRec p (Sig p) -> Bool
is_bad_sig XRec p (Sig p)
s = Bool -> Bool
not (XRec p (Sig p) -> Bool
forall p. UnXRec p => LSig p -> Bool
isSpecLSig XRec p (Sig p)
s Bool -> Bool -> Bool
|| XRec p (Sig p) -> Bool
forall p. UnXRec p => LSig p -> Bool
isInlineLSig XRec p (Sig p)
s Bool -> Bool -> Bool
|| XRec p (Sig p) -> Bool
forall p. UnXRec p => LSig p -> Bool
isSCCFunSig XRec p (Sig p)
s)

    warn_discarded_sigs :: NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn)) -> TcRn ()
warn_discarded_sigs NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn))
bad_sigs_ne
      = let dia :: TcRnMessage
dia = TcId -> NonEmpty (LSig GhcRn) -> TcRnMessage
TcRnUnexpectedPragmas TcId
poly_id NonEmpty (LSig GhcRn)
NonEmpty (GenLocated SrcSpanAnnA (Sig GhcRn))
bad_sigs_ne
        in TcRnMessage -> TcRn ()
addDiagnosticTc TcRnMessage
dia

--------------
tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag TcId
poly_id prag :: Sig GhcRn
prag@(SpecSig XSpecSig GhcRn
_ LIdP GhcRn
fun_name [LHsSigType GhcRn]
hs_tys InlinePragma
inl)
-- See Note [Handling SPECIALISE pragmas]
--
-- The Name fun_name in the SpecSig may not be the same as that of the poly_id
-- Example: SPECIALISE for a class method: the Name in the SpecSig is
--          for the selector Id, but the poly_id is something like $cop
-- However we want to use fun_name in the error message, since that is
-- what the user wrote (#8537)
  = SDoc -> TcM [TcSpecPrag] -> TcM [TcSpecPrag]
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Sig GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
spec_ctxt Sig GhcRn
prag) (TcM [TcSpecPrag] -> TcM [TcSpecPrag])
-> TcM [TcSpecPrag] -> TcM [TcSpecPrag]
forall a b. (a -> b) -> a -> b
$
    do  { Bool -> TcRnMessage -> TcRn ()
warnIf (Bool -> Bool
not (Kind -> Bool
isOverloadedTy Kind
poly_ty Bool -> Bool -> Bool
|| InlinePragma -> Bool
isInlinePragma InlinePragma
inl)) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                 LIdP GhcRn -> TcRnMessage
TcRnNonOverloadedSpecialisePragma LIdP GhcRn
fun_name
                    -- Note [SPECIALISE pragmas]
        ; [TcSpecPrag]
spec_prags <- (GenLocated SrcSpanAnnA (HsSigType GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag)
-> [GenLocated SrcSpanAnnA (HsSigType GhcRn)] -> TcM [TcSpecPrag]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag
tc_one [LHsSigType GhcRn]
[GenLocated SrcSpanAnnA (HsSigType GhcRn)]
hs_tys
        ; String -> SDoc -> TcRn ()
traceTc String
"tcSpecPrag" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Arity -> SDoc -> SDoc
nest Arity
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((TcSpecPrag -> SDoc) -> [TcSpecPrag] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TcSpecPrag -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcSpecPrag]
spec_prags)))
        ; [TcSpecPrag] -> TcM [TcSpecPrag]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [TcSpecPrag]
spec_prags }
  where
    name :: Name
name      = TcId -> Name
idName TcId
poly_id
    poly_ty :: Kind
poly_ty   = TcId -> Kind
idType TcId
poly_id
    spec_ctxt :: a -> SDoc
spec_ctxt a
prag = SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the pragma:") Arity
2 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
prag)

    tc_one :: GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag
tc_one GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty
      = do { Kind
spec_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Kind
tcHsSigType   (Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
name ReportRedundantConstraints
NoRRC) LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty
           ; HsWrapper
wrap    <- UserTypeCtxt -> Kind -> Kind -> TcM HsWrapper
tcSpecWrapper (Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
name (LHsSigType GhcRn -> ReportRedundantConstraints
lhsSigTypeContextSpan LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty)) Kind
poly_ty Kind
spec_ty
           ; TcSpecPrag -> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcId -> HsWrapper -> InlinePragma -> TcSpecPrag
SpecPrag TcId
poly_id HsWrapper
wrap InlinePragma
inl) }

tcSpecPrag TcId
_ Sig GhcRn
prag = String -> SDoc -> TcM [TcSpecPrag]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSpecPrag" (Sig GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr Sig GhcRn
prag)

--------------
tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
-- A simpler variant of tcSubType, used for SPECIALISE pragmas
-- See Note [Handling SPECIALISE pragmas], wrinkle 1
tcSpecWrapper :: UserTypeCtxt -> Kind -> Kind -> TcM HsWrapper
tcSpecWrapper UserTypeCtxt
ctxt Kind
poly_ty Kind
spec_ty
  = do { (HsWrapper
sk_wrap, HsWrapper
inst_wrap)
               <- UserTypeCtxt
-> Kind -> (Kind -> TcM HsWrapper) -> TcM (HsWrapper, HsWrapper)
forall result.
UserTypeCtxt
-> Kind -> (Kind -> TcM result) -> TcM (HsWrapper, result)
tcTopSkolemise UserTypeCtxt
ctxt Kind
spec_ty ((Kind -> TcM HsWrapper) -> TcM (HsWrapper, HsWrapper))
-> (Kind -> TcM HsWrapper) -> TcM (HsWrapper, HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ Kind
spec_tau ->
                  do { (HsWrapper
inst_wrap, Kind
tau) <- CtOrigin -> Kind -> TcM (HsWrapper, Kind)
topInstantiate CtOrigin
orig Kind
poly_ty
                     ; TcCoercionN
_ <- Maybe TypedThing -> Kind -> Kind -> TcM TcCoercionN
unifyType Maybe TypedThing
forall a. Maybe a
Nothing Kind
spec_tau Kind
tau
                            -- Deliberately ignore the evidence
                            -- See Note [Handling SPECIALISE pragmas],
                            --   wrinkle (2)
                     ; HsWrapper -> TcM HsWrapper
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
inst_wrap }
       ; HsWrapper -> TcM HsWrapper
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
sk_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inst_wrap) }
  where
    orig :: CtOrigin
orig = UserTypeCtxt -> CtOrigin
SpecPragOrigin UserTypeCtxt
ctxt

--------------
tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag]
-- SPECIALISE pragmas for imported things
tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag]
tcImpPrags [LSig GhcRn]
prags
  = do { Module
this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; if (DynFlags -> Bool
not_specialising DynFlags
dflags) then
            [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
         else do
            { [GenLocated SrcSpanAnnA [TcSpecPrag]]
pss <- (GenLocated SrcSpanAnnA (Name, Sig GhcRn)
 -> TcRn (GenLocated SrcSpanAnnA [TcSpecPrag]))
-> [GenLocated SrcSpanAnnA (Name, Sig GhcRn)]
-> TcRn [GenLocated SrcSpanAnnA [TcSpecPrag]]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM (((Name, Sig GhcRn) -> TcM [TcSpecPrag])
-> GenLocated SrcSpanAnnA (Name, Sig GhcRn)
-> TcRn (GenLocated SrcSpanAnnA [TcSpecPrag])
forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec)
                     [SrcSpanAnnA
-> (Name, Sig GhcRn) -> GenLocated SrcSpanAnnA (Name, Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (Name
name,Sig GhcRn
prag)
                             | (L SrcSpanAnnA
loc prag :: Sig GhcRn
prag@(SpecSig XSpecSig GhcRn
_ (L SrcSpanAnnN
_ Name
name) [LHsSigType GhcRn]
_ InlinePragma
_)) <- [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
prags
                             , Bool -> Bool
not (Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
name) ]
            ; [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LTcSpecPrag] -> TcM [LTcSpecPrag])
-> [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA [TcSpecPrag] -> [LTcSpecPrag])
-> [GenLocated SrcSpanAnnA [TcSpecPrag]] -> [LTcSpecPrag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(L SrcSpanAnnA
l [TcSpecPrag]
ps) -> (TcSpecPrag -> LTcSpecPrag) -> [TcSpecPrag] -> [LTcSpecPrag]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> TcSpecPrag -> LTcSpecPrag
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)) [TcSpecPrag]
ps) [GenLocated SrcSpanAnnA [TcSpecPrag]]
pss } }
  where
    -- Ignore SPECIALISE pragmas for imported things
    -- when we aren't specialising, or when we aren't generating
    -- code.  The latter happens when Haddocking the base library;
    -- we don't want complaints about lack of INLINABLE pragmas
    not_specialising :: DynFlags -> Bool
not_specialising DynFlags
dflags =
      Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Specialise DynFlags
dflags) Bool -> Bool -> Bool
|| Bool -> Bool
not (Backend -> Bool
backendRespectsSpecialise (DynFlags -> Backend
backend DynFlags
dflags))

tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec (Name
name, Sig GhcRn
prag)
 = do { TcId
id <- Name -> TcM TcId
tcLookupId Name
name
      ; if Unfolding -> Bool
hasSomeUnfolding (TcId -> Unfolding
realIdUnfolding TcId
id)
           -- See Note [SPECIALISE pragmas for imported Ids]
        then TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag TcId
id Sig GhcRn
prag
        else do { let dia :: TcRnMessage
dia = Name -> TcRnMessage
TcRnSpecialiseNotVisible Name
name
                ; TcRnMessage -> TcRn ()
addDiagnosticTc TcRnMessage
dia
                ; [TcSpecPrag] -> TcM [TcSpecPrag]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [] } }

{- Note [SPECIALISE pragmas for imported Ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
An imported Id may or may not have an unfolding.  If not, we obviously
can't specialise it here; indeed the desugar falls over (#18118).

We used to test whether it had a user-specified INLINABLE pragma but,
because of Note [Worker/wrapper for INLINABLE functions] in
GHC.Core.Opt.WorkWrap, even an INLINABLE function may end up with
a wrapper that has no pragma, just an unfolding (#19246).  So now
we just test whether the function has an unfolding.

There's a risk that a pragma-free function may have an unfolding now
(because it is fairly small), and then gets a bit bigger, and no
longer has an unfolding in the future.  But then you'll get a helpful
error message suggesting an INLINABLE pragma, which you can follow.
That seems enough for now.
-}