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

\section[TcExpr]{Typecheck an expression}
-}

{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
                tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
                tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
                tcCheckId,
                addExprErrCtxt,
                getFixedTyVars ) where

#include "HsVersions.h"

import GhcPrelude

import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
import THNames( liftStringName, liftName )

import GHC.Hs
import TcHsSyn
import TcRnMonad
import TcUnify
import BasicTypes
import Inst
import TcBinds          ( chooseInferredQuantifiers, tcLocalBinds )
import TcSigs           ( tcUserTypeSig, tcInstSig )
import TcSimplify       ( simplifyInfer, InferMode(..) )
import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )
import FamInstEnv       ( FamInstEnvs )
import RnEnv            ( addUsedGRE )
import RnUtils          ( addNameClashErrRn, unknownSubordinateErr )
import TcEnv
import TcArrows
import TcMatches
import TcHsType
import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
import TcPat
import TcMType
import TcOrigin
import TcType
import Id
import IdInfo
import ConLike
import DataCon
import PatSyn
import Name
import NameEnv
import NameSet
import RdrName
import TyCon
import TyCoRep
import TyCoPpr
import TyCoSubst (substTyWithInScope)
import Type
import TcEvidence
import VarSet
import TysWiredIn
import TysPrim( intPrimTy )
import PrimOp( tagToEnumKey )
import PrelNames
import DynFlags
import SrcLoc
import Util
import VarEnv  ( emptyTidyEnv, mkInScopeSet )
import ListSetOps
import Maybes
import Outputable
import FastString
import Control.Monad
import Class(classTyCon)
import UniqSet ( 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}
*                                                                      *
************************************************************************
-}

tcPolyExpr, tcPolyExprNC
  :: LHsExpr GhcRn         -- Expression to type check
  -> TcSigmaType           -- Expected type (could be a polytype)
  -> TcM (LHsExpr GhcTcId) -- Generalised expr with expected type

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

tcPolyExpr :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr   LHsExpr GhcRn
expr TcSigmaType
res_ty = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tc_poly_expr LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
res_ty)
tcPolyExprNC :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExprNC LHsExpr GhcRn
expr TcSigmaType
res_ty = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tc_poly_expr_nc LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
res_ty)

-- these versions take an ExpType
tc_poly_expr, tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType
                              -> TcM (LHsExpr GhcTcId)
tc_poly_expr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tc_poly_expr LHsExpr GhcRn
expr ExpSigmaType
res_ty
  = LHsExpr GhcRn -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. LHsExpr GhcRn -> TcM a -> TcM a
addExprErrCtxt LHsExpr GhcRn
expr (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
    do { String -> SDoc -> TcRn ()
traceTc String
"tcPolyExpr" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty); LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tc_poly_expr_nc LHsExpr GhcRn
expr ExpSigmaType
res_ty }

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

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

tcMonoExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
  = SDoc -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> SDoc
exprCtxt LHsExpr GhcRn
expr) (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
    LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExprNC LHsExpr GhcRn
expr ExpSigmaType
res_ty

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

---------------
tcInferSigma, tcInferSigmaNC :: LHsExpr GhcRn -> TcM ( LHsExpr GhcTcId
                                                    , TcSigmaType )
-- Infer a *sigma*-type.
tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigma LHsExpr GhcRn
expr = SDoc
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> SDoc
exprCtxt LHsExpr GhcRn
expr) (LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigmaNC LHsExpr GhcRn
expr)

tcInferSigmaNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigmaNC (L SrcSpan
loc HsExpr GhcRn
expr)
  = SrcSpan
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTcId, TcSigmaType)
 -> TcM (LHsExpr GhcTcId, TcSigmaType))
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
    do { (HsExpr GhcTcId
expr', TcSigmaType
sigma) <- (ExpSigmaType -> TcM (HsExpr GhcTcId))
-> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
tcInferNoInst (HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcExpr HsExpr GhcRn
expr)
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTcId
expr', TcSigmaType
sigma) }

tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcRhoType)
-- Infer a *rho*-type. The return type is always (shallowly) instantiated.
tcInferRho :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRho LHsExpr GhcRn
expr = SDoc
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> SDoc
exprCtxt LHsExpr GhcRn
expr) (LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRhoNC LHsExpr GhcRn
expr)

tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRhoNC LHsExpr GhcRn
expr
  = do { (LHsExpr GhcTcId
expr', TcSigmaType
sigma) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigmaNC LHsExpr GhcRn
expr
       ; (HsWrapper
wrap, TcSigmaType
rho) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
expr) TcSigmaType
sigma
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrap LHsExpr GhcTcId
expr', TcSigmaType
rho) }


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

NB: The res_ty is always deeply skolemised.
-}

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

tcExpr e :: HsExpr GhcRn
e@(HsApp {})     ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcApp1 HsExpr GhcRn
e ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsAppType {}) ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcApp1 HsExpr GhcRn
e ExpSigmaType
res_ty

tcExpr e :: HsExpr GhcRn
e@(HsLit XLitE GhcRn
x HsLit GhcRn
lit) ExpSigmaType
res_ty
  = do { let lit_ty :: TcSigmaType
lit_ty = HsLit GhcRn -> TcSigmaType
forall (p :: Pass). HsLit (GhcPass p) -> TcSigmaType
hsLitType HsLit GhcRn
lit
       ; HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResult HsExpr GhcRn
e (XLitE GhcTcId -> HsLit GhcTcId -> HsExpr GhcTcId
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
XLitE GhcTcId
x (HsLit GhcRn -> HsLit GhcTcId
forall a b. ConvertIdX a b => HsLit a -> HsLit b
convertLit HsLit GhcRn
lit)) TcSigmaType
lit_ty ExpSigmaType
res_ty }

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

tcExpr (HsSCC XSCC GhcRn
x SourceText
src StringLiteral
lbl LHsExpr GhcRn
expr) ExpSigmaType
res_ty
  = do { LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSCC GhcTcId
-> SourceText -> StringLiteral -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p.
XSCC p -> SourceText -> StringLiteral -> LHsExpr p -> HsExpr p
HsSCC XSCC GhcRn
XSCC GhcTcId
x SourceText
src StringLiteral
lbl LHsExpr GhcTcId
expr') }

tcExpr (HsTickPragma XTickPragma GhcRn
x SourceText
src (StringLiteral, (Int, Int), (Int, Int))
info ((SourceText, SourceText), (SourceText, SourceText))
srcInfo LHsExpr GhcRn
expr) ExpSigmaType
res_ty
  = do { LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTickPragma GhcTcId
-> SourceText
-> (StringLiteral, (Int, Int), (Int, Int))
-> ((SourceText, SourceText), (SourceText, SourceText))
-> LHsExpr GhcTcId
-> HsExpr GhcTcId
forall p.
XTickPragma p
-> SourceText
-> (StringLiteral, (Int, Int), (Int, Int))
-> ((SourceText, SourceText), (SourceText, SourceText))
-> LHsExpr p
-> HsExpr p
HsTickPragma XTickPragma GhcRn
XTickPragma GhcTcId
x SourceText
src (StringLiteral, (Int, Int), (Int, Int))
info ((SourceText, SourceText), (SourceText, SourceText))
srcInfo LHsExpr GhcTcId
expr') }

tcExpr (HsCoreAnn XCoreAnn GhcRn
x SourceText
src StringLiteral
lbl LHsExpr GhcRn
expr) ExpSigmaType
res_ty
  = do  { LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
expr ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCoreAnn GhcTcId
-> SourceText -> StringLiteral -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p.
XCoreAnn p -> SourceText -> StringLiteral -> LHsExpr p -> HsExpr p
HsCoreAnn XCoreAnn GhcRn
XCoreAnn GhcTcId
x SourceText
src StringLiteral
lbl LHsExpr GhcTcId
expr') }

tcExpr (HsOverLit XOverLitE GhcRn
x HsOverLit GhcRn
lit) ExpSigmaType
res_ty
  = do  { HsOverLit GhcTcId
lit' <- HsOverLit GhcRn -> ExpSigmaType -> TcM (HsOverLit GhcTcId)
newOverloadedLit HsOverLit GhcRn
lit ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOverLitE GhcTcId -> HsOverLit GhcTcId -> HsExpr GhcTcId
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcRn
XOverLitE GhcTcId
x HsOverLit GhcTcId
lit') }

tcExpr (NegApp XNegApp GhcRn
x LHsExpr GhcRn
expr SyntaxExpr GhcRn
neg_expr) ExpSigmaType
res_ty
  = do  { (LHsExpr GhcTcId
expr', SyntaxExpr GhcTcId
neg_expr')
            <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
NegateOrigin SyntaxExpr GhcRn
neg_expr [SyntaxOpType
SynAny] ExpSigmaType
res_ty (([TcSigmaType] -> TcM (LHsExpr GhcTcId))
 -> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId, SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
               \[TcSigmaType
arg_ty] ->
               LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
expr (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
arg_ty)
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XNegApp GhcTcId
-> LHsExpr GhcTcId -> SyntaxExpr GhcTcId -> HsExpr GhcTcId
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp XNegApp GhcRn
XNegApp GhcTcId
x LHsExpr GhcTcId
expr' SyntaxExpr GhcTcId
neg_expr') }

tcExpr e :: HsExpr GhcRn
e@(HsIPVar XIPVar GhcRn
_ HsIPName
x) ExpSigmaType
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.) -}
         TcSigmaType
ip_ty <- TcM TcSigmaType
newOpenFlexiTyVarTy
       ; let ip_name :: TcSigmaType
ip_name = FastString -> TcSigmaType
mkStrLitTy (HsIPName -> FastString
hsIPNameFS HsIPName
x)
       ; Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
       ; EvVar
ip_var <- CtOrigin -> TcSigmaType -> TcM EvVar
emitWantedEvVar CtOrigin
origin (Class -> [TcSigmaType] -> TcSigmaType
mkClassPred Class
ipClass [TcSigmaType
ip_name, TcSigmaType
ip_ty])
       ; HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResult HsExpr GhcRn
e
                   (Class
-> TcSigmaType -> TcSigmaType -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
Class
-> TcSigmaType
-> TcSigmaType
-> HsExpr (GhcPass id)
-> HsExpr (GhcPass id)
fromDict Class
ipClass TcSigmaType
ip_name TcSigmaType
ip_ty (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExtField
noExtField (SrcSpanLess (Located EvVar) -> Located EvVar
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located EvVar)
EvVar
ip_var)))
                   TcSigmaType
ip_ty ExpSigmaType
res_ty }
  where
  -- Coerces a dictionary for `IP "x" t` into `t`.
  fromDict :: Class
-> TcSigmaType
-> TcSigmaType
-> HsExpr (GhcPass id)
-> HsExpr (GhcPass id)
fromDict Class
ipClass TcSigmaType
x TcSigmaType
ty = HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap (HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id))
-> HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$
                          TcSigmaType -> TcCoercionR
unwrapIP (TcSigmaType -> TcCoercionR) -> TcSigmaType -> TcCoercionR
forall a b. (a -> b) -> a -> b
$ Class -> [TcSigmaType] -> TcSigmaType
mkClassPred Class
ipClass [TcSigmaType
x,TcSigmaType
ty]
  origin :: CtOrigin
origin = HsIPName -> CtOrigin
IPOccOrigin HsIPName
x

tcExpr e :: HsExpr GhcRn
e@(HsOverLabel XOverLabel GhcRn
_ Maybe (IdP GhcRn)
mb_fromLabel FastString
l) ExpSigmaType
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 -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcExpr (SrcSpan -> Name -> HsExpr GhcRn
applyFromLabel SrcSpan
loc Name
IdP GhcRn
fromLabel) ExpSigmaType
res_ty
           Maybe (IdP GhcRn)
Nothing -> do { Class
isLabelClass <- Name -> TcM Class
tcLookupClass Name
isLabelClassName
                         ; TcSigmaType
alpha <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
                         ; let pred :: TcSigmaType
pred = Class -> [TcSigmaType] -> TcSigmaType
mkClassPred Class
isLabelClass [TcSigmaType
lbl, TcSigmaType
alpha]
                         ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
                         ; EvVar
var <- CtOrigin -> TcSigmaType -> TcM EvVar
emitWantedEvVar CtOrigin
origin TcSigmaType
pred
                         ; HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResult HsExpr GhcRn
e
                                       (TcSigmaType -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcSigmaType -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
fromDict TcSigmaType
pred (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExtField
noExtField (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc EvVar
var)))
                                        TcSigmaType
alpha ExpSigmaType
res_ty } }
  where
  -- Coerces a dictionary for `IsLabel "x" t` into `t`,
  -- or `HasField "x" r a into `r -> a`.
  fromDict :: TcSigmaType -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
fromDict TcSigmaType
pred = HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap (HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id))
-> HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> HsWrapper) -> TcCoercionR -> HsWrapper
forall a b. (a -> b) -> a -> b
$ TcSigmaType -> TcCoercionR
unwrapIP TcSigmaType
pred
  origin :: CtOrigin
origin = FastString -> CtOrigin
OverLabelOrigin FastString
l
  lbl :: TcSigmaType
lbl = FastString -> TcSigmaType
mkStrLitTy FastString
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 XAppTypeE GhcRn
NoExtField
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 XVar GhcRn
NoExtField
noExtField (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
fromLabel)))
         (GenLocated SrcSpan (HsType GhcRn)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType 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 XTyLit GhcRn
NoExtField
noExtField (SourceText -> FastString -> HsTyLit
HsStrTy SourceText
NoSourceText FastString
l))))

tcExpr (HsLam XLam GhcRn
x MatchGroup GhcRn (LHsExpr GhcRn)
match) ExpSigmaType
res_ty
  = do  { (MatchGroup GhcTcId (LHsExpr GhcTcId)
match', HsWrapper
wrap) <- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
tcMatchLambda SDoc
herald TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
match ExpSigmaType
res_ty
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (XLam GhcTcId
-> MatchGroup GhcTcId (LHsExpr GhcTcId) -> HsExpr GhcTcId
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcRn
XLam GhcTcId
x MatchGroup GhcTcId (LHsExpr GhcTcId)
match')) }
  where
    match_ctxt :: TcMatchCtxt HsExpr
match_ctxt = MC :: forall (body :: * -> *).
HsMatchContext Name
-> (Located (body GhcRn)
    -> ExpSigmaType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext Name
mc_what = HsMatchContext Name
forall id. HsMatchContext id
LambdaExpr, mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcBody }
    herald :: SDoc
herald = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The lambda expression" SDoc -> SDoc -> SDoc
<+>
                   SDoc -> SDoc
quotes (Depth -> SDoc -> SDoc
pprSetDepth (Int -> Depth
PartWay Int
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) ExpSigmaType
res_ty
  = do { (MatchGroup GhcTcId (LHsExpr GhcTcId)
matches', HsWrapper
wrap)
           <- SDoc
-> TcMatchCtxt HsExpr
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
tcMatchLambda SDoc
msg TcMatchCtxt HsExpr
match_ctxt MatchGroup GhcRn (LHsExpr GhcRn)
matches ExpSigmaType
res_ty
           -- The laziness annotation is because we don't want to fail here
           -- if there are multiple arguments
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ XLamCase GhcTcId
-> MatchGroup GhcTcId (LHsExpr GhcTcId) -> HsExpr GhcTcId
forall p. XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLamCase XLamCase GhcRn
XLamCase GhcTcId
x MatchGroup GhcTcId (LHsExpr GhcTcId)
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 Name
-> (Located (body GhcRn)
    -> ExpSigmaType -> TcM (Located (body GhcTcId)))
-> TcMatchCtxt body
MC { mc_what :: HsMatchContext Name
mc_what = HsMatchContext Name
forall id. HsMatchContext id
CaseAlt, mc_body :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
mc_body = LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcBody }

tcExpr e :: HsExpr GhcRn
e@(ExprWithTySig XExprWithTySig GhcRn
_ LHsExpr GhcRn
expr LHsSigWcType (NoGhcTc GhcRn)
sig_ty) ExpSigmaType
res_ty
  = do { let loc :: SrcSpan
loc = GenLocated SrcSpan (HsType GhcRn) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsSigWcType GhcRn -> GenLocated SrcSpan (HsType GhcRn)
forall pass. LHsSigWcType pass -> LHsType pass
hsSigWcType LHsSigWcType (NoGhcTc GhcRn)
LHsSigWcType GhcRn
sig_ty)
       ; 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 (NoGhcTc GhcRn)
LHsSigWcType GhcRn
sig_ty Maybe Name
forall a. Maybe a
Nothing
       ; (LHsExpr GhcTcId
expr', TcSigmaType
poly_ty) <- LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcExprSig LHsExpr GhcRn
expr TcIdSigInfo
sig_info
       ; let expr'' :: HsExpr GhcTcId
expr'' = XExprWithTySig GhcTcId
-> LHsExpr GhcTcId
-> LHsSigWcType (NoGhcTc GhcTcId)
-> HsExpr GhcTcId
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcTcId
NoExtField
noExtField LHsExpr GhcTcId
expr' LHsSigWcType (NoGhcTc GhcRn)
LHsSigWcType (NoGhcTc GhcTcId)
sig_ty
       ; HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResult HsExpr GhcRn
e HsExpr GhcTcId
expr'' TcSigmaType
poly_ty ExpSigmaType
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) ExpSigmaType
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 GhcTcId
arg1', TcSigmaType
arg1_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigma 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, [TcSigmaType
arg2_sigma], TcSigmaType
op_res_ty) <-
           SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
matchActualFunTys SDoc
doc CtOrigin
orig1 (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
arg1)) Int
1 TcSigmaType
arg1_ty

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

       ; LHsExpr GhcTcId
arg2' <- LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg LHsExpr GhcRn
op LHsExpr GhcRn
arg2 TcSigmaType
arg2_sigma Int
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)
-> TcSigmaType -> TcSigmaType -> 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
$ TcSigmaType -> NewHsTypeX
NHsCoreTy TcSigmaType
arg2_sigma))
                        (HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
tcTypeKind TcSigmaType
arg2_sigma) TcSigmaType
liftedTypeKind
           -- Ignore the evidence. arg2_sigma must have type * or #,
           -- because we know (arg2_sigma -> op_res_ty) is well-kinded
           -- (because otherwise matchActualFunTys 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

       ; EvVar
op_id  <- Name -> TcM EvVar
tcLookupId Name
IdP GhcRn
op_name
       ; let op' :: LHsExpr GhcTcId
op' = SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap ([TcSigmaType] -> HsWrapper
mkWpTyApps [ HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
getRuntimeRep TcSigmaType
op_res_ty
                                               , TcSigmaType
arg2_sigma
                                               , TcSigmaType
op_res_ty])
                                   (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExtField
noExtField (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv EvVar
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 GhcTcId
expr' = XOpApp GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> HsExpr GhcTcId
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
XOpApp GhcTcId
fix (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrap_arg1 LHsExpr GhcTcId
arg1') LHsExpr GhcTcId
op' LHsExpr GhcTcId
arg2'

       ; HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResult HsExpr GhcRn
expr HsExpr GhcTcId
expr' TcSigmaType
op_res_ty ExpSigmaType
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 -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
arg1)
    -- See Note [Disambiguating record fields]
  = do { TcSigmaType
sig_tc_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM TcSigmaType
tcHsSigWcType UserTypeCtxt
ExprSigCtxt LHsSigWcType GhcRn
sig_ty
       ; Name
sel_name <- Located RdrName -> TcSigmaType -> TcM Name
disambiguateSelector Located RdrName
lbl TcSigmaType
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 XRecFld GhcRn
NoExtField
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 -> ExpSigmaType -> TcM (HsExpr GhcTcId)
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) ExpSigmaType
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)
       ; (HsWrapper
wrap, LHsExpr GhcTcId
op', [HsValArg LHsExpr GhcTcId
arg1', HsValArg LHsExpr GhcTcId
arg2'])
           <- Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> SDoc
mk_op_msg LHsExpr GhcRn
op)
                     LHsExpr GhcRn
op [LHsExpr GhcRn -> LHsExprArgIn
forall tm ty. tm -> HsArg tm ty
HsValArg LHsExpr GhcRn
arg1, LHsExpr GhcRn -> LHsExprArgIn
forall tm ty. tm -> HsArg tm ty
HsValArg LHsExpr GhcRn
arg2] ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ XOpApp GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> HsExpr GhcTcId
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
XOpApp GhcTcId
fix LHsExpr GhcTcId
arg1' LHsExpr GhcTcId
op' LHsExpr GhcTcId
arg2') }

-- 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) ExpSigmaType
res_ty
  = do { (LHsExpr GhcTcId
op', TcSigmaType
op_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferFun LHsExpr GhcRn
op
       ; (HsWrapper
wrap_fun, [TcSigmaType
arg1_ty, TcSigmaType
arg2_ty], TcSigmaType
op_res_ty)
                  <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
matchActualFunTys (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 -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
op)) Int
2 TcSigmaType
op_ty
       ; HsWrapper
wrap_res <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR CtOrigin
SectionOrigin (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr)
                                 (TcSigmaType -> TcSigmaType -> TcSigmaType
mkVisFunTy TcSigmaType
arg1_ty TcSigmaType
op_res_ty) ExpSigmaType
res_ty
       ; LHsExpr GhcTcId
arg2' <- LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg LHsExpr GhcRn
op LHsExpr GhcRn
arg2 TcSigmaType
arg2_ty Int
2
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap_res (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
                  XSectionR GhcTcId
-> LHsExpr GhcTcId -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionR XSectionR GhcRn
XSectionR GhcTcId
x (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrap_fun LHsExpr GhcTcId
op') LHsExpr GhcTcId
arg2' ) }
  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) ExpSigmaType
res_ty
  = do { (LHsExpr GhcTcId
op', TcSigmaType
op_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferFun LHsExpr GhcRn
op
       ; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags      -- Note [Left sections]
       ; let n_reqd_args :: Int
n_reqd_args | Extension -> DynFlags -> Bool
xopt Extension
LangExt.PostfixOperators DynFlags
dflags = Int
1
                         | Bool
otherwise                            = Int
2

       ; (HsWrapper
wrap_fn, (TcSigmaType
arg1_ty:[TcSigmaType]
arg_tys), TcSigmaType
op_res_ty)
           <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
matchActualFunTys (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 -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
op))
                                Int
n_reqd_args TcSigmaType
op_ty
       ; HsWrapper
wrap_res <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR CtOrigin
SectionOrigin (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr)
                                 ([TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [TcSigmaType]
arg_tys TcSigmaType
op_res_ty) ExpSigmaType
res_ty
       ; LHsExpr GhcTcId
arg1' <- LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg LHsExpr GhcRn
op LHsExpr GhcRn
arg1 TcSigmaType
arg1_ty Int
1
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap_res (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
                  XSectionL GhcTcId
-> LHsExpr GhcTcId -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p
SectionL XSectionL GhcRn
XSectionL GhcTcId
x LHsExpr GhcTcId
arg1' (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrap_fn LHsExpr GhcTcId
op') ) }
  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) ExpSigmaType
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 :: Int
arity  = [LHsTupArg GhcRn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsTupArg GhcRn]
tup_args
             tup_tc :: TyCon
tup_tc = Boxity -> Int -> TyCon
tupleTyCon Boxity
boxity Int
arity
               -- NB: tupleTyCon doesn't flatten 1-tuples
               -- See Note [Don't flatten tuples from HsSyn] in MkCore
       ; TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
       ; (TcCoercionR
coi, [TcSigmaType]
arg_tys) <- TyCon -> TcSigmaType -> TcM (TcCoercionR, [TcSigmaType])
matchExpectedTyConApp TyCon
tup_tc TcSigmaType
res_ty
                           -- Unboxed tuples have RuntimeRep vars, which we
                           -- don't care about here
                           -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
       ; let arg_tys' :: [TcSigmaType]
arg_tys' = case Boxity
boxity of Boxity
Unboxed -> Int -> [TcSigmaType] -> [TcSigmaType]
forall a. Int -> [a] -> [a]
drop Int
arity [TcSigmaType]
arg_tys
                                       Boxity
Boxed   -> [TcSigmaType]
arg_tys
       ; [LHsTupArg GhcTcId]
tup_args1 <- [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId]
tcTupArgs [LHsTupArg GhcRn]
tup_args [TcSigmaType]
arg_tys'
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcCoercionR -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo TcCoercionR
coi (XExplicitTuple GhcTcId
-> [LHsTupArg GhcTcId] -> Boxity -> HsExpr GhcTcId
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTcId
x [LHsTupArg GhcTcId]
tup_args1 Boxity
boxity) }

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

       ; [TcSigmaType]
arg_tys <- case Boxity
boxity of
           { Boxity
Boxed   -> Int -> TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
newFlexiTyVarTys Int
arity TcSigmaType
liftedTypeKind
           ; Boxity
Unboxed -> Int
-> TcM TcSigmaType -> IOEnv (Env TcGblEnv TcLclEnv) [TcSigmaType]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
arity TcM TcSigmaType
newOpenFlexiTyVarTy }
       ; let actual_res_ty :: TcSigmaType
actual_res_ty
                 = [TcSigmaType] -> TcSigmaType -> TcSigmaType
mkVisFunTys [TcSigmaType
ty | (TcSigmaType
ty, (L SrcSpan
_ (Missing XMissing GhcRn
_))) <- [TcSigmaType]
arg_tys [TcSigmaType]
-> [LHsTupArg GhcRn] -> [(TcSigmaType, LHsTupArg GhcRn)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [LHsTupArg GhcRn]
tup_args]
                            (Boxity -> [TcSigmaType] -> TcSigmaType
mkTupleTy1 Boxity
boxity [TcSigmaType]
arg_tys)
                   -- See Note [Don't flatten tuples from HsSyn] in MkCore

       ; HsWrapper
wrap <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR (String -> CtOrigin
Shouldn'tHappenOrigin String
"ExpTuple")
                             (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr)
                             TcSigmaType
actual_res_ty ExpSigmaType
res_ty

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

       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (XExplicitTuple GhcTcId
-> [LHsTupArg GhcTcId] -> Boxity -> HsExpr GhcTcId
forall p. XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XExplicitTuple GhcRn
XExplicitTuple GhcTcId
x [LHsTupArg GhcTcId]
tup_args1 Boxity
boxity) }

tcExpr (ExplicitSum XExplicitSum GhcRn
_ Int
alt Int
arity LHsExpr GhcRn
expr) ExpSigmaType
res_ty
  = do { let sum_tc :: TyCon
sum_tc = Int -> TyCon
sumTyCon Int
arity
       ; TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
       ; (TcCoercionR
coi, [TcSigmaType]
arg_tys) <- TyCon -> TcSigmaType -> TcM (TcCoercionR, [TcSigmaType])
matchExpectedTyConApp TyCon
sum_tc TcSigmaType
res_ty
       ; -- Drop levity vars, we don't care about them here
         let arg_tys' :: [TcSigmaType]
arg_tys' = Int -> [TcSigmaType] -> [TcSigmaType]
forall a. Int -> [a] -> [a]
drop Int
arity [TcSigmaType]
arg_tys
       ; LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr ([TcSigmaType]
arg_tys' [TcSigmaType] -> Int -> TcSigmaType
forall a. Outputable a => [a] -> Int -> a
`getNth` (Int
alt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcCoercionR -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo TcCoercionR
coi (XExplicitSum GhcTcId
-> Int -> Int -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XExplicitSum p -> Int -> Int -> LHsExpr p -> HsExpr p
ExplicitSum [TcSigmaType]
XExplicitSum GhcTcId
arg_tys' Int
alt Int
arity LHsExpr GhcTcId
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) ExpSigmaType
res_ty
  = case Maybe (SyntaxExpr GhcRn)
witness of
      Maybe (SyntaxExpr GhcRn)
Nothing   -> do  { TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
                       ; (TcCoercionR
coi, TcSigmaType
elt_ty) <- TcSigmaType -> TcM (TcCoercionR, TcSigmaType)
matchExpectedListTy TcSigmaType
res_ty
                       ; [LHsExpr GhcTcId]
exprs' <- (LHsExpr GhcRn -> TcM (LHsExpr GhcTcId))
-> [LHsExpr GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) [LHsExpr GhcTcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcSigmaType -> LHsExpr GhcRn -> TcM (LHsExpr GhcTcId)
tc_elt TcSigmaType
elt_ty) [LHsExpr GhcRn]
exprs
                       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                         TcCoercionR -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcCoercionR -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo TcCoercionR
coi (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> [LHsExpr GhcTcId]
-> HsExpr GhcTcId
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList TcSigmaType
XExplicitList GhcTcId
elt_ty Maybe (SyntaxExpr GhcTcId)
forall a. Maybe a
Nothing [LHsExpr GhcTcId]
exprs' }

      Just SyntaxExpr GhcRn
fln -> do { (([LHsExpr GhcTcId]
exprs', TcSigmaType
elt_ty), SyntaxExpr GhcTcId
fln')
                         <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM ([LHsExpr GhcTcId], TcSigmaType))
-> TcM (([LHsExpr GhcTcId], TcSigmaType), SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
ListOrigin SyntaxExpr GhcRn
fln
                                       [TcSigmaType -> SyntaxOpType
synKnownType TcSigmaType
intTy, SyntaxOpType
SynList] ExpSigmaType
res_ty (([TcSigmaType] -> TcM ([LHsExpr GhcTcId], TcSigmaType))
 -> TcM (([LHsExpr GhcTcId], TcSigmaType), SyntaxExpr GhcTcId))
-> ([TcSigmaType] -> TcM ([LHsExpr GhcTcId], TcSigmaType))
-> TcM (([LHsExpr GhcTcId], TcSigmaType), SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                            \ [TcSigmaType
elt_ty] ->
                            do { [LHsExpr GhcTcId]
exprs' <-
                                    (LHsExpr GhcRn -> TcM (LHsExpr GhcTcId))
-> [LHsExpr GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) [LHsExpr GhcTcId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcSigmaType -> LHsExpr GhcRn -> TcM (LHsExpr GhcTcId)
tc_elt TcSigmaType
elt_ty) [LHsExpr GhcRn]
exprs
                               ; ([LHsExpr GhcTcId], TcSigmaType)
-> TcM ([LHsExpr GhcTcId], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsExpr GhcTcId]
exprs', TcSigmaType
elt_ty) }

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

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

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

tcExpr (HsCase XCase GhcRn
x LHsExpr GhcRn
scrut MatchGroup GhcRn (LHsExpr GhcRn)
matches) ExpSigmaType
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
          (LHsExpr GhcTcId
scrut', TcSigmaType
scrut_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRho LHsExpr GhcRn
scrut

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

tcExpr (HsIf XIf GhcRn
x Maybe (SyntaxExpr GhcRn)
Nothing LHsExpr GhcRn
pred LHsExpr GhcRn
b1 LHsExpr GhcRn
b2) ExpSigmaType
res_ty    -- Ordinary 'if'
  = do { LHsExpr GhcTcId
pred' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
pred (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
boolTy)
       ; ExpSigmaType
res_ty <- ExpSigmaType -> TcM ExpSigmaType
tauifyExpType ExpSigmaType
res_ty
           -- Just like Note [Case branches must never infer a non-tau type]
           -- in TcMatches (See #10619)

       ; LHsExpr GhcTcId
b1' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
b1 ExpSigmaType
res_ty
       ; LHsExpr GhcTcId
b2' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
b2 ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XIf GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> HsExpr GhcTcId
forall p.
XIf p
-> Maybe (SyntaxExpr p)
-> LHsExpr p
-> LHsExpr p
-> LHsExpr p
-> HsExpr p
HsIf XIf GhcRn
XIf GhcTcId
x Maybe (SyntaxExpr GhcTcId)
forall a. Maybe a
Nothing LHsExpr GhcTcId
pred' LHsExpr GhcTcId
b1' LHsExpr GhcTcId
b2') }

tcExpr (HsIf XIf GhcRn
x (Just SyntaxExpr GhcRn
fun) LHsExpr GhcRn
pred LHsExpr GhcRn
b1 LHsExpr GhcRn
b2) ExpSigmaType
res_ty
  = do { ((LHsExpr GhcTcId
pred', LHsExpr GhcTcId
b1', LHsExpr GhcTcId
b2'), SyntaxExpr GhcTcId
fun')
           <- CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType]
    -> TcM (LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId))
-> TcM
     ((LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId),
      SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
IfOrigin SyntaxExpr GhcRn
fun [SyntaxOpType
SynAny, SyntaxOpType
SynAny, SyntaxOpType
SynAny] ExpSigmaType
res_ty (([TcSigmaType]
  -> TcM (LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId))
 -> TcM
      ((LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId),
       SyntaxExpr GhcTcId))
-> ([TcSigmaType]
    -> TcM (LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId))
-> TcM
     ((LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId),
      SyntaxExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
              \ [TcSigmaType
pred_ty, TcSigmaType
b1_ty, TcSigmaType
b2_ty] ->
              do { LHsExpr GhcTcId
pred' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
pred TcSigmaType
pred_ty
                 ; LHsExpr GhcTcId
b1'   <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
b1   TcSigmaType
b1_ty
                 ; LHsExpr GhcTcId
b2'   <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
b2   TcSigmaType
b2_ty
                 ; (LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId)
-> TcM (LHsExpr GhcTcId, LHsExpr GhcTcId, LHsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcTcId
pred', LHsExpr GhcTcId
b1', LHsExpr GhcTcId
b2') }
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XIf GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> LHsExpr GhcTcId
-> HsExpr GhcTcId
forall p.
XIf p
-> Maybe (SyntaxExpr p)
-> LHsExpr p
-> LHsExpr p
-> LHsExpr p
-> HsExpr p
HsIf XIf GhcRn
XIf GhcTcId
x (SyntaxExpr GhcTcId -> Maybe (SyntaxExpr GhcTcId)
forall a. a -> Maybe a
Just SyntaxExpr GhcTcId
fun') LHsExpr GhcTcId
pred' LHsExpr GhcTcId
b1' LHsExpr GhcTcId
b2') }

tcExpr (HsMultiIf XMultiIf GhcRn
_ [LGRHS GhcRn (LHsExpr GhcRn)]
alts) ExpSigmaType
res_ty
  = do { ExpSigmaType
res_ty <- if [LGRHS GhcRn (LHsExpr GhcRn)] -> Bool
forall a. [a] -> Bool
isSingleton [LGRHS GhcRn (LHsExpr GhcRn)]
alts
                   then ExpSigmaType -> TcM ExpSigmaType
forall (m :: * -> *) a. Monad m => a -> m a
return ExpSigmaType
res_ty
                   else ExpSigmaType -> TcM ExpSigmaType
tauifyExpType ExpSigmaType
res_ty
             -- Just like TcMatches
             -- Note [Case branches must never infer a non-tau type]

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

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

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

-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
-- See Note [Grand plan for static forms] in 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) ExpSigmaType
res_ty
  = do  { TcSigmaType
res_ty          <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
        ; (TcCoercionR
co, (TcSigmaType
p_ty, TcSigmaType
expr_ty)) <- TcSigmaType -> TcM (TcCoercionR, (TcSigmaType, TcSigmaType))
matchExpectedAppTy TcSigmaType
res_ty
        ; (LHsExpr GhcTcId
expr', WantedConstraints
lie)    <- TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId, WantedConstraints)
forall a. TcM a -> TcM (a, WantedConstraints)
captureConstraints (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId, WantedConstraints))
-> TcM (LHsExpr GhcTcId)
-> TcM (LHsExpr GhcTcId, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
            SDoc -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the body of a static form:")
                             Int
2 (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
expr)
                       ) (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
            LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExprNC LHsExpr GhcRn
expr TcSigmaType
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
        ; EvVar
_ <- CtOrigin -> TcSigmaType -> TcM EvVar
emitWantedEvVar CtOrigin
StaticOrigin (TcSigmaType -> TcM EvVar) -> TcSigmaType -> TcM EvVar
forall a b. (a -> b) -> a -> b
$
                  TyCon -> [TcSigmaType] -> TcSigmaType
mkTyConApp (Class -> TyCon
classTyCon Class
typeableClass)
                             [TcSigmaType
liftedTypeKind, TcSigmaType
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 GhcTcId
fromStaticPtr <- CtOrigin -> Name -> [TcSigmaType] -> TcM (HsExpr GhcTcId)
newMethodFromName CtOrigin
StaticOrigin Name
fromStaticPtrName
                                             [TcSigmaType
p_ty]
        ; let wrap :: HsWrapper
wrap = [TcSigmaType] -> HsWrapper
mkWpTyApps [TcSigmaType
expr_ty]
        ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ TcCoercionR -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
TcCoercionR -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo TcCoercionR
co (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ XApp GhcTcId
-> LHsExpr GhcTcId -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp XApp GhcTcId
NoExtField
noExtField
                                         (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsExpr GhcTcId -> LHsExpr GhcTcId)
-> HsExpr GhcTcId -> LHsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap HsExpr GhcTcId
fromStaticPtr)
                                         (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XStatic GhcTcId -> LHsExpr GhcTcId -> HsExpr GhcTcId
forall p. XStatic p -> LHsExpr p -> HsExpr p
HsStatic XStatic GhcRn
XStatic GhcTcId
fvs LHsExpr GhcTcId
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 }) ExpSigmaType
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 GhcTcId
con_expr, TcSigmaType
con_sigma) <- Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId Name
IdP GhcRn
con_name
        ; (HsWrapper
con_wrap, TcSigmaType
con_tau) <-
            CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (Name -> CtOrigin
OccurrenceOf Name
IdP GhcRn
con_name) TcSigmaType
con_sigma
              -- a shallow instantiation should really be enough for
              -- a data constructor.
        ; let arity :: Int
arity = ConLike -> Int
conLikeArity ConLike
con_like
              Right ([TcSigmaType]
arg_tys, TcSigmaType
actual_res_ty) = Int -> TcSigmaType -> Either Int ([TcSigmaType], TcSigmaType)
tcSplitFunTysN Int
arity TcSigmaType
con_tau
        ; case ConLike -> Maybe EvVar
conLikeWrapId_maybe ConLike
con_like of
               Maybe EvVar
Nothing -> Name -> TcM (HsExpr GhcTcId)
forall name a. Outputable name => name -> TcM a
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con_like)
               Just EvVar
con_id -> do {
                  HsWrapper
res_wrap <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR (String -> CtOrigin
Shouldn'tHappenOrigin String
"RecordCon")
                                          (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr) TcSigmaType
actual_res_ty ExpSigmaType
res_ty
                ; HsRecordBinds GhcTcId
rbinds' <- ConLike
-> [TcSigmaType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTcId)
tcRecordBinds ConLike
con_like [TcSigmaType]
arg_tys HsRecordBinds GhcRn
rbinds
                ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                  HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
res_wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
                  RecordCon :: forall p.
XRecordCon p -> Located (IdP p) -> HsRecordBinds p -> HsExpr p
RecordCon { rcon_ext :: XRecordCon GhcTcId
rcon_ext = RecordConTc :: ConLike -> HsExpr GhcTcId -> RecordConTc
RecordConTc
                                 { rcon_con_like :: ConLike
rcon_con_like = ConLike
con_like
                                 , rcon_con_expr :: HsExpr GhcTcId
rcon_con_expr = HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
con_wrap HsExpr GhcTcId
con_expr }
                            , rcon_con_name :: Located (IdP GhcTcId)
rcon_con_name = SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc EvVar
con_id
                            , rcon_flds :: HsRecordBinds GhcTcId
rcon_flds = HsRecordBinds GhcTcId
rbinds' } } }

{-
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 TcTyClsDecls), 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 }) ExpSigmaType
res_ty
  = ASSERT( notNull rbnds )
    do  { -- STEP -2: typecheck the record_expr, the record to be updated
          (LHsExpr GhcTcId
record_expr', TcSigmaType
record_rho) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRho LHsExpr GhcRn
record_expr

        -- STEP -1  See Note [Disambiguating record fields]
        -- After this we know that rbinds is unambiguous
        ; [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds <- LHsExpr GhcRn
-> TcSigmaType
-> [LHsRecUpdField GhcRn]
-> ExpSigmaType
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
disambiguateRecordBinds LHsExpr GhcRn
record_expr TcSigmaType
record_rho [LHsRecUpdField GhcRn]
rbnds ExpSigmaType
res_ty
        ; let upd_flds :: [AmbiguousFieldOcc GhcTcId]
upd_flds = (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
 -> AmbiguousFieldOcc GhcTcId)
-> [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> [AmbiguousFieldOcc GhcTcId]
forall a b. (a -> b) -> [a] -> [b]
map (Located (AmbiguousFieldOcc GhcTcId) -> AmbiguousFieldOcc GhcTcId
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located (AmbiguousFieldOcc GhcTcId) -> AmbiguousFieldOcc GhcTcId)
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
    -> Located (AmbiguousFieldOcc GhcTcId))
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> AmbiguousFieldOcc GhcTcId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcTcId)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
 -> Located (AmbiguousFieldOcc GhcTcId))
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
    -> HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcTcId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds
              upd_fld_occs :: [FastString]
upd_fld_occs = (AmbiguousFieldOcc GhcTcId -> FastString)
-> [AmbiguousFieldOcc GhcTcId] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FastString
occNameFS (OccName -> FastString)
-> (AmbiguousFieldOcc GhcTcId -> OccName)
-> AmbiguousFieldOcc GhcTcId
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (AmbiguousFieldOcc GhcTcId -> RdrName)
-> AmbiguousFieldOcc GhcTcId
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbiguousFieldOcc GhcTcId -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc) [AmbiguousFieldOcc GhcTcId]
upd_flds
              sel_ids :: [EvVar]
sel_ids      = (AmbiguousFieldOcc GhcTcId -> EvVar)
-> [AmbiguousFieldOcc GhcTcId] -> [EvVar]
forall a b. (a -> b) -> [a] -> [b]
map AmbiguousFieldOcc GhcTcId -> EvVar
selectorAmbiguousFieldOcc [AmbiguousFieldOcc GhcTcId]
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 GhcTcId) (LHsExpr GhcRn)
fld <- [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds,
                           -- Excludes class ops
                           let L SrcSpan
loc EvVar
sel_id = HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> Located EvVar
forall arg.
HsRecField' (AmbiguousFieldOcc GhcTcId) arg -> Located EvVar
hsRecUpdFieldId (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> SrcSpanLess
     (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
fld),
                           Bool -> Bool
not (EvVar -> Bool
isRecordSelector EvVar
sel_id),
                           let fld_name :: Name
fld_name = EvVar -> Name
idName EvVar
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 ([EvVar]
data_sels, [EvVar]
pat_syn_sels) =
                (EvVar -> Bool) -> [EvVar] -> ([EvVar], [EvVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition EvVar -> Bool
isDataConRecordSelector [EvVar]
sel_ids
        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )
        ; Bool -> SDoc -> TcRn ()
checkTc ( [EvVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvVar]
data_sels Bool -> Bool -> Bool
|| [EvVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvVar]
pat_syn_sels )
                  ( [EvVar] -> [EvVar] -> SDoc
mixedSelectors [EvVar]
data_sels [EvVar]
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)
              EvVar
sel_id : [EvVar]
_  = [EvVar]
sel_ids

              mtycon :: Maybe TyCon
              mtycon :: Maybe TyCon
mtycon = case EvVar -> IdDetails
idDetails EvVar
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 EvVar -> IdDetails
idDetails EvVar
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] -> [FastString] -> [ConLike]
conLikesWithFields [ConLike]
con_likes [FastString]
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 GhcTcId) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds [ConLike]
con_likes)

        -- Take apart a representative constructor
        ; let con1 :: ConLike
con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
              ([EvVar]
con1_tvs, [EvVar]
_, [EqSpec]
_, [TcSigmaType]
_prov_theta, [TcSigmaType]
req_theta, [TcSigmaType]
con1_arg_tys, TcSigmaType
_)
                 = ConLike
-> ([EvVar], [EvVar], [EqSpec], [TcSigmaType], [TcSigmaType],
    [TcSigmaType], TcSigmaType)
conLikeFullSig ConLike
con1
              con1_flds :: [FastString]
con1_flds   = (FieldLbl Name -> FastString) -> [FieldLbl Name] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel ([FieldLbl Name] -> [FastString])
-> [FieldLbl Name] -> [FastString]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con1
              con1_tv_tys :: [TcSigmaType]
con1_tv_tys = [EvVar] -> [TcSigmaType]
mkTyVarTys [EvVar]
con1_tvs
              con1_res_ty :: TcSigmaType
con1_res_ty = case Maybe TyCon
mtycon of
                              Just TyCon
tc -> TyCon -> [TcSigmaType] -> TcSigmaType
mkFamilyTyConApp TyCon
tc [TcSigmaType]
con1_tv_tys
                              Maybe TyCon
Nothing -> ConLike -> [TcSigmaType] -> TcSigmaType
conLikeResTy ConLike
con1 [TcSigmaType]
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 EvVar -> Bool
forall a. Maybe a -> Bool
isJust (Maybe EvVar -> Bool) -> Maybe EvVar -> Bool
forall a b. (a -> b) -> a -> b
$ ConLike -> Maybe EvVar
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 :: [(FastString, TcSigmaType)]
flds1_w_tys  = String
-> [FastString] -> [TcSigmaType] -> [(FastString, TcSigmaType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"tcExpr:RecConUpd" [FastString]
con1_flds [TcSigmaType]
con1_arg_tys
              bad_upd_flds :: [(FastString, TcSigmaType)]
bad_upd_flds = ((FastString, TcSigmaType) -> Bool)
-> [(FastString, TcSigmaType)] -> [(FastString, TcSigmaType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FastString, TcSigmaType) -> Bool
bad_fld [(FastString, TcSigmaType)]
flds1_w_tys
              con1_tv_set :: VarSet
con1_tv_set  = [EvVar] -> VarSet
mkVarSet [EvVar]
con1_tvs
              bad_fld :: (FastString, TcSigmaType) -> Bool
bad_fld (FastString
fld, TcSigmaType
ty) = FastString
fld FastString -> [FastString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FastString]
upd_fld_occs Bool -> Bool -> Bool
&&
                                      Bool -> Bool
not (TcSigmaType -> VarSet
tyCoVarsOfType TcSigmaType
ty VarSet -> VarSet -> Bool
`subVarSet` VarSet
con1_tv_set)
        ; Bool -> SDoc -> TcRn ()
checkTc ([(FastString, TcSigmaType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FastString, TcSigmaType)]
bad_upd_flds) ([(FastString, TcSigmaType)] -> SDoc
badFieldTypes [(FastString, TcSigmaType)]
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 = [FastString] -> [EvVar] -> [ConLike] -> VarSet
getFixedTyVars [FastString]
upd_fld_occs [EvVar]
con1_tvs [ConLike]
relevant_cons
              is_fixed_tv :: EvVar -> Bool
is_fixed_tv EvVar
tv = EvVar
tv EvVar -> VarSet -> Bool
`elemVarSet` VarSet
fixed_tvs

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

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

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

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

        ; HsWrapper
wrap_res <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR (HsExpr GhcRn -> CtOrigin
exprCtOrigin HsExpr GhcRn
expr)
                                  (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr) TcSigmaType
rec_res_ty ExpSigmaType
res_ty
        ; TcCoercionR
co_scrut <- Maybe (HsExpr GhcRn)
-> TcSigmaType -> TcSigmaType -> TcM TcCoercionR
unifyType (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
record_expr)) TcSigmaType
record_rho TcSigmaType
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 GhcTcId]
rbinds'      <- ConLike
-> [TcSigmaType]
-> [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTcId]
tcRecordUpd ConLike
con1 [TcSigmaType]
con1_arg_tys' [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds

        -- STEP 6: Deal with the stupid theta
        ; let theta' :: [TcSigmaType]
theta' = TCvSubst -> [TcSigmaType] -> [TcSigmaType]
substThetaUnchecked TCvSubst
scrut_subst (ConLike -> [TcSigmaType]
conLikeStupidTheta ConLike
con1)
        ; CtOrigin -> [TcSigmaType] -> TcRn ()
instStupidTheta CtOrigin
RecordUpdOrigin [TcSigmaType]
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 -> [TcSigmaType] -> [TcCoercionR] -> TcCoercionR
mkTcUnbranchedAxInstCo CoAxiom Unbranched
co_con [TcSigmaType]
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' :: [TcSigmaType]
req_theta' = TCvSubst -> [TcSigmaType] -> [TcSigmaType]
substThetaUnchecked TCvSubst
scrut_subst [TcSigmaType]
req_theta
        ; HsWrapper
req_wrap <- CtOrigin -> [TcSigmaType] -> TcM HsWrapper
instCallConstraints CtOrigin
RecordUpdOrigin [TcSigmaType]
req_theta'

        -- Phew!
        ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId -> TcM (HsExpr GhcTcId))
-> HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
          HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap_res (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$
          RecordUpd :: forall p.
XRecordUpd p -> LHsExpr p -> [LHsRecUpdField p] -> HsExpr p
RecordUpd { rupd_expr :: LHsExpr GhcTcId
rupd_expr
                          = HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
fam_co (TcCoercionR -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
TcCoercionR -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrapCo TcCoercionR
co_scrut LHsExpr GhcTcId
record_expr')
                    , rupd_flds :: [LHsRecUpdField GhcTcId]
rupd_flds = [LHsRecUpdField GhcTcId]
rbinds'
                    , rupd_ext :: XRecordUpd GhcTcId
rupd_ext = RecordUpdTc :: [ConLike]
-> [TcSigmaType] -> [TcSigmaType] -> HsWrapper -> RecordUpdTc
RecordUpdTc
                        { rupd_cons :: [ConLike]
rupd_cons = [ConLike]
relevant_cons
                        , rupd_in_tys :: [TcSigmaType]
rupd_in_tys = [TcSigmaType]
scrut_inst_tys
                        , rupd_out_tys :: [TcSigmaType]
rupd_out_tys = [TcSigmaType]
result_inst_tys
                        , rupd_wrap :: HsWrapper
rupd_wrap = HsWrapper
req_wrap }} }

tcExpr e :: HsExpr GhcRn
e@(HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
f) ExpSigmaType
res_ty
    = HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcCheckRecSelId HsExpr GhcRn
e AmbiguousFieldOcc GhcRn
f ExpSigmaType
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) ExpSigmaType
res_ty
  = Maybe (SyntaxExpr GhcRn)
-> ArithSeqInfo GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcArithSeq Maybe (SyntaxExpr GhcRn)
witness ArithSeqInfo GhcRn
seq ExpSigmaType
res_ty

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

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

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

tcExpr HsExpr GhcRn
other ExpSigmaType
_ = String -> SDoc -> TcM (HsExpr GhcTcId)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcMonoExpr" (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

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

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

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

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

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

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

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

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

-- HsArg is defined in GHC.Hs.Types

wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn)
           => LHsExpr (GhcPass id)
           -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)]
           -> LHsExpr (GhcPass id)
wrapHsArgs :: LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs LHsExpr (GhcPass id)
f []                     = LHsExpr (GhcPass id)
f
wrapHsArgs LHsExpr (GhcPass id)
f (HsValArg  LHsExpr (GhcPass id)
a : [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args)   = LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs (LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp LHsExpr (GhcPass id)
f LHsExpr (GhcPass id)
a)          [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args
wrapHsArgs LHsExpr (GhcPass id)
f (HsTypeArg SrcSpan
_ HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
t : [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args) = LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs (LHsExpr (GhcPass id)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> LHsExpr (GhcPass id)
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> LHsExpr (GhcPass id)
mkHsAppType LHsExpr (GhcPass id)
f HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
t)      [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args
wrapHsArgs LHsExpr (GhcPass id)
f (HsArgPar SrcSpan
sp : [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args)   = LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs (SrcSpan -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)
forall l e. l -> e -> GenLocated l e
L SrcSpan
sp (HsExpr (GhcPass id) -> LHsExpr (GhcPass id))
-> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)
forall a b. (a -> b) -> a -> b
$ XPar (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XPar (GhcPass id)
NoExtField
noExtField LHsExpr (GhcPass id)
f) [HsArg
   (LHsExpr (GhcPass id))
   (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
args

isHsValArg :: HsArg tm ty -> Bool
isHsValArg :: HsArg tm ty -> Bool
isHsValArg (HsValArg {})  = Bool
True
isHsValArg (HsTypeArg {}) = Bool
False
isHsValArg (HsArgPar {})  = Bool
False

isArgPar :: HsArg tm ty -> Bool
isArgPar :: HsArg tm ty -> Bool
isArgPar (HsArgPar {})  = Bool
True
isArgPar (HsValArg {})  = Bool
False
isArgPar (HsTypeArg {}) = Bool
False

isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d)
isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d)
isArgPar_maybe (HsArgPar SrcSpan
sp) = HsArg c d -> Maybe (HsArg c d)
forall a. a -> Maybe a
Just (HsArg c d -> Maybe (HsArg c d)) -> HsArg c d -> Maybe (HsArg c d)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsArg c d
forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar SrcSpan
sp
isArgPar_maybe HsArg a b
_ = Maybe (HsArg c d)
forall a. Maybe a
Nothing

type LHsExprArgIn  = HsArg (LHsExpr GhcRn)   (LHsWcType GhcRn)
type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn)

tcApp1 :: HsExpr GhcRn  -- either HsApp or HsAppType
       -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcApp1 :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcApp1 HsExpr GhcRn
e ExpSigmaType
res_ty
  = do { (HsWrapper
wrap, LHsExpr GhcTcId
fun, [LHsExprArgOut]
args) <- Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp Maybe SDoc
forall a. Maybe a
Nothing (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcRn)
HsExpr GhcRn
e) [] ExpSigmaType
res_ty
       ; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTcId -> SrcSpanLess (LHsExpr GhcTcId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcTcId -> SrcSpanLess (LHsExpr GhcTcId))
-> LHsExpr GhcTcId -> SrcSpanLess (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTcId -> [LHsExprArgOut] -> LHsExpr GhcTcId
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs LHsExpr GhcTcId
fun [LHsExprArgOut]
args) }

tcApp :: Maybe SDoc  -- like "The function `f' is applied to"
                     -- or leave out to get exactly that message
      -> LHsExpr GhcRn -> [LHsExprArgIn] -- Function and args
      -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
           -- (wrap, fun, args). For an ordinary function application,
           -- these should be assembled as (wrap (fun args)).
           -- But OpApp is slightly different, so that's why the caller
           -- must assemble

tcApp :: Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp Maybe SDoc
m_herald (L SrcSpan
sp (HsPar XPar GhcRn
_ LHsExpr GhcRn
fun)) [LHsExprArgIn]
args ExpSigmaType
res_ty
  = Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp Maybe SDoc
m_herald LHsExpr GhcRn
fun (SrcSpan -> LHsExprArgIn
forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar SrcSpan
sp LHsExprArgIn -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. a -> [a] -> [a]
: [LHsExprArgIn]
args) ExpSigmaType
res_ty

tcApp Maybe SDoc
m_herald (L SrcSpan
_ (HsApp XApp GhcRn
_ LHsExpr GhcRn
fun LHsExpr GhcRn
arg1)) [LHsExprArgIn]
args ExpSigmaType
res_ty
  = Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp Maybe SDoc
m_herald LHsExpr GhcRn
fun (LHsExpr GhcRn -> LHsExprArgIn
forall tm ty. tm -> HsArg tm ty
HsValArg LHsExpr GhcRn
arg1 LHsExprArgIn -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. a -> [a] -> [a]
: [LHsExprArgIn]
args) ExpSigmaType
res_ty

tcApp Maybe SDoc
m_herald (L SrcSpan
_ (HsAppType XAppTypeE GhcRn
_ LHsExpr GhcRn
fun LHsWcType (NoGhcTc GhcRn)
ty1)) [LHsExprArgIn]
args ExpSigmaType
res_ty
  = Maybe SDoc
-> LHsExpr GhcRn
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcApp Maybe SDoc
m_herald LHsExpr GhcRn
fun (SrcSpan
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> LHsExprArgIn
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
noSrcSpan LHsWcType (NoGhcTc GhcRn)
HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
ty1 LHsExprArgIn -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. a -> [a] -> [a]
: [LHsExprArgIn]
args) ExpSigmaType
res_ty

tcApp Maybe SDoc
m_herald fun :: LHsExpr GhcRn
fun@(L SrcSpan
loc (HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
fld_lbl)) [LHsExprArgIn]
args ExpSigmaType
res_ty
  | Ambiguous XAmbiguous GhcRn
_ Located RdrName
lbl        <- AmbiguousFieldOcc GhcRn
fld_lbl  -- Still ambiguous
  , HsValArg (L SrcSpan
_ HsExpr GhcRn
arg) : [LHsExprArgIn]
_ <- (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. (a -> Bool) -> [a] -> [a]
filterOut LHsExprArgIn -> Bool
forall tm ty. HsArg tm ty -> 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 { TcSigmaType
sig_tc_ty <- UserTypeCtxt -> LHsSigWcType GhcRn -> TcM TcSigmaType
tcHsSigWcType UserTypeCtxt
ExprSigCtxt LHsSigWcType GhcRn
sig_ty
       ; Name
sel_name  <- Located RdrName -> TcSigmaType -> TcM Name
disambiguateSelector Located RdrName
lbl TcSigmaType
sig_tc_ty
       ; (HsExpr GhcTcId
tc_fun, TcSigmaType
fun_ty) <- AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferRecSelId (XUnambiguous GhcRn -> Located RdrName -> AmbiguousFieldOcc GhcRn
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous Name
XUnambiguous GhcRn
sel_name Located RdrName
lbl)
       ; Maybe SDoc
-> LHsExpr GhcRn
-> LHsExpr GhcTcId
-> TcSigmaType
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcFunApp Maybe SDoc
m_herald LHsExpr GhcRn
fun (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTcId
tc_fun) TcSigmaType
fun_ty [LHsExprArgIn]
args ExpSigmaType
res_ty }

tcApp Maybe SDoc
_m_herald (L SrcSpan
loc (HsVar XVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
fun_id))) [LHsExprArgIn]
args ExpSigmaType
res_ty
  -- Special typing rule for tagToEnum#
  | Name
IdP GhcRn
fun_id Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
  , Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
  = SrcSpan
-> Name
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcTagToEnum SrcSpan
loc Name
IdP GhcRn
fun_id [LHsExprArgIn]
args ExpSigmaType
res_ty
  where
    n_val_args :: Int
n_val_args = (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> Int
forall a. (a -> Bool) -> [a] -> Int
count LHsExprArgIn -> Bool
forall tm ty. HsArg tm ty -> Bool
isHsValArg [LHsExprArgIn]
args

tcApp Maybe SDoc
m_herald LHsExpr GhcRn
fun [LHsExprArgIn]
args ExpSigmaType
res_ty
  = do { (LHsExpr GhcTcId
tc_fun, TcSigmaType
fun_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferFun LHsExpr GhcRn
fun
       ; Maybe SDoc
-> LHsExpr GhcRn
-> LHsExpr GhcTcId
-> TcSigmaType
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcFunApp Maybe SDoc
m_herald LHsExpr GhcRn
fun LHsExpr GhcTcId
tc_fun TcSigmaType
fun_ty [LHsExprArgIn]
args ExpSigmaType
res_ty }

---------------------
tcFunApp :: Maybe SDoc  -- like "The function `f' is applied to"
                        -- or leave out to get exactly that message
         -> LHsExpr GhcRn                  -- Renamed function
         -> LHsExpr GhcTcId -> TcSigmaType -- Function and its type
         -> [LHsExprArgIn]                 -- Arguments
         -> ExpRhoType                     -- Overall result type
         -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
            -- (wrapper-for-result, fun, args)
            -- For an ordinary function application,
            -- these should be assembled as wrap_res[ fun args ]
            -- But OpApp is slightly different, so that's why the caller
            -- must assemble

-- tcFunApp deals with the general case;
-- the special cases are handled by tcApp
tcFunApp :: Maybe SDoc
-> LHsExpr GhcRn
-> LHsExpr GhcTcId
-> TcSigmaType
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcFunApp Maybe SDoc
m_herald LHsExpr GhcRn
rn_fun LHsExpr GhcTcId
tc_fun TcSigmaType
fun_sigma [LHsExprArgIn]
rn_args ExpSigmaType
res_ty
  = do { let orig :: CtOrigin
orig = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
rn_fun

       ; String -> SDoc -> TcRn ()
traceTc String
"tcFunApp" (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
rn_fun SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
fun_sigma SDoc -> SDoc -> SDoc
$$ [LHsExprArgIn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsExprArgIn]
rn_args SDoc -> SDoc -> SDoc
$$ ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty)
       ; (HsWrapper
wrap_fun, [LHsExprArgOut]
tc_args, TcSigmaType
actual_res_ty)
           <- LHsExpr GhcRn
-> TcSigmaType
-> CtOrigin
-> [LHsExprArgIn]
-> SDoc
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
tcArgs LHsExpr GhcRn
rn_fun TcSigmaType
fun_sigma CtOrigin
orig [LHsExprArgIn]
rn_args
                     (Maybe SDoc
m_herald Maybe SDoc -> SDoc -> SDoc
forall a. Maybe a -> a -> a
`orElse` LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc
mk_app_msg LHsExpr GhcRn
rn_fun [LHsExprArgIn]
rn_args)

            -- this is just like tcWrapResult, but the types don't line
            -- up to call that function
       ; HsWrapper
wrap_res <- Bool
-> HsExpr GhcRn
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
-> TcM HsWrapper
forall a.
Bool
-> HsExpr GhcRn -> TcSigmaType -> ExpSigmaType -> TcM a -> TcM a
addFunResCtxt Bool
True (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
rn_fun) TcSigmaType
actual_res_ty ExpSigmaType
res_ty (TcM HsWrapper -> TcM HsWrapper) -> TcM HsWrapper -> TcM HsWrapper
forall a b. (a -> b) -> a -> b
$
                     CtOrigin
-> UserTypeCtxt
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeDS_NC_O CtOrigin
orig UserTypeCtxt
GenSigCtxt
                       (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (HsExpr GhcRn -> Maybe (HsExpr GhcRn))
-> HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn))
-> LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcRn -> [LHsExprArgIn] -> LHsExpr GhcRn
forall (id :: Pass).
(NoGhcTc (GhcPass id) ~ GhcRn) =>
LHsExpr (GhcPass id)
-> [HsArg
      (LHsExpr (GhcPass id))
      (HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn)))]
-> LHsExpr (GhcPass id)
wrapHsArgs LHsExpr GhcRn
rn_fun [LHsExprArgIn]
rn_args)
                       TcSigmaType
actual_res_ty ExpSigmaType
res_ty

       ; (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrap_res, HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
wrap_fun LHsExpr GhcTcId
tc_fun, [LHsExprArgOut]
tc_args) }

mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc
mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc
mk_app_msg LHsExpr GhcRn
fun [LHsExprArgIn]
args = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
what SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
expr)
                          , String -> SDoc
text String
"is applied to"]
  where
    what :: String
what | [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))]
type_app_args = String
"function"
         | Bool
otherwise          = String
"expression"
    -- Include visible type arguments (but not other arguments) in the herald.
    -- See Note [Herald for matchExpectedFunTys] in TcUnify.
    expr :: LHsExpr GhcRn
expr = LHsExpr GhcRn
-> [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))]
-> LHsExpr GhcRn
mkHsAppTypes LHsExpr GhcRn
fun [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))]
type_app_args
    type_app_args :: [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))]
type_app_args = [HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty | HsTypeArg SrcSpan
_ HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty <- [LHsExprArgIn]
args]

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"

----------------
tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
-- Infer type of a function
tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferFun (L SrcSpan
loc (HsVar XVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
name)))
  = do { (HsExpr GhcTcId
fun, TcSigmaType
ty) <- SrcSpan
-> TcM (HsExpr GhcTcId, TcSigmaType)
-> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId Name
IdP GhcRn
name)
               -- Don't wrap a context around a plain Id
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTcId
fun, TcSigmaType
ty) }

tcInferFun (L SrcSpan
loc (HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
f))
  = do { (HsExpr GhcTcId
fun, TcSigmaType
ty) <- SrcSpan
-> TcM (HsExpr GhcTcId, TcSigmaType)
-> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferRecSelId AmbiguousFieldOcc GhcRn
f)
               -- Don't wrap a context around a plain Id
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsExpr GhcTcId
fun, TcSigmaType
ty) }

tcInferFun LHsExpr GhcRn
fun
  = LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigma LHsExpr GhcRn
fun
      -- NB: tcInferSigma; see TcUnify
      -- Note [Deep instantiation of InferResult] in TcUnify


----------------
-- | Type-check the arguments to a function, possibly including visible type
-- applications
tcArgs :: LHsExpr GhcRn   -- ^ The function itself (for err msgs only)
       -> TcSigmaType    -- ^ the (uninstantiated) type of the function
       -> CtOrigin       -- ^ the origin for the function's type
       -> [LHsExprArgIn] -- ^ the args
       -> SDoc           -- ^ the herald for matchActualFunTys
       -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
          -- ^ (a wrapper for the function, the tc'd args, result type)
tcArgs :: LHsExpr GhcRn
-> TcSigmaType
-> CtOrigin
-> [LHsExprArgIn]
-> SDoc
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
tcArgs LHsExpr GhcRn
fun TcSigmaType
orig_fun_ty CtOrigin
fun_orig [LHsExprArgIn]
orig_args SDoc
herald
  = [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go [] Int
1 TcSigmaType
orig_fun_ty [LHsExprArgIn]
orig_args
  where
    -- Don't count visible type arguments when determining how many arguments
    -- an expression is given in an arity mismatch error, since visible type
    -- arguments reported as a part of the expression herald itself.
    -- See Note [Herald for matchExpectedFunTys] in TcUnify.
    orig_expr_args_arity :: Int
orig_expr_args_arity = (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> Int
forall a. (a -> Bool) -> [a] -> Int
count LHsExprArgIn -> Bool
forall tm ty. HsArg tm ty -> 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 LHsExpr GhcRn
fun of
          L SrcSpan
_ (HsUnboundVar {}) -> Bool
True
          LHsExpr GhcRn
_                     -> Bool
False

    go :: [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go [TcSigmaType]
_ Int
_ TcSigmaType
fun_ty [] = (HsWrapper, [LHsExprArgOut], TcSigmaType)
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, [], TcSigmaType
fun_ty)

    go [TcSigmaType]
acc_args Int
n TcSigmaType
fun_ty (HsArgPar SrcSpan
sp : [LHsExprArgIn]
args)
      = do { (HsWrapper
inner_wrap, [LHsExprArgOut]
args', TcSigmaType
res_ty) <- [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go [TcSigmaType]
acc_args Int
n TcSigmaType
fun_ty [LHsExprArgIn]
args
           ; (HsWrapper, [LHsExprArgOut], TcSigmaType)
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
inner_wrap, SrcSpan -> LHsExprArgOut
forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar SrcSpan
sp LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args', TcSigmaType
res_ty)
           }

    go [TcSigmaType]
acc_args Int
n TcSigmaType
fun_ty (HsTypeArg SrcSpan
l HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg : [LHsExprArgIn]
args)
      | Bool
fun_is_out_of_scope   -- See Note [VTA for out-of-scope functions]
      = [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go [TcSigmaType]
acc_args (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) TcSigmaType
fun_ty [LHsExprArgIn]
args

      | Bool
otherwise
      = do { (HsWrapper
wrap1, TcSigmaType
upsilon_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiateInferred CtOrigin
fun_orig TcSigmaType
fun_ty
               -- wrap1 :: fun_ty "->" upsilon_ty
           ; case TcSigmaType -> Maybe (TyVarBinder, TcSigmaType)
tcSplitForAllTy_maybe TcSigmaType
upsilon_ty of
               Just (TyVarBinder
tvb, TcSigmaType
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 :: EvVar
tv   = TyVarBinder -> EvVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyVarBinder
tvb
                          kind :: TcSigmaType
kind = EvVar -> TcSigmaType
tyVarKind EvVar
tv
                    ; TcSigmaType
ty_arg <- HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> TcSigmaType -> TcM TcSigmaType
tcHsTypeApp HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg TcSigmaType
kind

                    ; TcSigmaType
inner_ty <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
inner_ty
                          -- See Note [Visible type application zonk]
                    ; let in_scope :: InScopeSet
in_scope  = VarSet -> InScopeSet
mkInScopeSet ([TcSigmaType] -> VarSet
tyCoVarsOfTypes [TcSigmaType
upsilon_ty, TcSigmaType
ty_arg])

                          insted_ty :: TcSigmaType
insted_ty = InScopeSet
-> [EvVar] -> [TcSigmaType] -> TcSigmaType -> TcSigmaType
substTyWithInScope InScopeSet
in_scope [EvVar
tv] [TcSigmaType
ty_arg] TcSigmaType
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 [EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
tv, TcSigmaType -> SDoc
debugPprType TcSigmaType
kind
                                          , TcSigmaType -> SDoc
debugPprType TcSigmaType
ty_arg
                                          , TcSigmaType -> SDoc
debugPprType (HasDebugCallStack => TcSigmaType -> TcSigmaType
TcSigmaType -> TcSigmaType
tcTypeKind TcSigmaType
ty_arg)
                                          , TcSigmaType -> SDoc
debugPprType TcSigmaType
inner_ty
                                          , TcSigmaType -> SDoc
debugPprType TcSigmaType
insted_ty ])

                    ; (HsWrapper
inner_wrap, [LHsExprArgOut]
args', TcSigmaType
res_ty)
                        <- [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go [TcSigmaType]
acc_args (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) TcSigmaType
insted_ty [LHsExprArgIn]
args
                   -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty
                    ; let inst_wrap :: HsWrapper
inst_wrap = [TcSigmaType] -> HsWrapper
mkWpTyApps [TcSigmaType
ty_arg]
                    ; (HsWrapper, [LHsExprArgOut], TcSigmaType)
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper
inner_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
inst_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1
                             , SrcSpan
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> LHsExprArgOut
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args'
                             , TcSigmaType
res_ty ) }
               Maybe (TyVarBinder, TcSigmaType)
_ -> TcSigmaType
-> HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
forall a b.
Outputable a =>
TcSigmaType -> a -> IOEnv (Env TcGblEnv TcLclEnv) b
ty_app_err TcSigmaType
upsilon_ty HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg }

    go [TcSigmaType]
acc_args Int
n TcSigmaType
fun_ty (HsValArg LHsExpr GhcRn
arg : [LHsExprArgIn]
args)
      = do { (HsWrapper
wrap, [TcSigmaType
arg_ty], TcSigmaType
res_ty)
               <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> [TcSigmaType]
-> Int
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
matchActualFunTysPart SDoc
herald CtOrigin
fun_orig (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
fun)) Int
1 TcSigmaType
fun_ty
                                        [TcSigmaType]
acc_args Int
orig_expr_args_arity
               -- wrap :: fun_ty "->" arg_ty -> res_ty
           ; LHsExpr GhcTcId
arg' <- LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg LHsExpr GhcRn
fun LHsExpr GhcRn
arg TcSigmaType
arg_ty Int
n
           ; (HsWrapper
inner_wrap, [LHsExprArgOut]
args', TcSigmaType
inner_res_ty)
               <- [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go (TcSigmaType
arg_ty TcSigmaType -> [TcSigmaType] -> [TcSigmaType]
forall a. a -> [a] -> [a]
: [TcSigmaType]
acc_args) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) TcSigmaType
res_ty [LHsExprArgIn]
args
               -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
           ; (HsWrapper, [LHsExprArgOut], TcSigmaType)
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper
-> HsWrapper -> TcSigmaType -> TcSigmaType -> SDoc -> HsWrapper
mkWpFun HsWrapper
idHsWrapper HsWrapper
inner_wrap TcSigmaType
arg_ty TcSigmaType
res_ty SDoc
doc HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap
                    , LHsExpr GhcTcId -> LHsExprArgOut
forall tm ty. tm -> HsArg tm ty
HsValArg LHsExpr GhcTcId
arg' LHsExprArgOut -> [LHsExprArgOut] -> [LHsExprArgOut]
forall a. a -> [a] -> [a]
: [LHsExprArgOut]
args'
                    , TcSigmaType
inner_res_ty ) }
      where
        doc :: SDoc
doc = String -> SDoc
text String
"When checking the" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
n SDoc -> SDoc -> SDoc
<+>
              String -> SDoc
text String
"argument to" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
fun)

    ty_app_err :: TcSigmaType -> a -> IOEnv (Env TcGblEnv TcLclEnv) b
ty_app_err TcSigmaType
ty a
arg
      = do { (TidyEnv
_, TcSigmaType
ty) <- TidyEnv -> TcSigmaType -> TcM (TidyEnv, TcSigmaType)
zonkTidyTcType TidyEnv
emptyTidyEnv TcSigmaType
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 (TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
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 TyCoRep.

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 CHoleCan constraint, 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 CHoleCan, 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 CHoleCan constraint;
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 :: LHsExpr GhcRn                   -- The function (for error messages)
      -> LHsExpr GhcRn                   -- Actual arguments
      -> TcRhoType                       -- expected arg type
      -> Int                             -- # of argument
      -> TcM (LHsExpr GhcTcId)           -- Resulting argument
tcArg :: LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg LHsExpr GhcRn
fun LHsExpr GhcRn
arg TcSigmaType
ty Int
arg_no = SDoc -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> LHsExpr GhcRn -> Int -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Int -> SDoc
funAppCtxt LHsExpr GhcRn
fun LHsExpr GhcRn
arg Int
arg_no) (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                          LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExprNC LHsExpr GhcRn
arg TcSigmaType
ty

----------------
tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId]
tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId]
tcTupArgs [LHsTupArg GhcRn]
args [TcSigmaType]
tys
  = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
  where
    go :: (GenLocated l (HsTupArg GhcRn), TcSigmaType)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTcId))
go (L l
l (Missing {}),   TcSigmaType
arg_ty) = GenLocated l (HsTupArg GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> HsTupArg GhcTcId -> GenLocated l (HsTupArg GhcTcId)
forall l e. l -> e -> GenLocated l e
L l
l (XMissing GhcTcId -> HsTupArg GhcTcId
forall id. XMissing id -> HsTupArg id
Missing TcSigmaType
XMissing GhcTcId
arg_ty))
    go (L l
l (Present XPresent GhcRn
x LHsExpr GhcRn
expr), TcSigmaType
arg_ty) = do { LHsExpr GhcTcId
expr' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr TcSigmaType
arg_ty
                                           ; GenLocated l (HsTupArg GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return (l -> HsTupArg GhcTcId -> GenLocated l (HsTupArg GhcTcId)
forall l e. l -> e -> GenLocated l e
L l
l (XPresent GhcTcId -> LHsExpr GhcTcId -> HsTupArg GhcTcId
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present XPresent GhcRn
XPresent GhcTcId
x LHsExpr GhcTcId
expr')) }
    go (L l
_ (XTupArg XXTupArg GhcRn
nec), TcSigmaType
_) = NoExtCon
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTcId))
forall a. NoExtCon -> a
noExtCon XXTupArg GhcRn
NoExtCon
nec

---------------------------
-- See TcType.SyntaxOpType also for commentary
tcSyntaxOp :: CtOrigin
           -> SyntaxExpr GhcRn
           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
           -> ExpRhoType               -- ^ overall result type
           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
           -> TcM (a, SyntaxExpr GhcTcId)
-- ^ Typecheck a syntax operator
-- The operator is a variable or a lambda at this stage (i.e. renamer
-- output)
tcSyntaxOp :: CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpSigmaType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOp CtOrigin
orig SyntaxExpr GhcRn
expr [SyntaxOpType]
arg_tys ExpSigmaType
res_ty
  = CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
forall a.
CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOpGen CtOrigin
orig SyntaxExpr GhcRn
expr [SyntaxOpType]
arg_tys (ExpSigmaType -> SyntaxOpType
SynType ExpSigmaType
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
              -> SyntaxExpr GhcRn
              -> [SyntaxOpType]
              -> SyntaxOpType
              -> ([TcSigmaType] -> TcM a)
              -> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOpGen :: CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
tcSyntaxOpGen CtOrigin
orig SyntaxExpr GhcRn
op [SyntaxOpType]
arg_tys SyntaxOpType
res_ty [TcSigmaType] -> TcM a
thing_inside
  = do { (LHsExpr GhcTcId
expr, TcSigmaType
sigma) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigma (LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType))
-> LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a b. (a -> b) -> a -> b
$ SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn)
-> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ SyntaxExpr GhcRn -> HsExpr GhcRn
forall p. SyntaxExpr p -> HsExpr p
syn_expr SyntaxExpr GhcRn
op
       ; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (SyntaxExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExpr GhcRn
op SDoc -> SDoc -> SDoc
$$ LHsExpr GhcTcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcTcId
expr SDoc -> SDoc -> SDoc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
sigma)
       ; (a
result, HsWrapper
expr_wrap, [HsWrapper]
arg_wraps, HsWrapper
res_wrap)
           <- CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a.
CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcSigmaType
sigma [SyntaxOpType]
arg_tys SyntaxOpType
res_ty (([TcSigmaType] -> TcM a)
 -> TcM (a, HsWrapper, [HsWrapper], HsWrapper))
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
forall a b. (a -> b) -> a -> b
$
              [TcSigmaType] -> TcM a
thing_inside
       ; String -> SDoc -> TcRn ()
traceTc String
"tcSyntaxOpGen" (SyntaxExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr SyntaxExpr GhcRn
op SDoc -> SDoc -> SDoc
$$ LHsExpr GhcTcId -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcTcId
expr SDoc -> SDoc -> SDoc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
sigma )
       ; (a, SyntaxExpr GhcTcId) -> TcM (a, SyntaxExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, SyntaxExpr :: forall p. HsExpr p -> [HsWrapper] -> HsWrapper -> SyntaxExpr p
SyntaxExpr { syn_expr :: HsExpr GhcTcId
syn_expr = HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
expr_wrap (HsExpr GhcTcId -> HsExpr GhcTcId)
-> HsExpr GhcTcId -> HsExpr GhcTcId
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTcId -> SrcSpanLess (LHsExpr GhcTcId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcTcId
expr
                                    , syn_arg_wraps :: [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
                                    , syn_res_wrap :: HsWrapper
syn_res_wrap  = HsWrapper
res_wrap }) }

{-
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] -> TcM a)    -- ^ check the arguments
          -> TcM (a, HsWrapper)
           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
tcSynArgE :: CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE CtOrigin
orig TcSigmaType
sigma_ty SyntaxOpType
syn_ty [TcSigmaType] -> TcM a
thing_inside
  = do { (HsWrapper
skol_wrap, (a
result, HsWrapper
ty_wrapper))
           <- UserTypeCtxt
-> TcSigmaType
-> ([EvVar] -> TcSigmaType -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall result.
UserTypeCtxt
-> TcSigmaType
-> ([EvVar] -> TcSigmaType -> TcM result)
-> TcM (HsWrapper, result)
tcSkolemise UserTypeCtxt
GenSigCtxt TcSigmaType
sigma_ty (([EvVar] -> TcSigmaType -> TcM (a, HsWrapper))
 -> TcM (HsWrapper, (a, HsWrapper)))
-> ([EvVar] -> TcSigmaType -> TcM (a, HsWrapper))
-> TcM (HsWrapper, (a, HsWrapper))
forall a b. (a -> b) -> a -> b
$ \ [EvVar]
_ TcSigmaType
rho_ty ->
              TcSigmaType -> SyntaxOpType -> TcM (a, HsWrapper)
go TcSigmaType
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 :: TcSigmaType -> SyntaxOpType -> TcM (a, HsWrapper)
go TcSigmaType
rho_ty SyntaxOpType
SynAny
      = do { a
result <- [TcSigmaType] -> TcM a
thing_inside [TcSigmaType
rho_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }

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

    go TcSigmaType
rho_ty SyntaxOpType
SynList
      = do { (TcCoercionR
list_co, TcSigmaType
elt_ty) <- TcSigmaType -> TcM (TcCoercionR, TcSigmaType)
matchExpectedListTy TcSigmaType
rho_ty
           ; a
result <- [TcSigmaType] -> TcM a
thing_inside [TcSigmaType
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 TcSigmaType
rho_ty (SynFun SyntaxOpType
arg_shape SyntaxOpType
res_shape)
      = do { ( ( ( (a
result, TcSigmaType
arg_ty, TcSigmaType
res_ty)
                 , HsWrapper
res_wrapper )                   -- :: res_ty_out "->" res_ty
               , HsWrapper
arg_wrapper1, [], HsWrapper
arg_wrapper2 )  -- :: arg_ty "->" arg_ty_out
             , HsWrapper
match_wrapper )         -- :: (arg_ty -> res_ty) "->" rho_ty
               <- SDoc
-> Int
-> ExpSigmaType
-> ([ExpSigmaType]
    -> ExpSigmaType
    -> TcM
         (((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
          [HsWrapper], HsWrapper))
-> TcM
     ((((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
       [HsWrapper], HsWrapper),
      HsWrapper)
forall a.
SDoc
-> Int
-> ExpSigmaType
-> ([ExpSigmaType] -> ExpSigmaType -> TcM a)
-> TcM (a, HsWrapper)
matchExpectedFunTys SDoc
herald Int
1 (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
rho_ty) (([ExpSigmaType]
  -> ExpSigmaType
  -> TcM
       (((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
        [HsWrapper], HsWrapper))
 -> TcM
      ((((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
        [HsWrapper], HsWrapper),
       HsWrapper))
-> ([ExpSigmaType]
    -> ExpSigmaType
    -> TcM
         (((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
          [HsWrapper], HsWrapper))
-> TcM
     ((((a, TcSigmaType, TcSigmaType), HsWrapper), HsWrapper,
       [HsWrapper], HsWrapper),
      HsWrapper)
forall a b. (a -> b) -> a -> b
$
                  \ [ExpSigmaType
arg_ty] ExpSigmaType
res_ty ->
                  do { TcSigmaType
arg_tc_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
arg_ty
                     ; TcSigmaType
res_tc_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
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 )

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

           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return ( a
result
                    , HsWrapper
match_wrapper HsWrapper -> HsWrapper -> HsWrapper
<.>
                      HsWrapper
-> HsWrapper -> TcSigmaType -> TcSigmaType -> SDoc -> HsWrapper
mkWpFun (HsWrapper
arg_wrapper2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
arg_wrapper1) HsWrapper
res_wrapper
                              TcSigmaType
arg_ty TcSigmaType
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 TcSigmaType
rho_ty (SynType ExpSigmaType
the_ty)
      = do { HsWrapper
wrap   <- CtOrigin
-> UserTypeCtxt -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
tcSubTypeET CtOrigin
orig UserTypeCtxt
GenSigCtxt ExpSigmaType
the_ty TcSigmaType
rho_ty
           ; a
result <- [TcSigmaType] -> 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] -> 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 :: CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA CtOrigin
orig TcSigmaType
sigma_ty [SyntaxOpType]
arg_shapes SyntaxOpType
res_shape [TcSigmaType] -> TcM a
thing_inside
  = do { (HsWrapper
match_wrapper, [TcSigmaType]
arg_tys, TcSigmaType
res_ty)
           <- SDoc
-> CtOrigin
-> Maybe (HsExpr GhcRn)
-> Int
-> TcSigmaType
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
matchActualFunTys SDoc
herald CtOrigin
orig Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing ([SyntaxOpType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SyntaxOpType]
arg_shapes) TcSigmaType
sigma_ty
              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
       ; ((a
result, HsWrapper
res_wrapper), [HsWrapper]
arg_wrappers)
           <- [TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a.
[TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e [TcSigmaType]
arg_tys [SyntaxOpType]
arg_shapes (([TcSigmaType] -> TcM (a, HsWrapper))
 -> TcM ((a, HsWrapper), [HsWrapper]))
-> ([TcSigmaType] -> TcM (a, HsWrapper))
-> TcM ((a, HsWrapper), [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [TcSigmaType]
arg_results ->
              TcSigmaType
-> SyntaxOpType -> ([TcSigmaType] -> TcM a) -> TcM (a, HsWrapper)
forall a.
TcSigmaType
-> SyntaxOpType -> ([TcSigmaType] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg    TcSigmaType
res_ty  SyntaxOpType
res_shape  (([TcSigmaType] -> TcM a) -> TcM (a, HsWrapper))
-> ([TcSigmaType] -> TcM a) -> TcM (a, HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [TcSigmaType]
res_results ->
              [TcSigmaType] -> TcM a
thing_inside ([TcSigmaType]
arg_results [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
res_results)
       ; (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] -> TcM a)
                  -> TcM (a, [HsWrapper])
                    -- the wrappers are for arguments
    tc_syn_args_e :: [TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (TcSigmaType
arg_ty : [TcSigmaType]
arg_tys) (SyntaxOpType
arg_shape : [SyntaxOpType]
arg_shapes) [TcSigmaType] -> TcM a
thing_inside
      = do { ((a
result, [HsWrapper]
arg_wraps), HsWrapper
arg_wrap)
               <- CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a.
CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE     CtOrigin
orig TcSigmaType
arg_ty  SyntaxOpType
arg_shape  (([TcSigmaType] -> TcM (a, [HsWrapper]))
 -> TcM ((a, [HsWrapper]), HsWrapper))
-> ([TcSigmaType] -> TcM (a, [HsWrapper]))
-> TcM ((a, [HsWrapper]), HsWrapper)
forall a b. (a -> b) -> a -> b
$ \ [TcSigmaType]
arg1_results ->
                  [TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
forall a.
[TcSigmaType]
-> [SyntaxOpType]
-> ([TcSigmaType] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e      [TcSigmaType]
arg_tys [SyntaxOpType]
arg_shapes (([TcSigmaType] -> TcM a) -> TcM (a, [HsWrapper]))
-> ([TcSigmaType] -> TcM a) -> TcM (a, [HsWrapper])
forall a b. (a -> b) -> a -> b
$ \ [TcSigmaType]
args_results ->
                  [TcSigmaType] -> TcM a
thing_inside ([TcSigmaType]
arg1_results [TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
args_results)
           ; (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 [TcSigmaType]
_ [SyntaxOpType]
_ [TcSigmaType] -> TcM a
thing_inside = (, []) (a -> (a, [HsWrapper])) -> TcM a -> TcM (a, [HsWrapper])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TcSigmaType] -> 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 :: TcSigmaType
-> SyntaxOpType -> ([TcSigmaType] -> TcM a) -> TcM (a, HsWrapper)
tc_syn_arg TcSigmaType
res_ty SyntaxOpType
SynAny [TcSigmaType] -> TcM a
thing_inside
      = do { a
result <- [TcSigmaType] -> TcM a
thing_inside [TcSigmaType
res_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
idHsWrapper) }
    tc_syn_arg TcSigmaType
res_ty SyntaxOpType
SynRho [TcSigmaType] -> TcM a
thing_inside
      = do { (HsWrapper
inst_wrap, TcSigmaType
rho_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
deeplyInstantiate CtOrigin
orig TcSigmaType
res_ty
               -- inst_wrap :: res_ty "->" rho_ty
           ; a
result <- [TcSigmaType] -> TcM a
thing_inside [TcSigmaType
rho_ty]
           ; (a, HsWrapper) -> TcM (a, HsWrapper)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
inst_wrap) }
    tc_syn_arg TcSigmaType
res_ty SyntaxOpType
SynList [TcSigmaType] -> TcM a
thing_inside
      = do { (HsWrapper
inst_wrap, TcSigmaType
rho_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate CtOrigin
orig TcSigmaType
res_ty
               -- inst_wrap :: res_ty "->" rho_ty
           ; (TcCoercionR
list_co, TcSigmaType
elt_ty)   <- TcSigmaType -> TcM (TcCoercionR, TcSigmaType)
matchExpectedListTy TcSigmaType
rho_ty
               -- list_co :: [elt_ty] ~N rho_ty
           ; a
result <- [TcSigmaType] -> TcM a
thing_inside [TcSigmaType
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 TcSigmaType
_ (SynFun {}) [TcSigmaType] -> 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 TcSigmaType
res_ty (SynType ExpSigmaType
the_ty) [TcSigmaType] -> TcM a
thing_inside
      = do { HsWrapper
wrap   <- CtOrigin
-> UserTypeCtxt -> TcSigmaType -> ExpSigmaType -> TcM HsWrapper
tcSubTypeO CtOrigin
orig UserTypeCtxt
GenSigCtxt TcSigmaType
res_ty ExpSigmaType
the_ty
           ; a
result <- [TcSigmaType] -> 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 GhcTcId, TcType)
tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcExprSig LHsExpr GhcRn
expr (CompleteSig { sig_bndr :: TcIdSigInfo -> EvVar
sig_bndr = EvVar
poly_id, sig_loc :: TcIdSigInfo -> SrcSpan
sig_loc = SrcSpan
loc })
  = SrcSpan
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (LHsExpr GhcTcId, TcSigmaType)
 -> TcM (LHsExpr GhcTcId, TcSigmaType))
-> TcM (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall a b. (a -> b) -> a -> b
$   -- Sets the location for the implication constraint
    do { ([(Name, EvVar)]
tv_prs, [TcSigmaType]
theta, TcSigmaType
tau) <- ([EvVar] -> TcM (TCvSubst, [EvVar]))
-> EvVar -> TcM ([(Name, EvVar)], [TcSigmaType], TcSigmaType)
tcInstType [EvVar] -> TcM (TCvSubst, [EvVar])
tcInstSkolTyVars EvVar
poly_id
       ; [EvVar]
given <- [TcSigmaType] -> TcM [EvVar]
newEvVars [TcSigmaType]
theta
       ; String -> SDoc -> TcRn ()
traceTc String
"tcExprSig: CompleteSig" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"poly_id:" SDoc -> SDoc -> SDoc
<+> EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
poly_id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (EvVar -> TcSigmaType
idType EvVar
poly_id)
              , String -> SDoc
text String
"tv_prs:" SDoc -> SDoc -> SDoc
<+> [(Name, EvVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, EvVar)]
tv_prs ]

       ; let skol_info :: SkolemInfo
skol_info = UserTypeCtxt -> TcSigmaType -> [(Name, EvVar)] -> SkolemInfo
SigSkol UserTypeCtxt
ExprSigCtxt (EvVar -> TcSigmaType
idType EvVar
poly_id) [(Name, EvVar)]
tv_prs
             skol_tvs :: [EvVar]
skol_tvs  = ((Name, EvVar) -> EvVar) -> [(Name, EvVar)] -> [EvVar]
forall a b. (a -> b) -> [a] -> [b]
map (Name, EvVar) -> EvVar
forall a b. (a, b) -> b
snd [(Name, EvVar)]
tv_prs
       ; (TcEvBinds
ev_binds, LHsExpr GhcTcId
expr') <- SkolemInfo
-> [EvVar]
-> [EvVar]
-> TcM (LHsExpr GhcTcId)
-> TcM (TcEvBinds, LHsExpr GhcTcId)
forall result.
SkolemInfo
-> [EvVar] -> [EvVar] -> TcM result -> TcM (TcEvBinds, result)
checkConstraints SkolemInfo
skol_info [EvVar]
skol_tvs [EvVar]
given (TcM (LHsExpr GhcTcId) -> TcM (TcEvBinds, LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (TcEvBinds, LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                              [(Name, EvVar)] -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall r. [(Name, EvVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, EvVar)]
tv_prs (TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId))
-> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
                              LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExprNC LHsExpr GhcRn
expr TcSigmaType
tau

       ; let poly_wrap :: HsWrapper
poly_wrap = [EvVar] -> HsWrapper
mkWpTyLams   [EvVar]
skol_tvs
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [EvVar] -> HsWrapper
mkWpLams [EvVar]
given
                         HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet  TcEvBinds
ev_binds
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
poly_wrap LHsExpr GhcTcId
expr', EvVar -> TcSigmaType
idType EvVar
poly_id) }

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

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

       ; String -> SDoc -> TcRn ()
traceTc String
"tcExpSig" ([EvVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvVar]
qtvs SDoc -> SDoc -> SDoc
$$ [EvVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvVar]
givens SDoc -> SDoc -> SDoc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
inferred_sigma SDoc -> SDoc -> SDoc
$$ TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
my_sigma)
       ; let poly_wrap :: HsWrapper
poly_wrap = HsWrapper
wrap
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [EvVar] -> HsWrapper
mkWpTyLams [EvVar]
qtvs
                         HsWrapper -> HsWrapper -> HsWrapper
<.> [EvVar] -> HsWrapper
mkWpLams [EvVar]
givens
                         HsWrapper -> HsWrapper -> HsWrapper
<.> TcEvBinds -> HsWrapper
mkWpLet  TcEvBinds
ev_binds
       ; (LHsExpr GhcTcId, TcSigmaType)
-> TcM (LHsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap HsWrapper
poly_wrap LHsExpr GhcTcId
expr', TcSigmaType
my_sigma) }


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

So for partial signatures we apply the MR if no context is given.  So
   e :: IO _          apply the MR
   e :: _ => IO _     do not apply the MR
just like in TcBinds.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 GhcTcId)
tcCheckId :: Name -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcCheckId Name
name ExpSigmaType
res_ty
  = do { (HsExpr GhcTcId
expr, TcSigmaType
actual_res_ty) <- Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId Name
name
       ; String -> SDoc -> TcRn ()
traceTc String
"tcCheckId" ([SDoc] -> SDoc
vcat [Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
actual_res_ty, ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty])
       ; Bool
-> HsExpr GhcRn
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
-> TcM (HsExpr GhcTcId)
forall a.
Bool
-> HsExpr GhcRn -> TcSigmaType -> ExpSigmaType -> TcM a -> TcM a
addFunResCtxt Bool
False (XVar GhcRn -> GenLocated SrcSpan (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (SrcSpanLess (GenLocated SrcSpan Name) -> GenLocated SrcSpan Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Name
SrcSpanLess (GenLocated SrcSpan Name)
name)) TcSigmaType
actual_res_ty ExpSigmaType
res_ty (TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId))
-> TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
         CtOrigin
-> HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResultO (Name -> CtOrigin
OccurrenceOf Name
name) (XVar GhcRn -> GenLocated SrcSpan (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExtField
noExtField (SrcSpanLess (GenLocated SrcSpan Name) -> GenLocated SrcSpan Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc Name
SrcSpanLess (GenLocated SrcSpan Name)
name)) HsExpr GhcTcId
expr
                                                          TcSigmaType
actual_res_ty ExpSigmaType
res_ty }

tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcCheckRecSelId :: HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcCheckRecSelId HsExpr GhcRn
rn_expr f :: AmbiguousFieldOcc GhcRn
f@(Unambiguous XUnambiguous GhcRn
_ (L SrcSpan
_ RdrName
lbl)) ExpSigmaType
res_ty
  = do { (HsExpr GhcTcId
expr, TcSigmaType
actual_res_ty) <- AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferRecSelId AmbiguousFieldOcc GhcRn
f
       ; Bool
-> HsExpr GhcRn
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
-> TcM (HsExpr GhcTcId)
forall a.
Bool
-> HsExpr GhcRn -> TcSigmaType -> ExpSigmaType -> TcM a -> TcM a
addFunResCtxt Bool
False (XRecFld GhcRn -> AmbiguousFieldOcc GhcRn -> HsExpr GhcRn
forall p. XRecFld p -> AmbiguousFieldOcc p -> HsExpr p
HsRecFld XRecFld GhcRn
NoExtField
noExtField AmbiguousFieldOcc GhcRn
f) TcSigmaType
actual_res_ty ExpSigmaType
res_ty (TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId))
-> TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
         CtOrigin
-> HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResultO (RdrName -> CtOrigin
OccurrenceOfRecSel RdrName
lbl) HsExpr GhcRn
rn_expr HsExpr GhcTcId
expr TcSigmaType
actual_res_ty ExpSigmaType
res_ty }
tcCheckRecSelId HsExpr GhcRn
rn_expr (Ambiguous XAmbiguous GhcRn
_ Located RdrName
lbl) ExpSigmaType
res_ty
  = case TcSigmaType -> Maybe (TcSigmaType, TcSigmaType)
tcSplitFunTy_maybe (TcSigmaType -> Maybe (TcSigmaType, TcSigmaType))
-> Maybe TcSigmaType -> Maybe (TcSigmaType, TcSigmaType)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpSigmaType -> Maybe TcSigmaType
checkingExpType_maybe ExpSigmaType
res_ty of
      Maybe (TcSigmaType, TcSigmaType)
Nothing       -> Located RdrName -> TcM (HsExpr GhcTcId)
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lbl
      Just (TcSigmaType
arg, TcSigmaType
_) -> do { Name
sel_name <- Located RdrName -> TcSigmaType -> TcM Name
disambiguateSelector Located RdrName
lbl TcSigmaType
arg
                          ; HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
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)
                                                    ExpSigmaType
res_ty }
tcCheckRecSelId HsExpr GhcRn
_ (XAmbiguousFieldOcc XXAmbiguousFieldOcc GhcRn
nec) ExpSigmaType
_ = NoExtCon -> TcM (HsExpr GhcTcId)
forall a. NoExtCon -> a
noExtCon XXAmbiguousFieldOcc GhcRn
NoExtCon
nec

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

------------------------
tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
-- Look up an occurrence of an Id
-- Do not instantiate its type
tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId Name
id_name
  | Name
id_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
  = SDoc -> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. SDoc -> TcRn a
failWithTc (String -> SDoc
text String
"tagToEnum# must appear applied to one argument")
        -- tcApp catches the case (tagToEnum# arg)

  | 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 GhcTcId, TcSigmaType)
tc_infer_id (Name -> RdrName
nameRdrName Name
id_name) Name
id_name
         else Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tc_infer_assert Name
id_name }

  | Bool
otherwise
  = do { (HsExpr GhcTcId
expr, TcSigmaType
ty) <- RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
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
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty)
       ; (HsExpr GhcTcId, TcSigmaType) -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsExpr GhcTcId
expr, TcSigmaType
ty) }

tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
-- Deal with an occurrence of 'assert'
-- See Note [Adding the implicit parameter to 'assert']
tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tc_infer_assert Name
assert_name
  = do { EvVar
assert_error_id <- Name -> TcM EvVar
tcLookupId Name
assertErrorName
       ; (HsWrapper
wrap, TcSigmaType
id_rho) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate (Name -> CtOrigin
OccurrenceOf Name
assert_name)
                                          (EvVar -> TcSigmaType
idType EvVar
assert_error_id)
       ; (HsExpr GhcTcId, TcSigmaType) -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExtField
noExtField (SrcSpanLess (Located EvVar) -> Located EvVar
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located EvVar)
EvVar
assert_error_id)), TcSigmaType
id_rho)
       }

tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
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 -> EvVar
tct_id = EvVar
id }
               -> do { EvVar -> TcRn ()
check_naughty EvVar
id        -- Note [Local record selectors]
                     ; EvVar -> TcRn ()
checkThLocalId EvVar
id
                     ; EvVar -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) p.
(Monad m, XVar p ~ NoExtField, IdP p ~ EvVar) =>
EvVar -> m (HsExpr p, TcSigmaType)
return_id EvVar
id }

             AGlobal (AnId EvVar
id)
               -> do { EvVar -> TcRn ()
check_naughty EvVar
id
                     ; EvVar -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) p.
(Monad m, XVar p ~ NoExtField, IdP p ~ EvVar) =>
EvVar -> m (HsExpr p, TcSigmaType)
return_id EvVar
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 GhcTcId, TcSigmaType)
return_data_con DataCon
con
                 PatSynCon PatSyn
ps    -> PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcPatSynBuilderOcc PatSyn
ps

             TcTyThing
_ -> SDoc -> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. SDoc -> TcRn a
failWithTc (SDoc -> TcM (HsExpr GhcTcId, TcSigmaType))
-> SDoc -> TcM (HsExpr GhcTcId, TcSigmaType)
forall a b. (a -> b) -> a -> b
$
                  TcTyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyThing
thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"used where a value identifier was expected" }
  where
    return_id :: EvVar -> m (HsExpr p, TcSigmaType)
return_id EvVar
id = (HsExpr p, TcSigmaType) -> m (HsExpr p, TcSigmaType)
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 XVar p
NoExtField
noExtField (SrcSpanLess (Located (IdP p)) -> Located (IdP p)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located (IdP p))
EvVar
id), EvVar -> TcSigmaType
idType EvVar
id)

    return_data_con :: DataCon -> TcM (HsExpr GhcTcId, TcSigmaType)
return_data_con DataCon
con
       -- For data constructors, must perform the stupid-theta check
      | [TcSigmaType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcSigmaType]
stupid_theta
      = (HsExpr GhcTcId, TcSigmaType) -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return (XConLikeOut GhcTcId -> ConLike -> HsExpr GhcTcId
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut XConLikeOut GhcTcId
NoExtField
noExtField (DataCon -> ConLike
RealDataCon DataCon
con), TcSigmaType
con_ty)

      | Bool
otherwise
       -- See Note [Instantiating stupid theta]
      = do { let ([EvVar]
tvs, [TcSigmaType]
theta, TcSigmaType
rho) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
con_ty
           ; (TCvSubst
subst, [EvVar]
tvs') <- [EvVar] -> TcM (TCvSubst, [EvVar])
newMetaTyVars [EvVar]
tvs
           ; let tys' :: [TcSigmaType]
tys'   = [EvVar] -> [TcSigmaType]
mkTyVarTys [EvVar]
tvs'
                 theta' :: [TcSigmaType]
theta' = HasCallStack => TCvSubst -> [TcSigmaType] -> [TcSigmaType]
TCvSubst -> [TcSigmaType] -> [TcSigmaType]
substTheta TCvSubst
subst [TcSigmaType]
theta
                 rho' :: TcSigmaType
rho'   = HasCallStack => TCvSubst -> TcSigmaType -> TcSigmaType
TCvSubst -> TcSigmaType -> TcSigmaType
substTy TCvSubst
subst TcSigmaType
rho
           ; HsWrapper
wrap <- CtOrigin -> [TcSigmaType] -> [TcSigmaType] -> TcM HsWrapper
instCall (Name -> CtOrigin
OccurrenceOf Name
id_name) [TcSigmaType]
tys' [TcSigmaType]
theta'
           ; DataCon -> [TcSigmaType] -> TcRn ()
addDataConStupidTheta DataCon
con [TcSigmaType]
tys'
           ; (HsExpr GhcTcId, TcSigmaType) -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (XConLikeOut GhcTcId -> ConLike -> HsExpr GhcTcId
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut XConLikeOut GhcTcId
NoExtField
noExtField (DataCon -> ConLike
RealDataCon DataCon
con))
                    , TcSigmaType
rho') }

      where
        con_ty :: TcSigmaType
con_ty         = DataCon -> TcSigmaType
dataConUserType DataCon
con
        stupid_theta :: [TcSigmaType]
stupid_theta   = DataCon -> [TcSigmaType]
dataConStupidTheta DataCon
con

    check_naughty :: EvVar -> TcRn ()
check_naughty EvVar
id
      | EvVar -> Bool
isNaughtyRecordSelector EvVar
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 -> UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId)
-- 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 CHoleCan does bind it, so it's
-- not unbound any more!
tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcUnboundId HsExpr GhcRn
rn_expr UnboundVar
unbound ExpSigmaType
res_ty
 = do { TcSigmaType
ty <- TcM TcSigmaType
newOpenFlexiTyVarTy  -- Allow Int# etc (#12531)
      ; let occ :: OccName
occ = UnboundVar -> OccName
unboundVarOcc UnboundVar
unbound
      ; Name
name <- OccName -> TcM Name
forall gbl lcl. OccName -> TcRnIf gbl lcl Name
newSysName OccName
occ
      ; let ev :: EvVar
ev = Name -> TcSigmaType -> EvVar
mkLocalId Name
name TcSigmaType
ty
      ; Ct
can <- Hole -> EvVar -> TcSigmaType -> TcM Ct
newHoleCt (UnboundVar -> Hole
ExprHole UnboundVar
unbound) EvVar
ev TcSigmaType
ty
      ; Ct -> TcRn ()
emitInsoluble Ct
can
      ; CtOrigin
-> HsExpr GhcRn
-> HsExpr GhcTcId
-> TcSigmaType
-> ExpSigmaType
-> TcM (HsExpr GhcTcId)
tcWrapResultO (OccName -> CtOrigin
UnboundOccurrenceOf OccName
occ) HsExpr GhcRn
rn_expr
          (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExtField
noExtField (SrcSpanLess (Located EvVar) -> Located EvVar
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located EvVar)
EvVar
ev)) TcSigmaType
ty ExpSigmaType
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.

-}

tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
            -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
-- tagToEnum# :: forall a. Int# -> a
-- See Note [tagToEnum#]   Urgh!
tcTagToEnum :: SrcSpan
-> Name
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcTagToEnum SrcSpan
loc Name
fun_name [LHsExprArgIn]
args ExpSigmaType
res_ty
  = do { EvVar
fun <- Name -> TcM EvVar
tcLookupId Name
fun_name

       ; let pars1 :: [LHsExprArgOut]
pars1 = (LHsExprArgIn -> Maybe LHsExprArgOut)
-> [LHsExprArgIn] -> [LHsExprArgOut]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsExprArgIn -> Maybe LHsExprArgOut
forall a b c d. HsArg a b -> Maybe (HsArg c d)
isArgPar_maybe [LHsExprArgIn]
before
             pars2 :: [LHsExprArgOut]
pars2 = (LHsExprArgIn -> Maybe LHsExprArgOut)
-> [LHsExprArgIn] -> [LHsExprArgOut]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsExprArgIn -> Maybe LHsExprArgOut
forall a b c d. HsArg a b -> Maybe (HsArg c d)
isArgPar_maybe [LHsExprArgIn]
after
             -- args contains exactly one HsValArg
             ([LHsExprArgIn]
before, LHsExprArgIn
_:[LHsExprArgIn]
after) = (LHsExprArgIn -> Bool)
-> [LHsExprArgIn] -> ([LHsExprArgIn], [LHsExprArgIn])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break LHsExprArgIn -> Bool
forall tm ty. HsArg tm ty -> Bool
isHsValArg [LHsExprArgIn]
args

       ; LHsExpr GhcRn
arg <- case (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. (a -> Bool) -> [a] -> [a]
filterOut LHsExprArgIn -> Bool
forall tm ty. HsArg tm ty -> Bool
isArgPar [LHsExprArgIn]
args of
           [HsTypeArg SrcSpan
_ HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg, HsValArg LHsExpr GhcRn
term_arg]
             -> do { TcSigmaType
ty_arg <- HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> TcSigmaType -> TcM TcSigmaType
tcHsTypeApp HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg TcSigmaType
liftedTypeKind
                   ; HsWrapper
_ <- CtOrigin
-> UserTypeCtxt -> TcSigmaType -> ExpSigmaType -> TcM HsWrapper
tcSubTypeDS (Name -> CtOrigin
OccurrenceOf Name
fun_name) UserTypeCtxt
GenSigCtxt TcSigmaType
ty_arg ExpSigmaType
res_ty
                     -- other than influencing res_ty, we just
                     -- don't care about a type arg passed in.
                     -- So drop the evidence.
                   ; LHsExpr GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcRn
term_arg }
           [HsValArg LHsExpr GhcRn
term_arg] -> do { TcSigmaType
_ <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
                                     ; LHsExpr GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcRn
term_arg }
           [LHsExprArgIn]
_          -> String
-> [LHsExprArgIn] -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
forall a. String -> [LHsExprArgIn] -> TcM a
too_many_args String
"tagToEnum#" [LHsExprArgIn]
args

       ; TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
readExpType ExpSigmaType
res_ty
       ; TcSigmaType
ty'    <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
res_ty

       -- Check that the type is algebraic
       ; let mb_tc_app :: Maybe (TyCon, [TcSigmaType])
mb_tc_app = HasCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty'
             Just (TyCon
tc, [TcSigmaType]
tc_args) = Maybe (TyCon, [TcSigmaType])
mb_tc_app
       ; Bool -> SDoc -> TcRn ()
checkTc (Maybe (TyCon, [TcSigmaType]) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TyCon, [TcSigmaType])
mb_tc_app)
                 (TcSigmaType -> SDoc -> SDoc
mk_error TcSigmaType
ty' SDoc
doc1)

       -- Look through any type family
       ; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
       ; let (TyCon
rep_tc, [TcSigmaType]
rep_args, TcCoercionR
coi)
               = FamInstEnvs
-> TyCon -> [TcSigmaType] -> (TyCon, [TcSigmaType], TcCoercionR)
tcLookupDataFamInst FamInstEnvs
fam_envs TyCon
tc [TcSigmaType]
tc_args
            -- coi :: tc tc_args ~R rep_tc rep_args

       ; Bool -> SDoc -> TcRn ()
checkTc (TyCon -> Bool
isEnumerationTyCon TyCon
rep_tc)
                 (TcSigmaType -> SDoc -> SDoc
mk_error TcSigmaType
ty' SDoc
doc2)

       ; LHsExpr GhcTcId
arg' <- LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTcId)
tcMonoExpr LHsExpr GhcRn
arg (TcSigmaType -> ExpSigmaType
mkCheckExpType TcSigmaType
intPrimTy)
       ; let fun' :: LHsExpr GhcTcId
fun' = SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsWrapper -> HsExpr GhcTcId -> HsExpr GhcTcId
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap (TcSigmaType -> HsWrapper
WpTyApp TcSigmaType
rep_ty) (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExtField
noExtField (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc EvVar
fun)))
             rep_ty :: TcSigmaType
rep_ty = TyCon -> [TcSigmaType] -> TcSigmaType
mkTyConApp TyCon
rep_tc [TcSigmaType]
rep_args
             out_args :: [LHsExprArgOut]
out_args = [[LHsExprArgOut]] -> [LHsExprArgOut]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [LHsExprArgOut]
pars1
              , [LHsExpr GhcTcId -> LHsExprArgOut
forall tm ty. tm -> HsArg tm ty
HsValArg LHsExpr GhcTcId
arg']
              , [LHsExprArgOut]
pars2
              ]

       ; (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
forall (m :: * -> *) a. Monad m => a -> m a
return (TcCoercionR -> HsWrapper
mkWpCastR (TcCoercionR -> TcCoercionR
mkTcSymCo TcCoercionR
coi), LHsExpr GhcTcId
fun', [LHsExprArgOut]
out_args) }
                 -- coi is a Representational coercion
  where
    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 :: TcSigmaType -> SDoc -> SDoc
mk_error TcSigmaType
ty SDoc
what
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Bad call to tagToEnum#"
               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"at type" SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty)
           Int
2 SDoc
what

too_many_args :: String -> [LHsExprArgIn] -> TcM a
too_many_args :: String -> [LHsExprArgIn] -> TcM a
too_many_args String
fun [LHsExprArgIn]
args
  = SDoc -> TcM a
forall a. SDoc -> TcRn a
failWith (SDoc -> TcM a) -> SDoc -> TcM a
forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Too many type arguments to" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
fun SDoc -> SDoc -> SDoc
<> SDoc
colon)
       Int
2 ([SDoc] -> SDoc
sep ((LHsExprArgIn -> SDoc) -> [LHsExprArgIn] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LHsExprArgIn -> SDoc
forall (p :: Pass) a pass l.
(OutputableBndr (IdP (GhcPass (NoGhcTcPass p))),
 OutputableBndr (NameOrRdrName (IdP (GhcPass (NoGhcTcPass p)))),
 OutputableBndr (IdP (GhcPass p)),
 OutputableBndr (NameOrRdrName (IdP (GhcPass p))), Outputable a,
 Outputable (XIPBinds (GhcPass p)),
 Outputable (XViaStrategy (GhcPass p)),
 Outputable (XIPBinds (GhcPass (NoGhcTcPass p))),
 Outputable (XViaStrategy (GhcPass (NoGhcTcPass p))),
 NoGhcTcPass p ~ NoGhcTcPass (NoGhcTcPass p),
 XXHsWildCardBndrs pass (GenLocated l (HsType (GhcPass p)))
 ~ NoExtCon) =>
HsArg a (HsWildCardBndrs pass (GenLocated l (HsType (GhcPass p))))
-> SDoc
pp [LHsExprArgIn]
args))
  where
    pp :: HsArg a (HsWildCardBndrs pass (GenLocated l (HsType (GhcPass p))))
-> SDoc
pp (HsValArg a
e)                             = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
e
    pp (HsTypeArg SrcSpan
_ (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = L l
_ HsType (GhcPass p)
t })) = HsType (GhcPass p) -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
HsType (GhcPass p) -> SDoc
pprHsType HsType (GhcPass p)
t
    pp (HsTypeArg SrcSpan
_ (XHsWildCardBndrs XXHsWildCardBndrs pass (GenLocated l (HsType (GhcPass p)))
nec)) = NoExtCon -> SDoc
forall a. NoExtCon -> a
noExtCon XXHsWildCardBndrs pass (GenLocated l (HsType (GhcPass p)))
NoExtCon
nec
    pp (HsArgPar SrcSpan
_) = SDoc
empty


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

checkThLocalId :: Id -> TcM ()
checkThLocalId :: EvVar -> TcRn ()
checkThLocalId EvVar
id
  = do  { Maybe (TopLevelFlag, Int, ThStage)
mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, Int, ThStage))
getStageAndBindLevel (EvVar -> Name
idName EvVar
id)
        ; case Maybe (TopLevelFlag, Int, ThStage)
mb_local_use of
             Just (TopLevelFlag
top_lvl, Int
bind_lvl, ThStage
use_stage