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

-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}

module TcSigs(
       TcSigInfo(..),
       TcIdSigInfo(..), TcIdSigInst,
       TcPatSynInfo(..),
       TcSigFun,

       isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,
       completeSigPolyId_maybe,

       tcTySigs, tcUserTypeSig, completeSigFromId,
       tcInstSig,

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

#include "HsVersions.h"

import GhcPrelude

import HsSyn
import TcHsType
import TcRnTypes
import TcRnMonad
import TcType
import TcMType
import TcValidity ( checkValidType )
import TcUnify( tcSkolemise, unifyType )
import Inst( topInstantiate )
import TcEnv( tcLookupId )
import TcEvidence( HsWrapper, (<.>) )
import Type( mkTyVarBinders )

import DynFlags
import Var      ( TyVar, tyVarKind )
import Id       ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )
import PrelNames( mkUnboundName )
import BasicTypes
import Bag( foldrBag )
import Module( getModule )
import Name
import NameEnv
import Outputable
import SrcLoc
import Util( singleton )
import Maybes( orElse )
import Data.Maybe( mapMaybe )
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 TcBinds.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, raather
  than somehow quantifying over them.  And the "TcLevel" of those
  unification variables is correct because we are in tcMonoBinds.


Note [Scoped tyvars]
~~~~~~~~~~~~~~~~~~~~
The -XScopedTypeVariables flag brings lexically-scoped type variables
into scope for any explicitly forall-quantified type variables:
        f :: forall a. a -> a
        f x = e
Then 'a' is in scope inside 'e'.

However, we do *not* support this
  - For pattern bindings e.g
        f :: forall a. a->a
        (f,g) = e

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 *inital* 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     idsi :: TcIdSigInfo
idsi) = TcIdSigInfo -> Name
tcIdSigName TcIdSigInfo
idsi
tcSigInfoName (TcPatSynSig tpsi :: TcPatSynInfo
tpsi) = TcPatSynInfo -> Name
patsig_name TcPatSynInfo
tpsi

completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
completeSigPolyId_maybe sig :: TcSigInfo
sig
  | TcIdSig sig_info :: 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 hs_sigs :: [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
$   -- See Note [Fail eagerly on bad signatures]
    do { [[TcSigInfo]]
ty_sigs_s <- (LSig GhcRn -> TcRn [TcSigInfo])
-> [LSig GhcRn] -> TcRn [[TcSigInfo]]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM LSig GhcRn -> TcRn [TcSigInfo]
tcTySig [LSig 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 (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 _ (IdSig _ id :: TcId
id))
  = do { let ctxt :: UserTypeCtxt
ctxt = Name -> Bool -> UserTypeCtxt
FunSigCtxt (TcId -> Name
idName TcId
id) Bool
False
                    -- False: 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 (m :: * -> *) a. Monad m => a -> m a
return [TcIdSigInfo -> TcSigInfo
TcIdSig TcIdSigInfo
sig] }

tcTySig (L loc :: SrcSpan
loc (TypeSig _ names :: [Located (IdP GhcRn)]
names sig_ty :: LHsSigWcType GhcRn
sig_ty))
  = SrcSpan -> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
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)
sequence [ SrcSpan
-> LHsSigWcType GhcRn
-> Maybe Name
-> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType GhcRn
sig_ty (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name)
                          | L _ name :: Name
name <- [GenLocated SrcSpan Name]
[Located (IdP GhcRn)]
names ]
       ; [TcSigInfo] -> TcRn [TcSigInfo]
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 loc :: SrcSpan
loc (PatSynSig _ names :: [Located (IdP GhcRn)]
names sig_ty :: LHsSigType GhcRn
sig_ty))
  = SrcSpan -> TcRn [TcSigInfo] -> TcRn [TcSigInfo]
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
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)
sequence [ Name
-> LHsSigType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo
tcPatSynSig Name
name LHsSigType GhcRn
sig_ty
                            | L _ name :: Name
name <- [GenLocated SrcSpan Name]
[Located (IdP GhcRn)]
names ]
       ; [TcSigInfo] -> TcRn [TcSigInfo]
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 _ = [TcSigInfo] -> TcRn [TcSigInfo]
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 loc :: SrcSpan
loc hs_sig_ty :: LHsSigWcType GhcRn
hs_sig_ty mb_name :: Maybe Name
mb_name
  | LHsSigWcType GhcRn -> Bool
isCompleteHsSig LHsSigWcType GhcRn
hs_sig_ty
  = do { Type
sigma_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
tcHsSigWcType UserTypeCtxt
ctxt_F LHsSigWcType GhcRn
hs_sig_ty
       ; TcIdSigInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcIdSigInfo
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 :: TcId -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
CompleteSig { sig_bndr :: TcId
sig_bndr  = Name -> Type -> TcId
mkLocalId Name
name Type
sigma_ty
                     , sig_ctxt :: UserTypeCtxt
sig_ctxt  = UserTypeCtxt
ctxt_T
                     , 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 (m :: * -> *) a. Monad m => a -> m a
return (PartialSig :: Name
-> LHsSigWcType GhcRn -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
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_F, sig_loc :: SrcSpan
sig_loc = SrcSpan
loc })
  where
    name :: Name
name   = case Maybe Name
mb_name of
               Just n :: Name
n  -> Name
n
               Nothing -> OccName -> Name
mkUnboundName (String -> OccName
mkVarOcc "<expression>")
    ctxt_F :: UserTypeCtxt
ctxt_F = case Maybe Name
mb_name of
               Just n :: Name
n  -> Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
n Bool
False
               Nothing -> UserTypeCtxt
ExprSigCtxt
    ctxt_T :: UserTypeCtxt
ctxt_T = case Maybe Name
mb_name of
               Just n :: Name
n  -> Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
n Bool
True
               Nothing -> UserTypeCtxt
ExprSigCtxt



completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo
-- Used for instance methods and record selectors
completeSigFromId :: UserTypeCtxt -> TcId -> TcIdSigInfo
completeSigFromId ctxt :: UserTypeCtxt
ctxt id :: TcId
id
  = CompleteSig :: TcId -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
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 LHsSigType
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 = HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = LHsType GhcRn
hs_ty } })
   = [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
XHsWC GhcRn (LHsSigType GhcRn)
wcs Bool -> Bool -> Bool
&& LHsType GhcRn -> Bool
no_anon_wc LHsType GhcRn
hs_ty
isCompleteHsSig (HsWC _ (XHsImplicitBndrs _)) = String -> Bool
forall a. String -> a
panic "isCompleteHsSig"
isCompleteHsSig (XHsWildCardBndrs _) = String -> Bool
forall a. String -> a
panic "isCompleteHsSig"

no_anon_wc :: LHsType GhcRn -> Bool
no_anon_wc :: LHsType GhcRn -> Bool
no_anon_wc lty :: LHsType GhcRn
lty = LHsType GhcRn -> Bool
go LHsType GhcRn
lty
  where
    go :: LHsType GhcRn -> Bool
go (L _ ty :: HsType GhcRn
ty) = case HsType GhcRn
ty of
      HsWildCardTy _                 -> Bool
False
      HsAppTy _ ty1 :: LHsType GhcRn
ty1 ty2 :: LHsType GhcRn
ty2              -> LHsType GhcRn -> Bool
go LHsType GhcRn
ty1 Bool -> Bool -> Bool
&& LHsType GhcRn -> Bool
go LHsType GhcRn
ty2
      HsAppKindTy _ ty :: LHsType GhcRn
ty ki :: LHsType GhcRn
ki            -> LHsType GhcRn -> Bool
go LHsType GhcRn
ty Bool -> Bool -> Bool
&& LHsType GhcRn -> Bool
go LHsType GhcRn
ki
      HsFunTy _ ty1 :: LHsType GhcRn
ty1 ty2 :: LHsType GhcRn
ty2              -> LHsType GhcRn -> Bool
go LHsType GhcRn
ty1 Bool -> Bool -> Bool
&& LHsType GhcRn -> Bool
go LHsType GhcRn
ty2
      HsListTy _ ty :: LHsType GhcRn
ty                  -> LHsType GhcRn -> Bool
go LHsType GhcRn
ty
      HsTupleTy _ _ tys :: [LHsType GhcRn]
tys              -> [LHsType GhcRn] -> Bool
gos [LHsType GhcRn]
tys
      HsSumTy _ tys :: [LHsType GhcRn]
tys                  -> [LHsType GhcRn] -> Bool
gos [LHsType GhcRn]
tys
      HsOpTy _ ty1 :: LHsType GhcRn
ty1 _ ty2 :: LHsType GhcRn
ty2             -> LHsType GhcRn -> Bool
go LHsType GhcRn
ty1 Bool -> Bool -> Bool
&& LHsType GhcRn -> Bool
go LHsType GhcRn
ty2
      HsParTy _ ty :: LHsType GhcRn
ty                   -> LHsType GhcRn -> Bool
go LHsType GhcRn
ty
      HsIParamTy _ _ ty :: LHsType GhcRn
ty              -> LHsType GhcRn -> Bool
go LHsType GhcRn
ty
      HsKindSig _ ty :: LHsType GhcRn
ty kind :: LHsType GhcRn
kind            -> LHsType GhcRn -> Bool
go LHsType GhcRn
ty Bool -> Bool -> Bool
&& LHsType GhcRn -> Bool
go LHsType GhcRn
kind
      HsDocTy _ ty :: LHsType GhcRn
ty _                 -> LHsType GhcRn -> Bool
go LHsType GhcRn
ty
      HsBangTy _ _ ty :: LHsType GhcRn
ty                -> LHsType GhcRn -> Bool
go LHsType GhcRn
ty
      HsRecTy _ flds :: [LConDeclField GhcRn]
flds                 -> [LHsType GhcRn] -> Bool
gos ([LHsType GhcRn] -> Bool) -> [LHsType GhcRn] -> Bool
forall a b. (a -> b) -> a -> b
$ (LConDeclField GhcRn -> LHsType GhcRn)
-> [LConDeclField GhcRn] -> [LHsType GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map (ConDeclField GhcRn -> LHsType GhcRn
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcRn -> LHsType GhcRn)
-> (LConDeclField GhcRn -> ConDeclField GhcRn)
-> LConDeclField GhcRn
-> LHsType GhcRn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LConDeclField GhcRn -> ConDeclField GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LConDeclField GhcRn]
flds
      HsExplicitListTy _ _ tys :: [LHsType GhcRn]
tys       -> [LHsType GhcRn] -> Bool
gos [LHsType GhcRn]
tys
      HsExplicitTupleTy _ tys :: [LHsType GhcRn]
tys        -> [LHsType GhcRn] -> Bool
gos [LHsType GhcRn]
tys
      HsForAllTy { hst_bndrs :: forall pass. HsType pass -> [LHsTyVarBndr pass]
hst_bndrs = [LHsTyVarBndr GhcRn]
bndrs
                 , hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
ty } -> [LHsTyVarBndr GhcRn] -> Bool
no_anon_wc_bndrs [LHsTyVarBndr GhcRn]
bndrs
                                        Bool -> Bool -> Bool
&& LHsType GhcRn -> Bool
go LHsType GhcRn
ty
      HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = L _ ctxt :: [LHsType GhcRn]
ctxt
               , hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
ty }  -> [LHsType GhcRn] -> Bool
gos [LHsType GhcRn]
ctxt Bool -> Bool -> Bool
&& LHsType GhcRn -> Bool
go LHsType GhcRn
ty
      HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty :: HsType GhcRn
ty)) -> LHsType GhcRn -> Bool
go (LHsType GhcRn -> Bool) -> LHsType GhcRn -> Bool
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsType GhcRn -> LHsType GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
noSrcSpan HsType GhcRn
ty
      HsSpliceTy{} -> Bool
True
      HsTyLit{} -> Bool
True
      HsTyVar{} -> Bool
True
      HsStarTy{} -> Bool
True
      XHsType{} -> Bool
True      -- Core type, which does not have any wildcard

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

no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool
no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool
no_anon_wc_bndrs ltvs :: [LHsTyVarBndr GhcRn]
ltvs = (LHsTyVarBndr GhcRn -> Bool) -> [LHsTyVarBndr GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (HsTyVarBndr GhcRn -> Bool
go (HsTyVarBndr GhcRn -> Bool)
-> (LHsTyVarBndr GhcRn -> HsTyVarBndr GhcRn)
-> LHsTyVarBndr GhcRn
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsTyVarBndr GhcRn -> HsTyVarBndr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LHsTyVarBndr GhcRn]
ltvs
  where
    go :: HsTyVarBndr GhcRn -> Bool
go (UserTyVar _ _)      = Bool
True
    go (KindedTyVar _ _ ki :: LHsType GhcRn
ki) = LHsType GhcRn -> Bool
no_anon_wc LHsType GhcRn
ki
    go (XTyVarBndr{})       = String -> Bool
forall a. String -> a
panic "no_anon_wc_bndrs"

{- 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 type sig
is wrong (eg at the top level of the module),
which is over-conservative
-}

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

Note [Pattern synonym signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Pattern synonym signatures are surprisingly tricky (see Trac #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 [solveEqualities 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 TcPatSyn.tc_patsyn_finish, and that
fails if there are un-filled-in coercion variables mentioned
in the type (Trac #15694).

The best thing is simply to use solveEqualities to solve all the
equalites, 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.

(NB: this solveEqualities wraps newImplicitTKBndrs, which itself
does a solveLocalEqualities; so solveEqualities isn't going to
make any further progress; it'll just report any unsolved ones,
and fail, as it should.)
-}

tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo
-- See Note [Pattern synonym signatures]
-- See Note [Recipe for checking a signature] in TcHsType
tcPatSynSig :: Name
-> LHsSigType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo
tcPatSynSig name :: Name
name sig_ty :: LHsSigType GhcRn
sig_ty
  | HsIB { hsib_ext :: forall pass thing. HsImplicitBndrs pass thing -> XHsIB pass thing
hsib_ext = XHsIB GhcRn (LHsType GhcRn)
implicit_hs_tvs
         , hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = LHsType GhcRn
hs_ty }  <- LHsSigType GhcRn
sig_ty
  , (univ_hs_tvs :: [LHsTyVarBndr GhcRn]
univ_hs_tvs, hs_req :: GenLocated SrcSpan [LHsType GhcRn]
hs_req,  hs_ty1 :: LHsType GhcRn
hs_ty1)     <- LHsType GhcRn
-> ([LHsTyVarBndr GhcRn], GenLocated SrcSpan [LHsType GhcRn],
    LHsType GhcRn)
forall pass.
LHsType pass
-> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
splitLHsSigmaTy LHsType GhcRn
hs_ty
  , (ex_hs_tvs :: [LHsTyVarBndr GhcRn]
ex_hs_tvs,   hs_prov :: GenLocated SrcSpan [LHsType GhcRn]
hs_prov, hs_body_ty :: LHsType GhcRn
hs_body_ty) <- LHsType GhcRn
-> ([LHsTyVarBndr GhcRn], GenLocated SrcSpan [LHsType GhcRn],
    LHsType GhcRn)
forall pass.
LHsType pass
-> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)
splitLHsSigmaTy LHsType GhcRn
hs_ty1
  = do {  String -> SDoc -> TcRn ()
traceTc "tcPatSynSig 1" (LHsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
sig_ty)
       ; (implicit_tvs :: [TcId]
implicit_tvs, (univ_tvs :: [TcId]
univ_tvs, (ex_tvs :: [TcId]
ex_tvs, (req :: [Type]
req, prov :: [Type]
prov, body_ty :: Type
body_ty))))
           <- TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
-> TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
forall r. TcM r -> TcM r
pushTcLevelM_   (TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
 -> TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type)))))
-> TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
-> TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
forall a b. (a -> b) -> a -> b
$
              TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
-> TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
forall r. TcM r -> TcM r
solveEqualities (TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
 -> TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type)))))
-> TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
-> TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
forall a b. (a -> b) -> a -> b
$ -- See Note [solveEqualities in tcPatSynSig]
              [Name]
-> TcM ([TcId], ([TcId], ([Type], [Type], Type)))
-> TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
forall a. [Name] -> TcM a -> TcM ([TcId], a)
bindImplicitTKBndrs_Skol [Name]
XHsIB GhcRn (LHsType GhcRn)
implicit_hs_tvs (TcM ([TcId], ([TcId], ([Type], [Type], Type)))
 -> TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type)))))
-> TcM ([TcId], ([TcId], ([Type], [Type], Type)))
-> TcM ([TcId], ([TcId], ([TcId], ([Type], [Type], Type))))
forall a b. (a -> b) -> a -> b
$
              [LHsTyVarBndr GhcRn]
-> TcM ([TcId], ([Type], [Type], Type))
-> TcM ([TcId], ([TcId], ([Type], [Type], Type)))
forall a. [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcId], a)
bindExplicitTKBndrs_Skol [LHsTyVarBndr GhcRn]
univ_hs_tvs     (TcM ([TcId], ([Type], [Type], Type))
 -> TcM ([TcId], ([TcId], ([Type], [Type], Type))))
-> TcM ([TcId], ([Type], [Type], Type))
-> TcM ([TcId], ([TcId], ([Type], [Type], Type)))
forall a b. (a -> b) -> a -> b
$
              [LHsTyVarBndr GhcRn]
-> TcM ([Type], [Type], Type)
-> TcM ([TcId], ([Type], [Type], Type))
forall a. [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcId], a)
bindExplicitTKBndrs_Skol [LHsTyVarBndr GhcRn]
ex_hs_tvs       (TcM ([Type], [Type], Type)
 -> TcM ([TcId], ([Type], [Type], Type)))
-> TcM ([Type], [Type], Type)
-> TcM ([TcId], ([Type], [Type], Type))
forall a b. (a -> b) -> a -> b
$
              do { [Type]
req     <- GenLocated SrcSpan [LHsType GhcRn] -> TcM [Type]
tcHsContext GenLocated SrcSpan [LHsType GhcRn]
hs_req
                 ; [Type]
prov    <- GenLocated SrcSpan [LHsType GhcRn] -> TcM [Type]
tcHsContext GenLocated SrcSpan [LHsType GhcRn]
hs_prov
                 ; Type
body_ty <- LHsType GhcRn -> TcM Type
tcHsOpenType LHsType GhcRn
hs_body_ty
                     -- A (literal) pattern can be unlifted;
                     -- e.g. pattern Zero <- 0#   (Trac #12094)
                 ; ([Type], [Type], Type) -> TcM ([Type], [Type], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
req, [Type]
prov, Type
body_ty) }

       ; let ungen_patsyn_ty :: Type
ungen_patsyn_ty = [TcId]
-> [TcId] -> [TcId] -> [Type] -> [TcId] -> [Type] -> Type -> Type
build_patsyn_type [] [TcId]
implicit_tvs [TcId]
univ_tvs [Type]
req
                                                 [TcId]
ex_tvs [Type]
prov Type
body_ty

       -- Kind generalisation
       ; [TcId]
kvs <- Type -> TcM [TcId]
kindGeneralize Type
ungen_patsyn_ty
       ; String -> SDoc -> TcRn ()
traceTc "tcPatSynSig" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ungen_patsyn_ty)

       -- These are /signatures/ so we zonk to squeeze out any kind
       -- unification variables.  Do this after kindGeneralize which may
       -- default kind variables to *.
       ; [TcId]
implicit_tvs <- [TcId] -> TcM [TcId]
zonkAndScopedSort [TcId]
implicit_tvs
       ; [TcId]
univ_tvs     <- (TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId)
-> [TcId] -> TcM [TcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
zonkTyCoVarKind [TcId]
univ_tvs
       ; [TcId]
ex_tvs       <- (TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId)
-> [TcId] -> TcM [TcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TcId -> IOEnv (Env TcGblEnv TcLclEnv) TcId
zonkTyCoVarKind [TcId]
ex_tvs
       ; [Type]
req          <- [Type] -> TcM [Type]
zonkTcTypes [Type]
req
       ; [Type]
prov         <- [Type] -> TcM [Type]
zonkTcTypes [Type]
prov
       ; Type
body_ty      <- Type -> TcM Type
zonkTcType  Type
body_ty

       -- Skolems have TcLevels too, though they're used only for debugging.
       -- If you don't do this, the debugging checks fail in TcPatSyn.
       -- Test case: patsyn/should_compile/T13441
{-
       ; tclvl <- getTcLevel
       ; let env0                  = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs
             (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs
             (env2, univ_tvs')     = promoteSkolemsX tclvl env1 univ_tvs
             (env3, ex_tvs')       = promoteSkolemsX tclvl env2 ex_tvs
             req'                  = substTys env3 req
             prov'                 = substTys env3 prov
             body_ty'              = substTy  env3 body_ty
-}
      ; let implicit_tvs' :: [TcId]
implicit_tvs' = [TcId]
implicit_tvs
            univ_tvs' :: [TcId]
univ_tvs'     = [TcId]
univ_tvs
            ex_tvs' :: [TcId]
ex_tvs'       = [TcId]
ex_tvs
            req' :: [Type]
req'          = [Type]
req
            prov' :: [Type]
prov'         = [Type]
prov
            body_ty' :: Type
body_ty'      = Type
body_ty

       -- Now do validity checking
       ; UserTypeCtxt -> Type -> TcRn ()
checkValidType UserTypeCtxt
ctxt (Type -> TcRn ()) -> Type -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [TcId]
-> [TcId] -> [TcId] -> [Type] -> [TcId] -> [Type] -> Type -> Type
build_patsyn_type [TcId]
kvs [TcId]
implicit_tvs' [TcId]
univ_tvs' [Type]
req' [TcId]
ex_tvs' [Type]
prov' Type
body_ty'

       -- arguments become the types of binders. We thus cannot allow
       -- levity polymorphism here
       ; let (arg_tys :: [Type]
arg_tys, _) = Type -> ([Type], Type)
tcSplitFunTys Type
body_ty'
       ; (Type -> TcRn ()) -> [Type] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> Type -> TcRn ()
checkForLevPoly SDoc
empty) [Type]
arg_tys

       ; String -> SDoc -> TcRn ()
traceTc "tcTySig }" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
vcat [ String -> SDoc
text "implicit_tvs" SDoc -> SDoc -> SDoc
<+> [TcId] -> SDoc
ppr_tvs [TcId]
implicit_tvs'
              , String -> SDoc
text "kvs" SDoc -> SDoc -> SDoc
<+> [TcId] -> SDoc
ppr_tvs [TcId]
kvs
              , String -> SDoc
text "univ_tvs" SDoc -> SDoc -> SDoc
<+> [TcId] -> SDoc
ppr_tvs [TcId]
univ_tvs'
              , String -> SDoc
text "req" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
req'
              , String -> SDoc
text "ex_tvs" SDoc -> SDoc -> SDoc
<+> [TcId] -> SDoc
ppr_tvs [TcId]
ex_tvs'
              , String -> SDoc
text "prov" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
prov'
              , String -> SDoc
text "body_ty" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_ty' ]
       ; TcPatSynInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (TPSI :: Name
-> [TyVarBinder]
-> [TcId]
-> [Type]
-> [TcId]
-> [Type]
-> Type
-> TcPatSynInfo
TPSI { patsig_name :: Name
patsig_name = Name
name
                      , patsig_implicit_bndrs :: [TyVarBinder]
patsig_implicit_bndrs = ArgFlag -> [TcId] -> [TyVarBinder]
mkTyVarBinders ArgFlag
Inferred  [TcId]
kvs [TyVarBinder] -> [TyVarBinder] -> [TyVarBinder]
forall a. [a] -> [a] -> [a]
++
                                                ArgFlag -> [TcId] -> [TyVarBinder]
mkTyVarBinders ArgFlag
Specified [TcId]
implicit_tvs'
                      , patsig_univ_bndrs :: [TcId]
patsig_univ_bndrs     = [TcId]
univ_tvs'
                      , patsig_req :: [Type]
patsig_req            = [Type]
req'
                      , patsig_ex_bndrs :: [TcId]
patsig_ex_bndrs       = [TcId]
ex_tvs'
                      , patsig_prov :: [Type]
patsig_prov           = [Type]
prov'
                      , patsig_body_ty :: Type
patsig_body_ty        = Type
body_ty' }) }
  where
    ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
PatSynCtxt Name
name

    build_patsyn_type :: [TcId]
-> [TcId] -> [TcId] -> [Type] -> [TcId] -> [Type] -> Type -> Type
build_patsyn_type kvs :: [TcId]
kvs imp :: [TcId]
imp univ :: [TcId]
univ req :: [Type]
req ex :: [TcId]
ex prov :: [Type]
prov body :: Type
body
      = [TcId] -> Type -> Type
mkInvForAllTys [TcId]
kvs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
        [TcId] -> Type -> Type
mkSpecForAllTys ([TcId]
imp [TcId] -> [TcId] -> [TcId]
forall a. [a] -> [a] -> [a]
++ [TcId]
univ) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
        [Type] -> Type -> Type
mkFunTys [Type]
req (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
        [TcId] -> Type -> Type
mkSpecForAllTys [TcId]
ex (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
        [Type] -> Type -> Type
mkFunTys [Type]
prov (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
        Type
body
tcPatSynSig _ (XHsImplicitBndrs _) = String -> IOEnv (Env TcGblEnv TcLclEnv) TcPatSynInfo
forall a. String -> a
panic "tcPatSynSig"

ppr_tvs :: [TyVar] -> SDoc
ppr_tvs :: [TcId] -> SDoc
ppr_tvs tvs :: [TcId]
tvs = SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat [ TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
tv SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcId -> Type
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 { (tv_prs :: [(Name, TcId)]
tv_prs, theta :: [Type]
theta, tau :: Type
tau) <- ([TcId] -> TcM (TCvSubst, [TcId]))
-> TcId -> TcM ([(Name, TcId)], [Type], Type)
tcInstType [TcId] -> TcM (TCvSubst, [TcId])
newMetaTyVarTyVars TcId
poly_id
              -- See Note [Pattern bindings and complete signatures]

       ; TcIdSigInst -> TcM TcIdSigInst
forall (m :: * -> *) a. Monad m => a -> m a
return (TISI :: TcIdSigInfo
-> [(Name, TcId)]
-> [Type]
-> Type
-> [(Name, TcId)]
-> Maybe Type
-> TcIdSigInst
TISI { sig_inst_sig :: TcIdSigInfo
sig_inst_sig   = TcIdSigInfo
sig
                      , sig_inst_skols :: [(Name, TcId)]
sig_inst_skols = [(Name, TcId)]
tv_prs
                      , sig_inst_wcs :: [(Name, TcId)]
sig_inst_wcs   = []
                      , sig_inst_wcx :: Maybe Type
sig_inst_wcx   = Maybe Type
forall a. Maybe a
Nothing
                      , sig_inst_theta :: [Type]
sig_inst_theta = [Type]
theta
                      , sig_inst_tau :: Type
sig_inst_tau   = Type
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 "Staring partial sig {" (TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
hs_sig)
       ; (wcs :: [(Name, TcId)]
wcs, wcx :: Maybe Type
wcx, tv_names :: [Name]
tv_names, tvs :: [TcId]
tvs, theta :: [Type]
theta, tau :: Type
tau) <- UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM ([(Name, TcId)], Maybe Type, [Name], [TcId], [Type], Type)
tcHsPartialSigType UserTypeCtxt
ctxt LHsSigWcType GhcRn
hs_ty

        -- Clone the quantified tyvars
        -- Reason: we might have    f, g :: forall a. a -> _ -> a
        --         and we want it to behave exactly as if there were
        --         two separate signatures.  Cloning here seems like
        --         the easiest way to do so, and is very similar to
        --         the tcInstType in the CompleteSig case
        -- See Trac #14643
       ; (subst :: TCvSubst
subst, tvs' :: [TcId]
tvs') <- [TcId] -> TcM (TCvSubst, [TcId])
newMetaTyVarTyVars [TcId]
tvs
                         -- Why newMetaTyVarTyVars?  See TcBinds
                         -- Note [Quantified variables in partial type signatures]
       ; let tv_prs :: [(Name, TcId)]
tv_prs = [Name]
tv_names [Name] -> [TcId] -> [(Name, TcId)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcId]
tvs'
             inst_sig :: TcIdSigInst
inst_sig = TISI :: TcIdSigInfo
-> [(Name, TcId)]
-> [Type]
-> Type
-> [(Name, TcId)]
-> Maybe Type
-> TcIdSigInst
TISI { sig_inst_sig :: TcIdSigInfo
sig_inst_sig   = TcIdSigInfo
hs_sig
                             , sig_inst_skols :: [(Name, TcId)]
sig_inst_skols = [(Name, TcId)]
tv_prs
                             , sig_inst_wcs :: [(Name, TcId)]
sig_inst_wcs   = [(Name, TcId)]
wcs
                             , sig_inst_wcx :: Maybe Type
sig_inst_wcx   = Maybe Type
wcx
                             , sig_inst_theta :: [Type]
sig_inst_theta = HasCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst [Type]
theta
                             , sig_inst_tau :: Type
sig_inst_tau   = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy  TCvSubst
subst Type
tau }
       ; String -> SDoc -> TcRn ()
traceTc "End partial sig }" (TcIdSigInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInst
inst_sig)
       ; TcIdSigInst -> TcM TcIdSigInst
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 TcBinds.mkExport

See Note [Signature skolems] in TcType

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

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

type TcPragEnv = NameEnv [LSig GhcRn]

emptyPragEnv :: TcPragEnv
emptyPragEnv :: TcPragEnv
emptyPragEnv = TcPragEnv
forall a. NameEnv a
emptyNameEnv

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

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

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

    get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
    get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
get_sig (L l :: SrcSpan
l (SpecSig x :: XSpecSig GhcRn
x lnm :: Located (IdP GhcRn)
lnm@(L _ nm :: IdP GhcRn
nm) ty :: [LHsSigType GhcRn]
ty inl :: InlinePragma
inl))
      = (Name, LSig GhcRn) -> Maybe (Name, LSig GhcRn)
forall a. a -> Maybe a
Just (Name
IdP GhcRn
nm, SrcSpan -> Sig GhcRn -> LSig GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Sig GhcRn -> LSig GhcRn) -> Sig GhcRn -> LSig GhcRn
forall a b. (a -> b) -> a -> b
$ XSpecSig GhcRn
-> Located (IdP GhcRn)
-> [LHsSigType GhcRn]
-> InlinePragma
-> Sig GhcRn
forall pass.
XSpecSig pass
-> Located (IdP pass)
-> [LHsSigType pass]
-> InlinePragma
-> Sig pass
SpecSig   XSpecSig GhcRn
x Located (IdP GhcRn)
lnm [LHsSigType GhcRn]
ty (Name -> InlinePragma -> InlinePragma
add_arity Name
IdP GhcRn
nm InlinePragma
inl))
    get_sig (L l :: SrcSpan
l (InlineSig x :: XInlineSig GhcRn
x lnm :: Located (IdP GhcRn)
lnm@(L _ nm :: IdP GhcRn
nm) inl :: InlinePragma
inl))
      = (Name, LSig GhcRn) -> Maybe (Name, LSig GhcRn)
forall a. a -> Maybe a
Just (Name
IdP GhcRn
nm, SrcSpan -> Sig GhcRn -> LSig GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Sig GhcRn -> LSig GhcRn) -> Sig GhcRn -> LSig GhcRn
forall a b. (a -> b) -> a -> b
$ XInlineSig GhcRn
-> Located (IdP GhcRn) -> InlinePragma -> Sig GhcRn
forall pass.
XInlineSig pass -> Located (IdP pass) -> InlinePragma -> Sig pass
InlineSig XInlineSig GhcRn
x Located (IdP GhcRn)
lnm    (Name -> InlinePragma -> InlinePragma
add_arity Name
IdP GhcRn
nm InlinePragma
inl))
    get_sig (L l :: SrcSpan
l (SCCFunSig x :: XSCCFunSig GhcRn
x st :: SourceText
st lnm :: Located (IdP GhcRn)
lnm@(L _ nm :: IdP GhcRn
nm) str :: Maybe (Located StringLiteral)
str))
      = (Name, LSig GhcRn) -> Maybe (Name, LSig GhcRn)
forall a. a -> Maybe a
Just (Name
IdP GhcRn
nm, SrcSpan -> Sig GhcRn -> LSig GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Sig GhcRn -> LSig GhcRn) -> Sig GhcRn -> LSig GhcRn
forall a b. (a -> b) -> a -> b
$ XSCCFunSig GhcRn
-> SourceText
-> Located (IdP GhcRn)
-> Maybe (Located StringLiteral)
-> Sig GhcRn
forall pass.
XSCCFunSig pass
-> SourceText
-> Located (IdP pass)
-> Maybe (Located StringLiteral)
-> Sig pass
SCCFunSig XSCCFunSig GhcRn
x SourceText
st Located (IdP GhcRn)
lnm Maybe (Located StringLiteral)
str)
    get_sig _ = Maybe (Name, LSig GhcRn)
forall a. Maybe a
Nothing

    add_arity :: Name -> InlinePragma -> InlinePragma
add_arity n :: Name
n inl_prag :: InlinePragma
inl_prag   -- Adjust inl_sat field to match visible arity of function
      | InlineSpec
Inline <- InlinePragma -> InlineSpec
inl_inline InlinePragma
inl_prag
        -- add arity only for real INLINE pragmas, not INLINABLE
      = case NameEnv Arity -> Name -> Maybe Arity
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Arity
ar_env Name
n of
          Just ar :: Arity
ar -> InlinePragma
inl_prag { inl_sat :: Maybe Arity
inl_sat = Arity -> Maybe Arity
forall a. a -> Maybe a
Just Arity
ar }
          Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n )
                     -- There really should be a binding for every INLINE pragma
                     InlinePragma
inl_prag
      | Bool
otherwise
      = InlinePragma
inl_prag

    -- ar_env maps a local to the arity of its definition
    ar_env :: NameEnv Arity
    ar_env :: NameEnv Arity
ar_env = (LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity)
-> NameEnv Arity -> LHsBinds GhcRn -> NameEnv Arity
forall a r. (a -> r -> r) -> r -> Bag a -> r
foldrBag LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity NameEnv Arity
forall a. NameEnv a
emptyNameEnv LHsBinds GhcRn
binds

lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
lhsBindArity (L _ (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = Located (IdP GhcRn)
id, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcRn (LHsExpr GhcRn)
ms })) env :: NameEnv Arity
env
  = NameEnv Arity -> Name -> Arity -> NameEnv Arity
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv Arity
env (GenLocated SrcSpan Name -> SrcSpanLess (GenLocated SrcSpan Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc GenLocated SrcSpan Name
Located (IdP GhcRn)
id) (MatchGroup GhcRn (LHsExpr GhcRn) -> Arity
forall id body. MatchGroup id body -> Arity
matchGroupArity MatchGroup GhcRn (LHsExpr GhcRn)
ms)
lhsBindArity _ env :: NameEnv Arity
env = NameEnv Arity
env        -- PatBind/VarBind


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

    warn_multiple_inlines :: GenLocated SrcSpan InlinePragma
-> [GenLocated SrcSpan InlinePragma] -> TcRn ()
warn_multiple_inlines _ [] = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    warn_multiple_inlines inl1 :: GenLocated SrcSpan InlinePragma
inl1@(L loc :: SrcSpan
loc prag1 :: InlinePragma
prag1) (inl2 :: GenLocated SrcSpan InlinePragma
inl2@(L _ prag2 :: InlinePragma
prag2) : inls :: [GenLocated SrcSpan 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 SrcSpan InlinePragma
-> [GenLocated SrcSpan InlinePragma] -> TcRn ()
warn_multiple_inlines GenLocated SrcSpan InlinePragma
inl2 [GenLocated SrcSpan InlinePragma]
inls
       | Bool
otherwise
       = SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason
                     (SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text "Multiple INLINE pragmas for" SDoc -> SDoc -> SDoc
<+> TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id)
                       2 ([SDoc] -> SDoc
vcat (String -> SDoc
text "Ignoring all but the first"
                                SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (GenLocated SrcSpan InlinePragma -> SDoc)
-> [GenLocated SrcSpan InlinePragma] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan InlinePragma -> SDoc
forall a a. (Outputable a, Outputable a) => GenLocated a a -> SDoc
pp_inl (GenLocated SrcSpan InlinePragma
inl1GenLocated SrcSpan InlinePragma
-> [GenLocated SrcSpan InlinePragma]
-> [GenLocated SrcSpan InlinePragma]
forall a. a -> [a] -> [a]
:GenLocated SrcSpan InlinePragma
inl2GenLocated SrcSpan InlinePragma
-> [GenLocated SrcSpan InlinePragma]
-> [GenLocated SrcSpan InlinePragma]
forall a. a -> [a] -> [a]
:[GenLocated SrcSpan InlinePragma]
inls))))

    pp_inl :: GenLocated a a -> SDoc
pp_inl (L loc :: a
loc prag :: a
prag) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
prag SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
loc)


{- *********************************************************************
*                                                                      *
                   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 DsBinds 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. We don't use full-on tcSubType, because that does co and contra
   variance and that in turn will generate too complex a LHS for the
   RULE.  So we use a single invocation of skolemise /
   topInstantiate in tcSpecWrapper.  (Actually I think that even
   the "deeply" stuff may be too much, because it introduces lambdas,
   though I think it can be made to work without too much trouble.)

2. We need to take care with type families (Trac #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
      skolemiseation) 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

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 TcInstDcls.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 poly_id :: TcId
poly_id prag_sigs :: [LSig GhcRn]
prag_sigs
  = do { String -> SDoc -> TcRn ()
traceTc "tcSpecPrags" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
<+> [LSig GhcRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LSig GhcRn]
spec_sigs)
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([LSig GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LSig GhcRn]
bad_sigs) TcRn ()
warn_discarded_sigs
       ; [GenLocated SrcSpan [TcSpecPrag]]
pss <- (LSig GhcRn -> TcRn (GenLocated SrcSpan [TcSpecPrag]))
-> [LSig GhcRn] -> TcRn [GenLocated SrcSpan [TcSpecPrag]]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM ((SrcSpanLess (LSig GhcRn)
 -> TcM (SrcSpanLess (GenLocated SrcSpan [TcSpecPrag])))
-> LSig GhcRn -> TcRn (GenLocated SrcSpan [TcSpecPrag])
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
wrapLocM (TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag TcId
poly_id)) [LSig GhcRn]
spec_sigs
       ; [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LTcSpecPrag] -> TcM [LTcSpecPrag])
-> [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpan [TcSpecPrag] -> [LTcSpecPrag])
-> [GenLocated SrcSpan [TcSpecPrag]] -> [LTcSpecPrag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(L l :: SrcSpan
l ps :: [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 SrcSpan
l) [TcSpecPrag]
ps) [GenLocated SrcSpan [TcSpecPrag]]
pss }
  where
    spec_sigs :: [LSig GhcRn]
spec_sigs = (LSig GhcRn -> Bool) -> [LSig GhcRn] -> [LSig GhcRn]
forall a. (a -> Bool) -> [a] -> [a]
filter LSig GhcRn -> Bool
forall name. LSig name -> Bool
isSpecLSig [LSig GhcRn]
prag_sigs
    bad_sigs :: [LSig GhcRn]
bad_sigs  = (LSig GhcRn -> Bool) -> [LSig GhcRn] -> [LSig GhcRn]
forall a. (a -> Bool) -> [a] -> [a]
filter LSig GhcRn -> Bool
forall name. LSig name -> Bool
is_bad_sig [LSig GhcRn]
prag_sigs
    is_bad_sig :: LSig name -> Bool
is_bad_sig s :: LSig name
s = Bool -> Bool
not (LSig name -> Bool
forall name. LSig name -> Bool
isSpecLSig LSig name
s Bool -> Bool -> Bool
|| LSig name -> Bool
forall name. LSig name -> Bool
isInlineLSig LSig name
s Bool -> Bool -> Bool
|| LSig name -> Bool
forall name. LSig name -> Bool
isSCCFunSig LSig name
s)

    warn_discarded_sigs :: TcRn ()
warn_discarded_sigs
      = WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason
                  (SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text "Discarding unexpected pragmas for" SDoc -> SDoc -> SDoc
<+> TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id)
                      2 ([SDoc] -> SDoc
vcat ((LSig GhcRn -> SDoc) -> [LSig GhcRn] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SDoc) -> (LSig GhcRn -> SrcSpan) -> LSig GhcRn -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LSig GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc) [LSig GhcRn]
bad_sigs)))

--------------
tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag poly_id :: TcId
poly_id prag :: Sig GhcRn
prag@(SpecSig _ fun_name :: Located (IdP GhcRn)
fun_name hs_tys :: [LHsSigType GhcRn]
hs_tys inl :: 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 (Trac #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 -> SDoc -> TcRn ()
warnIf (Bool -> Bool
not (Type -> Bool
isOverloadedTy Type
poly_ty Bool -> Bool -> Bool
|| InlinePragma -> Bool
isInlinePragma InlinePragma
inl))
                 (String -> SDoc
text "SPECIALISE pragma for non-overloaded function"
                  SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (GenLocated SrcSpan Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan Name
Located (IdP GhcRn)
fun_name))
                  -- Note [SPECIALISE pragmas]
        ; [TcSpecPrag]
spec_prags <- (LHsSigType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag)
-> [LHsSigType GhcRn] -> TcM [TcSpecPrag]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsSigType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag
tc_one [LHsSigType GhcRn]
hs_tys
        ; String -> SDoc -> TcRn ()
traceTc "tcSpecPrag" (TcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcId
poly_id SDoc -> SDoc -> SDoc
$$ Arity -> SDoc -> SDoc
nest 2 ([SDoc] -> SDoc
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 (m :: * -> *) a. Monad m => a -> m a
return [TcSpecPrag]
spec_prags }
  where
    name :: Name
name      = TcId -> Name
idName TcId
poly_id
    poly_ty :: Type
poly_ty   = TcId -> Type
idType TcId
poly_id
    spec_ctxt :: a -> SDoc
spec_ctxt prag :: a
prag = SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text "In the SPECIALISE pragma") 2 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
prag)

    tc_one :: LHsSigType GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag
tc_one hs_ty :: LHsSigType GhcRn
hs_ty
      = do { Type
spec_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType   (Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
name Bool
False) LHsSigType GhcRn
hs_ty
           ; HsWrapper
wrap    <- UserTypeCtxt -> Type -> Type -> TcM HsWrapper
tcSpecWrapper (Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
name Bool
True)  Type
poly_ty Type
spec_ty
           ; TcSpecPrag -> IOEnv (Env TcGblEnv TcLclEnv) TcSpecPrag
forall (m :: * -> *) a. Monad m => a -> m a
return (TcId -> HsWrapper -> InlinePragma -> TcSpecPrag
SpecPrag TcId
poly_id HsWrapper
wrap InlinePragma
inl) }

tcSpecPrag _ prag :: Sig GhcRn
prag = String -> SDoc -> TcM [TcSpecPrag]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 -> Type -> Type -> TcM HsWrapper
tcSpecWrapper ctxt :: UserTypeCtxt
ctxt poly_ty :: Type
poly_ty spec_ty :: Type
spec_ty
  = do { (sk_wrap :: HsWrapper
sk_wrap, inst_wrap :: HsWrapper
inst_wrap)
               <- UserTypeCtxt
-> Type
-> ([TcId] -> Type -> TcM HsWrapper)
-> TcM (HsWrapper, HsWrapper)
forall result.
UserTypeCtxt
-> Type
-> ([TcId] -> Type -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemise UserTypeCtxt
ctxt Type
spec_ty (([TcId] -> Type -> TcM HsWrapper) -> TcM (HsWrapper, HsWrapper))
-> ([TcId] -> Type -> TcM HsWrapper) -> TcM (HsWrapper, HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ _ spec_tau :: Type
spec_tau ->
                  do { (inst_wrap :: HsWrapper
inst_wrap, tau :: Type
tau) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
poly_ty
                     ; TcCoercionN
_ <- Maybe (HsExpr GhcRn) -> Type -> Type -> TcM TcCoercionN
unifyType Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing Type
spec_tau Type
tau
                            -- Deliberately ignore the evidence
                            -- See Note [Handling SPECIALISE pragmas],
                            --   wrinkle (2)
                     ; HsWrapper -> TcM HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
inst_wrap }
       ; HsWrapper -> TcM HsWrapper
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 prags :: [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 (m :: * -> *) a. Monad m => a -> m a
return []
         else do
            { [GenLocated SrcSpan [TcSpecPrag]]
pss <- (GenLocated SrcSpan (Name, Sig GhcRn)
 -> TcRn (GenLocated SrcSpan [TcSpecPrag]))
-> [GenLocated SrcSpan (Name, Sig GhcRn)]
-> TcRn [GenLocated SrcSpan [TcSpecPrag]]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM ((SrcSpanLess (GenLocated SrcSpan (Name, Sig GhcRn))
 -> TcM (SrcSpanLess (GenLocated SrcSpan [TcSpecPrag])))
-> GenLocated SrcSpan (Name, Sig GhcRn)
-> TcRn (GenLocated SrcSpan [TcSpecPrag])
forall a b.
(HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
wrapLocM (Name, Sig GhcRn) -> TcM [TcSpecPrag]
SrcSpanLess (GenLocated SrcSpan (Name, Sig GhcRn))
-> TcM (SrcSpanLess (GenLocated SrcSpan [TcSpecPrag]))
tcImpSpec)
                     [SrcSpan
-> (Name, Sig GhcRn) -> GenLocated SrcSpan (Name, Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Name
IdP GhcRn
name,Sig GhcRn
prag)
                             | (L loc :: SrcSpan
loc prag :: Sig GhcRn
prag@(SpecSig _ (L _ name :: IdP GhcRn
name) _ _)) <- [LSig GhcRn]
prags
                             , Bool -> Bool
not (Module -> Name -> Bool
nameIsLocalOrFrom Module
this_mod Name
IdP GhcRn
name) ]
            ; [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LTcSpecPrag] -> TcM [LTcSpecPrag])
-> [LTcSpecPrag] -> TcM [LTcSpecPrag]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpan [TcSpecPrag] -> [LTcSpecPrag])
-> [GenLocated SrcSpan [TcSpecPrag]] -> [LTcSpecPrag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(L l :: SrcSpan
l ps :: [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 SrcSpan
l) [TcSpecPrag]
ps) [GenLocated SrcSpan [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 dflags :: DynFlags
dflags
      | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Specialise DynFlags
dflags) = Bool
True
      | Bool
otherwise = case DynFlags -> HscTarget
hscTarget DynFlags
dflags of
                      HscNothing -> Bool
True
                      HscInterpreted -> Bool
True
                      _other :: HscTarget
_other         -> Bool
False

tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec (name :: Name
name, prag :: Sig GhcRn
prag)
 = do { TcId
id <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TcId
tcLookupId Name
name
      ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (InlinePragma -> Bool
isAnyInlinePragma (TcId -> InlinePragma
idInlinePragma TcId
id))
               (WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason (Name -> SDoc
impSpecErr Name
name))
      ; TcId -> Sig GhcRn -> TcM [TcSpecPrag]
tcSpecPrag TcId
id Sig GhcRn
prag }

impSpecErr :: Name -> SDoc
impSpecErr :: Name -> SDoc
impSpecErr name :: Name
name
  = SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text "You cannot SPECIALISE" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name))
       2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text "because its definition has no INLINE/INLINABLE pragma"
               , SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep
                   [ String -> SDoc
text "or its defining module" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
                   , String -> SDoc
text "was compiled without -O"]])
  where
    mod :: Module
mod = HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name