{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
{-# LANGUAGE ViewPatterns         #-}
{-# LANGUAGE MultiWayIf #-}
{-
%
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}

module GHC.Tc.Gen.Head
       ( HsExprArg(..), HsExprLoc, TcPass(..), QLFlag(..), EWrap(..)
       , splitHsApps, rebuildHsApps
       , addArgWrap, isHsValArg, getFunSrcSpan
       , leadingValArgs, isVisibleArg, getDeepSubsumptionFlag_DataConHead

       , tcInferAppHead, tcInferAppHead_maybe
       , tcInferId, tcCheckId, tcInferConLike, obviousSig
       , tyConOf, tyConOfET
       , nonBidirectionalErr

       , pprArgInst, addFunResCtxt ) where

import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )

import GHC.Prelude
import GHC.Hs
import GHC.Hs.Syn.Type

import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Expand( tcExpand )
import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )
import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family ( tcLookupDataFamInst )
import GHC.Tc.Errors.Types
import GHC.Tc.Solver          ( InferMode(..), simplifyInfer )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) )
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Constraint( WantedConstraints )
import GHC.Tc.Utils.TcType as TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Zonk.TcType


import GHC.Core.FamInstEnv    ( FamInstEnvs )
import GHC.Core.UsageEnv      ( singleUsageUE, UsageEnv )
import GHC.Core.PatSyn( PatSyn, patSynName )
import GHC.Core.ConLike( ConLike(..) )
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.Type

import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.Error

import GHC.Builtin.Names

import GHC.Driver.DynFlags
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable

import GHC.Data.Maybe

{- *********************************************************************
*                                                                      *
              HsExprArg: auxiliary data type
*                                                                      *
********************************************************************* -}

{- Note [HsExprArg]
~~~~~~~~~~~~~~~~~~~
The data type HsExprArg :: TcPass -> Type
is a very local type, used only within this module and GHC.Tc.Gen.App

* It's just a bog-standard zipper for an application chain
  See Note [Application chains and heads] in GHC.Tc.Gen.App for
  what an "application chain" is.

* It's a GHC-specific type, so using TTG only where necessary

* It is indexed by TcPass, meaning
  - HsExprArg TcpRn:
      The result of splitHsApps, which decomposes a HsExpr GhcRn

  - HsExprArg TcpInst:
      The result of tcInstFun, which instantiates the function type,
      perhaps taking a quick look at arguments.

  - HsExprArg TcpTc:
      The result of tcArg, which typechecks the value args
      In EValArg we now have a (LHsExpr GhcTc)

* rebuildPrefixApps is dual to splitHsApps, and zips an application
  back into a HsExpr

Invariants:

1. With QL switched off, all arguments are ValArg; no ValArgQL

2. With QL switched on, tcInstFun converts some ValArgs to ValArgQL,
   under the conditions when quick-look should happen (eg the argument
   type is guarded) -- see quickLookArg

Note [EValArgQL]
~~~~~~~~~~~~~~~~
Data constructor EValArgQL represents an argument that has been
partly-type-checked by Quick Look: the first part of `tcApp` has been
done, but not the second, `finishApp` part.

The constuctor captures all the bits and pieces needed to complete
typechecking.  (An alternative would to to store a function closure,
but that's less concrete.)  See Note [Quick Look at value arguments]
in GHC.Tc.Gen.App

Note [splitHsApps]
~~~~~~~~~~~~~~~~~~
The key function
  splitHsApps :: HsExpr GhcRn -> Maybe (HsExpr GhcRn, [HsExprArg 'TcpRn])
takes apart either an HsApp, HsTypeApp, an infix OpApp, and XExprs returning

* The "head" of the application, an expression that is often a variable/data constructor
  this is used for typechecking

* The "user head" or "error head" of the application, to be reported to the
  user in case of an error.  Example:
         (`op` e)
  expands (via ExpandedThingRn) to
         (rightSection op e)
  but we don't want to see 'rightSection' in error messages. So we keep the
  innermost un-expanded head as the "error head".

* A list of HsExprArg, the arguments

-}

type HsExprLoc = EpAnn AnnListItem    -- The location attached to a HsExpr

data TcPass = TcpRn     -- Arguments decomposed
            | TcpInst   -- Function instantiated
            | TcpTc     -- Typechecked

data HsExprArg (p :: TcPass) where -- See Note [HsExprArg]

  -- Data constructor EValArg represents a value argument
  EValArg :: { forall (p :: TcPass). HsExprArg p -> SrcSpanAnnA
ea_loc_span :: HsExprLoc
             , forall (p :: TcPass). HsExprArg p -> XEVAType p
ea_arg_ty   :: !(XEVAType p)
             , forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg      :: LHsExpr (GhcPass (XPass p)) }
          -> HsExprArg p

  -- Data constructor EValArgQL represents an argument that has been
  -- partly-type-checked by Quick Look; see Note [EValArgQL]
  EValArgQL :: { HsExprArg 'TcpInst -> SrcSpanAnnA
eaql_loc_span :: HsExprLoc
               , HsExprArg 'TcpInst -> Scaled Kind
eaql_arg_ty   :: Scaled TcSigmaType  -- Argument type expected by function
               , HsExprArg 'TcpInst -> LHsExpr (GhcPass 'Renamed)
eaql_larg     :: LHsExpr GhcRn       -- Original application, for
                                                      -- location and error msgs
               , HsExprArg 'TcpInst -> HsExpr (GhcPass 'Renamed)
eaql_rn_fun   :: HsExpr GhcRn        -- Application chain head of the argument
               , HsExprArg 'TcpInst -> (HsExpr (GhcPass 'Typechecked), SrcSpan)
eaql_tc_fun   :: (HsExpr GhcTc, SrcSpan) -- Typechecked head and its location span
               , HsExprArg 'TcpInst -> UsageEnv
eaql_fun_ue   :: UsageEnv -- Usage environment of the typechecked head (QLA5)
               , HsExprArg 'TcpInst -> [HsExprArg 'TcpInst]
eaql_args     :: [HsExprArg 'TcpInst]  -- Args: instantiated, not typechecked
               , HsExprArg 'TcpInst -> WantedConstraints
eaql_wanted   :: WantedConstraints
               , HsExprArg 'TcpInst -> Bool
eaql_encl     :: Bool                  -- True <=> we have already qlUnified
                                                        --          eaql_arg_ty and eaql_res_rho
               , HsExprArg 'TcpInst -> Kind
eaql_res_rho  :: TcRhoType }           -- Result type of the application
            -> HsExprArg 'TcpInst  -- Only exists in TcpInst phase

  ETypeArg :: { ea_loc_span :: HsExprLoc
              , forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
ea_hs_ty    :: LHsWcType GhcRn  -- The type arg
              , forall (p :: TcPass). HsExprArg p -> XETAType p
ea_ty_arg   :: !(XETAType p) }  -- Kind-checked type arg
           -> HsExprArg p

  EPrag :: HsExprLoc -> (HsPragE (GhcPass (XPass p))) -> HsExprArg p
  EWrap :: EWrap                                      -> HsExprArg p

type family XETAType (p :: TcPass) where  -- Type arguments
  XETAType 'TcpRn = NoExtField
  XETAType _      = Type

type family XEVAType (p :: TcPass) where   -- Value arguments
  XEVAType 'TcpInst = Scaled TcSigmaTypeFRR
  XEVAType _        = NoExtField

data QLFlag = DoQL | NoQL

data EWrap = EPar    HsExprLoc
           | EExpand HsExprLoc HsCtxt
           | EHsWrap HsWrapper


instance Outputable QLFlag where
  ppr :: QLFlag -> SDoc
ppr QLFlag
DoQL = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DoQL"
  ppr QLFlag
NoQL = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NoQL"

type family XPass (p :: TcPass) where
  XPass 'TcpRn   = 'Renamed
  XPass 'TcpInst = 'Renamed
  XPass 'TcpTc   = 'Typechecked

mkEValArg :: HsExprLoc -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg :: SrcSpanAnnA -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg SrcSpanAnnA
src_loc LHsExpr (GhcPass 'Renamed)
e = EValArg { ea_arg :: LHsExpr (GhcPass (XPass 'TcpRn))
ea_arg = LHsExpr (GhcPass 'Renamed)
LHsExpr (GhcPass (XPass 'TcpRn))
e, ea_loc_span :: SrcSpanAnnA
ea_loc_span = SrcSpanAnnA
src_loc
                              , ea_arg_ty :: XEVAType 'TcpRn
ea_arg_ty = NoExtField
XEVAType 'TcpRn
noExtField }

mkETypeArg :: HsExprLoc -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg :: SrcSpanAnnA -> LHsWcType (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkETypeArg SrcSpanAnnA
src_loc LHsWcType (GhcPass 'Renamed)
hs_ty =
  ETypeArg { ea_loc_span :: SrcSpanAnnA
ea_loc_span = SrcSpanAnnA
src_loc
           , ea_hs_ty :: LHsWcType (GhcPass 'Renamed)
ea_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty
           , ea_ty_arg :: XETAType 'TcpRn
ea_ty_arg = NoExtField
XETAType 'TcpRn
noExtField }

addArgWrap :: HsWrapper -> [HsExprArg p] -> [HsExprArg p]
addArgWrap :: forall (p :: TcPass). HsWrapper -> [HsExprArg p] -> [HsExprArg p]
addArgWrap HsWrapper
wrap [HsExprArg p]
args
 | HsWrapper -> Bool
isIdHsWrapper HsWrapper
wrap = [HsExprArg p]
args
 | Bool
otherwise          = EWrap -> HsExprArg p
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsWrapper -> EWrap
EHsWrap HsWrapper
wrap) HsExprArg p -> [HsExprArg p] -> [HsExprArg p]
forall a. a -> [a] -> [a]
: [HsExprArg p]
args


--------------------
getFunSrcSpan :: [HsExprArg 'TcpRn] -> TcM SrcSpan
getFunSrcSpan :: [HsExprArg 'TcpRn] -> TcM SrcSpan
getFunSrcSpan [] = TcM SrcSpan
getSrcSpanM
getFunSrcSpan (ETypeArg { ea_loc_span :: forall (p :: TcPass). HsExprArg p -> SrcSpanAnnA
ea_loc_span = SrcSpanAnnA
l }    : [HsExprArg 'TcpRn]
_)    = SrcSpan -> TcM SrcSpan
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
getFunSrcSpan (EValArg  { ea_loc_span :: forall (p :: TcPass). HsExprArg p -> SrcSpanAnnA
ea_loc_span = SrcSpanAnnA
l }    : [HsExprArg 'TcpRn]
_)    = SrcSpan -> TcM SrcSpan
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
getFunSrcSpan (EPrag SrcSpanAnnA
l HsPragE (GhcPass (XPass 'TcpRn))
_                       : [HsExprArg 'TcpRn]
_)    = SrcSpan -> TcM SrcSpan
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
getFunSrcSpan (EWrap (EPar SrcSpanAnnA
l)                  : [HsExprArg 'TcpRn]
_)    = SrcSpan -> TcM SrcSpan
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
getFunSrcSpan (EWrap (EExpand SrcSpanAnnA
l HsCtxt
_)             : [HsExprArg 'TcpRn]
_)    = SrcSpan -> TcM SrcSpan
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
getFunSrcSpan (EWrap (EHsWrap {})              : [HsExprArg 'TcpRn]
args) = [HsExprArg 'TcpRn] -> TcM SrcSpan
getFunSrcSpan [HsExprArg 'TcpRn]
args

--------------------
isHsValArg :: HsExprArg id -> Bool
isHsValArg :: forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg (EValArg {}) = Bool
True
isHsValArg HsExprArg id
_            = Bool
False

leadingValArgs :: [HsExprArg 'TcpRn] -> [LHsExpr GhcRn]
leadingValArgs :: [HsExprArg 'TcpRn] -> [LHsExpr (GhcPass 'Renamed)]
leadingValArgs []                                = []
leadingValArgs (EValArg { ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = LHsExpr (GhcPass (XPass 'TcpRn))
arg } : [HsExprArg 'TcpRn]
args) = LHsExpr (GhcPass (XPass 'TcpRn))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
arg GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
-> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn] -> [LHsExpr (GhcPass 'Renamed)]
leadingValArgs [HsExprArg 'TcpRn]
args
leadingValArgs (EWrap {}    : [HsExprArg 'TcpRn]
args)              = [HsExprArg 'TcpRn] -> [LHsExpr (GhcPass 'Renamed)]
leadingValArgs [HsExprArg 'TcpRn]
args
leadingValArgs (EPrag {}    : [HsExprArg 'TcpRn]
args)              = [HsExprArg 'TcpRn] -> [LHsExpr (GhcPass 'Renamed)]
leadingValArgs [HsExprArg 'TcpRn]
args
leadingValArgs (ETypeArg {} : [HsExprArg 'TcpRn]
_)                 = []

isValArg :: HsExprArg id -> Bool
isValArg :: forall (id :: TcPass). HsExprArg id -> Bool
isValArg (EValArg {}) = Bool
True
isValArg HsExprArg id
_            = Bool
False

isVisibleArg :: HsExprArg id -> Bool
isVisibleArg :: forall (id :: TcPass). HsExprArg id -> Bool
isVisibleArg (EValArg {})  = Bool
True
isVisibleArg (ETypeArg {}) = Bool
True
isVisibleArg HsExprArg id
_             = Bool
False

instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
  ppr :: HsExprArg p -> SDoc
ppr (EPrag SrcSpanAnnA
_ HsPragE (GhcPass (XPass p))
p)                     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EPrag" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsPragE (GhcPass (XPass p)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsPragE (GhcPass (XPass p))
p
  ppr (ETypeArg { ea_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
ea_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty }) = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'@' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> HsWildCardBndrs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsWcType (GhcPass 'Renamed)
HsWildCardBndrs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
hs_ty
  ppr (EWrap EWrap
wrap)                    = EWrap -> SDoc
forall a. Outputable a => a -> SDoc
ppr EWrap
wrap
  ppr (EValArg { ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = LHsExpr (GhcPass (XPass p))
arg, ea_loc_span :: forall (p :: TcPass). HsExprArg p -> SrcSpanAnnA
ea_loc_span = SrcSpanAnnA
sloc })
    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (SrcSpanAnnA -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanAnnA
sloc) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsExpr (GhcPass (XPass p))) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr (GhcPass (XPass p))
GenLocated SrcSpanAnnA (HsExpr (GhcPass (XPass p)))
arg
  ppr (EValArgQL { eaql_tc_fun :: HsExprArg 'TcpInst -> (HsExpr (GhcPass 'Typechecked), SrcSpan)
eaql_tc_fun = (HsExpr (GhcPass 'Typechecked), SrcSpan)
fun, eaql_args :: HsExprArg 'TcpInst -> [HsExprArg 'TcpInst]
eaql_args = [HsExprArg 'TcpInst]
args, eaql_res_rho :: HsExprArg 'TcpInst -> Kind
eaql_res_rho = Kind
ty})
    = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArgQL" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (HsExpr (GhcPass 'Typechecked), SrcSpan) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr (GhcPass 'Typechecked), SrcSpan)
fun)
         Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [HsExprArg 'TcpInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpInst]
args, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ea_ql_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
ty ])

pprArgInst :: HsExprArg 'TcpInst -> SDoc
-- Ugh!  A special version for 'TcpInst, se we can print the arg_ty of EValArg
pprArgInst :: HsExprArg 'TcpInst -> SDoc
pprArgInst (EPrag SrcSpanAnnA
_ HsPragE (GhcPass (XPass 'TcpInst))
p)                     = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EPrag" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsPragE (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsPragE (GhcPass 'Renamed)
HsPragE (GhcPass (XPass 'TcpInst))
p
pprArgInst (ETypeArg { ea_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
ea_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty }) = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'@' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> HsWildCardBndrs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsWcType (GhcPass 'Renamed)
HsWildCardBndrs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
hs_ty
pprArgInst (EWrap EWrap
wrap)                    = EWrap -> SDoc
forall a. Outputable a => a -> SDoc
ppr EWrap
wrap
pprArgInst (EValArg { ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = LHsExpr (GhcPass (XPass 'TcpInst))
arg, ea_arg_ty :: forall (p :: TcPass). HsExprArg p -> XEVAType p
ea_arg_ty = XEVAType 'TcpInst
ty })
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr (GhcPass (XPass 'TcpInst))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
arg)
       Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Scaled Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Scaled Kind
XEVAType 'TcpInst
ty)
pprArgInst (EValArgQL { eaql_tc_fun :: HsExprArg 'TcpInst -> (HsExpr (GhcPass 'Typechecked), SrcSpan)
eaql_tc_fun = (HsExpr (GhcPass 'Typechecked), SrcSpan)
fun, eaql_args :: HsExprArg 'TcpInst -> [HsExprArg 'TcpInst]
eaql_args = [HsExprArg 'TcpInst]
args, eaql_res_rho :: HsExprArg 'TcpInst -> Kind
eaql_res_rho = Kind
ty})
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArgQL" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (HsExpr (GhcPass 'Typechecked), SrcSpan) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr (GhcPass 'Typechecked), SrcSpan)
fun)
       Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((HsExprArg 'TcpInst -> SDoc) -> [HsExprArg 'TcpInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map HsExprArg 'TcpInst -> SDoc
pprArgInst [HsExprArg 'TcpInst]
args), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ea_ql_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
ty ])

instance Outputable EWrap where
  ppr :: EWrap -> SDoc
ppr (EPar SrcSpanAnnA
_)      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EPar"
  ppr (EHsWrap HsWrapper
w)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EHsWrap" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsWrapper -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWrapper
w
  ppr (EExpand SrcSpanAnnA
_ HsCtxt
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EExpand"  -- No Outputable instance for HsCtxt yet



{- *********************************************************************
*                                                                      *
                 Splitting and rebuilding
*                                                                      *
********************************************************************* -}

-- | Split the expression into an application chain
-- See Note [splitHsApps]
-- See Note [Application chains and heads]
splitHsApps :: HsExpr GhcRn -> TcM (HsExpr GhcRn, [HsExprArg 'TcpRn])
splitHsApps :: HsExpr (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Renamed), [HsExprArg 'TcpRn])
splitHsApps HsExpr (GhcPass 'Renamed)
e = HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr (GhcPass 'Renamed), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
e []
  where
    go :: HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr (GhcPass 'Renamed), [HsExprArg 'TcpRn])
go (HsPar XPar (GhcPass 'Renamed)
_ (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun))        [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr (GhcPass 'Renamed), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (SrcSpanAnnA -> EWrap
EPar SrcSpanAnnA
l)   HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
    go (HsPragE XPragE (GhcPass 'Renamed)
_ HsPragE (GhcPass 'Renamed)
p (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun))    [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr (GhcPass 'Renamed), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> HsPragE (GhcPass (XPass 'TcpRn)) -> HsExprArg 'TcpRn
forall (p :: TcPass).
SrcSpanAnnA -> HsPragE (GhcPass (XPass p)) -> HsExprArg p
EPrag      SrcSpanAnnA
l HsPragE (GhcPass 'Renamed)
HsPragE (GhcPass (XPass 'TcpRn))
p   HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
    go (HsAppType XAppTypeE (GhcPass 'Renamed)
_ (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun) LHsWcType (NoGhcTc (GhcPass 'Renamed))
ty) [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr (GhcPass 'Renamed), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> LHsWcType (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkETypeArg SrcSpanAnnA
l LHsWcType (NoGhcTc (GhcPass 'Renamed))
LHsWcType (GhcPass 'Renamed)
ty  HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
    go (HsApp XApp (GhcPass 'Renamed)
_ (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun) LHsExpr (GhcPass 'Renamed)
arg)    [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr (GhcPass 'Renamed), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg  SrcSpanAnnA
l LHsExpr (GhcPass 'Renamed)
arg HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
    go HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args = do { mb_hse <- HsExpr (GhcPass 'Renamed)
-> TcM (Maybe (HsExpansion (GhcPass 'Renamed)))
tcExpand HsExpr (GhcPass 'Renamed)
fun
                     ; case mb_hse of
                          Just (HSE { hse_ctxt :: forall p. HsExpansion p -> HsCtxt
hse_ctxt = HsCtxt
orig, hse_exp :: forall p. HsExpansion p -> LHsExpr p
hse_exp = L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun' })
                            -> HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr (GhcPass 'Renamed), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun' (EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (SrcSpanAnnA -> HsCtxt -> EWrap
EExpand SrcSpanAnnA
l HsCtxt
orig) HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
                          Maybe (HsExpansion (GhcPass 'Renamed))
Nothing
                            -> (HsExpr (GhcPass 'Renamed), [HsExprArg 'TcpRn])
-> TcM (HsExpr (GhcPass 'Renamed), [HsExprArg 'TcpRn])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr (GhcPass 'Renamed)
fun, [HsExprArg 'TcpRn]
args) }

-- | Rebuild an application: takes a type-checked application head
-- expression together with arguments in the form of typechecked 'HsExprArg's
-- and returns a typechecked application of the head to the arguments.
rebuildHsApps :: HsExpr GhcTc
                      -- ^ the function being applied
              -> [HsExprArg 'TcpTc]
                      -- ^ the arguments to the function
              -> HsExpr GhcTc
rebuildHsApps :: HsExpr (GhcPass 'Typechecked)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps HsExpr (GhcPass 'Typechecked)
fun [] = HsExpr (GhcPass 'Typechecked)
fun
rebuildHsApps HsExpr (GhcPass 'Typechecked)
fun (HsExprArg 'TcpTc
arg : [HsExprArg 'TcpTc]
args)
  = case HsExprArg 'TcpTc
arg of
      EValArg { ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = LHsExpr (GhcPass (XPass 'TcpTc))
arg, ea_loc_span :: forall (p :: TcPass). HsExprArg p -> SrcSpanAnnA
ea_loc_span = SrcSpanAnnA
l }
        -> HsExpr (GhcPass 'Typechecked)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (XApp (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> HsExpr (GhcPass 'Typechecked)
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp (GhcPass 'Typechecked)
NoExtField
noExtField (SrcSpanAnnA
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsExpr (GhcPass 'Typechecked)
fun) LHsExpr (GhcPass 'Typechecked)
LHsExpr (GhcPass (XPass 'TcpTc))
arg) [HsExprArg 'TcpTc]
args
      ETypeArg { ea_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
ea_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty, ea_ty_arg :: forall (p :: TcPass). HsExprArg p -> XETAType p
ea_ty_arg = XETAType 'TcpTc
ty, ea_loc_span :: forall (p :: TcPass). HsExprArg p -> SrcSpanAnnA
ea_loc_span = SrcSpanAnnA
l }
        -> HsExpr (GhcPass 'Typechecked)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (XAppTypeE (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> LHsWcType (NoGhcTc (GhcPass 'Typechecked))
-> HsExpr (GhcPass 'Typechecked)
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE (GhcPass 'Typechecked)
XETAType 'TcpTc
ty (SrcSpanAnnA
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsExpr (GhcPass 'Typechecked)
fun) LHsWcType (NoGhcTc (GhcPass 'Typechecked))
LHsWcType (GhcPass 'Renamed)
hs_ty) [HsExprArg 'TcpTc]
args
      EPrag SrcSpanAnnA
l HsPragE (GhcPass (XPass 'TcpTc))
p
        -> HsExpr (GhcPass 'Typechecked)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (XPragE (GhcPass 'Typechecked)
-> HsPragE (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> HsExpr (GhcPass 'Typechecked)
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE (GhcPass 'Typechecked)
NoExtField
noExtField HsPragE (GhcPass 'Typechecked)
HsPragE (GhcPass (XPass 'TcpTc))
p (SrcSpanAnnA
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsExpr (GhcPass 'Typechecked)
fun)) [HsExprArg 'TcpTc]
args
      EWrap (EPar SrcSpanAnnA
l)
        -> HsExpr (GhcPass 'Typechecked)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (XPar (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar (GhcPass 'Typechecked)
NoExtField
noExtField (SrcSpanAnnA
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsExpr (GhcPass 'Typechecked)
fun)) [HsExprArg 'TcpTc]
args
      EWrap (EExpand SrcSpanAnnA
l HsCtxt
o)
        -> HsExpr (GhcPass 'Typechecked)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (XXExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall p. XXExpr p -> HsExpr p
XExpr (HsExpansion (GhcPass 'Typechecked) -> XXExprGhcTc
ExpandedThingTc (HsCtxt
-> LHsExpr (GhcPass 'Typechecked)
-> HsExpansion (GhcPass 'Typechecked)
forall p. HsCtxt -> LHsExpr p -> HsExpansion p
HSE HsCtxt
o (SrcSpanAnnA
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsExpr (GhcPass 'Typechecked)
fun)))) [HsExprArg 'TcpTc]
args
      EWrap (EHsWrap HsWrapper
wrap)
        -> HsExpr (GhcPass 'Typechecked)
-> [HsExprArg 'TcpTc] -> HsExpr (GhcPass 'Typechecked)
rebuildHsApps (HsWrapper
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
mkHsWrap HsWrapper
wrap HsExpr (GhcPass 'Typechecked)
fun) [HsExprArg 'TcpTc]
args


{- Note [Desugar OpApp in the typechecker]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Operator sections are desugared in the renamer; see GHC.Rename.Expr
Note [Handling overloaded and rebindable constructs].
But for reasons explained there, we rename OpApp to OpApp.  Then,
here in the typechecker, we desugar it to a use of ExpandedThingRn.
That makes it possible to typecheck something like
     e1 `f` e2
where
   f :: forall a. t1 -> forall b. t2 -> t3

Note [Looking through Template Haskell splices in splitHsApps]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When typechecking an application, we must look through untyped TH splices in
order to typecheck examples like the one in #21077:

  data Foo = MkFoo () (forall a. a -> a)

  foo :: Foo
  foo = $([| MkFoo () |]) $ \x -> x

In principle, this is straightforward to accomplish. By the time we typecheck
`foo`, the renamer will have already run the splice, so all we have to do is
look at the expanded version of the splice in `splitHsApps`. This is accomplished
in `splitHsApps` be deligating it to `tcExpand`. Where, `tcExpand` returns the
expression to `splitHsApps`, to continue splitting the application chain.

There is one slight complication in that untyped TH splices also include
modFinalizers (see Note [Delaying modFinalizers in untyped splices] in
GHC.Rename.Splice), which must be run during typechecking. `tcExpand` is a
convenient place to run the modFinalizers, so we do so there. This is the
reason that `splitHsApps` uses the TcM monad.

`HsUntypedSplice` covers both ordinary TH splices, such as the example above,
as well as quasiquotes (see Note [Quasi-quote overview] in
Language.Haskell.Syntax.Expr). The `tcExpand` case for `HsUntypedSplice`
handles both of these. This is easy to accomplish, since all the real work in
handling splices and quasiquotes has already been performed by the renamer by
the time we get to `splitHsApps`.

-}

{- Note [Type Checking Template Haskell Splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
`tcExpr` has a separate case for `HsUntypedSplice`s that do /not/ occur at the
head of an application. See also Note [Looking through Template Haskell splices in splitHsApps]

This is important to handle programs like this one:

  foo :: (forall a. a -> a) -> b -> b
  foo = $([| \g x -> g x |])

Here, it is vital that we push the expected type inwards so that `g` gets the
type `forall a. a -> a`, and the `tcExpr` case for `HsUntypedSplice` performs
this pushing. Without it, we would instead infer `g` to have type `b -> b`,
which isn't sufficiently general. Unfortunately, this does mean that there are
two different places in the code where an `HsUntypedSplice`'s modFinalizers can
be ran, depending on whether the splice appears at the head of an application
or not.

-}


{- *********************************************************************
*                                                                      *
                 tcInferAppHead
*                                                                      *
********************************************************************* -}

tcInferAppHead :: (HsExpr GhcRn, SrcSpan)
               -> TcM (HsExpr GhcTc, TcSigmaType)
-- Infer type of the head of an application
--   i.e. the 'f' in (f e1 ... en)
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
-- We get back a /SigmaType/ because we have special cases for
--   * A bare identifier (just look it up)
--     This case also covers a record selector HsRecSel
--   * An expression with a type signature (e :: ty)
--   * An XExpr where 'f' is actually an expanded out expression
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
--
-- Note that [] and (,,) are both HsVar:
--   see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr
--
-- NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those
--     cases are dealt with by splitHsApps.
--
-- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App
tcInferAppHead :: (HsExpr (GhcPass 'Renamed), SrcSpan)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferAppHead (HsExpr (GhcPass 'Renamed)
fun,SrcSpan
fun_lspan)
  = SrcSpan
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
fun_lspan (TcM (HsExpr (GhcPass 'Typechecked), Kind)
 -> TcM (HsExpr (GhcPass 'Typechecked), Kind))
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a b. (a -> b) -> a -> b
$
    do { mb_tc_fun <- HsExpr (GhcPass 'Renamed)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), Kind))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun
       ; case mb_tc_fun of
            Just (HsExpr (GhcPass 'Typechecked)
fun', Kind
fun_sigma) -> (HsExpr (GhcPass 'Typechecked), Kind)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr (GhcPass 'Typechecked)
fun', Kind
fun_sigma)
            Maybe (HsExpr (GhcPass 'Typechecked), Kind)
Nothing                -> (ExpRhoType -> TcM (HsExpr (GhcPass 'Typechecked)))
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a. (ExpRhoType -> TcM a) -> TcM (a, Kind)
runInferRho (HsExpr (GhcPass 'Renamed)
-> ExpRhoType -> TcM (HsExpr (GhcPass 'Typechecked))
tcExpr HsExpr (GhcPass 'Renamed)
fun) }

tcInferAppHead_maybe :: HsExpr GhcRn
                     -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
-- Returns Nothing for a complicated head
-- XExpr's although complicated needs to be looked through, useful for QL things when
-- the argument is an XExpr
tcInferAppHead_maybe :: HsExpr (GhcPass 'Renamed)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), Kind))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun = case HsExpr (GhcPass 'Renamed)
fun of
      HsVar XVar (GhcPass 'Renamed)
_ LIdOccP (GhcPass 'Renamed)
nm              -> (HsExpr (GhcPass 'Typechecked), Kind)
-> Maybe (HsExpr (GhcPass 'Typechecked), Kind)
(HsExpr (GhcPass 'Typechecked), Kind)
-> Maybe (HsExpr (GhcPass 'Typechecked), Kind)
forall a. a -> Maybe a
Just ((HsExpr (GhcPass 'Typechecked), Kind)
 -> Maybe (HsExpr (GhcPass 'Typechecked), Kind))
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), Kind))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnN (WithUserRdr Name)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferId LIdOccP (GhcPass 'Renamed)
GenLocated SrcSpanAnnN (WithUserRdr Name)
nm
      ExprWithTySig XExprWithTySig (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty -> (HsExpr (GhcPass 'Typechecked), Kind)
-> Maybe (HsExpr (GhcPass 'Typechecked), Kind)
(HsExpr (GhcPass 'Typechecked), Kind)
-> Maybe (HsExpr (GhcPass 'Typechecked), Kind)
forall a. a -> Maybe a
Just ((HsExpr (GhcPass 'Typechecked), Kind)
 -> Maybe (HsExpr (GhcPass 'Typechecked), Kind))
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), Kind))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr (GhcPass 'Renamed)
-> LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcExprWithSig LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty
      HsOverLit XOverLitE (GhcPass 'Renamed)
_ HsOverLit (GhcPass 'Renamed)
lit         -> (HsExpr (GhcPass 'Typechecked), Kind)
-> Maybe (HsExpr (GhcPass 'Typechecked), Kind)
(HsExpr (GhcPass 'Typechecked), Kind)
-> Maybe (HsExpr (GhcPass 'Typechecked), Kind)
forall a. a -> Maybe a
Just ((HsExpr (GhcPass 'Typechecked), Kind)
 -> Maybe (HsExpr (GhcPass 'Typechecked), Kind))
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), Kind))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsOverLit (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferOverLit HsOverLit (GhcPass 'Renamed)
lit
      XExpr (HsRecSelRn FieldOcc (GhcPass 'Renamed)
f)    -> (HsExpr (GhcPass 'Typechecked), Kind)
-> Maybe (HsExpr (GhcPass 'Typechecked), Kind)
(HsExpr (GhcPass 'Typechecked), Kind)
-> Maybe (HsExpr (GhcPass 'Typechecked), Kind)
forall a. a -> Maybe a
Just ((HsExpr (GhcPass 'Typechecked), Kind)
 -> Maybe (HsExpr (GhcPass 'Typechecked), Kind))
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), Kind))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldOcc (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferRecSelId FieldOcc (GhcPass 'Renamed)
f
      HsExpr (GhcPass 'Renamed)
_                       -> Maybe (HsExpr (GhcPass 'Typechecked), Kind)
-> TcM (Maybe (HsExpr (GhcPass 'Typechecked), Kind))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HsExpr (GhcPass 'Typechecked), Kind)
forall a. Maybe a
Nothing

{- *********************************************************************
*                                                                      *
                 Record selectors
*                                                                      *
********************************************************************* -}

tcInferRecSelId :: FieldOcc GhcRn
                -> TcM ( (HsExpr GhcTc, TcSigmaType))
tcInferRecSelId :: FieldOcc (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferRecSelId (FieldOcc XCFieldOcc (GhcPass 'Renamed)
lbl (L SrcSpanAnnN
l Name
sel_name))
     = do { sel_id <- TcM TcTyVar
tc_rec_sel_id
        ; let expr = XXExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall p. XXExpr p -> HsExpr p
XExpr (FieldOcc (GhcPass 'Typechecked) -> XXExprGhcTc
HsRecSelTc (XCFieldOcc (GhcPass 'Typechecked)
-> LIdP (GhcPass 'Typechecked) -> FieldOcc (GhcPass 'Typechecked)
forall pass. XCFieldOcc pass -> LIdP pass -> FieldOcc pass
FieldOcc XCFieldOcc (GhcPass 'Renamed)
XCFieldOcc (GhcPass 'Typechecked)
lbl (SrcSpanAnnN -> TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l TcTyVar
sel_id)))
        ; return $ (expr, idType sel_id)
        }
     where
       occ :: OccName
       occ :: OccName
occ = Name -> OccName
nameOccName Name
sel_name
       tc_rec_sel_id :: TcM TcId
       -- Like tc_infer_id, but returns an Id not a HsExpr,
       -- so we can wrap it back up into a HsRecSel
       tc_rec_sel_id :: TcM TcTyVar
tc_rec_sel_id
         = do { thing <- Name -> TcM TcTyThing
tcLookup Name
sel_name
              ; case thing of
                    ATcId { tct_id :: TcTyThing -> TcTyVar
tct_id = TcTyVar
id }
                      -> do { OccName -> TcTyVar -> TcM ()
check_naughty OccName
occ TcTyVar
id  -- See Note [Local record selectors]
                            ; TcTyVar -> TcM ()
check_local_id TcTyVar
id
                            ; TcTyVar -> TcM TcTyVar
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyVar
id }

                    AGlobal (AnId TcTyVar
id)
                      -> do { OccName -> TcTyVar -> TcM ()
check_naughty OccName
occ TcTyVar
id
                            ; TcTyVar -> TcM TcTyVar
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyVar
id }
                           -- A global cannot possibly be ill-staged
                           -- nor does it need the 'lifting' treatment
                           -- hence no checkTh stuff here

                    TcTyThing
_ -> TcRnMessage -> TcM TcTyVar
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM TcTyVar) -> TcRnMessage -> TcM TcTyVar
forall a b. (a -> b) -> a -> b
$ TcTyThing -> TcRnMessage
TcRnExpectedValueId TcTyThing
thing }

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

-- A type signature on the argument of an ambiguous record selector or
-- the record expression in an update must be "obvious", i.e. the
-- outermost constructor ignoring parentheses.
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig :: HsExpr (GhcPass 'Renamed)
-> Maybe (LHsSigWcType (GhcPass 'Renamed))
obviousSig (ExprWithTySig XExprWithTySig (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
_ LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
ty) = HsWildCardBndrs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
-> Maybe
     (HsWildCardBndrs
        (GhcPass 'Renamed)
        (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))))
forall a. a -> Maybe a
Just LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
HsWildCardBndrs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)))
ty
obviousSig (HsPar XPar (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
p)            = HsExpr (GhcPass 'Renamed)
-> Maybe (LHsSigWcType (GhcPass 'Renamed))
obviousSig (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
p)
obviousSig (HsPragE XPragE (GhcPass 'Renamed)
_ HsPragE (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
p)        = HsExpr (GhcPass 'Renamed)
-> Maybe (LHsSigWcType (GhcPass 'Renamed))
obviousSig (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
p)
obviousSig HsExpr (GhcPass 'Renamed)
_                      = Maybe (LHsSigWcType (GhcPass 'Renamed))
Maybe
  (HsWildCardBndrs
     (GhcPass 'Renamed)
     (GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed))))
forall a. Maybe a
Nothing

-- Extract the outermost TyCon of a type, if there is one; for
-- data families this is the representation tycon (because that's
-- where the fields live).
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf :: FamInstEnvs -> Kind -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs Kind
ty0
  = case HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
tcSplitTyConApp_maybe Kind
ty of
      Just (TyCon
tc, [Kind]
tys) -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just ((TyCon, [Kind], Coercion) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 (FamInstEnvs -> TyCon -> [Kind] -> (TyCon, [Kind], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_inst_envs TyCon
tc [Kind]
tys))
      Maybe (TyCon, [Kind])
Nothing        -> Maybe TyCon
forall a. Maybe a
Nothing
  where
    ([TcTyVar]
_, [Kind]
_, Kind
ty) = Kind -> ([TcTyVar], [Kind], Kind)
tcSplitSigmaTy Kind
ty0

-- Variant of tyConOf that works for ExpTypes
tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET FamInstEnvs
fam_inst_envs ExpRhoType
ty0 = FamInstEnvs -> Kind -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs (Kind -> Maybe TyCon) -> Maybe Kind -> Maybe TyCon
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpRhoType -> Maybe Kind
checkingExpType_maybe ExpRhoType
ty0

{- *********************************************************************
*                                                                      *
                Expressions with a type signature
                        expr :: type
*                                                                      *
********************************************************************* -}

tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
              -> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig :: LHsExpr (GhcPass 'Renamed)
-> LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcExprWithSig LHsExpr (GhcPass 'Renamed)
expr LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty
  = do { sig_info <- TcM TcIdSig -> TcM TcIdSig
forall r. TcM r -> TcM r
checkNoErrs (TcM TcIdSig -> TcM TcIdSig) -> TcM TcIdSig -> TcM TcIdSig
forall a b. (a -> b) -> a -> b
$  -- Avoid error cascade
                     SrcSpan
-> LHsSigWcType (GhcPass 'Renamed) -> Maybe Name -> TcM TcIdSig
tcUserTypeSig SrcSpan
loc LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty Maybe Name
forall a. Maybe a
Nothing
       ; (expr', poly_ty) <- tcExprSig expr sig_info
       ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) }
  where
    loc :: SrcSpan
loc = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA (LHsSigWcType (GhcPass 'Renamed) -> LHsSigType (GhcPass 'Renamed)
forall (p :: Pass).
LHsSigWcType (GhcPass p) -> LHsSigType (GhcPass p)
dropWildCards LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty)

tcExprSig :: LHsExpr GhcRn -> TcIdSig -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig :: LHsExpr (GhcPass 'Renamed)
-> TcIdSig -> TcM (LHsExpr (GhcPass 'Typechecked), Kind)
tcExprSig LHsExpr (GhcPass 'Renamed)
expr (TcCompleteSig TcCompleteSig
sig)
   = do { expr' <- LHsExpr (GhcPass 'Renamed)
-> TcCompleteSig -> TcM (LHsExpr (GhcPass 'Typechecked))
tcPolyLExprSig LHsExpr (GhcPass 'Renamed)
expr TcCompleteSig
sig
        ; return (expr', idType (sig_bndr sig)) }

tcExprSig LHsExpr (GhcPass 'Renamed)
expr sig :: TcIdSig
sig@(TcPartialSig (PSig { psig_name :: TcPartialSig -> Name
psig_name = Name
name, psig_loc :: TcPartialSig -> SrcSpan
psig_loc = SrcSpan
loc }))
  = SrcSpan
-> TcM (LHsExpr (GhcPass 'Typechecked), Kind)
-> TcM (LHsExpr (GhcPass 'Typechecked), Kind)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr (GhcPass 'Typechecked), Kind)
 -> TcM (LHsExpr (GhcPass 'Typechecked), Kind))
-> TcM (LHsExpr (GhcPass 'Typechecked), Kind)
-> TcM (LHsExpr (GhcPass 'Typechecked), Kind)
forall a b. (a -> b) -> a -> b
$   -- Sets the location for the implication constraint
    do { (tclvl, wanted, (expr', sig_inst))
             <- TcM
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
   TcIdSigInst)
-> TcM
     (TcLevel, WantedConstraints,
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
       TcIdSigInst))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints  (TcM
   (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
    TcIdSigInst)
 -> TcM
      (TcLevel, WantedConstraints,
       (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
        TcIdSigInst)))
-> TcM
     (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
      TcIdSigInst)
-> TcM
     (TcLevel, WantedConstraints,
      (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)),
       TcIdSigInst))
forall a b. (a -> b) -> a -> b
$
                do { sig_inst <- TcIdSig -> TcM TcIdSigInst
tcInstSig TcIdSig
sig
                   ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $
                              tcExtendNameTyVarEnv (sig_inst_wcs   sig_inst) $
                              tcCheckPolyExprNC expr (sig_inst_tau sig_inst)
                   ; return (expr', sig_inst) }
       -- See Note [Partial expression signatures]
       ; let tau = TcIdSigInst -> Kind
sig_inst_tau TcIdSigInst
sig_inst
             infer_mode | [Kind] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TcIdSigInst -> [Kind]
sig_inst_theta TcIdSigInst
sig_inst)
                        , Maybe Kind -> Bool
forall a. Maybe a -> Bool
isNothing (TcIdSigInst -> Maybe Kind
sig_inst_wcx TcIdSigInst
sig_inst)
                        = InferMode
ApplyMR
                        | Bool
otherwise
                        = InferMode
NoRestrictions
       ; ((qtvs, givens, ev_binds, _), residual)
           <- captureConstraints $
              simplifyInfer NotTopLevel tclvl infer_mode
                            [sig_inst] [(name, tau)] wanted
       ; emitConstraints residual

       ; tau <- liftZonkM $ zonkTcType tau
       ; let inferred_theta = (TcTyVar -> Kind) -> [TcTyVar] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map TcTyVar -> Kind
evVarPred [TcTyVar]
givens
             tau_tvs        = Kind -> TyCoVarSet
tyCoVarsOfType Kind
tau
       ; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta
                                   tau_tvs qtvs (Just sig_inst)
       ; let inferred_sigma = [TcTyVar] -> [Kind] -> Kind -> Kind
HasDebugCallStack => [TcTyVar] -> [Kind] -> Kind -> Kind
mkInfSigmaTy [TcTyVar]
qtvs [Kind]
inferred_theta Kind
tau
             my_sigma       = [InvisTVBinder] -> Kind -> Kind
mkInvisForAllTys [InvisTVBinder]
binders ([Kind] -> Kind -> Kind
HasDebugCallStack => [Kind] -> Kind -> Kind
mkPhiTy  [Kind]
my_theta Kind
tau)
       ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.
                 then return idHsWrapper  -- Fast path; also avoids complaint when we infer
                                          -- an ambiguous type and have AllowAmbiguousType
                                          -- e..g infer  x :: forall a. F a -> Int
                 else tcSubTypeSigma ExprSigOrigin (ExprSigCtxt NoRRC) inferred_sigma my_sigma

       ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)
       ; let poly_wrap = HsWrapper
wrap
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [TcTyVar] -> HsWrapper
mkWpTyLams [TcTyVar]
qtvs
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [TcTyVar] -> HsWrapper
mkWpEvLams [TcTyVar]
givens
                         HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet  TcEvBinds
ev_binds
       ; return (mkLHsWrap poly_wrap expr', my_sigma) }


{- Note [Partial expression signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Partial type signatures on expressions are easy to get wrong.  But
here is a guiding principle
    e :: ty
should behave like
    let x :: ty
        x = e
    in x

So for partial signatures we apply the MR if no context is given.  So
   e :: IO _          apply the MR
   e :: _ => IO _     do not apply the MR
just like in GHC.Tc.Gen.Bind.decideGeneralisationPlan

This makes a difference (#11670):
   peek :: Ptr a -> IO CLong
   peek ptr = peekElemOff undefined 0 :: _
from (peekElemOff undefined 0) we get
          type: IO w
   constraints: Storable w

We must NOT try to generalise over 'w' because the signature specifies
no constraints so we'll complain about not being able to solve
Storable w.  Instead, don't generalise; then _ gets instantiated to
CLong, as it should.
-}


{- *********************************************************************
*                                                                      *
                 Overloaded literals
*                                                                      *
********************************************************************* -}

tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferOverLit :: HsOverLit (GhcPass 'Renamed)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferOverLit lit :: HsOverLit (GhcPass 'Renamed)
lit@(OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = OverLitVal
val
                            , ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = OverLitRn { ol_rebindable :: OverLitRn -> Bool
ol_rebindable = Bool
rebindable
                                                 , ol_from_fun :: OverLitRn -> LIdP (GhcPass 'Renamed)
ol_from_fun = L SrcSpanAnnN
loc Name
from_name } })
  = -- Desugar "3" to (fromInteger (3 :: Integer))
    --   where fromInteger is gotten by looking up from_name, and
    --   the (3 :: Integer) is returned by mkOverLit
    -- Ditto the string literal "foo" to (fromString ("foo" :: String))
    --
    -- See Note [Typechecking overloaded literals] in GHC.Tc.Gen.Expr
    do { hs_lit <- OverLitVal -> TcM (HsLit (GhcPass 'Typechecked))
mkOverLit OverLitVal
val
       ; from_id <- tcLookupId from_name
       ; (wrap1, from_ty) <- topInstantiate (LiteralOrigin lit) (idType from_id)
       ; let
           thing    = Name -> TypedThing
NameThing Name
from_name
           mb_thing = TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just TypedThing
thing
           herald   = TypedThing -> HsExpr (GhcPass 'Typechecked) -> ExpectedFunTyCtxt
forall (p :: Pass).
Outputable (HsExpr (GhcPass p)) =>
TypedThing -> HsExpr (GhcPass p) -> ExpectedFunTyCtxt
ExpectedFunTyArg TypedThing
thing (XLitE (GhcPass 'Typechecked)
-> HsLit (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE (GhcPass 'Typechecked)
NoExtField
noExtField HsLit (GhcPass 'Typechecked)
hs_lit)
       ; (co2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty

       ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)
       -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast
       ; let lit_expr = SrcSpanAnnA
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnN
loc) (HsExpr (GhcPass 'Typechecked)
 -> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked)))
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall a b. (a -> b) -> a -> b
$ Coercion
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
mkHsWrapCo Coercion
co (HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked))
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall a b. (a -> b) -> a -> b
$
                        XLitE (GhcPass 'Typechecked)
-> HsLit (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE (GhcPass 'Typechecked)
NoExtField
noExtField HsLit (GhcPass 'Typechecked)
hs_lit
             from_expr = HsWrapper
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
mkHsWrap (Coercion -> HsWrapper
mkWpCastN Coercion
co2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1) (HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked))
-> HsExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall a b. (a -> b) -> a -> b
$
                         LIdP (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall (p :: Pass).
IsPass p =>
LIdP (GhcPass p) -> HsExpr (GhcPass p)
mkHsVar (SrcSpanAnnN -> TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TcTyVar
from_id)
             witness = XApp (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> LHsExpr (GhcPass 'Typechecked)
-> HsExpr (GhcPass 'Typechecked)
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp (GhcPass 'Typechecked)
NoExtField
noExtField (SrcSpanAnnA
-> HsExpr (GhcPass 'Typechecked)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a b. (HasLoc a, HasAnnotation b) => a -> b
l2l SrcSpanAnnN
loc) HsExpr (GhcPass 'Typechecked)
from_expr) LHsExpr (GhcPass 'Typechecked)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Typechecked))
lit_expr
             lit' = OverLit { ol_val :: OverLitVal
ol_val = OverLitVal
val
                            , ol_ext :: XOverLit (GhcPass 'Typechecked)
ol_ext = OverLitTc { ol_rebindable :: Bool
ol_rebindable = Bool
rebindable
                                                 , ol_witness :: HsExpr (GhcPass 'Typechecked)
ol_witness = HsExpr (GhcPass 'Typechecked)
witness
                                                 , ol_type :: Kind
ol_type = Kind
res_ty } }
       ; return (HsOverLit noExtField lit', res_ty) }

{- *********************************************************************
*                                                                      *
                 tcInferId, tcCheckId
*                                                                      *
********************************************************************* -}

tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr (GhcPass 'Typechecked))
tcCheckId Name
name ExpRhoType
res_ty
  = do { (expr, actual_res_ty) <- GenLocated SrcSpanAnnN (WithUserRdr Name)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferId (WithUserRdr Name -> GenLocated SrcSpanAnnN (WithUserRdr Name)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (WithUserRdr Name -> GenLocated SrcSpanAnnN (WithUserRdr Name))
-> WithUserRdr Name -> GenLocated SrcSpanAnnN (WithUserRdr Name)
forall a b. (a -> b) -> a -> b
$ Name -> WithUserRdr Name
noUserRdr Name
name)
       ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
       ; addFunResCtxt expr [] actual_res_ty res_ty $
         tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty }
  where
    rn_fun :: HsExpr (GhcPass 'Renamed)
rn_fun = LIdP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall (p :: Pass).
IsPass p =>
LIdP (GhcPass p) -> HsExpr (GhcPass p)
mkHsVar (Name -> GenLocated SrcSpanAnnN Name
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA Name
name)

------------------------
tcInferId :: LocatedN (WithUserRdr Name) -> TcM (HsExpr GhcTc, TcSigmaType)
-- Look up an occurrence of an Id
-- Do not instantiate its type
tcInferId :: GenLocated SrcSpanAnnN (WithUserRdr Name)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferId lname :: GenLocated SrcSpanAnnN (WithUserRdr Name)
lname@(L SrcSpanAnnN
loc (WithUserRdr RdrName
rdr Name
id_name))

  | Name
id_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
assertIdKey
  = -- See Note [Overview of assertions]
    do { dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; if gopt Opt_IgnoreAsserts dflags
         then tc_infer_id lname
         else tc_infer_id (L loc $ WithUserRdr rdr assertErrorName) }

  | Bool
otherwise
  = GenLocated SrcSpanAnnN (WithUserRdr Name)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tc_infer_id GenLocated SrcSpanAnnN (WithUserRdr Name)
lname

tc_infer_id :: LocatedN (WithUserRdr Name) -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id :: GenLocated SrcSpanAnnN (WithUserRdr Name)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tc_infer_id (L SrcSpanAnnN
loc (WithUserRdr RdrName
rdr Name
id_name))
 = do { thing <- Name -> TcM TcTyThing
tcLookup Name
id_name
      ; (expr,ty) <- case thing of
             ATcId { tct_id :: TcTyThing -> TcTyVar
tct_id = TcTyVar
id }
               -> do { TcTyVar -> TcM ()
check_local_id TcTyVar
id
                     ; TcTyVar -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
return_id TcTyVar
id }

             AGlobal (AnId TcTyVar
id) -> TcTyVar -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
return_id TcTyVar
id
               -- A global cannot possibly be ill-staged
               -- nor does it need the 'lifting' treatment
               -- Hence no checkTh stuff here

             AGlobal (AConLike ConLike
cl) -> ConLike -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferConLike ConLike
cl

             (TcTyThing -> Maybe TyCon
tcTyThingTyCon_maybe -> Just TyCon
tc) -> WhatLooking
-> WithUserRdr Name -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a. WhatLooking -> WithUserRdr Name -> TcM a
failIllegalTyCon WhatLooking
WL_Term (RdrName -> Name -> WithUserRdr Name
forall a. RdrName -> a -> WithUserRdr a
WithUserRdr RdrName
rdr (TyCon -> Name
tyConName TyCon
tc))
             ATyVar Name
name TcTyVar
_ -> WithUserRdr Name -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a. WithUserRdr Name -> TcM a
failIllegalTyVar (RdrName -> Name -> WithUserRdr Name
forall a. RdrName -> a -> WithUserRdr a
WithUserRdr RdrName
rdr Name
name)

             TcTyThing
_ -> TcRnMessage -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (HsExpr (GhcPass 'Typechecked), Kind))
-> TcRnMessage -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a b. (a -> b) -> a -> b
$ TcTyThing -> TcRnMessage
TcRnExpectedValueId TcTyThing
thing

       ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
       ; return (expr, ty) }
  where
    return_id :: TcTyVar -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
return_id TcTyVar
id = (HsExpr (GhcPass 'Typechecked), Kind)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LIdP (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall (p :: Pass).
IsPass p =>
LIdP (GhcPass p) -> HsExpr (GhcPass p)
mkHsVar (SrcSpanAnnN -> TcTyVar -> GenLocated SrcSpanAnnN TcTyVar
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TcTyVar
id), TcTyVar -> Kind
idType TcTyVar
id)

{- Note [Overview of assertions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you write (assert pred x) then

  * If `-fignore-asserts` (which sets Opt_IgnoreAsserts) is on, the code is
    typechecked as written, but `assert`, defined in GHC.Internal.Base
       assert _pred r = r
    simply ignores `pred`

  * But without `-fignore-asserts`, GHC rewrites it to (assertError pred e)
    and that is defined in GHC.Internal.IO.Exception as
        assertError :: (?callStack :: CallStack) => Bool -> a -> a
    which does test the predicate and, if it is not True, throws an exception,
    capturing the CallStack.

    This rewrite is done in `tcInferId`.

So `-fignore-asserts` makes the assertion go away altogether, which may be good for
production code.

The reason that `assert` and `assertError` are defined in very different modules
is a historical accident.

Note: the Haddock for `assert` is on `GHC.Internal.Base.assert`, since that is
what appears in the user's source proram.

It's not entirely kosher to rewrite `assert` to `assertError`, because there's no
way to "undo" if you want to see the original source code in the typechecker
output.  We can fix this if it becomes a problem.

Note [Suppress hints with RequiredTypeArguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When a type variable is used at the term level, GHC assumes the user might
have made a typo and suggests a term variable with a similar name.

For example, if the user writes
  f (Proxy :: Proxy nap) (Proxy :: Proxy gap) = nap (+1) [1,2,3]
then GHC will helpfully suggest `map` instead of `nap`
  • Illegal term-level use of the type variable ‘nap’
  • Perhaps use ‘map’ (imported from Prelude)

Importantly, GHC does /not/ suggest `gap`, which is in scope.
Question: How does GHC know not to suggest `gap`?  After all, the edit distance
          between `map`, `nap`, and `gap` is equally short.
Answer: GHC takes the namespace into consideration. `gap` is a `tvName`, and GHC
        would only suggest a `varName` at the term level.

In other words, the current hint infrastructure assumes that the namespace of an
entity is a reliable indicator of its level
   term-level name <=> term-level entity
   type-level name <=> type-level entity

With RequiredTypeArguments, this assumption does not hold. Consider
  bad :: forall a b -> ...
  bad nap gap = nap

This use of `nap` on the RHS is illegal because `nap` stands for a type
variable. It cannot be returned as the result of a function. At the same time,
it is bound as a `varName`, i.e. in the term-level namespace.

Unless we suppress hints, GHC gets awfully confused
    • Illegal term-level use of the variable ‘nap’
    • Perhaps use one of these:
        ‘nap’ (line 2), ‘gap’ (line 2), ‘map’ (imported from Prelude)

GHC shouldn't suggest `gap`, which is also a type variable; using it would
result in the same error. And it especially shouldn't suggest using `nap`
instead of `nap`, which is absurd.

The proper solution is to overhaul the hint system to consider what a name
stands for instead of looking at its namespace alone. This is tracked in #24231.
As a temporary measure, we avoid those potentially misleading hints by
suppressing them entirely if RequiredTypeArguments is in effect.
-}

check_local_id :: Id -> TcM ()
check_local_id :: TcTyVar -> TcM ()
check_local_id TcTyVar
id
  = do { UsageEnv -> TcM ()
tcEmitBindingUsage (UsageEnv -> TcM ()) -> UsageEnv -> TcM ()
forall a b. (a -> b) -> a -> b
$ TcTyVar -> UsageEnv
singleUsageUE TcTyVar
id }

check_naughty :: OccName -> TcId -> TcM ()
check_naughty :: OccName -> TcTyVar -> TcM ()
check_naughty OccName
lbl TcTyVar
id
  | TcTyVar -> Bool
isNaughtyRecordSelector TcTyVar
id = TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (OccName -> TcRnMessage
TcRnRecSelectorEscapedTyVar OccName
lbl)
  | Bool
otherwise                  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

tcInferConLike :: ConLike -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferConLike :: ConLike -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferConLike (RealDataCon DataCon
con) = DataCon -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferDataCon DataCon
con
tcInferConLike (PatSynCon PatSyn
ps)    = PatSyn -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferPatSyn  PatSyn
ps

tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
-- See Note [Typechecking data constructors]
tcInferDataCon :: DataCon -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferDataCon DataCon
con =
  (HsExpr (GhcPass 'Typechecked), Kind)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XXExpr (GhcPass 'Typechecked) -> HsExpr (GhcPass 'Typechecked)
forall p. XXExpr p -> HsExpr p
XExpr (ConLike -> XXExprGhcTc
ConLike -> XXExprGhcTc
ConLikeTc (ConLike -> XXExprGhcTc) -> ConLike -> XXExprGhcTc
forall a b. (a -> b) -> a -> b
$ DataCon -> ConLike
RealDataCon DataCon
con), TcTyVar -> Kind
idType (TcTyVar -> Kind) -> TcTyVar -> Kind
forall a b. (a -> b) -> a -> b
$ DataCon -> TcTyVar
dataConWrapId DataCon
con)

tcInferPatSyn :: PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferPatSyn :: PatSyn -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
tcInferPatSyn PatSyn
ps
  = case PatSyn -> Maybe (HsExpr (GhcPass 'Typechecked), Kind)
patSynBuilderOcc PatSyn
ps of
       Just (HsExpr (GhcPass 'Typechecked)
expr,Kind
ty) -> (HsExpr (GhcPass 'Typechecked), Kind)
-> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr (GhcPass 'Typechecked)
expr,Kind
ty)
       Maybe (HsExpr (GhcPass 'Typechecked), Kind)
Nothing        -> TcRnMessage -> TcM (HsExpr (GhcPass 'Typechecked), Kind)
forall a. TcRnMessage -> TcM a
failWithTc (Name -> TcRnMessage
nonBidirectionalErr (PatSyn -> Name
patSynName PatSyn
ps))

nonBidirectionalErr :: Name -> TcRnMessage
nonBidirectionalErr :: Name -> TcRnMessage
nonBidirectionalErr = Name -> TcRnMessage
Name -> TcRnMessage
TcRnPatSynNotBidirectional

{- Note [Typechecking data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As per Note [Polymorphisation of linear fields] in GHC.Core.Multiplicity, when
we use a data constructor as a term, we want to consider its field to have
polymorphic multiplicities. Note [Data constructors are linear by default] says:

    Just :: a. a %1 -> Maybe a

    data D a = MkD Int a
    MkD :: Int %1 -> a %1 -> D a

but we want:

    Just :: forall {p} a. a %p -> Maybe a
    MkD :: forall {p1} {p2} Int %p1 -> a %p2 -> D a

This is particularly important for partial applications, e.g. 'map Just' or
'map (MkD 3)'. To achieve this, we treat this as a subsumption problem, and
use the subsumption mechanism that exists for typechecking applications.

Here is how it works.  First, a quick refresher on deep subsumption. Given
    f :: Int -> forall a. a -> a
    g :: (forall b. Int -> b -> b) -> ()
consider the application `g f`, where f’s type doesn’t match the type
that `g` expects.  We solve this using deep subsumption, by eta-expanding `f`:
    g (/\b. \x:Int. f x @b)
See Note [Deep subsumption] in GHC.Tc.Utils.Unify)

How does this apply to data constructors?
    data D a = MkD Int a
    MkD :: Int %1 -> a %1 -> D a
    h :: (a -> D a) -> ()
We can typecheck `h (MkD 3)` by saying that
    a %1-> D a   <=    a -> D a

That is, the linear type is "more polymorphic than" the non-linear one.
We can witness this by doing deep subsumption, which generates this:
    h (\ y -> MkD 3 y)
The typing rule for lambda turns the linear arrow on `MkD` into whatever
linearity the caller needs.

However, it's wasteful to introduce a lambda abstraction here: after all,
we are just making up for Note [Data constructors are linear by default]. If
we had given data constructors a multiplicity-polymorphic type from the get go,
we wouldn't have needed to introduce these lambdas. Indeed, introducing lambda
abstractions comes with its own raft of subtle implications (e.g. loss of sharing),
as explained in Note [Desugaring WpFun]. We avoid these issues by generating a
cast instead of a WpFun HsWrapper, using an unsafe coercion which coercions from
One to Many: see the calls to 'mkSubMultFunCo' in 'mkWpFun', and the use of
'OneSubMult' in GHC.Tc.utils.Unify.tc_sub_type_deep.
These coercions only serve to lint the output of the typechecker as per
Note [Linting linearity] in GHC.Core.Lint; these coercions get eliminated during
coercion optimisation (see GHC.Core.Coercion.Opt.opt_univ).

Bottom line: when typechecking a data constructor application, when doing the
subtype check wrt the context of that application, use deep subsumption,
treating linear arrows as if they were multiplicity-polymorphic. You can
see this happening in the 'go_fun' case of GHC.Tc.Utils.Unify.tc_sub_type_deep.

Notice that this is only needed for /partially applied/ data constructors.
Moreover, we only generalise linear fields this way: fields with multiplicity
Many, or other multiplicity expressions are exclusive to -XLinearTypes, hence
don't have backward compatibility implications.

See the LinearEtaExpansions test which contains many tricky test cases, with
commentary.

[Historical note]

  In the original implementation (from GHC 9.0 and up until GHC 9.14), and as
  described in GHC proposal #111, we instead generalised ALL occurrences of
  data constructors, even fully applied occurrences. For example, "Just 3"
  would turn into "(\ x -> Just x) 3", later beta-reduced by the simplifier.

  However, this caused problems, as it was liable to introduce lambda
  abstractions whose binder did not have a fixed runtime representation,
  in particular in conjunction with -XUnliftedNewtypes. For example (#17201):

    {-# LANGUAGE TypeFamilies, UnliftedNewtypes #-}

    type N :: TYPE r -> TYPE r
    newtype N a = MkN a

  Given an expression such as 'MkN False', we would eta-expand 'MkN', which
  resulted in:

    ( ( /\r /\(a :: TYPE r) \(x :: a) -> MkN x ) @LiftedRep @Bool False

  in which the binder (x :: a :: TYPE r) does not have a fixed RuntimeRep
  (see Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). We would then have
  to rely on the simple optimiser beta-reducing this away before it caused
  problems. However, this eta-expansion is completely needless, as MkN
  appears fully saturated.

  See also #17021, a similar example in which the representation is hidden
  under a type family application. In this example, it was even more difficult
  to get the optimiser to take care of the lambda; much better to avoid
  unnecessarily eta-expanding altogether.

  The proposal incorrectly stated that "eta expansion is not sufficient to
  restore backwards compatibility", but this is incorrect: if one does a full
  subtype check like with deep subsumption, then the eta-expansion approach
  works. This did require fixing some bugs in deep subsumption (#26225).
-}

{-
************************************************************************
*                                                                      *
                 Template Haskell checks
*                                                                      *
************************************************************************
-}


{-
Note [Lifting strings]
~~~~~~~~~~~~~~~~~~~~~~
If we see $(... [| s |] ...) where s::String, we don't want to
generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
So this conditional short-circuits the lifting mechanism to generate
(liftString "xy") in that case.  I didn't want to use overlapping instances
for the Lift class in TH.Syntax, because that can lead to overlapping-instance
errors in a polymorphic situation.

If this check fails (which isn't impossible) we get another chance; see
Note [Converting strings] in Convert.hs

Note [Local record selectors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Record selectors for TyCons in this module are ordinary local bindings,
which show up as ATcIds rather than AGlobals.  So we need to check for
naughtiness in both branches.  c.f. GHC.Tc.TyCl.Utils.mkRecSelBinds.

Note [Explicit Level Imports]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This is the overview note which explains the whole implementation of ExplicitLevelImports

GHC Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0682-explicit-level-imports.rst
Paper: https://mpickering.github.io/papers/explicit-level-imports.pdf

The feature is turned on by the `ExplicitLevelImports` extension.
At the source level, the user marks imports with `quote` or `splice` to introduce
them at level 1 or -1.

The function GHC.Tc.Utils.Monad.getCurrentAndBindLevel. computes the levels
at which a Name is available:
  - for top-level Names, this information is stored in its GRE; it is either local
    (level 0) or imported, in which case the levels it is imported at are stored in the
    'ImpDeclSpec's for the GRE. The function 'greLevels' retrieves this information.
  - for locally-bound Names, this information is stored in the ThBindEnv.
GHC.Rename.Splice.checkCrossLevelLifting checks that levels in user-written programs
are correct.

Instances are checked by `checkWellLevelledDFun`, which computes the level of an
instance by calling `checkWellLevelledInstanceWhat`, which sees what is available at by looking at the module graph.

That's it for the main implementation of the feature; the rest is modifications
to the driver parts of the code to use this information. For example, in downsweep,
we only enable code generation for modules needed at the runtime stage.
See Note [-fno-code mode].

-}


{- *********************************************************************
*                                                                      *
         Error reporting for function result mis-matches
*                                                                      *
********************************************************************* -}

addFunResCtxt :: HasDebugCallStack
              => HsExpr GhcTc -> [HsExprArg p]
              -> TcType -> ExpRhoType
              -> TcM a -> TcM a
-- When we have a mis-match in the return type of a function
-- try to give a helpful message about too many/few arguments
-- But not in generated code, where we don't want
-- to mention internal (rebindable syntax) function names
addFunResCtxt :: forall (p :: TcPass) a.
HasDebugCallStack =>
HsExpr (GhcPass 'Typechecked)
-> [HsExprArg p] -> Kind -> ExpRhoType -> TcM a -> TcM a
addFunResCtxt HsExpr (GhcPass 'Typechecked)
fun [HsExprArg p]
args Kind
fun_res_ty ExpRhoType
env_ty TcM a
thing_inside
  = HsCtxt -> TcM a -> TcM a
forall a. HsCtxt -> TcM a -> TcM a
addErrCtxt (HsExpr (GhcPass 'Typechecked)
-> Int -> Kind -> ExpRhoType -> HsCtxt
FunResCtxt HsExpr (GhcPass 'Typechecked)
fun ((HsExprArg p -> Bool) -> [HsExprArg p] -> Int
forall a. (a -> Bool) -> [a] -> Int
count HsExprArg p -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isValArg [HsExprArg p]
args) Kind
fun_res_ty ExpRhoType
env_ty) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    TcM a
thing_inside
      -- NB: use a landmark error context, so that an empty context
      -- doesn't suppress some more useful context

{-
Note [Splitting nested sigma types in mismatched function types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When one applies a function to too few arguments, GHC tries to determine this
fact if possible so that it may give a helpful error message. It accomplishes
this by checking if the type of the applied function has more argument types
than supplied arguments.

Previously, GHC computed the number of argument types through tcSplitSigmaTy.
This is incorrect in the face of nested foralls, however!
This caused Ticket #13311, for instance:

  f :: forall a. (Monoid a) => Int -> forall b. (Monoid b) => Maybe a -> Maybe b

If one uses `f` like so:

  do { f; putChar 'a' }

Then tcSplitSigmaTy will decompose the type of `f` into:

  Tyvars: [a]
  Context: (Monoid a)
  Argument types: []
  Return type: Int -> forall b. Monoid b => Maybe a -> Maybe b

That is, it will conclude that there are *no* argument types, and since `f`
was given no arguments, it won't print a helpful error message. On the other
hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to:

  Tyvars: [a, b]
  Context: (Monoid a, Monoid b)
  Argument types: [Int, Maybe a]
  Return type: Maybe b

So now GHC recognizes that `f` has one more argument type than it was actually
provided.

Notice that tcSplitNestedSigmaTys looks through function arrows too, regardless
of simple/deep subsumption.  Here we are concerned only whether there is a
mis-match in the number of value arguments.
-}