{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE DisambiguateRecordFields #-}

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

module GHC.Tc.Gen.Head
       ( HsExprArg(..), EValArg(..), TcPass(..)
       , AppCtxt(..), appCtxtLoc, insideExpansion
       , splitHsApps, rebuildHsApps
       , addArgWrap, isHsValArg
       , countLeadingValArgs, isVisibleArg, pprHsExprArgTc
       , countVisAndInvisValArgs, countHsWrapperInvisArgs

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

       , addHeadCtxt, addExprCtxt, addFunResCtxt ) where

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

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

import GHC.Tc.Gen.HsType
import GHC.Rename.Unbound     ( unknownNameSuggestions, WhatLooking(..) )

import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan )
import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family ( tcLookupDataFamInst )
import GHC.Core.FamInstEnv    ( FamInstEnvs )
import GHC.Core.UsageEnv      ( singleUsageUE )
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.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Zonk.TcType


import GHC.Core.PatSyn( PatSyn )
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.Var( isInvisibleFunArg )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Error

import GHC.Builtin.Types( multiplicityTy )
import GHC.Builtin.Names
import GHC.Builtin.Names.TH( liftStringName, liftName )

import GHC.Driver.Env
import GHC.Driver.DynFlags
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain

import GHC.Data.Maybe
import Control.Monad



{- *********************************************************************
*                                                                      *
              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 really a 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
      Adds EWrap nodes, the argument type in EValArg,
      and the kind-checked type in ETypeArg

  - 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

Note [EValArg]
~~~~~~~~~~~~~~
The data type EValArg is the payload of the EValArg constructor of
HsExprArg; i.e. a value argument of the application.  EValArg has two
forms:

* ValArg: payload is just the expression itself. Simple.

* ValArgQL: captures the results of applying quickLookArg to the
  argument in a ValArg.  When we later want to typecheck that argument
  we can just carry on from where quick-look left off.  The fields of
  ValArgQL exactly capture what is needed to complete the job.

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 [splitHsApps]
~~~~~~~~~~~~~~~~~~
The key function
  splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, HsExpr GhcRn, [HsExprArg 'TcpRn])
takes apart either an HsApp, or an infix OpApp, returning

* The "head" of the application, an expression that is often a variable;
  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 HsExpanded) 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
-}

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

data HsExprArg (p :: TcPass)
  = -- See Note [HsExprArg]
    EValArg  { forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt   :: AppCtxt
             , forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg    :: EValArg p
             , forall (p :: TcPass). HsExprArg p -> XEVAType p
eva_arg_ty :: !(XEVAType p) }

  | ETypeArg { eva_ctxt  :: AppCtxt
             , forall (p :: TcPass).
HsExprArg p -> LHsToken "@" (GhcPass 'Renamed)
eva_at    :: !(LHsToken "@" GhcRn)
             , forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
eva_hs_ty :: LHsWcType GhcRn  -- The type arg
             , forall (p :: TcPass). HsExprArg p -> XETAType p
eva_ty    :: !(XETAType p) }  -- Kind-checked type arg

  | EPrag    AppCtxt
             (HsPragE (GhcPass (XPass p)))

  | EWrap    EWrap

data EWrap = EPar    AppCtxt
           | EExpand (HsExpr GhcRn)
           | EHsWrap HsWrapper

data EValArg (p :: TcPass) where  -- See Note [EValArg]
  ValArg   :: LHsExpr (GhcPass (XPass p))
           -> EValArg p

  ValArgQL :: { EValArg 'TcpInst -> LHsExpr (GhcPass 'Renamed)
va_expr :: LHsExpr GhcRn        -- Original application
                                                -- For location and error msgs
              , EValArg 'TcpInst -> (HsExpr GhcTc, AppCtxt)
va_fun  :: (HsExpr GhcTc, AppCtxt) -- Function of the application,
                                                   -- typechecked, plus its context
              , EValArg 'TcpInst -> [HsExprArg 'TcpInst]
va_args :: [HsExprArg 'TcpInst] -- Args, instantiated
              , EValArg 'TcpInst -> TcSigmaType
va_ty   :: TcRhoType }          -- Result type
           -> EValArg 'TcpInst  -- Only exists in TcpInst phase

data AppCtxt
  = VAExpansion
       (HsExpr GhcRn)    -- Inside an expansion of this expression
       SrcSpan           -- The SrcSpan of the expression
                         --    noSrcSpan if outermost; see Note [AppCtxt]

  | VACall
       (HsExpr GhcRn) Int  -- In the third argument of function f
       SrcSpan             -- The SrcSpan of the application (f e1 e2 e3)
                         --    noSrcSpan if outermost; see Note [AppCtxt]

{- Note [AppCtxt]
~~~~~~~~~~~~~~~~~
In a call (f e1 ... en), we pair up each argument with an AppCtxt. For
example, the AppCtxt for e3 allows us to say
    "In the third argument of `f`"
See splitHsApps.

To do this we must take a quick look into the expression to find the
function at the head (`f` in this case) and how many arguments it
has. That is what the funcion top_ctxt does.

If the function part is an expansion, we don't want to look further.
For example, with rebindable syntax the expression
    (if e1 then e2 else e3) e4 e5
might expand to
    (ifThenElse e1 e2 e3) e4 e5
For e4 we an AppCtxt that says "In the first argument of (if ...)",
not "In the fourth argument of ifThenElse".  So top_ctxt stops
at expansions.

The SrcSpan in an AppCtxt describes the whole call.  We initialise
it to noSrcSpan, because splitHsApps deals in HsExpr not LHsExpr, so
we don't have a span for the whole call; and we use that noSrcSpan in
GHC.Tc.Gen.App.tcInstFun (set_fun_ctxt) to avoid pushing "In the expression `f`"
a second time.
-}

appCtxtLoc :: AppCtxt -> SrcSpan
appCtxtLoc :: AppCtxt -> SrcSpan
appCtxtLoc (VAExpansion HsExpr (GhcPass 'Renamed)
_ SrcSpan
l) = SrcSpan
l
appCtxtLoc (VACall HsExpr (GhcPass 'Renamed)
_ ThLevel
_ SrcSpan
l)    = SrcSpan
l

insideExpansion :: AppCtxt -> Bool
insideExpansion :: AppCtxt -> Bool
insideExpansion (VAExpansion {}) = Bool
True
insideExpansion (VACall {})      = Bool
False

instance Outputable AppCtxt where
  ppr :: AppCtxt -> SDoc
ppr (VAExpansion HsExpr (GhcPass 'Renamed)
e SrcSpan
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"VAExpansion" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
e
  ppr (VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n SrcSpan
_)    = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"VACall" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThLevel -> SDoc
forall doc. IsLine doc => ThLevel -> doc
int ThLevel
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
f

type family XPass p where
  XPass 'TcpRn   = 'Renamed
  XPass 'TcpInst = 'Renamed
  XPass 'TcpTc   = 'Typechecked

type family XETAType p where  -- Type arguments
  XETAType 'TcpRn = NoExtField
  XETAType _      = Type

type family XEVAType p where  -- Value arguments
  XEVAType 'TcpRn = NoExtField
  XEVAType _      = Scaled Type

mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg :: AppCtxt -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
e = EValArg { eva_arg :: EValArg 'TcpRn
eva_arg = LHsExpr (GhcPass (XPass 'TcpRn)) -> EValArg 'TcpRn
forall (p :: TcPass). LHsExpr (GhcPass (XPass p)) -> EValArg p
ValArg LHsExpr (GhcPass 'Renamed)
LHsExpr (GhcPass (XPass 'TcpRn))
e, eva_ctxt :: AppCtxt
eva_ctxt = AppCtxt
ctxt
                           , eva_arg_ty :: XEVAType 'TcpRn
eva_arg_ty = NoExtField
XEVAType 'TcpRn
noExtField }

mkETypeArg :: AppCtxt -> LHsToken "@" GhcRn -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg :: AppCtxt
-> LHsToken "@" (GhcPass 'Renamed)
-> LHsWcType (GhcPass 'Renamed)
-> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsToken "@" (GhcPass 'Renamed)
at LHsWcType (GhcPass 'Renamed)
hs_ty =
  ETypeArg { eva_ctxt :: AppCtxt
eva_ctxt = AppCtxt
ctxt
           , eva_at :: LHsToken "@" (GhcPass 'Renamed)
eva_at = LHsToken "@" (GhcPass 'Renamed)
at, eva_hs_ty :: LHsWcType (GhcPass 'Renamed)
eva_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty
           , eva_ty :: XETAType 'TcpRn
eva_ty = NoExtField
XETAType 'TcpRn
noExtField }

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

splitHsApps :: HsExpr GhcRn
            -> ( (HsExpr GhcRn, AppCtxt)  -- Head
               , [HsExprArg 'TcpRn])      -- Args
-- See Note [splitHsApps]
splitHsApps :: HsExpr (GhcPass 'Renamed)
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr (GhcPass 'Renamed)
e = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
e (ThLevel -> HsExpr (GhcPass 'Renamed) -> AppCtxt
top_ctxt ThLevel
0 HsExpr (GhcPass 'Renamed)
e) []
  where
    top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt
    -- Always returns VACall fun n_val_args noSrcSpan
    -- to initialise the argument splitting in 'go'
    -- See Note [AppCtxt]
    top_ctxt :: ThLevel -> HsExpr (GhcPass 'Renamed) -> AppCtxt
top_ctxt ThLevel
n (HsPar XPar (GhcPass 'Renamed)
_ LHsToken "(" (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun LHsToken ")" (GhcPass 'Renamed)
_)           = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
forall {l}.
ThLevel -> GenLocated l (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt ThLevel
n LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
fun
    top_ctxt ThLevel
n (HsPragE XPragE (GhcPass 'Renamed)
_ HsPragE (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun)           = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
forall {l}.
ThLevel -> GenLocated l (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt ThLevel
n LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
fun
    top_ctxt ThLevel
n (HsAppType XAppTypeE (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun LHsToken "@" (GhcPass 'Renamed)
_ LHsWcType (NoGhcTc (GhcPass 'Renamed))
_)         = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
forall {l}.
ThLevel -> GenLocated l (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt (ThLevel
nThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ThLevel
1) LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
fun
    top_ctxt ThLevel
n (HsApp XApp (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun LHsExpr (GhcPass 'Renamed)
_)             = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
forall {l}.
ThLevel -> GenLocated l (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt (ThLevel
nThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ThLevel
1) LHsExpr (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
fun
    top_ctxt ThLevel
n (XExpr (HsExpanded HsExpr (GhcPass 'Renamed)
orig HsExpr (GhcPass 'Renamed)
_)) = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
orig      ThLevel
n SrcSpan
noSrcSpan
    top_ctxt ThLevel
n HsExpr (GhcPass 'Renamed)
other_fun                   = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
other_fun ThLevel
n SrcSpan
noSrcSpan

    top_lctxt :: ThLevel -> GenLocated l (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt ThLevel
n (L l
_ HsExpr (GhcPass 'Renamed)
fun) = ThLevel -> HsExpr (GhcPass 'Renamed) -> AppCtxt
top_ctxt ThLevel
n HsExpr (GhcPass 'Renamed)
fun

    go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
       -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
    -- Modify the AppCtxt as we walk inwards, so it describes the next argument
    go :: HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go (HsPar XPar (GhcPass 'Renamed)
_ LHsToken "(" (GhcPass 'Renamed)
_ (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun) LHsToken ")" (GhcPass 'Renamed)
_)       AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
set SrcSpanAnnA
l AppCtxt
ctxt) (EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (AppCtxt -> EWrap
EPar AppCtxt
ctxt)     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))       AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
set SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> HsPragE (GhcPass (XPass 'TcpRn)) -> HsExprArg 'TcpRn
forall (p :: TcPass).
AppCtxt -> HsPragE (GhcPass (XPass p)) -> HsExprArg p
EPrag      AppCtxt
ctxt 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) LHsToken "@" (GhcPass 'Renamed)
at LHsWcType (NoGhcTc (GhcPass 'Renamed))
ty) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt
-> LHsToken "@" (GhcPass 'Renamed)
-> LHsWcType (GhcPass 'Renamed)
-> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsToken "@" (GhcPass 'Renamed)
at 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)       AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg  AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
arg   HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)

    -- See Note [Looking through HsExpanded]
    go (XExpr (HsExpanded HsExpr (GhcPass 'Renamed)
orig HsExpr (GhcPass 'Renamed)
fun)) AppCtxt
ctxt [HsExprArg 'TcpRn]
args
      = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (HsExpr (GhcPass 'Renamed) -> SrcSpan -> AppCtxt
VAExpansion HsExpr (GhcPass 'Renamed)
orig (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt))
               (EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsExpr (GhcPass 'Renamed) -> EWrap
EExpand HsExpr (GhcPass 'Renamed)
orig) HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)

    -- See Note [Desugar OpApp in the typechecker]
    go e :: HsExpr (GhcPass 'Renamed)
e@(OpApp XOpApp (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
arg1 (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
op) LHsExpr (GhcPass 'Renamed)
arg2) AppCtxt
_ [HsExprArg 'TcpRn]
args
      = ( (HsExpr (GhcPass 'Renamed)
op, HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
op ThLevel
0 (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l))
        ,   AppCtxt -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg (HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
op ThLevel
1 SrcSpan
generatedSrcSpan) LHsExpr (GhcPass 'Renamed)
arg1
          HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: AppCtxt -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg (HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
op ThLevel
2 SrcSpan
generatedSrcSpan) LHsExpr (GhcPass 'Renamed)
arg2
          HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsExpr (GhcPass 'Renamed) -> EWrap
EExpand HsExpr (GhcPass 'Renamed)
e)
          HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args )

    go HsExpr (GhcPass 'Renamed)
e AppCtxt
ctxt [HsExprArg 'TcpRn]
args = ((HsExpr (GhcPass 'Renamed)
e,AppCtxt
ctxt), [HsExprArg 'TcpRn]
args)

    set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
    set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
set SrcSpanAnnA
l (VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n SrcSpan
_)        = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
    set SrcSpanAnnA
_ ctxt :: AppCtxt
ctxt@(VAExpansion {}) = AppCtxt
ctxt

    dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt
    dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l (VACall HsExpr (GhcPass 'Renamed)
f ThLevel
n SrcSpan
_)        = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
f (ThLevel
nThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
-ThLevel
1) (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
    dec SrcSpanAnnA
_ ctxt :: AppCtxt
ctxt@(VAExpansion {}) = AppCtxt
ctxt

-- | 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.
--
-- This performs a representation-polymorphism check to ensure that the
-- remaining value arguments in an application have a fixed RuntimeRep.
--
-- See Note [Checking for representation-polymorphic built-ins].
rebuildHsApps :: HsExpr GhcTc
                      -- ^ the function being applied
              -> AppCtxt
              -> [HsExprArg 'TcpTc]
                      -- ^ the arguments to the function
              -> TcRhoType
                      -- ^ result type of the application
              -> TcM (HsExpr GhcTc)
rebuildHsApps :: HsExpr GhcTc
-> AppCtxt
-> [HsExprArg 'TcpTc]
-> TcSigmaType
-> TcM (HsExpr GhcTc)
rebuildHsApps HsExpr GhcTc
fun AppCtxt
ctxt [HsExprArg 'TcpTc]
args TcSigmaType
app_res_rho
  = do { [HsExprArg 'TcpTc] -> TcSigmaType -> HsExpr GhcTc -> TcM ()
HasDebugCallStack =>
[HsExprArg 'TcpTc] -> TcSigmaType -> HsExpr GhcTc -> TcM ()
tcRemainingValArgs [HsExprArg 'TcpTc]
args TcSigmaType
app_res_rho HsExpr GhcTc
fun
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps HsExpr GhcTc
fun AppCtxt
ctxt [HsExprArg 'TcpTc]
args }

-- | The worker function for 'rebuildHsApps': simply rebuilds
-- an application chain in which arguments are specified as
-- typechecked 'HsExprArg's.
rebuild_hs_apps :: HsExpr GhcTc
                      -- ^ the function being applied
              -> AppCtxt
              -> [HsExprArg 'TcpTc]
                      -- ^ the arguments to the function
              -> HsExpr GhcTc
rebuild_hs_apps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps HsExpr GhcTc
fun AppCtxt
_ [] = HsExpr GhcTc
fun
rebuild_hs_apps HsExpr GhcTc
fun AppCtxt
ctxt (HsExprArg 'TcpTc
arg : [HsExprArg 'TcpTc]
args)
  = case HsExprArg 'TcpTc
arg of
      EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = ValArg LHsExpr (GhcPass (XPass 'TcpTc))
arg, eva_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt = AppCtxt
ctxt' }
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
EpAnn NoEpAnns
forall a. EpAnn a
noAnn LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun LHsExpr GhcTc
LHsExpr (GhcPass (XPass 'TcpTc))
arg) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
      ETypeArg { eva_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
eva_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty, eva_at :: forall (p :: TcPass).
HsExprArg p -> LHsToken "@" (GhcPass 'Renamed)
eva_at = LHsToken "@" (GhcPass 'Renamed)
at, eva_ty :: forall (p :: TcPass). HsExprArg p -> XETAType p
eva_ty = XETAType 'TcpTc
ty, eva_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
eva_ctxt = AppCtxt
ctxt' }
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (XAppTypeE GhcTc
-> LHsExpr GhcTc
-> LHsToken "@" GhcTc
-> LHsWcType (NoGhcTc GhcTc)
-> HsExpr GhcTc
forall p.
XAppTypeE p
-> LHsExpr p -> LHsToken "@" p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcTc
XETAType 'TcpTc
ty LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun LHsToken "@" (GhcPass 'Renamed)
LHsToken "@" GhcTc
at LHsWcType (NoGhcTc GhcTc)
LHsWcType (GhcPass 'Renamed)
hs_ty) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
      EPrag AppCtxt
ctxt' HsPragE (GhcPass (XPass 'TcpTc))
p
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (XPragE GhcTc -> HsPragE GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE GhcTc
NoExtField
noExtField HsPragE GhcTc
HsPragE (GhcPass (XPass 'TcpTc))
p LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
      EWrap (EPar AppCtxt
ctxt')
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (LHsExpr GhcTc -> HsExpr GhcTc
forall (id :: Pass). LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
gHsPar LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
      EWrap (EExpand HsExpr (GhcPass 'Renamed)
orig)
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (XXExpr GhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (HsExpansion (HsExpr (GhcPass 'Renamed)) (HsExpr GhcTc)
-> XXExprGhcTc
ExpansionExpr (HsExpr (GhcPass 'Renamed)
-> HsExpr GhcTc
-> HsExpansion (HsExpr (GhcPass 'Renamed)) (HsExpr GhcTc)
forall orig expanded. orig -> expanded -> HsExpansion orig expanded
HsExpanded HsExpr (GhcPass 'Renamed)
orig HsExpr GhcTc
fun))) AppCtxt
ctxt [HsExprArg 'TcpTc]
args
      EWrap (EHsWrap HsWrapper
wrap)
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuild_hs_apps (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
fun) AppCtxt
ctxt [HsExprArg 'TcpTc]
args
  where
    lfun :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun = SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan (SrcSpan -> SrcSpanAnnA) -> SrcSpan -> SrcSpanAnnA
forall a b. (a -> b) -> a -> b
$ AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt) HsExpr GhcTc
fun

{- Note [Checking for representation-polymorphic built-ins]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We cannot have representation-polymorphic or levity-polymorphic
function arguments. See Note [Representation polymorphism invariants]
in GHC.Core.  That is checked by the calls to `hasFixedRuntimeRep` in
`tcEValArg`.

But some /built-in/ functions have representation-polymorphic argument
types. Users can't define such Ids; they are all GHC built-ins or data
constructors.  Specifically they are:

1. A few wired-in Ids such as coerce and unsafeCoerce#,
2. Primops, such as raise#.
3. Newtype constructors with `UnliftedNewtypes` which have
   a representation-polymorphic argument.
4. Representation-polymorphic data constructors: unboxed tuples
   and unboxed sums.

For (1) consider
  badId :: forall r (a :: TYPE r). a -> a
  badId = unsafeCoerce# @r @r @a @a

The wired-in function
  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                   (a :: TYPE r1) (b :: TYPE r2).
                   a -> b
has a convenient but representation-polymorphic type. It has no
binding; instead it has a compulsory unfolding, after which we
would have
  badId = /\r /\(a :: TYPE r). \(x::a). ...body of unsafeCorece#...
And this is no good because of that rep-poly \(x::a).  So we want
to reject this.

On the other hand
  goodId :: forall (a :: Type). a -> a
  goodId = unsafeCoerce# @LiftedRep @LiftedRep @a @a

is absolutely fine, because after we inline the unfolding, the \(x::a)
is representation-monomorphic.

Test cases: T14561, RepPolyWrappedVar2.

For primops (2) the situation is similar; they are eta-expanded in
CorePrep to be saturated, and that eta-expansion must not add a
representation-polymorphic lambda.

Test cases: T14561b, RepPolyWrappedVar, UnliftedNewtypesCoerceFail.

For (3), consider a representation-polymorphic newtype with
UnliftedNewtypes:

  type Id :: forall r. TYPE r -> TYPE r
  newtype Id a where { MkId :: a }

  bad :: forall r (a :: TYPE r). a -> Id a
  bad = MkId @r @a             -- Want to reject

  good :: forall (a :: Type). a -> Id a
  good = MkId @LiftedRep @a   -- Want to accept

Test cases: T18481, UnliftedNewtypesLevityBinder

So these cases need special treatment. We add a special case
in tcApp to check whether an application of an Id has any remaining
representation-polymorphic arguments, after instantiation and application
of previous arguments.  This is achieved by the tcRemainingValArgs
function, which computes the types of the remaining value arguments, and checks
that each of these have a fixed runtime representation.

Note that this function also ensures that data constructors always
appear saturated, by performing eta-expansion if necessary.
See Note [Typechecking data constructors].

Wrinkle [Arity]

  We don't want to check for arguments past the arity of the function.

  For example

      raise# :: forall {r :: RuntimeRep} (a :: Type) (b :: TYPE r). a -> b

  has arity 1, so an instantiation such as:

      foo :: forall w r (z :: TYPE r). w -> z -> z
      foo = raise# @w @(z -> z)

  is unproblematic.  This means we must take care not to perform a
  representation-polymorphism check on `z`.

  To achieve this, we consult the arity of the 'Id' which is the head
  of the application (or just use 1 for a newtype constructor),
  and keep track of how many value-level arguments we have seen,
  to ensure we stop checking once we reach the arity.
  This is slightly complicated by the need to include both visible
  and invisible arguments, as the arity counts both:
  see GHC.Tc.Gen.Head.countVisAndInvisValArgs.

  Test cases: T20330{a,b}

Wrinkle [Syntactic check]

  We only perform a syntactic check in tcRemainingValArgs. That is,
  we will reject partial applications such as:

    type RR :: RuntimeREp
    type family RR where { RR = IntRep }
    type T :: TYPE RR
    type family T where { T = Int# }

    (# , #) @LiftedRep @RR e1

  Why do we reject? Wee would need to elaborate this partial application
  of (# , #) as follows:

    let x1 = e1
    in
      ( \ @(ty2 :: TYPE RR) (x2 :: ty2 |> TYPE RR[0])
      -> ( ( (# , #) @LiftedRep @RR @Char @ty2 x1 ) |> co1 )
           x2
      ) |> co2

  That is, we need to cast the partial application

    (# , #) @LiftedRep @RR @Char @ty2 x1

  so that the next argument we provide to it has a fixed RuntimeRep,
  and then eta-expand it. This is quite tricky, and other parts
  of the compiler aren't set up to handle this mix of applications
  and casts (e.g. checkCanEtaExpand in GHC.Core.Lint).

  So we refrain from doing so, and instead limit ourselves to a simple syntactic
  check. See the wiki page https://gitlab.haskell.org/ghc/ghc/-/wikis/Remaining-ValArgs
  for a more in-depth discussion.
-}

-- | Typecheck the remaining value arguments in a partial application,
-- ensuring they have a fixed RuntimeRep in the sense of Note [Fixed RuntimeRep]
-- in GHC.Tc.Utils.Concrete.
--
-- Example:
--
-- > repPolyId :: forall r (a :: TYPE r). a -> a
-- > repPolyId = coerce
--
-- This is an invalid instantiation of 'coerce', as we can't eta expand it
-- to
--
-- > \@r \@(a :: TYPE r) (x :: a) -> coerce @r @a @a x
--
-- because the binder `x` does not have a fixed runtime representation.
tcRemainingValArgs :: HasDebugCallStack
                   => [HsExprArg 'TcpTc]
                   -> TcRhoType
                   -> HsExpr GhcTc
                   -> TcM ()
tcRemainingValArgs :: HasDebugCallStack =>
[HsExprArg 'TcpTc] -> TcSigmaType -> HsExpr GhcTc -> TcM ()
tcRemainingValArgs [HsExprArg 'TcpTc]
applied_args TcSigmaType
app_res_rho HsExpr GhcTc
fun = case HsExpr GhcTc
fun of

  HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Var
fun_id)

    -- (1): unsafeCoerce#
    -- 'unsafeCoerce#' is peculiar: it is patched in manually as per
    -- Note [Wiring in unsafeCoerce#] in GHC.HsToCore.
    -- Unfortunately, even though its arity is set to 1 in GHC.HsToCore.mkUnsafeCoercePrimPair,
    -- at this stage, if we query idArity, we get 0. This is because
    -- we end up looking at the non-patched version of unsafeCoerce#
    -- defined in Unsafe.Coerce, and that one indeed has arity 0.
    --
    -- We thus manually specify the correct arity of 1 here.
    | Var -> Name
idName Var
fun_id Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unsafeCoercePrimName
    -> ThLevel -> RepPolyFun -> TcM ()
tc_remaining_args ThLevel
1 (Var -> RepPolyFun
RepPolyWiredIn Var
fun_id)

    -- (2): primops and other wired-in representation-polymorphic functions,
    -- such as 'rightSection', 'oneShot', etc; see bindings with Compulsory unfoldings
    -- in GHC.Types.Id.Make
    | Name -> Bool
isWiredInName (Var -> Name
idName Var
fun_id) Bool -> Bool -> Bool
&& Var -> Bool
hasNoBinding Var
fun_id
    -> ThLevel -> RepPolyFun -> TcM ()
tc_remaining_args (Var -> ThLevel
idArity Var
fun_id) (Var -> RepPolyFun
RepPolyWiredIn Var
fun_id)
       -- NB: idArity consults the IdInfo of the Id. This can be a problem
       -- in the presence of hs-boot files, as we might not have finished
       -- typechecking; inspecting the IdInfo at this point can cause
       -- strange Core Lint errors (see #20447).
       -- We avoid this entirely by only checking wired-in names,
       -- as those are the only ones this check is applicable to anyway.

  XExpr (ConLikeTc (RealDataCon DataCon
con) [Var]
_ [Scaled TcSigmaType]
_)
    -- (3): Representation-polymorphic newtype constructors.
    | DataCon -> Bool
isNewDataCon DataCon
con
    -- (4): Unboxed tuples and unboxed sums
    Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedTupleDataCon DataCon
con
    Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con
    -> ThLevel -> RepPolyFun -> TcM ()
tc_remaining_args (DataCon -> ThLevel
dc_val_arity DataCon
con) (DataCon -> RepPolyFun
RepPolyDataCon DataCon
con)

  HsExpr GhcTc
_ -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  where

    dc_val_arity :: DataCon -> Arity
    dc_val_arity :: DataCon -> ThLevel
dc_val_arity DataCon
con = (TcSigmaType -> Bool) -> [TcSigmaType] -> ThLevel
forall a. (a -> Bool) -> [a] -> ThLevel
count (Bool -> Bool
not (Bool -> Bool) -> (TcSigmaType -> Bool) -> TcSigmaType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcSigmaType -> Bool
isEqPrimPred) (DataCon -> [TcSigmaType]
dataConTheta DataCon
con)
                     ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ [TcSigmaType] -> ThLevel
forall a. [a] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length (DataCon -> [TcSigmaType]
dataConStupidTheta DataCon
con)
                     ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ DataCon -> ThLevel
dataConSourceArity DataCon
con
      -- Count how many value-level arguments this data constructor expects:
      --    - dictionary arguments from the context (including the stupid context),
      --    - source value arguments.
      -- Tests: EtaExpandDataCon, EtaExpandStupid{1,2}.

    nb_applied_vis_val_args :: Int
    nb_applied_vis_val_args :: ThLevel
nb_applied_vis_val_args = (HsExprArg 'TcpTc -> Bool) -> [HsExprArg 'TcpTc] -> ThLevel
forall a. (a -> Bool) -> [a] -> ThLevel
count HsExprArg 'TcpTc -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg [HsExprArg 'TcpTc]
applied_args

    nb_applied_val_args :: Int
    nb_applied_val_args :: ThLevel
nb_applied_val_args = [HsExprArg 'TcpTc] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg 'TcpTc]
applied_args

    tc_remaining_args :: Arity -> RepPolyFun -> TcM ()
    tc_remaining_args :: ThLevel -> RepPolyFun -> TcM ()
tc_remaining_args ThLevel
arity RepPolyFun
rep_poly_fun =
      ThLevel -> ThLevel -> [(Scaled TcSigmaType, FunTyFlag)] -> TcM ()
tc_rem_args
        (ThLevel
nb_applied_vis_val_args ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ ThLevel
1)
        (ThLevel
nb_applied_val_args ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ ThLevel
1)
        [(Scaled TcSigmaType, FunTyFlag)]
rem_arg_tys

      where

      rem_arg_tys :: [(Scaled Type, FunTyFlag)]
      rem_arg_tys :: [(Scaled TcSigmaType, FunTyFlag)]
rem_arg_tys = TcSigmaType -> [(Scaled TcSigmaType, FunTyFlag)]
getRuntimeArgTys TcSigmaType
app_res_rho
        -- We do not need to zonk app_res_rho first, because the number of arrows
        -- in the (possibly instantiated) inferred type of the function will
        -- be at least the arity of the function.

      -- The following function is essentially "mapM hasFixedRuntimeRep rem_arg_tys",
      -- but we need to keep track of indices for error messages, hence the manual recursion.
      tc_rem_args :: Int
                     -- visible value argument index, starting from 1
                     -- (only used to report the argument position in error messages)
                  -> Int
                     -- value argument index, starting from 1
                     -- used to count up to the arity to ensure that
                     -- we don't check too many argument types
                  -> [(Scaled Type, FunTyFlag)]
                     -- run-time argument types
                  -> TcM ()
      tc_rem_args :: ThLevel -> ThLevel -> [(Scaled TcSigmaType, FunTyFlag)] -> TcM ()
tc_rem_args ThLevel
_ ThLevel
i_val [(Scaled TcSigmaType, FunTyFlag)]
_
        | ThLevel
i_val ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ThLevel
arity
        = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      tc_rem_args ThLevel
_ ThLevel
_ []
        -- Should never happen: it would mean that the arity is higher
        -- than the number of arguments apparent from the type.
        = String -> SDoc -> TcM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcRemainingValArgs" SDoc
debug_msg
      tc_rem_args ThLevel
i_visval !ThLevel
i_val ((Scaled TcSigmaType
_ TcSigmaType
arg_ty, FunTyFlag
af) : [(Scaled TcSigmaType, FunTyFlag)]
tys)
        = do { let (ThLevel
i_visval', ArgPos
arg_pos)
                     | FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af = ( ThLevel
i_visval    , ArgPos
ArgPosInvis )
                     | Bool
otherwise            = ( ThLevel
i_visval ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ ThLevel
1, ThLevel -> ArgPos
ArgPosVis ThLevel
i_visval )
                   frr_ctxt :: FixedRuntimeRepContext
frr_ctxt = RepPolyFun -> ArgPos -> FixedRuntimeRepContext
FRRNoBindingResArg RepPolyFun
rep_poly_fun ArgPos
arg_pos
             ; HasDebugCallStack =>
FixedRuntimeRepContext -> TcSigmaType -> TcM ()
FixedRuntimeRepContext -> TcSigmaType -> TcM ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
frr_ctxt TcSigmaType
arg_ty
                 -- Why is this a syntactic check? See Wrinkle [Syntactic check] in
                 -- Note [Checking for representation-polymorphic built-ins].
             ; ThLevel -> ThLevel -> [(Scaled TcSigmaType, FunTyFlag)] -> TcM ()
tc_rem_args ThLevel
i_visval' (ThLevel
i_val ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ ThLevel
1) [(Scaled TcSigmaType, FunTyFlag)]
tys }

      debug_msg :: SDoc
      debug_msg :: SDoc
debug_msg =
        [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
          [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"app_head =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
fun
          , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arity =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThLevel
arity
          , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"applied_args =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsExprArg 'TcpTc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpTc]
applied_args
          , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"nb_applied_val_args =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ThLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThLevel
nb_applied_val_args ]


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

countLeadingValArgs :: [HsExprArg id] -> Int
countLeadingValArgs :: forall (id :: TcPass). [HsExprArg id] -> ThLevel
countLeadingValArgs []                   = ThLevel
0
countLeadingValArgs (EValArg {}  : [HsExprArg id]
args) = ThLevel
1 ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countLeadingValArgs [HsExprArg id]
args
countLeadingValArgs (EWrap {}    : [HsExprArg id]
args) = [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countLeadingValArgs [HsExprArg id]
args
countLeadingValArgs (EPrag {}    : [HsExprArg id]
args) = [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countLeadingValArgs [HsExprArg id]
args
countLeadingValArgs (ETypeArg {} : [HsExprArg id]
_)    = ThLevel
0

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

-- | Count visible and invisible value arguments in a list
-- of 'HsExprArg' arguments.
countVisAndInvisValArgs :: [HsExprArg id] -> Arity
countVisAndInvisValArgs :: forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs []                  = ThLevel
0
countVisAndInvisValArgs (EValArg {} : [HsExprArg id]
args) = ThLevel
1 ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args
countVisAndInvisValArgs (EWrap EWrap
wrap : [HsExprArg id]
args) =
  case EWrap
wrap of { EHsWrap HsWrapper
hsWrap            -> HsWrapper -> ThLevel
countHsWrapperInvisArgs HsWrapper
hsWrap ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args
               ; EPar   {}                 -> [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args
               ; EExpand {}                -> [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args }
countVisAndInvisValArgs (EPrag {}   : [HsExprArg id]
args) = [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args
countVisAndInvisValArgs (ETypeArg {}: [HsExprArg id]
args) = [HsExprArg id] -> ThLevel
forall (id :: TcPass). [HsExprArg id] -> ThLevel
countVisAndInvisValArgs [HsExprArg id]
args

-- | Counts the number of invisible term-level arguments applied by an 'HsWrapper'.
-- Precondition: this wrapper contains no abstractions.
countHsWrapperInvisArgs :: HsWrapper -> Arity
countHsWrapperInvisArgs :: HsWrapper -> ThLevel
countHsWrapperInvisArgs = HsWrapper -> ThLevel
forall {a}. Num a => HsWrapper -> a
go
  where
    go :: HsWrapper -> a
go HsWrapper
WpHole = a
0
    go (WpCompose HsWrapper
wrap1 HsWrapper
wrap2) = HsWrapper -> a
go HsWrapper
wrap1 a -> a -> a
forall a. Num a => a -> a -> a
+ HsWrapper -> a
go HsWrapper
wrap2
    go fun :: HsWrapper
fun@(WpFun {}) = HsWrapper -> a
forall {a} {a}. Outputable a => a -> a
nope HsWrapper
fun
    go (WpCast {}) = a
0
    go evLam :: HsWrapper
evLam@(WpEvLam {}) = HsWrapper -> a
forall {a} {a}. Outputable a => a -> a
nope HsWrapper
evLam
    go (WpEvApp EvTerm
_) = a
1
    go tyLam :: HsWrapper
tyLam@(WpTyLam {}) = HsWrapper -> a
forall {a} {a}. Outputable a => a -> a
nope HsWrapper
tyLam
    go (WpTyApp TcSigmaType
_) = a
0
    go (WpLet TcEvBinds
_) = a
0
    go (WpMultCoercion {}) = a
0

    nope :: a -> a
nope a
x = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"countHsWrapperInvisApps" (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x)

instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
  ppr :: HsExprArg p -> SDoc
ppr (EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = EValArg p
arg })      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> EValArg p -> SDoc
forall a. Outputable a => a -> SDoc
ppr EValArg p
arg
  ppr (EPrag AppCtxt
_ 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 { eva_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
eva_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

instance Outputable EWrap where
  ppr :: EWrap -> SDoc
ppr (EPar AppCtxt
_)       = 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 HsExpr (GhcPass 'Renamed)
orig) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EExpand" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
orig

instance OutputableBndrId (XPass p) => Outputable (EValArg p) where
  ppr :: EValArg p -> SDoc
ppr (ValArg LHsExpr (GhcPass (XPass p))
e) = GenLocated SrcSpanAnnA (HsExpr (GhcPass (XPass p))) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr (GhcPass (XPass p))
GenLocated SrcSpanAnnA (HsExpr (GhcPass (XPass p)))
e
  ppr (ValArgQL { va_fun :: EValArg 'TcpInst -> (HsExpr GhcTc, AppCtxt)
va_fun = (HsExpr GhcTc, AppCtxt)
fun, va_args :: EValArg 'TcpInst -> [HsExprArg 'TcpInst]
va_args = [HsExprArg 'TcpInst]
args, va_ty :: EValArg 'TcpInst -> TcSigmaType
va_ty = TcSigmaType
ty})
    = SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ValArgQL" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (HsExpr GhcTc, AppCtxt) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr GhcTc, AppCtxt)
fun)
         ThLevel
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
"va_ty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty ])

pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc
pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc
pprHsExprArgTc (EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = EValArg 'TcpInst
tm, eva_arg_ty :: forall (p :: TcPass). HsExprArg p -> XEVAType p
eva_arg_ty = XEVAType 'TcpInst
ty })
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"EValArg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> ThLevel -> SDoc -> SDoc
hang (EValArg 'TcpInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr EValArg 'TcpInst
tm) ThLevel
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Scaled TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr Scaled TcSigmaType
XEVAType 'TcpInst
ty)
pprHsExprArgTc HsExprArg 'TcpInst
arg = HsExprArg 'TcpInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExprArg 'TcpInst
arg

{- 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 HsExpanded.
That makes it possible to typecheck something like
     e1 `f` e2
where
   f :: forall a. t1 -> forall b. t2 -> t3

Note [Looking through HsExpanded]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When creating an application chain in splitHsApps, we must deal with
     HsExpanded f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3

as a single application chain `f e1 e2 e3`.  Otherwise stuff like overloaded
labels (#19154) won't work.

It's easy to achieve this: `splitHsApps` unwraps `HsExpanded`.
-}

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

tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
               -> [HsExprArg 'TcpRn]
               -> 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)
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
--
-- Why do we need the arguments to infer the type of the head of the
-- application? Simply to inform add_head_ctxt about whether or not
-- to put push a new "In the expression..." context. (We don't push a
-- new one if there are no arguments, because we already have.)
--
-- 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), AppCtxt)
-> [HsExprArg 'TcpRn] -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead (HsExpr (GhcPass 'Renamed)
fun,AppCtxt
ctxt) [HsExprArg 'TcpRn]
args
  = AppCtxt
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a. AppCtxt -> TcM a -> TcM a
addHeadCtxt AppCtxt
ctxt (TcM (HsExpr GhcTc, TcSigmaType)
 -> TcM (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
    do { Maybe (HsExpr GhcTc, TcSigmaType)
mb_tc_fun <- HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args
       ; case Maybe (HsExpr GhcTc, TcSigmaType)
mb_tc_fun of
            Just (HsExpr GhcTc
fun', TcSigmaType
fun_sigma) -> (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
fun', TcSigmaType
fun_sigma)
            Maybe (HsExpr GhcTc, TcSigmaType)
Nothing -> (ExpRhoType -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a. (ExpRhoType -> TcM a) -> TcM (a, TcSigmaType)
tcInfer (HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr (GhcPass 'Renamed)
fun) }

tcInferAppHead_maybe :: HsExpr GhcRn
                     -> [HsExprArg 'TcpRn]
                     -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
-- Returns Nothing for a complicated head
tcInferAppHead_maybe :: HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args
  = case HsExpr (GhcPass 'Renamed)
fun of
      HsVar XVar (GhcPass 'Renamed)
_ (L SrcSpanAnnN
_ Name
nm)          -> (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
nm
      HsRecSel XRecSel (GhcPass 'Renamed)
_ FieldOcc (GhcPass 'Renamed)
f              -> (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldOcc (GhcPass 'Renamed) -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId FieldOcc (GhcPass 'Renamed)
f
      ExprWithTySig XExprWithTySig (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty   -> (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr (GhcPass 'Renamed)
-> LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
-> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty
      HsOverLit XOverLitE (GhcPass 'Renamed)
_ HsOverLit (GhcPass 'Renamed)
lit           -> (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsOverLit (GhcPass 'Renamed) -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferOverLit HsOverLit (GhcPass 'Renamed)
lit
      HsUntypedSplice (HsUntypedSpliceTop ThModFinalizers
_ HsExpr (GhcPass 'Renamed)
e) HsUntypedSplice (GhcPass 'Renamed)
_
                                -> HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
e [HsExprArg 'TcpRn]
args
      HsExpr (GhcPass 'Renamed)
_                         -> Maybe (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HsExpr GhcTc, TcSigmaType)
forall a. Maybe a
Nothing

addHeadCtxt :: AppCtxt -> TcM a -> TcM a
addHeadCtxt :: forall a. AppCtxt -> TcM a -> TcM a
addHeadCtxt AppCtxt
fun_ctxt TcM a
thing_inside
  | Bool -> Bool
not (SrcSpan -> Bool
isGoodSrcSpan SrcSpan
fun_loc)   -- noSrcSpan => no arguments
  = TcM a
thing_inside                  -- => context is already set
  | Bool
otherwise
  = SrcSpan -> TcM a -> TcM a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
fun_loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
    case AppCtxt
fun_ctxt of
      VAExpansion HsExpr (GhcPass 'Renamed)
orig SrcSpan
_ -> HsExpr (GhcPass 'Renamed) -> TcM a -> TcM a
forall a. HsExpr (GhcPass 'Renamed) -> TcRn a -> TcRn a
addExprCtxt HsExpr (GhcPass 'Renamed)
orig TcM a
thing_inside
      VACall {}          -> TcM a
thing_inside
  where
    fun_loc :: SrcSpan
fun_loc = AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
fun_ctxt

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

tcInferRecSelId :: FieldOcc GhcRn
                -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId :: FieldOcc (GhcPass 'Renamed) -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId (FieldOcc XCFieldOcc (GhcPass 'Renamed)
sel_name XRec (GhcPass 'Renamed) RdrName
lbl)
   = do { Var
sel_id <- TcM Var
tc_rec_sel_id
        ; let expr :: HsExpr GhcTc
expr = XRecSel GhcTc -> FieldOcc GhcTc -> HsExpr GhcTc
forall p. XRecSel p -> FieldOcc p -> HsExpr p
HsRecSel XRecSel GhcTc
NoExtField
noExtField (XCFieldOcc GhcTc -> XRec GhcTc RdrName -> FieldOcc GhcTc
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc XCFieldOcc GhcTc
Var
sel_id XRec (GhcPass 'Renamed) RdrName
XRec GhcTc RdrName
lbl)
        ; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, Var -> TcSigmaType
idType Var
sel_id)
        }
     where
       occ :: OccName
       occ :: OccName
occ = RdrName -> OccName
rdrNameOcc (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc XRec (GhcPass 'Renamed) RdrName
GenLocated SrcSpanAnnN RdrName
lbl)

       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 Var
tc_rec_sel_id
         = do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup XCFieldOcc (GhcPass 'Renamed)
Name
sel_name
              ; case TcTyThing
thing of
                    ATcId { tct_id :: TcTyThing -> Var
tct_id = Var
id }
                      -> do { OccName -> Var -> TcM ()
check_naughty OccName
occ Var
id  -- See Note [Local record selectors]
                            ; Var -> TcM ()
check_local_id Var
id
                            ; Var -> TcM Var
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Var
id }

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

                    TcTyThing
_ -> TcRnMessage -> TcM Var
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM Var) -> TcRnMessage -> TcM Var
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)
_ LHsToken "(" (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
p LHsToken ")" (GhcPass 'Renamed)
_)        = 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 -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcSigmaType
ty0
  = case HasDebugCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty of
      Just (TyCon
tc, [TcSigmaType]
tys) -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just ((TyCon, [TcSigmaType], Coercion) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 (FamInstEnvs
-> TyCon -> [TcSigmaType] -> (TyCon, [TcSigmaType], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_inst_envs TyCon
tc [TcSigmaType]
tys))
      Maybe (TyCon, [TcSigmaType])
Nothing        -> Maybe TyCon
forall a. Maybe a
Nothing
  where
    ([Var]
_, [TcSigmaType]
_, TcSigmaType
ty) = TcSigmaType -> ([Var], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
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 -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs (TcSigmaType -> Maybe TyCon) -> Maybe TcSigmaType -> Maybe TyCon
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpRhoType -> Maybe TcSigmaType
checkingExpType_maybe ExpRhoType
ty0

fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage
fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage
fieldNotInType RecSelParent
p RdrName
rdr
  = RdrName -> NotInScopeError -> TcRnMessage
mkTcRnNotInScope RdrName
rdr (NotInScopeError -> TcRnMessage) -> NotInScopeError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$
    SDoc -> NotInScopeError
UnknownSubordinate (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"field of type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (RecSelParent -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecSelParent
p))


{- *********************************************************************
*                                                                      *
                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 GhcTc, TcSigmaType)
tcExprWithSig LHsExpr (GhcPass 'Renamed)
expr LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty
  = do { TcIdSigInfo
sig_info <- TcM TcIdSigInfo -> TcM TcIdSigInfo
forall r. TcM r -> TcM r
checkNoErrs (TcM TcIdSigInfo -> TcM TcIdSigInfo)
-> TcM TcIdSigInfo -> TcM TcIdSigInfo
forall a b. (a -> b) -> a -> b
$  -- Avoid error cascade
                     SrcSpan
-> LHsSigWcType (GhcPass 'Renamed) -> Maybe Name -> TcM TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty Maybe Name
forall a. Maybe a
Nothing
       ; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcSigmaType
poly_ty) <- UserTypeCtxt
-> LHsExpr (GhcPass 'Renamed)
-> TcIdSigInfo
-> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig UserTypeCtxt
ctxt LHsExpr (GhcPass 'Renamed)
expr TcIdSigInfo
sig_info
       ; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XExprWithTySig GhcTc
-> LHsExpr GhcTc -> LHsSigWcType (NoGhcTc GhcTc) -> HsExpr GhcTc
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcTc
NoExtField
noExtField LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (NoGhcTc GhcTc)
hs_ty, TcSigmaType
poly_ty) }
  where
    loc :: SrcSpan
loc = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (LHsSigWcType (GhcPass 'Renamed) -> LHsSigType (GhcPass 'Renamed)
forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty)
    ctxt :: UserTypeCtxt
ctxt = ReportRedundantConstraints -> UserTypeCtxt
ExprSigCtxt (LHsSigWcType (GhcPass 'Renamed) -> ReportRedundantConstraints
lhsSigWcTypeContextSpan LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty)

tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig :: UserTypeCtxt
-> LHsExpr (GhcPass 'Renamed)
-> TcIdSigInfo
-> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig UserTypeCtxt
ctxt LHsExpr (GhcPass 'Renamed)
expr (CompleteSig { sig_bndr :: TcIdSigInfo -> Var
sig_bndr = Var
poly_id, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
  = SrcSpan
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc, TcSigmaType)
 -> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$   -- Sets the location for the implication constraint
    do { let poly_ty :: TcSigmaType
poly_ty = Var -> TcSigmaType
idType Var
poly_id
       ; (HsWrapper
wrap, GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr') <- UserTypeCtxt
-> TcSigmaType
-> (TcSigmaType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (HsWrapper, GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall result.
UserTypeCtxt
-> TcSigmaType
-> (TcSigmaType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseScoped UserTypeCtxt
ctxt TcSigmaType
poly_ty ((TcSigmaType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
 -> TcM (HsWrapper, GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> (TcSigmaType -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (HsWrapper, GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$ \TcSigmaType
rho_ty ->
                          LHsExpr (GhcPass 'Renamed) -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr (GhcPass 'Renamed)
expr TcSigmaType
rho_ty
       ; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcSigmaType)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcSigmaType
poly_ty) }

tcExprSig UserTypeCtxt
_ LHsExpr (GhcPass 'Renamed)
expr sig :: TcIdSigInfo
sig@(PartialSig { psig_name :: TcIdSigInfo -> Name
psig_name = Name
name, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
  = SrcSpan
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc, TcSigmaType)
 -> TcM (LHsExpr GhcTc, TcSigmaType))
-> TcM (LHsExpr GhcTc, TcSigmaType)
-> TcM (LHsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$   -- Sets the location for the implication constraint
    do { (TcLevel
tclvl, WantedConstraints
wanted, (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcIdSigInst
sig_inst))
             <- TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
-> TcM
     (TcLevel, WantedConstraints,
      (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints  (TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
 -> TcM
      (TcLevel, WantedConstraints,
       (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
-> TcM
     (TcLevel, WantedConstraints,
      (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst))
forall a b. (a -> b) -> a -> b
$
                do { TcIdSigInst
sig_inst <- TcIdSigInfo -> TcM TcIdSigInst
tcInstSig TcIdSigInfo
sig
                   ; GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' <- [(Name, Var)]
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall r. [(Name, Var)] -> TcM r -> TcM r
tcExtendNameTyVarEnv ((InvisTVBinder -> Var) -> [(Name, InvisTVBinder)] -> [(Name, Var)]
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a, b) -> f (a, c)
mapSnd InvisTVBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar ([(Name, InvisTVBinder)] -> [(Name, Var)])
-> [(Name, InvisTVBinder)] -> [(Name, Var)]
forall a b. (a -> b) -> a -> b
$ TcIdSigInst -> [(Name, InvisTVBinder)]
sig_inst_skols TcIdSigInst
sig_inst) (TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
 -> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
                              [(Name, Var)] -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall r. [(Name, Var)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (TcIdSigInst -> [(Name, Var)]
sig_inst_wcs   TcIdSigInst
sig_inst) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                              LHsExpr (GhcPass 'Renamed) -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr (GhcPass 'Renamed)
expr (TcIdSigInst -> TcSigmaType
sig_inst_tau TcIdSigInst
sig_inst)
                   ; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcIdSigInst
sig_inst) }
       -- See Note [Partial expression signatures]
       ; let tau :: TcSigmaType
tau = TcIdSigInst -> TcSigmaType
sig_inst_tau TcIdSigInst
sig_inst
             infer_mode :: InferMode
infer_mode | [TcSigmaType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TcIdSigInst -> [TcSigmaType]
sig_inst_theta TcIdSigInst
sig_inst)
                        , Maybe TcSigmaType -> Bool
forall a. Maybe a -> Bool
isNothing (TcIdSigInst -> Maybe TcSigmaType
sig_inst_wcx TcIdSigInst
sig_inst)
                        = InferMode
ApplyMR
                        | Bool
otherwise
                        = InferMode
NoRestrictions
       ; (([Var]
qtvs, [Var]
givens, TcEvBinds
ev_binds, Bool
_), WantedConstraints
residual)
           <- TcM ([Var], [Var], TcEvBinds, Bool)
-> TcM (([Var], [Var], TcEvBinds, Bool), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM ([Var], [Var], TcEvBinds, Bool)
 -> TcM (([Var], [Var], TcEvBinds, Bool), WantedConstraints))
-> TcM ([Var], [Var], TcEvBinds, Bool)
-> TcM (([Var], [Var], TcEvBinds, Bool), WantedConstraints)
forall a b. (a -> b) -> a -> b
$ TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, TcSigmaType)]
-> WantedConstraints
-> TcM ([Var], [Var], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
infer_mode [TcIdSigInst
sig_inst] [(Name
name, TcSigmaType
tau)] WantedConstraints
wanted
       ; WantedConstraints -> TcM ()
emitConstraints WantedConstraints
residual

       ; TcSigmaType
tau <- ZonkM TcSigmaType -> TcM TcSigmaType
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM TcSigmaType -> TcM TcSigmaType)
-> ZonkM TcSigmaType -> TcM TcSigmaType
forall a b. (a -> b) -> a -> b
$ TcSigmaType -> ZonkM TcSigmaType
zonkTcType TcSigmaType
tau
       ; let inferred_theta :: [TcSigmaType]
inferred_theta = (Var -> TcSigmaType) -> [Var] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map Var -> TcSigmaType
evVarPred [Var]
givens
             tau_tvs :: TyCoVarSet
tau_tvs        = TcSigmaType -> TyCoVarSet
tyCoVarsOfType TcSigmaType
tau
       ; ([InvisTVBinder]
binders, [TcSigmaType]
my_theta) <- WantedConstraints
-> [TcSigmaType]
-> TyCoVarSet
-> [Var]
-> Maybe TcIdSigInst
-> TcM ([InvisTVBinder], [TcSigmaType])
chooseInferredQuantifiers WantedConstraints
residual [TcSigmaType]
inferred_theta
                                   TyCoVarSet
tau_tvs [Var]
qtvs (TcIdSigInst -> Maybe TcIdSigInst
forall a. a -> Maybe a
Just TcIdSigInst
sig_inst)
       ; let inferred_sigma :: TcSigmaType
inferred_sigma = [Var] -> [TcSigmaType] -> TcSigmaType -> TcSigmaType
HasDebugCallStack =>
[Var] -> [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkInfSigmaTy [Var]
qtvs [TcSigmaType]
inferred_theta TcSigmaType
tau
             my_sigma :: TcSigmaType
my_sigma       = [InvisTVBinder] -> TcSigmaType -> TcSigmaType
mkInvisForAllTys [InvisTVBinder]
binders ([TcSigmaType] -> TcSigmaType -> TcSigmaType
HasDebugCallStack => [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkPhiTy  [TcSigmaType]
my_theta TcSigmaType
tau)
       ; HsWrapper
wrap <- if TcSigmaType
inferred_sigma TcSigmaType -> TcSigmaType -> Bool
`eqType` TcSigmaType
my_sigma -- NB: eqType ignores vis.
                 then HsWrapper -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper  -- Fast path; also avoids complaint when we infer
                                          -- an ambiguous type and have AllowAmbiguousType
                                          -- e..g infer  x :: forall a. F a -> Int
                 else CtOrigin
-> UserTypeCtxt
-> TcSigmaType
-> TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
tcSubTypeSigma CtOrigin
ExprSigOrigin (ReportRedundantConstraints -> UserTypeCtxt
ExprSigCtxt ReportRedundantConstraints
NoRRC) TcSigmaType
inferred_sigma TcSigmaType
my_sigma

       ; String -> SDoc -> TcM ()
traceTc String
"tcExpSig" ([Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
qtvs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
givens SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
inferred_sigma SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
my_sigma)
       ; let poly_wrap :: HsWrapper
poly_wrap = HsWrapper
wrap
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [Var] -> HsWrapper
mkWpTyLams [Var]
qtvs
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [Var] -> HsWrapper
mkWpEvLams [Var]
givens
                         HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet  TcEvBinds
ev_binds
       ; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcSigmaType)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
poly_wrap LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcSigmaType
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 GhcTc, TcSigmaType)
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))
    do { HsLit GhcTc
hs_lit <- OverLitVal -> TcM (HsLit GhcTc)
mkOverLit OverLitVal
val
       ; Var
from_id <- Name -> TcM Var
tcLookupId Name
from_name
       ; (HsWrapper
wrap1, TcSigmaType
from_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (HsOverLit (GhcPass 'Renamed) -> CtOrigin
LiteralOrigin HsOverLit (GhcPass 'Renamed)
lit) (Var -> TcSigmaType
idType Var
from_id)
       ; let
           thing :: TypedThing
thing    = Name -> TypedThing
NameThing Name
from_name
           mb_thing :: Maybe TypedThing
mb_thing = TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just TypedThing
thing
           herald :: ExpectedFunTyOrigin
herald   = TypedThing -> HsExpr GhcTc -> ExpectedFunTyOrigin
forall (p :: Pass).
OutputableBndrId p =>
TypedThing -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTyArg TypedThing
thing (XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcTc
EpAnn NoEpAnns
forall a. EpAnn a
noAnn HsLit GhcTc
hs_lit)
       ; (HsWrapper
wrap2, Scaled TcSigmaType
sarg_ty, TcSigmaType
res_ty) <- ExpectedFunTyOrigin
-> Maybe TypedThing
-> (ThLevel, [Scaled TcSigmaType])
-> TcSigmaType
-> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)
matchActualFunTySigma ExpectedFunTyOrigin
herald Maybe TypedThing
mb_thing
                                                           (ThLevel
1, []) TcSigmaType
from_ty

       ; Coercion
co <- Maybe TypedThing -> TcSigmaType -> TcSigmaType -> TcM Coercion
unifyType Maybe TypedThing
mb_thing (HsLit GhcTc -> TcSigmaType
forall (p :: Pass). HsLit (GhcPass p) -> TcSigmaType
hsLitType HsLit GhcTc
hs_lit) (Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
sarg_ty)
       ; let lit_expr :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
lit_expr = SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
loc) (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ Coercion -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo Coercion
co (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                        XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcTc
EpAnn NoEpAnns
forall a. EpAnn a
noAnn HsLit GhcTc
hs_lit
             from_expr :: HsExpr GhcTc
from_expr = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper
wrap2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1) (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                         XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcTc
NoExtField
noExtField (SrcSpanAnnN -> Var -> LocatedAn NameAnn Var
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc Var
from_id)
             witness :: HsExpr GhcTc
witness = XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
EpAnn NoEpAnns
forall a. EpAnn a
noAnn (SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcSpanAnnN
loc) HsExpr GhcTc
from_expr) LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lit_expr
             lit' :: HsOverLit GhcTc
lit' = HsOverLit (GhcPass 'Renamed)
lit { ol_ext = OverLitTc { ol_rebindable = rebindable
                                             , ol_witness = witness
                                             , ol_type = res_ty } }
       ; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLitE GhcTc -> HsOverLit GhcTc -> HsExpr GhcTc
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcTc
EpAnn NoEpAnns
forall a. EpAnn a
noAnn HsOverLit GhcTc
lit', TcSigmaType
res_ty) }

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

tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId Name
name ExpRhoType
res_ty
  = do { (HsExpr GhcTc
expr, TcSigmaType
actual_res_ty) <- Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
name
       ; String -> SDoc -> TcM ()
traceTc String
"tcCheckId" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
actual_res_ty, ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty])
       ; HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcSigmaType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
-> TcM (HsExpr GhcTc)
forall a.
HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcSigmaType
-> ExpRhoType
-> TcM a
-> TcM a
addFunResCtxt HsExpr (GhcPass 'Renamed)
rn_fun [] TcSigmaType
actual_res_ty ExpRhoType
res_ty (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
         CtOrigin
-> HsExpr (GhcPass 'Renamed)
-> HsExpr GhcTc
-> TcSigmaType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcWrapResultO (Name -> CtOrigin
OccurrenceOf Name
name) HsExpr (GhcPass 'Renamed)
rn_fun HsExpr GhcTc
expr TcSigmaType
actual_res_ty ExpRhoType
res_ty }
  where
    rn_fun :: HsExpr (GhcPass 'Renamed)
rn_fun = XVar (GhcPass 'Renamed)
-> LIdP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar (GhcPass 'Renamed)
NoExtField
noExtField (Name -> GenLocated SrcSpanAnnN Name
forall a an. a -> LocatedAn an a
noLocA Name
name)

------------------------
tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
-- Look up an occurrence of an Id
-- Do not instantiate its type
tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
id_name
  | Name
id_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
assertIdKey
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_IgnoreAsserts DynFlags
dflags
         then Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id Name
id_name
         else Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert Name
id_name }

  | Bool
otherwise
  = do { (HsExpr GhcTc
expr, TcSigmaType
ty) <- Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id Name
id_name
       ; String -> SDoc -> TcM ()
traceTc String
"tcInferId" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
id_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty)
       ; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcSigmaType
ty) }

tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
-- Deal with an occurrence of 'assert'
-- See Note [Adding the implicit parameter to 'assert']
tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert Name
assert_name
  = do { Var
assert_error_id <- Name -> TcM Var
tcLookupId Name
assertErrorName
       ; (HsWrapper
wrap, TcSigmaType
id_rho) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (Name -> CtOrigin
OccurrenceOf Name
assert_name)
                                          (Var -> TcSigmaType
idType Var
assert_error_id)
       ; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcTc
NoExtField
noExtField (Var -> LocatedAn NameAnn Var
forall a an. a -> LocatedAn an a
noLocA Var
assert_error_id)), TcSigmaType
id_rho)
       }

tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id Name
id_name
 = do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
id_name
      ; case TcTyThing
thing of
             ATcId { tct_id :: TcTyThing -> Var
tct_id = Var
id }
               -> do { Var -> TcM ()
check_local_id Var
id
                     ; Var -> TcM (HsExpr GhcTc, TcSigmaType)
forall {p} {an} {m :: * -> *}.
(XVar p ~ NoExtField, IdP p ~ Var, XRec p Var ~ LocatedAn an Var,
 Monad m) =>
Var -> m (HsExpr p, TcSigmaType)
return_id Var
id }

             AGlobal (AnId Var
id) -> Var -> TcM (HsExpr GhcTc, TcSigmaType)
forall {p} {an} {m :: * -> *}.
(XVar p ~ NoExtField, IdP p ~ Var, XRec p Var ~ LocatedAn an Var,
 Monad m) =>
Var -> m (HsExpr p, TcSigmaType)
return_id Var
id
               -- A global cannot possibly be ill-staged
               -- nor does it need the 'lifting' treatment
               -- Hence no checkTh stuff here

             AGlobal (AConLike (RealDataCon DataCon
con)) -> DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferDataCon DataCon
con
             AGlobal (AConLike (PatSynCon PatSyn
ps)) -> Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferPatSyn Name
id_name PatSyn
ps
             (TcTyThing -> Maybe TyCon
tcTyThingTyCon_maybe -> Just TyCon
tc) -> TyCon -> TcM (HsExpr GhcTc, TcSigmaType)
fail_tycon TyCon
tc -- TyCon or TcTyCon
             ATyVar Name
name Var
_ -> Name -> TcM (HsExpr GhcTc, TcSigmaType)
fail_tyvar Name
name

             TcTyThing
_ -> TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType))
-> TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$ TcTyThing -> TcRnMessage
TcRnExpectedValueId TcTyThing
thing }
  where
    fail_tycon :: TyCon -> TcM (HsExpr GhcTc, TcSigmaType)
fail_tycon TyCon
tc = do
      GlobalRdrEnv
gre <- TcRn GlobalRdrEnv
getGlobalRdrEnv
      let nm :: Name
nm = TyCon -> Name
tyConName TyCon
tc
          pprov :: SDoc
pprov = case GlobalRdrEnv -> Name -> Maybe (GlobalRdrEltX GREInfo)
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
lookupGRE_Name GlobalRdrEnv
gre Name
nm of
                      Just GlobalRdrEltX GREInfo
gre -> ThLevel -> SDoc -> SDoc
nest ThLevel
2 (GlobalRdrEltX GREInfo -> SDoc
forall info. GlobalRdrEltX info -> SDoc
pprNameProvenance GlobalRdrEltX GREInfo
gre)
                      Maybe (GlobalRdrEltX GREInfo)
Nothing  -> SDoc
forall doc. IsOutput doc => doc
empty
      NameSpace -> Name -> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
fail_with_msg NameSpace
dataName Name
nm SDoc
pprov

    fail_tyvar :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
fail_tyvar Name
nm =
      let pprov :: SDoc
pprov = ThLevel -> SDoc -> SDoc
nest ThLevel
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bound at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
nm))
      in NameSpace -> Name -> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
fail_with_msg NameSpace
varName Name
nm SDoc
pprov

    fail_with_msg :: NameSpace -> Name -> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
fail_with_msg NameSpace
whatName Name
nm SDoc
pprov = do
      ([ImportError]
import_errs, [GhcHint]
hints) <- NameSpace
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
get_suggestions NameSpace
whatName
      UnitState
unit_state <- HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units (HscEnv -> UnitState)
-> IOEnv (Env TcGblEnv TcLclEnv) HscEnv
-> IOEnv (Env TcGblEnv TcLclEnv) UnitState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
      let
        -- TODO: unfortunate to have to convert to SDoc here.
        -- This should go away once we refactor ErrInfo.
        hint_msg :: SDoc
hint_msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GhcHint -> SDoc) -> [GhcHint] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GhcHint]
hints
        import_err_msg :: SDoc
import_err_msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (ImportError -> SDoc) -> [ImportError] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ImportError -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ImportError]
import_errs
        info :: ErrInfo
info = ErrInfo { errInfoContext :: SDoc
errInfoContext = SDoc
pprov, errInfoSupplementary :: SDoc
errInfoSupplementary = SDoc
import_err_msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
hint_msg }
      TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType))
-> TcRnMessage -> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$ UnitState -> TcRnMessageDetailed -> TcRnMessage
TcRnMessageWithInfo UnitState
unit_state (
              ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage ErrInfo
info (Name -> Bool -> TcRnMessage
TcRnIncorrectNameSpace Name
nm Bool
False))

    get_suggestions :: NameSpace
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
get_suggestions NameSpace
ns = do
       let occ :: OccName
occ = NameSpace -> FastString -> OccName
mkOccNameFS NameSpace
ns (OccName -> FastString
occNameFS (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
id_name))
       LocalRdrEnv
lcl_env <- RnM LocalRdrEnv
getLocalRdrEnv
       LocalRdrEnv
-> WhatLooking
-> RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
unknownNameSuggestions LocalRdrEnv
lcl_env WhatLooking
WL_Anything (OccName -> RdrName
mkRdrUnqual OccName
occ)

    return_id :: Var -> m (HsExpr p, TcSigmaType)
return_id Var
id = (HsExpr p, TcSigmaType) -> m (HsExpr p, TcSigmaType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar p -> LIdP p -> HsExpr p
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar p
NoExtField
noExtField (Var -> LocatedAn an Var
forall a an. a -> LocatedAn an a
noLocA Var
id), Var -> TcSigmaType
idType Var
id)

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

check_naughty :: OccName -> TcId -> TcM ()
check_naughty :: OccName -> Var -> TcM ()
check_naughty OccName
lbl Var
id
  | Var -> Bool
isNaughtyRecordSelector Var
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 ()

tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
-- See Note [Typechecking data constructors]
tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferDataCon DataCon
con
  = do { let tvbs :: [InvisTVBinder]
tvbs  = DataCon -> [InvisTVBinder]
dataConUserTyVarBinders DataCon
con
             tvs :: [Var]
tvs   = [InvisTVBinder] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tvbs
             theta :: [TcSigmaType]
theta = DataCon -> [TcSigmaType]
dataConOtherTheta DataCon
con
             args :: [Scaled TcSigmaType]
args  = DataCon -> [Scaled TcSigmaType]
dataConOrigArgTys DataCon
con
             res :: TcSigmaType
res   = DataCon -> TcSigmaType
dataConOrigResTy DataCon
con
             stupid_theta :: [TcSigmaType]
stupid_theta = DataCon -> [TcSigmaType]
dataConStupidTheta DataCon
con

       ; [Scaled TcSigmaType]
scaled_arg_tys <- (Scaled TcSigmaType
 -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcSigmaType))
-> [Scaled TcSigmaType]
-> IOEnv (Env TcGblEnv TcLclEnv) [Scaled TcSigmaType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Scaled TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcSigmaType)
linear_to_poly [Scaled TcSigmaType]
args

       ; let full_theta :: [TcSigmaType]
full_theta  = [TcSigmaType]
stupid_theta [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
theta
             all_arg_tys :: [Scaled TcSigmaType]
all_arg_tys = (TcSigmaType -> Scaled TcSigmaType)
-> [TcSigmaType] -> [Scaled TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map TcSigmaType -> Scaled TcSigmaType
forall a. a -> Scaled a
unrestricted [TcSigmaType]
full_theta [Scaled TcSigmaType]
-> [Scaled TcSigmaType] -> [Scaled TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [Scaled TcSigmaType]
scaled_arg_tys
                -- We are building the type of the data con wrapper, so the
                -- type must precisely match the construction in
                -- GHC.Core.DataCon.dataConWrapperType.
                -- See Note [Instantiating stupid theta]
                -- in GHC.Core.DataCon.

       ; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( XXExpr GhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (ConLike -> [Var] -> [Scaled TcSigmaType] -> XXExprGhcTc
ConLikeTc (DataCon -> ConLike
RealDataCon DataCon
con) [Var]
tvs [Scaled TcSigmaType]
all_arg_tys)
                , [InvisTVBinder] -> TcSigmaType -> TcSigmaType
mkInvisForAllTys [InvisTVBinder]
tvbs (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$ [TcSigmaType] -> TcSigmaType -> TcSigmaType
HasDebugCallStack => [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkPhiTy [TcSigmaType]
full_theta (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$
                  [Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
HasDebugCallStack =>
[Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
mkScaledFunTys [Scaled TcSigmaType]
scaled_arg_tys TcSigmaType
res ) }
  where
    linear_to_poly :: Scaled Type -> TcM (Scaled Type)
    -- linear_to_poly implements point (3,4)
    -- of Note [Typechecking data constructors]
    linear_to_poly :: Scaled TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcSigmaType)
linear_to_poly (Scaled TcSigmaType
OneTy TcSigmaType
ty) = do { TcSigmaType
mul_var <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
multiplicityTy
                                          ; Scaled TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcSigmaType -> TcSigmaType -> Scaled TcSigmaType
forall a. TcSigmaType -> a -> Scaled a
Scaled TcSigmaType
mul_var TcSigmaType
ty) }
    linear_to_poly Scaled TcSigmaType
scaled_ty         = Scaled TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcSigmaType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Scaled TcSigmaType
scaled_ty

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

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

{- Note [Adding the implicit parameter to 'assert']
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The typechecker transforms (assert e1 e2) to (assertError e1 e2).
This isn't really the Right Thing because there's no way to "undo"
if you want to see the original source code in the typechecker
output.  We'll have fix this in due course, when we care more about
being able to reconstruct the exact original program.

Note [Typechecking data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As per Note [Polymorphisation of linear fields] in
GHC.Core.Multiplicity, linear fields of data constructors get a
polymorphic multiplicity when the data constructor is used as a term:

    Just :: forall {p} a. a %p -> Maybe a

So at an occurrence of a data constructor we do the following:

1. Typechecking, in tcInferDataCon.

  a. Get the original type of the constructor, say
     K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a
     Note the %1: it is linear

  b. We are going to return a ConLikeTc, thus:
     XExpr (ConLikeTc K [r,a] [Scaled p a])
      :: forall (r :: RuntimeRep) (a :: TYPE r). a %p -> T r a
   where 'p' is a fresh multiplicity unification variable.

   To get the returned ConLikeTc, we allocate a fresh multiplicity
   variable for each linear argument, and store the type, scaled by
   the fresh multiplicity variable in the ConLikeTc; along with
   the type of the ConLikeTc. This is done by linear_to_poly.

   If the argument is not linear (perhaps explicitly declared as
   non-linear by the user), don't bother with this.

2. Desugaring, in dsConLike.

  a. The (ConLikeTc K [r,a] [Scaled p a]) is desugared to
     (/\r (a :: TYPE r). \(x %p :: a). K @r @a x)
   which has the desired type given in the previous bullet.

   The 'p' is the multiplicity unification variable, which
   will by now have been unified to something, or defaulted in
   `GHC.Tc.Zonk.Type.commitFlexi`. So it won't just be an
   (unbound) variable.

   So a saturated application (K e), where e::Int will desugar to
     (/\r (a :: TYPE r). ..etc..)
        @LiftedRep @Int e
   and all those lambdas will beta-reduce away in the simple optimiser
   (see Wrinkle [Representation-polymorphic lambdas] below).

   But for an /unsaturated/ application, such as `map (K @LiftedRep @Int) xs`,
   beta reduction will leave (\x %Many :: Int. K x), which is the type `map`
   expects whereas if we had just plain K, with its linear type, we'd
   get a type mismatch. That's why we do this funky desugaring.

Wrinkles

  [ConLikeTc arguments]

    Note that the [TcType] argument to ConLikeTc is strictly redundant; those are
    the type variables from the dataConUserTyVarBinders of the data constructor.
    Similarly in the [Scaled TcType] field of ConLikeTc, the types come directly
    from the data constructor.  The only bit that /isn't/ redundant is the
    fresh multiplicity variables!

    So an alternative would be to define ConLikeTc like this:
        | ConLikeTc [TcType]    -- Just the multiplicity variables
    But then the desugarer would need to repeat some of the work done here.
    So for now at least ConLikeTc records this strictly-redundant info.

  [Representation-polymorphic lambdas]

    The lambda expression we produce in (4) can have representation-polymorphic
    arguments, as indeed in (/\r (a :: TYPE r). \(x %p :: a). K @r @a x),
    we have a lambda-bound variable x :: (a :: TYPE r).
    This goes against the representation polymorphism invariants given in
    Note [Representation polymorphism invariants] in GHC.Core. The trick is that
    this this lambda will always be instantiated in a way that upholds the invariants.
    This is achieved as follows:

      A. Any arguments to such lambda abstractions are guaranteed to have
         a fixed runtime representation. This is enforced in 'tcApp' by
         'matchActualFunTySigma'.

      B. If there are fewer arguments than there are bound term variables,
         hasFixedRuntimeRep_remainingValArgs will ensure that we are still
         instantiating at a representation-monomorphic type, e.g.

         ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int#
           :: Int# -> T IntRep Int#

      C. In the output of the desugarer in (4) above, we have a representation
         polymorphic lambda, which Lint would normally reject. So for that one
         pass, we switch off Lint's representation-polymorphism checks; see
         the `lf_check_fixed_rep` flag in `LintFlags`.
-}

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

checkThLocalId :: Id -> TcM ()
-- The renamer has already done checkWellStaged,
--   in RnSplice.checkThLocalName, so don't repeat that here.
-- Here we just add constraints for cross-stage lifting
checkThLocalId :: Var -> TcM ()
checkThLocalId Var
id
  = do  { Maybe (TopLevelFlag, ThLevel, ThStage)
mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel (Var -> Name
idName Var
id)
        ; case Maybe (TopLevelFlag, ThLevel, ThStage)
mb_local_use of
             Just (TopLevelFlag
top_lvl, ThLevel
bind_lvl, ThStage
use_stage)
                | ThStage -> ThLevel
thLevel ThStage
use_stage ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ThLevel
bind_lvl
                -> TopLevelFlag -> Var -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl Var
id ThStage
use_stage
             Maybe (TopLevelFlag, ThLevel, ThStage)
_  -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()   -- Not a locally-bound thing, or
                               -- no cross-stage link
    }

--------------------------------------
checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
-- If we are inside typed brackets, and (use_lvl > bind_lvl)
-- we must check whether there's a cross-stage lift to do
-- Examples   \x -> [|| x ||]
--            [|| map ||]
--
-- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but
-- this code is applied to *typed* brackets.

checkCrossStageLifting :: TopLevelFlag -> Var -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl Var
id (Brack ThStage
_ (TcPending TcRef [PendingTcSplice]
ps_var TcRef WantedConstraints
lie_var QuoteWrapper
q))
  | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
  = Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
id_name) (Name -> TcM ()
keepAlive Name
id_name)
    -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice

  | Bool
otherwise
  =     -- Nested identifiers, such as 'x' in
        -- E.g. \x -> [|| h x ||]
        -- We must behave as if the reference to x was
        --      h $(lift x)
        -- We use 'x' itself as the splice proxy, used by
        -- the desugarer to stitch it all back together.
        -- If 'x' occurs many times we may get many identical
        -- bindings of the same splice proxy, but that doesn't
        -- matter, although it's a mite untidy.
    do  { let id_ty :: TcSigmaType
id_ty = Var -> TcSigmaType
idType Var
id
        ; Bool -> TcRnMessage -> TcM ()
checkTc (TcSigmaType -> Bool
isTauTy TcSigmaType
id_ty) (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$
          THError -> TcRnMessage
TcRnTHError (THError -> TcRnMessage) -> THError -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ TypedTHError -> THError
TypedTHError (TypedTHError -> THError) -> TypedTHError -> THError
forall a b. (a -> b) -> a -> b
$ Var -> TypedTHError
SplicePolymorphicLocalVar Var
id
               -- If x is polymorphic, its occurrence sites might
               -- have different instantiations, so we can't use plain
               -- 'x' as the splice proxy name.  I don't know how to
               -- solve this, and it's probably unimportant, so I'm
               -- just going to flag an error for now

        ; HsExpr GhcTc
lift <- if TcSigmaType -> Bool
isStringTy TcSigmaType
id_ty then
                     do { Var
sid <- Name -> TcM Var
tcLookupId Name
GHC.Builtin.Names.TH.liftStringName
                                     -- See Note [Lifting strings]
                        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar XVar GhcTc
NoExtField
noExtField (Var -> LocatedAn NameAnn Var
forall a an. a -> LocatedAn an a
noLocA Var
sid)) }
                  else
                     TcRef WantedConstraints -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar TcRef WantedConstraints
lie_var   (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                          -- Put the 'lift' constraint into the right LIE
                     CtOrigin -> Name -> [TcSigmaType] -> TcM (HsExpr GhcTc)
newMethodFromName (Name -> CtOrigin
OccurrenceOf Name
id_name)
                                       Name
GHC.Builtin.Names.TH.liftName
                                       [HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
getRuntimeRep TcSigmaType
id_ty, TcSigmaType
id_ty]

                   -- Warning for implicit lift (#17804)
        ; (ErrInfo -> TcRnMessage) -> TcM ()
addDetailedDiagnostic (Name -> ErrInfo -> TcRnMessage
TcRnImplicitLift (Name -> ErrInfo -> TcRnMessage) -> Name -> ErrInfo -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ Var -> Name
idName Var
id)

                   -- Update the pending splices
        ; [PendingTcSplice]
ps <- TcRef [PendingTcSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingTcSplice]
forall a env. IORef a -> IOEnv env a
readMutVar TcRef [PendingTcSplice]
ps_var
        ; let pending_splice :: PendingTcSplice
pending_splice = Name -> LHsExpr GhcTc -> PendingTcSplice
PendingTcSplice Name
id_name
                                 (LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (QuoteWrapper -> HsWrapper
applyQuoteWrapper QuoteWrapper
q) (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcTc
lift))
                                          (IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcTc
Var
id))
        ; TcRef [PendingTcSplice] -> [PendingTcSplice] -> TcM ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar TcRef [PendingTcSplice]
ps_var (PendingTcSplice
pending_splice PendingTcSplice -> [PendingTcSplice] -> [PendingTcSplice]
forall a. a -> [a] -> [a]
: [PendingTcSplice]
ps)

        ; () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () }
  where
    id_name :: Name
id_name = Var -> Name
idName Var
id

checkCrossStageLifting TopLevelFlag
_ Var
_ ThStage
_ = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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


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

addFunResCtxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn]
              -> 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 a.
HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcSigmaType
-> ExpRhoType
-> TcM a
-> TcM a
addFunResCtxt HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args TcSigmaType
fun_res_ty ExpRhoType
env_ty TcM a
thing_inside
  = do { TcSigmaType
env_tv  <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
       ; Bool
dumping <- DumpFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
Opt_D_dump_tc_trace
       ; (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
forall a. (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM (\TidyEnv
env -> (TidyEnv
env, ) (SDoc -> (TidyEnv, SDoc)) -> ZonkM SDoc -> ZonkM (TidyEnv, SDoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> TcSigmaType -> ZonkM SDoc
mk_msg Bool
dumping TcSigmaType
env_tv) TcM a
thing_inside }
      -- NB: use a landmark error context, so that an empty context
      -- doesn't suppress some more useful context
  where
    mk_msg :: Bool -> TcSigmaType -> ZonkM SDoc
mk_msg Bool
dumping TcSigmaType
env_tv
      = do { Maybe TcSigmaType
mb_env_ty <- ExpRhoType -> ZonkM (Maybe TcSigmaType)
forall (m :: * -> *).
MonadIO m =>
ExpRhoType -> m (Maybe TcSigmaType)
readExpType_maybe ExpRhoType
env_ty
                     -- by the time the message is rendered, the ExpType
                     -- will be filled in (except if we're debugging)
           ; TcSigmaType
fun_res' <- TcSigmaType -> ZonkM TcSigmaType
zonkTcType TcSigmaType
fun_res_ty
           ; TcSigmaType
env'     <- case Maybe TcSigmaType
mb_env_ty of
                           Just TcSigmaType
env_ty -> TcSigmaType -> ZonkM TcSigmaType
zonkTcType TcSigmaType
env_ty
                           Maybe TcSigmaType
Nothing     -> do { Bool -> ZonkM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert Bool
dumping; TcSigmaType -> ZonkM TcSigmaType
forall a. a -> ZonkM a
forall (m :: * -> *) a. Monad m => a -> m a
return TcSigmaType
env_tv }
           ; let -- See Note [Splitting nested sigma types in mismatched
                 --           function types]
                 ([Var]
_, [TcSigmaType]
_, TcSigmaType
fun_tau) = TcSigmaType -> ([Var], [TcSigmaType], TcSigmaType)
tcSplitNestedSigmaTys TcSigmaType
fun_res'
                 ([Var]
_, [TcSigmaType]
_, TcSigmaType
env_tau) = TcSigmaType -> ([Var], [TcSigmaType], TcSigmaType)
tcSplitNestedSigmaTys TcSigmaType
env'
                     -- env_ty is an ExpRhoTy, but with simple subsumption it
                     -- is not deeply skolemised, so still use tcSplitNestedSigmaTys
                 ([Scaled TcSigmaType]
args_fun, TcSigmaType
res_fun) = TcSigmaType -> ([Scaled TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
fun_tau
                 ([Scaled TcSigmaType]
args_env, TcSigmaType
res_env) = TcSigmaType -> ([Scaled TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
env_tau
                 n_fun :: ThLevel
n_fun = [Scaled TcSigmaType] -> ThLevel
forall a. [a] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args_fun
                 n_env :: ThLevel
n_env = [Scaled TcSigmaType] -> ThLevel
forall a. [a] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args_env
                 info :: SDoc
info  | -- Check for too few args
                         --  fun_tau = a -> b, res_tau = Int
                         ThLevel
n_fun ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ThLevel
n_env
                       , TcSigmaType -> Bool
not_fun TcSigmaType
res_env
                       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Probable cause:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
fun)
                         SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is applied to too few arguments"

                       | -- Check for too many args
                         -- fun_tau = a -> Int,   res_tau = a -> b -> c -> d
                         -- The final guard suppresses the message when there
                         -- aren't enough args to drop; eg. the call is (f e1)
                         ThLevel
n_fun ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
< ThLevel
n_env
                       , TcSigmaType -> Bool
not_fun TcSigmaType
res_fun
                       , (ThLevel
n_fun ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ (HsExprArg 'TcpRn -> Bool) -> [HsExprArg 'TcpRn] -> ThLevel
forall a. (a -> Bool) -> [a] -> ThLevel
count HsExprArg 'TcpRn -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isValArg [HsExprArg 'TcpRn]
args) ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= ThLevel
n_env
                          -- Never suggest that a naked variable is
                                           -- applied to too many args!
                       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Possible cause:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
fun)
                         SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is applied to too many arguments"

                       | Bool
otherwise
                       = SDoc
forall doc. IsOutput doc => doc
Outputable.empty

           ; SDoc -> ZonkM SDoc
forall a. a -> ZonkM a
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
info }

    not_fun :: TcSigmaType -> Bool
not_fun TcSigmaType
ty   -- ty is definitely not an arrow type,
                 -- and cannot conceivably become one
      = case HasDebugCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty of
          Just (TyCon
tc, [TcSigmaType]
_) -> TyCon -> Bool
isAlgTyCon TyCon
tc
          Maybe (TyCon, [TcSigmaType])
Nothing      -> Bool
False

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


{- *********************************************************************
*                                                                      *
             Misc utility functions
*                                                                      *
********************************************************************* -}

addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt :: forall a. HsExpr (GhcPass 'Renamed) -> TcRn a -> TcRn a
addExprCtxt HsExpr (GhcPass 'Renamed)
e TcRn a
thing_inside
  = case HsExpr (GhcPass 'Renamed)
e of
      HsUnboundVar {} -> TcRn a
thing_inside
      HsExpr (GhcPass 'Renamed)
_ -> SDoc -> TcRn a -> TcRn a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr (GhcPass 'Renamed) -> SDoc
exprCtxt HsExpr (GhcPass 'Renamed)
e) TcRn a
thing_inside
   -- The HsUnboundVar special case addresses situations like
   --    f x = _
   -- when we don't want to say "In the expression: _",
   -- because it is mentioned in the error message itself

exprCtxt :: HsExpr GhcRn -> SDoc
exprCtxt :: HsExpr (GhcPass 'Renamed) -> SDoc
exprCtxt HsExpr (GhcPass 'Renamed)
expr = SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the expression:") ThLevel
2 (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall (p :: Pass). HsExpr (GhcPass p) -> HsExpr (GhcPass p)
stripParensHsExpr HsExpr (GhcPass 'Renamed)
expr))