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

-}

{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies, DataKinds, TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
                                      -- in module GHC.Hs.Extension

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

module GHC.Tc.Gen.Expr
       ( tcCheckPolyExpr,
         tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC,
         tcInferSigma, tcInferRho, tcInferRhoNC,
         tcExpr,
         tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
         tcCheckId,
         addAmbiguousNameErr,
         getFixedTyVars ) where

#include "HsVersions.h"

import GHC.Prelude

import {-# SOURCE #-}   GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
import GHC.Builtin.Names.TH( liftStringName, liftName )

import GHC.Hs
import GHC.Tc.Utils.Zonk
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Types.Basic
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Gen.Bind        ( chooseInferredQuantifiers, tcLocalBinds )
import GHC.Tc.Gen.Sig         ( tcUserTypeSig, tcInstSig )
import GHC.Tc.Solver          ( simplifyInfer, InferMode(..) )
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst, tcLookupDataFamInst_maybe )
import GHC.Core.FamInstEnv    ( FamInstEnvs )
import GHC.Rename.Env         ( addUsedGRE )
import GHC.Rename.Utils       ( addNameClashErrRn, unknownSubordinateErr )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
import GHC.Tc.Gen.Match
import GHC.Tc.Gen.HsType
import GHC.Tc.TyCl.PatSyn     ( tcPatSynBuilderOcc, nonBidirectionalErr )
import GHC.Tc.Gen.Pat
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
import GHC.Core.TyCo.Subst (substTyWithInScope)
import GHC.Core.Type
import GHC.Tc.Types.Evidence
import GHC.Types.Var.Set
import GHC.Builtin.Types
import GHC.Builtin.PrimOps( tagToEnumKey )
import GHC.Builtin.Names
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Types.Var.Env  ( emptyTidyEnv, mkInScopeSet )
import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Data.FastString
import Control.Monad
import GHC.Core.Class(classTyCon)
import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
import qualified GHC.LanguageExtensions as LangExt

import Data.Function
import Data.List (partition, sortBy, groupBy, intersect)
import qualified Data.Set as Set

{-
************************************************************************
*                                                                      *
\subsection{Main wrappers}
*                                                                      *
************************************************************************
-}


tcCheckPolyExpr, tcCheckPolyExprNC
  :: LHsExpr GhcRn         -- Expression to type check
  -> TcSigmaType           -- Expected type (could be a polytype)
  -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type

-- tcCheckPolyExpr is a convenient place (frequent but not too frequent)
-- place to add context information.
-- The NC version does not do so, usually because the caller wants
-- to do so himself.

tcCheckPolyExpr :: LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr   LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyExpr   LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)
tcCheckPolyExprNC :: LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyExprNC LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)

-- These versions take an ExpType
tcPolyExpr, tcPolyExprNC
  :: LHsExpr GhcRn -> ExpSigmaType
  -> TcM (LHsExpr GhcTc)

tcPolyExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyExpr LHsExpr GhcRn
expr ExpRhoType
res_ty
  = LHsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
    do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyExpr" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
       ; LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyExprNC LHsExpr GhcRn
expr ExpRhoType
res_ty }

tcPolyExprNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcPolyExprNC (L SrcSpan
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
  = SrcSpan
-> HsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall {a}. SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a
set_loc_and_ctxt SrcSpan
loc HsExpr GhcRn
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
    do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyExprNC" (ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)
       ; (HsWrapper
wrap, HsExpr GhcTc
expr') <- UserTypeCtxt
-> ExpRhoType
-> (ExpRhoType -> TcM (HsExpr GhcTc))
-> TcM (HsWrapper, HsExpr GhcTc)
forall result.
UserTypeCtxt
-> ExpRhoType
-> (ExpRhoType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemiseET UserTypeCtxt
GenSigCtxt ExpRhoType
res_ty ((ExpRhoType -> TcM (HsExpr GhcTc))
 -> TcM (HsWrapper, HsExpr GhcTc))
-> (ExpRhoType -> TcM (HsExpr GhcTc))
-> TcM (HsWrapper, HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ \ ExpRhoType
res_ty ->
                          HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
       ; LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTc -> TcM (LHsExpr GhcTc))
-> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
expr') }

  where -- See Note [Rebindable syntax and HsExpansion), which describes
        -- the logic behind this location/context tweaking.
        set_loc_and_ctxt :: SrcSpan -> HsExpr GhcRn -> TcRn a -> TcRn a
set_loc_and_ctxt SrcSpan
l HsExpr GhcRn
e TcRn a
m = do
          Bool
inGenCode <- TcRn Bool
inGeneratedCode
          if Bool
inGenCode Bool -> Bool -> Bool
&& Bool -> Bool
not (SrcSpan -> Bool
isGeneratedSrcSpan SrcSpan
l)
            then SrcSpan -> TcRn a -> TcRn a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
l (TcRn a -> TcRn a) -> TcRn a -> TcRn a
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcRn a -> TcRn a
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcRn
e) TcRn a
m
            else SrcSpan -> TcRn a -> TcRn a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
l TcRn a
m

---------------
tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
-- Used by tcRnExpr to implement GHCi :type
-- It goes against the principle of eager instantiation,
-- so we expect very very few calls to this function
-- Most clients will want tcInferRho
tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferSigma le :: LHsExpr GhcRn
le@(L SrcSpan
loc HsExpr GhcRn
expr)
  = LHsExpr GhcRn
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
le (TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType))
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType))
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$
    do { (HsExpr GhcTc
fun, [LHsExprArgOut]
args, TcType
ty) <- HsExpr GhcRn -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcType)
tcInferApp HsExpr GhcRn
expr
       ; (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
applyHsArgs HsExpr GhcTc
fun [LHsExprArgOut]
args), TcType
ty) }

---------------
tcCheckMonoExpr, tcCheckMonoExprNC
    :: LHsExpr GhcRn     -- Expression to type check
    -> TcRhoType         -- Expected type
                         -- Definitely no foralls at the top
    -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr :: LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckMonoExpr   LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr   LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)
tcCheckMonoExprNC :: LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckMonoExprNC LHsExpr GhcRn
expr TcType
res_ty = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty)

tcMonoExpr, tcMonoExprNC
    :: LHsExpr GhcRn     -- Expression to type check
    -> ExpRhoType        -- Expected type
                         -- Definitely no foralls at the top
    -> TcM (LHsExpr GhcTc)

tcMonoExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExpr LHsExpr GhcRn
expr ExpRhoType
res_ty
  = LHsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
expr (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
    LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC LHsExpr GhcRn
expr ExpRhoType
res_ty

tcMonoExprNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcMonoExprNC (L SrcSpan
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
  = SrcSpan -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
        ; LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTc
expr') }

---------------
tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
-- Infer a *rho*-type. The return type is always instantiated.
tcInferRho :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRho LHsExpr GhcRn
le = LHsExpr GhcRn
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
le (LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRhoNC LHsExpr GhcRn
le)

tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRhoNC (L SrcSpan
loc HsExpr GhcRn
expr)
  = SrcSpan
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType))
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$
    do { (HsExpr GhcTc
expr', TcType
rho) <- (ExpRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc, TcType)
forall a. (ExpRhoType -> TcM a) -> TcM (a, TcType)
tcInfer (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr)
       ; (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTc
expr', TcType
rho) }


{- *********************************************************************
*                                                                      *
        tcExpr: the main expression typechecker
*                                                                      *
********************************************************************* -}

tcLExpr, tcLExprNC
    :: LHsExpr GhcRn     -- Expression to type check
    -> ExpRhoType        -- Expected type
                         -- Definitely no foralls at the top
    -> TcM (LHsExpr GhcTc)

tcLExpr :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
expr ExpRhoType
res_ty
  = SrcSpan -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (LHsExpr GhcRn -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsExpr GhcRn
expr) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
expr (LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExprNC LHsExpr GhcRn
expr ExpRhoType
res_ty)

tcLExprNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExprNC (L SrcSpan
loc HsExpr GhcRn
expr) ExpRhoType
res_ty
  = SrcSpan -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
    do  { HsExpr GhcTc
expr' <- HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
        ; LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTc
expr') }

tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr (HsVar XVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
name))   ExpRhoType
res_ty = Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId Name
IdP GhcRn
name ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsUnboundVar XUnboundVar GhcRn
_ OccName
uv)  ExpRhoType
res_ty = HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTc)
tcUnboundId HsExpr GhcRn
e OccName
uv ExpRhoType
res_ty

tcExpr e :: HsExpr GhcRn
e@(HsApp {})     ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsAppType {}) ExpRhoType
res_ty = HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
e ExpRhoType
res_ty

tcExpr e :: HsExpr GhcRn
e@(HsLit XLitE GhcRn
x HsLit GhcRn
lit) ExpRhoType
res_ty
  = do { let lit_ty :: TcType
lit_ty = HsLit GhcRn -> TcType
forall (p :: Pass). HsLit (GhcPass p) -> TcType
hsLitType HsLit GhcRn
lit
       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e (XLitE GhcTc -> HsLit GhcTc -> HsExpr GhcTc
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
XLitE GhcTc
x (HsLit GhcRn -> HsLit GhcTc
forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit HsLit GhcRn
lit)) TcType
lit_ty ExpRhoType
res_ty }

tcExpr (HsPar XPar GhcRn
x LHsExpr GhcRn
expr) ExpRhoType
res_ty = do { LHsExpr GhcTc
expr' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExprNC LHsExpr GhcRn
expr ExpRhoType
res_ty
                                  ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XPar GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar GhcRn
XPar GhcTc
x LHsExpr GhcTc
expr') }

tcExpr (HsPragE XPragE GhcRn
x HsPragE GhcRn
prag LHsExpr GhcRn
expr) ExpRhoType
res_ty
  = do { LHsExpr GhcTc
expr' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
expr ExpRhoType
res_ty
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XPragE GhcTc -> HsPragE GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p
HsPragE XPragE GhcRn
XPragE GhcTc
x (HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag HsPragE GhcRn
prag) LHsExpr GhcTc
expr') }

tcExpr (HsOverLit XOverLitE GhcRn
x HsOverLit GhcRn
lit) ExpRhoType
res_ty
  = do  { HsOverLit GhcTc
lit' <- HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc)
newOverloadedLit HsOverLit GhcRn
lit ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
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 GhcRn
XOverLitE GhcTc
x HsOverLit GhcTc
lit') }

tcExpr (NegApp XNegApp GhcRn
x LHsExpr GhcRn
expr SyntaxExpr GhcRn
neg_expr) ExpRhoType
res_ty
  = do  { (LHsExpr GhcTc
expr', SyntaxExprTc
neg_expr')
            <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> [TcType] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
NegateOrigin SyntaxExpr GhcRn
SyntaxExprRn
neg_expr [SyntaxOpType
SynAny] ExpRhoType
res_ty (([TcType] -> [TcType] -> TcM (LHsExpr GhcTc))
 -> TcM (LHsExpr GhcTc, SyntaxExprTc))
-> ([TcType] -> [TcType] -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc, SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
               \[TcType
arg_ty] [TcType
arg_mult] ->
               TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
arg_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
expr (TcType -> ExpRhoType
mkCheckExpType TcType
arg_ty)
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XNegApp GhcTc -> LHsExpr GhcTc -> SyntaxExpr GhcTc -> HsExpr GhcTc
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp XNegApp GhcRn
XNegApp GhcTc
x LHsExpr GhcTc
expr' SyntaxExpr GhcTc
SyntaxExprTc
neg_expr') }

tcExpr e :: HsExpr GhcRn
e@(HsIPVar XIPVar GhcRn
_ HsIPName
x) ExpRhoType
res_ty
  = do {   {- Implicit parameters must have a *tau-type* not a
              type scheme.  We enforce this by creating a fresh
              type variable as its type.  (Because res_ty may not
              be a tau-type.) -}
         TcType
ip_ty <- TcM TcType
newOpenFlexiTyVarTy
       ; let ip_name :: TcType
ip_name = FieldLabelString -> TcType
mkStrLitTy (HsIPName -> FieldLabelString
hsIPNameFS HsIPName
x)
       ; Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
       ; Var
ip_var <- CtOrigin -> TcType -> TcM Var
emitWantedEvVar CtOrigin
origin (Class -> [TcType] -> TcType
mkClassPred Class
ipClass [TcType
ip_name, TcType
ip_ty])
       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e
                   (Class -> TcType -> TcType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass TcType
ip_name TcType
ip_ty (XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (Var -> Located Var
forall e. e -> Located e
noLoc Var
ip_var)))
                   TcType
ip_ty ExpRhoType
res_ty }
  where
  -- Coerces a dictionary for `IP "x" t` into `t`.
  fromDict :: Class -> TcType -> TcType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict Class
ipClass TcType
x TcType
ty = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc)
-> HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$
                          TcType -> TcCoercionR
unwrapIP (TcType -> TcCoercionR) -> TcType -> TcCoercionR
forall a b. (a -> b) -> a -> b
$ Class -> [TcType] -> TcType
mkClassPred Class
ipClass [TcType
x,TcType
ty]
  origin :: CtOrigin
origin = HsIPName -> CtOrigin
IPOccOrigin HsIPName
x

tcExpr e :: HsExpr GhcRn
e@(HsOverLabel XOverLabel GhcRn
_ Maybe (IdP GhcRn)
mb_fromLabel FieldLabelString
l) ExpRhoType
res_ty
  = do { -- See Note [Type-checking overloaded labels]
         SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
       ; case Maybe (IdP GhcRn)
mb_fromLabel of
           Just IdP GhcRn
fromLabel -> HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr (SrcSpan -> Name -> HsExpr GhcRn
applyFromLabel SrcSpan
loc Name
IdP GhcRn
fromLabel) ExpRhoType
res_ty
           Maybe (IdP GhcRn)
Nothing -> do { Class
isLabelClass <- Name -> TcM Class
tcLookupClass Name
isLabelClassName
                         ; TcType
alpha <- TcType -> TcM TcType
newFlexiTyVarTy TcType
liftedTypeKind
                         ; let pred :: TcType
pred = Class -> [TcType] -> TcType
mkClassPred Class
isLabelClass [TcType
lbl, TcType
alpha]
                         ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
                         ; Var
var <- CtOrigin -> TcType -> TcM Var
emitWantedEvVar CtOrigin
origin TcType
pred
                         ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e
                                       (TcType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict TcType
pred (XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (SrcSpan -> Var -> Located Var
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Var
var)))
                                        TcType
alpha ExpRhoType
res_ty } }
  where
  -- Coerces a dictionary for `IsLabel "x" t` into `t`,
  -- or `HasField "x" r a into `r -> a`.
  fromDict :: TcType -> HsExpr GhcTc -> HsExpr GhcTc
fromDict TcType
pred = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc)
-> HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$ TcType -> TcCoercionR
unwrapIP TcType
pred
  origin :: CtOrigin
origin = FieldLabelString -> CtOrigin
OverLabelOrigin FieldLabelString
l
  lbl :: TcType
lbl = FieldLabelString -> TcType
mkStrLitTy FieldLabelString
l

  applyFromLabel :: SrcSpan -> Name -> HsExpr GhcRn
applyFromLabel SrcSpan
loc Name
fromLabel =
    XAppTypeE GhcRn
-> LHsExpr GhcRn -> LHsWcType (NoGhcTc GhcRn) -> HsExpr GhcRn
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
XAppTypeE GhcRn
noExtField
         (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XVar GhcRn -> GenLocated SrcSpan (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
fromLabel)))
         (GenLocated SrcSpan (HsType GhcRn) -> LHsWcType GhcRn
forall thing. thing -> HsWildCardBndrs GhcRn thing
mkEmptyWildCardBndrs (SrcSpan -> HsType GhcRn -> GenLocated SrcSpan (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTyLit GhcRn -> HsTyLit -> HsType GhcRn
forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit NoExtField
XTyLit GhcRn
noExtField (SourceText -> FieldLabelString -> HsTyLit
HsStrTy SourceText
NoSourceText FieldLabelString
l))))

tcExpr (HsLam XLam GhcRn
x MatchGroup GhcRn (LHsExpr GhcRn)
match) ExpRhoType
res_ty
  = do  { (HsWrapper
wrap, MatchGroup GhcTc (LHsExpr GhcTc)
match') <- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda SDoc
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
match ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (XLam GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcRn
XLam GhcTc
x MatchGroup GhcTc (LHsExpr GhcTc)
match')) }
  where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (Located (body GhcRn)
    -> ExpRhoType -> TcM (Located (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
LambdaExpr, mc_body :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }
    herald :: SDoc
herald = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The lambda expression" SDoc -> SDoc -> SDoc
<+>
                   SDoc -> SDoc
quotes (Depth -> SDoc -> SDoc
pprSetDepth (ThLevel -> Depth
PartWay ThLevel
1) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                           MatchGroup GhcRn (LHsExpr GhcRn) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr GhcRn)
match),
                        -- The pprSetDepth makes the abstraction print briefly
                   String -> SDoc
text String
"has"]

tcExpr e :: HsExpr GhcRn
e@(HsLamCase XLamCase GhcRn
x MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, MatchGroup GhcTc (LHsExpr GhcTc)
matches')
           <- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
tcMatchLambda SDoc
msg TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpRhoType
res_ty
           -- The laziness annotation is because we don't want to fail here
           -- if there are multiple arguments
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XLamCase GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcRn
XLamCase GhcTc
x MatchGroup GhcTc (LHsExpr GhcTc)
matches') }
  where
    msg :: SDoc
msg = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
              , String -> SDoc
text String
"requires"]
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (Located (body GhcRn)
    -> ExpRhoType -> TcM (Located (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt, mc_body :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }

tcExpr e :: HsExpr GhcRn
e@(ExprWithTySig XExprWithTySig GhcRn
_ LHsExpr GhcRn
expr LHsSigWcType (NoGhcTc GhcRn)
hs_ty) ExpRhoType
res_ty
  = do { (HsExpr GhcTc
expr', TcType
poly_ty) <- LHsExpr GhcRn
-> LHsSigWcType (NoGhcTc GhcRn) -> TcM (HsExpr GhcTc, TcType)
tcExprWithSig LHsExpr GhcRn
expr LHsSigWcType (NoGhcTc GhcRn)
hs_ty
       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
e HsExpr GhcTc
expr' TcType
poly_ty ExpRhoType
res_ty }

{-
Note [Type-checking overloaded labels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Recall that we have

  module GHC.OverloadedLabels where
    class IsLabel (x :: Symbol) a where
      fromLabel :: a

We translate `#foo` to `fromLabel @"foo"`, where we use

 * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not
 * `GHC.OverloadedLabels.fromLabel`.

In the `RebindableSyntax` case, the renamer will have filled in the
first field of `HsOverLabel` with the `fromLabel` function to use, and
we simply apply it to the appropriate visible type argument.

In the `OverloadedLabels` case, when we see an overloaded label like
`#foo`, we generate a fresh variable `alpha` for the type and emit an
`IsLabel "foo" alpha` constraint.  Because the `IsLabel` class has a
single method, it is represented by a newtype, so we can coerce
`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).

-}


{-
************************************************************************
*                                                                      *
                Infix operators and sections
*                                                                      *
************************************************************************

Note [Left sections]
~~~~~~~~~~~~~~~~~~~~
Left sections, like (4 *), are equivalent to
        \ x -> (*) 4 x,
or, if PostfixOperators is enabled, just
        (*) 4
With PostfixOperators we don't actually require the function to take
two arguments at all.  For example, (x `not`) means (not x); you get
postfix operators!  Not Haskell 98, but it's less work and kind of
useful.

Note [Typing rule for ($)]
~~~~~~~~~~~~~~~~~~~~~~~~~~
People write
   runST $ blah
so much, where
   runST :: (forall s. ST s a) -> a
that I have finally given in and written a special type-checking
rule just for saturated applications of ($).
  * Infer the type of the first argument
  * Decompose it; should be of form (arg2_ty -> res_ty),
       where arg2_ty might be a polytype
  * Use arg2_ty to typecheck arg2
-}

tcExpr expr :: HsExpr GhcRn
expr@(OpApp XOpApp GhcRn
fix LHsExpr GhcRn
arg1 LHsExpr GhcRn
op LHsExpr GhcRn
arg2) ExpRhoType
res_ty
  | (L SrcSpan
loc (HsVar XVar GhcRn
_ (L SrcSpan
lv IdP GhcRn
op_name))) <- LHsExpr GhcRn
op
  , Name
IdP GhcRn
op_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
dollarIdKey        -- Note [Typing rule for ($)]
  = do { String -> SDoc -> TcRn ()
traceTc String
"Application rule" (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
op)
       ; (LHsExpr GhcTc
arg1', TcType
arg1_ty) <- SDoc -> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> LHsExpr GhcRn -> ThLevel -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> ThLevel -> SDoc
funAppCtxt LHsExpr GhcRn
op LHsExpr GhcRn
arg1 ThLevel
1) (TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType))
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$
                             LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRhoNC LHsExpr GhcRn
arg1

       ; let doc :: SDoc
doc   = String -> SDoc
text String
"The first argument of ($) takes"
             orig1 :: CtOrigin
orig1 = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
arg1
       ; (HsWrapper
wrap_arg1, [Scaled TcType
arg2_sigma], TcType
op_res_ty) <-
           SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> ThLevel
-> TcType
-> TcM (HsWrapper, [Scaled TcType], TcType)
matchActualFunTysRho SDoc
doc CtOrigin
orig1 (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
arg1)) ThLevel
1 TcType
arg1_ty

       ; HsWrapper
mult_wrap <- CtOrigin -> TcType -> TcType -> TcM HsWrapper
tcSubMult CtOrigin
AppOrigin TcType
Many (Scaled TcType -> TcType
forall a. Scaled a -> TcType
scaledMult Scaled TcType
arg2_sigma)
         -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
         --
         -- When ($) becomes multiplicity-polymorphic, then the above check will
         -- need to go. But in the meantime, it would produce ill-typed
         -- desugared code to accept linear functions to the left of a ($).

         -- We have (arg1 $ arg2)
         -- So: arg1_ty = arg2_ty -> op_res_ty
         -- where arg2_sigma maybe polymorphic; that's the point

       ; LHsExpr GhcTc
arg2' <- HsExpr GhcRn
-> LHsExpr GhcRn -> Scaled TcType -> ThLevel -> TcM (LHsExpr GhcTc)
tcArg HsExpr GhcRn
nl_op LHsExpr GhcRn
arg2 Scaled TcType
arg2_sigma ThLevel
2

       -- Make sure that the argument type has kind '*'
       --   ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b
       -- Eg we do not want to allow  (D#  $  4.0#)   #5570
       --    (which gives a seg fault)
       ; TcCoercionR
_ <- Maybe (HsType GhcRn) -> TcType -> TcType -> TcM TcCoercionR
unifyKind (HsType GhcRn -> Maybe (HsType GhcRn)
forall a. a -> Maybe a
Just (XXType GhcRn -> HsType GhcRn
forall pass. XXType pass -> HsType pass
XHsType (XXType GhcRn -> HsType GhcRn) -> XXType GhcRn -> HsType GhcRn
forall a b. (a -> b) -> a -> b
$ TcType -> NewHsTypeX
NHsCoreTy (Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing Scaled TcType
arg2_sigma)))
                        (HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind (Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing Scaled TcType
arg2_sigma)) TcType
liftedTypeKind
           -- Ignore the evidence. arg2_sigma must have type * or #,
           -- because we know (arg2_sigma -> op_res_ty) is well-kinded
           -- (because otherwise matchActualFunTysRho would fail)
           -- So this 'unifyKind' will either succeed with Refl, or will
           -- produce an insoluble constraint * ~ #, which we'll report later.

       -- NB: unlike the argument type, the *result* type, op_res_ty can
       -- have any kind (#8739), so we don't need to check anything for that

       ; Var
op_id  <- Name -> TcM Var
tcLookupId Name
IdP GhcRn
op_name
       ; let op' :: LHsExpr GhcTc
op' = SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap ([TcType] -> HsWrapper
mkWpTyApps [ HasDebugCallStack => TcType -> TcType
TcType -> TcType
getRuntimeRep TcType
op_res_ty
                                               , Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing Scaled TcType
arg2_sigma
                                               , TcType
op_res_ty])
                                   (XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (SrcSpan -> Var -> Located Var
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv Var
op_id)))
             -- arg1' :: arg1_ty
             -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
             -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty

             expr' :: HsExpr GhcTc
expr' = XOpApp GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
XOpApp GhcTc
fix (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (HsWrapper
wrap_arg1 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
mult_wrap) LHsExpr GhcTc
arg1') LHsExpr GhcTc
op' LHsExpr GhcTc
arg2'

       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
op_res_ty ExpRhoType
res_ty }

  | L SrcSpan
loc (HsRecFld XRecFld GhcRn
_ (Ambiguous XAmbiguous GhcRn
_ Located RdrName
lbl)) <- LHsExpr GhcRn
op
  , Just LHsSigWcType GhcRn
sig_ty <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
arg1)
    -- See Note [Disambiguating record fields]
  = do { TcType
sig_tc_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM TcType
tcHsSigWcType UserTypeCtxt
ExprSigCtxt LHsSigWcType GhcRn
sig_ty
       ; Name
sel_name <- Located RdrName -> TcType -> TcM Name
disambiguateSelector Located RdrName
lbl TcType
sig_tc_ty
       ; let op' :: LHsExpr GhcRn
op' = SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XRecFld GhcRn -> AmbiguousFieldOcc GhcRn -> HsExpr GhcRn
forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld NoExtField
XRecFld GhcRn
noExtField (XUnambiguous GhcRn -> Located RdrName -> AmbiguousFieldOcc GhcRn
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous Name
XUnambiguous GhcRn
sel_name Located RdrName
lbl))
       ; HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr (XOpApp GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
fix LHsExpr GhcRn
arg1 LHsExpr GhcRn
op' LHsExpr GhcRn
arg2) ExpRhoType
res_ty
       }

  | Bool
otherwise
  = do { String -> SDoc -> TcRn ()
traceTc String
"Non Application rule" (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
op)
       ; (LHsExpr GhcTc
op', TcType
op_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRhoNC LHsExpr GhcRn
op

       ; (HsWrapper
wrap_fun, [Scaled TcType
arg1_ty, Scaled TcType
arg2_ty], TcType
op_res_ty)
                  <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> ThLevel
-> TcType
-> TcM (HsWrapper, [Scaled TcType], TcType)
matchActualFunTysRho (LHsExpr GhcRn -> SDoc
mk_op_msg LHsExpr GhcRn
op) CtOrigin
fn_orig
                                          (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op)) ThLevel
2 TcType
op_ty
         -- You might think we should use tcInferApp here, but there is
         -- too much impedance-matching, because tcApp may return wrappers as
         -- well as type-checked arguments.

       ; LHsExpr GhcTc
arg1' <- HsExpr GhcRn
-> LHsExpr GhcRn -> Scaled TcType -> ThLevel -> TcM (LHsExpr GhcTc)
tcArg HsExpr GhcRn
nl_op LHsExpr GhcRn
arg1 Scaled TcType
arg1_ty ThLevel
1
       ; LHsExpr GhcTc
arg2' <- HsExpr GhcRn
-> LHsExpr GhcRn -> Scaled TcType -> ThLevel -> TcM (LHsExpr GhcTc)
tcArg HsExpr GhcRn
nl_op LHsExpr GhcRn
arg2 Scaled TcType
arg2_ty ThLevel
2

       ; let expr' :: HsExpr GhcTc
expr' = XOpApp GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
XOpApp GhcTc
fix LHsExpr GhcTc
arg1' (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap_fun LHsExpr GhcTc
op') LHsExpr GhcTc
arg2'
       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
op_res_ty ExpRhoType
res_ty }
  where
    fn_orig :: CtOrigin
fn_orig = HsExpr GhcRn -> CtOrigin
exprCtOrigin HsExpr GhcRn
nl_op
    nl_op :: HsExpr GhcRn
nl_op   = LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op

-- Right sections, equivalent to \ x -> x `op` expr, or
--      \ x -> op x expr

tcExpr expr :: HsExpr GhcRn
expr@(SectionR XSectionR GhcRn
x LHsExpr GhcRn
op LHsExpr GhcRn
arg2) ExpRhoType
res_ty
  = do { (LHsExpr GhcTc
op', TcType
op_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRhoNC LHsExpr GhcRn
op
       ; (HsWrapper
wrap_fun, [Scaled TcType
arg1_mult TcType
arg1_ty, Scaled TcType
arg2_ty], TcType
op_res_ty)
                  <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> ThLevel
-> TcType
-> TcM (HsWrapper, [Scaled TcType], TcType)
matchActualFunTysRho (LHsExpr GhcRn -> SDoc
mk_op_msg LHsExpr GhcRn
op) CtOrigin
fn_orig
                                          (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op)) ThLevel
2 TcType
op_ty
       ; LHsExpr GhcTc
arg2' <- HsExpr GhcRn
-> LHsExpr GhcRn -> Scaled TcType -> ThLevel -> TcM (LHsExpr GhcTc)
tcArg (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op) LHsExpr GhcRn
arg2 Scaled TcType
arg2_ty ThLevel
2
       ; let expr' :: HsExpr GhcTc
expr'      = XSectionR GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcRn
XSectionR GhcTc
x (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap_fun LHsExpr GhcTc
op') LHsExpr GhcTc
arg2'
             act_res_ty :: TcType
act_res_ty = TcType -> TcType -> TcType -> TcType
mkVisFunTy TcType
arg1_mult TcType
arg1_ty TcType
op_res_ty
       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
act_res_ty ExpRhoType
res_ty }

  where
    fn_orig :: CtOrigin
fn_orig = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
op
    -- It's important to use the origin of 'op', so that call-stacks
    -- come out right; they are driven by the OccurrenceOf CtOrigin
    -- See #13285

tcExpr expr :: HsExpr GhcRn
expr@(SectionL XSectionL GhcRn
x LHsExpr GhcRn
arg1 LHsExpr GhcRn
op) ExpRhoType
res_ty
  = do { (LHsExpr GhcTc
op', TcType
op_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRhoNC LHsExpr GhcRn
op
       ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags      -- Note [Left sections]
       ; let n_reqd_args :: ThLevel
n_reqd_args | Extension -> DynFlags -> Bool
xopt Extension
LangExt.PostfixOperators DynFlags
dflags = ThLevel
1
                         | Bool
otherwise                            = ThLevel
2

       ; (HsWrapper
wrap_fn, (Scaled TcType
arg1_ty:[Scaled TcType]
arg_tys), TcType
op_res_ty)
           <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> ThLevel
-> TcType
-> TcM (HsWrapper, [Scaled TcType], TcType)
matchActualFunTysRho (LHsExpr GhcRn -> SDoc
mk_op_msg LHsExpr GhcRn
op) CtOrigin
fn_orig
                                   (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op)) ThLevel
n_reqd_args TcType
op_ty
       ; LHsExpr GhcTc
arg1' <- HsExpr GhcRn
-> LHsExpr GhcRn -> Scaled TcType -> ThLevel -> TcM (LHsExpr GhcTc)
tcArg (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
op) LHsExpr GhcRn
arg1 Scaled TcType
arg1_ty ThLevel
1
       ; let expr' :: HsExpr GhcTc
expr'      = XSectionL GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcRn
XSectionL GhcTc
x LHsExpr GhcTc
arg1' (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
wrap_fn LHsExpr GhcTc
op')
             act_res_ty :: TcType
act_res_ty = [Scaled TcType] -> TcType -> TcType
mkVisFunTys [Scaled TcType]
arg_tys TcType
op_res_ty
       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
act_res_ty ExpRhoType
res_ty }
  where
    fn_orig :: CtOrigin
fn_orig = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
op
    -- It's important to use the origin of 'op', so that call-stacks
    -- come out right; they are driven by the OccurrenceOf CtOrigin
    -- See #13285

tcExpr expr :: HsExpr GhcRn
expr@(ExplicitTuple XExplicitTuple GhcRn
x [LHsTupArg GhcRn]
tup_args Boxity
boxity) ExpRhoType
res_ty
  | (LHsTupArg GhcRn -> Bool) -> [LHsTupArg GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTupArg GhcRn -> Bool
forall id. LHsTupArg id -> Bool
tupArgPresent [LHsTupArg GhcRn]
tup_args
  = do { let arity :: ThLevel
arity  = [LHsTupArg GhcRn] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [LHsTupArg GhcRn]
tup_args
             tup_tc :: TyCon
tup_tc = Boxity -> ThLevel -> TyCon
tupleTyCon Boxity
boxity ThLevel
arity
               -- NB: tupleTyCon doesn't flatten 1-tuples
               -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
       ; TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
       ; (TcCoercionR
coi, [TcType]
arg_tys) <- TyCon -> TcType -> TcM (TcCoercionR, [TcType])
matchExpectedTyConApp TyCon
tup_tc TcType
res_ty
                           -- Unboxed tuples have RuntimeRep vars, which we
                           -- don't care about here
                           -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
       ; let arg_tys' :: [TcType]
arg_tys' = case Boxity
boxity of Boxity
Unboxed -> ThLevel -> [TcType] -> [TcType]
forall a. ThLevel -> [a] -> [a]
drop ThLevel
arity [TcType]
arg_tys
                                       Boxity
Boxed   -> [TcType]
arg_tys
       ; [LHsTupArg GhcTc]
tup_args1 <- [LHsTupArg GhcRn] -> [TcType] -> TcM [LHsTupArg GhcTc]
tcTupArgs [LHsTupArg GhcRn]
tup_args [TcType]
arg_tys'
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XExplicitTuple GhcTc -> [LHsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTc
x [LHsTupArg GhcTc]
tup_args1 Boxity
boxity) }

  | Bool
otherwise
  = -- The tup_args are a mixture of Present and Missing (for tuple sections)
    do { let arity :: ThLevel
arity = [LHsTupArg GhcRn] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [LHsTupArg GhcRn]
tup_args

       ; [TcType]
arg_tys <- case Boxity
boxity of
           { Boxity
Boxed   -> ThLevel -> TcType -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
newFlexiTyVarTys ThLevel
arity TcType
liftedTypeKind
           ; Boxity
Unboxed -> ThLevel -> TcM TcType -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
forall (m :: * -> *) a. Applicative m => ThLevel -> m a -> m [a]
replicateM ThLevel
arity TcM TcType
newOpenFlexiTyVarTy }

       -- Handle tuple sections where
       ; [LHsTupArg GhcTc]
tup_args1 <- [LHsTupArg GhcRn] -> [TcType] -> TcM [LHsTupArg GhcTc]
tcTupArgs [LHsTupArg GhcRn]
tup_args [TcType]
arg_tys

       ; let expr' :: HsExpr GhcTc
expr'       = XExplicitTuple GhcTc -> [LHsTupArg GhcTc] -> Boxity -> HsExpr GhcTc
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTc
x [LHsTupArg GhcTc]
tup_args1 Boxity
boxity
             missing_tys :: [Scaled TcType]
missing_tys = [TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
Scaled TcType
mult TcType
ty | (L SrcSpan
_ (Missing (Scaled TcType
mult TcType
_)), TcType
ty) <- [LHsTupArg GhcTc] -> [TcType] -> [(LHsTupArg GhcTc, TcType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LHsTupArg GhcTc]
tup_args1 [TcType]
arg_tys]

             -- See Note [Linear fields generalization]
             act_res_ty :: TcType
act_res_ty
                 = [Scaled TcType] -> TcType -> TcType
mkVisFunTys [Scaled TcType]
missing_tys (Boxity -> [TcType] -> TcType
mkTupleTy1 Boxity
boxity [TcType]
arg_tys)
                   -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make

       ; String -> SDoc -> TcRn ()
traceTc String
"ExplicitTuple" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
act_res_ty SDoc -> SDoc -> SDoc
$$ ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty)

       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
act_res_ty ExpRhoType
res_ty }

tcExpr (ExplicitSum XExplicitSum GhcRn
_ ThLevel
alt ThLevel
arity LHsExpr GhcRn
expr) ExpRhoType
res_ty
  = do { let sum_tc :: TyCon
sum_tc = ThLevel -> TyCon
sumTyCon ThLevel
arity
       ; TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
       ; (TcCoercionR
coi, [TcType]
arg_tys) <- TyCon -> TcType -> TcM (TcCoercionR, [TcType])
matchExpectedTyConApp TyCon
sum_tc TcType
res_ty
       ; -- Drop levity vars, we don't care about them here
         let arg_tys' :: [TcType]
arg_tys' = ThLevel -> [TcType] -> [TcType]
forall a. ThLevel -> [a] -> [a]
drop ThLevel
arity [TcType]
arg_tys
       ; LHsExpr GhcTc
expr' <- LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr ([TcType]
arg_tys' [TcType] -> ThLevel -> TcType
forall a. Outputable a => [a] -> ThLevel -> a
`getNth` (ThLevel
alt ThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
- ThLevel
1))
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XExplicitSum GhcTc
-> ThLevel -> ThLevel -> LHsExpr GhcTc -> HsExpr GhcTc
forall p.
XExplicitSum p -> ThLevel -> ThLevel -> LHsExpr p -> HsExpr p
ExplicitSum [TcType]
XExplicitSum GhcTc
arg_tys' ThLevel
alt ThLevel
arity LHsExpr GhcTc
expr' ) }

-- This will see the empty list only when -XOverloadedLists.
-- See Note [Empty lists] in GHC.Hs.Expr.
tcExpr (ExplicitList XExplicitList GhcRn
_ Maybe (SyntaxExpr GhcRn)
witness [LHsExpr GhcRn]
exprs) ExpRhoType
res_ty
  = case Maybe (SyntaxExpr GhcRn)
witness of
      Maybe (SyntaxExpr GhcRn)
Nothing   -> do  { TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
                       ; (TcCoercionR
coi, TcType
elt_ty) <- TcType -> TcM (TcCoercionR, TcType)
matchExpectedListTy TcType
res_ty
                       ; [LHsExpr GhcTc]
exprs' <- (LHsExpr GhcRn -> TcM (LHsExpr GhcTc))
-> [LHsExpr GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) [LHsExpr GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcType -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc)
tc_elt TcType
elt_ty) [LHsExpr GhcRn]
exprs
                       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                         TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTc
-> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> HsExpr GhcTc
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList TcType
XExplicitList GhcTc
elt_ty Maybe (SyntaxExpr GhcTc)
forall a. Maybe a
Nothing [LHsExpr GhcTc]
exprs' }

      Just SyntaxExpr GhcRn
fln -> do { (([LHsExpr GhcTc]
exprs', TcType
elt_ty), SyntaxExprTc
fln')
                         <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> [TcType] -> TcM ([LHsExpr GhcTc], TcType))
-> TcM (([LHsExpr GhcTc], TcType), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
ListOrigin SyntaxExpr GhcRn
SyntaxExprRn
fln
                                       [TcType -> SyntaxOpType
synKnownType TcType
intTy, SyntaxOpType
SynList] ExpRhoType
res_ty (([TcType] -> [TcType] -> TcM ([LHsExpr GhcTc], TcType))
 -> TcM (([LHsExpr GhcTc], TcType), SyntaxExprTc))
-> ([TcType] -> [TcType] -> TcM ([LHsExpr GhcTc], TcType))
-> TcM (([LHsExpr GhcTc], TcType), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
                            \ [TcType
elt_ty] [TcType
_int_mul, TcType
list_mul] ->
                              -- We ignore _int_mul because the integer (first
                              -- argument of fromListN) is statically known: it
                              -- is desugared to a literal. Therefore there is
                              -- no variable of which to scale the usage in that
                              -- first argument, and `_int_mul` is completely
                              -- free in this expression.
                            do { [LHsExpr GhcTc]
exprs' <-
                                    (LHsExpr GhcRn -> TcM (LHsExpr GhcTc))
-> [LHsExpr GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) [LHsExpr GhcTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
list_mul (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> (LHsExpr GhcRn -> TcM (LHsExpr GhcTc))
-> LHsExpr GhcRn
-> TcM (LHsExpr GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcType -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc)
tc_elt TcType
elt_ty) [LHsExpr GhcRn]
exprs
                               ; ([LHsExpr GhcTc], TcType) -> TcM ([LHsExpr GhcTc], TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsExpr GhcTc]
exprs', TcType
elt_ty) }

                     ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTc
-> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> HsExpr GhcTc
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList TcType
XExplicitList GhcTc
elt_ty (SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just SyntaxExprTc
fln') [LHsExpr GhcTc]
exprs' }
     where tc_elt :: TcType -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc)
tc_elt TcType
elt_ty LHsExpr GhcRn
expr = LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcType
elt_ty

{-
************************************************************************
*                                                                      *
                Let, case, if, do
*                                                                      *
************************************************************************
-}

tcExpr (HsLet XLet GhcRn
x (L SrcSpan
l HsLocalBinds GhcRn
binds) LHsExpr GhcRn
expr) ExpRhoType
res_ty
  = do  { (HsLocalBinds GhcTc
binds', LHsExpr GhcTc
expr') <- HsLocalBinds GhcRn
-> TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall thing.
HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing)
tcLocalBinds HsLocalBinds GhcRn
binds (TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (HsLocalBinds GhcTc, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
                             LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
expr ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XLet GhcTc -> LHsLocalBinds GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XLet p -> LHsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet XLet GhcRn
XLet GhcTc
x (SrcSpan -> HsLocalBinds GhcTc -> LHsLocalBinds GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsLocalBinds GhcTc
binds') LHsExpr GhcTc
expr') }

tcExpr (HsCase XCase GhcRn
x LHsExpr GhcRn
scrut MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpRhoType
res_ty
  = do  {  -- We used to typecheck the case alternatives first.
           -- The case patterns tend to give good type info to use
           -- when typechecking the scrutinee.  For example
           --   case (map f) of
           --     (x:xs) -> ...
           -- will report that map is applied to too few arguments
           --
           -- But now, in the GADT world, we need to typecheck the scrutinee
           -- first, to get type info that may be refined in the case alternatives
          let mult :: TcType
mult = TcType
Many
            -- There is not yet syntax or inference mechanism for case
            -- expressions to be anything else than unrestricted.

          -- Typecheck the scrutinee.  We use tcInferRho but tcInferSigma
          -- would also be possible (tcMatchesCase accepts sigma-types)
          -- Interesting litmus test: do these two behave the same?
          --     case id        of {..}
          --     case (\v -> v) of {..}
          -- This design choice is discussed in #17790
        ; (LHsExpr GhcTc
scrut', TcType
scrut_ty) <- TcType
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
mult (TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType))
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRho LHsExpr GhcRn
scrut

        ; String -> SDoc -> TcRn ()
traceTc String
"HsCase" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
scrut_ty)
        ; MatchGroup GhcTc (LHsExpr GhcTc)
matches' <- TcMatchCtxt HsExpr
-> Scaled TcType
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (MatchGroup GhcTc (LHsExpr GhcTc))
forall (body :: * -> *).
Outputable (body GhcRn) =>
TcMatchCtxt body
-> Scaled TcType
-> MatchGroup GhcRn (Located (body GhcRn))
-> ExpRhoType
-> TcM (MatchGroup GhcTc (Located (body GhcTc)))
tcMatchesCase TcMatchCtxt HsExpr
match_ctxt (TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
Scaled TcType
mult TcType
scrut_ty) MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCase GhcTc
-> LHsExpr GhcTc
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> HsExpr GhcTc
forall p.
XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsCase XCase GhcRn
XCase GhcTc
x LHsExpr GhcTc
scrut' MatchGroup GhcTc (LHsExpr GhcTc)
matches') }
 where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (Located (body GhcRn)
    -> ExpRhoType -> TcM (Located (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt,
                      mc_body :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }

tcExpr (HsIf XIf GhcRn
x LHsExpr GhcRn
pred LHsExpr GhcRn
b1 LHsExpr GhcRn
b2) ExpRhoType
res_ty
  = do { LHsExpr GhcTc
pred' <- LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
pred (TcType -> ExpRhoType
mkCheckExpType TcType
boolTy)
       ; (UsageEnv
u1,LHsExpr GhcTc
b1') <- TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
b1 ExpRhoType
res_ty
       ; (UsageEnv
u2,LHsExpr GhcTc
b2') <- TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage (TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (UsageEnv, LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcLExpr LHsExpr GhcRn
b2 ExpRhoType
res_ty
       ; UsageEnv -> TcRn ()
tcEmitBindingUsage (UsageEnv -> UsageEnv -> UsageEnv
supUE UsageEnv
u1 UsageEnv
u2)
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XIf GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsIf XIf GhcRn
XIf GhcTc
x LHsExpr GhcTc
pred' LHsExpr GhcTc
b1' LHsExpr GhcTc
b2') }

tcExpr (HsMultiIf XMultiIf GhcRn
_ [LGRHS GhcRn (LHsExpr GhcRn)]
alts) ExpRhoType
res_ty
  = do { [Located (GRHS GhcTc (LHsExpr GhcTc))]
alts' <- (LGRHS GhcRn (LHsExpr GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (Located (GRHS GhcTc (LHsExpr GhcTc))))
-> [LGRHS GhcRn (LHsExpr GhcRn)]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [Located (GRHS GhcTc (LHsExpr GhcTc))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((GRHS GhcRn (LHsExpr GhcRn) -> TcM (GRHS GhcTc (LHsExpr GhcTc)))
-> LGRHS GhcRn (LHsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Located (GRHS GhcTc (LHsExpr GhcTc)))
forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM ((GRHS GhcRn (LHsExpr GhcRn) -> TcM (GRHS GhcTc (LHsExpr GhcTc)))
 -> LGRHS GhcRn (LHsExpr GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv) (Located (GRHS GhcTc (LHsExpr GhcTc))))
-> (GRHS GhcRn (LHsExpr GhcRn) -> TcM (GRHS GhcTc (LHsExpr GhcTc)))
-> LGRHS GhcRn (LHsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Located (GRHS GhcTc (LHsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ TcMatchCtxt HsExpr
-> ExpRhoType
-> GRHS GhcRn (LHsExpr GhcRn)
-> TcM (GRHS GhcTc (LHsExpr GhcTc))
forall (body :: * -> *).
TcMatchCtxt body
-> ExpRhoType
-> GRHS GhcRn (Located (body GhcRn))
-> TcM (GRHS GhcTc (Located (body GhcTc)))
tcGRHS TcMatchCtxt HsExpr
match_ctxt ExpRhoType
res_ty) [LGRHS GhcRn (LHsExpr GhcRn)]
alts
       ; TcType
res_ty <- ExpRhoType -> TcM TcType
readExpType ExpRhoType
res_ty
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XMultiIf GhcTc
-> [Located (GRHS GhcTc (LHsExpr GhcTc))] -> HsExpr GhcTc
forall p. XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p
HsMultiIf TcType
XMultiIf GhcTc
res_ty [Located (GRHS GhcTc (LHsExpr GhcTc))]
alts') }
  where match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext GhcRn
-> (Located (body GhcRn)
    -> ExpRhoType -> TcM (Located (body GhcTc)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext GhcRn
mc_what = HsMatchContext GhcRn
forall p. HsMatchContext p
IfAlt, mc_body :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
mc_body = LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
tcBody }

tcExpr (HsDo XDo GhcRn
_ HsStmtContext GhcRn
do_or_lc Located [ExprLStmt GhcRn]
stmts) ExpRhoType
res_ty
  = do { HsExpr GhcTc
expr' <- HsStmtContext GhcRn
-> Located [ExprLStmt GhcRn] -> ExpRhoType -> TcM (HsExpr GhcTc)
tcDoStmts HsStmtContext GhcRn
do_or_lc Located [ExprLStmt GhcRn]
stmts ExpRhoType
res_ty
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return HsExpr GhcTc
expr' }

tcExpr (HsProc XProc GhcRn
x LPat GhcRn
pat LHsCmdTop GhcRn
cmd) ExpRhoType
res_ty
  = do  { (Located (Pat GhcTc)
pat', LHsCmdTop GhcTc
cmd', TcCoercionR
coi) <- LPat GhcRn
-> LHsCmdTop GhcRn
-> ExpRhoType
-> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercionR)
tcProc LPat GhcRn
pat LHsCmdTop GhcRn
cmd ExpRhoType
res_ty
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
coi (XProc GhcTc -> LPat GhcTc -> LHsCmdTop GhcTc -> HsExpr GhcTc
forall p. XProc p -> LPat p -> LHsCmdTop p -> HsExpr p
HsProc XProc GhcRn
XProc GhcTc
x Located (Pat GhcTc)
LPat GhcTc
pat' LHsCmdTop GhcTc
cmd') }

-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.
-- To type check
--      (static e) :: p a
-- we want to check (e :: a),
-- and wrap (static e) in a call to
--    fromStaticPtr :: IsStatic p => StaticPtr a -> p a

tcExpr (HsStatic XStatic GhcRn
fvs LHsExpr GhcRn
expr) ExpRhoType
res_ty
  = do  { TcType
res_ty          <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
        ; (TcCoercionR
co, (TcType
p_ty, TcType
expr_ty)) <- TcType -> TcM (TcCoercionR, (TcType, TcType))
matchExpectedAppTy TcType
res_ty
        ; (LHsExpr GhcTc
expr', WantedConstraints
lie)    <- TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc, WantedConstraints))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
            SDoc -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the body of a static form:")
                             ThLevel
2 (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
expr)
                       ) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
            LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
expr TcType
expr_ty

        -- Check that the free variables of the static form are closed.
        -- It's OK to use nonDetEltsUniqSet here as the only side effects of
        -- checkClosedInStaticForm are error messages.
        ; (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> TcRn ()
checkClosedInStaticForm ([Name] -> TcRn ()) -> [Name] -> TcRn ()
forall a b. (a -> b) -> a -> b
$ UniqSet Name -> [Name]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet Name
XStatic GhcRn
fvs

        -- Require the type of the argument to be Typeable.
        -- The evidence is not used, but asking the constraint ensures that
        -- the current implementation is as restrictive as future versions
        -- of the StaticPointers extension.
        ; Class
typeableClass <- Name -> TcM Class
tcLookupClass Name
typeableClassName
        ; Var
_ <- CtOrigin -> TcType -> TcM Var
emitWantedEvVar CtOrigin
StaticOrigin (TcType -> TcM Var) -> TcType -> TcM Var
forall a b. (a -> b) -> a -> b
$
                  TyCon -> [TcType] -> TcType
mkTyConApp (Class -> TyCon
classTyCon Class
typeableClass)
                             [TcType
liftedTypeKind, TcType
expr_ty]

        -- Insert the constraints of the static form in a global list for later
        -- validation.
        ; WantedConstraints -> TcRn ()
emitStaticConstraints WantedConstraints
lie

        -- Wrap the static form with the 'fromStaticPtr' call.
        ; HsExpr GhcTc
fromStaticPtr <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName CtOrigin
StaticOrigin Name
fromStaticPtrName
                                             [TcType
p_ty]
        ; let wrap :: HsWrapper
wrap = [TcType] -> HsWrapper
mkWpTyApps [TcType
expr_ty]
        ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo TcCoercionR
co (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp GhcTc
noExtField
                                         (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsExpr GhcTc -> LHsExpr GhcTc) -> HsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap HsExpr GhcTc
fromStaticPtr)
                                         (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XStatic GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic XStatic GhcRn
XStatic GhcTc
fvs LHsExpr GhcTc
expr'))
        }

{-
************************************************************************
*                                                                      *
                Record construction and update
*                                                                      *
************************************************************************
-}

tcExpr expr :: HsExpr GhcRn
expr@(RecordCon { rcon_con_name :: forall p. HsExpr p -> Located (IdP p)
rcon_con_name = L SrcSpan
loc IdP GhcRn
con_name
                       , rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcRn
rbinds }) ExpRhoType
res_ty
  = do  { ConLike
con_like <- Name -> TcM ConLike
tcLookupConLike Name
IdP GhcRn
con_name

        -- Check for missing fields
        ; ConLike -> HsRecordBinds GhcRn -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds

        ; (HsExpr GhcTc
con_expr, TcType
con_sigma) <- Name -> TcM (HsExpr GhcTc, TcType)
tcInferId Name
IdP GhcRn
con_name
        ; (HsWrapper
con_wrap, TcType
con_tau)   <- CtOrigin -> TcType -> TcM (HsWrapper, TcType)
topInstantiate CtOrigin
orig TcType
con_sigma
              -- a shallow instantiation should really be enough for
              -- a data constructor.
        ; let arity :: ThLevel
arity = ConLike -> ThLevel
conLikeArity ConLike
con_like
              Right ([Scaled TcType]
arg_tys, TcType
actual_res_ty) = ThLevel -> TcType -> Either ThLevel ([Scaled TcType], TcType)
tcSplitFunTysN ThLevel
arity TcType
con_tau
        ; case ConLike -> Maybe Var
conLikeWrapId_maybe ConLike
con_like of {
               Maybe Var
Nothing -> Name -> TcM (HsExpr GhcTc)
forall name a. Outputable name => name -> TcM a
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con_like) ;
               Just Var
con_id ->

     do { HsRecordBinds GhcTc
rbinds' <- ConLike
-> [TcType] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like ((Scaled TcType -> TcType) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing [Scaled TcType]
arg_tys) HsRecordBinds GhcRn
rbinds
                   -- It is currently not possible for a record to have
                   -- multiplicities. When they do, `tcRecordBinds` will take
                   -- scaled types instead. Meanwhile, it's safe to take
                   -- `scaledThing` above, as we know all the multiplicities are
                   -- Many.
        ; let rcon_tc :: RecordConTc
rcon_tc = RecordConTc :: ConLike -> HsExpr GhcTc -> RecordConTc
RecordConTc
                           { rcon_con_like :: ConLike
rcon_con_like = ConLike
con_like
                           , rcon_con_expr :: HsExpr GhcTc
rcon_con_expr = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
con_wrap HsExpr GhcTc
con_expr }
              expr' :: HsExpr GhcTc
expr' = RecordCon :: forall p.
XRecordCon p -> Located (IdP p) -> HsRecordBinds p -> HsExpr p
RecordCon { rcon_ext :: XRecordCon GhcTc
rcon_ext = XRecordCon GhcTc
RecordConTc
rcon_tc
                                , rcon_con_name :: Located (IdP GhcTc)
rcon_con_name = SrcSpan -> Var -> Located Var
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Var
con_id
                                , rcon_flds :: HsRecordBinds GhcTc
rcon_flds = HsRecordBinds GhcTc
rbinds' }

        ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResultMono HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
actual_res_ty ExpRhoType
res_ty } } }
  where
    orig :: CtOrigin
orig = Name -> CtOrigin
OccurrenceOf Name
IdP GhcRn
con_name

{-
Note [Type of a record update]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The main complication with RecordUpd is that we need to explicitly
handle the *non-updated* fields.  Consider:

        data T a b c = MkT1 { fa :: a, fb :: (b,c) }
                     | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
                     | MkT3 { fd :: a }

        upd :: T a b c -> (b',c) -> T a b' c
        upd t x = t { fb = x}

The result type should be (T a b' c)
not (T a b c),   because 'b' *is not* mentioned in a non-updated field
not (T a b' c'), because 'c' *is*     mentioned in a non-updated field
NB that it's not good enough to look at just one constructor; we must
look at them all; cf #3219

After all, upd should be equivalent to:
        upd t x = case t of
                        MkT1 p q -> MkT1 p x
                        MkT2 a b -> MkT2 p b
                        MkT3 d   -> error ...

So we need to give a completely fresh type to the result record,
and then constrain it by the fields that are *not* updated ("p" above).
We call these the "fixed" type variables, and compute them in getFixedTyVars.

Note that because MkT3 doesn't contain all the fields being updated,
its RHS is simply an error, so it doesn't impose any type constraints.
Hence the use of 'relevant_cont'.

Note [Implicit type sharing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We also take into account any "implicit" non-update fields.  For example
        data T a b where { MkT { f::a } :: T a a; ... }
So the "real" type of MkT is: forall ab. (a~b) => a -> T a b

Then consider
        upd t x = t { f=x }
We infer the type
        upd :: T a b -> a -> T a b
        upd (t::T a b) (x::a)
           = case t of { MkT (co:a~b) (_:a) -> MkT co x }
We can't give it the more general type
        upd :: T a b -> c -> T c b

Note [Criteria for update]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to allow update for existentials etc, provided the updated
field isn't part of the existential. For example, this should be ok.
  data T a where { MkT { f1::a, f2::b->b } :: T a }
  f :: T a -> b -> T b
  f t b = t { f1=b }

The criterion we use is this:

  The types of the updated fields
  mention only the universally-quantified type variables
  of the data constructor

NB: this is not (quite) the same as being a "naughty" record selector
(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least
in the case of GADTs. Consider
   data T a where { MkT :: { f :: a } :: T [a] }
Then f is not "naughty" because it has a well-typed record selector.
But we don't allow updates for 'f'.  (One could consider trying to
allow this, but it makes my head hurt.  Badly.  And no one has asked
for it.)

In principle one could go further, and allow
  g :: T a -> T a
  g t = t { f2 = \x -> x }
because the expression is polymorphic...but that seems a bridge too far.

Note [Data family example]
~~~~~~~~~~~~~~~~~~~~~~~~~~
    data instance T (a,b) = MkT { x::a, y::b }
  --->
    data :TP a b = MkT { a::a, y::b }
    coTP a b :: T (a,b) ~ :TP a b

Suppose r :: T (t1,t2), e :: t3
Then  r { x=e } :: T (t3,t1)
  --->
      case r |> co1 of
        MkT x y -> MkT e y |> co2
      where co1 :: T (t1,t2) ~ :TP t1 t2
            co2 :: :TP t3 t2 ~ T (t3,t2)
The wrapping with co2 is done by the constructor wrapper for MkT

Outgoing invariants
~~~~~~~~~~~~~~~~~~~
In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):

  * cons are the data constructors to be updated

  * in_inst_tys, out_inst_tys have same length, and instantiate the
        *representation* tycon of the data cons.  In Note [Data
        family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]

Note [Mixed Record Field Updates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following pattern synonym.

  data MyRec = MyRec { foo :: Int, qux :: String }

  pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}

This allows updates such as the following

  updater :: MyRec -> MyRec
  updater a = a {f1 = 1 }

It would also make sense to allow the following update (which we reject).

  updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"

This leads to confusing behaviour when the selectors in fact refer the same
field.

  updater a = a {f1 = 1, foo = 2} ==? ???

For this reason, we reject a mixture of pattern synonym and normal record
selectors in the same update block. Although of course we still allow the
following.

  updater a = (a {f1 = 1}) {foo = 2}

  > updater (MyRec 0 "str")
  MyRec 2 "str"

-}

tcExpr expr :: HsExpr GhcRn
expr@(RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcRn
record_expr, rupd_flds :: forall p. HsExpr p -> [LHsRecUpdField p]
rupd_flds = [LHsRecUpdField GhcRn]
rbnds }) ExpRhoType
res_ty
  = ASSERT( notNull rbnds )
    do  { -- STEP -2: typecheck the record_expr, the record to be updated
          (LHsExpr GhcTc
record_expr', TcType
record_rho) <- TcType
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
Many (TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType))
-> TcM (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType)
tcInferRho LHsExpr GhcRn
record_expr
            -- Record update drops some of the content of the record (namely the
            -- content of the field being updated). As a consequence, unless the
            -- field being updated is unrestricted in the record, or we need an
            -- unrestricted record. Currently, we simply always require an
            -- unrestricted record.
            --
            -- Consider the following example:
            --
            -- data R a = R { self :: a }
            -- bad :: a ⊸ ()
            -- bad x = let r = R x in case r { self = () } of { R x' -> x' }
            --
            -- This should definitely *not* typecheck.

        -- STEP -1  See Note [Disambiguating record fields]
        -- After this we know that rbinds is unambiguous
        ; [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds <- LHsExpr GhcRn
-> TcType
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcType
record_rho [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty
        ; let upd_flds :: [AmbiguousFieldOcc GhcTc]
upd_flds = (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
 -> AmbiguousFieldOcc GhcTc)
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [AmbiguousFieldOcc GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
 -> AmbiguousFieldOcc GhcTc)
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
    -> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> AmbiguousFieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
 -> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
    -> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc) [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds
              upd_fld_occs :: [FieldLabelString]
upd_fld_occs = (AmbiguousFieldOcc GhcTc -> FieldLabelString)
-> [AmbiguousFieldOcc GhcTc] -> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FieldLabelString
occNameFS (OccName -> FieldLabelString)
-> (AmbiguousFieldOcc GhcTc -> OccName)
-> AmbiguousFieldOcc GhcTc
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (AmbiguousFieldOcc GhcTc -> RdrName)
-> AmbiguousFieldOcc GhcTc
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbiguousFieldOcc GhcTc -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc) [AmbiguousFieldOcc GhcTc]
upd_flds
              sel_ids :: [Var]
sel_ids      = (AmbiguousFieldOcc GhcTc -> Var)
-> [AmbiguousFieldOcc GhcTc] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map AmbiguousFieldOcc GhcTc -> Var
selectorAmbiguousFieldOcc [AmbiguousFieldOcc GhcTc]
upd_flds
        -- STEP 0
        -- Check that the field names are really field names
        -- and they are all field names for proper records or
        -- all field names for pattern synonyms.
        ; let bad_guys :: [TcRn ()]
bad_guys = [ SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
addErrTc (Name -> SDoc
notSelector Name
fld_name)
                         | LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
fld <- [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds,
                           -- Excludes class ops
                           let L SrcSpan
loc Var
sel_id = HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> Located Var
forall arg.
HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Var
hsRecUpdFieldId (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
fld),
                           Bool -> Bool
not (Var -> Bool
isRecordSelector Var
sel_id),
                           let fld_name :: Name
fld_name = Var -> Name
idName Var
sel_id ]
        ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TcRn ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcRn ()]
bad_guys) ([TcRn ()] -> IOEnv (Env TcGblEnv TcLclEnv) [()]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TcRn ()]
bad_guys IOEnv (Env TcGblEnv TcLclEnv) [()] -> TcRn () -> TcRn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TcRn ()
forall env a. IOEnv env a
failM)
        -- See note [Mixed Record Selectors]
        ; let ([Var]
data_sels, [Var]
pat_syn_sels) =
                (Var -> Bool) -> [Var] -> ([Var], [Var])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Var -> Bool
isDataConRecordSelector [Var]
sel_ids
        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )
        ; Bool -> SDoc -> TcRn ()
checkTc ( [Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
data_sels Bool -> Bool -> Bool
|| [Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
pat_syn_sels )
                  ( [Var] -> [Var] -> SDoc
mixedSelectors [Var]
data_sels [Var]
pat_syn_sels )

        -- STEP 1
        -- Figure out the tycon and data cons from the first field name
        ; let   -- It's OK to use the non-tc splitters here (for a selector)
              Var
sel_id : [Var]
_  = [Var]
sel_ids

              mtycon :: Maybe TyCon
              mtycon :: Maybe TyCon
mtycon = case Var -> IdDetails
idDetails Var
sel_id of
                          RecSelId (RecSelData TyCon
tycon) Bool
_ -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tycon
                          IdDetails
_ -> Maybe TyCon
forall a. Maybe a
Nothing

              con_likes :: [ConLike]
              con_likes :: [ConLike]
con_likes = case Var -> IdDetails
idDetails Var
sel_id of
                             RecSelId (RecSelData TyCon
tc) Bool
_
                                -> (DataCon -> ConLike) -> [DataCon] -> [ConLike]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ConLike
RealDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
                             RecSelId (RecSelPatSyn PatSyn
ps) Bool
_
                                -> [PatSyn -> ConLike
PatSynCon PatSyn
ps]
                             IdDetails
_  -> String -> [ConLike]
forall a. String -> a
panic String
"tcRecordUpd"
                -- NB: for a data type family, the tycon is the instance tycon

              relevant_cons :: [ConLike]
relevant_cons = [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields [ConLike]
con_likes [FieldLabelString]
upd_fld_occs
                -- A constructor is only relevant to this process if
                -- it contains *all* the fields that are being updated
                -- Other ones will cause a runtime error if they occur

        -- Step 2
        -- Check that at least one constructor has all the named fields
        -- i.e. has an empty set of bad fields returned by badFields
        ; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not ([ConLike] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConLike]
relevant_cons)) ([LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds [ConLike]
con_likes)

        -- Take apart a representative constructor
        ; let con1 :: ConLike
con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
              ([Var]
con1_tvs, [Var]
_, [EqSpec]
_, [TcType]
_prov_theta, [TcType]
req_theta, [Scaled TcType]
scaled_con1_arg_tys, TcType
_)
                 = ConLike
-> ([Var], [Var], [EqSpec], [TcType], [TcType], [Scaled TcType],
    TcType)
conLikeFullSig ConLike
con1
              con1_arg_tys :: [TcType]
con1_arg_tys = (Scaled TcType -> TcType) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing [Scaled TcType]
scaled_con1_arg_tys
                -- We can safely drop the fields' multiplicities because
                -- they are currently always 1: there is no syntax for record
                -- fields with other multiplicities yet. This way we don't need
                -- to handle it in the rest of the function
              con1_flds :: [FieldLabelString]
con1_flds   = (FieldLbl Name -> FieldLabelString)
-> [FieldLbl Name] -> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel ([FieldLbl Name] -> [FieldLabelString])
-> [FieldLbl Name] -> [FieldLabelString]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con1
              con1_tv_tys :: [TcType]
con1_tv_tys = [Var] -> [TcType]
mkTyVarTys [Var]
con1_tvs
              con1_res_ty :: TcType
con1_res_ty = case Maybe TyCon
mtycon of
                              Just TyCon
tc -> TyCon -> [TcType] -> TcType
mkFamilyTyConApp TyCon
tc [TcType]
con1_tv_tys
                              Maybe TyCon
Nothing -> ConLike -> [TcType] -> TcType
conLikeResTy ConLike
con1 [TcType]
con1_tv_tys

        -- Check that we're not dealing with a unidirectional pattern
        -- synonym
        ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Var -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Var -> Bool) -> Maybe Var -> Bool
forall a b. (a -> b) -> a -> b
$ ConLike -> Maybe Var
conLikeWrapId_maybe ConLike
con1)
                  (Name -> TcRn ()
forall name a. Outputable name => name -> TcM a
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con1))

        -- STEP 3    Note [Criteria for update]
        -- Check that each updated field is polymorphic; that is, its type
        -- mentions only the universally-quantified variables of the data con
        ; let flds1_w_tys :: [(FieldLabelString, TcType)]
flds1_w_tys  = String
-> [FieldLabelString] -> [TcType] -> [(FieldLabelString, TcType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcExpr:RecConUpd" [FieldLabelString]
con1_flds [TcType]
con1_arg_tys
              bad_upd_flds :: [(FieldLabelString, TcType)]
bad_upd_flds = ((FieldLabelString, TcType) -> Bool)
-> [(FieldLabelString, TcType)] -> [(FieldLabelString, TcType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FieldLabelString, TcType) -> Bool
bad_fld [(FieldLabelString, TcType)]
flds1_w_tys
              con1_tv_set :: VarSet
con1_tv_set  = [Var] -> VarSet
mkVarSet [Var]
con1_tvs
              bad_fld :: (FieldLabelString, TcType) -> Bool
bad_fld (FieldLabelString
fld, TcType
ty) = FieldLabelString
fld FieldLabelString -> [FieldLabelString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FieldLabelString]
upd_fld_occs Bool -> Bool -> Bool
&&
                                      Bool -> Bool
not (TcType -> VarSet
tyCoVarsOfType TcType
ty VarSet -> VarSet -> Bool
`subVarSet` VarSet
con1_tv_set)
        ; Bool -> SDoc -> TcRn ()
checkTc ([(FieldLabelString, TcType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, TcType)]
bad_upd_flds) ([(FieldLabelString, TcType)] -> SDoc
badFieldTypes [(FieldLabelString, TcType)]
bad_upd_flds)

        -- STEP 4  Note [Type of a record update]
        -- Figure out types for the scrutinee and result
        -- Both are of form (T a b c), with fresh type variables, but with
        -- common variables where the scrutinee and result must have the same type
        -- These are variables that appear in *any* arg of *any* of the
        -- relevant constructors *except* in the updated fields
        --
        ; let fixed_tvs :: VarSet
fixed_tvs = [FieldLabelString] -> [Var] -> [ConLike] -> VarSet
getFixedTyVars [FieldLabelString]
upd_fld_occs [Var]
con1_tvs [ConLike]
relevant_cons
              is_fixed_tv :: Var -> Bool
is_fixed_tv Var
tv = Var
tv Var -> VarSet -> Bool
`elemVarSet` VarSet
fixed_tvs

              mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
              -- Deals with instantiation of kind variables
              --   c.f. GHC.Tc.Utils.TcMType.newMetaTyVars
              mk_inst_ty :: TCvSubst -> (Var, TcType) -> TcM (TCvSubst, TcType)
mk_inst_ty TCvSubst
subst (Var
tv, TcType
result_inst_ty)
                | Var -> Bool
is_fixed_tv Var
tv   -- Same as result type
                = (TCvSubst, TcType) -> TcM (TCvSubst, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst -> Var -> TcType -> TCvSubst
extendTvSubst TCvSubst
subst Var
tv TcType
result_inst_ty, TcType
result_inst_ty)
                | Bool
otherwise        -- Fresh type, of correct kind
                = do { (TCvSubst
subst', Var
new_tv) <- TCvSubst -> Var -> TcM (TCvSubst, Var)
newMetaTyVarX TCvSubst
subst Var
tv
                     ; (TCvSubst, TcType) -> TcM (TCvSubst, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst', Var -> TcType
mkTyVarTy Var
new_tv) }

        ; (TCvSubst
result_subst, [Var]
con1_tvs') <- [Var] -> TcM (TCvSubst, [Var])
newMetaTyVars [Var]
con1_tvs
        ; let result_inst_tys :: [TcType]
result_inst_tys = [Var] -> [TcType]
mkTyVarTys [Var]
con1_tvs'
              init_subst :: TCvSubst
init_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (TCvSubst -> InScopeSet
getTCvInScope TCvSubst
result_subst)

        ; (TCvSubst
scrut_subst, [TcType]
scrut_inst_tys) <- (TCvSubst -> (Var, TcType) -> TcM (TCvSubst, TcType))
-> TCvSubst
-> [(Var, TcType)]
-> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, [TcType])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst -> (Var, TcType) -> TcM (TCvSubst, TcType)
mk_inst_ty TCvSubst
init_subst
                                                      ([Var]
con1_tvs [Var] -> [TcType] -> [(Var, TcType)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcType]
result_inst_tys)

        ; let rec_res_ty :: TcType
rec_res_ty    = HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
TcType.substTy TCvSubst
result_subst TcType
con1_res_ty
              scrut_ty :: TcType
scrut_ty      = HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
TcType.substTy TCvSubst
scrut_subst  TcType
con1_res_ty
              con1_arg_tys' :: [TcType]
con1_arg_tys' = (TcType -> TcType) -> [TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
TcType.substTy TCvSubst
result_subst) [TcType]
con1_arg_tys

        ; TcCoercionR
co_scrut <- Maybe (HsExpr GhcRn) -> TcType -> TcType -> TcM TcCoercionR
unifyType (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
record_expr)) TcType
record_rho TcType
scrut_ty
                -- NB: normal unification is OK here (as opposed to subsumption),
                -- because for this to work out, both record_rho and scrut_ty have
                -- to be normal datatypes -- no contravariant stuff can go on

        -- STEP 5
        -- Typecheck the bindings
        ; [LHsRecUpdField GhcTc]
rbinds'      <- ConLike
-> [TcType]
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd ConLike
con1 [TcType]
con1_arg_tys' [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds

        -- STEP 6: Deal with the stupid theta
        ; let theta' :: [TcType]
theta' = TCvSubst -> [TcType] -> [TcType]
substThetaUnchecked TCvSubst
scrut_subst (ConLike -> [TcType]
conLikeStupidTheta ConLike
con1)
        ; CtOrigin -> [TcType] -> TcRn ()
instStupidTheta CtOrigin
RecordUpdOrigin [TcType]
theta'

        -- Step 7: make a cast for the scrutinee, in the
        --         case that it's from a data family
        ; let fam_co :: HsWrapper   -- RepT t1 .. tn ~R scrut_ty
              fam_co :: HsWrapper
fam_co | Just TyCon
tycon <- Maybe TyCon
mtycon
                     , Just CoAxiom Unbranched
co_con <- TyCon -> Maybe (CoAxiom Unbranched)
tyConFamilyCoercion_maybe TyCon
tycon
                     = TcCoercionR -> HsWrapper
mkWpCastR (CoAxiom Unbranched -> [TcType] -> [TcCoercionR] -> TcCoercionR
mkTcUnbranchedAxInstCo CoAxiom Unbranched
co_con [TcType]
scrut_inst_tys [])
                     | Bool
otherwise
                     = HsWrapper
idHsWrapper

        -- Step 8: Check that the req constraints are satisfied
        -- For normal data constructors req_theta is empty but we must do
        -- this check for pattern synonyms.
        ; let req_theta' :: [TcType]
req_theta' = TCvSubst -> [TcType] -> [TcType]
substThetaUnchecked TCvSubst
scrut_subst [TcType]
req_theta
        ; HsWrapper
req_wrap <- CtOrigin -> [TcType] -> TcM HsWrapper
instCallConstraints CtOrigin
RecordUpdOrigin [TcType]
req_theta'

        -- Phew!
        ; let upd_tc :: RecordUpdTc
upd_tc = RecordUpdTc :: [ConLike] -> [TcType] -> [TcType] -> HsWrapper -> RecordUpdTc
RecordUpdTc { rupd_cons :: [ConLike]
rupd_cons = [ConLike]
relevant_cons
                                   , rupd_in_tys :: [TcType]
rupd_in_tys = [TcType]
scrut_inst_tys
                                   , rupd_out_tys :: [TcType]
rupd_out_tys = [TcType]
result_inst_tys
                                   , rupd_wrap :: HsWrapper
rupd_wrap = HsWrapper
req_wrap }
              expr' :: HsExpr GhcTc
expr' = RecordUpd :: forall p.
XRecordUpd p -> LHsExpr p -> [LHsRecUpdField p] -> HsExpr p
RecordUpd { rupd_expr :: LHsExpr GhcTc
rupd_expr = HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
fam_co (LHsExpr GhcTc -> LHsExpr GhcTc) -> LHsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
                                              TcCoercionR -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrapCo TcCoercionR
co_scrut LHsExpr GhcTc
record_expr'
                                , rupd_flds :: [LHsRecUpdField GhcTc]
rupd_flds = [LHsRecUpdField GhcTc]
rbinds'
                                , rupd_ext :: XRecordUpd GhcTc
rupd_ext = XRecordUpd GhcTc
RecordUpdTc
upd_tc }

        ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
rec_res_ty ExpRhoType
res_ty }

tcExpr e :: HsExpr GhcRn
e@(HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
f) ExpRhoType
res_ty
    = HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckRecSelId HsExpr GhcRn
e AmbiguousFieldOcc GhcRn
f ExpRhoType
res_ty

{-
************************************************************************
*                                                                      *
        Arithmetic sequences                    e.g. [a,b..]
        and their parallel-array counterparts   e.g. [: a,b.. :]

*                                                                      *
************************************************************************
-}

tcExpr (ArithSeq XArithSeq GhcRn
_ Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq) ExpRhoType
res_ty
  = Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq ExpRhoType
res_ty

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

-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'.
-- Here we get rid of it and add the finalizers to the global environment.
--
-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
tcExpr (HsSpliceE XSpliceE GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
mod_finalizers (HsSplicedExpr HsExpr GhcRn
expr)))
       ExpRhoType
res_ty
  = do ThModFinalizers -> TcRn ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
       HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
expr ExpRhoType
res_ty
tcExpr (HsSpliceE XSpliceE GhcRn
_ HsSplice GhcRn
splice)          ExpRhoType
res_ty = HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcSpliceExpr HsSplice GhcRn
splice ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsBracket XBracket GhcRn
_ HsBracket GhcRn
brack)         ExpRhoType
res_ty = HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcTypedBracket HsExpr GhcRn
e HsBracket GhcRn
brack ExpRhoType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsRnBracketOut XRnBracketOut GhcRn
_ HsBracket GhcRn
brack [PendingRnSplice]
ps) ExpRhoType
res_ty = HsExpr GhcRn
-> HsBracket GhcRn
-> [PendingRnSplice]
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcUntypedBracket HsExpr GhcRn
e HsBracket GhcRn
brack [PendingRnSplice]
ps ExpRhoType
res_ty

{-
************************************************************************
*                                                                      *
                Rebindable syntax
*                                                                      *
************************************************************************
-}

-- See Note [Rebindable syntax and HsExpansion].
tcExpr (XExpr (HsExpanded HsExpr GhcRn
a HsExpr GhcRn
b)) ExpRhoType
t
  = (HsExpr GhcTc -> HsExpr GhcTc)
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XXExprGhcTc -> HsExpr GhcTc
forall p. XXExpr p -> HsExpr p
XExpr (XXExprGhcTc -> HsExpr GhcTc)
-> (HsExpr GhcTc -> XXExprGhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpansion (HsExpr GhcRn) (HsExpr GhcTc) -> XXExprGhcTc
ExpansionExpr (HsExpansion (HsExpr GhcRn) (HsExpr GhcTc) -> XXExprGhcTc)
-> (HsExpr GhcTc -> HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))
-> HsExpr GhcTc
-> XXExprGhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExpr GhcRn
-> HsExpr GhcTc -> HsExpansion (HsExpr GhcRn) (HsExpr GhcTc)
forall a b. a -> b -> HsExpansion a b
HsExpanded HsExpr GhcRn
a) (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
      SrcSpan -> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
generatedSrcSpan (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
b ExpRhoType
t)

{-
************************************************************************
*                                                                      *
                Catch-all
*                                                                      *
************************************************************************
-}

tcExpr HsExpr GhcRn
other ExpRhoType
_ = String -> SDoc -> TcM (HsExpr GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLExpr" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
other)
  -- Include ArrForm, ArrApp, which shouldn't appear at all
  -- Also HsTcBracketOut, HsQuasiQuoteE


{- *********************************************************************
*                                                                      *
             Pragmas on expressions
*                                                                      *
********************************************************************* -}

tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag (HsPragSCC XSCC GhcRn
x1 SourceText
src StringLiteral
ann) = XSCC GhcTc -> SourceText -> StringLiteral -> HsPragE GhcTc
forall p. XSCC p -> SourceText -> StringLiteral -> HsPragE p
HsPragSCC XSCC GhcRn
XSCC GhcTc
x1 SourceText
src StringLiteral
ann
tcExprPrag (HsPragTick XTickPragma GhcRn
x1 SourceText
src (StringLiteral, (ThLevel, ThLevel), (ThLevel, ThLevel))
info ((SourceText, SourceText), (SourceText, SourceText))
srcInfo) = XTickPragma GhcTc
-> SourceText
-> (StringLiteral, (ThLevel, ThLevel), (ThLevel, ThLevel))
-> ((SourceText, SourceText), (SourceText, SourceText))
-> HsPragE GhcTc
forall p.
XTickPragma p
-> SourceText
-> (StringLiteral, (ThLevel, ThLevel), (ThLevel, ThLevel))
-> ((SourceText, SourceText), (SourceText, SourceText))
-> HsPragE p
HsPragTick XTickPragma GhcRn
XTickPragma GhcTc
x1 SourceText
src (StringLiteral, (ThLevel, ThLevel), (ThLevel, ThLevel))
info ((SourceText, SourceText), (SourceText, SourceText))
srcInfo


{- *********************************************************************
*                                                                      *
             Expression with type signature e::ty
*                                                                      *
********************************************************************* -}

tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
              -> TcM (HsExpr GhcTc, TcSigmaType)
tcExprWithSig :: LHsExpr GhcRn
-> LHsSigWcType (NoGhcTc GhcRn) -> TcM (HsExpr GhcTc, TcType)
tcExprWithSig LHsExpr GhcRn
expr LHsSigWcType (NoGhcTc GhcRn)
hs_ty
  = do { TcIdSigInfo
sig_info <- TcM TcIdSigInfo -> TcM TcIdSigInfo
forall r. TcM r -> TcM r
checkNoErrs (TcM TcIdSigInfo -> TcM TcIdSigInfo)
-> TcM TcIdSigInfo -> TcM TcIdSigInfo
forall a b. (a -> b) -> a -> b
$  -- Avoid error cascade
                     SrcSpan -> LHsSigWcType GhcRn -> Maybe Name -> TcM TcIdSigInfo
tcUserTypeSig SrcSpan
loc LHsSigWcType GhcRn
LHsSigWcType (NoGhcTc GhcRn)
hs_ty Maybe Name
forall a. Maybe a
Nothing
       ; (LHsExpr GhcTc
expr', TcType
poly_ty) <- LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
tcExprSig LHsExpr GhcRn
expr TcIdSigInfo
sig_info
       ; (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExprWithTySig GhcTc
-> LHsExpr GhcTc -> LHsSigWcType (NoGhcTc GhcTc) -> HsExpr GhcTc
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
XExprWithTySig GhcTc
noExtField LHsExpr GhcTc
expr' LHsSigWcType (NoGhcTc GhcRn)
LHsSigWcType (NoGhcTc GhcTc)
hs_ty, TcType
poly_ty) }
  where
    loc :: SrcSpan
loc = GenLocated SrcSpan (HsType GhcRn) -> SrcSpan
forall l e. GenLocated l e -> l
getLoc (LHsSigWcType GhcRn -> GenLocated SrcSpan (HsType GhcRn)
forall pass. LHsSigWcType pass -> LHsType pass
hsSigWcType LHsSigWcType GhcRn
LHsSigWcType (NoGhcTc GhcRn)
hs_ty)

{-
************************************************************************
*                                                                      *
                Arithmetic sequences [a..b] etc
*                                                                      *
************************************************************************
-}

tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
           -> TcM (HsExpr GhcTc)

tcArithSeq :: Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(From LHsExpr GhcRn
expr) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
       ; LHsExpr GhcTc
expr' <-TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcType
elt_ty
       ; HsExpr GhcTc
enum_from <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromName [TcType
elt_ty]
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
         XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
enum_from Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> ArithSeqInfo id
From LHsExpr GhcTc
expr') }

tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThen LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
       ; LHsExpr GhcTc
expr1' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcType
elt_ty
       ; LHsExpr GhcTc
expr2' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcType
elt_ty
       ; HsExpr GhcTc
enum_from_then <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromThenName [TcType
elt_ty]
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
         XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
enum_from_then Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThen LHsExpr GhcTc
expr1' LHsExpr GhcTc
expr2') }

tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromTo LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
       ; LHsExpr GhcTc
expr1' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcType
elt_ty
       ; LHsExpr GhcTc
expr2' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcType
elt_ty
       ; HsExpr GhcTc
enum_from_to <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromToName [TcType
elt_ty]
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
         XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
enum_from_to Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id. LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromTo LHsExpr GhcTc
expr1' LHsExpr GhcTc
expr2') }

tcArithSeq Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThenTo LHsExpr GhcRn
expr1 LHsExpr GhcRn
expr2 LHsExpr GhcRn
expr3) ExpRhoType
res_ty
  = do { (HsWrapper
wrap, TcType
elt_mult, TcType
elt_ty, Maybe SyntaxExprTc
wit') <- Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
witness ExpRhoType
res_ty
        ; LHsExpr GhcTc
expr1' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr1 TcType
elt_ty
        ; LHsExpr GhcTc
expr2' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr2 TcType
elt_ty
        ; LHsExpr GhcTc
expr3' <- TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
elt_mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr3 TcType
elt_ty
        ; HsExpr GhcTc
eft <- CtOrigin -> Name -> [TcType] -> TcM (HsExpr GhcTc)
newMethodFromName (ArithSeqInfo GhcRn -> CtOrigin
ArithSeqOrigin ArithSeqInfo GhcRn
seq)
                              Name
enumFromThenToName [TcType
elt_ty]
        ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc -> TcM (HsExpr GhcTc))
-> HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (HsExpr GhcTc -> HsExpr GhcTc) -> HsExpr GhcTc -> HsExpr GhcTc
forall a b. (a -> b) -> a -> b
$
          XArithSeq GhcTc
-> Maybe (SyntaxExpr GhcTc) -> ArithSeqInfo GhcTc -> HsExpr GhcTc
forall p.
XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p
ArithSeq XArithSeq GhcTc
HsExpr GhcTc
eft Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
wit' (LHsExpr GhcTc
-> LHsExpr GhcTc -> LHsExpr GhcTc -> ArithSeqInfo GhcTc
forall id.
LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id
FromThenTo LHsExpr GhcTc
expr1' LHsExpr GhcTc
expr2' LHsExpr GhcTc
expr3') }

-----------------
arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
                -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType :: Maybe (SyntaxExpr GhcRn)
-> ExpRhoType
-> TcM (HsWrapper, TcType, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Maybe (SyntaxExpr GhcRn)
Nothing ExpRhoType
res_ty
  = do { TcType
res_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty
       ; (TcCoercionR
coi, TcType
elt_ty) <- TcType -> TcM (TcCoercionR, TcType)
matchExpectedListTy TcType
res_ty
       ; (HsWrapper, TcType, TcType, Maybe SyntaxExprTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (HsWrapper, TcType, TcType, Maybe SyntaxExprTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
coi, TcType
One, TcType
elt_ty, Maybe SyntaxExprTc
forall a. Maybe a
Nothing) }
arithSeqEltType (Just SyntaxExpr GhcRn
fl) ExpRhoType
res_ty
  = do { ((TcType
elt_mult, TcType
elt_ty), SyntaxExprTc
fl')
           <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> [TcType] -> TcM (TcType, TcType))
-> TcM ((TcType, TcType), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
ListOrigin SyntaxExpr GhcRn
SyntaxExprRn
fl [SyntaxOpType
SynList] ExpRhoType
res_ty (([TcType] -> [TcType] -> TcM (TcType, TcType))
 -> TcM ((TcType, TcType), SyntaxExprTc))
-> ([TcType] -> [TcType] -> TcM (TcType, TcType))
-> TcM ((TcType, TcType), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
              \ [TcType
elt_ty] [TcType
elt_mult] -> (TcType, TcType) -> TcM (TcType, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcType
elt_mult, TcType
elt_ty)
       ; (HsWrapper, TcType, TcType, Maybe SyntaxExprTc)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (HsWrapper, TcType, TcType, Maybe SyntaxExprTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, TcType
elt_mult, TcType
elt_ty, SyntaxExprTc -> Maybe SyntaxExprTc
forall a. a -> Maybe a
Just SyntaxExprTc
fl') }

{-
************************************************************************
*                                                                      *
                Applications
*                                                                      *
************************************************************************
-}

{- Note [Typechecking applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We typecheck application chains (f e1 @ty e2) specially:

* So we can report errors like "in the third arument of a call of f"

* So we can do Visible Type Application (VTA), for which we must not
  eagerly instantiate the function part of the application.

* So that we can do Quick Look impredicativity.

The idea is:

* Use collectHsArgs, which peels off
     HsApp, HsTypeApp, HsPrag, HsPar
  returning the function in the corner and the arguments

* Use tcInferAppHead to infer the type of the fuction,
    as an (uninstantiated) TcSigmaType
  There are special cases for
     HsVar, HsREcFld, and ExprWithTySig
  Otherwise, delegate back to tcExpr, which
    infers an (instantiated) TcRhoType

Some cases that /won't/ work:

1. Consider this (which uses visible type application):

    (let { f :: forall a. a -> a; f x = x } in f) @Int

   Since 'let' is not among the special cases for tcInferAppHead,
   we'll delegate back to tcExpr, which will instantiate f's type
   and the type application to @Int will fail.  Too bad!

-}

-- HsExprArg is a very local type, used only within this module.
-- It's really a zipper for an application chain
-- It's a GHC-specific type, so using TTG only where necessary
data HsExprArg id
  = HsEValArg  SrcSpan        -- Of the function
               (LHsExpr (GhcPass id))
  | HsETypeArg SrcSpan        -- Of the function
               (LHsWcType (NoGhcTc (GhcPass id)))
               !(XExprTypeArg id)
  | HsEPrag    SrcSpan
               (HsPragE (GhcPass id))
  | HsEPar     SrcSpan         -- Of the nested expr
  | HsEWrap    !(XArgWrap id)  -- Wrapper, after typechecking only

-- The outer location is the location of the application itself
type LHsExprArgIn  = HsExprArg 'Renamed
type LHsExprArgOut = HsExprArg 'Typechecked

instance OutputableBndrId id => Outputable (HsExprArg id) where
  ppr :: HsExprArg id -> SDoc
ppr (HsEValArg SrcSpan
_ LHsExpr (GhcPass id)
tm)       = LHsExpr (GhcPass id) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr (GhcPass id)
tm
  ppr (HsEPrag SrcSpan
_ HsPragE (GhcPass id)
p)          = String -> SDoc
text String
"HsPrag" SDoc -> SDoc -> SDoc
<+> HsPragE (GhcPass id) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsPragE (GhcPass id)
p
  ppr (HsETypeArg SrcSpan
_ LHsWcType (NoGhcTc (GhcPass id))
hs_ty XExprTypeArg id
_) = Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<> LHsWcType (GhcPass (NoGhcTcPass id)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsWcType (GhcPass (NoGhcTcPass id))
LHsWcType (NoGhcTc (GhcPass id))
hs_ty
  ppr (HsEPar SrcSpan
_)             = String -> SDoc
text String
"HsEPar"
  ppr (HsEWrap XArgWrap id
w)             = case forall (p :: Pass). IsPass p => GhcPass p
ghcPass @id of
                                    GhcPass id
GhcTc -> String -> SDoc
text String
"HsEWrap" SDoc -> SDoc -> SDoc
<+> HsWrapper -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsWrapper
XArgWrap id
w
                                    GhcPass id
_     -> SDoc
empty

type family XExprTypeArg id where
  XExprTypeArg 'Parsed      = NoExtField
  XExprTypeArg 'Renamed     = NoExtField
  XExprTypeArg 'Typechecked = Type

type family XArgWrap id where
  XArgWrap 'Parsed      = NoExtCon
  XArgWrap 'Renamed     = NoExtCon
  XArgWrap 'Typechecked = HsWrapper

addArgWrap :: HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut]
addArgWrap :: HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut]
addArgWrap HsWrapper
wrap [LHsExprArgOut]
args
 | HsWrapper -> Bool
isIdHsWrapper HsWrapper
wrap = [LHsExprArgOut]
args
 | Bool
otherwise          = XArgWrap 'Typechecked -> LHsExprArgOut
forall (id :: Pass). XArgWrap id -> HsExprArg id
HsEWrap HsWrapper
XArgWrap 'Typechecked
wrap LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args

collectHsArgs :: HsExpr GhcRn -> (HsExpr GhcRn, [LHsExprArgIn])
collectHsArgs :: HsExpr GhcRn -> (HsExpr GhcRn, [LHsExprArgIn])
collectHsArgs HsExpr GhcRn
e = HsExpr GhcRn -> [LHsExprArgIn] -> (HsExpr GhcRn, [LHsExprArgIn])
forall {id :: Pass}.
(XExprTypeArg id ~ NoExtField) =>
HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go HsExpr GhcRn
e []
  where
    go :: HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go (HsPar XPar (GhcPass id)
_     (L SrcSpan
l HsExpr (GhcPass id)
fun))       [HsExprArg id]
args = HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go HsExpr (GhcPass id)
fun (SrcSpan -> HsExprArg id
forall (id :: Pass). SrcSpan -> HsExprArg id
HsEPar SrcSpan
l HsExprArg id -> [HsExprArg id] -> [HsExprArg id]
forall a. a -> [a] -> [a]
: [HsExprArg id]
args)
    go (HsPragE XPragE (GhcPass id)
_ HsPragE (GhcPass id)
p (L SrcSpan
l HsExpr (GhcPass id)
fun))       [HsExprArg id]
args = HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go HsExpr (GhcPass id)
fun (SrcSpan -> HsPragE (GhcPass id) -> HsExprArg id
forall (id :: Pass).
SrcSpan -> HsPragE (GhcPass id) -> HsExprArg id
HsEPrag SrcSpan
l HsPragE (GhcPass id)
p HsExprArg id -> [HsExprArg id] -> [HsExprArg id]
forall a. a -> [a] -> [a]
: [HsExprArg id]
args)
    go (HsApp XApp (GhcPass id)
_     (L SrcSpan
l HsExpr (GhcPass id)
fun) GenLocated SrcSpan (HsExpr (GhcPass id))
arg)   [HsExprArg id]
args = HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go HsExpr (GhcPass id)
fun (SrcSpan -> GenLocated SrcSpan (HsExpr (GhcPass id)) -> HsExprArg id
forall (id :: Pass).
SrcSpan -> LHsExpr (GhcPass id) -> HsExprArg id
HsEValArg SrcSpan
l GenLocated SrcSpan (HsExpr (GhcPass id))
arg HsExprArg id -> [HsExprArg id] -> [HsExprArg id]
forall a. a -> [a] -> [a]
: [HsExprArg id]
args)
    go (HsAppType XAppTypeE (GhcPass id)
_ (L SrcSpan
l HsExpr (GhcPass id)
fun) LHsWcType (NoGhcTc (GhcPass id))
hs_ty) [HsExprArg id]
args = HsExpr (GhcPass id)
-> [HsExprArg id] -> (HsExpr (GhcPass id), [HsExprArg id])
go HsExpr (GhcPass id)
fun (SrcSpan
-> LHsWcType (NoGhcTc (GhcPass id))
-> XExprTypeArg id
-> HsExprArg id
forall (id :: Pass).
SrcSpan
-> LHsWcType (NoGhcTc (GhcPass id))
-> XExprTypeArg id
-> HsExprArg id
HsETypeArg SrcSpan
l LHsWcType (NoGhcTc (GhcPass id))
hs_ty NoExtField
XExprTypeArg id
noExtField HsExprArg id -> [HsExprArg id] -> [HsExprArg id]
forall a. a -> [a] -> [a]
: [HsExprArg id]
args)
    go HsExpr (GhcPass id)
e                             [HsExprArg id]
args = (HsExpr (GhcPass id)
e,[HsExprArg id]
args)

applyHsArgs :: HsExpr GhcTc -> [LHsExprArgOut]-> HsExpr GhcTc
applyHsArgs :: HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
applyHsArgs HsExpr GhcTc
fun [LHsExprArgOut]
args
  = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go HsExpr GhcTc
fun [LHsExprArgOut]
args
  where
    go :: HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go HsExpr GhcTc
fun [] = HsExpr GhcTc
fun
    go HsExpr GhcTc
fun (HsEWrap XArgWrap 'Typechecked
wrap : [LHsExprArgOut]
args)          = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
XArgWrap 'Typechecked
wrap HsExpr GhcTc
fun) [LHsExprArgOut]
args
    go HsExpr GhcTc
fun (HsEValArg SrcSpan
l LHsExpr GhcTc
arg : [LHsExprArgOut]
args)       = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go (XApp GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp NoExtField
XApp GhcTc
noExtField (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcTc
fun) LHsExpr GhcTc
arg) [LHsExprArgOut]
args
    go HsExpr GhcTc
fun (HsETypeArg SrcSpan
l LHsWcType (NoGhcTc GhcTc)
hs_ty XExprTypeArg 'Typechecked
ty : [LHsExprArgOut]
args) = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go (XAppTypeE GhcTc
-> LHsExpr GhcTc -> LHsWcType (NoGhcTc GhcTc) -> HsExpr GhcTc
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcTc
XExprTypeArg 'Typechecked
ty (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcTc
fun) LHsWcType (NoGhcTc GhcTc)
hs_ty) [LHsExprArgOut]
args
    go HsExpr GhcTc
fun (HsEPar SrcSpan
l : [LHsExprArgOut]
args)              = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go (XPar GhcTc -> LHsExpr GhcTc -> HsExpr GhcTc
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcTc
noExtField (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcTc
fun)) [LHsExprArgOut]
args
    go HsExpr GhcTc
fun (HsEPrag SrcSpan
l HsPragE GhcTc
p : [LHsExprArgOut]
args)           = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
go (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
p (SrcSpan -> HsExpr GhcTc -> LHsExpr GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsExpr GhcTc
fun)) [LHsExprArgOut]
args

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

isArgPar :: HsExprArg id -> Bool
isArgPar :: forall (id :: Pass). HsExprArg id -> Bool
isArgPar (HsEPar {}) = Bool
True
isArgPar HsExprArg id
_           = Bool
False

getFunLoc :: [HsExprArg 'Renamed] -> Maybe SrcSpan
getFunLoc :: [LHsExprArgIn] -> Maybe SrcSpan
getFunLoc []    = Maybe SrcSpan
forall a. Maybe a
Nothing
getFunLoc (LHsExprArgIn
a:[LHsExprArgIn]
_) = SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (SrcSpan -> Maybe SrcSpan) -> SrcSpan -> Maybe SrcSpan
forall a b. (a -> b) -> a -> b
$ case LHsExprArgIn
a of
                           HsEValArg SrcSpan
l LHsExpr GhcRn
_    -> SrcSpan
l
                           HsETypeArg SrcSpan
l LHsWcType (NoGhcTc GhcRn)
_ XExprTypeArg 'Renamed
_ -> SrcSpan
l
                           HsEPrag SrcSpan
l HsPragE GhcRn
_      -> SrcSpan
l
                           HsEPar SrcSpan
l         -> SrcSpan
l

---------------------------
tcApp :: HsExpr GhcRn  -- either HsApp or HsAppType
       -> ExpRhoType -> TcM (HsExpr GhcTc)
-- See Note [Typechecking applications]
tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr GhcRn
expr ExpRhoType
res_ty
  = do { (HsExpr GhcTc
fun, [LHsExprArgOut]
args, TcType
app_res_ty) <- HsExpr GhcRn -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcType)
tcInferApp HsExpr GhcRn
expr
       ; if HsExpr GhcTc -> Bool
isTagToEnum HsExpr GhcTc
fun
         then HsExpr GhcRn
-> HsExpr GhcTc
-> [LHsExprArgOut]
-> TcType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcTagToEnum HsExpr GhcRn
expr HsExpr GhcTc
fun [LHsExprArgOut]
args TcType
app_res_ty ExpRhoType
res_ty
              -- Done here because we have res_ty,
              -- whereas tcInferApp does not
         else

    -- The wildly common case
    do { let expr' :: HsExpr GhcTc
expr' = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
applyHsArgs HsExpr GhcTc
fun [LHsExprArgOut]
args
       ; Bool
-> HsExpr GhcTc
-> TcType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
-> TcM (HsExpr GhcTc)
forall a.
Bool -> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM a -> TcM a
addFunResCtxt Bool
True HsExpr GhcTc
fun TcType
app_res_ty ExpRhoType
res_ty (TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc))
-> TcM (HsExpr GhcTc) -> TcM (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
         HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
app_res_ty ExpRhoType
res_ty } }

---------------------------
tcInferApp :: HsExpr GhcRn
           -> TcM ( HsExpr GhcTc    -- Function
                  , [LHsExprArgOut]  -- Arguments
                  , TcSigmaType)     -- Inferred type: a sigma-type!
-- Also used by Module.tcRnExpr to implement GHCi :type
tcInferApp :: HsExpr GhcRn -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcType)
tcInferApp HsExpr GhcRn
expr
  | -- Gruesome special case for ambiguous record selectors
    HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
fld_lbl        <- HsExpr GhcRn
fun
  , Ambiguous XAmbiguous GhcRn
_ Located RdrName
lbl           <- AmbiguousFieldOcc GhcRn
fld_lbl  -- Still ambiguous
  , HsEValArg SrcSpan
_ (L SrcSpan
_ HsExpr GhcRn
arg) : [LHsExprArgIn]
_ <- (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. (a -> Bool) -> [a] -> [a]
filterOut LHsExprArgIn -> Bool
forall (id :: Pass). HsExprArg id -> Bool
isArgPar [LHsExprArgIn]
args -- A value arg is first
  , Just LHsSigWcType GhcRn
sig_ty               <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig HsExpr GhcRn
arg  -- A type sig on the arg disambiguates
  = do { TcType
sig_tc_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM TcType
tcHsSigWcType UserTypeCtxt
ExprSigCtxt LHsSigWcType GhcRn
sig_ty
       ; Name
sel_name  <- Located RdrName -> TcType -> TcM Name
disambiguateSelector Located RdrName
lbl TcType
sig_tc_ty
       ; (HsExpr GhcTc
tc_fun, TcType
fun_ty) <- AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcType)
tcInferRecSelId (XUnambiguous GhcRn -> Located RdrName -> AmbiguousFieldOcc GhcRn
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous Name
XUnambiguous GhcRn
sel_name Located RdrName
lbl)
       ; HsExpr GhcRn
-> HsExpr GhcTc
-> TcType
-> [LHsExprArgIn]
-> TcM (HsExpr GhcTc, [LHsExprArgOut], TcType)
tcInferApp_finish HsExpr GhcRn
fun HsExpr GhcTc
tc_fun TcType
fun_ty [LHsExprArgIn]
args }

  | Bool
otherwise  -- The wildly common case
  = do { (HsExpr GhcTc
tc_fun, TcType
fun_ty) <- TcM (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
set_fun_loc (HsExpr GhcRn -> TcM (HsExpr GhcTc, TcType)
tcInferAppHead HsExpr GhcRn
fun)
       ; HsExpr GhcRn
-> HsExpr GhcTc
-> TcType
-> [LHsExprArgIn]
-> TcM (HsExpr GhcTc, [LHsExprArgOut], TcType)
tcInferApp_finish HsExpr GhcRn
fun HsExpr GhcTc
tc_fun TcType
fun_ty [LHsExprArgIn]
args }
  where
    (HsExpr GhcRn
fun, [LHsExprArgIn]
args) = HsExpr GhcRn -> (HsExpr GhcRn, [LHsExprArgIn])
collectHsArgs HsExpr GhcRn
expr
    set_fun_loc :: TcM (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
set_fun_loc TcM (HsExpr GhcTc, TcType)
thing_inside
      = case [LHsExprArgIn] -> Maybe SrcSpan
getFunLoc [LHsExprArgIn]
args of
          Maybe SrcSpan
Nothing  -> TcM (HsExpr GhcTc, TcType)
thing_inside  -- Don't set the location twice
          Just SrcSpan
loc -> SrcSpan -> TcM (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc TcM (HsExpr GhcTc, TcType)
thing_inside

tcInferApp_finish
    :: HsExpr GhcRn                 -- Renamed function
    -> HsExpr GhcTc -> TcSigmaType  -- Function and its type
    -> [LHsExprArgIn]               -- Arguments
    -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)
tcInferApp_finish :: HsExpr GhcRn
-> HsExpr GhcTc
-> TcType
-> [LHsExprArgIn]
-> TcM (HsExpr GhcTc, [LHsExprArgOut], TcType)
tcInferApp_finish HsExpr GhcRn
rn_fun HsExpr GhcTc
tc_fun TcType
fun_sigma [LHsExprArgIn]
rn_args
  = do { ([LHsExprArgOut]
tc_args, TcType
actual_res_ty) <- HsExpr GhcRn
-> TcType -> [LHsExprArgIn] -> TcM ([LHsExprArgOut], TcType)
tcArgs HsExpr GhcRn
rn_fun TcType
fun_sigma [LHsExprArgIn]
rn_args
       ; (HsExpr GhcTc, [LHsExprArgOut], TcType)
-> TcM (HsExpr GhcTc, [LHsExprArgOut], TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
tc_fun, [LHsExprArgOut]
tc_args, TcType
actual_res_ty) }

mk_op_msg :: LHsExpr GhcRn -> SDoc
mk_op_msg :: LHsExpr GhcRn -> SDoc
mk_op_msg LHsExpr GhcRn
op = String -> SDoc
text String
"The operator" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
op) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"takes"

----------------
tcInferAppHead :: HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
-- Infer type of the head of an application, returning a /SigmaType/
--   i.e. the 'f' in (f e1 ... en)
-- We get back a SigmaType because we have special cases for
--   * A bare identifier (just look it up)
--     This case also covers a record selectro HsRecFld
--   * An expression with a type signature (e :: ty)
--
-- 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 collectHsArgs.
--
-- See Note [Typechecking applications]
tcInferAppHead :: HsExpr GhcRn -> TcM (HsExpr GhcTc, TcType)
tcInferAppHead HsExpr GhcRn
e
  = case HsExpr GhcRn
e of
      HsVar XVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
nm)        -> Name -> TcM (HsExpr GhcTc, TcType)
tcInferId Name
IdP GhcRn
nm
      HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
f            -> AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcType)
tcInferRecSelId AmbiguousFieldOcc GhcRn
f
      ExprWithTySig XExprWithTySig GhcRn
_ LHsExpr GhcRn
e LHsSigWcType (NoGhcTc GhcRn)
hs_ty -> TcM (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
add_ctxt (TcM (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType))
-> TcM (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn
-> LHsSigWcType (NoGhcTc GhcRn) -> TcM (HsExpr GhcTc, TcType)
tcExprWithSig LHsExpr GhcRn
e LHsSigWcType (NoGhcTc GhcRn)
hs_ty
      HsExpr GhcRn
_                       -> TcM (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
add_ctxt (TcM (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType))
-> TcM (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
forall a b. (a -> b) -> a -> b
$ (ExpRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc, TcType)
forall a. (ExpRhoType -> TcM a) -> TcM (a, TcType)
tcInfer (HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr HsExpr GhcRn
e)
  where
    add_ctxt :: TcM (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
add_ctxt TcM (HsExpr GhcTc, TcType)
thing = SDoc -> TcM (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr GhcRn -> SDoc
exprCtxt HsExpr GhcRn
e) TcM (HsExpr GhcTc, TcType)
thing

----------------
-- | Type-check the arguments to a function, possibly including visible type
-- applications
tcArgs :: HsExpr GhcRn   -- ^ The function itself (for err msgs only)
       -> TcSigmaType    -- ^ the (uninstantiated) type of the function
       -> [LHsExprArgIn] -- ^ the args
       -> TcM ([LHsExprArgOut], TcSigmaType)
          -- ^ (a wrapper for the function, the tc'd args, result type)
tcArgs :: HsExpr GhcRn
-> TcType -> [LHsExprArgIn] -> TcM ([LHsExprArgOut], TcType)
tcArgs HsExpr GhcRn
fun TcType
orig_fun_ty [LHsExprArgIn]
orig_args
  = ThLevel
-> [Scaled TcType]
-> TcType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcType)
go ThLevel
1 [] TcType
orig_fun_ty [LHsExprArgIn]
orig_args
  where
    fun_orig :: CtOrigin
fun_orig = HsExpr GhcRn -> CtOrigin
exprCtOrigin HsExpr GhcRn
fun
    herald :: SDoc
herald = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun)
                 , String -> SDoc
text String
"is applied to"]

    -- Count value args only when complaining about a function
    -- applied to too many value args
    -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify.
    n_val_args :: ThLevel
n_val_args = (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> ThLevel
forall a. (a -> Bool) -> [a] -> ThLevel
count LHsExprArgIn -> Bool
forall (id :: Pass). HsExprArg id -> Bool
isHsValArg [LHsExprArgIn]
orig_args

    fun_is_out_of_scope :: Bool
fun_is_out_of_scope  -- See Note [VTA for out-of-scope functions]
      = case HsExpr GhcRn
fun of
          HsUnboundVar {} -> Bool
True
          HsExpr GhcRn
_               -> Bool
False

    go :: Int           -- Which argment number this is (incl type args)
       -> [Scaled TcSigmaType] -- Value args to which applied so far
       -> TcSigmaType
       -> [LHsExprArgIn] -> TcM ([LHsExprArgOut], TcSigmaType)
    go :: ThLevel
-> [Scaled TcType]
-> TcType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcType)
go ThLevel
_ [Scaled TcType]
_ TcType
fun_ty [] = String -> SDoc -> TcRn ()
traceTc String
"tcArgs:ret" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_ty) TcRn ()
-> TcM ([LHsExprArgOut], TcType) -> TcM ([LHsExprArgOut], TcType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ([LHsExprArgOut], TcType) -> TcM ([LHsExprArgOut], TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], TcType
fun_ty)

    go ThLevel
n [Scaled TcType]
so_far TcType
fun_ty (HsEPar SrcSpan
sp : [LHsExprArgIn]
args)
      = do { ([LHsExprArgOut]
args', TcType
res_ty) <- ThLevel
-> [Scaled TcType]
-> TcType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcType)
go ThLevel
n [Scaled TcType]
so_far TcType
fun_ty [LHsExprArgIn]
args
           ; ([LHsExprArgOut], TcType) -> TcM ([LHsExprArgOut], TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> LHsExprArgOut
forall (id :: Pass). SrcSpan -> HsExprArg id
HsEPar SrcSpan
sp LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args', TcType
res_ty) }

    go ThLevel
n [Scaled TcType]
so_far TcType
fun_ty (HsEPrag SrcSpan
sp HsPragE GhcRn
prag : [LHsExprArgIn]
args)
      = do { ([LHsExprArgOut]
args', TcType
res_ty) <- ThLevel
-> [Scaled TcType]
-> TcType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcType)
go ThLevel
n [Scaled TcType]
so_far TcType
fun_ty [LHsExprArgIn]
args
           ; ([LHsExprArgOut], TcType) -> TcM ([LHsExprArgOut], TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsPragE GhcTc -> LHsExprArgOut
forall (id :: Pass).
SrcSpan -> HsPragE (GhcPass id) -> HsExprArg id
HsEPrag SrcSpan
sp (HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag HsPragE GhcRn
prag) LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args', TcType
res_ty) }

    go ThLevel
n [Scaled TcType]
so_far TcType
fun_ty (HsETypeArg SrcSpan
loc LHsWcType (NoGhcTc GhcRn)
hs_ty_arg XExprTypeArg 'Renamed
_ : [LHsExprArgIn]
args)
      | Bool
fun_is_out_of_scope   -- See Note [VTA for out-of-scope functions]
      = ThLevel
-> [Scaled TcType]
-> TcType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcType)
go (ThLevel
nThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ThLevel
1) [Scaled TcType]
so_far TcType
fun_ty [LHsExprArgIn]
args

      | Bool
otherwise
      = do { (HsWrapper
wrap1, TcType
upsilon_ty) <- CtOrigin -> TcType -> TcM (HsWrapper, TcType)
topInstantiateInferred CtOrigin
fun_orig TcType
fun_ty
               -- wrap1 :: fun_ty "->" upsilon_ty
           ; case TcType -> Maybe (TyVarBinder, TcType)
tcSplitForAllTy_maybe TcType
upsilon_ty of
               Just (TyVarBinder
tvb, TcType
inner_ty)
                 | TyVarBinder -> ArgFlag
forall tv argf. VarBndr tv argf -> argf
binderArgFlag TyVarBinder
tvb ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ArgFlag
Specified ->
                   -- It really can't be Inferred, because we've justn
                   -- instantiated those. But, oddly, it might just be Required.
                   -- See Note [Required quantifiers in the type of a term]
                 do { let tv :: Var
tv   = TyVarBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar TyVarBinder
tvb
                          kind :: TcType
kind = Var -> TcType
tyVarKind Var
tv
                    ; TcType
ty_arg <- LHsWcType GhcRn -> TcType -> TcM TcType
tcHsTypeApp LHsWcType GhcRn
LHsWcType (NoGhcTc GhcRn)
hs_ty_arg TcType
kind

                    ; TcType
inner_ty <- TcType -> TcM TcType
zonkTcType TcType
inner_ty
                          -- See Note [Visible type application zonk]
                    ; let in_scope :: InScopeSet
in_scope  = VarSet -> InScopeSet
mkInScopeSet ([TcType] -> VarSet
tyCoVarsOfTypes [TcType
upsilon_ty, TcType
ty_arg])
                          insted_ty :: TcType
insted_ty = InScopeSet -> [Var] -> [TcType] -> TcType -> TcType
substTyWithInScope InScopeSet
in_scope [Var
tv] [TcType
ty_arg] TcType
inner_ty
                                      -- NB: tv and ty_arg have the same kind, so this
                                      --     substitution is kind-respecting
                    ; String -> SDoc -> TcRn ()
traceTc String
"VTA" ([SDoc] -> SDoc
vcat [Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tv, TcType -> SDoc
debugPprType TcType
kind
                                          , TcType -> SDoc
debugPprType TcType
ty_arg
                                          , TcType -> SDoc
debugPprType (HasDebugCallStack => TcType -> TcType
TcType -> TcType
tcTypeKind TcType
ty_arg)
                                          , TcType -> SDoc
debugPprType TcType
inner_ty
                                          , TcType -> SDoc
debugPprType TcType
insted_ty ])

                    ; ([LHsExprArgOut]
args', TcType
res_ty) <- ThLevel
-> [Scaled TcType]
-> TcType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcType)
go (ThLevel
nThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ThLevel
1) [Scaled TcType]
so_far TcType
insted_ty [LHsExprArgIn]
args
                    ; ([LHsExprArgOut], TcType) -> TcM ([LHsExprArgOut], TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut]
addArgWrap HsWrapper
wrap1 ([LHsExprArgOut] -> [LHsExprArgOut])
-> [LHsExprArgOut] -> [LHsExprArgOut]
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> LHsWcType (NoGhcTc GhcTc)
-> XExprTypeArg 'Typechecked
-> LHsExprArgOut
forall (id :: Pass).
SrcSpan
-> LHsWcType (NoGhcTc (GhcPass id))
-> XExprTypeArg id
-> HsExprArg id
HsETypeArg SrcSpan
loc LHsWcType (NoGhcTc GhcRn)
LHsWcType (NoGhcTc GhcTc)
hs_ty_arg TcType
XExprTypeArg 'Typechecked
ty_arg LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args'
                             , TcType
res_ty ) }
               Maybe (TyVarBinder, TcType)
_ -> TcType -> LHsWcType GhcRn -> TcM ([LHsExprArgOut], TcType)
forall {a} {b}.
Outputable a =>
TcType -> a -> IOEnv (Env TcGblEnv TcLclEnv) b
ty_app_err TcType
upsilon_ty LHsWcType GhcRn
LHsWcType (NoGhcTc GhcRn)
hs_ty_arg }

    go ThLevel
n [Scaled TcType]
so_far TcType
fun_ty (HsEValArg SrcSpan
loc LHsExpr GhcRn
arg : [LHsExprArgIn]
args)
      = do { (HsWrapper
wrap, Scaled TcType
arg_ty, TcType
res_ty)
               <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> (ThLevel, [Scaled TcType])
-> TcType
-> TcM (HsWrapper, Scaled TcType, TcType)
matchActualFunTySigma SDoc
herald CtOrigin
fun_orig (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
fun)
                                        (ThLevel
n_val_args, [Scaled TcType]
so_far) TcType
fun_ty
           ; LHsExpr GhcTc
arg' <- HsExpr GhcRn
-> LHsExpr GhcRn -> Scaled TcType -> ThLevel -> TcM (LHsExpr GhcTc)
tcArg HsExpr GhcRn
fun LHsExpr GhcRn
arg Scaled TcType
arg_ty ThLevel
n
           ; ([LHsExprArgOut]
args', TcType
inner_res_ty) <- ThLevel
-> [Scaled TcType]
-> TcType
-> [LHsExprArgIn]
-> TcM ([LHsExprArgOut], TcType)
go (ThLevel
nThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ThLevel
1) (Scaled TcType
arg_tyScaled TcType -> [Scaled TcType] -> [Scaled TcType]
forall a. a -> [a] -> [a]
:[Scaled TcType]
so_far) TcType
res_ty [LHsExprArgIn]
args
           ; ([LHsExprArgOut], TcType) -> TcM ([LHsExprArgOut], TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut]
addArgWrap HsWrapper
wrap ([LHsExprArgOut] -> [LHsExprArgOut])
-> [LHsExprArgOut] -> [LHsExprArgOut]
forall a b. (a -> b) -> a -> b
$ SrcSpan -> LHsExpr GhcTc -> LHsExprArgOut
forall (id :: Pass).
SrcSpan -> LHsExpr (GhcPass id) -> HsExprArg id
HsEValArg SrcSpan
loc LHsExpr GhcTc
arg' LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args'
                    , TcType
inner_res_ty ) }

    ty_app_err :: TcType -> a -> IOEnv (Env TcGblEnv TcLclEnv) b
ty_app_err TcType
ty a
arg
      = do { (TidyEnv
_, TcType
ty) <- TidyEnv -> TcType -> TcM (TidyEnv, TcType)
zonkTidyTcType TidyEnv
emptyTidyEnv TcType
ty
           ; SDoc -> IOEnv (Env TcGblEnv TcLclEnv) b
forall a. SDoc -> TcRn a
failWith (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) b
forall a b. (a -> b) -> a -> b
$
               String -> SDoc
text String
"Cannot apply expression of type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty) SDoc -> SDoc -> SDoc
$$
               String -> SDoc
text String
"to a visible type argument" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
arg) }

{- Note [Required quantifiers in the type of a term]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (#15859)

  data A k :: k -> Type      -- A      :: forall k -> k -> Type
  type KindOf (a :: k) = k   -- KindOf :: forall k. k -> Type
  a = (undefind :: KindOf A) @Int

With ImpredicativeTypes (thin ice, I know), we instantiate
KindOf at type (forall k -> k -> Type), so
  KindOf A = forall k -> k -> Type
whose first argument is Required

We want to reject this type application to Int, but in earlier
GHCs we had an ASSERT that Required could not occur here.

The ice is thin; c.f. Note [No Required TyCoBinder in terms]
in GHC.Core.TyCo.Rep.

Note [VTA for out-of-scope functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose 'wurble' is not in scope, and we have
   (wurble @Int @Bool True 'x')

Then the renamer will make (HsUnboundVar "wurble) for 'wurble',
and the typechecker will typecheck it with tcUnboundId, giving it
a type 'alpha', and emitting a deferred Hole, to be reported later.

But then comes the visible type application. If we do nothing, we'll
generate an immediate failure (in tc_app_err), saying that a function
of type 'alpha' can't be applied to Bool.  That's insane!  And indeed
users complain bitterly (#13834, #17150.)

The right error is the Hole, which has /already/ been emitted by
tcUnboundId.  It later reports 'wurble' as out of scope, and tries to
give its type.

Fortunately in tcArgs we still have access to the function, so we can
check if it is a HsUnboundVar.  We use this info to simply skip over
any visible type arguments.  We've already inferred the type of the
function, so we'll /already/ have emitted a Hole;
failing preserves that constraint.

We do /not/ want to fail altogether in this case (via failM) becuase
that may abandon an entire instance decl, which (in the presence of
-fdefer-type-errors) leads to leading to #17792.

Downside; the typechecked term has lost its visible type arguments; we
don't even kind-check them.  But let's jump that bridge if we come to
it.  Meanwhile, let's not crash!

Note [Visible type application zonk]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg).

* tcHsTypeApp only guarantees that
    - ty_arg is zonked
    - kind(zonk(tv)) = kind(ty_arg)
  (checkExpectedKind zonks as it goes).

So we must zonk inner_ty as well, to guarantee consistency between zonk(tv)
and inner_ty.  Otherwise we can build an ill-kinded type.  An example was
#14158, where we had:
   id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a
and we had the visible type application
  id @(->)

* We instantiated k := kappa, yielding
    forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a
* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *).
* That instantiated (->) as ((->) q1 q1), and unified kappa := q1,
  Here q1 :: RuntimeRep
* Now we substitute
     cat  :->  (->) q1 q1 :: TYPE q1 -> TYPE q1 -> *
  but we must first zonk the inner_ty to get
      forall (a :: TYPE q1). cat a a
  so that the result of substitution is well-kinded
  Failing to do so led to #14158.
-}

----------------
tcArg :: HsExpr GhcRn                   -- The function (for error messages)
      -> LHsExpr GhcRn                   -- Actual arguments
      -> Scaled TcSigmaType              -- expected arg type
      -> Int                             -- # of argument
      -> TcM (LHsExpr GhcTc)           -- Resulting argument
tcArg :: HsExpr GhcRn
-> LHsExpr GhcRn -> Scaled TcType -> ThLevel -> TcM (LHsExpr GhcTc)
tcArg HsExpr GhcRn
fun LHsExpr GhcRn
arg (Scaled TcType
mult TcType
ty) ThLevel
arg_no
   = SDoc -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr GhcRn -> LHsExpr GhcRn -> ThLevel -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> ThLevel -> SDoc
funAppCtxt HsExpr GhcRn
fun LHsExpr GhcRn
arg ThLevel
arg_no) (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$
     do { String -> SDoc -> TcRn ()
traceTc String
"tcArg" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
          [SDoc] -> SDoc
vcat [ ThLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr ThLevel
arg_no SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"of" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun
               , String -> SDoc
text String
"arg type:" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty
               , String -> SDoc
text String
"arg:" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
arg ]
        ; TcType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a. TcType -> TcM a -> TcM a
tcScalingUsage TcType
mult (TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc))
-> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
arg TcType
ty }

----------------
tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc]
tcTupArgs :: [LHsTupArg GhcRn] -> [TcType] -> TcM [LHsTupArg GhcTc]
tcTupArgs [LHsTupArg GhcRn]
args [TcType]
tys
  = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
  where
    go :: (GenLocated l (HsTupArg GhcRn), TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTc))
go (L l
l (Missing {}),   TcType
arg_ty) = do { TcType
mult <- TcType -> TcM TcType
newFlexiTyVarTy TcType
multiplicityTy
                                         ; GenLocated l (HsTupArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> HsTupArg GhcTc -> GenLocated l (HsTupArg GhcTc)
forall l e. l -> e -> GenLocated l e
L l
l (XMissing GhcTc -> HsTupArg GhcTc
forall id. XMissing id -> HsTupArg id
Missing (TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
Scaled TcType
mult TcType
arg_ty))) }
    go (L l
l (Present XPresent GhcRn
x LHsExpr GhcRn
expr), TcType
arg_ty) = do { LHsExpr GhcTc
expr' <- LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr LHsExpr GhcRn
expr TcType
arg_ty
                                           ; GenLocated l (HsTupArg GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> HsTupArg GhcTc -> GenLocated l (HsTupArg GhcTc)
forall l e. l -> e -> GenLocated l e
L l
l (XPresent GhcTc -> LHsExpr GhcTc -> HsTupArg GhcTc
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
XPresent GhcTc
x LHsExpr GhcTc
expr')) }

---------------------------
-- See TcType.SyntaxOpType also for commentary
tcSyntaxOp :: CtOrigin
           -> SyntaxExprRn
           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
           -> ExpRhoType               -- ^ overall result type
           -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments,
                                                 -- takes a type per hole and a
                                                 -- multiplicity per arrow in
                                                 -- the shape.
           -> TcM (a, SyntaxExprTc)
-- ^ Typecheck a syntax operator
-- The operator is a variable or a lambda at this stage (i.e. renamer
-- output)
tcSyntaxOp :: forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys ExpRhoType
res_ty
  = CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig SyntaxExprRn
expr [SyntaxOpType]
arg_tys (ExpRhoType -> SyntaxOpType
SynType ExpRhoType
res_ty)

-- | Slightly more general version of 'tcSyntaxOp' that allows the caller
-- to specify the shape of the result of the syntax operator
tcSyntaxOpGen :: CtOrigin
              -> SyntaxExprRn
              -> [SyntaxOpType]
              -> SyntaxOpType
              -> ([TcSigmaType] -> [Mult] -> TcM a)
              -> TcM (a, SyntaxExprTc)
tcSyntaxOpGen :: forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen CtOrigin
orig (SyntaxExprRn HsExpr GhcRn
op) [SyntaxOpType]
arg_tys SyntaxOpType
res_ty [TcType] -> [TcType] -> TcM a
thing_inside
  = do { (HsExpr GhcTc
expr, TcType
sigma) <- HsExpr GhcRn -> TcM (HsExpr GhcTc, TcType)
tcInferAppHead HsExpr GhcRn
op
       ; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op SDoc -> SDoc -> SDoc
$$ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
sigma)
       ; (a
result, HsWrapper
expr_wrap, [HsWrapper]
arg_wraps, HsWrapper
res_wrap)
           <- CtOrigin
-> TcType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a.
CtOrigin
-> TcType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcType
sigma [SyntaxOpType]
arg_tys SyntaxOpType
res_ty (([TcType] -> [TcType] -> TcM a)
 -> TcM (a, HsWrapper, [HsWrapper], HsWrapper))
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a b. (a -> b) -> a -> b
$
              [TcType] -> [TcType] -> TcM a
thing_inside
       ; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
op SDoc -> SDoc -> SDoc
$$ HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr SDoc -> SDoc -> SDoc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
sigma )
       ; (a, SyntaxExprTc) -> TcM (a, SyntaxExprTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, SyntaxExprTc :: HsExpr GhcTc -> [HsWrapper] -> HsWrapper -> SyntaxExprTc
SyntaxExprTc { syn_expr :: HsExpr GhcTc
syn_expr = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
expr_wrap HsExpr GhcTc
expr
                                      , syn_arg_wraps :: [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
                                      , syn_res_wrap :: HsWrapper
syn_res_wrap  = HsWrapper
res_wrap }) }
tcSyntaxOpGen CtOrigin
_ SyntaxExprRn
NoSyntaxExprRn [SyntaxOpType]
_ SyntaxOpType
_ [TcType] -> [TcType] -> TcM a
_ = String -> TcM (a, SyntaxExprTc)
forall a. String -> a
panic String
"tcSyntaxOpGen"

{-
Note [tcSynArg]
~~~~~~~~~~~~~~~
Because of the rich structure of SyntaxOpType, we must do the
contra-/covariant thing when working down arrows, to get the
instantiation vs. skolemisation decisions correct (and, more
obviously, the orientation of the HsWrappers). We thus have
two tcSynArgs.
-}

-- works on "expected" types, skolemising where necessary
-- See Note [tcSynArg]
tcSynArgE :: CtOrigin
          -> TcSigmaType
          -> SyntaxOpType                -- ^ shape it is expected to have
          -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments
          -> TcM (a, HsWrapper)
           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
tcSynArgE :: forall a.
CtOrigin
-> TcType
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig TcType
sigma_ty SyntaxOpType
syn_ty [TcType] -> [TcType] -> TcM a
thing_inside
  = do { (HsWrapper
skol_wrap, (a
result, HsWrapper
ty_wrapper))
           <- UserTypeCtxt
-> TcType
-> (TcType -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall result.
UserTypeCtxt
-> TcType -> (TcType -> TcM result) -> TcM (HsWrapper, result)
tcSkolemise UserTypeCtxt
GenSigCtxt TcType
sigma_ty ((TcType -> TcM (a, HsWrapper)) -> TcM (HsWrapper, (a, HsWrapper)))
-> (TcType -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall a b. (a -> b) -> a -> b
$ \ TcType
rho_ty ->
              TcType -> SyntaxOpType -> TcM (a, HsWrapper)
go TcType
rho_ty SyntaxOpType
syn_ty
       ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
skol_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
ty_wrapper) }
    where
    go :: TcType -> SyntaxOpType -> TcM (a, HsWrapper)
go TcType
rho_ty SyntaxOpType
SynAny
      = do { a
result <- [TcType] -> [TcType] -> TcM a
thing_inside [TcType
rho_ty] []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }

    go TcType
rho_ty SyntaxOpType
SynRho   -- same as SynAny, because we skolemise eagerly
      = do { a
result <- [TcType] -> [TcType] -> TcM a
thing_inside [TcType
rho_ty] []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }

    go TcType
rho_ty SyntaxOpType
SynList
      = do { (TcCoercionR
list_co, TcType
elt_ty) <- TcType -> TcM (TcCoercionR, TcType)
matchExpectedListTy TcType
rho_ty
           ; a
result <- [TcType] -> [TcType] -> TcM a
thing_inside [TcType
elt_ty] []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcCoercionR -> HsWrapper
mkWpCastN TcCoercionR
list_co) }

    go TcType
rho_ty (SynFun SyntaxOpType
arg_shape SyntaxOpType
res_shape)
      = do { ( HsWrapper
match_wrapper                         -- :: (arg_ty -> res_ty) "->" rho_ty
             , ( ( (a
result, TcType
arg_ty, TcType
res_ty, TcType
op_mult)
                 , HsWrapper
res_wrapper )                     -- :: res_ty_out "->" res_ty
               , HsWrapper
arg_wrapper1, [], HsWrapper
arg_wrapper2 ) )  -- :: arg_ty "->" arg_ty_out
               <- SDoc
-> UserTypeCtxt
-> ThLevel
-> ExpRhoType
-> ([Scaled ExpRhoType]
    -> ExpRhoType
    -> TcM
         (((a, TcType, TcType, TcType), HsWrapper), HsWrapper, [HsWrapper],
          HsWrapper))
-> TcM
     (HsWrapper,
      (((a, TcType, TcType, TcType), HsWrapper), HsWrapper, [HsWrapper],
       HsWrapper))
forall a.
SDoc
-> UserTypeCtxt
-> ThLevel
-> ExpRhoType
-> ([Scaled ExpRhoType] -> ExpRhoType -> TcM a)
-> TcM (HsWrapper, a)
matchExpectedFunTys SDoc
herald UserTypeCtxt
GenSigCtxt ThLevel
1 (TcType -> ExpRhoType
mkCheckExpType TcType
rho_ty) (([Scaled ExpRhoType]
  -> ExpRhoType
  -> TcM
       (((a, TcType, TcType, TcType), HsWrapper), HsWrapper, [HsWrapper],
        HsWrapper))
 -> TcM
      (HsWrapper,
       (((a, TcType, TcType, TcType), HsWrapper), HsWrapper, [HsWrapper],
        HsWrapper)))
-> ([Scaled ExpRhoType]
    -> ExpRhoType
    -> TcM
         (((a, TcType, TcType, TcType), HsWrapper), HsWrapper, [HsWrapper],
          HsWrapper))
-> TcM
     (HsWrapper,
      (((a, TcType, TcType, TcType), HsWrapper), HsWrapper, [HsWrapper],
       HsWrapper))
forall a b. (a -> b) -> a -> b
$
                  \ [Scaled ExpRhoType
arg_ty] ExpRhoType
res_ty ->
                  do { TcType
arg_tc_ty <- ExpRhoType -> TcM TcType
expTypeToType (Scaled ExpRhoType -> ExpRhoType
forall a. Scaled a -> a
scaledThing Scaled ExpRhoType
arg_ty)
                     ; TcType
res_tc_ty <- ExpRhoType -> TcM TcType
expTypeToType ExpRhoType
res_ty

                         -- another nested arrow is too much for now,
                         -- but I bet we'll never need this
                     ; MASSERT2( case arg_shape of
                                   SynFun {} -> False;
                                   _         -> True
                               , text "Too many nested arrows in SyntaxOpType" $$
                                 pprCtOrigin orig )

                     ; let arg_mult :: TcType
arg_mult = Scaled ExpRhoType -> TcType
forall a. Scaled a -> TcType
scaledMult Scaled ExpRhoType
arg_ty
                     ; CtOrigin
-> TcType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType]
    -> [TcType] -> TcM ((a, TcType, TcType, TcType), HsWrapper))
-> TcM
     (((a, TcType, TcType, TcType), HsWrapper), HsWrapper, [HsWrapper],
      HsWrapper)
forall a.
CtOrigin
-> TcType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcType
arg_tc_ty [] SyntaxOpType
arg_shape (([TcType]
  -> [TcType] -> TcM ((a, TcType, TcType, TcType), HsWrapper))
 -> TcM
      (((a, TcType, TcType, TcType), HsWrapper), HsWrapper, [HsWrapper],
       HsWrapper))
-> ([TcType]
    -> [TcType] -> TcM ((a, TcType, TcType, TcType), HsWrapper))
-> TcM
     (((a, TcType, TcType, TcType), HsWrapper), HsWrapper, [HsWrapper],
      HsWrapper)
forall a b. (a -> b) -> a -> b
$
                       \ [TcType]
arg_results [TcType]
arg_res_mults ->
                       CtOrigin
-> TcType
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM (a, TcType, TcType, TcType))
-> TcM ((a, TcType, TcType, TcType), HsWrapper)
forall a.
CtOrigin
-> TcType
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig TcType
res_tc_ty SyntaxOpType
res_shape (([TcType] -> [TcType] -> TcM (a, TcType, TcType, TcType))
 -> TcM ((a, TcType, TcType, TcType), HsWrapper))
-> ([TcType] -> [TcType] -> TcM (a, TcType, TcType, TcType))
-> TcM ((a, TcType, TcType, TcType), HsWrapper)
forall a b. (a -> b) -> a -> b
$
                       \ [TcType]
res_results [TcType]
res_res_mults ->
                       do { a
result <- [TcType] -> [TcType] -> TcM a
thing_inside ([TcType]
arg_results [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
res_results) ([TcType
arg_mult] [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
arg_res_mults [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
res_res_mults)
                          ; (a, TcType, TcType, TcType) -> TcM (a, TcType, TcType, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcType
arg_tc_ty, TcType
res_tc_ty, TcType
arg_mult) }}

           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return ( a
result
                    , HsWrapper
match_wrapper HsWrapper -> HsWrapper -> HsWrapper
<.>
                      HsWrapper
-> HsWrapper -> Scaled TcType -> TcType -> SDoc -> HsWrapper
mkWpFun (HsWrapper
arg_wrapper2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
arg_wrapper1) HsWrapper
res_wrapper
                              (TcType -> TcType -> Scaled TcType
forall a. TcType -> a -> Scaled a
Scaled TcType
op_mult TcType
arg_ty) TcType
res_ty SDoc
doc ) }
      where
        herald :: SDoc
herald = String -> SDoc
text String
"This rebindable syntax expects a function with"
        doc :: SDoc
doc = String -> SDoc
text String
"When checking a rebindable syntax operator arising from" SDoc -> SDoc -> SDoc
<+> CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig

    go TcType
rho_ty (SynType ExpRhoType
the_ty)
      = do { HsWrapper
wrap   <- CtOrigin -> UserTypeCtxt -> ExpRhoType -> TcType -> TcM HsWrapper
tcSubTypePat CtOrigin
orig UserTypeCtxt
GenSigCtxt ExpRhoType
the_ty TcType
rho_ty
           ; a
result <- [TcType] -> [TcType] -> TcM a
thing_inside [] []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrap) }

-- works on "actual" types, instantiating where necessary
-- See Note [tcSynArg]
tcSynArgA :: CtOrigin
          -> TcSigmaType
          -> [SyntaxOpType]              -- ^ argument shapes
          -> SyntaxOpType                -- ^ result shape
          -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments
          -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
            -- ^ returns a wrapper to be applied to the original function,
            -- wrappers to be applied to arguments
            -- and a wrapper to be applied to the overall expression
tcSynArgA :: forall a.
CtOrigin
-> TcType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcType
sigma_ty [SyntaxOpType]
arg_shapes SyntaxOpType
res_shape [TcType] -> [TcType] -> TcM a
thing_inside
  = do { (HsWrapper
match_wrapper, [Scaled TcType]
arg_tys, TcType
res_ty)
           <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> ThLevel
-> TcType
-> TcM (HsWrapper, [Scaled TcType], TcType)
matchActualFunTysRho SDoc
herald CtOrigin
orig Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing
                                   ([SyntaxOpType] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [SyntaxOpType]
arg_shapes) TcType
sigma_ty
              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
       ; ((a
result, HsWrapper
res_wrapper), [HsWrapper]
arg_wrappers)
           <- [TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a.
[TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e ((Scaled TcType -> TcType) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing [Scaled TcType]
arg_tys) [SyntaxOpType]
arg_shapes (([TcType] -> [TcType] -> TcM (a, HsWrapper))
 -> TcM ((a, HsWrapper), [HsWrapper]))
-> ([TcType] -> [TcType] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [TcType]
arg_results [TcType]
arg_res_mults ->
              TcType -> SyntaxOpType -> ([TcType] -> TcM a) -> TcM (a, HsWrapper)
forall a.
TcType -> SyntaxOpType -> ([TcType] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg    TcType
res_ty  SyntaxOpType
res_shape  (([TcType] -> TcM a) -> TcM (a, HsWrapper))
-> ([TcType] -> TcM a) -> TcM (a, HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [TcType]
res_results ->
              [TcType] -> [TcType] -> TcM a
thing_inside ([TcType]
arg_results [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
res_results) ((Scaled TcType -> TcType) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcType -> TcType
forall a. Scaled a -> TcType
scaledMult [Scaled TcType]
arg_tys [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
arg_res_mults)
       ; (a, HsWrapper, [HsWrapper], HsWrapper)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
match_wrapper, [HsWrapper]
arg_wrappers, HsWrapper
res_wrapper) }
  where
    herald :: SDoc
herald = String -> SDoc
text String
"This rebindable syntax expects a function with"

    tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
                  -> ([TcSigmaType] -> [Mult] -> TcM a)
                  -> TcM (a, [HsWrapper])
                    -- the wrappers are for arguments
    tc_syn_args_e :: forall a.
[TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (TcType
arg_ty : [TcType]
arg_tys) (SyntaxOpType
arg_shape : [SyntaxOpType]
arg_shapes) [TcType] -> [TcType] -> TcM a
thing_inside
      = do { ((a
result, [HsWrapper]
arg_wraps), HsWrapper
arg_wrap)
               <- CtOrigin
-> TcType
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a.
CtOrigin
-> TcType
-> SyntaxOpType
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE     CtOrigin
orig TcType
arg_ty  SyntaxOpType
arg_shape  (([TcType] -> [TcType] -> TcM (a, [HsWrapper]))
 -> TcM ((a, [HsWrapper]), HsWrapper))
-> ([TcType] -> [TcType] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [TcType]
arg1_results [TcType]
arg1_mults ->
                  [TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, [HsWrapper])
forall a.
[TcType]
-> [SyntaxOpType]
-> ([TcType] -> [TcType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e      [TcType]
arg_tys [SyntaxOpType]
arg_shapes (([TcType] -> [TcType] -> TcM a) -> TcM (a, [HsWrapper]))
-> ([TcType] -> [TcType] -> TcM a) -> TcM (a, [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [TcType]
args_results [TcType]
args_mults ->
                  [TcType] -> [TcType] -> TcM a
thing_inside ([TcType]
arg1_results [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
args_results) ([TcType]
arg1_mults [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
args_mults)
           ; (a, [HsWrapper]) -> TcM (a, [HsWrapper])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
arg_wrap HsWrapper -> [HsWrapper] -> [HsWrapper]
forall a. a -> [a] -> [a]
: [HsWrapper]
arg_wraps) }
    tc_syn_args_e [TcType]
_ [SyntaxOpType]
_ [TcType] -> [TcType] -> TcM a
thing_inside = (, []) (a -> (a, [HsWrapper])) -> TcM a -> TcM (a, [HsWrapper])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TcType] -> [TcType] -> TcM a
thing_inside [] []

    tc_syn_arg :: TcSigmaType -> SyntaxOpType
               -> ([TcSigmaType] -> TcM a)
               -> TcM (a, HsWrapper)
                  -- the wrapper applies to the overall result
    tc_syn_arg :: forall a.
TcType -> SyntaxOpType -> ([TcType] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg TcType
res_ty SyntaxOpType
SynAny [TcType] -> TcM a
thing_inside
      = do { a
result <- [TcType] -> TcM a
thing_inside [TcType
res_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
    tc_syn_arg TcType
res_ty SyntaxOpType
SynRho [TcType] -> TcM a
thing_inside
      = do { (HsWrapper
inst_wrap, TcType
rho_ty) <- CtOrigin -> TcType -> TcM (HsWrapper, TcType)
topInstantiate CtOrigin
orig TcType
res_ty
               -- inst_wrap :: res_ty "->" rho_ty
           ; a
result <- [TcType] -> TcM a
thing_inside [TcType
rho_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
inst_wrap) }
    tc_syn_arg TcType
res_ty SyntaxOpType
SynList [TcType] -> TcM a
thing_inside
      = do { (HsWrapper
inst_wrap, TcType
rho_ty) <- CtOrigin -> TcType -> TcM (HsWrapper, TcType)
topInstantiate CtOrigin
orig TcType
res_ty
               -- inst_wrap :: res_ty "->" rho_ty
           ; (TcCoercionR
list_co, TcType
elt_ty)   <- TcType -> TcM (TcCoercionR, TcType)
matchExpectedListTy TcType
rho_ty
               -- list_co :: [elt_ty] ~N rho_ty
           ; a
result <- [TcType] -> TcM a
thing_inside [TcType
elt_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, TcCoercionR -> HsWrapper
mkWpCastN (TcCoercionR -> TcCoercionR
mkTcSymCo TcCoercionR
list_co) HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inst_wrap) }
    tc_syn_arg TcType
_ (SynFun {}) [TcType] -> TcM a
_
      = String -> SDoc -> TcM (a, HsWrapper)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcSynArgA hits a SynFun" (CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig)
    tc_syn_arg TcType
res_ty (SynType ExpRhoType
the_ty) [TcType] -> TcM a
thing_inside
      = do { HsWrapper
wrap   <- CtOrigin -> UserTypeCtxt -> TcType -> ExpRhoType -> TcM HsWrapper
tcSubType CtOrigin
orig UserTypeCtxt
GenSigCtxt TcType
res_ty ExpRhoType
the_ty
           ; a
result <- [TcType] -> TcM a
thing_inside []
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrap) }

{-
Note [Push result type in]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Unify with expected result before type-checking the args so that the
info from res_ty percolates to args.  This is when we might detect a
too-few args situation.  (One can think of cases when the opposite
order would give a better error message.)
experimenting with putting this first.

Here's an example where it actually makes a real difference

   class C t a b | t a -> b
   instance C Char a Bool

   data P t a = forall b. (C t a b) => MkP b
   data Q t   = MkQ (forall a. P t a)

   f1, f2 :: Q Char;
   f1 = MkQ (MkP True)
   f2 = MkQ (MkP True :: forall a. P Char a)

With the change, f1 will type-check, because the 'Char' info from
the signature is propagated into MkQ's argument. With the check
in the other order, the extra signature in f2 is reqd.

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

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

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

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

       ; String -> SDoc -> TcRn ()
traceTc String
"tcExpSig" ([Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
qtvs SDoc -> SDoc -> SDoc
$$ [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
givens SDoc -> SDoc -> SDoc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
inferred_sigma SDoc -> SDoc -> SDoc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
my_sigma)
       ; let poly_wrap :: HsWrapper
poly_wrap = HsWrapper
wrap
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [Var] -> HsWrapper
mkWpTyLams [Var]
qtvs
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [Var] -> HsWrapper
mkWpLams [Var]
givens
                         HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet  TcEvBinds
ev_binds
       ; (LHsExpr GhcTc, TcType) -> TcM (LHsExpr GhcTc, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap HsWrapper
poly_wrap LHsExpr GhcTc
expr', TcType
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.
-}

{- *********************************************************************
*                                                                      *
                 tcInferId
*                                                                      *
********************************************************************* -}

tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckId Name
name ExpRhoType
res_ty
  | Name
name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
  = SDoc -> TcM (HsExpr GhcTc)
forall a. SDoc -> TcRn a
failWithTc (String -> SDoc
text String
"tagToEnum# must appear applied to one argument")
    -- tcApp catches the case (tagToEnum# arg)

  | Bool
otherwise
  = do { (HsExpr GhcTc
expr, TcType
actual_res_ty) <- Name -> TcM (HsExpr GhcTc, TcType)
tcInferId Name
name
       ; String -> SDoc -> TcRn ()
traceTc String
"tcCheckId" ([SDoc] -> SDoc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
actual_res_ty, ExpRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpRhoType
res_ty])
       ; Bool
-> HsExpr GhcTc
-> TcType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
-> TcM (HsExpr GhcTc)
forall a.
Bool -> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM a -> TcM a
addFunResCtxt Bool
False HsExpr GhcTc
expr TcType
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 GhcRn
-> HsExpr GhcTc
-> TcType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcWrapResultO (Name -> CtOrigin
OccurrenceOf Name
name) (XVar GhcRn -> GenLocated SrcSpan (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField (Name -> GenLocated SrcSpan Name
forall e. e -> Located e
noLoc Name
name)) HsExpr GhcTc
expr
                                           TcType
actual_res_ty ExpRhoType
res_ty }

tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckRecSelId :: HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckRecSelId HsExpr GhcRn
rn_expr f :: AmbiguousFieldOcc GhcRn
f@(Unambiguous {}) ExpRhoType
res_ty
  = do { (HsExpr GhcTc
expr, TcType
actual_res_ty) <- AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcType)
tcInferRecSelId AmbiguousFieldOcc GhcRn
f
       ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
rn_expr HsExpr GhcTc
expr TcType
actual_res_ty ExpRhoType
res_ty }
tcCheckRecSelId HsExpr GhcRn
rn_expr (Ambiguous XAmbiguous GhcRn
_ Located RdrName
lbl) ExpRhoType
res_ty
  = case TcType -> Maybe (Scaled TcType, TcType)
tcSplitFunTy_maybe (TcType -> Maybe (Scaled TcType, TcType))
-> Maybe TcType -> Maybe (Scaled TcType, TcType)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpRhoType -> Maybe TcType
checkingExpType_maybe ExpRhoType
res_ty of
      Maybe (Scaled TcType, TcType)
Nothing       -> Located RdrName -> TcM (HsExpr GhcTc)
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lbl
      Just (Scaled TcType
arg, TcType
_) -> do { Name
sel_name <- Located RdrName -> TcType -> TcM Name
disambiguateSelector Located RdrName
lbl (Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing Scaled TcType
arg)
                          ; HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcCheckRecSelId HsExpr GhcRn
rn_expr (XUnambiguous GhcRn -> Located RdrName -> AmbiguousFieldOcc GhcRn
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous Name
XUnambiguous GhcRn
sel_name Located RdrName
lbl)
                                                    ExpRhoType
res_ty }

------------------------
tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcRhoType)
tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcType)
tcInferRecSelId (Unambiguous XUnambiguous GhcRn
sel (L SrcSpan
_ RdrName
lbl))
  = do { (HsExpr GhcTc
expr', TcType
ty) <- RdrName -> Name -> TcM (HsExpr GhcTc, TcType)
tc_infer_id RdrName
lbl Name
XUnambiguous GhcRn
sel
       ; (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr', TcType
ty) }
tcInferRecSelId (Ambiguous XAmbiguous GhcRn
_ Located RdrName
lbl)
  = Located RdrName -> TcM (HsExpr GhcTc, TcType)
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lbl

------------------------
tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
-- Look up an occurrence of an Id
-- Do not instantiate its type
tcInferId :: Name -> TcM (HsExpr GhcTc, TcType)
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 RdrName -> Name -> TcM (HsExpr GhcTc, TcType)
tc_infer_id (Name -> RdrName
nameRdrName Name
id_name) Name
id_name
         else Name -> TcM (HsExpr GhcTc, TcType)
tc_infer_assert Name
id_name }

  | Bool
otherwise
  = do { (HsExpr GhcTc
expr, TcType
ty) <- RdrName -> Name -> TcM (HsExpr GhcTc, TcType)
tc_infer_id (Name -> RdrName
nameRdrName Name
id_name) Name
id_name
       ; String -> SDoc -> TcRn ()
traceTc String
"tcInferId" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
id_name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)
       ; (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTc
expr, TcType
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, TcType)
tc_infer_assert Name
assert_name
  = do { Var
assert_error_id <- Name -> TcM Var
tcLookupId Name
assertErrorName
       ; (HsWrapper
wrap, TcType
id_rho) <- CtOrigin -> TcType -> TcM (HsWrapper, TcType)
topInstantiate (Name -> CtOrigin
OccurrenceOf Name
assert_name)
                                          (Var -> TcType
idType Var
assert_error_id)
       ; (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (Var -> Located Var
forall e. e -> Located e
noLoc Var
assert_error_id)), TcType
id_rho)
       }

tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTc, TcSigmaType)
tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTc, TcType)
tc_infer_id RdrName
lbl Name
id_name
 = do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
id_name
      ; case TcTyThing
thing of
             ATcId { tct_id :: TcTyThing -> Var
tct_id = Var
id }
               -> do { Var -> TcRn ()
check_naughty Var
id        -- Note [Local record selectors]
                     ; Var -> TcRn ()
checkThLocalId Var
id
                     ; UsageEnv -> TcRn ()
tcEmitBindingUsage (UsageEnv -> TcRn ()) -> UsageEnv -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> TcType -> UsageEnv
forall n. NamedThing n => n -> TcType -> UsageEnv
unitUE Name
id_name TcType
One
                     ; Var -> TcM (HsExpr GhcTc, TcType)
forall {m :: * -> *} {p}.
(Monad m, XVar p ~ NoExtField, IdP p ~ Var) =>
Var -> m (HsExpr p, TcType)
return_id Var
id }

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

             AGlobal (AConLike ConLike
cl) -> case ConLike
cl of
                 RealDataCon DataCon
con -> DataCon -> TcM (HsExpr GhcTc, TcType)
return_data_con DataCon
con
                 PatSynCon PatSyn
ps    -> PatSyn -> TcM (HsExpr GhcTc, TcType)
tcPatSynBuilderOcc PatSyn
ps

             TcTyThing
_ -> SDoc -> TcM (HsExpr GhcTc, TcType)
forall a. SDoc -> TcRn a
failWithTc (SDoc -> TcM (HsExpr GhcTc, TcType))
-> SDoc -> TcM (HsExpr GhcTc, TcType)
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
    return_id :: Var -> m (HsExpr p, TcType)
return_id Var
id = (HsExpr p, TcType) -> m (HsExpr p, TcType)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar p -> Located (IdP p) -> HsExpr p
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar p
noExtField (Var -> Located Var
forall e. e -> Located e
noLoc Var
id), Var -> TcType
idType Var
id)

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

           -- See Note [Linear fields generalization]
           ; [TcType]
mul_vars <- ThLevel -> TcType -> IOEnv (Env TcGblEnv TcLclEnv) [TcType]
newFlexiTyVarTys ([Scaled TcType] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcType]
args) TcType
multiplicityTy
           ; let scaleArgs :: [Scaled TcType] -> [Scaled TcType]
scaleArgs [Scaled TcType]
args' = String
-> (TcType -> Scaled TcType -> Scaled TcType)
-> [TcType]
-> [Scaled TcType]
-> [Scaled TcType]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"return_data_con" TcType -> Scaled TcType -> Scaled TcType
forall {a}. TcType -> Scaled a -> Scaled a
combine [TcType]
mul_vars [Scaled TcType]
args'
                 combine :: TcType -> Scaled a -> Scaled a
combine TcType
var (Scaled TcType
One a
ty) = TcType -> a -> Scaled a
forall a. TcType -> a -> Scaled a
Scaled TcType
var a
ty
                 combine TcType
_   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 TcType) -> HsWrapper
etaWrapper t (Scaled TcType)
arg_tys = (Scaled TcType -> HsWrapper -> HsWrapper)
-> HsWrapper -> t (Scaled TcType) -> HsWrapper
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Scaled TcType
scaled_ty HsWrapper
wr -> HsWrapper -> HsWrapper -> Scaled TcType -> SDoc -> HsWrapper
WpFun HsWrapper
WpHole HsWrapper
wr Scaled TcType
scaled_ty SDoc
empty) HsWrapper
WpHole t (Scaled TcType)
arg_tys

           -- See Note [Instantiating stupid theta]
           ; let shouldInstantiate :: Bool
shouldInstantiate = (Bool -> Bool
not ([TcType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [TcType]
dataConStupidTheta DataCon
con)) Bool -> Bool -> Bool
||
                                      TcType -> Bool
isKindLevPoly (TyCon -> TcType
tyConResKind (DataCon -> TyCon
dataConTyCon DataCon
con)))
           ; case Bool
shouldInstantiate of
               Bool
True -> do { (TCvSubst
subst, [Var]
tvs') <- [Var] -> TcM (TCvSubst, [Var])
newMetaTyVars ([VarBndr Var Specificity] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Var Specificity]
tvs)
                           ; let tys' :: [TcType]
tys'   = [Var] -> [TcType]
mkTyVarTys [Var]
tvs'
                                 theta' :: [TcType]
theta' = HasCallStack => TCvSubst -> [TcType] -> [TcType]
TCvSubst -> [TcType] -> [TcType]
substTheta TCvSubst
subst [TcType]
theta
                                 args' :: [Scaled TcType]
args'  = HasCallStack => TCvSubst -> [Scaled TcType] -> [Scaled TcType]
TCvSubst -> [Scaled TcType] -> [Scaled TcType]
substScaledTys TCvSubst
subst [Scaled TcType]
args
                                 res' :: TcType
res'   = HasCallStack => TCvSubst -> TcType -> TcType
TCvSubst -> TcType -> TcType
substTy TCvSubst
subst TcType
res
                           ; HsWrapper
wrap <- CtOrigin -> [TcType] -> [TcType] -> TcM HsWrapper
instCall (Name -> CtOrigin
OccurrenceOf Name
id_name) [TcType]
tys' [TcType]
theta'
                           ; let scaled_arg_tys :: [Scaled TcType]
scaled_arg_tys = [Scaled TcType] -> [Scaled TcType]
scaleArgs [Scaled TcType]
args'
                                 eta_wrap :: HsWrapper
eta_wrap = [Scaled TcType] -> HsWrapper
forall {t :: * -> *}. Foldable t => t (Scaled TcType) -> HsWrapper
etaWrapper [Scaled TcType]
scaled_arg_tys
                           ; DataCon -> [TcType] -> TcRn ()
addDataConStupidTheta DataCon
con [TcType]
tys'
                           ; (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
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 TcType] -> TcType -> TcType
mkVisFunTys [Scaled TcType]
scaled_arg_tys TcType
res')
                           }
               Bool
False -> let scaled_arg_tys :: [Scaled TcType]
scaled_arg_tys = [Scaled TcType] -> [Scaled TcType]
scaleArgs [Scaled TcType]
args
                            wrap1 :: HsWrapper
wrap1 = [TcType] -> HsWrapper
mkWpTyApps ([Var] -> [TcType]
mkTyVarTys ([Var] -> [TcType]) -> [Var] -> [TcType]
forall a b. (a -> b) -> a -> b
$ [VarBndr Var Specificity] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Var Specificity]
tvs)
                            eta_wrap :: HsWrapper
eta_wrap = [Scaled TcType] -> HsWrapper
forall {t :: * -> *}. Foldable t => t (Scaled TcType) -> HsWrapper
etaWrapper ((TcType -> Scaled TcType) -> [TcType] -> [Scaled TcType]
forall a b. (a -> b) -> [a] -> [b]
map TcType -> Scaled TcType
forall a. a -> Scaled a
unrestricted [TcType]
theta [Scaled TcType] -> [Scaled TcType] -> [Scaled TcType]
forall a. [a] -> [a] -> [a]
++ [Scaled TcType]
scaled_arg_tys)
                            wrap2 :: HsWrapper
wrap2 = [Var] -> HsWrapper
mkWpTyLams ([Var] -> HsWrapper) -> [Var] -> HsWrapper
forall a b. (a -> b) -> a -> b
$ [VarBndr Var Specificity] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Var Specificity]
tvs
                        in (HsExpr GhcTc, TcType) -> TcM (HsExpr GhcTc, TcType)
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))
                                  , [VarBndr Var Specificity] -> TcType -> TcType
mkInvisForAllTys [VarBndr Var Specificity]
tvs (TcType -> TcType) -> TcType -> TcType
forall a b. (a -> b) -> a -> b
$ [TcType] -> TcType -> TcType
mkInvisFunTysMany [TcType]
theta (TcType -> TcType) -> TcType -> TcType
forall a b. (a -> b) -> a -> b
$ [Scaled TcType] -> TcType -> TcType
mkVisFunTys [Scaled TcType]
scaled_arg_tys TcType
res)
           }

    check_naughty :: Var -> TcRn ()
check_naughty Var
id
      | Var -> Bool
isNaughtyRecordSelector Var
id = SDoc -> TcRn ()
forall a. SDoc -> TcRn a
failWithTc (RdrName -> SDoc
naughtyRecordSel RdrName
lbl)
      | Bool
otherwise                  = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTc)
-- Typecheck an occurrence of an unbound Id
--
-- Some of these started life as a true expression hole "_".
-- Others might simply be variables that accidentally have no binding site
--
-- We turn all of them into HsVar, since HsUnboundVar can't contain an
-- Id; and indeed the evidence for the ExprHole does bind it, so it's
-- not unbound any more!
tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTc)
tcUnboundId HsExpr GhcRn
rn_expr OccName
occ ExpRhoType
res_ty
 = do { TcType
ty <- TcM TcType
newOpenFlexiTyVarTy  -- Allow Int# etc (#12531)
      ; Name
name <- OccName -> TcM Name
forall gbl lcl. OccName -> TcRnIf gbl lcl Name
newSysName OccName
occ
      ; let ev :: Var
ev = HasDebugCallStack => Name -> TcType -> TcType -> Var
Name -> TcType -> TcType -> Var
mkLocalId Name
name TcType
Many TcType
ty
      ; OccName -> Var -> TcType -> TcRn ()
emitNewExprHole OccName
occ Var
ev TcType
ty
      ; CtOrigin
-> HsExpr GhcRn
-> HsExpr GhcTc
-> TcType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcWrapResultO (OccName -> CtOrigin
UnboundOccurrenceOf OccName
occ) HsExpr GhcRn
rn_expr
          (XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (Var -> Located Var
forall e. e -> Located e
noLoc Var
ev)) TcType
ty ExpRhoType
res_ty }


{-
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 [tagToEnum#]
~~~~~~~~~~~~~~~~~
Nasty check to ensure that tagToEnum# is applied to a type that is an
enumeration TyCon.  Unification may refine the type later, but this
check won't see that, alas.  It's crude, because it relies on our
knowing *now* that the type is ok, which in turn relies on the
eager-unification part of the type checker pushing enough information
here.  In theory the Right Thing to do is to have a new form of
constraint but I definitely cannot face that!  And it works ok as-is.

Here's are two cases that should fail
        f :: forall a. a
        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable

        g :: Int
        g = tagToEnum# 0        -- Int is not an enumeration

When data type families are involved it's a bit more complicated.
     data family F a
     data instance F [Int] = A | B | C
Then we want to generate something like
     tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
Usually that coercion is hidden inside the wrappers for
constructors of F [Int] but here we have to do it explicitly.

It's all grotesquely complicated.

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.

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

isTagToEnum :: HsExpr GhcTc -> Bool
isTagToEnum :: HsExpr GhcTc -> Bool
isTagToEnum (HsVar XVar GhcTc
_ (L SrcSpan
_ IdP GhcTc
fun_id)) = Var
IdP GhcTc
fun_id Var -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
isTagToEnum HsExpr GhcTc
_ = Bool
False

tcTagToEnum :: HsExpr GhcRn -> HsExpr GhcTc -> [LHsExprArgOut]
            -> TcSigmaType -> ExpRhoType
            -> TcM (HsExpr GhcTc)
-- tagToEnum# :: forall a. Int# -> a
-- See Note [tagToEnum#]   Urgh!
tcTagToEnum :: HsExpr GhcRn
-> HsExpr GhcTc
-> [LHsExprArgOut]
-> TcType
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcTagToEnum HsExpr GhcRn
expr HsExpr GhcTc
fun [LHsExprArgOut]
args TcType
app_res_ty ExpRhoType
res_ty
  = do { TcType
res_ty <- ExpRhoType -> TcM TcType
readExpType ExpRhoType
res_ty
       ; TcType
ty'    <- TcType -> TcM TcType
zonkTcType TcType
res_ty

       -- Check that the type is algebraic
       ; case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty' of {
           Maybe (TyCon, [TcType])
Nothing -> do { SDoc -> TcRn ()
addErrTc (TcType -> SDoc -> SDoc
mk_error TcType
ty' SDoc
doc1)
                         ; TcM (HsExpr GhcTc)
vanilla_result } ;
           Just (TyCon
tc, [TcType]
tc_args) ->

    do { -- Look through any type family
       ; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
       ; case FamInstEnvs
-> TyCon -> [TcType] -> Maybe (TyCon, [TcType], TcCoercionR)
tcLookupDataFamInst_maybe FamInstEnvs
fam_envs TyCon
tc [TcType]
tc_args of {
           Maybe (TyCon, [TcType], TcCoercionR)
Nothing -> do { TcType -> TyCon -> TcRn ()
check_enumeration TcType
ty' TyCon
tc
                         ; TcM (HsExpr GhcTc)
vanilla_result } ;
           Just (TyCon
rep_tc, [TcType]
rep_args, TcCoercionR
coi) ->

    do { -- coi :: tc tc_args ~R rep_tc rep_args
         TcType -> TyCon -> TcRn ()
check_enumeration TcType
ty' TyCon
rep_tc
       ; let val_arg :: [LHsExprArgOut]
val_arg = (LHsExprArgOut -> Bool) -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (LHsExprArgOut -> Bool) -> LHsExprArgOut -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExprArgOut -> Bool
forall (id :: Pass). HsExprArg id -> Bool
isHsValArg) [LHsExprArgOut]
args
             rep_ty :: TcType
rep_ty  = TyCon -> [TcType] -> TcType
mkTyConApp TyCon
rep_tc [TcType]
rep_args
             fun' :: HsExpr GhcTc
fun'    = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (TcType -> HsWrapper
WpTyApp TcType
rep_ty) HsExpr GhcTc
fun
             expr' :: HsExpr GhcTc
expr'   = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
applyHsArgs HsExpr GhcTc
fun' [LHsExprArgOut]
val_arg
             df_wrap :: HsWrapper
df_wrap = TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> TcCoercionR
mkTcSymCo TcCoercionR
coi)
       ; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
df_wrap HsExpr GhcTc
expr') }}}}}

  where
    vanilla_result :: TcM (HsExpr GhcTc)
vanilla_result
      = do { let expr' :: HsExpr GhcTc
expr' = HsExpr GhcTc -> [LHsExprArgOut] -> HsExpr GhcTc
applyHsArgs HsExpr GhcTc
fun [LHsExprArgOut]
args
           ; HsExpr GhcRn
-> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM (HsExpr GhcTc)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTc
expr' TcType
app_res_ty ExpRhoType
res_ty }

    check_enumeration :: TcType -> TyCon -> TcRn ()
check_enumeration TcType
ty' TyCon
tc
      | TyCon -> Bool
isEnumerationTyCon TyCon
tc = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise             = SDoc -> TcRn ()
addErrTc (TcType -> SDoc -> SDoc
mk_error TcType
ty' SDoc
doc2)

    doc1 :: SDoc
doc1 = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Specify the type by giving a type signature"
                , String -> SDoc
text String
"e.g. (tagToEnum# x) :: Bool" ]
    doc2 :: SDoc
doc2 = String -> SDoc
text String
"Result type must be an enumeration type"

    mk_error :: TcType -> SDoc -> SDoc
    mk_error :: TcType -> SDoc -> SDoc
mk_error TcType
ty SDoc
what
      = SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
text String
"Bad call to tagToEnum#"
               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"at type" SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)
           ThLevel
2 SDoc
what

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

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

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

checkCrossStageLifting :: TopLevelFlag -> Var -> ThStage -> TcRn ()
checkCrossStageLifting TopLevelFlag
top_lvl Var
id (Brack ThStage
_ (TcPending TcRef [PendingTcSplice]
ps_var TcRef WantedConstraints
lie_var QuoteWrapper
q))
  | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
  = Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
id_name) (Name -> TcRn ()
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 :: TcType
id_ty = Var -> TcType
idType Var
id
        ; Bool -> SDoc -> TcRn ()
checkTc (TcType -> Bool
isTauTy TcType
id_ty) (Var -> SDoc
polySpliceErr Var
id)
               -- If x is polymorphic, its occurrence sites might
               -- have different instantiations, so we can't use plain
               -- 'x' as the splice proxy name.  I don't know how to
               -- solve this, and it's probably unimportant, so I'm
               -- just going to flag an error for now

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

                   -- 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 -> LHsExpr GhcTc
forall e. e -> Located e
noLoc HsExpr GhcTc
lift))
                                          (IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar Var
IdP GhcTc
id))
        ; TcRef [PendingTcSplice] -> [PendingTcSplice] -> TcRn ()
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)

        ; () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
  where
    id_name :: Name
id_name = Var -> Name
idName Var
id

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

polySpliceErr :: Id -> SDoc
polySpliceErr :: Var -> SDoc
polySpliceErr Var
id
  = String -> SDoc
text String
"Can't splice the polymorphic local variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
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 "GHC.ThToHs"

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.


************************************************************************
*                                                                      *
\subsection{Record bindings}
*                                                                      *
************************************************************************
-}

getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
-- These tyvars must not change across the updates
getFixedTyVars :: [FieldLabelString] -> [Var] -> [ConLike] -> VarSet
getFixedTyVars [FieldLabelString]
upd_fld_occs [Var]
univ_tvs [ConLike]
cons
      = [Var] -> VarSet
mkVarSet [Var
tv1 | ConLike
con <- [ConLike]
cons
                      , let ([Var]
u_tvs, [Var]
_, [EqSpec]
eqspec, [TcType]
prov_theta
                             , [TcType]
req_theta, [Scaled TcType]
arg_tys, TcType
_)
                              = ConLike
-> ([Var], [Var], [EqSpec], [TcType], [TcType], [Scaled TcType],
    TcType)
conLikeFullSig ConLike
con
                            theta :: [TcType]
theta = [EqSpec] -> [TcType]
eqSpecPreds [EqSpec]
eqspec
                                     [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
prov_theta
                                     [TcType] -> [TcType] -> [TcType]
forall a. [a] -> [a] -> [a]
++ [TcType]
req_theta
                            flds :: [FieldLbl Name]
flds = ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con
                            fixed_tvs :: VarSet
fixed_tvs = [TcType] -> VarSet
exactTyCoVarsOfTypes ((Scaled TcType -> TcType) -> [Scaled TcType] -> [TcType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing [Scaled TcType]
fixed_tys)
                                    -- fixed_tys: See Note [Type of a record update]
                                        VarSet -> VarSet -> VarSet
`unionVarSet` [TcType] -> VarSet
tyCoVarsOfTypes [TcType]
theta
                                    -- Universally-quantified tyvars that
                                    -- appear in any of the *implicit*
                                    -- arguments to the constructor are fixed
                                    -- See Note [Implicit type sharing]

                            fixed_tys :: [Scaled TcType]
fixed_tys = [Scaled TcType
ty | (FieldLbl Name
fl, Scaled TcType
ty) <- [FieldLbl Name]
-> [Scaled TcType] -> [(FieldLbl Name, Scaled TcType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FieldLbl Name]
flds [Scaled TcType]
arg_tys
                                            , Bool -> Bool
not (FieldLbl Name -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel FieldLbl Name
fl FieldLabelString -> [FieldLabelString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FieldLabelString]
upd_fld_occs)]
                      , (Var
tv1,Var
tv) <- [Var]
univ_tvs [Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Var]
u_tvs
                      , Var
tv Var -> VarSet -> Bool
`elemVarSet` VarSet
fixed_tvs ]

{-
Note [Disambiguating record 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 `tcApp`.


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

-- 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.
disambiguateSelector :: Located RdrName -> Type -> TcM Name
disambiguateSelector :: Located RdrName -> TcType -> TcM Name
disambiguateSelector lr :: Located RdrName
lr@(L SrcSpan
_ RdrName
rdr) TcType
parent_type
 = do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
      ; case FamInstEnvs -> TcType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcType
parent_type of
          Maybe TyCon
Nothing -> Located RdrName -> TcM Name
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lr
          Just TyCon
p  ->
            do { [(RecSelParent, GlobalRdrElt)]
xs <- RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents 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
                   Just GlobalRdrElt
gre -> do { Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
                                  ; Name -> TcM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre) }
                   Maybe GlobalRdrElt
Nothing  -> SDoc -> TcM Name
forall a. SDoc -> TcRn a
failWithTc (RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
parent RdrName
rdr) } }

-- This field name really is ambiguous, so add a suitable "ambiguous
-- occurrence" error, then give up.
ambiguousSelector :: Located RdrName -> TcM a
ambiguousSelector :: forall a. Located RdrName -> TcM a
ambiguousSelector (L SrcSpan
_ RdrName
rdr)
  = do { RdrName -> TcRn ()
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 -> TcRn ()
addAmbiguousNameErr RdrName
rdr
  = do { GlobalRdrEnv
env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; let gres :: [GlobalRdrElt]
gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName RdrName
rdr GlobalRdrEnv
env
       ; [ErrCtxt] -> TcRn () -> TcRn ()
forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [] (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ RdrName -> [GlobalRdrElt] -> TcRn ()
addNameClashErrRn RdrName
rdr [GlobalRdrElt]
gres}

-- Disambiguate the fields in a record update.
-- See Note [Disambiguating record fields]
disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
                 -> [LHsRecUpdField GhcRn] -> ExpRhoType
                 -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds :: LHsExpr GhcRn
-> TcType
-> [LHsRecUpdField GhcRn]
-> ExpRhoType
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcType
record_rho [LHsRecUpdField GhcRn]
rbnds ExpRhoType
res_ty
    -- Are all the fields unambiguous?
  = case (LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name))
-> [LHsRecUpdField GhcRn] -> Maybe [(LHsRecUpdField GhcRn, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
isUnambiguous [LHsRecUpdField GhcRn]
rbnds of
                     -- If so, just skip to looking up the Ids
                     -- Always the case if DuplicateRecordFields is off
      Just [(LHsRecUpdField GhcRn, Name)]
rbnds' -> ((LHsRecUpdField GhcRn, Name)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)))
-> [(LHsRecUpdField GhcRn, Name)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LHsRecUpdField GhcRn, Name)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector [(LHsRecUpdField GhcRn, Name)]
rbnds'
      Maybe [(LHsRecUpdField GhcRn, Name)]
Nothing     -> -- If not, try to identify a single parent
        do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
             -- Look up the possible parents for each field
           ; [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents <- TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
           ; let possible_parents :: [[RecSelParent]]
possible_parents = ((LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
 -> [RecSelParent])
-> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
-> [[RecSelParent]]
forall a b. (a -> b) -> [a] -> [b]
map (((RecSelParent, GlobalRdrElt) -> RecSelParent)
-> [(RecSelParent, GlobalRdrElt)] -> [RecSelParent]
forall a b. (a -> b) -> [a] -> [b]
map (RecSelParent, GlobalRdrElt) -> RecSelParent
forall a b. (a, b) -> a
fst ([(RecSelParent, GlobalRdrElt)] -> [RecSelParent])
-> ((LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
    -> [(RecSelParent, GlobalRdrElt)])
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> [RecSelParent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> [(RecSelParent, GlobalRdrElt)]
forall a b. (a, b) -> b
snd) [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents
             -- Identify a single parent
           ; RecSelParent
p <- FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent FamInstEnvs
fam_inst_envs [[RecSelParent]]
possible_parents
             -- Pick the right selector with that parent for each field
           ; TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
forall r. TcM r -> TcM r
checkNoErrs (TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
 -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)])
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
forall a b. (a -> b) -> a -> b
$ ((LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)))
-> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p) [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents }
  where
    -- Extract the selector name of a field update if it is unambiguous
    isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
    isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
isUnambiguous LHsRecUpdField GhcRn
x = case Located (AmbiguousFieldOcc GhcRn) -> AmbiguousFieldOcc GhcRn
forall l e. GenLocated l e -> e
unLoc (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
x)) of
                        Unambiguous XUnambiguous GhcRn
sel_name Located RdrName
_ -> (LHsRecUpdField GhcRn, Name) -> Maybe (LHsRecUpdField GhcRn, Name)
forall a. a -> Maybe a
Just (LHsRecUpdField GhcRn
x, Name
XUnambiguous GhcRn
sel_name)
                        Ambiguous{}            -> Maybe (LHsRecUpdField GhcRn, Name)
forall a. Maybe a
Nothing

    -- Look up the possible parents and selector GREs for each field
    getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
                                , [(RecSelParent, GlobalRdrElt)])]
    getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
      = ([[(RecSelParent, GlobalRdrElt)]]
 -> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])])
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
-> TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([LHsRecUpdField GhcRn]
-> [[(RecSelParent, GlobalRdrElt)]]
-> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [LHsRecUpdField GhcRn]
rbnds) (IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
 -> TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])])
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
-> TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
forall a b. (a -> b) -> a -> b
$ (LHsRecUpdField GhcRn -> RnM [(RecSelParent, GlobalRdrElt)])
-> [LHsRecUpdField GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
          (RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents (RdrName -> RnM [(RecSelParent, GlobalRdrElt)])
-> (LHsRecUpdField GhcRn -> RdrName)
-> LHsRecUpdField GhcRn
-> RnM [(RecSelParent, GlobalRdrElt)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (Located RdrName -> RdrName)
-> (LHsRecUpdField GhcRn -> Located RdrName)
-> LHsRecUpdField GhcRn
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located RdrName
forall (p :: Pass). HsRecUpdField (GhcPass p) -> Located RdrName
hsRecUpdFieldRdr (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
 -> Located RdrName)
-> (LHsRecUpdField GhcRn
    -> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn))
-> LHsRecUpdField GhcRn
-> Located RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc)
          [LHsRecUpdField GhcRn]
rbnds

    -- Given a the lists of possible parents for each field,
    -- identify a single parent
    identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
    identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent FamInstEnvs
fam_inst_envs [[RecSelParent]]
possible_parents
      = case ([RecSelParent] -> [RecSelParent] -> [RecSelParent])
-> [[RecSelParent]] -> [RecSelParent]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 [RecSelParent] -> [RecSelParent] -> [RecSelParent]
forall a. Eq a => [a] -> [a] -> [a]
intersect [[RecSelParent]]
possible_parents of
        -- No parents for all fields: record update is ill-typed
        []  -> SDoc -> TcM RecSelParent
forall a. SDoc -> TcRn a
failWithTc ([LHsRecUpdField GhcRn] -> SDoc
noPossibleParents [LHsRecUpdField GhcRn]
rbnds)

        -- Exactly one datatype with all the fields: use that
        [RecSelParent
p] -> RecSelParent -> TcM RecSelParent
forall (m :: * -> *) a. Monad m => a -> m a
return RecSelParent
p

        -- Multiple possible parents: try harder to disambiguate
        -- Can we get a parent TyCon from the pushed-in type?
        RecSelParent
_:[RecSelParent]
_ | Just TyCon
p <- FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET FamInstEnvs
fam_inst_envs ExpRhoType
res_ty -> RecSelParent -> TcM RecSelParent
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
p)

        -- Does the expression being updated have a type signature?
        -- If so, try to extract a parent TyCon from it
            | Just {} <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
record_expr)
            , Just TyCon
tc <- FamInstEnvs -> TcType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcType
record_rho
            -> RecSelParent -> TcM RecSelParent
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
tc)

        -- Nothing else we can try...
        [RecSelParent]
_ -> SDoc -> TcM RecSelParent
forall a. SDoc -> TcRn a
failWithTc SDoc
badOverloadedUpdate

    -- Make a field unambiguous by choosing the given parent.
    -- Emits an error if the field cannot have that parent,
    -- e.g. if the user writes
    --     r { x = e } :: T
    -- where T does not have field x.
    pickParent :: RecSelParent
               -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
               -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
    pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent RecSelParent
p (LHsRecUpdField GhcRn
upd, [(RecSelParent, GlobalRdrElt)]
xs)
      = case RecSelParent
-> [(RecSelParent, GlobalRdrElt)] -> Maybe GlobalRdrElt
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RecSelParent
p [(RecSelParent, GlobalRdrElt)]
xs of
                      -- Phew! The parent is valid for this field.
                      -- Previously ambiguous fields must be marked as
                      -- used now that we know which one is meant, but
                      -- unambiguous ones shouldn't be recorded again
                      -- (giving duplicate deprecation warnings).
          Just GlobalRdrElt
gre -> do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(RecSelParent, GlobalRdrElt)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(RecSelParent, GlobalRdrElt)] -> [(RecSelParent, GlobalRdrElt)]
forall a. [a] -> [a]
tail [(RecSelParent, GlobalRdrElt)]
xs)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
                             let L SrcSpan
loc AmbiguousFieldOcc GhcRn
_ = HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
upd)
                             SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
                         ; (LHsRecUpdField GhcRn, Name)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre) }
                      -- The field doesn't belong to this parent, so report
                      -- an error but keep going through all the fields
          Maybe GlobalRdrElt
Nothing  -> do { SDoc -> TcRn ()
addErrTc (RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
p
                                      (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located RdrName
forall (p :: Pass). HsRecUpdField (GhcPass p) -> Located RdrName
hsRecUpdFieldRdr (LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc LHsRecUpdField GhcRn
upd))))
                         ; (LHsRecUpdField GhcRn, Name)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
gre_name ((RecSelParent, GlobalRdrElt) -> GlobalRdrElt
forall a b. (a, b) -> b
snd ([(RecSelParent, GlobalRdrElt)] -> (RecSelParent, GlobalRdrElt)
forall a. [a] -> a
head [(RecSelParent, GlobalRdrElt)]
xs))) }

    -- Given a (field update, selector name) pair, look up the
    -- selector to give a field update with an unambiguous Id
    lookupSelector :: (LHsRecUpdField GhcRn, Name)
                 -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
    lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (L SrcSpan
l HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
upd, Name
n)
      = do { Var
i <- Name -> TcM Var
tcLookupId Name
n
           ; let L SrcSpan
loc AmbiguousFieldOcc GhcRn
af = HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
upd
                 lbl :: RdrName
lbl      = AmbiguousFieldOcc GhcRn -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcRn
af
           ; LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)))
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
upd { hsRecFieldLbl :: GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
hsRecFieldLbl
                                  = SrcSpan
-> AmbiguousFieldOcc GhcTc
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcTc -> Located RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous Var
XUnambiguous GhcTc
i (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
lbl)) } }


-- 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 -> TcType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcType
ty0
  = case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
      Just (TyCon
tc, [TcType]
tys) -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just ((TyCon, [TcType], TcCoercionR) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 (FamInstEnvs -> TyCon -> [TcType] -> (TyCon, [TcType], TcCoercionR)
tcLookupDataFamInst FamInstEnvs
fam_inst_envs TyCon
tc [TcType]
tys))
      Maybe (TyCon, [TcType])
Nothing        -> Maybe TyCon
forall a. Maybe a
Nothing
  where
    ([Var]
_, [TcType]
_, TcType
ty) = TcType -> ([Var], [TcType], TcType)
tcSplitSigmaTy TcType
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 -> TcType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs (TcType -> Maybe TyCon) -> Maybe TcType -> Maybe TyCon
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpRhoType -> Maybe TcType
checkingExpType_maybe ExpRhoType
ty0

-- For an ambiguous record field, find all the candidate record
-- selectors (as GlobalRdrElts) and their parents.
lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents RdrName
rdr
  = do { GlobalRdrEnv
env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; let gres :: [GlobalRdrElt]
gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName RdrName
rdr GlobalRdrEnv
env
       ; (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 { Var
id <- Name -> TcM Var
tcLookupId (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre)
                          ; if Var -> Bool
isRecordSelector Var
id
                              then (RecSelParent, GlobalRdrElt)
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> RecSelParent
recordSelectorTyCon Var
id, GlobalRdrElt
gre)
                              else SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall a. SDoc -> TcRn a
failWithTc (Name -> SDoc
notSelector (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre)) }

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


{-
Game plan for record bindings
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1. Find the TyCon for the bindings, from the first field label.

2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.

For each binding field = value

3. Instantiate the field type (from the field label) using the type
   envt from step 2.

4  Type check the value using tcArg, passing the field type as
   the expected argument type.

This extends OK when the field types are universally quantified.
-}

tcRecordBinds
        :: ConLike
        -> [TcType]     -- Expected type for each field
        -> HsRecordBinds GhcRn
        -> TcM (HsRecordBinds GhcTc)

tcRecordBinds :: ConLike
-> [TcType] -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc)
tcRecordBinds ConLike
con_like [TcType]
arg_tys (HsRecFields [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds Maybe (Located ThLevel)
dd)
  = do  { [Maybe (LHsRecField GhcTc (LHsExpr GhcTc))]
mb_binds <- (LHsRecField GhcRn (LHsExpr GhcRn)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Maybe (LHsRecField GhcTc (LHsExpr GhcTc))))
-> [LHsRecField GhcRn (LHsExpr GhcRn)]
-> IOEnv
     (Env TcGblEnv TcLclEnv) [Maybe (LHsRecField GhcTc (LHsExpr GhcTc))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField GhcRn (LHsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds
        ; HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsRecField GhcTc (LHsExpr GhcTc)]
-> Maybe (Located ThLevel) -> HsRecordBinds GhcTc
forall p arg.
[LHsRecField p arg] -> Maybe (Located ThLevel) -> HsRecFields p arg
HsRecFields ([Maybe (LHsRecField GhcTc (LHsExpr GhcTc))]
-> [LHsRecField GhcTc (LHsExpr GhcTc)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (LHsRecField GhcTc (LHsExpr GhcTc))]
mb_binds) Maybe (Located ThLevel)
dd) }
  where
    fields :: [Name]
fields = (FieldLbl Name -> Name) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector ([FieldLbl Name] -> [Name]) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con_like
    flds_w_tys :: [(Name, TcType)]
flds_w_tys = String -> [Name] -> [TcType] -> [(Name, TcType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcRecordBinds" [Name]
fields [TcType]
arg_tys

    do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
            -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
    do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind (L SrcSpan
l fld :: HsRecField GhcRn (LHsExpr GhcRn)
fld@(HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = Located (FieldOcc GhcRn)
f
                                 , hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = LHsExpr GhcRn
rhs }))

      = do { Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
mb <- ConLike
-> [(Name, TcType)]
-> Located (FieldOcc GhcRn)
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcType)]
flds_w_tys Located (FieldOcc GhcRn)
f LHsExpr GhcRn
rhs
           ; case Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
mb of
               Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
Nothing         -> Maybe (LHsRecField GhcTc (LHsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LHsRecField GhcTc (LHsExpr GhcTc))
forall a. Maybe a
Nothing
               Just (LFieldOcc GhcTc
f', LHsExpr GhcTc
rhs') -> Maybe (LHsRecField GhcTc (LHsExpr GhcTc))
-> IOEnv
     (Env TcGblEnv TcLclEnv) (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsRecField GhcTc (LHsExpr GhcTc)
-> Maybe (LHsRecField GhcTc (LHsExpr GhcTc))
forall a. a -> Maybe a
Just (SrcSpan
-> HsRecField' (FieldOcc GhcTc) (LHsExpr GhcTc)
-> LHsRecField GhcTc (LHsExpr GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsRecField GhcRn (LHsExpr GhcRn)
fld { hsRecFieldLbl :: LFieldOcc GhcTc
hsRecFieldLbl = LFieldOcc GhcTc
f'
                                                          , hsRecFieldArg :: LHsExpr GhcTc
hsRecFieldArg = LHsExpr GhcTc
rhs' }))) }

tcRecordUpd
        :: ConLike
        -> [TcType]     -- Expected type for each field
        -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
        -> TcM [LHsRecUpdField GhcTc]

tcRecordUpd :: ConLike
-> [TcType]
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd ConLike
con_like [TcType]
arg_tys [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds = ([Maybe (LHsRecUpdField GhcTc)] -> [LHsRecUpdField GhcTc])
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTc)]
-> TcM [LHsRecUpdField GhcTc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (LHsRecUpdField GhcTc)] -> [LHsRecUpdField GhcTc]
forall a. [Maybe a] -> [a]
catMaybes (IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTc)]
 -> TcM [LHsRecUpdField GhcTc])
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTc)]
-> TcM [LHsRecUpdField GhcTc]
forall a b. (a -> b) -> a -> b
$ (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTc)))
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTc))
do_bind [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds
  where
    fields :: [Name]
fields = (FieldLbl Name -> Name) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector ([FieldLbl Name] -> [Name]) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con_like
    flds_w_tys :: [(Name, TcType)]
flds_w_tys = String -> [Name] -> [TcType] -> [(Name, TcType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcRecordUpd" [Name]
fields [TcType]
arg_tys

    do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
            -> TcM (Maybe (LHsRecUpdField GhcTc))
    do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTc))
do_bind (L SrcSpan
l fld :: HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
fld@(HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = L SrcSpan
loc AmbiguousFieldOcc GhcTc
af
                                 , hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = LHsExpr GhcRn
rhs }))
      = do { let lbl :: RdrName
lbl = AmbiguousFieldOcc GhcTc -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcTc
af
                 sel_id :: Var
sel_id = AmbiguousFieldOcc GhcTc -> Var
selectorAmbiguousFieldOcc AmbiguousFieldOcc GhcTc
af
                 f :: Located (FieldOcc GhcRn)
f = SrcSpan -> FieldOcc GhcRn -> Located (FieldOcc GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcRn -> Located RdrName -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc (Var -> Name
idName Var
sel_id) (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
lbl))
           ; Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
mb <- ConLike
-> [(Name, TcType)]
-> Located (FieldOcc GhcRn)
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcType)]
flds_w_tys Located (FieldOcc GhcRn)
f LHsExpr GhcRn
rhs
           ; case Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
mb of
               Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
Nothing         -> Maybe (LHsRecUpdField GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LHsRecUpdField GhcTc)
forall a. Maybe a
Nothing
               Just (LFieldOcc GhcTc
f', LHsExpr GhcTc
rhs') ->
                 Maybe (LHsRecUpdField GhcTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsRecUpdField GhcTc -> Maybe (LHsRecUpdField GhcTc)
forall a. a -> Maybe a
Just
                         (SrcSpan
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcTc)
-> LHsRecUpdField GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
fld { hsRecFieldLbl :: GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
hsRecFieldLbl
                                      = SrcSpan
-> AmbiguousFieldOcc GhcTc
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcTc -> Located RdrName -> AmbiguousFieldOcc GhcTc
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous
                                               (FieldOcc GhcTc -> XCFieldOcc GhcTc
forall pass. FieldOcc pass -> XCFieldOcc pass
extFieldOcc (LFieldOcc GhcTc -> FieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc LFieldOcc GhcTc
f'))
                                               (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
lbl))
                                   , hsRecFieldArg :: LHsExpr GhcTc
hsRecFieldArg = LHsExpr GhcTc
rhs' }))) }

tcRecordField :: ConLike -> Assoc Name Type
              -> LFieldOcc GhcRn -> LHsExpr GhcRn
              -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField :: ConLike
-> [(Name, TcType)]
-> Located (FieldOcc GhcRn)
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField ConLike
con_like [(Name, TcType)]
flds_w_tys (L SrcSpan
loc (FieldOcc XCFieldOcc GhcRn
sel_name Located RdrName
lbl)) LHsExpr GhcRn
rhs
  | Just TcType
field_ty <- [(Name, TcType)] -> Name -> Maybe TcType
forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe [(Name, TcType)]
flds_w_tys Name
XCFieldOcc GhcRn
sel_name
      = SDoc
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (FieldLabelString -> SDoc
fieldCtxt FieldLabelString
field_lbl) (TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
 -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall a b. (a -> b) -> a -> b
$
        do { LHsExpr GhcTc
rhs' <- LHsExpr GhcRn -> TcType -> TcM (LHsExpr GhcTc)
tcCheckPolyExprNC LHsExpr GhcRn
rhs TcType
field_ty
           ; let field_id :: Var
field_id = OccName -> Unique -> TcType -> TcType -> SrcSpan -> Var
mkUserLocal (Name -> OccName
nameOccName Name
XCFieldOcc GhcRn
sel_name)
                                        (Name -> Unique
nameUnique Name
XCFieldOcc GhcRn
sel_name)
                                        TcType
Many TcType
field_ty SrcSpan
loc
                -- Yuk: the field_id has the *unique* of the selector Id
                --          (so we can find it easily)
                --      but is a LocalId with the appropriate type of the RHS
                --          (so the desugarer knows the type of local binder to make)
           ; Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return ((LFieldOcc GhcTc, LHsExpr GhcTc)
-> Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
forall a. a -> Maybe a
Just (SrcSpan -> FieldOcc GhcTc -> LFieldOcc GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcTc -> Located RdrName -> FieldOcc GhcTc
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc Var
XCFieldOcc GhcTc
field_id Located RdrName
lbl), LHsExpr GhcTc
rhs')) }
      | Bool
otherwise
      = do { SDoc -> TcRn ()
addErrTc (ConLike -> FieldLabelString -> SDoc
badFieldCon ConLike
con_like FieldLabelString
field_lbl)
           ; Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)
forall a. Maybe a
Nothing }
  where
        field_lbl :: FieldLabelString
field_lbl = OccName -> FieldLabelString
occNameFS (OccName -> FieldLabelString) -> OccName -> FieldLabelString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc (Located RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc Located RdrName
lbl)


checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> TcM ()
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcRn ()
checkMissingFields ConLike
con_like HsRecordBinds GhcRn
rbinds
  | [FieldLbl Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLbl Name]
field_labels   -- Not declared as a record;
                        -- But C{} is still valid if no strict fields
  = if (HsImplBang -> Bool) -> [HsImplBang] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsImplBang -> Bool
isBanged [HsImplBang]
field_strs then
        -- Illegal if any arg is strict
        SDoc -> TcRn ()
addErrTc (ConLike -> [FieldLabelString] -> SDoc
missingStrictFields ConLike
con_like [])
    else do
        Bool
warn <- WarningFlag -> TcRn Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingFields
        Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn Bool -> Bool -> Bool
&& [HsImplBang] -> Bool
forall a. [a] -> Bool
notNull [HsImplBang]
field_strs Bool -> Bool -> Bool
&& [FieldLbl Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLbl Name]
field_labels)
             (WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingFields) Bool
True
                 (ConLike -> [FieldLabelString] -> SDoc
missingFields ConLike
con_like []))

  | Bool
otherwise = do              -- A record
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FieldLabelString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabelString]
missing_s_fields)
           (SDoc -> TcRn ()
addErrTc (ConLike -> [FieldLabelString] -> SDoc
missingStrictFields ConLike
con_like [FieldLabelString]
missing_s_fields))

    Bool
warn <- WarningFlag -> TcRn Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingFields
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn Bool -> Bool -> Bool
&& [FieldLabelString] -> Bool
forall a. [a] -> Bool
notNull [FieldLabelString]
missing_ns_fields)
         (WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingFields) Bool
True
             (ConLike -> [FieldLabelString] -> SDoc
missingFields ConLike
con_like [FieldLabelString]
missing_ns_fields))

  where
    missing_s_fields :: [FieldLabelString]
missing_s_fields
        = [ FieldLbl Name -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel FieldLbl Name
fl | (FieldLbl Name
fl, HsImplBang
str) <- [(FieldLbl Name, HsImplBang)]
field_info,
                 HsImplBang -> Bool
isBanged HsImplBang
str,
                 Bool -> Bool
not (FieldLbl Name
fl FieldLbl Name -> [Name] -> Bool
forall {t :: * -> *} {a}.
(Foldable t, Eq a) =>
FieldLbl a -> t a -> Bool
`elemField` [Name]
[XCFieldOcc GhcRn]
field_names_used)
          ]
    missing_ns_fields :: [FieldLabelString]
missing_ns_fields
        = [ FieldLbl Name -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel FieldLbl Name
fl | (FieldLbl Name
fl, HsImplBang
str) <- [(FieldLbl Name, HsImplBang)]
field_info,
                 Bool -> Bool
not (HsImplBang -> Bool
isBanged HsImplBang
str),
                 Bool -> Bool
not (FieldLbl Name
fl FieldLbl Name -> [Name] -> Bool
forall {t :: * -> *} {a}.
(Foldable t, Eq a) =>
FieldLbl a -> t a -> Bool
`elemField` [Name]
[XCFieldOcc GhcRn]
field_names_used)
          ]

    field_names_used :: [XCFieldOcc GhcRn]
field_names_used = HsRecordBinds GhcRn -> [XCFieldOcc GhcRn]
forall p arg. HsRecFields p arg -> [XCFieldOcc p]
hsRecFields HsRecordBinds GhcRn
rbinds
    field_labels :: [FieldLbl Name]
field_labels     = ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con_like

    field_info :: [(FieldLbl Name, HsImplBang)]
field_info = String
-> [FieldLbl Name] -> [HsImplBang] -> [(FieldLbl Name, HsImplBang)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"missingFields"
                          [FieldLbl Name]
field_labels
                          [HsImplBang]
field_strs

    field_strs :: [HsImplBang]
field_strs = ConLike -> [HsImplBang]
conLikeImplBangs ConLike
con_like

    FieldLbl a
fl elemField :: FieldLbl a -> t a -> Bool
`elemField` t a
flds = (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ a
fl' -> FieldLbl a -> a
forall a. FieldLbl a -> a
flSelector FieldLbl a
fl a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
fl') t a
flds

{-
************************************************************************
*                                                                      *
\subsection{Errors and contexts}
*                                                                      *
************************************************************************

Boring and alphabetical:
-}

fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt FieldLabelString
field_name
  = String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabelString
field_name) SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"field of a record")

addExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt :: forall a. LHsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt LHsExpr GhcRn
e TcRn a
thing_inside = SDoc -> TcRn a -> TcRn a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr GhcRn -> SDoc
exprCtxt (LHsExpr GhcRn -> HsExpr GhcRn
forall l e. GenLocated l e -> e
unLoc LHsExpr GhcRn
e)) TcRn a
thing_inside

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

addFunResCtxt :: Bool  -- There is at least one argument
              -> HsExpr GhcTc -> 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
--
-- Used for naked variables too; but with has_args = False
addFunResCtxt :: forall a.
Bool -> HsExpr GhcTc -> TcType -> ExpRhoType -> TcM a -> TcM a
addFunResCtxt Bool
has_args HsExpr GhcTc
fun TcType
fun_res_ty ExpRhoType
env_ty
  = (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)
      -- 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 TcType
mb_env_ty <- ExpRhoType -> TcM (Maybe TcType)
readExpType_maybe ExpRhoType
env_ty
                     -- by the time the message is rendered, the ExpType
                     -- will be filled in (except if we're debugging)
           ; TcType
fun_res' <- TcType -> TcM TcType
zonkTcType TcType
fun_res_ty
           ; TcType
env'     <- case Maybe TcType
mb_env_ty of
                           Just TcType
env_ty -> TcType -> TcM TcType
zonkTcType TcType
env_ty
                           Maybe TcType
Nothing     ->
                             do { Bool
dumping <- DumpFlag -> TcRn Bool
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
Opt_D_dump_tc_trace
                                ; MASSERT( dumping )
                                ; TcType -> TcM TcType
newFlexiTyVarTy TcType
liftedTypeKind }
           ; let -- See Note [Splitting nested sigma types in mismatched
                 --           function types]
                 ([Var]
_, [TcType]
_, TcType
fun_tau) = TcType -> ([Var], [TcType], TcType)
tcSplitNestedSigmaTys TcType
fun_res'
                 -- No need to call tcSplitNestedSigmaTys here, since env_ty is
                 -- an ExpRhoTy, i.e., it's already instantiated.
                 ([Var]
_, [TcType]
_, TcType
env_tau) = TcType -> ([Var], [TcType], TcType)
tcSplitSigmaTy TcType
env'
                 ([Scaled TcType]
args_fun, TcType
res_fun) = TcType -> ([Scaled TcType], TcType)
tcSplitFunTys TcType
fun_tau
                 ([Scaled TcType]
args_env, TcType
res_env) = TcType -> ([Scaled TcType], TcType)
tcSplitFunTys TcType
env_tau
                 n_fun :: ThLevel
n_fun = [Scaled TcType] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcType]
args_fun
                 n_env :: ThLevel
n_env = [Scaled TcType] -> ThLevel
forall (t :: * -> *) a. Foldable t => t a -> ThLevel
length [Scaled TcType]
args_env
                 info :: SDoc
info  | ThLevel
n_fun ThLevel -> ThLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ThLevel
n_env = SDoc
Outputable.empty
                       | ThLevel
n_fun ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ThLevel
n_env
                       , TcType -> Bool
not_fun TcType
res_env
                       = String -> SDoc
text String
"Probable cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
fun)
                         SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is applied to too few arguments"

                       | Bool
has_args
                       , TcType -> Bool
not_fun TcType
res_fun
                       = String -> SDoc
text String
"Possible cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
fun)
                         SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is applied to too many arguments"

                       | Bool
otherwise
                       = SDoc
Outputable.empty  -- Never suggest that a naked variable is                                         -- applied to too many args!
           ; SDoc -> IOEnv (Env TcGblEnv TcLclEnv) SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
info }
      where
        not_fun :: TcType -> Bool
not_fun TcType
ty   -- ty is definitely not an arrow type,
                     -- and cannot conceivably become one
          = case HasCallStack => TcType -> Maybe (TyCon, [TcType])
TcType -> Maybe (TyCon, [TcType])
tcSplitTyConApp_maybe TcType
ty of
              Just (TyCon
tc, [TcType]
_) -> TyCon -> Bool
isAlgTyCon TyCon
tc
              Maybe (TyCon, [TcType])
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 Trac
#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.
-}

badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
badFieldTypes :: [(FieldLabelString, TcType)] -> SDoc
badFieldTypes [(FieldLabelString, TcType)]
prs
  = SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
text String
"Record update for insufficiently polymorphic field"
                         SDoc -> SDoc -> SDoc
<> [(FieldLabelString, TcType)] -> SDoc
forall a. [a] -> SDoc
plural [(FieldLabelString, TcType)]
prs SDoc -> SDoc -> SDoc
<> SDoc
colon)
       ThLevel
2 ([SDoc] -> SDoc
vcat [ FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabelString
f SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty | (FieldLabelString
f,TcType
ty) <- [(FieldLabelString, TcType)]
prs ])

badFieldsUpd
  :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
               -- Field names that don't belong to a single datacon
  -> [ConLike] -- Data cons of the type which the first field name belongs to
  -> SDoc
badFieldsUpd :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds [ConLike]
data_cons
  = SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
text String
"No constructor has all these fields:")
       ThLevel
2 ([FieldLabelString] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [FieldLabelString]
conflictingFields)
          -- See Note [Finding the conflicting fields]
  where
    -- A (preferably small) set of fields such that no constructor contains
    -- all of them.  See Note [Finding the conflicting fields]
    conflictingFields :: [FieldLabelString]
conflictingFields = case [(FieldLabelString, [Bool])]
nonMembers of
        -- nonMember belongs to a different type.
        (FieldLabelString
nonMember, [Bool]
_) : [(FieldLabelString, [Bool])]
_ -> [FieldLabelString
aMember, FieldLabelString
nonMember]
        [] -> let
            -- All of rbinds belong to one type. In this case, repeatedly add
            -- a field to the set until no constructor contains the set.

            -- Each field, together with a list indicating which constructors
            -- have all the fields so far.
            growingSets :: [(FieldLabelString, [Bool])]
            growingSets :: [(FieldLabelString, [Bool])]
growingSets = ((FieldLabelString, [Bool])
 -> (FieldLabelString, [Bool]) -> (FieldLabelString, [Bool]))
-> [(FieldLabelString, [Bool])] -> [(FieldLabelString, [Bool])]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 (FieldLabelString, [Bool])
-> (FieldLabelString, [Bool]) -> (FieldLabelString, [Bool])
forall {a} {a}. (a, [Bool]) -> (a, [Bool]) -> (a, [Bool])
combine [(FieldLabelString, [Bool])]
membership
            combine :: (a, [Bool]) -> (a, [Bool]) -> (a, [Bool])
combine (a
_, [Bool]
setMem) (a
field, [Bool]
fldMem)
              = (a
field, (Bool -> Bool -> Bool) -> [Bool] -> [Bool] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(&&) [Bool]
setMem [Bool]
fldMem)
            in
            -- Fields that don't change the membership status of the set
            -- are redundant and can be dropped.
            ([(FieldLabelString, [Bool])] -> FieldLabelString)
-> [[(FieldLabelString, [Bool])]] -> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldLabelString, [Bool]) -> FieldLabelString
forall a b. (a, b) -> a
fst ((FieldLabelString, [Bool]) -> FieldLabelString)
-> ([(FieldLabelString, [Bool])] -> (FieldLabelString, [Bool]))
-> [(FieldLabelString, [Bool])]
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FieldLabelString, [Bool])] -> (FieldLabelString, [Bool])
forall a. [a] -> a
head) ([[(FieldLabelString, [Bool])]] -> [FieldLabelString])
-> [[(FieldLabelString, [Bool])]] -> [FieldLabelString]
forall a b. (a -> b) -> a -> b
$ ((FieldLabelString, [Bool]) -> (FieldLabelString, [Bool]) -> Bool)
-> [(FieldLabelString, [Bool])] -> [[(FieldLabelString, [Bool])]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ([Bool] -> [Bool] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([Bool] -> [Bool] -> Bool)
-> ((FieldLabelString, [Bool]) -> [Bool])
-> (FieldLabelString, [Bool])
-> (FieldLabelString, [Bool])
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (FieldLabelString, [Bool]) -> [Bool]
forall a b. (a, b) -> b
snd) [(FieldLabelString, [Bool])]
growingSets

    aMember :: FieldLabelString
aMember = ASSERT( not (null members) ) fst (head members)
    ([(FieldLabelString, [Bool])]
members, [(FieldLabelString, [Bool])]
nonMembers) = ((FieldLabelString, [Bool]) -> Bool)
-> [(FieldLabelString, [Bool])]
-> ([(FieldLabelString, [Bool])], [(FieldLabelString, [Bool])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> ((FieldLabelString, [Bool]) -> [Bool])
-> (FieldLabelString, [Bool])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldLabelString, [Bool]) -> [Bool]
forall a b. (a, b) -> b
snd) [(FieldLabelString, [Bool])]
membership

    -- For each field, which constructors contain the field?
    membership :: [(FieldLabelString, [Bool])]
    membership :: [(FieldLabelString, [Bool])]
membership = [(FieldLabelString, [Bool])] -> [(FieldLabelString, [Bool])]
forall {a}. [(a, [Bool])] -> [(a, [Bool])]
sortMembership ([(FieldLabelString, [Bool])] -> [(FieldLabelString, [Bool])])
-> [(FieldLabelString, [Bool])] -> [(FieldLabelString, [Bool])]
forall a b. (a -> b) -> a -> b
$
        (FieldLabelString -> (FieldLabelString, [Bool]))
-> [FieldLabelString] -> [(FieldLabelString, [Bool])]
forall a b. (a -> b) -> [a] -> [b]
map (\FieldLabelString
fld -> (FieldLabelString
fld, (Set FieldLabelString -> Bool) -> [Set FieldLabelString] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (FieldLabelString -> Set FieldLabelString -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FieldLabelString
fld) [Set FieldLabelString]
fieldLabelSets)) ([FieldLabelString] -> [(FieldLabelString, [Bool])])
-> [FieldLabelString] -> [(FieldLabelString, [Bool])]
forall a b. (a -> b) -> a -> b
$
          (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
 -> FieldLabelString)
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FieldLabelString
occNameFS (OccName -> FieldLabelString)
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
    -> OccName)
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
    -> RdrName)
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbiguousFieldOcc GhcTc -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc (AmbiguousFieldOcc GhcTc -> RdrName)
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
    -> AmbiguousFieldOcc GhcTc)
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
-> AmbiguousFieldOcc GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
 -> AmbiguousFieldOcc GhcTc)
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
    -> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> AmbiguousFieldOcc GhcTc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
 -> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc))
-> (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
    -> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
-> LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> GenLocated SrcSpan (AmbiguousFieldOcc GhcTc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc) [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
rbinds

    fieldLabelSets :: [Set.Set FieldLabelString]
    fieldLabelSets :: [Set FieldLabelString]
fieldLabelSets = (ConLike -> Set FieldLabelString)
-> [ConLike] -> [Set FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map ([FieldLabelString] -> Set FieldLabelString
forall a. Ord a => [a] -> Set a
Set.fromList ([FieldLabelString] -> Set FieldLabelString)
-> (ConLike -> [FieldLabelString])
-> ConLike
-> Set FieldLabelString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldLbl Name -> FieldLabelString)
-> [FieldLbl Name] -> [FieldLabelString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel ([FieldLbl Name] -> [FieldLabelString])
-> (ConLike -> [FieldLbl Name]) -> ConLike -> [FieldLabelString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConLike -> [FieldLbl Name]
conLikeFieldLabels) [ConLike]
data_cons

    -- Sort in order of increasing number of True, so that a smaller
    -- conflicting set can be found.
    sortMembership :: [(a, [Bool])] -> [(a, [Bool])]
sortMembership =
      ((ThLevel, (a, [Bool])) -> (a, [Bool]))
-> [(ThLevel, (a, [Bool]))] -> [(a, [Bool])]
forall a b. (a -> b) -> [a] -> [b]
map (ThLevel, (a, [Bool])) -> (a, [Bool])
forall a b. (a, b) -> b
snd ([(ThLevel, (a, [Bool]))] -> [(a, [Bool])])
-> ([(a, [Bool])] -> [(ThLevel, (a, [Bool]))])
-> [(a, [Bool])]
-> [(a, [Bool])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ((ThLevel, (a, [Bool])) -> (ThLevel, (a, [Bool])) -> Ordering)
-> [(ThLevel, (a, [Bool]))] -> [(ThLevel, (a, [Bool]))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (ThLevel -> ThLevel -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ThLevel -> ThLevel -> Ordering)
-> ((ThLevel, (a, [Bool])) -> ThLevel)
-> (ThLevel, (a, [Bool]))
-> (ThLevel, (a, [Bool]))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ThLevel, (a, [Bool])) -> ThLevel
forall a b. (a, b) -> a
fst) ([(ThLevel, (a, [Bool]))] -> [(ThLevel, (a, [Bool]))])
-> ([(a, [Bool])] -> [(ThLevel, (a, [Bool]))])
-> [(a, [Bool])]
-> [(ThLevel, (a, [Bool]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ((a, [Bool]) -> (ThLevel, (a, [Bool])))
-> [(a, [Bool])] -> [(ThLevel, (a, [Bool]))]
forall a b. (a -> b) -> [a] -> [b]
map (\ item :: (a, [Bool])
item@(a
_, [Bool]
membershipRow) -> ([Bool] -> ThLevel
countTrue [Bool]
membershipRow, (a, [Bool])
item))

    countTrue :: [Bool] -> ThLevel
countTrue = (Bool -> Bool) -> [Bool] -> ThLevel
forall a. (a -> Bool) -> [a] -> ThLevel
count Bool -> Bool
forall a. a -> a
id

{-
Note [Finding the conflicting fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
  data A = A {a0, a1 :: Int}
         | B {b0, b1 :: Int}
and we see a record update
  x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
Then we'd like to find the smallest subset of fields that no
constructor has all of.  Here, say, {a0,b0}, or {a0,b1}, etc.
We don't really want to report that no constructor has all of
{a0,a1,b0,b1}, because when there are hundreds of fields it's
hard to see what was really wrong.

We may need more than two fields, though; eg
  data T = A { x,y :: Int, v::Int }
          | B { y,z :: Int, v::Int }
          | C { z,x :: Int, v::Int }
with update
   r { x=e1, y=e2, z=e3 }, we

Finding the smallest subset is hard, so the code here makes
a decent stab, no more.  See #7989.
-}

naughtyRecordSel :: RdrName -> SDoc
naughtyRecordSel :: RdrName -> SDoc
naughtyRecordSel RdrName
sel_id
  = String -> SDoc
text String
"Cannot use record selector" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
sel_id) 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"

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"]

mixedSelectors :: [Id] -> [Id] -> SDoc
mixedSelectors :: [Var] -> [Var] -> SDoc
mixedSelectors data_sels :: [Var]
data_sels@(Var
dc_rep_id:[Var]
_) pat_syn_sels :: [Var]
pat_syn_sels@(Var
ps_rep_id:[Var]
_)
  = PtrString -> SDoc
ptext
      (String -> PtrString
sLit String
"Cannot use a mixture of pattern synonym and record selectors") SDoc -> SDoc -> SDoc
$$
    String -> SDoc
text String
"Record selectors defined by"
      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
rep_dc))
      SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
":"
      SDoc -> SDoc -> SDoc
<+> (Var -> SDoc) -> [Var] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
data_sels SDoc -> SDoc -> SDoc
$$
    String -> SDoc
text String
"Pattern synonym selectors defined by"
      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (PatSyn -> Name
patSynName PatSyn
rep_ps))
      SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
":"
      SDoc -> SDoc -> SDoc
<+> (Var -> SDoc) -> [Var] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
pat_syn_sels
  where
    RecSelPatSyn PatSyn
rep_ps = Var -> RecSelParent
recordSelectorTyCon Var
ps_rep_id
    RecSelData TyCon
rep_dc = Var -> RecSelParent
recordSelectorTyCon Var
dc_rep_id
mixedSelectors [Var]
_ [Var]
_ = String -> SDoc
forall a. String -> a
panic String
"GHC.Tc.Gen.Expr: mixedSelectors emptylists"


missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
missingStrictFields ConLike
con [FieldLabelString]
fields
  = SDoc
header SDoc -> SDoc -> SDoc
<> SDoc
rest
  where
    rest :: SDoc
rest | [FieldLabelString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabelString]
fields = SDoc
Outputable.empty  -- Happens for non-record constructors
                                           -- with strict fields
         | Bool
otherwise   = SDoc
colon SDoc -> SDoc -> SDoc
<+> (FieldLabelString -> SDoc) -> [FieldLabelString] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr [FieldLabelString]
fields

    header :: SDoc
header = String -> SDoc
text String
"Constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
             String -> SDoc
text String
"does not have the required strict field(s)"

missingFields :: ConLike -> [FieldLabelString] -> SDoc
missingFields :: ConLike -> [FieldLabelString] -> SDoc
missingFields ConLike
con [FieldLabelString]
fields
  = SDoc
header SDoc -> SDoc -> SDoc
<> SDoc
rest
  where
    rest :: SDoc
rest | [FieldLabelString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabelString]
fields = SDoc
Outputable.empty
         | Bool
otherwise = SDoc
colon SDoc -> SDoc -> SDoc
<+> (FieldLabelString -> SDoc) -> [FieldLabelString] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr [FieldLabelString]
fields
    header :: SDoc
header = String -> SDoc
text String
"Fields of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
             String -> SDoc
text String
"not initialised"

-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args))

noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
noPossibleParents [LHsRecUpdField GhcRn]
rbinds
  = SDoc -> ThLevel -> SDoc -> SDoc
hang (String -> SDoc
text String
"No type has all these fields:")
       ThLevel
2 ([Located (AmbiguousFieldOcc GhcRn)] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [Located (AmbiguousFieldOcc GhcRn)]
fields)
  where
    fields :: [Located (AmbiguousFieldOcc GhcRn)]
fields = (LHsRecUpdField GhcRn -> Located (AmbiguousFieldOcc GhcRn))
-> [LHsRecUpdField GhcRn] -> [Located (AmbiguousFieldOcc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
 -> Located (AmbiguousFieldOcc GhcRn))
-> (LHsRecUpdField GhcRn
    -> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn))
-> LHsRecUpdField GhcRn
-> Located (AmbiguousFieldOcc GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall l e. GenLocated l e -> e
unLoc) [LHsRecUpdField GhcRn]
rbinds

badOverloadedUpdate :: SDoc
badOverloadedUpdate :: SDoc
badOverloadedUpdate = String -> SDoc
text String
"Record update is ambiguous, and requires a type signature"

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

{-
************************************************************************
*                                                                      *
\subsection{Static Pointers}
*                                                                      *
************************************************************************
-}

-- | A data type to describe why a variable is not closed.
data NotClosedReason = NotLetBoundReason
                     | NotTypeClosed VarSet
                     | NotClosed Name NotClosedReason

-- | Checks if the given name is closed and emits an error if not.
--
-- See Note [Not-closed error messages].
checkClosedInStaticForm :: Name -> TcM ()
checkClosedInStaticForm :: Name -> TcRn ()
checkClosedInStaticForm Name
name = do
    TcTypeEnv
type_env <- TcM TcTypeEnv
getLclTypeEnv
    case TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed TcTypeEnv
type_env Name
name of
      Maybe NotClosedReason
Nothing -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just NotClosedReason
reason -> SDoc -> TcRn ()
addErrTc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> NotClosedReason -> SDoc
explain Name
name NotClosedReason
reason
  where
    -- See Note [Checking closedness].
    checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
    checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed TcTypeEnv
type_env Name
n = TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (Name -> UniqSet Name
unitNameSet Name
n) Name
n

    checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
    checkLoop :: TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env UniqSet Name
visited Name
n = do
      -- The @visited@ set is an accumulating parameter that contains the set of
      -- visited nodes, so we avoid repeating cycles in the traversal.
      case TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
type_env Name
n of
        Just (ATcId { tct_id :: TcTyThing -> Var
tct_id = Var
tcid, tct_info :: TcTyThing -> IdBindingInfo
tct_info = IdBindingInfo
info }) -> case IdBindingInfo
info of
          IdBindingInfo
ClosedLet   -> Maybe NotClosedReason
forall a. Maybe a
Nothing
          IdBindingInfo
NotLetBound -> NotClosedReason -> Maybe NotClosedReason
forall a. a -> Maybe a
Just NotClosedReason
NotLetBoundReason
          NonClosedLet UniqSet Name
fvs Bool
type_closed -> [NotClosedReason] -> Maybe NotClosedReason
forall a. [a] -> Maybe a
listToMaybe ([NotClosedReason] -> Maybe NotClosedReason)
-> [NotClosedReason] -> Maybe NotClosedReason
forall a b. (a -> b) -> a -> b
$
            -- Look for a non-closed variable in fvs
            [ Name -> NotClosedReason -> NotClosedReason
NotClosed Name
n' NotClosedReason
reason
            | Name
n' <- UniqSet Name -> [Name]
nameSetElemsStable UniqSet Name
fvs
            , Bool -> Bool
not (Name -> UniqSet Name -> Bool
elemNameSet Name
n' UniqSet Name
visited)
            , Just NotClosedReason
reason <- [TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (UniqSet Name -> Name -> UniqSet Name
extendNameSet UniqSet Name
visited Name
n') Name
n']
            ] [NotClosedReason] -> [NotClosedReason] -> [NotClosedReason]
forall a. [a] -> [a] -> [a]
++
            if Bool
type_closed then
              []
            else
              -- We consider non-let-bound variables easier to figure out than
              -- non-closed types, so we report non-closed types to the user
              -- only if we cannot spot the former.
              [ VarSet -> NotClosedReason
NotTypeClosed (VarSet -> NotClosedReason) -> VarSet -> NotClosedReason
forall a b. (a -> b) -> a -> b
$ TcType -> VarSet
tyCoVarsOfType (Var -> TcType
idType Var
tcid) ]
        -- The binding is closed.
        Maybe TcTyThing
_ -> Maybe NotClosedReason
forall a. Maybe a
Nothing

    -- Converts a reason into a human-readable sentence.
    --
    -- @explain name reason@ starts with
    --
    -- "<name> is used in a static form but it is not closed because it"
    --
    -- and then follows a list of causes. For each id in the path, the text
    --
    -- "uses <id> which"
    --
    -- is appended, yielding something like
    --
    -- "uses <id> which uses <id1> which uses <id2> which"
    --
    -- until the end of the path is reached, which is reported as either
    --
    -- "is not let-bound"
    --
    -- when the final node is not let-bound, or
    --
    -- "has a non-closed type because it contains the type variables:
    -- v1, v2, v3"
    --
    -- when the final node has a non-closed type.
    --
    explain :: Name -> NotClosedReason -> SDoc
    explain :: Name -> NotClosedReason -> SDoc
explain Name
name NotClosedReason
reason =
      SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is used in a static form but it is not closed"
                        SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"because it"
                        SDoc -> SDoc -> SDoc
$$
                        [SDoc] -> SDoc
sep (NotClosedReason -> [SDoc]
causes NotClosedReason
reason)

    causes :: NotClosedReason -> [SDoc]
    causes :: NotClosedReason -> [SDoc]
causes NotClosedReason
NotLetBoundReason = [String -> SDoc
text String
"is not let-bound."]
    causes (NotTypeClosed VarSet
vs) =
      [ String -> SDoc
text String
"has a non-closed type because it contains the"
      , String -> SDoc
text String
"type variables:" SDoc -> SDoc -> SDoc
<+>
        VarSet -> ([Var] -> SDoc) -> SDoc
pprVarSet VarSet
vs ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([Var] -> [SDoc]) -> [Var] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> ([Var] -> [SDoc]) -> [Var] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> SDoc) -> [Var] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (Var -> SDoc) -> Var -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr))
      ]
    causes (NotClosed Name
n NotClosedReason
reason) =
      let msg :: SDoc
msg = String -> SDoc
text String
"uses" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"which"
       in case NotClosedReason
reason of
            NotClosed Name
_ NotClosedReason
_ -> SDoc
msg SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: NotClosedReason -> [SDoc]
causes NotClosedReason
reason
            NotClosedReason
_   -> let ([SDoc]
xs0, [SDoc]
xs1) = ThLevel -> [SDoc] -> ([SDoc], [SDoc])
forall a. ThLevel -> [a] -> ([a], [a])
splitAt ThLevel
1 ([SDoc] -> ([SDoc], [SDoc])) -> [SDoc] -> ([SDoc], [SDoc])
forall a b. (a -> b) -> a -> b
$ NotClosedReason -> [SDoc]
causes NotClosedReason
reason
                    in (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SDoc
msg SDoc -> SDoc -> SDoc
<+>) [SDoc]
xs0 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
xs1

-- Note [Not-closed error messages]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- When variables in a static form are not closed, we go through the trouble
-- of explaining why they aren't.
--
-- Thus, the following program
--
-- > {-# LANGUAGE StaticPointers #-}
-- > module M where
-- >
-- > f x = static g
-- >   where
-- >     g = h
-- >     h = x
--
-- produces the error
--
--    'g' is used in a static form but it is not closed because it
--    uses 'h' which uses 'x' which is not let-bound.
--
-- And a program like
--
-- > {-# LANGUAGE StaticPointers #-}
-- > module M where
-- >
-- > import Data.Typeable
-- > import GHC.StaticPtr
-- >
-- > f :: Typeable a => a -> StaticPtr TypeRep
-- > f x = const (static (g undefined)) (h x)
-- >   where
-- >     g = h
-- >     h = typeOf
--
-- produces the error
--
--    'g' is used in a static form but it is not closed because it
--    uses 'h' which has a non-closed type because it contains the
--    type variables: 'a'
--

-- Note [Checking closedness]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- @checkClosed@ checks if a binding is closed and returns a reason if it is
-- not.
--
-- The bindings define a graph where the nodes are ids, and there is an edge
-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free
-- variables.
--
-- When @n@ is not closed, it has to exist in the graph some node reachable
-- from @n@ that it is not a let-bound variable or that it has a non-closed
-- type. Thus, the "reason" is a path from @n@ to this offending node.
--
-- When @n@ is not closed, we traverse the graph reachable from @n@ to build
-- the reason.
--