{-# 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 HsSyn
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 TcType
import Id
import IdInfo
import ConLike
import DataCon
import PatSyn
import Name
import NameEnv
import NameSet
import RdrName
import TyCon
import TyCoRep
import Type
import TcEvidence
import VarSet
import MkId( seqId )
import TysWiredIn
import TysPrim( intPrimTy, mkTemplateTyVars, tYPE )
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
import qualified Data.Set as Set
tcPolyExpr, tcPolyExprNC
:: LHsExpr GhcRn
-> TcSigmaType
-> TcM (LHsExpr GhcTcId)
tcPolyExpr :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr expr :: LHsExpr GhcRn
expr res_ty :: 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 expr :: LHsExpr GhcRn
expr res_ty :: 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 expr :: LHsExpr GhcRn
expr res_ty :: 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 "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 loc :: SrcSpan
loc expr :: HsExpr GhcRn
expr) res_ty :: 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 "tcPolyExprNC" (ExpSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExpSigmaType
res_ty)
; (wrap :: HsWrapper
wrap, expr' :: 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
$ \ res_ty :: 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 expr :: LHsExpr GhcRn
expr res_ty :: 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 loc :: SrcSpan
loc expr :: HsExpr GhcRn
expr) res_ty :: 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 expr :: 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 loc :: SrcSpan
loc expr :: 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 { (expr' :: HsExpr GhcTcId
expr', sigma :: 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 expr :: 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 expr :: LHsExpr GhcRn
expr
= do { (expr' :: LHsExpr GhcTcId
expr', sigma :: TcSigmaType
sigma) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigmaNC LHsExpr GhcRn
expr
; (wrap :: HsWrapper
wrap, rho :: 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 _ (L _ name :: IdP GhcRn
name)) res_ty :: ExpSigmaType
res_ty = Name -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcCheckId Name
IdP GhcRn
name ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsUnboundVar _ uv :: UnboundVar
uv) res_ty :: 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 {}) res_ty :: ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcApp1 HsExpr GhcRn
e ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsAppType {}) res_ty :: ExpSigmaType
res_ty = HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcApp1 HsExpr GhcRn
e ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsLit x :: XLitE GhcRn
x lit :: HsLit GhcRn
lit) res_ty :: 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 x :: XPar GhcRn
x expr :: LHsExpr GhcRn
expr) res_ty :: 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 x :: XSCC GhcRn
x src :: SourceText
src lbl :: StringLiteral
lbl expr :: LHsExpr GhcRn
expr) res_ty :: 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 x :: XTickPragma GhcRn
x src :: SourceText
src info :: (StringLiteral, (Int, Int), (Int, Int))
info srcInfo :: ((SourceText, SourceText), (SourceText, SourceText))
srcInfo expr :: LHsExpr GhcRn
expr) res_ty :: 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 x :: XCoreAnn GhcRn
x src :: SourceText
src lbl :: StringLiteral
lbl expr :: LHsExpr GhcRn
expr) res_ty :: 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 x :: XOverLitE GhcRn
x lit :: HsOverLit GhcRn
lit) res_ty :: 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 x :: XNegApp GhcRn
x expr :: LHsExpr GhcRn
expr neg_expr :: SyntaxExpr GhcRn
neg_expr) res_ty :: ExpSigmaType
res_ty
= do { (expr' :: LHsExpr GhcTcId
expr', neg_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
$
\[arg_ty :: 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 _ x :: HsIPName
x) res_ty :: 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
NoExt
noExt (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 ipClass :: Class
ipClass x :: TcSigmaType
x ty :: 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 _ mb_fromLabel :: Maybe (IdP GhcRn)
mb_fromLabel l :: FastString
l) res_ty :: ExpSigmaType
res_ty
= do {
SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; case Maybe (IdP GhcRn)
mb_fromLabel of
Just fromLabel :: IdP GhcRn
fromLabel -> HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcExpr (SrcSpan -> Name -> HsExpr GhcRn
applyFromLabel SrcSpan
loc Name
IdP GhcRn
fromLabel) ExpSigmaType
res_ty
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
NoExt
noExt (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 pred :: 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 loc :: SrcSpan
loc fromLabel :: 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
NoExt
noExt
(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
NoExt
noExt (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
NoExt
noExt (SourceText -> FastString -> HsTyLit
HsStrTy SourceText
NoSourceText FastString
l))))
tcExpr (HsLam x :: XLam GhcRn
x match :: MatchGroup GhcRn (LHsExpr GhcRn)
match) res_ty :: ExpSigmaType
res_ty
= do { (match' :: MatchGroup GhcTcId (LHsExpr GhcTcId)
match', wrap :: 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 "The lambda expression" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (Depth -> SDoc -> SDoc
pprSetDepth (Int -> Depth
PartWay 1) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
MatchGroup GhcRn (LHsExpr GhcRn) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId (GhcPass idR), Outputable body) =>
MatchGroup (GhcPass idR) body -> SDoc
pprMatches MatchGroup GhcRn (LHsExpr GhcRn)
match),
String -> SDoc
text "has"]
tcExpr e :: HsExpr GhcRn
e@(HsLamCase x :: XLamCase GhcRn
x matches :: MatchGroup GhcRn (LHsExpr GhcRn)
matches) res_ty :: ExpSigmaType
res_ty
= do { (matches' :: MatchGroup GhcTcId (LHsExpr GhcTcId)
matches', wrap :: 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 "The function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
, String -> SDoc
text "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 _ expr :: LHsExpr GhcRn
expr sig_ty :: LHsSigWcType (NoGhcTc GhcRn)
sig_ty) res_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
; (expr' :: LHsExpr GhcTcId
expr', poly_ty :: 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
NoExt
noExt 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 fix :: XOpApp GhcRn
fix arg1 :: LHsExpr GhcRn
arg1 op :: LHsExpr GhcRn
op arg2 :: LHsExpr GhcRn
arg2) res_ty :: ExpSigmaType
res_ty
| (L loc :: SrcSpan
loc (HsVar _ (L lv :: SrcSpan
lv op_name :: IdP GhcRn
op_name))) <- LHsExpr GhcRn
op
, Name
IdP GhcRn
op_name Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqIdKey
= do { TcSigmaType
arg1_ty <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind
; let arg2_exp_ty :: ExpSigmaType
arg2_exp_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 1
; LHsExpr GhcTcId
arg2' <- 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
op LHsExpr GhcRn
arg2 2) (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)
tc_poly_expr_nc LHsExpr GhcRn
arg2 ExpSigmaType
arg2_exp_ty
; TcSigmaType
arg2_ty <- ExpSigmaType -> TcM TcSigmaType
readExpType ExpSigmaType
arg2_exp_ty
; 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 [TcSigmaType
arg1_ty, TcSigmaType
arg2_ty])
(XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv EvVar
op_id)))
; 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
$ 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' }
| (L loc :: SrcSpan
loc (HsVar _ (L lv :: SrcSpan
lv op_name :: 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 "Application rule" (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
op)
; (arg1' :: LHsExpr GhcTcId
arg1', arg1_ty :: TcSigmaType
arg1_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferSigma LHsExpr GhcRn
arg1
; let doc :: SDoc
doc = String -> SDoc
text "The first argument of ($) takes"
orig1 :: CtOrigin
orig1 = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
arg1
; (wrap_arg1 :: HsWrapper
wrap_arg1, [arg2_sigma :: TcSigmaType
arg2_sigma], op_res_ty :: 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)) 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 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
; HsWrapper
wrap_res <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR CtOrigin
orig1 (HsExpr GhcRn -> Maybe (HsExpr GhcRn)
forall a. a -> Maybe a
Just HsExpr GhcRn
expr) TcSigmaType
op_res_ty ExpSigmaType
res_ty
; EvVar
op_id <- Name -> TcM EvVar
tcLookupId Name
IdP GhcRn
op_name
; TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
readExpType ExpSigmaType
res_ty
; 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
res_ty
, TcSigmaType
arg2_sigma
, TcSigmaType
res_ty])
(XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv EvVar
op_id)))
wrap1 :: HsWrapper
wrap1 = HsWrapper
-> HsWrapper -> TcSigmaType -> TcSigmaType -> SDoc -> HsWrapper
mkWpFun HsWrapper
idHsWrapper HsWrapper
wrap_res TcSigmaType
arg2_sigma TcSigmaType
res_ty SDoc
doc
HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap_arg1
doc :: SDoc
doc = String -> SDoc
text "When looking at the argument to ($)"
; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (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
wrap1 LHsExpr GhcTcId
arg1') LHsExpr GhcTcId
op' LHsExpr GhcTcId
arg2') }
| (L loc :: SrcSpan
loc (HsRecFld _ (Ambiguous _ lbl :: Located RdrName
lbl))) <- LHsExpr GhcRn
op
, Just sig_ty :: 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
NoExt
noExt (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 "Non Application rule" (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
op)
; (wrap :: HsWrapper
wrap, op' :: LHsExpr GhcTcId
op', [HsValArg arg1' :: LHsExpr GhcTcId
arg1', HsValArg arg2' :: 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 x :: XSectionR GhcRn
x op :: LHsExpr GhcRn
op arg2 :: LHsExpr GhcRn
arg2) res_ty :: ExpSigmaType
res_ty
= do { (op' :: LHsExpr GhcTcId
op', op_ty :: TcSigmaType
op_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferFun LHsExpr GhcRn
op
; (wrap_fun :: HsWrapper
wrap_fun, [arg1_ty :: TcSigmaType
arg1_ty, arg2_ty :: TcSigmaType
arg2_ty], op_res_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)) 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
mkFunTy 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 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 x :: XSectionL GhcRn
x arg1 :: LHsExpr GhcRn
arg1 op :: LHsExpr GhcRn
op) res_ty :: ExpSigmaType
res_ty
= do { (op' :: LHsExpr GhcTcId
op', op_ty :: 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 = 1
| Bool
otherwise = 2
; (wrap_fn :: HsWrapper
wrap_fn, (arg1_ty :: TcSigmaType
arg1_ty:arg_tys :: [TcSigmaType]
arg_tys), op_res_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
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
mkFunTys [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 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 x :: XExplicitTuple GhcRn
x tup_args :: [LHsTupArg GhcRn]
tup_args boxity :: Boxity
boxity) res_ty :: 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
; (coi :: TcCoercionR
coi, arg_tys :: [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 Unboxed -> Int -> [TcSigmaType] -> [TcSigmaType]
forall a. Int -> [a] -> [a]
drop Int
arity [TcSigmaType]
arg_tys
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
{ Boxed -> Int -> TcSigmaType -> TcM [TcSigmaType]
newFlexiTyVarTys Int
arity TcSigmaType
liftedTypeKind
; Unboxed -> Int -> TcM TcSigmaType -> TcM [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
mkFunTys [TcSigmaType
ty | (ty :: TcSigmaType
ty, (L _ (Missing _))) <- [TcSigmaType]
arg_tys [TcSigmaType]
-> [LHsTupArg GhcRn] -> [(TcSigmaType, LHsTupArg GhcRn)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [LHsTupArg GhcRn]
tup_args]
(Boxity -> [TcSigmaType] -> TcSigmaType
mkTupleTy Boxity
boxity [TcSigmaType]
arg_tys)
; HsWrapper
wrap <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR (String -> CtOrigin
Shouldn'tHappenOrigin "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 _ alt :: Int
alt arity :: Int
arity expr :: LHsExpr GhcRn
expr) res_ty :: 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
; (coi :: TcCoercionR
coi, arg_tys :: [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
- 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 _ witness :: Maybe (SyntaxExpr GhcRn)
witness exprs :: [LHsExpr GhcRn]
exprs) res_ty :: ExpSigmaType
res_ty
= case Maybe (SyntaxExpr GhcRn)
witness of
Nothing -> do { TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
; (coi :: TcCoercionR
coi, elt_ty :: 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 fln :: SyntaxExpr GhcRn
fln -> do { ((exprs' :: [LHsExpr GhcTcId]
exprs', elt_ty :: TcSigmaType
elt_ty), fln' :: 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
$
\ [elt_ty :: 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 elt_ty :: TcSigmaType
elt_ty expr :: LHsExpr GhcRn
expr = LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExpr LHsExpr GhcRn
expr TcSigmaType
elt_ty
tcExpr (HsLet x :: XLet GhcRn
x (L l :: SrcSpan
l binds :: HsLocalBinds GhcRn
binds) expr :: LHsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
= do { (binds' :: HsLocalBinds GhcTcId
binds', expr' :: 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 x :: XCase GhcRn
x scrut :: LHsExpr GhcRn
scrut matches :: MatchGroup GhcRn (LHsExpr GhcRn)
matches) res_ty :: ExpSigmaType
res_ty
= do {
(scrut' :: LHsExpr GhcTcId
scrut', scrut_ty :: TcSigmaType
scrut_ty) <- LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferRho LHsExpr GhcRn
scrut
; String -> SDoc -> TcRn ()
traceTc "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 x :: XIf GhcRn
x Nothing pred :: LHsExpr GhcRn
pred b1 :: LHsExpr GhcRn
b1 b2 :: LHsExpr GhcRn
b2) res_ty :: 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 x :: XIf GhcRn
x (Just fun :: SyntaxExpr GhcRn
fun) pred :: LHsExpr GhcRn
pred b1 :: LHsExpr GhcRn
b1 b2 :: LHsExpr GhcRn
b2) res_ty :: ExpSigmaType
res_ty
= do { ((pred' :: LHsExpr GhcTcId
pred', b1' :: LHsExpr GhcTcId
b1', b2' :: LHsExpr GhcTcId
b2'), fun' :: 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
$
\ [pred_ty :: TcSigmaType
pred_ty, b1_ty :: TcSigmaType
b1_ty, b2_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 _ alts :: [LGRHS GhcRn (LHsExpr GhcRn)]
alts) res_ty :: 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 _ do_or_lc :: HsStmtContext Name
do_or_lc stmts :: Located [ExprLStmt GhcRn]
stmts) res_ty :: 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 x :: XProc GhcRn
x pat :: LPat GhcRn
pat cmd :: LHsCmdTop GhcRn
cmd) res_ty :: ExpSigmaType
res_ty
= do { (pat' :: OutPat GhcTcId
pat', cmd' :: LHsCmdTop GhcTcId
cmd', coi :: 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 OutPat GhcTcId
pat' LHsCmdTop GhcTcId
cmd') }
tcExpr (HsStatic fvs :: XStatic GhcRn
fvs expr :: LHsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
= do { TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
; (co :: TcCoercionR
co, (p_ty :: TcSigmaType
p_ty, expr_ty :: TcSigmaType
expr_ty)) <- TcSigmaType -> TcM (TcCoercionR, (TcSigmaType, TcSigmaType))
matchExpectedAppTy TcSigmaType
res_ty
; (expr' :: LHsExpr GhcTcId
expr', lie :: 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 "In the body of a static form:")
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
NoExt
noExt
(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 loc :: SrcSpan
loc con_name :: IdP GhcRn
con_name
, rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcRn
rbinds }) res_ty :: 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
; (con_expr :: HsExpr GhcTcId
con_expr, con_sigma :: TcSigmaType
con_sigma) <- Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId Name
IdP GhcRn
con_name
; (con_wrap :: HsWrapper
con_wrap, con_tau :: 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 (arg_tys :: [TcSigmaType]
arg_tys, actual_res_ty :: 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
Nothing -> Name -> TcM (HsExpr GhcTcId)
forall name a. Outputable name => name -> TcM a
nonBidirectionalErr (ConLike -> Name
conLikeName ConLike
con_like)
Just con_id :: EvVar
con_id -> do {
HsWrapper
res_wrap <- CtOrigin
-> Maybe (HsExpr GhcRn)
-> TcSigmaType
-> ExpSigmaType
-> TcM HsWrapper
tcSubTypeHR (String -> CtOrigin
Shouldn'tHappenOrigin "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 }) res_ty :: ExpSigmaType
res_ty
= ASSERT( notNull rbnds )
do {
(record_expr' :: LHsExpr GhcTcId
record_expr', record_rho :: 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 loc :: SrcSpan
loc sel_id :: 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 (data_sels :: [EvVar]
data_sels, pat_syn_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
sel_id :: EvVar
sel_id : _ = [EvVar]
sel_ids
mtycon :: Maybe TyCon
mtycon :: Maybe TyCon
mtycon = case EvVar -> IdDetails
idDetails EvVar
sel_id of
RecSelId (RecSelData tycon :: TyCon
tycon) _ -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tycon
_ -> 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 tc :: TyCon
tc) _
-> (DataCon -> ConLike) -> [DataCon] -> [ConLike]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ConLike
RealDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
RecSelId (RecSelPatSyn ps :: PatSyn
ps) _
-> [PatSyn -> ConLike
PatSynCon PatSyn
ps]
_ -> String -> [ConLike]
forall a. String -> a
panic "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
(con1_tvs :: [EvVar]
con1_tvs, _, _, _prov_theta :: [TcSigmaType]
_prov_theta, req_theta :: [TcSigmaType]
req_theta, con1_arg_tys :: [TcSigmaType]
con1_arg_tys, _)
= 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 tc :: TyCon
tc -> TyCon -> [TcSigmaType] -> TcSigmaType
mkFamilyTyConApp TyCon
tc [TcSigmaType]
con1_tv_tys
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 "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 (fld :: FastString
fld, ty :: 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 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 subst :: TCvSubst
subst (tv :: EvVar
tv, result_inst_ty :: 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 { (subst' :: TCvSubst
subst', new_tv :: 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) }
; (result_subst :: TCvSubst
result_subst, con1_tvs' :: [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)
; (scrut_subst :: TCvSubst
scrut_subst, scrut_inst_tys :: [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
tycon <- Maybe TyCon
mtycon
, Just co_con :: 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 _ f :: AmbiguousFieldOcc GhcRn
f) res_ty :: ExpSigmaType
res_ty
= HsExpr GhcRn
-> AmbiguousFieldOcc GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcCheckRecSelId HsExpr GhcRn
e AmbiguousFieldOcc GhcRn
f ExpSigmaType
res_ty
tcExpr (ArithSeq _ witness :: Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq) res_ty :: 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 _ (HsSpliced _ mod_finalizers :: ThModFinalizers
mod_finalizers (HsSplicedExpr expr :: HsExpr GhcRn
expr)))
res_ty :: 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 _ splice :: HsSplice GhcRn
splice) res_ty :: ExpSigmaType
res_ty
= HsSplice GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTcId)
tcSpliceExpr HsSplice GhcRn
splice ExpSigmaType
res_ty
tcExpr e :: HsExpr GhcRn
e@(HsBracket _ brack :: HsBracket GhcRn
brack) res_ty :: 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 _ brack :: HsBracket GhcRn
brack ps :: [PendingRnSplice]
ps) res_ty :: 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 other :: HsExpr GhcRn
other _ = String -> SDoc -> TcM (HsExpr GhcTcId)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 witness :: Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(From expr :: LHsExpr GhcRn
expr) res_ty :: ExpSigmaType
res_ty
= do { (wrap :: HsWrapper
wrap, elt_ty :: TcSigmaType
elt_ty, wit' :: 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 witness :: Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThen expr1 :: LHsExpr GhcRn
expr1 expr2 :: LHsExpr GhcRn
expr2) res_ty :: ExpSigmaType
res_ty
= do { (wrap :: HsWrapper
wrap, elt_ty :: TcSigmaType
elt_ty, wit' :: 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 witness :: Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromTo expr1 :: LHsExpr GhcRn
expr1 expr2 :: LHsExpr GhcRn
expr2) res_ty :: ExpSigmaType
res_ty
= do { (wrap :: HsWrapper
wrap, elt_ty :: TcSigmaType
elt_ty, wit' :: 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 witness :: Maybe (SyntaxExpr GhcRn)
witness seq :: ArithSeqInfo GhcRn
seq@(FromThenTo expr1 :: LHsExpr GhcRn
expr1 expr2 :: LHsExpr GhcRn
expr2 expr3 :: LHsExpr GhcRn
expr3) res_ty :: ExpSigmaType
res_ty
= do { (wrap :: HsWrapper
wrap, elt_ty :: TcSigmaType
elt_ty, wit' :: 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 Nothing res_ty :: ExpSigmaType
res_ty
= do { TcSigmaType
res_ty <- ExpSigmaType -> TcM TcSigmaType
expTypeToType ExpSigmaType
res_ty
; (coi :: TcCoercionR
coi, elt_ty :: 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 fl :: SyntaxExpr GhcRn
fl) res_ty :: ExpSigmaType
res_ty
= do { (elt_ty :: TcSigmaType
elt_ty, fl' :: 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
$
\ [elt_ty :: 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 f :: LHsExpr (GhcPass id)
f [] = LHsExpr (GhcPass id)
f
wrapHsArgs f :: LHsExpr (GhcPass id)
f (HsValArg a :: LHsExpr (GhcPass id)
a : args :: [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 f :: LHsExpr (GhcPass id)
f (HsTypeArg _ t :: HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
t : args :: [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 f :: LHsExpr (GhcPass id)
f (HsArgPar sp :: SrcSpan
sp : args :: [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)
NoExt
noExt 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 sp :: 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 _ = 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 e :: HsExpr GhcRn
e res_ty :: ExpSigmaType
res_ty
= do { (wrap :: HsWrapper
wrap, fun :: LHsExpr GhcTcId
fun, args :: [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 -> HsExpr GhcTcId
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcTcId -> HsExpr GhcTcId)
-> LHsExpr GhcTcId -> HsExpr 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 m_herald :: Maybe SDoc
m_herald (L sp :: SrcSpan
sp (HsPar _ fun :: LHsExpr GhcRn
fun)) args :: [LHsExprArgIn]
args res_ty :: 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 m_herald :: Maybe SDoc
m_herald (L _ (HsApp _ fun :: LHsExpr GhcRn
fun arg1 :: LHsExpr GhcRn
arg1)) args :: [LHsExprArgIn]
args res_ty :: 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 m_herald :: Maybe SDoc
m_herald (L _ (HsAppType _ fun :: LHsExpr GhcRn
fun ty1 :: LHsWcType (NoGhcTc GhcRn)
ty1)) args :: [LHsExprArgIn]
args res_ty :: 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 m_herald :: Maybe SDoc
m_herald fun :: LHsExpr GhcRn
fun@(L loc :: SrcSpan
loc (HsRecFld _ fld_lbl :: AmbiguousFieldOcc GhcRn
fld_lbl)) args :: [LHsExprArgIn]
args res_ty :: ExpSigmaType
res_ty
| Ambiguous _ lbl :: Located RdrName
lbl <- AmbiguousFieldOcc GhcRn
fld_lbl
, HsValArg (L _ arg :: HsExpr GhcRn
arg) : _ <- (LHsExprArgIn -> Bool) -> [LHsExprArgIn] -> [LHsExprArgIn]
forall a. (a -> Bool) -> [a] -> [a]
filterOut LHsExprArgIn -> Bool
forall tm ty. HsArg tm ty -> Bool
isArgPar [LHsExprArgIn]
args
, Just sig_ty :: 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
; (tc_fun :: HsExpr GhcTcId
tc_fun, fun_ty :: 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 m_herald :: Maybe SDoc
m_herald fun :: LHsExpr GhcRn
fun@(L loc :: SrcSpan
loc (HsVar _ (L _ fun_id :: IdP GhcRn
fun_id))) args :: [LHsExprArgIn]
args res_ty :: 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
== 1
= SrcSpan
-> Name
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcTagToEnum SrcSpan
loc Name
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
seqIdKey
, Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2
= do { TcSigmaType
rep <- TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
runtimeRepTy
; let [alpha :: EvVar
alpha, beta :: EvVar
beta] = [TcSigmaType] -> [EvVar]
mkTemplateTyVars [TcSigmaType
liftedTypeKind, TcSigmaType -> TcSigmaType
tYPE TcSigmaType
rep]
seq_ty :: TcSigmaType
seq_ty = [EvVar] -> TcSigmaType -> TcSigmaType
mkSpecForAllTys [EvVar
alpha,EvVar
beta]
(EvVar -> TcSigmaType
mkTyVarTy EvVar
alpha TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` EvVar -> TcSigmaType
mkTyVarTy EvVar
beta TcSigmaType -> TcSigmaType -> TcSigmaType
`mkFunTy` EvVar -> TcSigmaType
mkTyVarTy EvVar
beta)
seq_fun :: LHsExpr GhcTcId
seq_fun = SrcSpan -> HsExpr GhcTcId -> LHsExpr GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpan -> EvVar -> Located EvVar
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc EvVar
seqId))
; Maybe SDoc
-> LHsExpr GhcRn
-> LHsExpr GhcTcId
-> TcSigmaType
-> [LHsExprArgIn]
-> ExpSigmaType
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
tcFunApp Maybe SDoc
m_herald LHsExpr GhcRn
fun LHsExpr GhcTcId
seq_fun TcSigmaType
seq_ty [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 _ (L loc :: SrcSpan
loc (ExplicitList _ Nothing [])) [HsTypeArg _ ty_arg :: HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
ty_arg] res_ty :: ExpSigmaType
res_ty
= do { TcSigmaType
ty_arg' <- HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
-> TcSigmaType -> TcM TcSigmaType
tcHsTypeApp HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
ty_arg TcSigmaType
liftedTypeKind
; let list_ty :: TcSigmaType
list_ty = TyCon -> [TcSigmaType] -> TcSigmaType
TyConApp TyCon
listTyCon [TcSigmaType
ty_arg']
; HsWrapper
_ <- CtOrigin
-> UserTypeCtxt -> TcSigmaType -> ExpSigmaType -> TcM HsWrapper
tcSubTypeDS (Name -> CtOrigin
OccurrenceOf Name
nilDataConName) UserTypeCtxt
GenSigCtxt
TcSigmaType
list_ty ExpSigmaType
res_ty
; let expr :: LHsExpr GhcTcId
expr :: LHsExpr GhcTcId
expr = 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
$ XExplicitList GhcTcId
-> Maybe (SyntaxExpr GhcTcId)
-> [LHsExpr GhcTcId]
-> HsExpr GhcTcId
forall p.
XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p
ExplicitList TcSigmaType
XExplicitList GhcTcId
ty_arg' Maybe (SyntaxExpr GhcTcId)
forall a. Maybe a
Nothing []
; (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
-> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, LHsExpr GhcTcId
expr, []) }
tcApp m_herald :: Maybe SDoc
m_herald fun :: LHsExpr GhcRn
fun args :: [LHsExprArgIn]
args res_ty :: ExpSigmaType
res_ty
= do { (tc_fun :: LHsExpr GhcTcId
tc_fun, fun_ty :: 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 m_herald :: Maybe SDoc
m_herald rn_fun :: LHsExpr GhcRn
rn_fun tc_fun :: LHsExpr GhcTcId
tc_fun fun_sigma :: TcSigmaType
fun_sigma rn_args :: [LHsExprArgIn]
rn_args res_ty :: ExpSigmaType
res_ty
= do { let orig :: CtOrigin
orig = LHsExpr GhcRn -> CtOrigin
lexprCtOrigin LHsExpr GhcRn
rn_fun
; String -> SDoc -> TcRn ()
traceTc "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)
; (wrap_fun :: HsWrapper
wrap_fun, tc_args :: [LHsExprArgOut]
tc_args, actual_res_ty :: 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 -> HsExpr GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (LHsExpr GhcRn -> HsExpr GhcRn) -> LHsExpr GhcRn -> HsExpr 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 fun :: LHsExpr GhcRn
fun args :: [LHsExprArgIn]
args = [SDoc] -> SDoc
sep [ String -> SDoc
text "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 "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 = "function"
| Bool
otherwise = "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 _ hs_ty :: 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 op :: LHsExpr GhcRn
op = String -> SDoc
text "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 "takes"
tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
tcInferFun (L loc :: SrcSpan
loc (HsVar _ (L _ name :: IdP GhcRn
name)))
= do { (fun :: HsExpr GhcTcId
fun, ty :: 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 loc :: SrcSpan
loc (HsRecFld _ f :: AmbiguousFieldOcc GhcRn
f))
= do { (fun :: HsExpr GhcTcId
fun, ty :: 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 fun :: 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 fun :: LHsExpr GhcRn
fun orig_fun_ty :: TcSigmaType
orig_fun_ty fun_orig :: CtOrigin
fun_orig orig_args :: [LHsExprArgIn]
orig_args herald :: SDoc
herald
= [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go [] 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
go :: [TcSigmaType]
-> Int
-> TcSigmaType
-> [LHsExprArgIn]
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
go _ _ fun_ty :: 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 acc_args :: [TcSigmaType]
acc_args n :: Int
n fun_ty :: TcSigmaType
fun_ty (HsArgPar sp :: SrcSpan
sp : args :: [LHsExprArgIn]
args)
= do { (inner_wrap :: HsWrapper
inner_wrap, args' :: [LHsExprArgOut]
args', res_ty :: 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 acc_args :: [TcSigmaType]
acc_args n :: Int
n fun_ty :: TcSigmaType
fun_ty (HsTypeArg l :: SrcSpan
l hs_ty_arg :: HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg : args :: [LHsExprArgIn]
args)
= do { (wrap1 :: HsWrapper
wrap1, upsilon_ty :: 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 (tvb :: TyVarBinder
tvb, inner_ty :: 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 "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 ])
; (inner_wrap :: HsWrapper
inner_wrap, args' :: [LHsExprArgOut]
args', res_ty :: 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
+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 ) }
_ -> 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 acc_args :: [TcSigmaType]
acc_args n :: Int
n fun_ty :: TcSigmaType
fun_ty (HsValArg arg :: LHsExpr GhcRn
arg : args :: [LHsExprArgIn]
args)
= do { (wrap :: HsWrapper
wrap, [arg_ty :: TcSigmaType
arg_ty], res_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)) 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
; (inner_wrap :: HsWrapper
inner_wrap, args' :: [LHsExprArgOut]
args', inner_res_ty :: 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
+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 "When checking the" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
n SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text "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 ty :: TcSigmaType
ty arg :: a
arg
= do { (_, ty :: 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 "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 "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 fun :: LHsExpr GhcRn
fun arg :: LHsExpr GhcRn
arg ty :: TcSigmaType
ty arg_no :: 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 args :: [LHsTupArg GhcRn]
args tys :: [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
l (Missing {}), arg_ty :: 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
l (Present x :: XPresent GhcRn
x expr :: LHsExpr GhcRn
expr), arg_ty :: 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 _ (XTupArg{}), _) = String
-> IOEnv (Env TcGblEnv TcLclEnv) (GenLocated l (HsTupArg GhcTcId))
forall a. String -> a
panic "tcTupArgs"
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 orig :: CtOrigin
orig expr :: SyntaxExpr GhcRn
expr arg_tys :: [SyntaxOpType]
arg_tys res_ty :: 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 orig :: CtOrigin
orig op :: SyntaxExpr GhcRn
op arg_tys :: [SyntaxOpType]
arg_tys res_ty :: SyntaxOpType
res_ty thing_inside :: [TcSigmaType] -> TcM a
thing_inside
= do { (expr :: LHsExpr GhcTcId
expr, sigma :: 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
; (result :: a
result, expr_wrap :: HsWrapper
expr_wrap, arg_wraps :: [HsWrapper]
arg_wraps, res_wrap :: 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
; (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 orig :: CtOrigin
orig sigma_ty :: TcSigmaType
sigma_ty syn_ty :: SyntaxOpType
syn_ty thing_inside :: [TcSigmaType] -> TcM a
thing_inside
= do { (skol_wrap :: HsWrapper
skol_wrap, (result :: a
result, ty_wrapper :: 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
$ \ _ rho_ty :: 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 rho_ty :: TcSigmaType
rho_ty 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 rho_ty :: TcSigmaType
rho_ty 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 rho_ty :: TcSigmaType
rho_ty SynList
= do { (list_co :: TcCoercionR
list_co, elt_ty :: 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 rho_ty :: TcSigmaType
rho_ty (SynFun arg_shape :: SyntaxOpType
arg_shape res_shape :: SyntaxOpType
res_shape)
= do { ( ( ( (result :: a
result, arg_ty :: TcSigmaType
arg_ty, res_ty :: TcSigmaType
res_ty)
, res_wrapper :: HsWrapper
res_wrapper )
, arg_wrapper1 :: HsWrapper
arg_wrapper1, [], arg_wrapper2 :: HsWrapper
arg_wrapper2 )
, match_wrapper :: 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 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
$
\ [arg_ty :: ExpSigmaType
arg_ty] res_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
$
\ arg_results :: [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
$
\ res_results :: [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 "This rebindable syntax expects a function with"
doc :: SDoc
doc = String -> SDoc
text "When checking a rebindable syntax operator arising from" SDoc -> SDoc -> SDoc
<+> CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig
go rho_ty :: TcSigmaType
rho_ty (SynType the_ty :: 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 orig :: CtOrigin
orig sigma_ty :: TcSigmaType
sigma_ty arg_shapes :: [SyntaxOpType]
arg_shapes res_shape :: SyntaxOpType
res_shape thing_inside :: [TcSigmaType] -> TcM a
thing_inside
= do { (match_wrapper :: HsWrapper
match_wrapper, arg_tys :: [TcSigmaType]
arg_tys, res_ty :: 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
; ((result :: a
result, res_wrapper :: HsWrapper
res_wrapper), arg_wrappers :: [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
$ \ arg_results :: [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
$ \ res_results :: [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 "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 (arg_ty :: TcSigmaType
arg_ty : arg_tys :: [TcSigmaType]
arg_tys) (arg_shape :: SyntaxOpType
arg_shape : arg_shapes :: [SyntaxOpType]
arg_shapes) thing_inside :: [TcSigmaType] -> TcM a
thing_inside
= do { ((result :: a
result, arg_wraps :: [HsWrapper]
arg_wraps), arg_wrap :: 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
$ \ arg1_results :: [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
$ \ args_results :: [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 _ _ thing_inside :: [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 res_ty :: TcSigmaType
res_ty SynAny thing_inside :: [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 res_ty :: TcSigmaType
res_ty SynRho thing_inside :: [TcSigmaType] -> TcM a
thing_inside
= do { (inst_wrap :: HsWrapper
inst_wrap, rho_ty :: 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 res_ty :: TcSigmaType
res_ty SynList thing_inside :: [TcSigmaType] -> TcM a
thing_inside
= do { (inst_wrap :: HsWrapper
inst_wrap, rho_ty :: TcSigmaType
rho_ty) <- CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)
topInstantiate CtOrigin
orig TcSigmaType
res_ty
; (list_co :: TcCoercionR
list_co, elt_ty :: 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 _ (SynFun {}) _
= String -> SDoc -> TcM (a, HsWrapper)
forall a. HasCallStack => String -> SDoc -> a
pprPanic "tcSynArgA hits a SynFun" (CtOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr CtOrigin
orig)
tc_syn_arg res_ty :: TcSigmaType
res_ty (SynType the_ty :: ExpSigmaType
the_ty) thing_inside :: [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 expr :: 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 { (tv_prs :: [(Name, EvVar)]
tv_prs, theta :: [TcSigmaType]
theta, tau :: 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 "tcExprSig: CompleteSig" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text "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 "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
; (ev_binds :: TcEvBinds
ev_binds, expr' :: 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 expr :: 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 { (tclvl :: TcLevel
tclvl, wanted :: WantedConstraints
wanted, (expr' :: LHsExpr GhcTcId
expr', sig_inst :: 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
; (qtvs :: [EvVar]
qtvs, givens :: [EvVar]
givens, ev_binds :: TcEvBinds
ev_binds, residual :: WantedConstraints
residual, _)
<- 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
; (binders :: [TyVarBinder]
binders, my_theta :: [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 "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
name res_ty :: ExpSigmaType
res_ty
= do { (expr :: HsExpr GhcTcId
expr, actual_res_ty :: TcSigmaType
actual_res_ty) <- Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId Name
name
; String -> SDoc -> TcRn ()
traceTc "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
NoExt
noExt (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
NoExt
noExt (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 rn_expr :: HsExpr GhcRn
rn_expr f :: AmbiguousFieldOcc GhcRn
f@(Unambiguous _ (L _ lbl :: RdrName
lbl)) res_ty :: ExpSigmaType
res_ty
= do { (expr :: HsExpr GhcTcId
expr, actual_res_ty :: 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
NoExt
noExt 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 rn_expr :: HsExpr GhcRn
rn_expr (Ambiguous _ lbl :: Located RdrName
lbl) res_ty :: 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
Nothing -> Located RdrName -> TcM (HsExpr GhcTcId)
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lbl
Just (arg :: TcSigmaType
arg, _) -> 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 _ (XAmbiguousFieldOcc _) _ = String -> TcM (HsExpr GhcTcId)
forall a. String -> a
panic "tcCheckRecSelId"
tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType)
tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferRecSelId (Unambiguous sel :: XUnambiguous GhcRn
sel (L _ lbl :: RdrName
lbl))
= do { (expr' :: HsExpr GhcTcId
expr', ty :: 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 _ lbl :: Located RdrName
lbl)
= Located RdrName -> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lbl
tcInferRecSelId (XAmbiguousFieldOcc _) = String -> TcM (HsExpr GhcTcId, TcSigmaType)
forall a. String -> a
panic "tcInferRecSelId"
tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tcInferId id_name :: 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 "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 { (expr :: HsExpr GhcTcId
expr, ty :: TcSigmaType
ty) <- RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
tc_infer_id (Name -> RdrName
nameRdrName Name
id_name) Name
id_name
; String -> SDoc -> TcRn ()
traceTc "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 assert_name :: Name
assert_name
= do { EvVar
assert_error_id <- Name -> TcM EvVar
tcLookupId Name
assertErrorName
; (wrap :: HsWrapper
wrap, id_rho :: 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
NoExt
noExt (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 lbl :: RdrName
lbl id_name :: 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 ~ NoExt, IdP p ~ EvVar) =>
EvVar -> m (HsExpr p, TcSigmaType)
return_id EvVar
id }
AGlobal (AnId id :: EvVar
id)
-> do { EvVar -> TcRn ()
check_naughty EvVar
id
; EvVar -> TcM (HsExpr GhcTcId, TcSigmaType)
forall (m :: * -> *) p.
(Monad m, XVar p ~ NoExt, IdP p ~ EvVar) =>
EvVar -> m (HsExpr p, TcSigmaType)
return_id EvVar
id }
AGlobal (AConLike cl :: ConLike
cl) -> case ConLike
cl of
RealDataCon con :: DataCon
con -> DataCon -> TcM (HsExpr GhcTcId, TcSigmaType)
return_data_con DataCon
con
PatSynCon ps :: PatSyn
ps -> PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
tcPatSynBuilderOcc PatSyn
ps
_ -> 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 "used where a value identifier was expected" }
where
return_id :: EvVar -> m (HsExpr p, TcSigmaType)
return_id 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
NoExt
noExt (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 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
NoExt
noExt (DataCon -> ConLike
RealDataCon DataCon
con), TcSigmaType
con_ty)
| Bool
otherwise
= do { let (tvs :: [EvVar]
tvs, theta :: [TcSigmaType]
theta, rho :: TcSigmaType
rho) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
con_ty
; (subst :: TCvSubst
subst, tvs' :: [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
NoExt
noExt (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 id :: 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 rn_expr :: HsExpr GhcRn
rn_expr unbound :: UnboundVar
unbound res_ty :: 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
NoExt
noExt (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 loc :: SrcSpan
loc fun_name :: Name
fun_name args :: [LHsExprArgIn]
args res_ty :: 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
(before :: [LHsExprArgIn]
before, _:after :: [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 _ hs_ty_arg :: HsWildCardBndrs GhcRn (GenLocated SrcSpan (HsType GhcRn))
hs_ty_arg, HsValArg term_arg :: 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 term_arg :: 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 }
_ -> String
-> [LHsExprArgIn] -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcRn)
forall a. String -> [LHsExprArgIn] -> TcM a
too_many_args "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 (tc :: TyCon
tc, tc_args :: [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 (rep_tc :: TyCon
rep_tc, rep_args :: [TcSigmaType]
rep_args, coi :: 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
NoExt
noExt (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 "Specify the type by giving a type signature"
, String -> SDoc
text "e.g. (tagToEnum# x) :: Bool" ]
doc2 :: SDoc
doc2 = String -> SDoc
text "Result type must be an enumeration type"
mk_error :: TcType -> SDoc -> SDoc
mk_error :: TcSigmaType -> SDoc -> SDoc
mk_error ty :: TcSigmaType
ty what :: SDoc
what
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Bad call to tagToEnum#"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "at type" SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty)
2 SDoc
what
too_many_args :: String -> [LHsExprArgIn] -> TcM a
too_many_args :: String -> [LHsExprArgIn] -> TcM a
too_many_args fun :: String
fun args :: [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 "Too many type arguments to" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
fun SDoc -> SDoc -> SDoc
<> SDoc
colon)
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)) =>
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 e :: a
e) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
e
pp (HsTypeArg _ (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = L _ t :: HsType (GhcPass p)
t })) = HsType (GhcPass p) -> SDoc
forall (p :: Pass).
OutputableBndrId (GhcPass p) =>
HsType (GhcPass p) -> SDoc
pprHsType HsType (GhcPass p)
t
pp (HsTypeArg _ (XHsWildCardBndrs _)) = String -> SDoc
forall a. String -> a
panic "too_many_args"
pp (HsArgPar _) = SDoc
empty
checkThLocalId :: Id -> TcM ()
checkThLocalId :: EvVar -> TcRn ()
checkThLocalId id :: 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 (top_lvl :: TopLevelFlag
top_lvl, bind_lvl :: Int
bind_lvl, use_stage :: ThStage
use_stage)
| ThStage -> Int
thLevel ThStage
use_stage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
bind_lvl
-> TopLevelFlag -> EvVar -> ThStage -> TcRn ()
checkCrossStageLifting TopLevelFlag
top_lvl EvVar
id ThStage
use_stage
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
checkCrossStageLifting :: TopLevelFlag -> EvVar -> ThStage -> TcRn ()
checkCrossStageLifting top_lvl :: TopLevelFlag
top_lvl id :: EvVar
id (Brack _ (TcPending ps_var :: TcRef [PendingTcSplice]
ps_var lie_var :: TcRef WantedConstraints
lie_var))
| TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
= Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Bool
isExternalName Name
id_name) (Name -> TcRn ()
keepAlive Name
id_name)
| Bool
otherwise
=
do { let id_ty :: TcSigmaType
id_ty = EvVar -> TcSigmaType
idType EvVar
id
; Bool -> SDoc -> TcRn ()
checkTc (TcSigmaType -> Bool
isTauTy TcSigmaType
id_ty) (EvVar -> SDoc
polySpliceErr EvVar
id)
; HsExpr GhcTcId
lift <- if TcSigmaType -> Bool
isStringTy TcSigmaType
id_ty then
do { EvVar
sid <- Name -> TcM EvVar
tcLookupId Name
THNames.liftStringName
; HsExpr GhcTcId -> TcM (HsExpr GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return (XVar GhcTcId -> Located (IdP GhcTcId) -> HsExpr GhcTcId
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcTcId
NoExt
noExt (SrcSpanLess (Located EvVar) -> Located EvVar
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located EvVar)
EvVar
sid)) }
else
TcRef WantedConstraints
-> TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall a. TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar TcRef WantedConstraints
lie_var (TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId))
-> TcM (HsExpr GhcTcId) -> TcM (HsExpr GhcTcId)
forall a b. (a -> b) -> a -> b
$
CtOrigin -> Name -> TcSigmaType -> TcM (HsExpr GhcTcId)
newMethodFromName (Name -> CtOrigin
OccurrenceOf Name
id_name)
Name
THNames.liftName TcSigmaType
id_ty
; [PendingTcSplice]
ps <- TcRef [PendingTcSplice]
-> IOEnv (Env TcGblEnv TcLclEnv) [PendingTcSplice]
forall a env. IORef a -> IOEnv env a
readMutVar TcRef [PendingTcSplice]
ps_var
; let pending_splice :: PendingTcSplice
pending_splice = Name -> LHsExpr GhcTcId -> PendingTcSplice
PendingTcSplice Name
id_name
(LHsExpr GhcTcId -> LHsExpr GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (SrcSpanLess (LHsExpr GhcTcId) -> LHsExpr GhcTcId
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcTcId)
HsExpr GhcTcId
lift) (IdP GhcTcId -> LHsExpr GhcTcId
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar EvVar
IdP GhcTcId
id))
; TcRef [PendingTcSplice] -> [PendingTcSplice] -> TcRn ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar TcRef [PendingTcSplice]
ps_var (PendingTcSplice
pending_splice PendingTcSplice -> [PendingTcSplice] -> [PendingTcSplice]
forall a. a -> [a] -> [a]
: [PendingTcSplice]
ps)
; () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
where
id_name :: Name
id_name = EvVar -> Name
idName EvVar
id
checkCrossStageLifting _ _ _ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
polySpliceErr :: Id -> SDoc
polySpliceErr :: EvVar -> SDoc
polySpliceErr id :: EvVar
id
= String -> SDoc
text "Can't splice the polymorphic local variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
id)
getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
getFixedTyVars :: [FastString] -> [EvVar] -> [ConLike] -> VarSet
getFixedTyVars upd_fld_occs :: [FastString]
upd_fld_occs univ_tvs :: [EvVar]
univ_tvs cons :: [ConLike]
cons
= [EvVar] -> VarSet
mkVarSet [EvVar
tv1 | ConLike
con <- [ConLike]
cons
, let (u_tvs :: [EvVar]
u_tvs, _, eqspec :: [EqSpec]
eqspec, prov_theta :: [TcSigmaType]
prov_theta
, req_theta :: [TcSigmaType]
req_theta, arg_tys :: [TcSigmaType]
arg_tys, _)
= ConLike
-> ([EvVar], [EvVar], [EqSpec], [TcSigmaType], [TcSigmaType],
[TcSigmaType], TcSigmaType)
conLikeFullSig ConLike
con
theta :: [TcSigmaType]
theta = [EqSpec] -> [TcSigmaType]
eqSpecPreds [EqSpec]
eqspec
[TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
prov_theta
[TcSigmaType] -> [TcSigmaType] -> [TcSigmaType]
forall a. [a] -> [a] -> [a]
++ [TcSigmaType]
req_theta
flds :: [FieldLbl Name]
flds = ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con
fixed_tvs :: VarSet
fixed_tvs = [TcSigmaType] -> VarSet
exactTyCoVarsOfTypes [TcSigmaType]
fixed_tys
VarSet -> VarSet -> VarSet
`unionVarSet` [TcSigmaType] -> VarSet
tyCoVarsOfTypes [TcSigmaType]
theta
fixed_tys :: [TcSigmaType]
fixed_tys = [TcSigmaType
ty | (fl :: FieldLbl Name
fl, ty :: TcSigmaType
ty) <- [FieldLbl Name] -> [TcSigmaType] -> [(FieldLbl Name, TcSigmaType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FieldLbl Name]
flds [TcSigmaType]
arg_tys
, Bool -> Bool
not (FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLbl Name
fl FastString -> [FastString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FastString]
upd_fld_occs)]
, (tv1 :: EvVar
tv1,tv :: EvVar
tv) <- [EvVar]
univ_tvs [EvVar] -> [EvVar] -> [(EvVar, EvVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [EvVar]
u_tvs
, EvVar
tv EvVar -> VarSet -> Bool
`elemVarSet` VarSet
fixed_tvs ]
disambiguateSelector :: Located RdrName -> Type -> TcM Name
disambiguateSelector :: Located RdrName -> TcSigmaType -> TcM Name
disambiguateSelector lr :: Located RdrName
lr@(L _ rdr :: RdrName
rdr) parent_type :: TcSigmaType
parent_type
= do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; case FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcSigmaType
parent_type of
Nothing -> Located RdrName -> TcM Name
forall a. Located RdrName -> TcM a
ambiguousSelector Located RdrName
lr
Just p :: TyCon
p ->
do { [(RecSelParent, GlobalRdrElt)]
xs <- RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents RdrName
rdr
; let parent :: RecSelParent
parent = TyCon -> RecSelParent
RecSelData TyCon
p
; case RecSelParent
-> [(RecSelParent, GlobalRdrElt)] -> Maybe GlobalRdrElt
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RecSelParent
parent [(RecSelParent, GlobalRdrElt)]
xs of
Just gre :: GlobalRdrElt
gre -> do { Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
; Name -> TcM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre) }
Nothing -> SDoc -> TcM Name
forall a. SDoc -> TcRn a
failWithTc (RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
parent RdrName
rdr) } }
ambiguousSelector :: Located RdrName -> TcM a
ambiguousSelector :: Located RdrName -> TcM a
ambiguousSelector (L _ rdr :: RdrName
rdr)
= do { GlobalRdrEnv
env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; let gres :: [GlobalRdrElt]
gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName RdrName
rdr GlobalRdrEnv
env
; [ErrCtxt] -> TcRn () -> TcRn ()
forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [] (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ RdrName -> [GlobalRdrElt] -> TcRn ()
addNameClashErrRn RdrName
rdr [GlobalRdrElt]
gres
; TcM a
forall env a. IOEnv env a
failM }
disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
-> [LHsRecUpdField GhcRn] -> ExpRhoType
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds :: LHsExpr GhcRn
-> TcSigmaType
-> [LHsRecUpdField GhcRn]
-> ExpSigmaType
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
disambiguateRecordBinds record_expr :: LHsExpr GhcRn
record_expr record_rho :: TcSigmaType
record_rho rbnds :: [LHsRecUpdField GhcRn]
rbnds res_ty :: ExpSigmaType
res_ty
= case (LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name))
-> [LHsRecUpdField GhcRn] -> Maybe [(LHsRecUpdField GhcRn, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
isUnambiguous [LHsRecUpdField GhcRn]
rbnds of
Just rbnds' :: [(LHsRecUpdField GhcRn, Name)]
rbnds' -> ((LHsRecUpdField GhcRn, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)))
-> [(LHsRecUpdField GhcRn, Name)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LHsRecUpdField GhcRn, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
lookupSelector [(LHsRecUpdField GhcRn, Name)]
rbnds'
Nothing ->
do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents <- TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
; let possible_parents :: [[RecSelParent]]
possible_parents = ((LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> [RecSelParent])
-> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
-> [[RecSelParent]]
forall a b. (a -> b) -> [a] -> [b]
map (((RecSelParent, GlobalRdrElt) -> RecSelParent)
-> [(RecSelParent, GlobalRdrElt)] -> [RecSelParent]
forall a b. (a -> b) -> [a] -> [b]
map (RecSelParent, GlobalRdrElt) -> RecSelParent
forall a b. (a, b) -> a
fst ([(RecSelParent, GlobalRdrElt)] -> [RecSelParent])
-> ((LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> [(RecSelParent, GlobalRdrElt)])
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> [RecSelParent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> [(RecSelParent, GlobalRdrElt)]
forall a b. (a, b) -> b
snd) [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents
; RecSelParent
p <- FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent FamInstEnvs
fam_inst_envs [[RecSelParent]]
possible_parents
; TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
forall r. TcM r -> TcM r
checkNoErrs (TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)])
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
forall a b. (a -> b) -> a -> b
$ ((LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)))
-> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
-> TcM [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
pickParent RecSelParent
p) [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
rbnds_with_parents }
where
isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn, Name)
isUnambiguous x :: LHsRecUpdField GhcRn
x = case Located (AmbiguousFieldOcc GhcRn)
-> SrcSpanLess (Located (AmbiguousFieldOcc GhcRn))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (LHsRecUpdField GhcRn -> SrcSpanLess (LHsRecUpdField GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsRecUpdField GhcRn
x)) of
Unambiguous sel_name _ -> (LHsRecUpdField GhcRn, Name) -> Maybe (LHsRecUpdField GhcRn, Name)
forall a. a -> Maybe a
Just (LHsRecUpdField GhcRn
x, Name
XUnambiguous GhcRn
sel_name)
Ambiguous{} -> Maybe (LHsRecUpdField GhcRn, Name)
forall a. Maybe a
Nothing
XAmbiguousFieldOcc{} -> Maybe (LHsRecUpdField GhcRn, Name)
forall a. Maybe a
Nothing
getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
= ([[(RecSelParent, GlobalRdrElt)]]
-> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])])
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
-> TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([LHsRecUpdField GhcRn]
-> [[(RecSelParent, GlobalRdrElt)]]
-> [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [LHsRecUpdField GhcRn]
rbnds) (IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
-> TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])])
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
-> TcM [(LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])]
forall a b. (a -> b) -> a -> b
$ (LHsRecUpdField GhcRn -> RnM [(RecSelParent, GlobalRdrElt)])
-> [LHsRecUpdField GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) [[(RecSelParent, GlobalRdrElt)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents (RdrName -> RnM [(RecSelParent, GlobalRdrElt)])
-> (LHsRecUpdField GhcRn -> RdrName)
-> LHsRecUpdField GhcRn
-> RnM [(RecSelParent, GlobalRdrElt)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located RdrName -> RdrName)
-> (LHsRecUpdField GhcRn -> Located RdrName)
-> LHsRecUpdField GhcRn
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located RdrName
forall (p :: Pass). HsRecUpdField (GhcPass p) -> Located RdrName
hsRecUpdFieldRdr (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located RdrName)
-> (LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn))
-> LHsRecUpdField GhcRn
-> Located RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc)
[LHsRecUpdField GhcRn]
rbnds
identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent fam_inst_envs :: FamInstEnvs
fam_inst_envs possible_parents :: [[RecSelParent]]
possible_parents
= case ([RecSelParent] -> [RecSelParent] -> [RecSelParent])
-> [[RecSelParent]] -> [RecSelParent]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 [RecSelParent] -> [RecSelParent] -> [RecSelParent]
forall a. Eq a => [a] -> [a] -> [a]
intersect [[RecSelParent]]
possible_parents of
[] -> SDoc -> TcM RecSelParent
forall a. SDoc -> TcRn a
failWithTc ([LHsRecUpdField GhcRn] -> SDoc
noPossibleParents [LHsRecUpdField GhcRn]
rbnds)
[p :: RecSelParent
p] -> RecSelParent -> TcM RecSelParent
forall (m :: * -> *) a. Monad m => a -> m a
return RecSelParent
p
_:_ | Just p :: TyCon
p <- FamInstEnvs -> ExpSigmaType -> Maybe TyCon
tyConOfET FamInstEnvs
fam_inst_envs ExpSigmaType
res_ty -> RecSelParent -> TcM RecSelParent
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
p)
| Just {} <- HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
record_expr)
, Just tc :: TyCon
tc <- FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs TcSigmaType
record_rho
-> RecSelParent -> TcM RecSelParent
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> RecSelParent
RecSelData TyCon
tc)
_ -> SDoc -> TcM RecSelParent
forall a. SDoc -> TcRn a
failWithTc SDoc
badOverloadedUpdate
pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
pickParent p :: RecSelParent
p (upd :: LHsRecUpdField GhcRn
upd, xs :: [(RecSelParent, GlobalRdrElt)]
xs)
= case RecSelParent
-> [(RecSelParent, GlobalRdrElt)] -> Maybe GlobalRdrElt
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RecSelParent
p [(RecSelParent, GlobalRdrElt)]
xs of
Just gre :: GlobalRdrElt
gre -> do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(RecSelParent, GlobalRdrElt)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(RecSelParent, GlobalRdrElt)] -> [(RecSelParent, GlobalRdrElt)]
forall a. [a] -> [a]
tail [(RecSelParent, GlobalRdrElt)]
xs)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
let L loc :: SrcSpan
loc _ = HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (LHsRecUpdField GhcRn -> SrcSpanLess (LHsRecUpdField GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsRecUpdField GhcRn
upd)
SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
; (LHsRecUpdField GhcRn, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre) }
Nothing -> do { SDoc -> TcRn ()
addErrTc (RecSelParent -> RdrName -> SDoc
fieldNotInType RecSelParent
p
(Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located RdrName
forall (p :: Pass). HsRecUpdField (GhcPass p) -> Located RdrName
hsRecUpdFieldRdr (LHsRecUpdField GhcRn -> SrcSpanLess (LHsRecUpdField GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsRecUpdField GhcRn
upd))))
; (LHsRecUpdField GhcRn, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
lookupSelector (LHsRecUpdField GhcRn
upd, GlobalRdrElt -> Name
gre_name ((RecSelParent, GlobalRdrElt) -> GlobalRdrElt
forall a b. (a, b) -> b
snd ([(RecSelParent, GlobalRdrElt)] -> (RecSelParent, GlobalRdrElt)
forall a. [a] -> a
head [(RecSelParent, GlobalRdrElt)]
xs))) }
lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
lookupSelector (L l :: SrcSpan
l upd :: HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
upd, n :: Name
n)
= do { EvVar
i <- Name -> TcM EvVar
tcLookupId Name
n
; let L loc :: SrcSpan
loc af :: AmbiguousFieldOcc GhcRn
af = HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
upd
lbl :: RdrName
lbl = AmbiguousFieldOcc GhcRn -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcRn
af
; LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)))
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn))
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
upd { hsRecFieldLbl :: Located (AmbiguousFieldOcc GhcTcId)
hsRecFieldLbl
= SrcSpan
-> AmbiguousFieldOcc GhcTcId -> Located (AmbiguousFieldOcc GhcTcId)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcTcId
-> Located RdrName -> AmbiguousFieldOcc GhcTcId
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous EvVar
XUnambiguous GhcTcId
i (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
lbl)) } }
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf fam_inst_envs :: FamInstEnvs
fam_inst_envs ty0 :: TcSigmaType
ty0
= case HasCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty of
Just (tc :: TyCon
tc, tys :: [TcSigmaType]
tys) -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just ((TyCon, [TcSigmaType], TcCoercionR) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 (FamInstEnvs
-> TyCon -> [TcSigmaType] -> (TyCon, [TcSigmaType], TcCoercionR)
tcLookupDataFamInst FamInstEnvs
fam_inst_envs TyCon
tc [TcSigmaType]
tys))
Nothing -> Maybe TyCon
forall a. Maybe a
Nothing
where
(_, _, ty :: TcSigmaType
ty) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
ty0
tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET :: FamInstEnvs -> ExpSigmaType -> Maybe TyCon
tyConOfET fam_inst_envs :: FamInstEnvs
fam_inst_envs ty0 :: ExpSigmaType
ty0 = FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf FamInstEnvs
fam_inst_envs (TcSigmaType -> Maybe TyCon) -> Maybe TcSigmaType -> Maybe TyCon
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpSigmaType -> Maybe TcSigmaType
checkingExpType_maybe ExpSigmaType
ty0
lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents rdr :: RdrName
rdr
= do { GlobalRdrEnv
env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; let gres :: [GlobalRdrElt]
gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName RdrName
rdr GlobalRdrEnv
env
; (GlobalRdrElt
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt))
-> [GlobalRdrElt] -> RnM [(RecSelParent, GlobalRdrElt)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GlobalRdrElt
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
lookupParent [GlobalRdrElt]
gres }
where
lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
lookupParent :: GlobalRdrElt
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
lookupParent gre :: GlobalRdrElt
gre = do { EvVar
id <- Name -> TcM EvVar
tcLookupId (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre)
; if EvVar -> Bool
isRecordSelector EvVar
id
then (RecSelParent, GlobalRdrElt)
-> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall (m :: * -> *) a. Monad m => a -> m a
return (EvVar -> RecSelParent
recordSelectorTyCon EvVar
id, GlobalRdrElt
gre)
else SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (RecSelParent, GlobalRdrElt)
forall a. SDoc -> TcRn a
failWithTc (Name -> SDoc
notSelector (GlobalRdrElt -> Name
gre_name GlobalRdrElt
gre)) }
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (ExprWithTySig _ _ ty :: LHsSigWcType (NoGhcTc GhcRn)
ty) = LHsSigWcType GhcRn -> Maybe (LHsSigWcType GhcRn)
forall a. a -> Maybe a
Just LHsSigWcType (NoGhcTc GhcRn)
LHsSigWcType GhcRn
ty
obviousSig (HsPar _ p :: LHsExpr GhcRn
p) = HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
obviousSig (LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
p)
obviousSig _ = Maybe (LHsSigWcType GhcRn)
forall a. Maybe a
Nothing
tcRecordBinds
:: ConLike
-> [TcType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTcId)
tcRecordBinds :: ConLike
-> [TcSigmaType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTcId)
tcRecordBinds con_like :: ConLike
con_like arg_tys :: [TcSigmaType]
arg_tys (HsRecFields rbinds :: [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds dd :: Maybe Int
dd)
= do { [Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))]
mb_binds <- (LHsRecField GhcRn (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))))
-> [LHsRecField GhcRn (LHsExpr GhcRn)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField GhcRn (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
do_bind [LHsRecField GhcRn (LHsExpr GhcRn)]
rbinds
; HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsRecField GhcTcId (LHsExpr GhcTcId)]
-> Maybe Int -> HsRecordBinds GhcTcId
forall p arg. [LHsRecField p arg] -> Maybe Int -> HsRecFields p arg
HsRecFields ([Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))]
-> [LHsRecField GhcTcId (LHsExpr GhcTcId)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))]
mb_binds) Maybe Int
dd) }
where
fields :: [Name]
fields = (FieldLbl Name -> Name) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector ([FieldLbl Name] -> [Name]) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con_like
flds_w_tys :: [(Name, TcSigmaType)]
flds_w_tys = String -> [Name] -> [TcSigmaType] -> [(Name, TcSigmaType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual "tcRecordBinds" [Name]
fields [TcSigmaType]
arg_tys
do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
do_bind (L l :: SrcSpan
l fld :: HsRecField GhcRn (LHsExpr GhcRn)
fld@(HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = Located (FieldOcc GhcRn)
f
, hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = LHsExpr GhcRn
rhs }))
= do { Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
mb <- ConLike
-> [(Name, TcSigmaType)]
-> Located (FieldOcc GhcRn)
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
tcRecordField ConLike
con_like [(Name, TcSigmaType)]
flds_w_tys Located (FieldOcc GhcRn)
f LHsExpr GhcRn
rhs
; case Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
mb of
Nothing -> Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))
forall a. Maybe a
Nothing
Just (f' :: LFieldOcc GhcTcId
f', rhs' :: LHsExpr GhcTcId
rhs') -> Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsRecField GhcTcId (LHsExpr GhcTcId)
-> Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId))
forall a. a -> Maybe a
Just (SrcSpan
-> HsRecField' (FieldOcc GhcTcId) (LHsExpr GhcTcId)
-> LHsRecField GhcTcId (LHsExpr GhcTcId)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsRecField GhcRn (LHsExpr GhcRn)
fld { hsRecFieldLbl :: LFieldOcc GhcTcId
hsRecFieldLbl = LFieldOcc GhcTcId
f'
, hsRecFieldArg :: LHsExpr GhcTcId
hsRecFieldArg = LHsExpr GhcTcId
rhs' }))) }
tcRecordUpd
:: ConLike
-> [TcType]
-> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTcId]
tcRecordUpd :: ConLike
-> [TcSigmaType]
-> [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTcId]
tcRecordUpd con_like :: ConLike
con_like arg_tys :: [TcSigmaType]
arg_tys rbinds :: [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds = ([Maybe (LHsRecUpdField GhcTcId)] -> [LHsRecUpdField GhcTcId])
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTcId)]
-> TcM [LHsRecUpdField GhcTcId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (LHsRecUpdField GhcTcId)] -> [LHsRecUpdField GhcTcId]
forall a. [Maybe a] -> [a]
catMaybes (IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTcId)]
-> TcM [LHsRecUpdField GhcTcId])
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTcId)]
-> TcM [LHsRecUpdField GhcTcId]
forall a b. (a -> b) -> a -> b
$ (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTcId)))
-> [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [Maybe (LHsRecUpdField GhcTcId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTcId))
do_bind [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds
where
fields :: [Name]
fields = (FieldLbl Name -> Name) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector ([FieldLbl Name] -> [Name]) -> [FieldLbl Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con_like
flds_w_tys :: [(Name, TcSigmaType)]
flds_w_tys = String -> [Name] -> [TcSigmaType] -> [(Name, TcSigmaType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual "tcRecordUpd" [Name]
fields [TcSigmaType]
arg_tys
do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecUpdField GhcTcId))
do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTcId))
do_bind (L l :: SrcSpan
l fld :: HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
fld@(HsRecField { hsRecFieldLbl :: forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl = L loc :: SrcSpan
loc af :: AmbiguousFieldOcc GhcTcId
af
, hsRecFieldArg :: forall id arg. HsRecField' id arg -> arg
hsRecFieldArg = LHsExpr GhcRn
rhs }))
= do { let lbl :: RdrName
lbl = AmbiguousFieldOcc GhcTcId -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc AmbiguousFieldOcc GhcTcId
af
sel_id :: EvVar
sel_id = AmbiguousFieldOcc GhcTcId -> EvVar
selectorAmbiguousFieldOcc AmbiguousFieldOcc GhcTcId
af
f :: Located (FieldOcc GhcRn)
f = SrcSpan -> FieldOcc GhcRn -> Located (FieldOcc GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcRn -> Located RdrName -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc (EvVar -> Name
idName EvVar
sel_id) (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
lbl))
; Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
mb <- ConLike
-> [(Name, TcSigmaType)]
-> Located (FieldOcc GhcRn)
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
tcRecordField ConLike
con_like [(Name, TcSigmaType)]
flds_w_tys Located (FieldOcc GhcRn)
f LHsExpr GhcRn
rhs
; case Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
mb of
Nothing -> Maybe (LHsRecUpdField GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LHsRecUpdField GhcTcId)
forall a. Maybe a
Nothing
Just (f' :: LFieldOcc GhcTcId
f', rhs' :: LHsExpr GhcTcId
rhs') ->
Maybe (LHsRecUpdField GhcTcId)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe (LHsRecUpdField GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsRecUpdField GhcTcId -> Maybe (LHsRecUpdField GhcTcId)
forall a. a -> Maybe a
Just
(SrcSpan
-> HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcTcId)
-> LHsRecUpdField GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (HsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
fld { hsRecFieldLbl :: Located (AmbiguousFieldOcc GhcTcId)
hsRecFieldLbl
= SrcSpan
-> AmbiguousFieldOcc GhcTcId -> Located (AmbiguousFieldOcc GhcTcId)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUnambiguous GhcTcId
-> Located RdrName -> AmbiguousFieldOcc GhcTcId
forall pass.
XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass
Unambiguous
(FieldOcc GhcTcId -> XCFieldOcc GhcTcId
forall pass. FieldOcc pass -> XCFieldOcc pass
extFieldOcc (LFieldOcc GhcTcId -> SrcSpanLess (LFieldOcc GhcTcId)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LFieldOcc GhcTcId
f'))
(SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
lbl))
, hsRecFieldArg :: LHsExpr GhcTcId
hsRecFieldArg = LHsExpr GhcTcId
rhs' }))) }
tcRecordField :: ConLike -> Assoc Name Type
-> LFieldOcc GhcRn -> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField :: ConLike
-> [(Name, TcSigmaType)]
-> Located (FieldOcc GhcRn)
-> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
tcRecordField con_like :: ConLike
con_like flds_w_tys :: [(Name, TcSigmaType)]
flds_w_tys (L loc :: SrcSpan
loc (FieldOcc sel_name :: XCFieldOcc GhcRn
sel_name lbl :: Located RdrName
lbl)) rhs :: LHsExpr GhcRn
rhs
| Just field_ty :: TcSigmaType
field_ty <- [(Name, TcSigmaType)] -> Name -> Maybe TcSigmaType
forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe [(Name, TcSigmaType)]
flds_w_tys Name
XCFieldOcc GhcRn
sel_name
= SDoc
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (FastString -> SDoc
fieldCtxt FastString
field_lbl) (TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)))
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
forall a b. (a -> b) -> a -> b
$
do { LHsExpr GhcTcId
rhs' <- LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTcId)
tcPolyExprNC LHsExpr GhcRn
rhs TcSigmaType
field_ty
; let field_id :: EvVar
field_id = OccName -> Unique -> TcSigmaType -> SrcSpan -> EvVar
mkUserLocal (Name -> OccName
nameOccName Name
XCFieldOcc GhcRn
sel_name)
(Name -> Unique
nameUnique Name
XCFieldOcc GhcRn
sel_name)
TcSigmaType
field_ty SrcSpan
loc
; Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return ((LFieldOcc GhcTcId, LHsExpr GhcTcId)
-> Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
forall a. a -> Maybe a
Just (SrcSpan -> FieldOcc GhcTcId -> LFieldOcc GhcTcId
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcTcId -> Located RdrName -> FieldOcc GhcTcId
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc EvVar
XCFieldOcc GhcTcId
field_id Located RdrName
lbl), LHsExpr GhcTcId
rhs')) }
| Bool
otherwise
= do { SDoc -> TcRn ()
addErrTc (ConLike -> FastString -> SDoc
badFieldCon ConLike
con_like FastString
field_lbl)
; Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
-> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId)
forall a. Maybe a
Nothing }
where
field_lbl :: FastString
field_lbl = OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc (Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
lbl)
tcRecordField _ _ (L _ (XFieldOcc _)) _ = String -> TcM (Maybe (LFieldOcc GhcTcId, LHsExpr GhcTcId))
forall a. String -> a
panic "tcRecordField"
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM ()
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcRn ()
checkMissingFields con_like :: ConLike
con_like rbinds :: HsRecordBinds GhcRn
rbinds
| [FieldLbl Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLbl Name]
field_labels
= if (HsImplBang -> Bool) -> [HsImplBang] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsImplBang -> Bool
isBanged [HsImplBang]
field_strs then
SDoc -> TcRn ()
addErrTc (ConLike -> [FastString] -> SDoc
missingStrictFields ConLike
con_like [])
else do
Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingFields
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn Bool -> Bool -> Bool
&& [HsImplBang] -> Bool
forall a. [a] -> Bool
notNull [HsImplBang]
field_strs Bool -> Bool -> Bool
&& [FieldLbl Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLbl Name]
field_labels)
(WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingFields) Bool
True
(ConLike -> [FastString] -> SDoc
missingFields ConLike
con_like []))
| Bool
otherwise = do
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FastString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FastString]
missing_s_fields)
(SDoc -> TcRn ()
addErrTc (ConLike -> [FastString] -> SDoc
missingStrictFields ConLike
con_like [FastString]
missing_s_fields))
Bool
warn <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnMissingFields
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn Bool -> Bool -> Bool
&& [FastString] -> Bool
forall a. [a] -> Bool
notNull [FastString]
missing_ns_fields)
(WarnReason -> Bool -> SDoc -> TcRn ()
warnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingFields) Bool
True
(ConLike -> [FastString] -> SDoc
missingFields ConLike
con_like [FastString]
missing_ns_fields))
where
missing_s_fields :: [FastString]
missing_s_fields
= [ FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLbl Name
fl | (fl :: FieldLbl Name
fl, str :: HsImplBang
str) <- [(FieldLbl Name, HsImplBang)]
field_info,
HsImplBang -> Bool
isBanged HsImplBang
str,
Bool -> Bool
not (FieldLbl Name
fl FieldLbl Name -> [Name] -> Bool
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
FieldLbl a -> t a -> Bool
`elemField` [Name]
[XCFieldOcc GhcRn]
field_names_used)
]
missing_ns_fields :: [FastString]
missing_ns_fields
= [ FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLbl Name
fl | (fl :: FieldLbl Name
fl, str :: HsImplBang
str) <- [(FieldLbl Name, HsImplBang)]
field_info,
Bool -> Bool
not (HsImplBang -> Bool
isBanged HsImplBang
str),
Bool -> Bool
not (FieldLbl Name
fl FieldLbl Name -> [Name] -> Bool
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
FieldLbl a -> t a -> Bool
`elemField` [Name]
[XCFieldOcc GhcRn]
field_names_used)
]
field_names_used :: [XCFieldOcc GhcRn]
field_names_used = HsRecordBinds GhcRn -> [XCFieldOcc GhcRn]
forall p arg. HsRecFields p arg -> [XCFieldOcc p]
hsRecFields HsRecordBinds GhcRn
rbinds
field_labels :: [FieldLbl Name]
field_labels = ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con_like
field_info :: [(FieldLbl Name, HsImplBang)]
field_info = String
-> [FieldLbl Name] -> [HsImplBang] -> [(FieldLbl Name, HsImplBang)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual "missingFields"
[FieldLbl Name]
field_labels
[HsImplBang]
field_strs
field_strs :: [HsImplBang]
field_strs = ConLike -> [HsImplBang]
conLikeImplBangs ConLike
con_like
fl :: FieldLbl a
fl elemField :: FieldLbl a -> t a -> Bool
`elemField` flds :: t a
flds = (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ fl' :: a
fl' -> FieldLbl a -> a
forall a. FieldLbl a -> a
flSelector FieldLbl a
fl a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
fl') t a
flds
addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a
addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a
addExprErrCtxt expr :: LHsExpr GhcRn
expr = SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (LHsExpr GhcRn -> SDoc
exprCtxt LHsExpr GhcRn
expr)
exprCtxt :: LHsExpr GhcRn -> SDoc
exprCtxt :: LHsExpr GhcRn -> SDoc
exprCtxt expr :: LHsExpr GhcRn
expr
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "In the expression:") 2 (LHsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcRn
expr)
fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt :: FastString -> SDoc
fieldCtxt field_name :: FastString
field_name
= String -> SDoc
text "In the" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
field_name) SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit "field of a record")
addFunResCtxt :: Bool
-> HsExpr GhcRn -> TcType -> ExpRhoType
-> TcM a -> TcM a
addFunResCtxt :: Bool
-> HsExpr GhcRn -> TcSigmaType -> ExpSigmaType -> TcM a -> TcM a
addFunResCtxt has_args :: Bool
has_args fun :: HsExpr GhcRn
fun fun_res_ty :: TcSigmaType
fun_res_ty env_ty :: ExpSigmaType
env_ty
= (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM (\env :: TidyEnv
env -> (TidyEnv
env, ) (SDoc -> (TidyEnv, SDoc))
-> IOEnv (Env TcGblEnv TcLclEnv) SDoc -> TcM (TidyEnv, SDoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) SDoc
mk_msg)
where
mk_msg :: IOEnv (Env TcGblEnv TcLclEnv) SDoc
mk_msg
= do { Maybe TcSigmaType
mb_env_ty <- ExpSigmaType -> TcM (Maybe TcSigmaType)
readExpType_maybe ExpSigmaType
env_ty
; TcSigmaType
fun_res' <- TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
fun_res_ty
; TcSigmaType
env' <- case Maybe TcSigmaType
mb_env_ty of
Just env_ty :: TcSigmaType
env_ty -> TcSigmaType -> TcM TcSigmaType
zonkTcType TcSigmaType
env_ty
Nothing ->
do { Bool
dumping <- DumpFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
Opt_D_dump_tc_trace
; MASSERT( dumping )
; TcSigmaType -> TcM TcSigmaType
newFlexiTyVarTy TcSigmaType
liftedTypeKind }
; let
(_, _, fun_tau :: TcSigmaType
fun_tau) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitNestedSigmaTys TcSigmaType
fun_res'
(_, _, env_tau :: TcSigmaType
env_tau) = TcSigmaType -> ([EvVar], [TcSigmaType], TcSigmaType)
tcSplitSigmaTy TcSigmaType
env'
(args_fun :: [TcSigmaType]
args_fun, res_fun :: TcSigmaType
res_fun) = TcSigmaType -> ([TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
fun_tau
(args_env :: [TcSigmaType]
args_env, res_env :: TcSigmaType
res_env) = TcSigmaType -> ([TcSigmaType], TcSigmaType)
tcSplitFunTys TcSigmaType
env_tau
n_fun :: Int
n_fun = [TcSigmaType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TcSigmaType]
args_fun
n_env :: Int
n_env = [TcSigmaType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TcSigmaType]
args_env
info :: SDoc
info | Int
n_fun Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n_env = SDoc
Outputable.empty
| Int
n_fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_env
, TcSigmaType -> Bool
not_fun TcSigmaType
res_env
= String -> SDoc
text "Probable cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is applied to too few arguments"
| Bool
has_args
, TcSigmaType -> Bool
not_fun TcSigmaType
res_fun
= String -> SDoc
text "Possible cause:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
fun)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is applied to too many arguments"
| Bool
otherwise
= SDoc
Outputable.empty
; SDoc -> IOEnv (Env TcGblEnv TcLclEnv) SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
info }
where
not_fun :: TcSigmaType -> Bool
not_fun ty :: TcSigmaType
ty
= case HasCallStack => TcSigmaType -> Maybe (TyCon, [TcSigmaType])
TcSigmaType -> Maybe (TyCon, [TcSigmaType])
tcSplitTyConApp_maybe TcSigmaType
ty of
Just (tc :: TyCon
tc, _) -> TyCon -> Bool
isAlgTyCon TyCon
tc
Nothing -> Bool
False
badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
badFieldTypes :: [(FastString, TcSigmaType)] -> SDoc
badFieldTypes prs :: [(FastString, TcSigmaType)]
prs
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Record update for insufficiently polymorphic field"
SDoc -> SDoc -> SDoc
<> [(FastString, TcSigmaType)] -> SDoc
forall a. [a] -> SDoc
plural [(FastString, TcSigmaType)]
prs SDoc -> SDoc -> SDoc
<> SDoc
colon)
2 ([SDoc] -> SDoc
vcat [ FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
f SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> TcSigmaType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcSigmaType
ty | (f :: FastString
f,ty :: TcSigmaType
ty) <- [(FastString, TcSigmaType)]
prs ])
badFieldsUpd
:: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike]
-> SDoc
badFieldsUpd :: [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> [ConLike] -> SDoc
badFieldsUpd rbinds :: [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
rbinds data_cons :: [ConLike]
data_cons
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "No constructor has all these fields:")
2 ([FastString] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [FastString]
conflictingFields)
where
conflictingFields :: [FastString]
conflictingFields = case [(FastString, [Bool])]
nonMembers of
(nonMember :: FastString
nonMember, _) : _ -> [FastString
aMember, FastString
nonMember]
[] -> let
growingSets :: [(FieldLabelString, [Bool])]
growingSets :: [(FastString, [Bool])]
growingSets = ((FastString, [Bool])
-> (FastString, [Bool]) -> (FastString, [Bool]))
-> [(FastString, [Bool])] -> [(FastString, [Bool])]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 (FastString, [Bool])
-> (FastString, [Bool]) -> (FastString, [Bool])
forall a a. (a, [Bool]) -> (a, [Bool]) -> (a, [Bool])
combine [(FastString, [Bool])]
membership
combine :: (a, [Bool]) -> (a, [Bool]) -> (a, [Bool])
combine (_, setMem :: [Bool]
setMem) (field :: a
field, fldMem :: [Bool]
fldMem)
= (a
field, (Bool -> Bool -> Bool) -> [Bool] -> [Bool] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(&&) [Bool]
setMem [Bool]
fldMem)
in
([(FastString, [Bool])] -> FastString)
-> [[(FastString, [Bool])]] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map ((FastString, [Bool]) -> FastString
forall a b. (a, b) -> a
fst ((FastString, [Bool]) -> FastString)
-> ([(FastString, [Bool])] -> (FastString, [Bool]))
-> [(FastString, [Bool])]
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FastString, [Bool])] -> (FastString, [Bool])
forall a. [a] -> a
head) ([[(FastString, [Bool])]] -> [FastString])
-> [[(FastString, [Bool])]] -> [FastString]
forall a b. (a -> b) -> a -> b
$ ((FastString, [Bool]) -> (FastString, [Bool]) -> Bool)
-> [(FastString, [Bool])] -> [[(FastString, [Bool])]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ([Bool] -> [Bool] -> Bool
forall a. Eq a => a -> a -> Bool
(==) ([Bool] -> [Bool] -> Bool)
-> ((FastString, [Bool]) -> [Bool])
-> (FastString, [Bool])
-> (FastString, [Bool])
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (FastString, [Bool]) -> [Bool]
forall a b. (a, b) -> b
snd) [(FastString, [Bool])]
growingSets
aMember :: FastString
aMember = ASSERT( not (null members) ) fst (head members)
(members :: [(FastString, [Bool])]
members, nonMembers :: [(FastString, [Bool])]
nonMembers) = ((FastString, [Bool]) -> Bool)
-> [(FastString, [Bool])]
-> ([(FastString, [Bool])], [(FastString, [Bool])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> ((FastString, [Bool]) -> [Bool]) -> (FastString, [Bool]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FastString, [Bool]) -> [Bool]
forall a b. (a, b) -> b
snd) [(FastString, [Bool])]
membership
membership :: [(FieldLabelString, [Bool])]
membership :: [(FastString, [Bool])]
membership = [(FastString, [Bool])] -> [(FastString, [Bool])]
forall a. [(a, [Bool])] -> [(a, [Bool])]
sortMembership ([(FastString, [Bool])] -> [(FastString, [Bool])])
-> [(FastString, [Bool])] -> [(FastString, [Bool])]
forall a b. (a -> b) -> a -> b
$
(FastString -> (FastString, [Bool]))
-> [FastString] -> [(FastString, [Bool])]
forall a b. (a -> b) -> [a] -> [b]
map (\fld :: FastString
fld -> (FastString
fld, (Set FastString -> Bool) -> [Set FastString] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Set FastString -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FastString
fld) [Set FastString]
fieldLabelSets)) ([FastString] -> [(FastString, [Bool])])
-> [FastString] -> [(FastString, [Bool])]
forall a b. (a -> b) -> a -> b
$
(LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> FastString)
-> [LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)]
-> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> FastString
occNameFS (OccName -> FastString)
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> OccName)
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc (RdrName -> OccName)
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> RdrName)
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AmbiguousFieldOcc GhcTcId -> RdrName
forall (p :: Pass). AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc (AmbiguousFieldOcc GhcTcId -> RdrName)
-> (LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> AmbiguousFieldOcc GhcTcId)
-> LHsRecField' (AmbiguousFieldOcc GhcTcId) (LHsExpr GhcRn)
-> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
fieldLabelSets :: [Set.Set FieldLabelString]
fieldLabelSets :: [Set FastString]
fieldLabelSets = (ConLike -> Set FastString) -> [ConLike] -> [Set FastString]
forall a b. (a -> b) -> [a] -> [b]
map ([FastString] -> Set FastString
forall a. Ord a => [a] -> Set a
Set.fromList ([FastString] -> Set FastString)
-> (ConLike -> [FastString]) -> ConLike -> Set FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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])
-> (ConLike -> [FieldLbl Name]) -> ConLike -> [FastString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConLike -> [FieldLbl Name]
conLikeFieldLabels) [ConLike]
data_cons
sortMembership :: [(a, [Bool])] -> [(a, [Bool])]
sortMembership =
((Int, (a, [Bool])) -> (a, [Bool]))
-> [(Int, (a, [Bool]))] -> [(a, [Bool])]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (a, [Bool])) -> (a, [Bool])
forall a b. (a, b) -> b
snd ([(Int, (a, [Bool]))] -> [(a, [Bool])])
-> ([(a, [Bool])] -> [(Int, (a, [Bool]))])
-> [(a, [Bool])]
-> [(a, [Bool])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((Int, (a, [Bool])) -> (Int, (a, [Bool])) -> Ordering)
-> [(Int, (a, [Bool]))] -> [(Int, (a, [Bool]))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, (a, [Bool])) -> Int)
-> (Int, (a, [Bool]))
-> (Int, (a, [Bool]))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, (a, [Bool])) -> Int
forall a b. (a, b) -> a
fst) ([(Int, (a, [Bool]))] -> [(Int, (a, [Bool]))])
-> ([(a, [Bool])] -> [(Int, (a, [Bool]))])
-> [(a, [Bool])]
-> [(Int, (a, [Bool]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((a, [Bool]) -> (Int, (a, [Bool])))
-> [(a, [Bool])] -> [(Int, (a, [Bool]))]
forall a b. (a -> b) -> [a] -> [b]
map (\ item :: (a, [Bool])
item@(_, membershipRow :: [Bool]
membershipRow) -> ([Bool] -> Int
countTrue [Bool]
membershipRow, (a, [Bool])
item))
countTrue :: [Bool] -> Int
countTrue = (Bool -> Bool) -> [Bool] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Bool -> Bool
forall a. a -> a
id
naughtyRecordSel :: RdrName -> SDoc
naughtyRecordSel :: RdrName -> SDoc
naughtyRecordSel sel_id :: RdrName
sel_id
= String -> SDoc
text "Cannot use record selector" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
sel_id) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text "as a function due to escaped type variables" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text "Probable fix: use pattern-matching syntax instead"
notSelector :: Name -> SDoc
notSelector :: Name -> SDoc
notSelector field :: Name
field
= [SDoc] -> SDoc
hsep [SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
field), String -> SDoc
text "is not a record selector"]
mixedSelectors :: [Id] -> [Id] -> SDoc
mixedSelectors :: [EvVar] -> [EvVar] -> SDoc
mixedSelectors data_sels :: [EvVar]
data_sels@(dc_rep_id :: EvVar
dc_rep_id:_) pat_syn_sels :: [EvVar]
pat_syn_sels@(ps_rep_id :: EvVar
ps_rep_id:_)
= PtrString -> SDoc
ptext
(String -> PtrString
sLit "Cannot use a mixture of pattern synonym and record selectors") SDoc -> SDoc -> SDoc
$$
String -> SDoc
text "Record selectors defined by"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
rep_dc))
SDoc -> SDoc -> SDoc
<> String -> SDoc
text ":"
SDoc -> SDoc -> SDoc
<+> (EvVar -> SDoc) -> [EvVar] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvVar]
data_sels SDoc -> SDoc -> SDoc
$$
String -> SDoc
text "Pattern synonym selectors defined by"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (PatSyn -> Name
patSynName PatSyn
rep_ps))
SDoc -> SDoc -> SDoc
<> String -> SDoc
text ":"
SDoc -> SDoc -> SDoc
<+> (EvVar -> SDoc) -> [EvVar] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvVar]
pat_syn_sels
where
RecSelPatSyn rep_ps :: PatSyn
rep_ps = EvVar -> RecSelParent
recordSelectorTyCon EvVar
ps_rep_id
RecSelData rep_dc :: TyCon
rep_dc = EvVar -> RecSelParent
recordSelectorTyCon EvVar
dc_rep_id
mixedSelectors _ _ = String -> SDoc
forall a. String -> a
panic "TcExpr: mixedSelectors emptylists"
missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
missingStrictFields :: ConLike -> [FastString] -> SDoc
missingStrictFields con :: ConLike
con fields :: [FastString]
fields
= SDoc
header SDoc -> SDoc -> SDoc
<> SDoc
rest
where
rest :: SDoc
rest | [FastString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FastString]
fields = SDoc
Outputable.empty
| Bool
otherwise = SDoc
colon SDoc -> SDoc -> SDoc
<+> (FastString -> SDoc) -> [FastString] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr [FastString]
fields
header :: SDoc
header = String -> SDoc
text "Constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text "does not have the required strict field(s)"
missingFields :: ConLike -> [FieldLabelString] -> SDoc
missingFields :: ConLike -> [FastString] -> SDoc
missingFields con :: ConLike
con fields :: [FastString]
fields
= SDoc
header SDoc -> SDoc -> SDoc
<> SDoc
rest
where
rest :: SDoc
rest | [FastString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FastString]
fields = SDoc
Outputable.empty
| Bool
otherwise = SDoc
colon SDoc -> SDoc -> SDoc
<+> (FastString -> SDoc) -> [FastString] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr [FastString]
fields
header :: SDoc
header = String -> SDoc
text "Fields of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text "not initialised"
noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
noPossibleParents rbinds :: [LHsRecUpdField GhcRn]
rbinds
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "No type has all these fields:")
2 ([Located (AmbiguousFieldOcc GhcRn)] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [Located (AmbiguousFieldOcc GhcRn)]
fields)
where
fields :: [Located (AmbiguousFieldOcc GhcRn)]
fields = (LHsRecUpdField GhcRn -> Located (AmbiguousFieldOcc GhcRn))
-> [LHsRecUpdField GhcRn] -> [Located (AmbiguousFieldOcc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn)
forall id arg. HsRecField' id arg -> Located id
hsRecFieldLbl (HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
-> Located (AmbiguousFieldOcc GhcRn))
-> (LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn))
-> LHsRecUpdField GhcRn
-> Located (AmbiguousFieldOcc GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsRecUpdField GhcRn
-> HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LHsRecUpdField GhcRn]
rbinds
badOverloadedUpdate :: SDoc
badOverloadedUpdate :: SDoc
badOverloadedUpdate = String -> SDoc
text "Record update is ambiguous, and requires a type signature"
fieldNotInType :: RecSelParent -> RdrName -> SDoc
fieldNotInType :: RecSelParent -> RdrName -> SDoc
fieldNotInType p :: RecSelParent
p rdr :: RdrName
rdr
= SDoc -> RdrName -> SDoc
unknownSubordinateErr (String -> SDoc
text "field of type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RecSelParent -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecSelParent
p)) RdrName
rdr
data NotClosedReason = NotLetBoundReason
| NotTypeClosed VarSet
| NotClosed Name NotClosedReason
checkClosedInStaticForm :: Name -> TcM ()
checkClosedInStaticForm :: Name -> TcRn ()
checkClosedInStaticForm name :: Name
name = do
TcTypeEnv
type_env <- TcM TcTypeEnv
getLclTypeEnv
case TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed TcTypeEnv
type_env Name
name of
Nothing -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just reason :: NotClosedReason
reason -> SDoc -> TcRn ()
addErrTc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> NotClosedReason -> SDoc
explain Name
name NotClosedReason
reason
where
checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed type_env :: TcTypeEnv
type_env n :: Name
n = TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (Name -> UniqSet Name
unitNameSet Name
n) Name
n
checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
checkLoop :: TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop type_env :: TcTypeEnv
type_env visited :: UniqSet Name
visited n :: Name
n = do
case TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
type_env Name
n of
Just (ATcId { tct_id :: TcTyThing -> EvVar
tct_id = EvVar
tcid, tct_info :: TcTyThing -> IdBindingInfo
tct_info = IdBindingInfo
info }) -> case IdBindingInfo
info of
ClosedLet -> Maybe NotClosedReason
forall a. Maybe a
Nothing
NotLetBound -> NotClosedReason -> Maybe NotClosedReason
forall a. a -> Maybe a
Just NotClosedReason
NotLetBoundReason
NonClosedLet fvs :: UniqSet Name
fvs type_closed :: Bool
type_closed -> [NotClosedReason] -> Maybe NotClosedReason
forall a. [a] -> Maybe a
listToMaybe ([NotClosedReason] -> Maybe NotClosedReason)
-> [NotClosedReason] -> Maybe NotClosedReason
forall a b. (a -> b) -> a -> b
$
[ Name -> NotClosedReason -> NotClosedReason
NotClosed Name
n' NotClosedReason
reason
| Name
n' <- UniqSet Name -> [Name]
nameSetElemsStable UniqSet Name
fvs
, Bool -> Bool
not (Name -> UniqSet Name -> Bool
elemNameSet Name
n' UniqSet Name
visited)
, Just reason :: NotClosedReason
reason <- [TcTypeEnv -> UniqSet Name -> Name -> Maybe NotClosedReason
checkLoop TcTypeEnv
type_env (UniqSet Name -> Name -> UniqSet Name
extendNameSet UniqSet Name
visited Name
n') Name
n']
] [NotClosedReason] -> [NotClosedReason] -> [NotClosedReason]
forall a. [a] -> [a] -> [a]
++
if Bool
type_closed then
[]
else
[ VarSet -> NotClosedReason
NotTypeClosed (VarSet -> NotClosedReason) -> VarSet -> NotClosedReason
forall a b. (a -> b) -> a -> b
$ TcSigmaType -> VarSet
tyCoVarsOfType (EvVar -> TcSigmaType
idType EvVar
tcid) ]
_ -> Maybe NotClosedReason
forall a. Maybe a
Nothing
explain :: Name -> NotClosedReason -> SDoc
explain :: Name -> NotClosedReason -> SDoc
explain name :: Name
name reason :: NotClosedReason
reason =
SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "is used in a static form but it is not closed"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "because it"
SDoc -> SDoc -> SDoc
$$
[SDoc] -> SDoc
sep (NotClosedReason -> [SDoc]
causes NotClosedReason
reason)
causes :: NotClosedReason -> [SDoc]
causes :: NotClosedReason -> [SDoc]
causes NotLetBoundReason = [String -> SDoc
text "is not let-bound."]
causes (NotTypeClosed vs :: VarSet
vs) =
[ String -> SDoc
text "has a non-closed type because it contains the"
, String -> SDoc
text "type variables:" SDoc -> SDoc -> SDoc
<+>
VarSet -> ([EvVar] -> SDoc) -> SDoc
pprVarSet VarSet
vs ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([EvVar] -> [SDoc]) -> [EvVar] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> ([EvVar] -> [SDoc]) -> [EvVar] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EvVar -> SDoc) -> [EvVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (EvVar -> SDoc) -> EvVar -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr))
]
causes (NotClosed n :: Name
n reason :: NotClosedReason
reason) =
let msg :: SDoc
msg = String -> SDoc
text "uses" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "which"
in case NotClosedReason
reason of
NotClosed _ _ -> SDoc
msg SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: NotClosedReason -> [SDoc]
causes NotClosedReason
reason
_ -> let (xs0 :: [SDoc]
xs0, xs1 :: [SDoc]
xs1) = Int -> [SDoc] -> ([SDoc], [SDoc])
forall a. Int -> [a] -> ([a], [a])
splitAt 1 ([SDoc] -> ([SDoc], [SDoc])) -> [SDoc] -> ([SDoc], [SDoc])
forall a b. (a -> b) -> a -> b
$ NotClosedReason -> [SDoc]
causes NotClosedReason
reason
in (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SDoc
msg SDoc -> SDoc -> SDoc
<+>) [SDoc]
xs0 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
xs1