{-# 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
tcPolyExpr, tcPolyExprNC
:: LHsExpr GhcRn
-> TcSigmaType
-> TcM (LHsExpr GhcTcId)
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)
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
-> ExpRhoType
-> 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 )
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)
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 :: 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 {
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
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 {
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
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),
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
; 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
$
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 }
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
= 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
; LHsExpr GhcTcId
arg2' <- LHsExpr GhcRn
-> LHsExpr GhcRn -> TcSigmaType -> Int -> TcM (LHsExpr GhcTcId)
tcArg LHsExpr GhcRn
op LHsExpr GhcRn
arg2 TcSigmaType
arg2_sigma Int
2
; 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
; 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)))
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)
= 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') }
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
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
; 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
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
; 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
; 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
=
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)
; 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
; [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
;
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' ) }
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
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 {
(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
= 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
; 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
; [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') }
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
; (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
; 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]
; WantedConstraints -> TcRn ()
emitStaticConstraints WantedConstraints
lie
; 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'))
}
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
; 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
; 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' } } }
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 {
(LHsExpr GhcTcId
record_expr', TcSigmaType
record_rho) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRho LHsExpr GhcRn
record_expr
; [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
; 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,
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)
; 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 )
; let
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"
relevant_cons :: [ConLike]
relevant_cons = [ConLike] -> [FastString] -> [ConLike]
conLikesWithFields [ConLike]
con_likes [FastString]
upd_fld_occs
; 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)
; 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
; 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))
; 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)
; 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)
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
= (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
= 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
; [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
; let theta' :: [TcSigmaType]
theta' = TCvSubst -> [TcSigmaType] -> [TcSigmaType]
substThetaUnchecked TCvSubst
scrut_subst (ConLike -> [TcSigmaType]
conLikeStupidTheta ConLike
con1)
; CtOrigin -> [TcSigmaType] -> TcRn ()
instStupidTheta CtOrigin
RecordUpdOrigin [TcSigmaType]
theta'
; let fam_co :: HsWrapper
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
; 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'
; 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
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
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
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)
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') }
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
-> 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
-> LHsExpr GhcRn -> [LHsExprArgIn]
-> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
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
, 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
, Just LHsSigWcType GhcRn
sig_ty <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig HsExpr GhcRn
arg
= 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
| 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
-> LHsExpr GhcRn
-> LHsExpr GhcTcId -> TcSigmaType
-> [LHsExprArgIn]
-> ExpRhoType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
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)
; 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"
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)
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)
; (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)
; (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
tcArgs :: LHsExpr GhcRn
-> TcSigmaType
-> CtOrigin
-> [LHsExprArgIn]
-> SDoc
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
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
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
= 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
= [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
; 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 ->
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
; 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
; 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
; 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
; 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
; (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) }
tcArg :: LHsExpr GhcRn
-> LHsExpr GhcRn
-> TcRhoType
-> Int
-> TcM (LHsExpr GhcTcId)
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
tcSyntaxOp :: CtOrigin
-> SyntaxExpr GhcRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr GhcTcId)
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)
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 }) }
tcSynArgE :: CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper)
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
= 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 )
, HsWrapper
arg_wrapper1, [], HsWrapper
arg_wrapper2 )
, HsWrapper
match_wrapper )
<- 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
; 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) }
tcSynArgA :: CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
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
; ((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])
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)
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
; 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
; (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 -> 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) }
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
$
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
$
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) }
; 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
then HsWrapper -> TcM HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper
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) }
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)
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")
| 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)
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
; 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 }
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
| [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
= 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)
tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcUnboundId HsExpr GhcRn
rn_expr UnboundVar
unbound ExpSigmaType
res_ty
= do { TcSigmaType
ty <- TcM TcSigmaType
newOpenFlexiTyVarTy
; 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 }
tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
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
([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
; 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
; 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)
; 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
; 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) }
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
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