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

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}

{-
%
(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, lookupParents, fieldNotInType
       , notSelector, nonBidirectionalErr

       , addExprCtxt, addFunResCtxt ) where

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

import GHC.Tc.Gen.HsType
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.Types.Basic
import GHC.Types.Error
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family ( tcLookupDataFamInst )
import GHC.Core.FamInstEnv    ( FamInstEnvs )
import GHC.Core.UsageEnv      ( unitUE )
import GHC.Rename.Unbound     ( unknownNameSuggestions, WhatLooking(..) )
import GHC.Unit.Module        ( getModule )
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.Hs
import GHC.Hs.Syn.Type
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.PatSyn( PatSyn )
import GHC.Core.ConLike( ConLike(..) )
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Tc.Types.Evidence
import GHC.Builtin.Types( multiplicityTy )
import GHC.Builtin.Names
import GHC.Builtin.Names.TH( liftStringName, liftName )
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad

import Data.Function

import GHC.Prelude


{- *********************************************************************
*                                                                      *
              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  { HsExprArg p -> AppCtxt
eva_ctxt   :: AppCtxt
             , HsExprArg p -> EValArg p
eva_arg    :: EValArg p
             , HsExprArg p -> XEVAType p
eva_arg_ty :: !(XEVAType p) }

  | ETypeArg { eva_ctxt  :: AppCtxt
             , HsExprArg p -> LHsWcType GhcRn
eva_hs_ty :: LHsWcType GhcRn  -- The type arg
             , 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 GhcRn
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 -> TcRhoType
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

  | VACall
       (HsExpr GhcRn) Int  -- In the third argument of function f
       SrcSpan             -- The SrcSpan of the application (f e1 e2 e3)

appCtxtLoc :: AppCtxt -> SrcSpan
appCtxtLoc :: AppCtxt -> SrcSpan
appCtxtLoc (VAExpansion HsExpr GhcRn
_ SrcSpan
l) = SrcSpan
l
appCtxtLoc (VACall HsExpr GhcRn
_ Int
_ 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 GhcRn
e SrcSpan
_) = String -> SDoc
text String
"VAExpansion" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e
  ppr (VACall HsExpr GhcRn
f Int
n SrcSpan
_)    = String -> SDoc
text String
"VACall" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
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 GhcRn -> HsExprArg 'TcpRn
mkEValArg AppCtxt
ctxt LHsExpr GhcRn
e = EValArg :: forall (p :: TcPass).
AppCtxt -> EValArg p -> XEVAType p -> HsExprArg p
EValArg { eva_arg :: EValArg 'TcpRn
eva_arg = LHsExpr (GhcPass (XPass 'TcpRn)) -> EValArg 'TcpRn
forall (p :: TcPass). LHsExpr (GhcPass (XPass p)) -> EValArg p
ValArg LHsExpr GhcRn
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 -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsWcType GhcRn
hs_ty = ETypeArg :: forall (p :: TcPass).
AppCtxt -> LHsWcType GhcRn -> XETAType p -> HsExprArg p
ETypeArg { eva_ctxt :: AppCtxt
eva_ctxt = AppCtxt
ctxt, eva_hs_ty :: LHsWcType GhcRn
eva_hs_ty = LHsWcType GhcRn
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 GhcRn -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr GhcRn
e = HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
e (Int -> HsExpr GhcRn -> AppCtxt
top_ctxt Int
0 HsExpr GhcRn
e) []
  where
    top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt
top_ctxt Int
n (HsPar XPar GhcRn
_ LHsToken "(" GhcRn
_ LHsExpr GhcRn
fun LHsToken ")" GhcRn
_)           = Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt Int
n LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
fun
    top_ctxt Int
n (HsPragE XPragE GhcRn
_ HsPragE GhcRn
_ LHsExpr GhcRn
fun)           = Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt Int
n LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
fun
    top_ctxt Int
n (HsAppType XAppTypeE GhcRn
_ LHsExpr GhcRn
fun LHsWcType (NoGhcTc GhcRn)
_)         = Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
fun
    top_ctxt Int
n (HsApp XApp GhcRn
_ LHsExpr GhcRn
fun LHsExpr GhcRn
_)             = Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
fun
    top_ctxt Int
n (XExpr (HsExpanded orig _)) = HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
orig      Int
n SrcSpan
noSrcSpan
    top_ctxt Int
n HsExpr GhcRn
other_fun                   = HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
other_fun Int
n SrcSpan
noSrcSpan

    top_lctxt :: Int -> GenLocated SrcSpanAnnA (HsExpr GhcRn) -> AppCtxt
top_lctxt Int
n (L SrcSpanAnnA
_ HsExpr GhcRn
fun) = Int -> HsExpr GhcRn -> AppCtxt
top_ctxt Int
n HsExpr GhcRn
fun

    go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
       -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
    go :: HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go (HsPar XPar GhcRn
_ LHsToken "(" GhcRn
_ (L l fun) LHsToken ")" GhcRn
_)    AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
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 GhcRn
_ HsPragE GhcRn
p (L l fun))    AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
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 GhcRn
HsPragE (GhcPass (XPass 'TcpRn))
p   HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
    go (HsAppType XAppTypeE GhcRn
_ (L l fun) LHsWcType (NoGhcTc GhcRn)
ty) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsWcType GhcRn
LHsWcType (NoGhcTc GhcRn)
ty  HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
    go (HsApp XApp GhcRn
_ (L l fun) LHsExpr GhcRn
arg)    AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg  AppCtxt
ctxt LHsExpr GhcRn
arg HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)

    -- See Note [Looking through HsExpanded]
    go (XExpr (HsExpanded orig fun)) AppCtxt
ctxt [HsExprArg 'TcpRn]
args
      = HsExpr GhcRn
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
go HsExpr GhcRn
fun (HsExpr GhcRn -> SrcSpan -> AppCtxt
VAExpansion HsExpr GhcRn
orig (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt)) (EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsExpr GhcRn -> EWrap
EExpand HsExpr GhcRn
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 GhcRn
e@(OpApp XOpApp GhcRn
_ LHsExpr GhcRn
arg1 (L l op) LHsExpr GhcRn
arg2) AppCtxt
_ [HsExprArg 'TcpRn]
args
      = ( (HsExpr GhcRn
op, HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
0 (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l))
        ,   AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg (HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
1 SrcSpan
generatedSrcSpan) LHsExpr GhcRn
arg1
          HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg (HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
op Int
2 SrcSpan
generatedSrcSpan) LHsExpr GhcRn
arg2
          HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsExpr GhcRn -> EWrap
EExpand HsExpr GhcRn
e)
          HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args )

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

    set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
    set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
set SrcSpanAnnA
l (VACall HsExpr GhcRn
f Int
n SrcSpan
_)        = HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
f Int
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 GhcRn
f Int
n SrcSpan
_)        = HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt
VACall HsExpr GhcRn
f (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
    dec SrcSpanAnnA
_ ctxt :: AppCtxt
ctxt@(VAExpansion {}) = AppCtxt
ctxt

rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc
rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps HsExpr GhcTc
fun AppCtxt
_ [] = HsExpr GhcTc
fun
rebuildHsApps 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
rebuildHsApps (XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTc
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 GhcRn
eva_hs_ty = LHsWcType GhcRn
hs_ty, 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
rebuildHsApps (XAppTypeE GhcTc
-> LHsExpr GhcTc -> LHsWcType (NoGhcTc GhcTc) -> HsExpr GhcTc
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcTc
XETAType 'TcpTc
ty LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
lfun LHsWcType GhcRn
LHsWcType (NoGhcTc GhcTc)
hs_ty) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
      EPrag AppCtxt
ctxt' HsPragE (GhcPass (XPass 'TcpTc))
p
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (XPragE GhcTc -> HsPragE GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE NoExtField
XPragE GhcTc
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
rebuildHsApps (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 GhcRn
orig)
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (XXExpr GhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (HsExpansion (HsExpr GhcRn) (HsExpr GhcTc) -> XXExprGhcTc
ExpansionExpr (HsExpr GhcRn
-> HsExpr GhcTc -> HsExpansion (HsExpr GhcRn) (HsExpr GhcTc)
forall orig expanded. orig -> expanded -> HsExpansion orig expanded
HsExpanded HsExpr GhcRn
orig HsExpr GhcTc
fun))) AppCtxt
ctxt [HsExprArg 'TcpTc]
args
      EWrap (EHsWrap HsWrapper
wrap)
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (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

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

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

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

isVisibleArg :: HsExprArg id -> Bool
isVisibleArg :: 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 :: [HsExprArg id] -> Int
countVisAndInvisValArgs []                  = Int
0
countVisAndInvisValArgs (EValArg {} : [HsExprArg id]
args) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countVisAndInvisValArgs [HsExprArg id]
args
countVisAndInvisValArgs (EWrap EWrap
wrap : [HsExprArg id]
args) =
  case EWrap
wrap of { EHsWrap HsWrapper
hsWrap            -> HsWrapper -> Int
countHsWrapperInvisArgs HsWrapper
hsWrap Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countVisAndInvisValArgs [HsExprArg id]
args
               ; EPar   {}                 -> [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countVisAndInvisValArgs [HsExprArg id]
args
               ; EExpand {}                -> [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countVisAndInvisValArgs [HsExprArg id]
args }
countVisAndInvisValArgs (EPrag {}   : [HsExprArg id]
args) = [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
countVisAndInvisValArgs [HsExprArg id]
args
countVisAndInvisValArgs (ETypeArg {}: [HsExprArg id]
args) = [HsExprArg id] -> Int
forall (id :: TcPass). [HsExprArg id] -> Int
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 -> Int
countHsWrapperInvisArgs = HsWrapper -> Int
forall p. Num p => HsWrapper -> p
go
  where
    go :: HsWrapper -> p
go HsWrapper
WpHole = p
0
    go (WpCompose HsWrapper
wrap1 HsWrapper
wrap2) = HsWrapper -> p
go HsWrapper
wrap1 p -> p -> p
forall a. Num a => a -> a -> a
+ HsWrapper -> p
go HsWrapper
wrap2
    go fun :: HsWrapper
fun@(WpFun {}) = HsWrapper -> p
forall a a. Outputable a => a -> a
nope HsWrapper
fun
    go (WpCast {}) = p
0
    go evLam :: HsWrapper
evLam@(WpEvLam {}) = HsWrapper -> p
forall a a. Outputable a => a -> a
nope HsWrapper
evLam
    go (WpEvApp EvTerm
_) = p
1
    go tyLam :: HsWrapper
tyLam@(WpTyLam {}) = HsWrapper -> p
forall a a. Outputable a => a -> a
nope HsWrapper
tyLam
    go (WpTyApp TcRhoType
_) = p
0
    go (WpLet TcEvBinds
_) = p
0
    go (WpMultCoercion {}) = p
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
text String
"EValArg" SDoc -> SDoc -> SDoc
<+> EValArg p -> SDoc
forall a. Outputable a => a -> SDoc
ppr EValArg p
arg
  ppr (EPrag AppCtxt
_ HsPragE (GhcPass (XPass p))
p)                      = String -> SDoc
text String
"EPrag" SDoc -> SDoc -> SDoc
<+> 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 GhcRn
eva_hs_ty = LHsWcType GhcRn
hs_ty }) = Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
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
text String
"EPar"
  ppr (EHsWrap HsWrapper
w)    = String -> SDoc
text String
"EHsWrap" SDoc -> SDoc -> SDoc
<+> HsWrapper -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWrapper
w
  ppr (EExpand HsExpr GhcRn
orig) = String -> SDoc
text String
"EExpand" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
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 -> TcRhoType
va_ty = TcRhoType
ty})
    = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"ValArgQL" SDoc -> SDoc -> SDoc
<+> (HsExpr GhcTc, AppCtxt) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr GhcTc, AppCtxt)
fun)
         Int
2 ([SDoc] -> SDoc
vcat [ [HsExprArg 'TcpInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpInst]
args, String -> SDoc
text String
"va_ty:" SDoc -> SDoc -> SDoc
<+> TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcRhoType
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
text String
"EValArg" SDoc -> SDoc -> SDoc
<+> SDoc -> Int -> SDoc -> SDoc
hang (EValArg 'TcpInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr EValArg 'TcpInst
tm) Int
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Scaled TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr Scaled TcRhoType
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 GhcRn, AppCtxt)
-> [HsExprArg 'TcpRn] -> TcM (HsExpr GhcTc, TcRhoType)
tcInferAppHead (HsExpr GhcRn
fun,AppCtxt
ctxt) [HsExprArg 'TcpRn]
args
  = SrcSpan
-> TcM (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt) (TcM (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall a b. (a -> b) -> a -> b
$
    do { Maybe (HsExpr GhcTc, TcRhoType)
mb_tc_fun <- HsExpr GhcRn
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcRhoType))
tcInferAppHead_maybe HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args
       ; case Maybe (HsExpr GhcTc, TcRhoType)
mb_tc_fun of
            Just (HsExpr GhcTc
fun', TcRhoType
fun_sigma) -> (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
fun', TcRhoType
fun_sigma)
            Maybe (HsExpr GhcTc, TcRhoType)
Nothing -> HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr GhcTc, TcRhoType)
-> TcM (HsExpr GhcTc, TcRhoType)
forall a. HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args (TcM (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall a b. (a -> b) -> a -> b
$
                       (ExpSigmaType -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc, TcRhoType)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, TcRhoType)
tcInfer (HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
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 GhcRn
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcRhoType))
tcInferAppHead_maybe HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args
  = case HsExpr GhcRn
fun of
      HsVar XVar GhcRn
_ (L _ nm)          -> (HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType)
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM (HsExpr GhcTc, TcRhoType)
tcInferId Name
nm
      HsRecSel XRecSel GhcRn
_ FieldOcc GhcRn
f              -> (HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType)
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldOcc GhcRn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferRecSelId FieldOcc GhcRn
f
      ExprWithTySig XExprWithTySig GhcRn
_ LHsExpr GhcRn
e LHsSigWcType (NoGhcTc GhcRn)
hs_ty   -> HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall a. HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args (TcM (Maybe (HsExpr GhcTc, TcRhoType))
 -> TcM (Maybe (HsExpr GhcTc, TcRhoType)))
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall a b. (a -> b) -> a -> b
$
                                   (HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType)
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcRn
-> LHsSigWcType (NoGhcTc GhcRn) -> TcM (HsExpr GhcTc, TcRhoType)
tcExprWithSig LHsExpr GhcRn
e LHsSigWcType (NoGhcTc GhcRn)
hs_ty
      HsOverLit XOverLitE GhcRn
_ HsOverLit GhcRn
lit           -> (HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcRhoType) -> Maybe (HsExpr GhcTc, TcRhoType))
-> TcM (HsExpr GhcTc, TcRhoType)
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferOverLit HsOverLit GhcRn
lit
      HsSpliceE XSpliceE GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
_ (HsSplicedExpr HsExpr GhcRn
e))
                                -> HsExpr GhcRn
-> [HsExprArg 'TcpRn] -> TcM (Maybe (HsExpr GhcTc, TcRhoType))
tcInferAppHead_maybe HsExpr GhcRn
e [HsExprArg 'TcpRn]
args
      HsExpr GhcRn
_                         -> Maybe (HsExpr GhcTc, TcRhoType)
-> TcM (Maybe (HsExpr GhcTc, TcRhoType))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HsExpr GhcTc, TcRhoType)
forall a. Maybe a
Nothing

add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
-- Don't push an expression context if the arguments are empty,
-- because it has already been pushed by tcExpr
add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args TcM a
thing_inside
  | [HsExprArg 'TcpRn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsExprArg 'TcpRn]
args = TcM a
thing_inside
  | Bool
otherwise = HsExpr GhcRn -> TcM a -> TcM a
forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
fun TcM a
thing_inside


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

tcInferRecSelId :: FieldOcc GhcRn
                -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId :: FieldOcc GhcRn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferRecSelId (FieldOcc XCFieldOcc GhcRn
sel_name XRec GhcRn RdrName
lbl)
   = do { TcId
sel_id <- TcM TcId
tc_rec_sel_id
        ; let expr :: HsExpr GhcTc
expr = XRecSel GhcTc -> FieldOcc GhcTc -> HsExpr GhcTc
forall p. XRecSel p -> FieldOcc p -> HsExpr p
HsRecSel NoExtField
XRecSel GhcTc
noExtField (XCFieldOcc GhcTc -> XRec GhcTc RdrName -> FieldOcc GhcTc
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc XCFieldOcc GhcTc
TcId
sel_id XRec GhcTc RdrName
XRec GhcRn RdrName
lbl)
        ; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcId -> TcRhoType
idType TcId
sel_id)
        }
     where
       occ :: OccName
       occ :: OccName
occ = RdrName -> OccName
rdrNameOcc (GenLocated SrcSpanAnnN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc XRec GhcRn 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 TcId
tc_rec_sel_id
         = do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup XCFieldOcc GhcRn
Name
sel_name
              ; case TcTyThing
thing of
                    ATcId { tct_id :: TcTyThing -> TcId
tct_id = TcId
id }
                      -> do { OccName -> TcId -> TcM ()
check_naughty OccName
occ TcId
id  -- See Note [Local record selectors]
                            ; TcId -> TcM ()
check_local_id TcId
id
                            ; TcId -> TcM TcId
forall (m :: * -> *) a. Monad m => a -> m a
return TcId
id }

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

                    TcTyThing
_ -> TcRnMessage -> TcM TcId
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM TcId) -> TcRnMessage -> TcM TcId
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 GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (ExprWithTySig XExprWithTySig GhcRn
_ LHsExpr GhcRn
_ LHsSigWcType (NoGhcTc GhcRn)
ty) = HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> Maybe
     (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn)))
forall a. a -> Maybe a
Just HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
LHsSigWcType (NoGhcTc GhcRn)
ty
obviousSig (HsPar XPar GhcRn
_ LHsToken "(" GhcRn
_ LHsExpr GhcRn
p LHsToken ")" GhcRn
_)        = HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
p)
obviousSig (HsPragE XPragE GhcRn
_ HsPragE GhcRn
_ LHsExpr GhcRn
p)        = HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (GenLocated SrcSpanAnnA (HsExpr GhcRn) -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
GenLocated SrcSpanAnnA (HsExpr GhcRn)
p)
obviousSig HsExpr GhcRn
_                      = Maybe (LHsSigWcType GhcRn)
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 -> TcRhoType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcRhoType
ty0
  = case HasCallStack => TcRhoType -> Maybe (TyCon, [TcRhoType])
TcRhoType -> Maybe (TyCon, [TcRhoType])
tcSplitTyConApp_maybe TcRhoType
ty of
      Just (TyCon
tc, [TcRhoType]
tys) -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just ((TyCon, [TcRhoType], Coercion) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 (FamInstEnvs
-> TyCon -> [TcRhoType] -> (TyCon, [TcRhoType], Coercion)
tcLookupDataFamInst FamInstEnvs
fam_inst_envs TyCon
tc [TcRhoType]
tys))
      Maybe (TyCon, [TcRhoType])
Nothing        -> Maybe TyCon
forall a. Maybe a
Nothing
  where
    ([TcId]
_, [TcRhoType]
_, TcRhoType
ty) = TcRhoType -> ([TcId], [TcRhoType], TcRhoType)
tcSplitSigmaTy TcRhoType
ty0

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


-- For an ambiguous record field, find all the candidate record
-- selectors (as GlobalRdrElts) and their parents.
lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents Bool
is_selector RdrName
rdr
  = do { GlobalRdrEnv
env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
        -- Filter by isRecFldGRE because otherwise a non-selector variable with
        -- an overlapping name can get through when NoFieldSelectors is enabled.
        -- See Note [NoFieldSelectors] in GHC.Rename.Env.
       ; let all_gres :: [GlobalRdrElt]
all_gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName' RdrName
rdr GlobalRdrEnv
env
       ; let gres :: [GlobalRdrElt]
gres | Bool
is_selector = (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
isFieldSelectorGRE [GlobalRdrElt]
all_gres
                  | Bool
otherwise   = (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
isRecFldGRE [GlobalRdrElt]
all_gres
       ; (GlobalRdrElt
 -> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt))
-> [GlobalRdrElt] -> RnM [(RecSelParent, GlobalRdrElt)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GlobalRdrElt
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
lookupParent [GlobalRdrElt]
gres }
  where
    lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
    lookupParent :: GlobalRdrElt
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
lookupParent GlobalRdrElt
gre = do { TcId
id <- Name -> TcM TcId
tcLookupId (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)
                          ; case TcId -> Maybe RecSelParent
recordSelectorTyCon_maybe TcId
id of
                              Just RecSelParent
rstc -> (RecSelParent, GlobalRdrElt)
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecSelParent
rstc, GlobalRdrElt
gre)
                              Maybe RecSelParent
Nothing -> TcRnMessage
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall a. TcRnMessage -> TcM a
failWithTc (Name -> TcRnMessage
notSelector (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)) }


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
text String
"field of type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RecSelParent -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecSelParent
p))

notSelector :: Name -> TcRnMessage
notSelector :: Name -> TcRnMessage
notSelector = Name -> TcRnMessage
TcRnNotARecordSelector


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

tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
              -> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig :: LHsExpr GhcRn
-> LHsSigWcType (NoGhcTc GhcRn) -> TcM (HsExpr GhcTc, TcRhoType)
tcExprWithSig LHsExpr GhcRn
expr LHsSigWcType (NoGhcTc GhcRn)
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 GhcRn -> Maybe Name -> TcM TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType GhcRn
LHsSigWcType (NoGhcTc GhcRn)
hs_ty Maybe Name
forall a. Maybe a
Nothing
       ; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcRhoType
poly_ty) <- UserTypeCtxt
-> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcRhoType)
tcExprSig UserTypeCtxt
ctxt LHsExpr GhcRn
expr TcIdSigInfo
sig_info
       ; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
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 NoExtField
XExprWithTySig GhcTc
noExtField LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr' LHsSigWcType (NoGhcTc GhcTc)
LHsSigWcType (NoGhcTc GhcRn)
hs_ty, TcRhoType
poly_ty) }
  where
    loc :: SrcSpan
loc = GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (LHsSigWcType GhcRn -> LHsSigType GhcRn
forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType GhcRn
LHsSigWcType (NoGhcTc GhcRn)
hs_ty)
    ctxt :: UserTypeCtxt
ctxt = ReportRedundantConstraints -> UserTypeCtxt
ExprSigCtxt (LHsSigWcType GhcRn -> ReportRedundantConstraints
lhsSigWcTypeContextSpan LHsSigWcType GhcRn
LHsSigWcType (NoGhcTc GhcRn)
hs_ty)

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

tcExprSig UserTypeCtxt
_ LHsExpr GhcRn
expr sig :: TcIdSigInfo
sig@(PartialSig { psig_name :: TcIdSigInfo -> Name
psig_name = Name
name, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
  = SrcSpan
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (IOEnv
   (Env TcGblEnv TcLclEnv)
   (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
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, TcId)]
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall r. [(Name, TcId)] -> TcM r -> TcM r
tcExtendNameTyVarEnv ((VarBndr TcId Specificity -> TcId)
-> [(Name, VarBndr TcId Specificity)] -> [(Name, TcId)]
forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd VarBndr TcId Specificity -> TcId
forall tv argf. VarBndr tv argf -> tv
binderVar ([(Name, VarBndr TcId Specificity)] -> [(Name, TcId)])
-> [(Name, VarBndr TcId Specificity)] -> [(Name, TcId)]
forall a b. (a -> b) -> a -> b
$ TcIdSigInst -> [(Name, VarBndr TcId Specificity)]
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, TcId)]
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall r. [(Name, TcId)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (TcIdSigInst -> [(Name, TcId)]
sig_inst_wcs   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
$
                              LHsExpr GhcRn -> TcRhoType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr (TcIdSigInst -> TcRhoType
sig_inst_tau TcIdSigInst
sig_inst)
                   ; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
-> TcM (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcIdSigInst)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcIdSigInst
sig_inst) }
       -- See Note [Partial expression signatures]
       ; let tau :: TcRhoType
tau = TcIdSigInst -> TcRhoType
sig_inst_tau TcIdSigInst
sig_inst
             infer_mode :: InferMode
infer_mode | [TcRhoType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TcIdSigInst -> [TcRhoType]
sig_inst_theta TcIdSigInst
sig_inst)
                        , Maybe TcRhoType -> Bool
forall a. Maybe a -> Bool
isNothing (TcIdSigInst -> Maybe TcRhoType
sig_inst_wcx TcIdSigInst
sig_inst)
                        = InferMode
ApplyMR
                        | Bool
otherwise
                        = InferMode
NoRestrictions
       ; (([TcId]
qtvs, [TcId]
givens, TcEvBinds
ev_binds, Bool
_), WantedConstraints
residual)
           <- TcM ([TcId], [TcId], TcEvBinds, Bool)
-> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM ([TcId], [TcId], TcEvBinds, Bool)
 -> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints))
-> TcM ([TcId], [TcId], TcEvBinds, Bool)
-> TcM (([TcId], [TcId], TcEvBinds, Bool), WantedConstraints)
forall a b. (a -> b) -> a -> b
$ TcLevel
-> InferMode
-> [TcIdSigInst]
-> [(Name, TcRhoType)]
-> WantedConstraints
-> TcM ([TcId], [TcId], TcEvBinds, Bool)
simplifyInfer TcLevel
tclvl InferMode
infer_mode [TcIdSigInst
sig_inst] [(Name
name, TcRhoType
tau)] WantedConstraints
wanted
       ; WantedConstraints -> TcM ()
emitConstraints WantedConstraints
residual

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

       ; String -> SDoc -> TcM ()
traceTc String
"tcExpSig" ([TcId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcId]
qtvs SDoc -> SDoc -> SDoc
$$ [TcId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcId]
givens SDoc -> SDoc -> SDoc
$$ TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcRhoType
inferred_sigma SDoc -> SDoc -> SDoc
$$ TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcRhoType
my_sigma)
       ; let poly_wrap :: HsWrapper
poly_wrap = HsWrapper
wrap
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [TcId] -> HsWrapper
mkWpTyLams [TcId]
qtvs
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [TcId] -> HsWrapper
mkWpLams [TcId]
givens
                         HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet  TcEvBinds
ev_binds
       ; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcRhoType)
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', TcRhoType
my_sigma) }


{- Note [Partial expression signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Partial type signatures on expressions are easy to get wrong.  But
here is a guiding principile
    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 GhcRn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferOverLit lit :: HsOverLit GhcRn
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 = rebindable
                                                 , ol_from_fun = L loc 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
       ; TcId
from_id <- Name -> TcM TcId
tcLookupId Name
from_name
       ; (HsWrapper
wrap1, TcRhoType
from_ty) <- CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
topInstantiate (HsOverLit GhcRn -> CtOrigin
LiteralOrigin HsOverLit GhcRn
lit) (TcId -> TcRhoType
idType TcId
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
forall a. EpAnn a
noAnn HsLit GhcTc
hs_lit)
       ; (HsWrapper
wrap2, Scaled TcRhoType
sarg_ty, TcRhoType
res_ty) <- ExpectedFunTyOrigin
-> Maybe TypedThing
-> (Int, [Scaled TcRhoType])
-> TcRhoType
-> TcM (HsWrapper, Scaled TcRhoType, TcRhoType)
matchActualFunTySigma ExpectedFunTyOrigin
herald Maybe TypedThing
mb_thing
                                                           (Int
1, []) TcRhoType
from_ty

       ; Coercion
co <- Maybe TypedThing -> TcRhoType -> TcRhoType -> TcM Coercion
unifyType Maybe TypedThing
mb_thing (HsLit GhcTc -> TcRhoType
forall (p :: Pass). HsLit (GhcPass p) -> TcRhoType
hsLitType HsLit GhcTc
hs_lit) (Scaled TcRhoType -> TcRhoType
forall a. Scaled a -> a
scaledThing Scaled TcRhoType
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
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 NoExtField
XVar GhcTc
noExtField (SrcSpanAnnN -> TcId -> GenLocated SrcSpanAnnN TcId
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TcId
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
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 GhcRn
lit { ol_ext :: XOverLit GhcTc
ol_ext = OverLitTc :: Bool -> HsExpr GhcTc -> TcRhoType -> OverLitTc
OverLitTc { $sel:ol_rebindable:OverLitTc :: Bool
ol_rebindable = Bool
rebindable
                                             , $sel:ol_witness:OverLitTc :: HsExpr GhcTc
ol_witness = HsExpr GhcTc
witness
                                             , $sel:ol_type:OverLitTc :: TcRhoType
ol_type = TcRhoType
res_ty } }
       ; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
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
forall a. EpAnn a
noAnn HsOverLit GhcTc
lit', TcRhoType
res_ty) }

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

tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId :: Name -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcCheckId Name
name ExpSigmaType
res_ty
  = do { (HsExpr GhcTc
expr, TcRhoType
actual_res_ty) <- Name -> TcM (HsExpr GhcTc, TcRhoType)
tcInferId Name
name
       ; String -> SDoc -> TcM ()
traceTc String
"tcCheckId" ([SDoc] -> SDoc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcRhoType
actual_res_ty, ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty])
       ; HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcRhoType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
-> TcM (HsExpr GhcTc)
forall a.
HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcRhoType
-> ExpSigmaType
-> TcM a
-> TcM a
addFunResCtxt HsExpr GhcRn
rn_fun [] TcRhoType
actual_res_ty ExpSigmaType
res_ty (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
         CtOrigin
-> HsExpr GhcRn
-> HsExpr GhcTc
-> TcRhoType
-> ExpSigmaType
-> TcM (HsExpr GhcTc)
tcWrapResultO (Name -> CtOrigin
OccurrenceOf Name
name) HsExpr GhcRn
rn_fun HsExpr GhcTc
expr TcRhoType
actual_res_ty ExpSigmaType
res_ty }
  where
    rn_fun :: HsExpr GhcRn
rn_fun = XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField (Name -> LocatedAn NameAnn 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, TcRhoType)
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, TcRhoType)
tc_infer_id Name
id_name
         else Name -> TcM (HsExpr GhcTc, TcRhoType)
tc_infer_assert Name
id_name }

  | Bool
otherwise
  = do { (HsExpr GhcTc
expr, TcRhoType
ty) <- Name -> TcM (HsExpr GhcTc, TcRhoType)
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
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcRhoType
ty)
       ; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcRhoType
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, TcRhoType)
tc_infer_assert Name
assert_name
  = do { TcId
assert_error_id <- Name -> TcM TcId
tcLookupId Name
assertErrorName
       ; (HsWrapper
wrap, TcRhoType
id_rho) <- CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
topInstantiate (Name -> CtOrigin
OccurrenceOf Name
assert_name)
                                          (TcId -> TcRhoType
idType TcId
assert_error_id)
       ; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
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 NoExtField
XVar GhcTc
noExtField (TcId -> GenLocated SrcSpanAnnN TcId
forall a an. a -> LocatedAn an a
noLocA TcId
assert_error_id)), TcRhoType
id_rho)
       }

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

             AGlobal (AnId TcId
id) -> TcId -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) p an.
(Monad m, XVar p ~ NoExtField,
 XRec p (IdP p) ~ GenLocated (SrcAnn an) TcId) =>
TcId -> m (HsExpr p, TcRhoType)
return_id TcId
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, TcRhoType)
tcInferDataCon DataCon
con
             AGlobal (AConLike (PatSynCon PatSyn
ps)) -> Name -> PatSyn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferPatSyn Name
id_name PatSyn
ps
             (TcTyThing -> Maybe TyCon
tcTyThingTyCon_maybe -> Just TyCon
tc) -> TyCon -> TcM (HsExpr GhcTc, TcRhoType)
fail_tycon TyCon
tc -- TyCon or TcTyCon
             ATyVar Name
name TcId
_ -> Name -> TcM (HsExpr GhcTc, TcRhoType)
fail_tyvar Name
name

             TcTyThing
_ -> TcRnMessage -> TcM (HsExpr GhcTc, TcRhoType)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (HsExpr GhcTc, TcRhoType))
-> TcRnMessage -> TcM (HsExpr GhcTc, TcRhoType)
forall a b. (a -> b) -> a -> b
$ TcTyThing -> TcRnMessage
TcRnExpectedValueId TcTyThing
thing }
  where
    fail_tycon :: TyCon -> TcM (HsExpr GhcTc, TcRhoType)
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 GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
gre Name
nm of
                      Just GlobalRdrElt
gre -> Int -> SDoc -> SDoc
nest Int
2 (GlobalRdrElt -> SDoc
pprNameProvenance GlobalRdrElt
gre)
                      Maybe GlobalRdrElt
Nothing  -> SDoc
empty
      NameSpace -> Name -> SDoc -> TcM (HsExpr GhcTc, TcRhoType)
fail_with_msg NameSpace
dataName Name
nm SDoc
pprov

    fail_tyvar :: Name -> TcM (HsExpr GhcTc, TcRhoType)
fail_tyvar Name
nm =
      let pprov :: SDoc
pprov = Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> 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, TcRhoType)
fail_with_msg NameSpace
varName Name
nm SDoc
pprov

    fail_with_msg :: NameSpace -> Name -> SDoc -> TcM (HsExpr GhcTc, TcRhoType)
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
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
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 :: SDoc -> SDoc -> ErrInfo
ErrInfo { errInfoContext :: SDoc
errInfoContext = SDoc
pprov, errInfoSupplementary :: SDoc
errInfoSupplementary = SDoc
import_err_msg SDoc -> SDoc -> SDoc
$$ SDoc
hint_msg }
        msg :: TcRnMessage
msg = UnitState -> TcRnMessageDetailed -> TcRnMessage
TcRnMessageWithInfo UnitState
unit_state
            (TcRnMessageDetailed -> TcRnMessage)
-> TcRnMessageDetailed -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ ErrInfo -> TcRnMessage -> TcRnMessageDetailed
TcRnMessageDetailed ErrInfo
info (Name -> Bool -> TcRnMessage
TcRnIncorrectNameSpace Name
nm Bool
False)
      TcRnMessage -> TcM (HsExpr GhcTc, TcRhoType)
forall a. TcRnMessage -> TcM a
failWithTc TcRnMessage
msg

    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))
       DynFlags
dflags  <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       LocalRdrEnv
lcl_env <- RnM LocalRdrEnv
getLocalRdrEnv
       ImportAvails
imp_info <- TcRn ImportAvails
getImports
       Module
curr_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       HomePackageTable
hpt <- TcRnIf TcGblEnv TcLclEnv HomePackageTable
forall gbl lcl. TcRnIf gbl lcl HomePackageTable
getHpt
       ([ImportError], [GhcHint])
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
forall (m :: * -> *) a. Monad m => a -> m a
return (([ImportError], [GhcHint])
 -> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint]))
-> ([ImportError], [GhcHint])
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
forall a b. (a -> b) -> a -> b
$ WhatLooking
-> DynFlags
-> HomePackageTable
-> Module
-> GlobalRdrEnv
-> LocalRdrEnv
-> ImportAvails
-> RdrName
-> ([ImportError], [GhcHint])
unknownNameSuggestions WhatLooking
WL_Anything DynFlags
dflags HomePackageTable
hpt Module
curr_mod GlobalRdrEnv
rdr_env
         LocalRdrEnv
lcl_env ImportAvails
imp_info (OccName -> RdrName
mkRdrUnqual OccName
occ)

    return_id :: TcId -> m (HsExpr p, TcRhoType)
return_id TcId
id = (HsExpr p, TcRhoType) -> m (HsExpr p, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar p -> XRec p (IdP p) -> HsExpr p
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar p
noExtField (TcId -> GenLocated (SrcAnn an) TcId
forall a an. a -> LocatedAn an a
noLocA TcId
id), TcId -> TcRhoType
idType TcId
id)

check_local_id :: Id -> TcM ()
check_local_id :: TcId -> TcM ()
check_local_id TcId
id
  = do { TcId -> TcM ()
checkThLocalId TcId
id
       ; UsageEnv -> TcM ()
tcEmitBindingUsage (UsageEnv -> TcM ()) -> UsageEnv -> TcM ()
forall a b. (a -> b) -> a -> b
$ Name -> TcRhoType -> UsageEnv
forall n. NamedThing n => n -> TcRhoType -> UsageEnv
unitUE (TcId -> Name
idName TcId
id) TcRhoType
One }

check_naughty :: OccName -> TcId -> TcM ()
check_naughty :: OccName -> TcId -> TcM ()
check_naughty OccName
lbl TcId
id
  | TcId -> Bool
isNaughtyRecordSelector TcId
id = TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (OccName -> TcRnMessage
TcRnRecSelectorEscapedTyVar OccName
lbl)
  | Bool
otherwise                  = () -> TcM ()
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, TcRhoType)
tcInferDataCon DataCon
con
  = do { let tvbs :: [VarBndr TcId Specificity]
tvbs  = DataCon -> [VarBndr TcId Specificity]
dataConUserTyVarBinders DataCon
con
             tvs :: [TcId]
tvs   = [VarBndr TcId Specificity] -> [TcId]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TcId Specificity]
tvbs
             theta :: [TcRhoType]
theta = DataCon -> [TcRhoType]
dataConOtherTheta DataCon
con
             args :: [Scaled TcRhoType]
args  = DataCon -> [Scaled TcRhoType]
dataConOrigArgTys DataCon
con
             res :: TcRhoType
res   = DataCon -> TcRhoType
dataConOrigResTy DataCon
con
             stupid_theta :: [TcRhoType]
stupid_theta = DataCon -> [TcRhoType]
dataConStupidTheta DataCon
con

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

       ; let full_theta :: [TcRhoType]
full_theta  = [TcRhoType]
stupid_theta [TcRhoType] -> [TcRhoType] -> [TcRhoType]
forall a. [a] -> [a] -> [a]
++ [TcRhoType]
theta
             all_arg_tys :: [Scaled TcRhoType]
all_arg_tys = (TcRhoType -> Scaled TcRhoType)
-> [TcRhoType] -> [Scaled TcRhoType]
forall a b. (a -> b) -> [a] -> [b]
map TcRhoType -> Scaled TcRhoType
forall a. a -> Scaled a
unrestricted [TcRhoType]
full_theta [Scaled TcRhoType] -> [Scaled TcRhoType] -> [Scaled TcRhoType]
forall a. [a] -> [a] -> [a]
++ [Scaled TcRhoType]
scaled_arg_tys
                -- stupid-theta must come first
                -- See Note [Instantiating stupid theta]

       ; (HsExpr GhcTc, TcRhoType) -> TcM (HsExpr GhcTc, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( XXExpr GhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (ConLike -> [TcId] -> [Scaled TcRhoType] -> XXExprGhcTc
ConLikeTc (DataCon -> ConLike
RealDataCon DataCon
con) [TcId]
tvs [Scaled TcRhoType]
all_arg_tys)
                , [VarBndr TcId Specificity] -> TcRhoType -> TcRhoType
mkInvisForAllTys [VarBndr TcId Specificity]
tvbs (TcRhoType -> TcRhoType) -> TcRhoType -> TcRhoType
forall a b. (a -> b) -> a -> b
$ [TcRhoType] -> TcRhoType -> TcRhoType
mkPhiTy [TcRhoType]
full_theta (TcRhoType -> TcRhoType) -> TcRhoType -> TcRhoType
forall a b. (a -> b) -> a -> b
$
                  [Scaled TcRhoType] -> TcRhoType -> TcRhoType
mkVisFunTys [Scaled TcRhoType]
scaled_arg_tys TcRhoType
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 TcRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcRhoType)
linear_to_poly (Scaled TcRhoType
One TcRhoType
ty) = do { TcRhoType
mul_var <- TcRhoType -> TcM TcRhoType
newFlexiTyVarTy TcRhoType
multiplicityTy
                                        ; Scaled TcRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcRhoType -> TcRhoType -> Scaled TcRhoType
forall a. TcRhoType -> a -> Scaled a
Scaled TcRhoType
mul_var TcRhoType
ty) }
    linear_to_poly Scaled TcRhoType
scaled_ty       = Scaled TcRhoType
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return Scaled TcRhoType
scaled_ty

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

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

{- 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,
mostly in tcInferDataCon:

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

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

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

4. The (ConLikeTc K [r,a] [Scaled p a]) is later desugared by
   GHC.HsToCore.Expr.dsConLike 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.Utils.Zonk.commitFlexi`. So it won't just be an
   (unbound) variable.

Wrinkles

* Note that the [TcType] is strictly redundant anyway; 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.

* 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#

  We then rely on the simple optimiser to beta reduce the lambda.

* See Note [Instantiating stupid theta] for an extra wrinkle


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 [Instantiating stupid theta]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a data type with a "stupid theta" (see
Note [The stupid context] in GHC.Core.DataCon):

  data Ord a => T a = MkT (Maybe a)

We want to generate an Ord constraint for every use of MkT; but
we also want to allow visible type application, such as
   MkT @Int

So we generate (ConLikeTc MkT [a] [Ord a, Maybe a]), with type
   forall a. Ord a => Maybe a -> T a

Now visible type application will work fine. But we desugar the
ConLikeTc to
   /\a \(d:Ord a) (x:Maybe a). MkT x
Notice that 'd' is dropped in this desugaring. We don't need it;
it was only there to generate a Wanted constraint. (That is why
it is stupid.)  To achieve this:

* We put the stupid-thata at the front of the list of argument
  types in ConLikeTc

* GHC.HsToCore.Expr.dsConLike generates /lambdas/ for all the
  arguments, but drops the stupid-theta arguments when building the
  /application/.

Nice.
-}

{-
************************************************************************
*                                                                      *
                 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 :: TcId -> TcM ()
checkThLocalId TcId
id
  = do  { Maybe (TopLevelFlag, Int, ThStage)
mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, Int, ThStage))
getStageAndBindLevel (TcId -> Name
idName TcId
id)
        ; case Maybe (TopLevelFlag, Int, ThStage)
mb_local_use of
             Just (TopLevelFlag
top_lvl, Int
bind_lvl, ThStage
use_stage)
                | ThStage -> Int
thLevel ThStage
use_stage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
bind_lvl
                -> TopLevelFlag -> TcId -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl TcId
id ThStage
use_stage
             Maybe (TopLevelFlag, Int, ThStage)
_  -> () -> TcM ()
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 -> TcId -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl TcId
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 :: TcRhoType
id_ty = TcId -> TcRhoType
idType TcId
id
        ; Bool -> TcRnMessage -> TcM ()
checkTc (TcRhoType -> Bool
isTauTy TcRhoType
id_ty) (TcId -> TcRnMessage
TcRnSplicePolymorphicLocalVar TcId
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 TcRhoType -> Bool
isStringTy TcRhoType
id_ty then
                     do { TcId
sid <- Name -> TcM TcId
tcLookupId Name
GHC.Builtin.Names.TH.liftStringName
                                     -- See Note [Lifting strings]
                        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcTc -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (TcId -> GenLocated SrcSpanAnnN TcId
forall a an. a -> LocatedAn an a
noLocA TcId
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 -> [TcRhoType] -> TcM (HsExpr GhcTc)
newMethodFromName (Name -> CtOrigin
OccurrenceOf Name
id_name)
                                       Name
GHC.Builtin.Names.TH.liftName
                                       [HasDebugCallStack => TcRhoType -> TcRhoType
TcRhoType -> TcRhoType
getRuntimeRep TcRhoType
id_ty, TcRhoType
id_ty]

                   -- Warning for implicit lift (#17804)
        ; (ErrInfo -> TcRnMessage) -> TcM ()
addDetailedDiagnostic (TcId -> ErrInfo -> TcRnMessage
forall var. Outputable var => var -> ErrInfo -> TcRnMessage
TcRnImplicitLift TcId
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
TcId
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 (m :: * -> *) a. Monad m => a -> m a
return () }
  where
    id_name :: Name
id_name = TcId -> Name
idName TcId
id

checkCrossStageLifting TopLevelFlag
_ TcId
_ ThStage
_ = () -> TcM ()
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 :: HsExpr GhcRn
-> [HsExprArg 'TcpRn]
-> TcRhoType
-> ExpSigmaType
-> TcM a
-> TcM a
addFunResCtxt HsExpr GhcRn
fun [HsExprArg 'TcpRn]
args TcRhoType
fun_res_ty ExpSigmaType
env_ty TcM a
thing_inside
  = (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM (\TidyEnv
env -> (TidyEnv
env, ) (SDoc -> (TidyEnv, SDoc))
-> IOEnv (Env TcGblEnv TcLclEnv) SDoc -> TcM (TidyEnv, SDoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) SDoc
mk_msg) 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 :: IOEnv (Env TcGblEnv TcLclEnv) SDoc
mk_msg
      = do { Maybe TcRhoType
mb_env_ty <- ExpSigmaType -> TcM (Maybe TcRhoType)
readExpType_maybe ExpSigmaType
env_ty
                     -- by the time the message is rendered, the ExpType
                     -- will be filled in (except if we're debugging)
           ; TcRhoType
fun_res' <- TcRhoType -> TcM TcRhoType
zonkTcType TcRhoType
fun_res_ty
           ; TcRhoType
env'     <- case Maybe TcRhoType
mb_env_ty of
                           Just TcRhoType
env_ty -> TcRhoType -> TcM TcRhoType
zonkTcType TcRhoType
env_ty
                           Maybe TcRhoType
Nothing     ->
                             do { Bool
dumping <- DumpFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
Opt_D_dump_tc_trace
                                ; Bool -> TcM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert Bool
dumping
                                ; TcRhoType -> TcM TcRhoType
newFlexiTyVarTy TcRhoType
liftedTypeKind }
           ; let -- See Note [Splitting nested sigma types in mismatched
                 --           function types]
                 ([TcId]
_, [TcRhoType]
_, TcRhoType
fun_tau) = TcRhoType -> ([TcId], [TcRhoType], TcRhoType)
tcSplitNestedSigmaTys TcRhoType
fun_res'
                 -- No need to call tcSplitNestedSigmaTys here, since env_ty is
                 -- an ExpRhoTy, i.e., it's already instantiated.
                 ([TcId]
_, [TcRhoType]
_, TcRhoType
env_tau) = TcRhoType -> ([TcId], [TcRhoType], TcRhoType)
tcSplitSigmaTy TcRhoType
env'
                 ([Scaled TcRhoType]
args_fun, TcRhoType
res_fun) = TcRhoType -> ([Scaled TcRhoType], TcRhoType)
tcSplitFunTys TcRhoType
fun_tau
                 ([Scaled TcRhoType]
args_env, TcRhoType
res_env) = TcRhoType -> ([Scaled TcRhoType], TcRhoType)
tcSplitFunTys TcRhoType
env_tau
                 n_fun :: Int
n_fun = [Scaled TcRhoType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled TcRhoType]
args_fun
                 n_env :: Int
n_env = [Scaled TcRhoType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled TcRhoType]
args_env
                 info :: SDoc
info  | -- Check for too few args
                         --  fun_tau = a -> b, res_tau = Int
                         Int
n_fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_env
                       , TcRhoType -> Bool
not_fun TcRhoType
res_env
                       = String -> SDoc
text String
"Probable cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun)
                         SDoc -> SDoc -> SDoc
<+> String -> SDoc
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)
                         Int
n_fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n_env
                       , TcRhoType -> Bool
not_fun TcRhoType
res_fun
                       , (Int
n_fun Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (HsExprArg 'TcpRn -> Bool) -> [HsExprArg 'TcpRn] -> Int
forall a. (a -> Bool) -> [a] -> Int
count HsExprArg 'TcpRn -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isValArg [HsExprArg 'TcpRn]
args) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n_env
                          -- Never suggest that a naked variable is
                                           -- applied to too many args!
                       = String -> SDoc
text String
"Possible cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun)
                         SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is applied to too many arguments"

                       | Bool
otherwise
                       = SDoc
Outputable.empty

           ; SDoc -> IOEnv (Env TcGblEnv TcLclEnv) SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
info }

    not_fun :: TcRhoType -> Bool
not_fun TcRhoType
ty   -- ty is definitely not an arrow type,
                 -- and cannot conceivably become one
      = case HasCallStack => TcRhoType -> Maybe (TyCon, [TcRhoType])
TcRhoType -> Maybe (TyCon, [TcRhoType])
tcSplitTyConApp_maybe TcRhoType
ty of
          Just (TyCon
tc, [TcRhoType]
_) -> TyCon -> Bool
isAlgTyCon TyCon
tc
          Maybe (TyCon, [TcRhoType])
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) => 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: 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: [Maybe a]
  Return type: Maybe b

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


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

addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
e TcRn a
thing_inside
  = case HsExpr GhcRn
e of
      HsUnboundVar {} -> TcRn a
thing_inside
      HsExpr GhcRn
_ -> SDoc -> TcRn a -> TcRn a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr GhcRn -> SDoc
exprCtxt HsExpr GhcRn
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 GhcRn -> SDoc
exprCtxt HsExpr GhcRn
expr = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the expression:") Int
2 (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HsExpr GhcRn -> HsExpr GhcRn
forall (p :: Pass). HsExpr (GhcPass p) -> HsExpr (GhcPass p)
stripParensHsExpr HsExpr GhcRn
expr))