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

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

       , tcInferAppHead, tcInferAppHead_maybe
       , tcInferId, tcCheckId
       , obviousSig, addAmbiguousNameErr
       , 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.Pat
import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )
import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Types.Basic
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst )
import GHC.Core.FamInstEnv    ( FamInstEnvs )
import GHC.Core.UsageEnv      ( unitUE )
import GHC.Rename.Env         ( addUsedGRE )
import GHC.Rename.Utils       ( addNameClashErrRn, unknownSubordinateErr )
import GHC.Tc.Solver          ( InferMode(..), simplifyInfer )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Zonk      ( hsLitType )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Hs
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.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.Session
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import Control.Monad

import Data.Function
import qualified Data.List.NonEmpty as NE

#include "HsVersions.h"

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

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

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

  | EWrap    EWrap

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

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

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

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

  | 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 (GhcPass 'Renamed)
_ SrcSpan
l) = SrcSpan
l
appCtxtLoc (VACall HsExpr (GhcPass 'Renamed)
_ ThLevel
_ SrcSpan
l)    = SrcSpan
l

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

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

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

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

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

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

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

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

splitHsApps :: HsExpr GhcRn
            -> ( (HsExpr GhcRn, AppCtxt)  -- Head
               , [HsExprArg 'TcpRn])      -- Args
-- See Note [splitHsApps]
splitHsApps :: HsExpr (GhcPass 'Renamed)
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr (GhcPass 'Renamed)
e = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
e (ThLevel -> HsExpr (GhcPass 'Renamed) -> AppCtxt
top_ctxt ThLevel
0 HsExpr (GhcPass 'Renamed)
e) []
  where
    top_ctxt :: ThLevel -> HsExpr (GhcPass 'Renamed) -> AppCtxt
top_ctxt ThLevel
n (HsPar XPar (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun)               = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt ThLevel
n GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
LHsExpr (GhcPass 'Renamed)
fun
    top_ctxt ThLevel
n (HsPragE XPragE (GhcPass 'Renamed)
_ HsPragE (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun)           = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt ThLevel
n GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
LHsExpr (GhcPass 'Renamed)
fun
    top_ctxt ThLevel
n (HsAppType XAppTypeE (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun LHsWcType (NoGhcTc (GhcPass 'Renamed))
_)         = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt (ThLevel
nThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ThLevel
1) GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
LHsExpr (GhcPass 'Renamed)
fun
    top_ctxt ThLevel
n (HsApp XApp (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
fun LHsExpr (GhcPass 'Renamed)
_)             = ThLevel
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> AppCtxt
top_lctxt (ThLevel
nThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ThLevel
1) GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
LHsExpr (GhcPass 'Renamed)
fun
    top_ctxt ThLevel
n (XExpr (HsExpanded HsExpr (GhcPass 'Renamed)
orig HsExpr (GhcPass 'Renamed)
_)) = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
orig      ThLevel
n SrcSpan
noSrcSpan
    top_ctxt ThLevel
n HsExpr (GhcPass 'Renamed)
other_fun                   = HsExpr (GhcPass 'Renamed) -> ThLevel -> SrcSpan -> AppCtxt
VACall HsExpr (GhcPass 'Renamed)
other_fun ThLevel
n SrcSpan
noSrcSpan

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

    go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
       -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
    go :: HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go (HsPar XPar (GhcPass 'Renamed)
_     (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun))    AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
set SrcSpanAnnA
l AppCtxt
ctxt) (EWrap -> HsExprArg 'TcpRn
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (AppCtxt -> EWrap
EPar AppCtxt
ctxt)   HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
    go (HsPragE XPragE (GhcPass 'Renamed)
_ HsPragE (GhcPass 'Renamed)
p (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun))    AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
set SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> HsPragE (GhcPass (XPass 'TcpRn)) -> HsExprArg 'TcpRn
forall (p :: TcPass).
AppCtxt -> HsPragE (GhcPass (XPass p)) -> HsExprArg p
EPrag      AppCtxt
ctxt HsPragE (GhcPass 'Renamed)
HsPragE (GhcPass (XPass 'TcpRn))
p   HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
    go (HsAppType XAppTypeE (GhcPass 'Renamed)
_ (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun) LHsWcType (NoGhcTc (GhcPass 'Renamed))
ty) AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> LHsWcType (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkETypeArg AppCtxt
ctxt LHsWcType (NoGhcTc (GhcPass 'Renamed))
LHsWcType (GhcPass 'Renamed)
ty  HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)
    go (HsApp XApp (GhcPass 'Renamed)
_ (L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
fun) LHsExpr (GhcPass 'Renamed)
arg)    AppCtxt
ctxt [HsExprArg 'TcpRn]
args = HsExpr (GhcPass 'Renamed)
-> AppCtxt
-> [HsExprArg 'TcpRn]
-> ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
go HsExpr (GhcPass 'Renamed)
fun (SrcSpanAnnA -> AppCtxt -> AppCtxt
dec SrcSpanAnnA
l AppCtxt
ctxt) (AppCtxt -> LHsExpr (GhcPass 'Renamed) -> HsExprArg 'TcpRn
mkEValArg  AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
arg HsExprArg 'TcpRn -> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpRn]
args)

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

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

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

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

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

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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
lfun LHsExpr GhcTc
LHsExpr (GhcPass (XPass 'TcpTc))
arg) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
      ETypeArg { eva_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
eva_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty, eva_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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
lfun LHsWcType (NoGhcTc GhcTc)
LHsWcType (GhcPass 'Renamed)
hs_ty) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
      EPrag AppCtxt
ctxt' HsPragE (GhcPass (XPass 'TcpTc))
p
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
      EWrap (EPar AppCtxt
ctxt')
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (XPar GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcTc
forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
lfun) AppCtxt
ctxt' [HsExprArg 'TcpTc]
args
      EWrap (EExpand HsExpr (GhcPass 'Renamed)
orig)
        -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (XXExpr GhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (HsExpansion (HsExpr (GhcPass 'Renamed)) (HsExpr GhcTc)
-> XXExprGhcTc
ExpansionExpr (HsExpr (GhcPass 'Renamed)
-> HsExpr GhcTc
-> HsExpansion (HsExpr (GhcPass 'Renamed)) (HsExpr GhcTc)
forall a b. a -> b -> HsExpansion a b
HsExpanded HsExpr (GhcPass 'Renamed)
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 :: forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg (EValArg {}) = Bool
True
isHsValArg HsExprArg id
_            = Bool
False

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

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

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

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 (GhcPass 'Renamed)
eva_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty }) = Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<> HsWildCardBndrs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWildCardBndrs
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
LHsWcType (GhcPass 'Renamed)
hs_ty
  ppr (EWrap EWrap
wrap)                     = EWrap -> SDoc
forall a. Outputable a => a -> SDoc
ppr EWrap
wrap

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

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

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

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

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

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

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

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

tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
               -> [HsExprArg 'TcpRn] -> Maybe TcRhoType
               -- These two args are solely for tcInferRecSelId
               -> 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 HsRecFld
--   * 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?  For two reasons:
--   * (Legitimate) The first arg has the source location of the head
--   * (Disgusting) Needed for record disambiguation; see tcInferRecSelId
--
-- Note that [] and (,,) are both HsVar:
--   see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr
--
-- NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those
--     cases are dealt with by splitHsApps.
--
-- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App
tcInferAppHead :: (HsExpr (GhcPass 'Renamed), AppCtxt)
-> [HsExprArg 'TcpRn]
-> Maybe TcSigmaType
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferAppHead (HsExpr (GhcPass 'Renamed)
fun,AppCtxt
ctxt) [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
  = SrcSpan
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (AppCtxt -> SrcSpan
appCtxtLoc AppCtxt
ctxt) (TcM (HsExpr GhcTc, TcSigmaType)
 -> TcM (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
    do { Maybe (HsExpr GhcTc, TcSigmaType)
mb_tc_fun <- HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> Maybe TcSigmaType
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
       ; case Maybe (HsExpr GhcTc, TcSigmaType)
mb_tc_fun of
            Just (HsExpr GhcTc
fun', TcSigmaType
fun_sigma) -> (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
fun', TcSigmaType
fun_sigma)
            Maybe (HsExpr GhcTc, TcSigmaType)
Nothing -> HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a.
HsExpr (GhcPass 'Renamed) -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args (TcM (HsExpr GhcTc, TcSigmaType)
 -> TcM (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
                       (ExpRhoType -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc, TcSigmaType)
forall a. (ExpRhoType -> TcM a) -> TcM (a, TcSigmaType)
tcInfer (HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr (GhcPass 'Renamed)
fun) }

tcInferAppHead_maybe :: HsExpr GhcRn
                     -> [HsExprArg 'TcpRn] -> Maybe TcRhoType
                        -- These two args are solely for tcInferRecSelId
                     -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
-- Returns Nothing for a complicated head
tcInferAppHead_maybe :: HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> Maybe TcSigmaType
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
tcInferAppHead_maybe HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
  = case HsExpr (GhcPass 'Renamed)
fun of
      HsVar XVar (GhcPass 'Renamed)
_ (L SrcAnn NameAnn
_ Name
nm)          -> (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
nm
      HsRecFld XRecFld (GhcPass 'Renamed)
_ AmbiguousFieldOcc (GhcPass 'Renamed)
f              -> (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AmbiguousFieldOcc (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> Maybe TcSigmaType
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId AmbiguousFieldOcc (GhcPass 'Renamed)
f [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
      ExprWithTySig XExprWithTySig (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty   -> HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall a.
HsExpr (GhcPass 'Renamed) -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args (TcM (Maybe (HsExpr GhcTc, TcSigmaType))
 -> TcM (Maybe (HsExpr GhcTc, TcSigmaType)))
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall a b. (a -> b) -> a -> b
$
                                   (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr (GhcPass 'Renamed)
-> LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
-> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty
      HsOverLit XOverLitE (GhcPass 'Renamed)
_ HsOverLit (GhcPass 'Renamed)
lit           -> (HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType)
forall a. a -> Maybe a
Just ((HsExpr GhcTc, TcSigmaType) -> Maybe (HsExpr GhcTc, TcSigmaType))
-> TcM (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsOverLit (GhcPass 'Renamed) -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferOverLit HsOverLit (GhcPass 'Renamed)
lit
      HsExpr (GhcPass 'Renamed)
_                         -> Maybe (HsExpr GhcTc, TcSigmaType)
-> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (HsExpr GhcTc, TcSigmaType)
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 :: forall a.
HsExpr (GhcPass 'Renamed) -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
add_head_ctxt HsExpr (GhcPass 'Renamed)
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 (GhcPass 'Renamed) -> TcM a -> TcM a
forall a. HsExpr (GhcPass 'Renamed) -> TcRn a -> TcRn a
addExprCtxt HsExpr (GhcPass 'Renamed)
fun TcM a
thing_inside


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

{-
Note [Deprecating ambiguous fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the future, the -XDuplicateRecordFields extension will no longer support
disambiguating record fields during type-checking (as described in Note
[Disambiguating record fields]).  For now, the -Wambiguous-fields option will
emit a warning whenever an ambiguous field is resolved using type information.
In a subsequent GHC release, this functionality will be removed and the warning
will turn into an ambiguity error in the renamer.

For background information, see GHC proposal #366
(https://github.com/ghc-proposals/ghc-proposals/pull/366).


Note [Disambiguating record fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
NB. The following is going to be removed: see
Note [Deprecating ambiguous fields].

When the -XDuplicateRecordFields extension is used, and the renamer
encounters a record selector or update that it cannot immediately
disambiguate (because it involves fields that belong to multiple
datatypes), it will defer resolution of the ambiguity to the
typechecker.  In this case, the `Ambiguous` constructor of
`AmbiguousFieldOcc` is used.

Consider the following definitions:

        data S = MkS { foo :: Int }
        data T = MkT { foo :: Int, bar :: Int }
        data U = MkU { bar :: Int, baz :: Int }

When the renamer sees `foo` as a selector or an update, it will not
know which parent datatype is in use.

For selectors, there are two possible ways to disambiguate:

1. Check if the pushed-in type is a function whose domain is a
   datatype, for example:

       f s = (foo :: S -> Int) s

       g :: T -> Int
       g = foo

    This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.

2. Check if the selector is applied to an argument that has a type
   signature, for example:

       h = foo (s :: S)

    This is checked by `tcInferRecSelId`.


Updates are slightly more complex.  The `disambiguateRecordBinds`
function tries to determine the parent datatype in three ways:

1. Check for types that have all the fields being updated. For example:

        f x = x { foo = 3, bar = 2 }

   Here `f` must be updating `T` because neither `S` nor `U` have
   both fields. This may also discover that no possible type exists.
   For example the following will be rejected:

        f' x = x { foo = 3, baz = 3 }

2. Use the type being pushed in, if it is already a TyConApp. The
   following are valid updates to `T`:

        g :: T -> T
        g x = x { foo = 3 }

        g' x = x { foo = 3 } :: T

3. Use the type signature of the record expression, if it exists and
   is a TyConApp. Thus this is valid update to `T`:

        h x = (x :: T) { foo = 3 }


Note that we do not look up the types of variables being updated, and
no constraint-solving is performed, so for example the following will
be rejected as ambiguous:

     let bad (s :: S) = foo s

     let r :: T
         r = blah
     in r { foo = 3 }

     \r. (r { foo = 3 },  r :: T )

We could add further tests, of a more heuristic nature. For example,
rather than looking for an explicit signature, we could try to infer
the type of the argument to a selector or the record expression being
updated, in case we are lucky enough to get a TyConApp straight
away. However, it might be hard for programmers to predict whether a
particular update is sufficiently obvious for the signature to be
omitted. Moreover, this might change the behaviour of typechecker in
non-obvious ways.

See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat.
-}

tcInferRecSelId :: AmbiguousFieldOcc GhcRn
                -> [HsExprArg 'TcpRn] -> Maybe TcRhoType
                -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId :: AmbiguousFieldOcc (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> Maybe TcSigmaType
-> TcM (HsExpr GhcTc, TcSigmaType)
tcInferRecSelId (Unambiguous XUnambiguous (GhcPass 'Renamed)
sel_name LocatedN RdrName
lbl) [HsExprArg 'TcpRn]
_args Maybe TcSigmaType
_mb_res_ty
   = do { Id
sel_id <- LocatedN RdrName -> Name -> TcM Id
tc_rec_sel_id LocatedN RdrName
lbl Name
XUnambiguous (GhcPass 'Renamed)
sel_name
        ; let expr :: HsExpr GhcTc
expr = XRecFld GhcTc -> AmbiguousFieldOcc GhcTc -> HsExpr GhcTc
forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld NoExtField
XRecFld GhcTc
noExtField (XUnambiguous GhcTc -> LocatedN RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Unambiguous Id
XUnambiguous GhcTc
sel_id LocatedN RdrName
lbl)
        ; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, Id -> TcSigmaType
idType Id
sel_id) }

tcInferRecSelId (Ambiguous XAmbiguous (GhcPass 'Renamed)
_ LocatedN RdrName
lbl) [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
   = do { Name
sel_name <- LocatedN RdrName
-> [HsExprArg 'TcpRn] -> Maybe TcSigmaType -> TcM Name
tcInferAmbiguousRecSelId LocatedN RdrName
lbl [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
        ; Id
sel_id   <- LocatedN RdrName -> Name -> TcM Id
tc_rec_sel_id LocatedN RdrName
lbl Name
sel_name
        ; let expr :: HsExpr GhcTc
expr = XRecFld GhcTc -> AmbiguousFieldOcc GhcTc -> HsExpr GhcTc
forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld NoExtField
XRecFld GhcTc
noExtField (XAmbiguous GhcTc -> LocatedN RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XAmbiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass
Ambiguous Id
XAmbiguous GhcTc
sel_id LocatedN RdrName
lbl)
        ; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, Id -> TcSigmaType
idType Id
sel_id) }

------------------------
tc_rec_sel_id :: LocatedN RdrName -> Name -> TcM TcId
-- Like tc_infer_id, but returns an Id not a HsExpr,
-- so we can wrap it back up into a HsRecFld
tc_rec_sel_id :: LocatedN RdrName -> Name -> TcM Id
tc_rec_sel_id LocatedN RdrName
lbl Name
sel_name
  = do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
sel_name
       ; case TcTyThing
thing of
             ATcId { tct_id :: TcTyThing -> Id
tct_id = Id
id }
               -> do { OccName -> Id -> TcM ()
check_naughty OccName
occ Id
id
                     ; Id -> TcM ()
check_local_id Id
id
                     ; Id -> TcM Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
id }

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

             TcTyThing
_ -> SDoc -> TcM Id
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcM Id) -> SDoc -> TcM Id
forall a b. (a -> b) -> a -> b
$
                  TcTyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyThing
thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"used where a value identifier was expected" }
  where
    occ :: OccName
occ = RdrName -> OccName
rdrNameOcc (LocatedN RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc LocatedN RdrName
lbl)

------------------------
tcInferAmbiguousRecSelId :: LocatedN RdrName
                         -> [HsExprArg 'TcpRn] -> Maybe TcRhoType
                         -> TcM Name
-- Disgusting special case for ambiguous record selectors
-- Given a RdrName that refers to multiple record fields, and the type
-- of its argument, try to determine the name of the selector that is
-- meant.
-- See Note [Disambiguating record fields]
tcInferAmbiguousRecSelId :: LocatedN RdrName
-> [HsExprArg 'TcpRn] -> Maybe TcSigmaType -> TcM Name
tcInferAmbiguousRecSelId LocatedN RdrName
lbl [HsExprArg 'TcpRn]
args Maybe TcSigmaType
mb_res_ty
  | HsExprArg 'TcpRn
arg1 : [HsExprArg 'TcpRn]
_ <- (HsExprArg 'TcpRn -> Bool)
-> [HsExprArg 'TcpRn] -> [HsExprArg 'TcpRn]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool)
-> (HsExprArg 'TcpRn -> Bool) -> HsExprArg 'TcpRn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExprArg 'TcpRn -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isVisibleArg) [HsExprArg 'TcpRn]
args -- A value arg is first
  , EValArg { eva_arg :: forall (p :: TcPass). HsExprArg p -> EValArg p
eva_arg = ValArg (L SrcSpanAnnA
_ HsExpr (GhcPass 'Renamed)
arg) } <- HsExprArg 'TcpRn
arg1
  , Just LHsSigWcType (GhcPass 'Renamed)
sig_ty <- HsExpr (GhcPass 'Renamed)
-> Maybe (LHsSigWcType (GhcPass 'Renamed))
obviousSig HsExpr (GhcPass 'Renamed)
arg  -- A type sig on the arg disambiguates
  = do { TcSigmaType
sig_tc_ty <- UserTypeCtxt -> LHsSigWcType (GhcPass 'Renamed) -> TcM TcSigmaType
tcHsSigWcType UserTypeCtxt
ExprSigCtxt LHsSigWcType (GhcPass 'Renamed)
sig_ty
       ; LocatedN RdrName -> TcSigmaType -> TcM Name
finish_ambiguous_selector LocatedN RdrName
lbl TcSigmaType
sig_tc_ty }

  | Just TcSigmaType
res_ty <- Maybe TcSigmaType
mb_res_ty
  , Just (Scaled TcSigmaType
arg_ty,TcSigmaType
_) <- TcSigmaType -> Maybe (Scaled TcSigmaType, TcSigmaType)
tcSplitFunTy_maybe TcSigmaType
res_ty
  = LocatedN RdrName -> TcSigmaType -> TcM Name
finish_ambiguous_selector LocatedN RdrName
lbl (Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
arg_ty)

  | Bool
otherwise
  = LocatedN RdrName -> TcM Name
forall a. LocatedN RdrName -> TcM a
ambiguousSelector LocatedN RdrName
lbl

finish_ambiguous_selector :: LocatedN RdrName -> Type -> TcM Name
finish_ambiguous_selector :: LocatedN RdrName -> TcSigmaType -> TcM Name
finish_ambiguous_selector lr :: LocatedN RdrName
lr@(L SrcAnn NameAnn
_ RdrName
rdr) TcSigmaType
parent_type
 = do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
      ; case FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcSigmaType
parent_type of {
          Maybe TyCon
Nothing -> LocatedN RdrName -> TcM Name
forall a. LocatedN RdrName -> TcM a
ambiguousSelector LocatedN RdrName
lr ;
          Just TyCon
p  ->

    do { [(RecSelParent, GlobalRdrElt)]
xs <- Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents Bool
True RdrName
rdr
       ; let parent :: RecSelParent
parent = TyCon -> RecSelParent
RecSelData TyCon
p
       ; case RecSelParent
-> [(RecSelParent, GlobalRdrElt)] -> Maybe GlobalRdrElt
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RecSelParent
parent [(RecSelParent, GlobalRdrElt)]
xs of {
           Maybe GlobalRdrElt
Nothing  -> SDoc -> TcM Name
forall a. SDoc -> TcM a
failWithTc (RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
parent RdrName
rdr) ;
           Just GlobalRdrElt
gre ->

    -- See Note [Unused name reporting and HasField] in GHC.Tc.Instance.Class
    do { Bool -> GlobalRdrElt -> TcM ()
addUsedGRE Bool
True GlobalRdrElt
gre
       ; Name -> TcM ()
keepAlive (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)
         -- See Note [Deprecating ambiguous fields]
       ; WarningFlag -> Bool -> SDoc -> TcM ()
warnIfFlag WarningFlag
Opt_WarnAmbiguousFields Bool
True (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
          [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The field" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
rdr)
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"belonging to type" SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
parent_type
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is ambiguous."
               , String -> SDoc
text String
"This will not be supported by -XDuplicateRecordFields in future releases of GHC."
               , if GlobalRdrElt -> Bool
isLocalGRE GlobalRdrElt
gre
                 then String -> SDoc
text String
"You can use explicit case analysis to resolve the ambiguity."
                 else String -> SDoc
text String
"You can use a qualified import or explicit case analysis to resolve the ambiguity."
               ]
       ; Name -> TcM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre) } } } } }

-- This field name really is ambiguous, so add a suitable "ambiguous
-- occurrence" error, then give up.
ambiguousSelector :: LocatedN RdrName -> TcM a
ambiguousSelector :: forall a. LocatedN RdrName -> TcM a
ambiguousSelector (L SrcAnn NameAnn
_ RdrName
rdr)
  = do { RdrName -> TcM ()
addAmbiguousNameErr RdrName
rdr
       ; TcM a
forall env a. IOEnv env a
failM }

-- | This name really is ambiguous, so add a suitable "ambiguous
-- occurrence" error, then continue
addAmbiguousNameErr :: RdrName -> TcM ()
addAmbiguousNameErr :: RdrName -> TcM ()
addAmbiguousNameErr RdrName
rdr
  = do { GlobalRdrEnv
env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; let gres :: [GlobalRdrElt]
gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName RdrName
rdr GlobalRdrEnv
env
       ; case [GlobalRdrElt]
gres of
         [] -> String -> TcM ()
forall a. String -> a
panic String
"addAmbiguousNameErr: not found"
         GlobalRdrElt
gre : [GlobalRdrElt]
gres -> [ErrCtxt] -> TcM () -> TcM ()
forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [] (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ RdrName -> NonEmpty GlobalRdrElt -> TcM ()
addNameClashErrRn RdrName
rdr (NonEmpty GlobalRdrElt -> TcM ())
-> NonEmpty GlobalRdrElt -> TcM ()
forall a b. (a -> b) -> a -> b
$ GlobalRdrElt
gre GlobalRdrElt -> [GlobalRdrElt] -> NonEmpty GlobalRdrElt
forall a. a -> [a] -> NonEmpty a
NE.:| [GlobalRdrElt]
gres}

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

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

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


-- 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 { Id
id <- Name -> TcM Id
tcLookupId (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)
                          ; case Id -> Maybe RecSelParent
recordSelectorTyCon_maybe Id
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 -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall a. SDoc -> TcM a
failWithTc (Name -> SDoc
notSelector (GlobalRdrElt -> Name
greMangledName GlobalRdrElt
gre)) }


fieldNotInType :: RecSelParent -> RdrName -> SDoc
fieldNotInType :: RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
p RdrName
rdr
  = SDoc -> RdrName -> SDoc
unknownSubordinateErr (String -> SDoc
text String
"field of type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RecSelParent -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecSelParent
p)) RdrName
rdr

notSelector :: Name -> SDoc
notSelector :: Name -> SDoc
notSelector Name
field
  = [SDoc] -> SDoc
hsep [SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
field), String -> SDoc
text String
"is not a record selector"]

naughtyRecordSel :: OccName -> SDoc
naughtyRecordSel :: OccName -> SDoc
naughtyRecordSel OccName
lbl
  = String -> SDoc
text String
"Cannot use record selector" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
lbl) SDoc -> SDoc -> SDoc
<+>
    String -> SDoc
text String
"as a function due to escaped type variables" SDoc -> SDoc -> SDoc
$$
    String -> SDoc
text String
"Probable fix: use pattern-matching syntax instead"


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

tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
              -> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig :: LHsExpr (GhcPass 'Renamed)
-> LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
-> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig LHsExpr (GhcPass 'Renamed)
expr LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty
  = do { TcIdSigInfo
sig_info <- TcM TcIdSigInfo -> TcM TcIdSigInfo
forall r. TcM r -> TcM r
checkNoErrs (TcM TcIdSigInfo -> TcM TcIdSigInfo)
-> TcM TcIdSigInfo -> TcM TcIdSigInfo
forall a b. (a -> b) -> a -> b
$  -- Avoid error cascade
                     SrcSpan
-> LHsSigWcType (GhcPass 'Renamed) -> Maybe Name -> TcM TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty Maybe Name
forall a. Maybe a
Nothing
       ; (GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr', TcSigmaType
poly_ty) <- LHsExpr (GhcPass 'Renamed)
-> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType)
tcExprSig LHsExpr (GhcPass 'Renamed)
expr TcIdSigInfo
sig_info
       ; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr' LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (NoGhcTc GhcTc)
hs_ty, TcSigmaType
poly_ty) }
  where
    loc :: SrcSpan
loc = GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Renamed)) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA (LHsSigWcType (GhcPass 'Renamed) -> LHsSigType (GhcPass 'Renamed)
forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
LHsSigWcType (GhcPass 'Renamed)
hs_ty)

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

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

       ; TcSigmaType
tau <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
tau
       ; let inferred_theta :: [TcSigmaType]
inferred_theta = (Id -> TcSigmaType) -> [Id] -> [TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map Id -> TcSigmaType
evVarPred [Id]
givens
             tau_tvs :: TyCoVarSet
tau_tvs        = TcSigmaType -> TyCoVarSet
tyCoVarsOfType TcSigmaType
tau
       ; ([InvisTVBinder]
binders, [TcSigmaType]
my_theta) <- [TcSigmaType]
-> TyCoVarSet
-> [Id]
-> Maybe TcIdSigInst
-> TcM ([InvisTVBinder], [TcSigmaType])
chooseInferredQuantifiers [TcSigmaType]
inferred_theta
                                   TyCoVarSet
tau_tvs [Id]
qtvs (TcIdSigInst -> Maybe TcIdSigInst
forall a. a -> Maybe a
Just TcIdSigInst
sig_inst)
       ; let inferred_sigma :: TcSigmaType
inferred_sigma = [Id] -> [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkInfSigmaTy [Id]
qtvs [TcSigmaType]
inferred_theta TcSigmaType
tau
             my_sigma :: TcSigmaType
my_sigma       = [InvisTVBinder] -> TcSigmaType -> TcSigmaType
mkInvisForAllTys [InvisTVBinder]
binders ([TcSigmaType] -> TcSigmaType -> TcSigmaType
mkPhiTy  [TcSigmaType]
my_theta TcSigmaType
tau)
       ; HsWrapper
wrap <- if TcSigmaType
inferred_sigma TcSigmaType -> TcSigmaType -> Bool
`eqType` TcSigmaType
my_sigma -- NB: eqType ignores vis.
                 then HsWrapper -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
forall (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 UserTypeCtxt
-> TcSigmaType
-> TcSigmaType
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
tcSubTypeSigma UserTypeCtxt
ExprSigCtxt TcSigmaType
inferred_sigma TcSigmaType
my_sigma

       ; String -> SDoc -> TcM ()
traceTc String
"tcExpSig" ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
qtvs SDoc -> SDoc -> SDoc
$$ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
givens SDoc -> SDoc -> SDoc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
inferred_sigma SDoc -> SDoc -> SDoc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
my_sigma)
       ; let poly_wrap :: HsWrapper
poly_wrap = HsWrapper
wrap
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [Id] -> HsWrapper
mkWpTyLams [Id]
qtvs
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [Id] -> HsWrapper
mkWpLams [Id]
givens
                         HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet  TcEvBinds
ev_binds
       ; (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcSigmaType)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (GenLocated SrcSpanAnnA (HsExpr GhcTc), TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
poly_wrap GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr', TcSigmaType
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 (GhcPass 'Renamed) -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferOverLit lit :: HsOverLit (GhcPass 'Renamed)
lit@(OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = OverLitVal
val
                            , ol_witness :: forall p. HsOverLit p -> HsExpr p
ol_witness = HsVar XVar (GhcPass 'Renamed)
_ (L SrcAnn NameAnn
loc Name
from_name)
                            , ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = XOverLit (GhcPass 'Renamed)
rebindable })
  = -- 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 { Id
from_id <- Name -> TcM Id
tcLookupId Name
from_name
       ; (HsWrapper
wrap1, TcSigmaType
from_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate CtOrigin
orig (Id -> TcSigmaType
idType Id
from_id)

       ; (HsWrapper
wrap2, Scaled TcSigmaType
sarg_ty, TcSigmaType
res_ty) <- SDoc
-> Maybe SDoc
-> (ThLevel, [Scaled TcSigmaType])
-> TcSigmaType
-> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)
matchActualFunTySigma SDoc
herald Maybe SDoc
mb_doc
                                                           (ThLevel
1, []) TcSigmaType
from_ty
       ; HsLit GhcTc
hs_lit <- OverLitVal -> TcM (HsLit GhcTc)
mkOverLit OverLitVal
val
       ; Coercion
co <- Maybe SDoc -> TcSigmaType -> TcSigmaType -> TcM Coercion
unifyType Maybe SDoc
mb_doc (HsLit GhcTc -> TcSigmaType
forall (p :: Pass). HsLit (GhcPass p) -> TcSigmaType
hsLitType HsLit GhcTc
hs_lit) (Scaled TcSigmaType -> TcSigmaType
forall a. Scaled a -> a
scaledThing Scaled TcSigmaType
sarg_ty)

       ; let lit_expr :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
lit_expr = SrcSpanAnnA
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L (SrcAnn NameAnn -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NameAnn
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 -> XRec GhcTc (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (SrcAnn NameAnn -> Id -> GenLocated (SrcAnn NameAnn) Id
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
loc Id
from_id)
             lit' :: HsOverLit GhcTc
lit' = HsOverLit (GhcPass 'Renamed)
lit { ol_witness :: HsExpr GhcTc
ol_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 (SrcAnn NameAnn -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
l2l SrcAnn NameAnn
loc) HsExpr GhcTc
from_expr) GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
lit_expr
                        , ol_ext :: XOverLit GhcTc
ol_ext = Bool -> TcSigmaType -> OverLitTc
OverLitTc Bool
XOverLit (GhcPass 'Renamed)
rebindable TcSigmaType
res_ty }
       ; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
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', TcSigmaType
res_ty) }
  where
    orig :: CtOrigin
orig   = HsOverLit (GhcPass 'Renamed) -> CtOrigin
LiteralOrigin HsOverLit (GhcPass 'Renamed)
lit
    mb_doc :: Maybe SDoc
mb_doc = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
from_name)
    herald :: SDoc
herald = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
from_name)
                 , String -> SDoc
text String
"is applied to"]

tcInferOverLit HsOverLit (GhcPass 'Renamed)
lit
  = String -> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcInferOverLit" (HsOverLit (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOverLit (GhcPass 'Renamed)
lit)


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

tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId Name
name ExpRhoType
res_ty
  = do { (HsExpr GhcTc
expr, TcSigmaType
actual_res_ty) <- Name -> TcM (HsExpr GhcTc, TcSigmaType)
tcInferId Name
name
       ; String -> SDoc -> TcM ()
traceTc String
"tcCheckId" ([SDoc] -> SDoc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
actual_res_ty, ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty])
       ; HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcSigmaType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
-> TcM (HsExpr GhcTc)
forall a.
HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcSigmaType
-> ExpRhoType
-> TcM a
-> TcM a
addFunResCtxt HsExpr (GhcPass 'Renamed)
rn_fun [] TcSigmaType
actual_res_ty ExpRhoType
res_ty (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
         CtOrigin
-> HsExpr (GhcPass 'Renamed)
-> HsExpr GhcTc
-> TcSigmaType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcWrapResultO (Name -> CtOrigin
OccurrenceOf Name
name) HsExpr (GhcPass 'Renamed)
rn_fun HsExpr GhcTc
expr TcSigmaType
actual_res_ty ExpRhoType
res_ty }
  where
    rn_fun :: HsExpr (GhcPass 'Renamed)
rn_fun = XVar (GhcPass 'Renamed)
-> LIdP (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar (GhcPass 'Renamed)
noExtField (Name -> GenLocated (SrcAnn 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, TcSigmaType)
tcInferId Name
id_name
  | Name
id_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
assertIdKey
  = do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_IgnoreAsserts DynFlags
dflags
         then Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id Name
id_name
         else Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_assert Name
id_name }

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

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

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

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

             AGlobal (AConLike ConLike
cl) -> case ConLike
cl of
                 RealDataCon DataCon
con -> DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
return_data_con DataCon
con
                 PatSynCon PatSyn
ps
                   | Just (HsExpr GhcTc
expr, TcSigmaType
ty) <- PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType)
patSynBuilderOcc PatSyn
ps
                   -> (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcSigmaType
ty)
                   | Bool
otherwise
                   -> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. SDoc -> TcM a
failWithTc (Name -> SDoc
forall a. Outputable a => a -> SDoc
nonBidirectionalErr Name
id_name)

             AGlobal (ATyCon TyCon
ty_con)
               -> GlobalRdrEnv -> TyCon -> TcM (HsExpr GhcTc, TcSigmaType)
forall {a}. GlobalRdrEnv -> TyCon -> TcM a
fail_tycon GlobalRdrEnv
global_env TyCon
ty_con

             ATyVar Name
name Id
_
                -> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcM (HsExpr GhcTc, TcSigmaType))
-> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
                     String -> SDoc
text String
"Illegal term-level use of the type variable"
                       SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
                       SDoc -> SDoc -> SDoc
$$ ThLevel -> SDoc -> SDoc
nest ThLevel
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
name))

             ATcTyCon TyCon
ty_con
               -> GlobalRdrEnv -> TyCon -> TcM (HsExpr GhcTc, TcSigmaType)
forall {a}. GlobalRdrEnv -> TyCon -> TcM a
fail_tycon GlobalRdrEnv
global_env TyCon
ty_con

             TcTyThing
_ -> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
forall a. SDoc -> TcM a
failWithTc (SDoc -> TcM (HsExpr GhcTc, TcSigmaType))
-> SDoc -> TcM (HsExpr GhcTc, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
                  TcTyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyThing
thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"used where a value identifier was expected" }
  where
    fail_tycon :: GlobalRdrEnv -> TyCon -> TcM a
fail_tycon GlobalRdrEnv
global_env TyCon
ty_con =
      let pprov :: SDoc
pprov = case GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
global_env (TyCon -> Name
tyConName TyCon
ty_con) of
            Just GlobalRdrElt
gre -> ThLevel -> SDoc -> SDoc
nest ThLevel
2 (GlobalRdrElt -> SDoc
pprNameProvenance GlobalRdrElt
gre)
            Maybe GlobalRdrElt
Nothing  -> SDoc
empty
      in SDoc -> TcM a
forall a. SDoc -> TcM a
failWithTc (TyCon -> SDoc
term_level_tycons TyCon
ty_con SDoc -> SDoc -> SDoc
$$ SDoc
pprov)

    term_level_tycons :: TyCon -> SDoc
term_level_tycons TyCon
ty_con
      = String -> SDoc
text String
"Illegal term-level use of the type constructor"
          SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
ty_con))

    return_id :: Id -> m (HsExpr p, TcSigmaType)
return_id Id
id = (HsExpr p, TcSigmaType) -> m (HsExpr p, TcSigmaType)
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 (Id -> GenLocated (SrcAnn an) Id
forall a an. a -> LocatedAn an a
noLocA Id
id), Id -> TcSigmaType
idType Id
id)

    return_data_con :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
return_data_con DataCon
con
      = do { let tvs :: [InvisTVBinder]
tvs = DataCon -> [InvisTVBinder]
dataConUserTyVarBinders DataCon
con
                 theta :: [TcSigmaType]
theta = DataCon -> [TcSigmaType]
dataConOtherTheta DataCon
con
                 args :: [Scaled TcSigmaType]
args = DataCon -> [Scaled TcSigmaType]
dataConOrigArgTys DataCon
con
                 res :: TcSigmaType
res = DataCon -> TcSigmaType
dataConOrigResTy DataCon
con

           -- See Note [Linear fields generalization]
           ; [TcSigmaType]
mul_vars <- ThLevel -> TcSigmaType -> TcM [TcSigmaType]
newFlexiTyVarTys ([Scaled TcSigmaType] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args) TcSigmaType
multiplicityTy
           ; let scaleArgs :: [Scaled TcSigmaType] -> [Scaled TcSigmaType]
scaleArgs [Scaled TcSigmaType]
args' = String
-> (TcSigmaType -> Scaled TcSigmaType -> Scaled TcSigmaType)
-> [TcSigmaType]
-> [Scaled TcSigmaType]
-> [Scaled TcSigmaType]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"return_data_con" TcSigmaType -> Scaled TcSigmaType -> Scaled TcSigmaType
forall {a}. TcSigmaType -> Scaled a -> Scaled a
combine [TcSigmaType]
mul_vars [Scaled TcSigmaType]
args'
                 combine :: TcSigmaType -> Scaled a -> Scaled a
combine TcSigmaType
var (Scaled TcSigmaType
One a
ty) = TcSigmaType -> a -> Scaled a
forall a. TcSigmaType -> a -> Scaled a
Scaled TcSigmaType
var a
ty
                 combine TcSigmaType
_   Scaled a
scaled_ty       = Scaled a
scaled_ty
                   -- The combine function implements the fact that, as
                   -- described in Note [Linear fields generalization], if a
                   -- field is not linear (last line) it isn't made polymorphic.

                 etaWrapper :: t (Scaled TcSigmaType) -> HsWrapper
etaWrapper t (Scaled TcSigmaType)
arg_tys = (Scaled TcSigmaType -> HsWrapper -> HsWrapper)
-> HsWrapper -> t (Scaled TcSigmaType) -> HsWrapper
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Scaled TcSigmaType
scaled_ty HsWrapper
wr -> HsWrapper -> HsWrapper -> Scaled TcSigmaType -> SDoc -> HsWrapper
WpFun HsWrapper
WpHole HsWrapper
wr Scaled TcSigmaType
scaled_ty SDoc
empty) HsWrapper
WpHole t (Scaled TcSigmaType)
arg_tys

           -- See Note [Instantiating stupid theta]
           ; let shouldInstantiate :: Bool
shouldInstantiate = (Bool -> Bool
not ([TcSigmaType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [TcSigmaType]
dataConStupidTheta DataCon
con)) Bool -> Bool -> Bool
||
                                      TcSigmaType -> Bool
isKindLevPoly (TyCon -> TcSigmaType
tyConResKind (DataCon -> TyCon
dataConTyCon DataCon
con)))
           ; case Bool
shouldInstantiate of
               Bool
True -> do { (TCvSubst
subst, [Id]
tvs') <- [Id] -> TcM (TCvSubst, [Id])
newMetaTyVars ([InvisTVBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tvs)
                           ; let tys' :: [TcSigmaType]
tys'   = [Id] -> [TcSigmaType]
mkTyVarTys [Id]
tvs'
                                 theta' :: [TcSigmaType]
theta' = HasCallStack => TCvSubst -> [TcSigmaType] -> [TcSigmaType]
TCvSubst -> [TcSigmaType] -> [TcSigmaType]
substTheta TCvSubst
subst [TcSigmaType]
theta
                                 args' :: [Scaled TcSigmaType]
args'  = HasCallStack =>
TCvSubst -> [Scaled TcSigmaType] -> [Scaled TcSigmaType]
TCvSubst -> [Scaled TcSigmaType] -> [Scaled TcSigmaType]
substScaledTys TCvSubst
subst [Scaled TcSigmaType]
args
                                 res' :: TcSigmaType
res'   = HasCallStack => TCvSubst -> TcSigmaType -> TcSigmaType
TCvSubst -> TcSigmaType -> TcSigmaType
substTy TCvSubst
subst TcSigmaType
res
                           ; HsWrapper
wrap <- CtOrigin
-> [TcSigmaType]
-> [TcSigmaType]
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
instCall (Name -> CtOrigin
OccurrenceOf Name
id_name) [TcSigmaType]
tys' [TcSigmaType]
theta'
                           ; let scaled_arg_tys :: [Scaled TcSigmaType]
scaled_arg_tys = [Scaled TcSigmaType] -> [Scaled TcSigmaType]
scaleArgs [Scaled TcSigmaType]
args'
                                 eta_wrap :: HsWrapper
eta_wrap = [Scaled TcSigmaType] -> HsWrapper
forall {t :: * -> *}.
Foldable t =>
t (Scaled TcSigmaType) -> HsWrapper
etaWrapper [Scaled TcSigmaType]
scaled_arg_tys
                           ; DataCon -> [TcSigmaType] -> TcM ()
addDataConStupidTheta DataCon
con [TcSigmaType]
tys'
                           ; (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper
eta_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap)
                                               (XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
XConLikeOut GhcTc
noExtField (DataCon -> ConLike
RealDataCon DataCon
con))
                                    , [Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [Scaled TcSigmaType]
scaled_arg_tys TcSigmaType
res')
                           }
               Bool
False -> let scaled_arg_tys :: [Scaled TcSigmaType]
scaled_arg_tys = [Scaled TcSigmaType] -> [Scaled TcSigmaType]
scaleArgs [Scaled TcSigmaType]
args
                            wrap1 :: HsWrapper
wrap1 = [TcSigmaType] -> HsWrapper
mkWpTyApps ([Id] -> [TcSigmaType]
mkTyVarTys ([Id] -> [TcSigmaType]) -> [Id] -> [TcSigmaType]
forall a b. (a -> b) -> a -> b
$ [InvisTVBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tvs)
                            eta_wrap :: HsWrapper
eta_wrap = [Scaled TcSigmaType] -> HsWrapper
forall {t :: * -> *}.
Foldable t =>
t (Scaled TcSigmaType) -> HsWrapper
etaWrapper ((TcSigmaType -> Scaled TcSigmaType)
-> [TcSigmaType] -> [Scaled TcSigmaType]
forall a b. (a -> b) -> [a] -> [b]
map TcSigmaType -> Scaled TcSigmaType
forall a. a -> Scaled a
unrestricted [TcSigmaType]
theta [Scaled TcSigmaType]
-> [Scaled TcSigmaType] -> [Scaled TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [Scaled TcSigmaType]
scaled_arg_tys)
                            wrap2 :: HsWrapper
wrap2 = [Id] -> HsWrapper
mkWpTyLams ([Id] -> HsWrapper) -> [Id] -> HsWrapper
forall a b. (a -> b) -> a -> b
$ [InvisTVBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [InvisTVBinder]
tvs
                        in (HsExpr GhcTc, TcSigmaType) -> TcM (HsExpr GhcTc, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper
wrap2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
eta_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1)
                                             (XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
XConLikeOut GhcTc
noExtField (DataCon -> ConLike
RealDataCon DataCon
con))
                                  , [InvisTVBinder] -> TcSigmaType -> TcSigmaType
mkInvisForAllTys [InvisTVBinder]
tvs (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$ [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkInvisFunTysMany [TcSigmaType]
theta (TcSigmaType -> TcSigmaType) -> TcSigmaType -> TcSigmaType
forall a b. (a -> b) -> a -> b
$ [Scaled TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [Scaled TcSigmaType]
scaled_arg_tys TcSigmaType
res)
           }

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

check_naughty :: OccName -> TcId -> TcM ()
check_naughty :: OccName -> Id -> TcM ()
check_naughty OccName
lbl Id
id
  | Id -> Bool
isNaughtyRecordSelector Id
id = SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc (OccName -> SDoc
naughtyRecordSel OccName
lbl)
  | Bool
otherwise                  = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

nonBidirectionalErr :: Outputable name => name -> SDoc
nonBidirectionalErr :: forall a. Outputable a => a -> SDoc
nonBidirectionalErr name
name = String -> SDoc
text String
"non-bidirectional pattern synonym"
                           SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (name -> SDoc
forall a. Outputable a => a -> SDoc
ppr name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"used in an expression"

{-
Note [Linear fields generalization]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As per Note [Polymorphisation of linear fields], linear field of data
constructors get a polymorphic type when the data constructor is used as a term.

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

This rule is known only to the typechecker: Just keeps its linear type in Core.

In order to desugar this generalised typing rule, we simply eta-expand:

    \a (x # p :: a) -> Just @a x

has the appropriate type. We insert these eta-expansion with WpFun wrappers.

A small hitch: if the constructor is levity-polymorphic (unboxed tuples, sums,
certain newtypes with -XUnliftedNewtypes) then this strategy produces

    \r1 r2 a b (x # p :: a) (y # q :: b) -> (# a, b #)

Which has type

    forall r1 r2 a b. a #p-> b #q-> (# a, b #)

Which violates the levity-polymorphism restriction see Note [Levity polymorphism
checking] in DsMonad.

So we really must instantiate r1 and r2 rather than quantify over them.  For
simplicity, we just instantiate the entire type, as described in Note
[Instantiating stupid theta]. It breaks visible type application with unboxed
tuples, sums and levity-polymorphic newtypes, but this doesn't appear to be used
anywhere.

A better plan: let's force all representation variable to be *inferred*, so that
they are not subject to visible type applications. Then we can instantiate
inferred argument eagerly.

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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Normally, when we infer the type of an Id, we don't instantiate,
because we wish to allow for visible type application later on.
But if a datacon has a stupid theta, we're a bit stuck. We need
to emit the stupid theta constraints with instantiated types. It's
difficult to defer this to the lazy instantiation, because a stupid
theta has no spot to put it in a type. So we just instantiate eagerly
in this case. Thus, users cannot use visible type application with
a data constructor sporting a stupid theta. I won't feel so bad for
the users that complain.
-}

{-
************************************************************************
*                                                                      *
                 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 :: Id -> TcM ()
checkThLocalId Id
id
  = do  { Maybe (TopLevelFlag, ThLevel, ThStage)
mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel (Id -> Name
idName Id
id)
        ; case Maybe (TopLevelFlag, ThLevel, ThStage)
mb_local_use of
             Just (TopLevelFlag
top_lvl, ThLevel
bind_lvl, ThStage
use_stage)
                | ThStage -> ThLevel
thLevel ThStage
use_stage ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ThLevel
bind_lvl
                -> TopLevelFlag -> Id -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl Id
id ThStage
use_stage
             Maybe (TopLevelFlag, ThLevel, 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 -> Id -> ThStage -> TcM ()
checkCrossStageLifting TopLevelFlag
top_lvl Id
id (Brack ThStage
_ (TcPending TcRef [PendingTcSplice]
ps_var TcRef WantedConstraints
lie_var QuoteWrapper
q))
  | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
  = Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
id_name) (Name -> TcM ()
keepAlive Name
id_name)
    -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice

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

        ; HsExpr GhcTc
lift <- if TcSigmaType -> Bool
isStringTy TcSigmaType
id_ty then
                     do { Id
sid <- Name -> TcM Id
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 -> XRec GhcTc (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (Id -> GenLocated (SrcAnn NameAnn) Id
forall a an. a -> LocatedAn an a
noLocA Id
sid)) }
                  else
                     TcRef WantedConstraints -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar TcRef WantedConstraints
lie_var   (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                          -- Put the 'lift' constraint into the right LIE
                     CtOrigin -> Name -> [TcSigmaType] -> TcM (HsExpr GhcTc)
newMethodFromName (Name -> CtOrigin
OccurrenceOf Name
id_name)
                                       Name
GHC.Builtin.Names.TH.liftName
                                       [HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
getRuntimeRep TcSigmaType
id_ty, TcSigmaType
id_ty]

                   -- Warning for implicit lift (#17804)
        ; WarningFlag -> TcM () -> TcM ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnImplicitLift (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
            WarnReason -> SDoc -> TcM ()
addWarnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnImplicitLift)
                       (String -> SDoc
text String
"The variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id) SDoc -> SDoc -> SDoc
<+>
                        String -> SDoc
text String
"is implicitly lifted in the TH quotation")

                   -- 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 Id
IdP GhcTc
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 = Id -> Name
idName Id
id

checkCrossStageLifting TopLevelFlag
_ Id
_ ThStage
_ = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

polySpliceErr :: Id -> SDoc
polySpliceErr :: Id -> SDoc
polySpliceErr Id
id
  = String -> SDoc
text String
"Can't splice the polymorphic local variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id)

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

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. TcTyClsBindings.mkAuxBinds.
-}


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

addFunResCtxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn]
              -> TcType -> ExpRhoType
              -> TcM a -> TcM a
-- When we have a mis-match in the return type of a function
-- try to give a helpful message about too many/few arguments
-- But not in generated code, where we don't want
-- to mention internal (rebindable syntax) function names
addFunResCtxt :: forall a.
HsExpr (GhcPass 'Renamed)
-> [HsExprArg 'TcpRn]
-> TcSigmaType
-> ExpRhoType
-> TcM a
-> TcM a
addFunResCtxt HsExpr (GhcPass 'Renamed)
fun [HsExprArg 'TcpRn]
args TcSigmaType
fun_res_ty ExpRhoType
env_ty TcM a
thing_inside
  = (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 TcSigmaType
mb_env_ty <- ExpRhoType -> TcM (Maybe TcSigmaType)
readExpType_maybe ExpRhoType
env_ty
                     -- by the time the message is rendered, the ExpType
                     -- will be filled in (except if we're debugging)
           ; TcSigmaType
fun_res' <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
fun_res_ty
           ; TcSigmaType
env'     <- case Maybe TcSigmaType
mb_env_ty of
                           Just TcSigmaType
env_ty -> TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
env_ty
                           Maybe TcSigmaType
Nothing     ->
                             do { Bool
dumping <- DumpFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
Opt_D_dump_tc_trace
                                ; MASSERT( dumping )
                                ; TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind }
           ; let -- See Note [Splitting nested sigma types in mismatched
                 --           function types]
                 ([Id]
_, [TcSigmaType]
_, TcSigmaType
fun_tau) = TcSigmaType -> ([Id], [TcSigmaType], TcSigmaType)
tcSplitNestedSigmaTys TcSigmaType
fun_res'
                 -- No need to call tcSplitNestedSigmaTys here, since env_ty is
                 -- an ExpRhoTy, i.e., it's already instantiated.
                 ([Id]
_, [TcSigmaType]
_, TcSigmaType
env_tau) = TcSigmaType -> ([Id], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
env'
                 ([Scaled TcSigmaType]
args_fun, TcSigmaType
res_fun) = TcSigmaType -> ([Scaled TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
fun_tau
                 ([Scaled TcSigmaType]
args_env, TcSigmaType
res_env) = TcSigmaType -> ([Scaled TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
env_tau
                 n_fun :: ThLevel
n_fun = [Scaled TcSigmaType] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args_fun
                 n_env :: ThLevel
n_env = [Scaled TcSigmaType] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcSigmaType]
args_env
                 info :: SDoc
info  | -- Check for too few args
                         --  fun_tau = a -> b, res_tau = Int
                         ThLevel
n_fun ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ThLevel
n_env
                       , TcSigmaType -> Bool
not_fun TcSigmaType
res_env
                       = String -> SDoc
text String
"Probable cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
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)
                         ThLevel
n_fun ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
< ThLevel
n_env
                       , TcSigmaType -> Bool
not_fun TcSigmaType
res_fun
                       , (ThLevel
n_fun ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ (HsExprArg 'TcpRn -> Bool) -> [HsExprArg 'TcpRn] -> ThLevel
forall a. (a -> Bool) -> [a] -> ThLevel
count HsExprArg 'TcpRn -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isValArg [HsExprArg 'TcpRn]
args) ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= ThLevel
n_env
                          -- Never suggest that a naked variable is
                                           -- applied to too many args!
                       = String -> SDoc
text String
"Possible cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
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 :: TcSigmaType -> Bool
not_fun TcSigmaType
ty   -- ty is definitely not an arrow type,
                 -- and cannot conceivably become one
      = case HasCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty of
          Just (TyCon
tc, [TcSigmaType]
_) -> TyCon -> Bool
isAlgTyCon TyCon
tc
          Maybe (TyCon, [TcSigmaType])
Nothing      -> Bool
False

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

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

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

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