module GHC.Tc.Gen.Expr
( tcCheckPolyExpr, tcCheckPolyExprNC,
tcCheckMonoExpr, tcCheckMonoExprNC,
tcMonoExpr, tcMonoExprNC,
tcInferRho, tcInferRhoNC,
tcPolyExpr, tcExpr,
tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
tcCheckId,
getFixedTyVars ) where
import GHC.Prelude
import GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Rename.Utils
import GHC.Tc.Utils.Zonk
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Gen.App
import GHC.Tc.Gen.Head
import GHC.Tc.Gen.Bind ( tcLocalBinds )
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Rename.Env ( addUsedGRE )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
import GHC.Tc.Gen.Match
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Tc.Types.Evidence
import GHC.Types.Var.Set
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad
import GHC.Core.Class(classTyCon)
import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
import Data.Function
import Data.List (partition, sortBy, groupBy, intersect)
tcCheckPolyExpr, tcCheckPolyExprNC
:: LHsExpr GhcRn
-> TcSigmaType
-> TcM (LHsExpr GhcTc)
tcCheckPolyExpr expr res_ty = tcPolyLExpr expr (mkCheckExpType res_ty)
tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty)
tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
-> TcM (LHsExpr GhcTc)
tcPolyLExpr (L loc expr) res_ty
= setSrcSpanA loc $
addExprCtxt expr $
do { expr' <- tcPolyExpr expr res_ty
; return (L loc expr') }
tcPolyLExprNC (L loc expr) res_ty
= setSrcSpanA loc $
do { expr' <- tcPolyExpr expr res_ty
; return (L loc expr') }
tcCheckMonoExpr, tcCheckMonoExprNC
:: LHsExpr GhcRn
-> TcRhoType
-> TcM (LHsExpr GhcTc)
tcCheckMonoExpr expr res_ty = tcMonoExpr expr (mkCheckExpType res_ty)
tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty)
tcMonoExpr, tcMonoExprNC
:: LHsExpr GhcRn
-> ExpRhoType
-> TcM (LHsExpr GhcTc)
tcMonoExpr (L loc expr) res_ty
= setSrcSpanA loc $
addExprCtxt expr $
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
tcMonoExprNC (L loc expr) res_ty
= setSrcSpanA loc $
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
tcInferRho (L loc expr)
= setSrcSpanA loc $
addExprCtxt expr $
do { (expr', rho) <- tcInfer (tcExpr expr)
; return (L loc expr', rho) }
tcInferRhoNC (L loc expr)
= setSrcSpanA loc $
do { (expr', rho) <- tcInfer (tcExpr expr)
; return (L loc expr', rho) }
tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
tcPolyExpr expr res_ty
= do { traceTc "tcPolyExpr" (ppr res_ty)
; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \ res_ty ->
tcExpr expr res_ty
; return $ mkHsWrap wrap expr' }
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcExpr e@(HsVar {}) res_ty = tcApp e res_ty
tcExpr e@(HsApp {}) res_ty = tcApp e res_ty
tcExpr e@(OpApp {}) res_ty = tcApp e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
tcExpr e@(HsRecSel {}) res_ty = tcApp e res_ty
tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty
tcExpr e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
; case mb_res of
Just lit' -> return (HsOverLit noAnn lit')
Nothing -> tcApp e res_ty }
tcExpr (HsUnboundVar _ occ) res_ty
= do { ty <- expTypeToType res_ty
; her <- emitNewExprHole occ ty
; tcEmitBindingUsage bottomUE
; return (HsUnboundVar her occ) }
tcExpr e@(HsLit x lit) res_ty
= do { let lit_ty = hsLitType lit
; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }
tcExpr (HsPar x lpar expr rpar) res_ty
= do { expr' <- tcMonoExprNC expr res_ty
; return (HsPar x lpar expr' rpar) }
tcExpr (HsPragE x prag expr) res_ty
= do { expr' <- tcMonoExpr expr res_ty
; return (HsPragE x (tcExprPrag prag) expr') }
tcExpr (NegApp x expr neg_expr) res_ty
= do { (expr', neg_expr')
<- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
\[arg_ty] [arg_mult] ->
tcScalingUsage arg_mult $ tcCheckMonoExpr expr arg_ty
; return (NegApp x expr' neg_expr') }
tcExpr e@(HsIPVar _ x) res_ty
= do { ip_ty <- newFlexiTyVarTy liftedTypeKind
; let ip_name = mkStrLitTy (hsIPNameFS x)
; ipClass <- tcLookupClass ipClassName
; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
; tcWrapResult e
(fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var)))
ip_ty res_ty }
where
fromDict ipClass x ty = mkHsWrap $ mkWpCastR $
unwrapIP $ mkClassPred ipClass [x,ty]
origin = IPOccOrigin x
tcExpr (HsLam _ match) res_ty
= do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty
; return (mkHsWrap wrap (HsLam noExtField match')) }
where
match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
herald = ExpectedFunTyLam match
tcExpr e@(HsLamCase x lc_variant matches) res_ty
= do { (wrap, matches')
<- tcMatchLambda herald match_ctxt matches res_ty
; return (mkHsWrap wrap $ HsLamCase x lc_variant matches') }
where
match_ctxt = MC { mc_what = LamCaseAlt lc_variant, mc_body = tcBody }
herald = ExpectedFunTyLamCase lc_variant e
tcExpr (ExplicitList _ exprs) res_ty
= do { res_ty <- expTypeToType res_ty
; (coi, elt_ty) <- matchExpectedListTy res_ty
; let tc_elt expr = tcCheckPolyExpr expr elt_ty
; exprs' <- mapM tc_elt exprs
; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' }
tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
| all tupArgPresent tup_args
= do { let arity = length tup_args
tup_tc = tupleTyCon boxity arity
; res_ty <- expTypeToType res_ty
; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
Boxed -> arg_tys
; tup_args1 <- tcTupArgs tup_args arg_tys'
; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }
| otherwise
=
do { let arity = length tup_args
; arg_tys <- case boxity of
{ Boxed -> newFlexiTyVarTys arity liftedTypeKind
; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
; tup_args1 <- tcTupArgs tup_args arg_tys
; let expr' = ExplicitTuple x tup_args1 boxity
missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys]
act_res_ty = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)
; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty)
; tcWrapResultMono expr expr' act_res_ty res_ty }
tcExpr (ExplicitSum _ alt arity expr) res_ty
= do { let sum_tc = sumTyCon arity
; res_ty <- expTypeToType res_ty
; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
;
let arg_tys' = drop arity arg_tys
arg_ty = arg_tys' `getNth` (alt 1)
; expr' <- tcCheckPolyExpr expr arg_ty
; hasFixedRuntimeRep_syntactic FRRUnboxedSum res_ty
; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }
tcExpr (HsLet x tkLet binds tkIn expr) res_ty
= do { (binds', expr') <- tcLocalBinds binds $
tcMonoExpr expr res_ty
; return (HsLet x tkLet binds' tkIn expr') }
tcExpr (HsCase x scrut matches) res_ty
= do {
mult <- newFlexiTyVarTy multiplicityTy
; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut
; traceTc "HsCase" (ppr scrut_ty)
; hasFixedRuntimeRep_syntactic FRRCase scrut_ty
; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty
; return (HsCase x scrut' matches') }
where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = tcBody }
tcExpr (HsIf x pred b1 b2) res_ty
= do { pred' <- tcCheckMonoExpr pred boolTy
; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty
; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty
; tcEmitBindingUsage (supUE u1 u2)
; return (HsIf x pred' b1' b2') }
tcExpr (HsMultiIf _ alts) res_ty
= do { alts' <- mapM (wrapLocMA $ tcGRHS match_ctxt res_ty) alts
; res_ty <- readExpType res_ty
; return (HsMultiIf res_ty alts') }
where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
tcExpr (HsDo _ do_or_lc stmts) res_ty
= tcDoStmts do_or_lc stmts res_ty
tcExpr (HsProc x pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
; return $ mkHsWrapCo coi (HsProc x pat' cmd') }
tcExpr (HsStatic fvs expr) res_ty
= do { res_ty <- expTypeToType res_ty
; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
; (expr', lie) <- captureConstraints $
addErrCtxt (hang (text "In the body of a static form:")
2 (ppr expr)
) $
tcCheckPolyExprNC expr expr_ty
; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs
; typeableClass <- tcLookupClass typeableClassName
; typeable_ev <- emitWantedEvVar StaticOrigin $
mkTyConApp (classTyCon typeableClass)
[liftedTypeKind, expr_ty]
; emitStaticConstraints lie
; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName
[p_ty]
; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty]
; loc <- getSrcSpanM
; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName
; return $ mkHsWrapCo co $ HsApp noComments
(L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr)
(L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr'))
}
tcExpr expr@(RecordCon { rcon_con = L loc con_name
, rcon_flds = rbinds }) res_ty
= do { con_like <- tcLookupConLike con_name
; (con_expr, con_sigma) <- tcInferId con_name
; (con_wrap, con_tau) <- topInstantiate orig con_sigma
; let arity = conLikeArity con_like
Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau
; checkTc (conLikeHasBuilder con_like) $
nonBidirectionalErr (conLikeName con_like)
; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds
; let rcon_tc = mkHsWrap con_wrap con_expr
expr' = RecordCon { rcon_ext = rcon_tc
, rcon_con = L loc con_like
, rcon_flds = rbinds' }
; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty
; checkMissingFields con_like rbinds arg_tys
; return ret }
where
orig = OccurrenceOf con_name
tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty
= assert (notNull rbnds) $
do {
(record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr
; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds
upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
sel_ids = map selectorAmbiguousFieldOcc upd_flds
; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
| fld <- rbinds,
let L loc sel_id = hsRecUpdFieldId (unLoc fld),
not (isRecordSelector sel_id),
let fld_name = idName sel_id ]
; unless (null bad_guys) (sequence bad_guys >> failM)
; let (data_sels, pat_syn_sels) =
partition isDataConRecordSelector sel_ids
; massert (all isPatSynRecordSelector pat_syn_sels)
; checkTc ( null data_sels || null pat_syn_sels )
( mixedSelectors data_sels pat_syn_sels )
; let
sel_id : _ = sel_ids
mtycon :: Maybe TyCon
mtycon = case idDetails sel_id of
RecSelId (RecSelData tycon) _ -> Just tycon
_ -> Nothing
con_likes :: [ConLike]
con_likes = case idDetails sel_id of
RecSelId (RecSelData tc) _
-> map RealDataCon (tyConDataCons tc)
RecSelId (RecSelPatSyn ps) _
-> [PatSynCon ps]
_ -> panic "tcRecordUpd"
relevant_cons = conLikesWithFields con_likes upd_fld_occs
; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)
; let con1 = assert (not (null relevant_cons) ) head relevant_cons
(con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _)
= conLikeFullSig con1
con1_arg_tys = map scaledThing scaled_con1_arg_tys
con1_flds = map flLabel $ conLikeFieldLabels con1
con1_tv_tys = mkTyVarTys con1_tvs
con1_res_ty = case mtycon of
Just tc -> mkFamilyTyConApp tc con1_tv_tys
Nothing -> conLikeResTy con1 con1_tv_tys
; checkTc (conLikeHasBuilder con1) $
nonBidirectionalErr (conLikeName con1)
; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
bad_upd_flds = filter bad_fld flds1_w_tys
con1_tv_set = mkVarSet con1_tvs
bad_fld (fld, ty) = fld `elem` upd_fld_occs &&
not (tyCoVarsOfType ty `subVarSet` con1_tv_set)
; checkTc (null bad_upd_flds) (TcRnFieldUpdateInvalidType bad_upd_flds)
; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
is_fixed_tv tv = tv `elemVarSet` fixed_tvs
mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
mk_inst_ty subst (tv, result_inst_ty)
| is_fixed_tv tv
= return (extendTvSubst subst tv result_inst_ty, result_inst_ty)
| otherwise
= do { (subst', new_tv) <- newMetaTyVarX subst tv
; return (subst', mkTyVarTy new_tv) }
; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs
; let result_inst_tys = mkTyVarTys con1_tvs'
init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)
; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst
(con1_tvs `zip` result_inst_tys)
; let rec_res_ty = TcType.substTy result_subst con1_res_ty
scrut_ty = TcType.substTy scrut_subst con1_res_ty
con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
; co_scrut <- unifyType (Just . HsExprRnThing $ unLoc record_expr) record_rho scrut_ty
; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds
; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)
; instStupidTheta RecordUpdOrigin theta'
; let fam_co :: HsWrapper
fam_co | Just tycon <- mtycon
, Just co_con <- tyConFamilyCoercion_maybe tycon
= mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys [])
| otherwise
= idHsWrapper
; let req_theta' = substThetaUnchecked scrut_subst req_theta
; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'
; let upd_tc = RecordUpdTc { rupd_cons = relevant_cons
, rupd_in_tys = scrut_inst_tys
, rupd_out_tys = result_inst_tys
, rupd_wrap = req_wrap }
expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $
mkLHsWrapCo co_scrut record_expr'
, rupd_flds = Left rbinds'
, rupd_ext = upd_tc }
; tcWrapResult expr expr' rec_res_ty res_ty }
tcExpr (RecordUpd {}) _ = panic "GHC.Tc.Gen.Expr: tcExpr: The impossible happened!"
tcExpr (ArithSeq _ witness seq) res_ty
= tcArithSeq witness seq res_ty
tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))
res_ty
= do addModFinalizersWithLclEnv mod_finalizers
tcExpr expr res_ty
tcExpr (HsSpliceE _ splice) res_ty = tcSpliceExpr splice res_ty
tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty
tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty
tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty)
tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty)
tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
-> TcM (HsExpr GhcTc)
tcArithSeq witness seq@(From expr) res_ty
= do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty
; enum_from <- newMethodFromName (ArithSeqOrigin seq)
enumFromName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq enum_from wit' (From expr') }
tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
= do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
= do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
enumFromToName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
= do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty
; eft <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenToName [elt_ty]
; return $ mkHsWrap wrap $
ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
-> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))
arithSeqEltType Nothing res_ty
= do { res_ty <- expTypeToType res_ty
; (coi, elt_ty) <- matchExpectedListTy res_ty
; return (mkWpCastN coi, One, elt_ty, Nothing) }
arithSeqEltType (Just fl) res_ty
= do { ((elt_mult, elt_ty), fl')
<- tcSyntaxOp ListOrigin fl [SynList] res_ty $
\ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty)
; return (idHsWrapper, elt_mult, elt_ty, Just fl') }
tcTupArgs :: [HsTupArg GhcRn]
-> [TcSigmaType]
-> TcM [HsTupArg GhcTc]
tcTupArgs args tys
= do massert (equalLength args tys)
checkTupSize (length args)
zipWith3M go [1,2..] args tys
where
go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc)
go i (Missing {}) arg_ty
= do { mult <- newFlexiTyVarTy multiplicityTy
; hasFixedRuntimeRep_syntactic (FRRTupleSection i) arg_ty
; return (Missing (Scaled mult arg_ty)) }
go i (Present x expr) arg_ty
= do { expr' <- tcCheckPolyExpr expr arg_ty
; hasFixedRuntimeRep_syntactic (FRRTupleArg i) arg_ty
; return (Present x expr') }
tcSyntaxOp :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcSigmaType] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp orig expr arg_tys res_ty
= tcSyntaxOpGen orig expr arg_tys (SynType res_ty)
tcSyntaxOpGen :: CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside
= do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) []
; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)
; (result, expr_wrap, arg_wraps, res_wrap)
<- tcSynArgA orig op sigma arg_tys res_ty $
thing_inside
; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )
; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap }) }
tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen"
tcSynArgE :: CtOrigin
-> HsExpr GhcRn
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE orig op sigma_ty syn_ty thing_inside
= do { (skol_wrap, (result, ty_wrapper))
<- tcTopSkolemise GenSigCtxt sigma_ty
(\ rho_ty -> go rho_ty syn_ty)
; return (result, skol_wrap <.> ty_wrapper) }
where
go rho_ty SynAny
= do { result <- thing_inside [rho_ty] []
; return (result, idHsWrapper) }
go rho_ty SynRho
= do { result <- thing_inside [rho_ty] []
; return (result, idHsWrapper) }
go rho_ty SynList
= do { (list_co, elt_ty) <- matchExpectedListTy rho_ty
; result <- thing_inside [elt_ty] []
; return (result, mkWpCastN list_co) }
go rho_ty (SynFun arg_shape res_shape)
= do { ( match_wrapper
, ( ( (result, arg_ty, res_ty, op_mult)
, res_wrapper )
, arg_wrapper1, [], arg_wrapper2 ) )
<- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $
\ [arg_ty] res_ty ->
do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)
; res_tc_ty <- expTypeToType res_ty
; massertPpr (case arg_shape of
SynFun {} -> False;
_ -> True)
(text "Too many nested arrows in SyntaxOpType" $$
pprCtOrigin orig)
; let arg_mult = scaledMult arg_ty
; tcSynArgA orig op arg_tc_ty [] arg_shape $
\ arg_results arg_res_mults ->
tcSynArgE orig op res_tc_ty res_shape $
\ res_results res_res_mults ->
do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults)
; return (result, arg_tc_ty, res_tc_ty, arg_mult) }}
; let fun_wrap = mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper
(Scaled op_mult arg_ty) res_ty
; return (result, match_wrapper <.> fun_wrap) }
where
herald = ExpectedFunTySyntaxOp orig op
go rho_ty (SynType the_ty)
= do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty
; result <- thing_inside [] []
; return (result, wrap) }
tcSynArgA :: CtOrigin
-> HsExpr GhcRn
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
= do { (match_wrapper, arg_tys, res_ty)
<- matchActualFunTysRho herald orig Nothing
(length arg_shapes) sigma_ty
; ((result, res_wrapper), arg_wrappers)
<- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->
tc_syn_arg res_ty res_shape $ \ res_results ->
thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults)
; return (result, match_wrapper, arg_wrappers, res_wrapper) }
where
herald = ExpectedFunTySyntaxOp orig op
tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType]
-> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-> TcM (a, [HsWrapper])
tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside
= do { ((result, arg_wraps), arg_wrap)
<- tcSynArgE orig op arg_ty arg_shape $ \ arg1_results arg1_mults ->
tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults ->
thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults)
; return (result, arg_wrap : arg_wraps) }
tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] []
tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType
-> ([TcSigmaTypeFRR] -> TcM a)
-> TcM (a, HsWrapper)
tc_syn_arg res_ty SynAny thing_inside
= do { result <- thing_inside [res_ty]
; return (result, idHsWrapper) }
tc_syn_arg res_ty SynRho thing_inside
= do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
; result <- thing_inside [rho_ty]
; return (result, inst_wrap) }
tc_syn_arg res_ty SynList thing_inside
= do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
; (list_co, elt_ty) <- matchExpectedListTy rho_ty
; result <- thing_inside [elt_ty]
; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }
tc_syn_arg _ (SynFun {}) _
= pprPanic "tcSynArgA hits a SynFun" (ppr orig)
tc_syn_arg res_ty (SynType the_ty) thing_inside
= do { wrap <- tcSubType orig GenSigCtxt res_ty the_ty
; result <- thing_inside []
; return (result, wrap) }
getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
getFixedTyVars upd_fld_occs univ_tvs cons
= mkVarSet [tv1 | con <- cons
, let (u_tvs, _, eqspec, prov_theta
, req_theta, arg_tys, _)
= conLikeFullSig con
theta = eqSpecPreds eqspec
++ prov_theta
++ req_theta
flds = conLikeFieldLabels con
fixed_tvs = exactTyCoVarsOfTypes (map scaledThing fixed_tys)
`unionVarSet` tyCoVarsOfTypes theta
fixed_tys = [ty | (fl, ty) <- zip flds arg_tys
, not (flLabel fl `elem` upd_fld_occs)]
, (tv1,tv) <- univ_tvs `zip` u_tvs
, tv `elemVarSet` fixed_tvs ]
disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
-> [LHsRecUpdField GhcRn] -> ExpRhoType
-> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
disambiguateRecordBinds record_expr record_rho rbnds res_ty
= case mapM isUnambiguous rbnds of
Just rbnds' -> mapM lookupSelector rbnds'
Nothing ->
do { fam_inst_envs <- tcGetFamInstEnvs
; rbnds_with_parents <- getUpdFieldsParents
; let possible_parents = map (map fst . snd) rbnds_with_parents
; p <- identifyParent fam_inst_envs possible_parents
; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
where
isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
isUnambiguous x = case unLoc (hfbLHS (unLoc x)) of
Unambiguous sel_name _ -> Just (x, sel_name)
Ambiguous{} -> Nothing
getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
= fmap (zip rbnds) $ mapM
(lookupParents False . unLoc . hsRecUpdFieldRdr . unLoc)
rbnds
identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent fam_inst_envs possible_parents
= case foldr1 intersect possible_parents of
[] -> failWithTc (TcRnNoPossibleParentForFields rbnds)
[p] -> return p
_:_ | Just p <- tyConOfET fam_inst_envs res_ty ->
do { reportAmbiguousField p
; return (RecSelData p) }
| Just {} <- obviousSig (unLoc record_expr)
, Just tc <- tyConOf fam_inst_envs record_rho
-> do { reportAmbiguousField tc
; return (RecSelData tc) }
_ -> failWithTc (TcRnBadOverloadedRecordUpdate rbnds)
pickParent :: RecSelParent
-> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
pickParent p (upd, xs)
= case lookup p xs of
Just gre -> do { unless (null (tail xs)) $ do
let L loc _ = hfbLHS (unLoc upd)
setSrcSpanA loc $ addUsedGRE True gre
; lookupSelector (upd, greMangledName gre) }
Nothing -> do { addErrTc (fieldNotInType p
(unLoc (hsRecUpdFieldRdr (unLoc upd))))
; lookupSelector (upd, greMangledName (snd (head xs))) }
lookupSelector :: (LHsRecUpdField GhcRn, Name)
-> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
lookupSelector (L l upd, n)
= do { i <- tcLookupId n
; let L loc af = hfbLHS upd
lbl = rdrNameAmbiguousFieldOcc af
; return $ L l HsFieldBind
{ hfbAnn = hfbAnn upd
, hfbLHS
= L (l2l loc) (Unambiguous i (L (l2l loc) lbl))
, hfbRHS = hfbRHS upd
, hfbPun = hfbPun upd
}
}
reportAmbiguousField :: TyCon -> TcM ()
reportAmbiguousField parent_type =
setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousField rupd parent_type
where
rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField }
loc = getLocA (head rbnds)
tcRecordBinds
:: ConLike
-> [TcType]
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTc)
tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
= do { mb_binds <- mapM do_bind rbinds
; return (HsRecFields (catMaybes mb_binds) dd) }
where
fields = map flSelector $ conLikeFieldLabels con_like
flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
do_bind (L l fld@(HsFieldBind { hfbLHS = f
, hfbRHS = rhs }))
= do { mb <- tcRecordField con_like flds_w_tys f rhs
; case mb of
Nothing -> return Nothing
Just (f', rhs') -> return (Just (L l (HsFieldBind
{ hfbAnn = hfbAnn fld
, hfbLHS = f'
, hfbRHS = rhs'
, hfbPun = hfbPun fld}))) }
tcRecordUpd
:: ConLike
-> [TcType]
-> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> TcM [LHsRecUpdField GhcTc]
tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
where
fields = map flSelector $ conLikeFieldLabels con_like
flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys
do_bind :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
-> TcM (Maybe (LHsRecUpdField GhcTc))
do_bind (L l fld@(HsFieldBind { hfbLHS = L loc af
, hfbRHS = rhs }))
= do { let lbl = rdrNameAmbiguousFieldOcc af
sel_id = selectorAmbiguousFieldOcc af
f = L loc (FieldOcc (idName sel_id) (L (l2l loc) lbl))
; mb <- tcRecordField con_like flds_w_tys f rhs
; case mb of
Nothing -> return Nothing
Just (f', rhs') ->
return (Just
(L l (fld { hfbLHS
= L loc (Unambiguous
(foExt (unLoc f'))
(L (l2l loc) lbl))
, hfbRHS = rhs' }))) }
tcRecordField :: ConLike -> Assoc Name Type
-> LFieldOcc GhcRn -> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
| Just field_ty <- assocMaybe flds_w_tys sel_name
= addErrCtxt (fieldCtxt field_lbl) $
do { rhs' <- tcCheckPolyExprNC rhs field_ty
; hasFixedRuntimeRep_syntactic (FRRRecordUpdate (unLoc lbl) (unLoc rhs'))
field_ty
; let field_id = mkUserLocal (nameOccName sel_name)
(nameUnique sel_name)
Many field_ty (locA loc)
; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
| otherwise
= do { addErrTc (badFieldConErr (getName con_like) field_lbl)
; return Nothing }
where
field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
checkMissingFields con_like rbinds arg_tys
| null field_labels
= if any isBanged field_strs then
addErrTc (TcRnMissingStrictFields con_like [])
else do
when (notNull field_strs && null field_labels) $ do
let msg = TcRnMissingFields con_like []
(diagnosticTc True msg)
| otherwise = do
unless (null missing_s_fields) $ do
fs <- zonk_fields missing_s_fields
addErrTc (TcRnMissingStrictFields con_like fs)
warn <- woptM Opt_WarnMissingFields
when (warn && notNull missing_ns_fields) $ do
fs <- zonk_fields missing_ns_fields
let msg = TcRnMissingFields con_like fs
diagnosticTc True msg
where
zonk_fields fs = forM fs $ \(str,ty) -> do
ty' <- zonkTcType ty
return (str,ty')
missing_s_fields
= [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info,
isBanged str,
not (fl `elemField` field_names_used)
]
missing_ns_fields
= [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info,
not (isBanged str),
not (fl `elemField` field_names_used)
]
field_names_used = hsRecFields rbinds
field_labels = conLikeFieldLabels con_like
field_info = zip3 field_labels field_strs arg_tys
field_strs = conLikeImplBangs con_like
fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt field_name
= text "In the" <+> quotes (ppr field_name) <+> text "field of a record"
badFieldsUpd
:: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-> [ConLike]
-> TcRnMessage
badFieldsUpd rbinds data_cons
= TcRnNoConstructorHasAllFields conflictingFields
where
conflictingFields = case nonMembers of
(nonMember, _) : _ -> [aMember, nonMember]
[] -> let
growingSets :: [(FieldLabelString, [Bool])]
growingSets = scanl1 combine membership
combine (_, setMem) (field, fldMem)
= (field, zipWith (&&) setMem fldMem)
in
map (fst . head) $ groupBy ((==) `on` snd) growingSets
aMember = assert (not (null members) ) fst (head members)
(members, nonMembers) = partition (or . snd) membership
membership :: [(FieldLabelString, [Bool])]
membership = sortMembership $
map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $
map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds
fieldLabelSets :: [UniqSet FieldLabelString]
fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons
sortMembership =
map snd .
sortBy (compare `on` fst) .
map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
countTrue = count id
mixedSelectors :: [Id] -> [Id] -> TcRnMessage
mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)
= TcRnMixedSelectors (tyConName rep_dc) data_sels (patSynName rep_ps) pat_syn_sels
where
RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
RecSelData rep_dc = recordSelectorTyCon dc_rep_id
mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists"
checkClosedInStaticForm :: Name -> TcM ()
checkClosedInStaticForm name = do
type_env <- getLclTypeEnv
case checkClosed type_env name of
Nothing -> return ()
Just reason -> addErrTc $ explain name reason
where
checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
checkClosed type_env n = checkLoop type_env (unitNameSet n) n
checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
checkLoop type_env visited n =
case lookupNameEnv type_env n of
Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of
ClosedLet -> Nothing
NotLetBound -> Just NotLetBoundReason
NonClosedLet fvs type_closed -> listToMaybe $
[ NotClosed n' reason
| n' <- nameSetElemsStable fvs
, not (elemNameSet n' visited)
, Just reason <- [checkLoop type_env (extendNameSet visited n') n']
] ++
if type_closed then
[]
else
[ NotTypeClosed $ tyCoVarsOfType (idType tcid) ]
_ -> Nothing
explain :: Name -> NotClosedReason -> TcRnMessage
explain = TcRnStaticFormNotClosed