module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
tcCheckId,
addExprErrCtxt,
getFixedTyVars ) where
#include "HsVersions.h"
import TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
import THNames( liftStringName, liftName )
import HsSyn
import TcHsSyn
import TcRnMonad
import TcUnify
import BasicTypes
import Inst
import TcBinds ( chooseInferredQuantifiers, tcLocalBinds
, tcUserTypeSig, tcExtendTyVarEnvFromSig )
import TcSimplify ( simplifyInfer )
import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst )
import FamInstEnv ( FamInstEnvs )
import RnEnv ( addUsedGRE, addNameClashErrRn
, unknownSubordinateErr )
import TcEnv
import TcArrows
import TcMatches
import TcHsType
import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
import TcPat
import TcMType
import TcType
import DsMonad
import Id
import IdInfo
import ConLike
import DataCon
import PatSyn
import Name
import RdrName
import TyCon
import Type
import TysPrim ( tYPE )
import TcEvidence
import VarSet
import TysWiredIn
import TysPrim( intPrimTy )
import PrimOp( tagToEnumKey )
import PrelNames
import MkId ( proxyHashId )
import DynFlags
import SrcLoc
import Util
import VarEnv ( emptyTidyEnv )
import ListSetOps
import Maybes
import Outputable
import FastString
import Control.Monad
import Class(classTyCon)
import qualified GHC.LanguageExtensions as LangExt
import Data.Function
import Data.List
import Data.Either
import qualified Data.Set as Set
tcPolyExpr, tcPolyExprNC
:: LHsExpr Name
-> TcSigmaType
-> TcM (LHsExpr TcId)
tcPolyExpr expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty)
tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty)
tc_poly_expr, tc_poly_expr_nc :: LHsExpr Name -> ExpSigmaType -> TcM (LHsExpr TcId)
tc_poly_expr expr res_ty
= addExprErrCtxt expr $
do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }
tc_poly_expr_nc (L loc expr) res_ty
= do { traceTc "tcPolyExprNC" (ppr res_ty)
; (wrap, expr')
<- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
setSrcSpan loc $
tcExpr expr res_ty
; return $ L loc (mkHsWrap wrap expr') }
tcMonoExpr, tcMonoExprNC
:: LHsExpr Name
-> ExpRhoType
-> TcM (LHsExpr TcId)
tcMonoExpr expr res_ty
= addErrCtxt (exprCtxt expr) $
tcMonoExprNC expr res_ty
tcMonoExprNC (L loc expr) res_ty
= setSrcSpan loc $
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
tcInferSigma, tcInferSigmaNC :: LHsExpr Name -> TcM ( LHsExpr TcId
, TcSigmaType )
tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr)
tcInferSigmaNC (L loc expr)
= setSrcSpan loc $
do { (expr', sigma) <- tcInfer (tcExpr expr)
; return (L loc expr', sigma) }
tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
tcInferRhoNC expr
= do { (expr', sigma) <- tcInferSigmaNC expr
; (wrap, rho) <- topInstantiate (exprCtOrigin (unLoc expr)) sigma
; return (mkLHsWrap wrap expr', rho) }
tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId)
tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
tcExpr (HsUnboundVar uv) res_ty = tcUnboundId uv res_ty
tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
tcExpr e@(HsLit lit) res_ty = do { let lit_ty = hsLitType lit
; tcWrapResult e (HsLit lit) lit_ty res_ty }
tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
; return (HsPar expr') }
tcExpr (HsSCC src lbl expr) res_ty
= do { expr' <- tcMonoExpr expr res_ty
; return (HsSCC src lbl expr') }
tcExpr (HsTickPragma src info srcInfo expr) res_ty
= do { expr' <- tcMonoExpr expr res_ty
; return (HsTickPragma src info srcInfo expr') }
tcExpr (HsCoreAnn src lbl expr) res_ty
= do { expr' <- tcMonoExpr expr res_ty
; return (HsCoreAnn src lbl expr') }
tcExpr (HsOverLit lit) res_ty
= do { lit' <- newOverloadedLit lit res_ty
; return (HsOverLit lit') }
tcExpr (NegApp expr neg_expr) res_ty
= do { (expr', neg_expr')
<- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
\[arg_ty] ->
tcMonoExpr expr (mkCheckExpType arg_ty)
; return (NegApp expr' neg_expr') }
tcExpr e@(HsIPVar x) res_ty
= do {
ip_ty <- newOpenFlexiTyVarTy
; 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 (noLoc ip_var)))
ip_ty res_ty }
where
fromDict ipClass x ty = HsWrap $ mkWpCastR $
unwrapIP $ mkClassPred ipClass [x,ty]
origin = IPOccOrigin x
tcExpr e@(HsOverLabel l) res_ty
= do { isLabelClass <- tcLookupClass isLabelClassName
; alpha <- newOpenFlexiTyVarTy
; let lbl = mkStrLitTy l
pred = mkClassPred isLabelClass [lbl, alpha]
; loc <- getSrcSpanM
; var <- emitWantedEvVar origin pred
; let proxy_arg = L loc (mkHsWrap (mkWpTyApps [typeSymbolKind, lbl])
(HsVar (L loc proxyHashId)))
tm = L loc (fromDict pred (HsVar (L loc var))) `HsApp` proxy_arg
; tcWrapResult e tm alpha res_ty }
where
fromDict pred = HsWrap $ mkWpCastR $ unwrapIP pred
origin = OverLabelOrigin l
tcExpr (HsLam match) res_ty
= do { (co_fn, _, match') <- tcMatchLambda herald match_ctxt match res_ty
; return (mkHsWrap co_fn (HsLam match')) }
where
match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
herald = sep [ text "The lambda expression" <+>
quotes (pprSetDepth (PartWay 1) $
pprMatches (LambdaExpr :: HsMatchContext Name) match),
text "has"]
tcExpr e@(HsLamCase _ matches) res_ty
= do { (co_fn, ~[arg_ty], matches')
<- tcMatchLambda msg match_ctxt matches res_ty
; return (mkHsWrap co_fn $ HsLamCase arg_ty matches') }
where msg = sep [ text "The function" <+> quotes (ppr e)
, text "requires"]
match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
tcExpr e@(ExprWithTySig expr sig_ty) res_ty
= do { sig_info <- checkNoErrs $
tcUserTypeSig sig_ty Nothing
; (expr', poly_ty) <- tcExprSig expr sig_info
; let expr'' = ExprWithTySigOut expr' sig_ty
; tcWrapResult e expr'' poly_ty res_ty }
tcExpr expr@(OpApp arg1 op fix arg2) res_ty
| (L loc (HsVar (L lv op_name))) <- op
, op_name `hasKey` seqIdKey
= do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
; let arg2_exp_ty = res_ty
; arg1' <- tcArg op arg1 arg1_ty 1
; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $
tc_poly_expr_nc arg2 arg2_exp_ty
; arg2_ty <- readExpType arg2_exp_ty
; op_id <- tcLookupId op_name
; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty])
(HsVar (L lv op_id)))
; return $ OpApp arg1' op' fix arg2' }
| (L loc (HsVar (L lv op_name))) <- op
, op_name `hasKey` dollarIdKey
= do { traceTc "Application rule" (ppr op)
; (arg1', arg1_ty) <- tcInferSigma arg1
; let doc = text "The first argument of ($) takes"
orig1 = exprCtOrigin (unLoc arg1)
; (wrap_arg1, [arg2_sigma], op_res_ty) <-
matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty
; arg2' <- tcArg op arg2 arg2_sigma 2
; _ <- unifyKind (Just arg2_sigma) (typeKind arg2_sigma) liftedTypeKind
; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty
; op_id <- tcLookupId op_name
; res_ty <- readExpType res_ty
; let op' = L loc (HsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty
, arg2_sigma
, res_ty])
(HsVar (L lv op_id)))
wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty
<.> wrap_arg1
; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') }
| (L loc (HsRecFld (Ambiguous lbl _))) <- op
, Just sig_ty <- obviousSig (unLoc arg1)
= do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
; sel_name <- disambiguateSelector lbl sig_tc_ty
; let op' = L loc (HsRecFld (Unambiguous lbl sel_name))
; tcExpr (OpApp arg1 op' fix arg2) res_ty
}
| otherwise
= do { traceTc "Non Application rule" (ppr op)
; (wrap, op', [Left arg1', Left arg2'])
<- tcApp (Just $ mk_op_msg op)
op [Left arg1, Left arg2] res_ty
; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') }
tcExpr expr@(SectionR op arg2) res_ty
= do { (op', op_ty) <- tcInferFun op
; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <-
matchActualFunTys (mk_op_msg op) SectionOrigin (Just op) 2 op_ty
; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
(mkFunTy arg1_ty op_res_ty) res_ty
; arg2' <- tcArg op arg2 arg2_ty 2
; return ( mkHsWrap wrap_res $
SectionR (mkLHsWrap wrap_fun op') arg2' ) }
tcExpr expr@(SectionL arg1 op) res_ty
= do { (op', op_ty) <- tcInferFun op
; dflags <- getDynFlags
; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1
| otherwise = 2
; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
<- matchActualFunTys (mk_op_msg op) SectionOrigin (Just op)
n_reqd_args op_ty
; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
(mkFunTys arg_tys op_res_ty) res_ty
; arg1' <- tcArg op arg1 arg1_ty 1
; return ( mkHsWrap wrap_res $
SectionL arg1' (mkLHsWrap wrap_fn op') ) }
tcExpr expr@(ExplicitTuple 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 tup_args1 boxity) }
| otherwise
=
do { let arity = length tup_args
; arg_tys <- case boxity of
{ Boxed -> newFlexiTyVarTys arity liftedTypeKind
; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
; let actual_res_ty
= mkFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]
(mkTupleTy boxity arg_tys)
; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")
(Just expr)
actual_res_ty res_ty
; tup_args1 <- tcTupArgs tup_args arg_tys
; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) }
tcExpr (ExplicitList _ witness exprs) res_ty
= case witness of
Nothing -> do { res_ty <- expTypeToType res_ty
; (coi, elt_ty) <- matchExpectedListTy res_ty
; exprs' <- mapM (tc_elt elt_ty) exprs
; return $
mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }
Just fln -> do { ((exprs', elt_ty), fln')
<- tcSyntaxOp ListOrigin fln
[synKnownType intTy, SynList] res_ty $
\ [elt_ty] ->
do { exprs' <-
mapM (tc_elt elt_ty) exprs
; return (exprs', elt_ty) }
; return $ ExplicitList elt_ty (Just fln') exprs' }
where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
tcExpr (ExplicitPArr _ exprs) res_ty
= do { res_ty <- expTypeToType res_ty
; (coi, elt_ty) <- matchExpectedPArrTy res_ty
; exprs' <- mapM (tc_elt elt_ty) exprs
; return $
mkHsWrapCo coi $ ExplicitPArr elt_ty exprs' }
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
tcExpr (HsLet (L l binds) expr) res_ty
= do { (binds', expr') <- tcLocalBinds binds $
tcMonoExpr expr res_ty
; return (HsLet (L l binds') expr') }
tcExpr (HsCase scrut matches) res_ty
= do {
(scrut', scrut_ty) <- tcInferRho scrut
; traceTc "HsCase" (ppr scrut_ty)
; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
; return (HsCase scrut' matches') }
where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = tcBody }
tcExpr (HsIf Nothing pred b1 b2) res_ty
= do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
; res_ty <- mkCheckExpType <$> expTypeToType res_ty
; b1' <- tcMonoExpr b1 res_ty
; b2' <- tcMonoExpr b2 res_ty
; return (HsIf Nothing pred' b1' b2') }
tcExpr (HsIf (Just fun) pred b1 b2) res_ty
= do { ((pred', b1', b2'), fun')
<- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $
\ [pred_ty, b1_ty, b2_ty] ->
do { pred' <- tcPolyExpr pred pred_ty
; b1' <- tcPolyExpr b1 b1_ty
; b2' <- tcPolyExpr b2 b2_ty
; return (pred', b1', b2') }
; return (HsIf (Just fun') pred' b1' b2') }
tcExpr (HsMultiIf _ alts) res_ty
= do { res_ty <- if isSingleton alts
then return res_ty
else mkCheckExpType <$> expTypeToType res_ty
; alts' <- mapM (wrapLocM $ 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
= do { expr' <- tcDoStmts do_or_lc stmts res_ty
; return expr' }
tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
; return $ mkHsWrapCo coi (HsProc pat' cmd') }
tcExpr (HsStatic 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)
) $
tcPolyExprNC expr expr_ty
; typeableClass <- tcLookupClass typeableClassName
; _ <- emitWantedEvVar StaticOrigin $
mkTyConApp (classTyCon typeableClass)
[liftedTypeKind, expr_ty]
; stWC <- tcg_static_wc <$> getGblEnv
; updTcRef stWC (andWC lie)
; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty
; let wrap = mkWpTyApps [expr_ty]
; loc <- getSrcSpanM
; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr)
(L loc (HsStatic expr'))
}
tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
, rcon_flds = rbinds }) res_ty
= do { con_like <- tcLookupConLike con_name
; checkMissingFields con_like rbinds
; (con_expr, con_sigma) <- tcInferId con_name
; (con_wrap, con_tau) <-
topInstantiate (OccurrenceOf con_name) con_sigma
; let arity = conLikeArity con_like
(arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
; case conLikeWrapId_maybe con_like of
Nothing -> nonBidirectionalErr (conLikeName con_like)
Just con_id -> do {
res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon")
(Just expr) actual_res_ty res_ty
; rbinds' <- tcRecordBinds con_like arg_tys rbinds
; return $
mkHsWrap res_wrap $
RecordCon { rcon_con_name = L loc con_id
, rcon_con_expr = mkHsWrap con_wrap con_expr
, rcon_con_like = con_like
, rcon_flds = rbinds' } } }
tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
= ASSERT( notNull rbnds )
do {
(record_expr', record_rho) <- tcInferRho record_expr
; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
; let upd_flds = map (unLoc . hsRecFieldLbl . 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, con1_arg_tys, _)
= conLikeFullSig con1
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
; unless (isJust $ conLikeWrapId_maybe 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) (badFieldTypes 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'
; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTCvSubst
(con1_tvs `zip` result_inst_tys)
; let rec_res_ty = TcType.substTy result_subst con1_res_ty
scrut_ty = TcType.substTyUnchecked scrut_subst con1_res_ty
con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
; wrap_res <- tcSubTypeHR (exprCtOrigin expr)
(Just expr) rec_res_ty res_ty
; co_scrut <- unifyType (Just 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'
; return $
mkHsWrap wrap_res $
RecordUpd { rupd_expr = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr')
, rupd_flds = rbinds'
, rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys
, rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } }
tcExpr (HsRecFld f) res_ty
= tcCheckRecSelId f res_ty
tcExpr (ArithSeq _ witness seq) res_ty
= tcArithSeq witness seq res_ty
tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
= do { res_ty <- expTypeToType res_ty
; (coi, elt_ty) <- matchExpectedPArrTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
(idName enumFromToP) elt_ty
; return $
mkHsWrapCo coi $ PArrSeq enum_from_to (FromTo expr1' expr2') }
tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
= do { res_ty <- expTypeToType res_ty
; (coi, elt_ty) <- matchExpectedPArrTy res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar
; eft <- newMethodFromName (PArrSeqOrigin seq)
(idName enumFromThenToP) elt_ty
; return $
mkHsWrapCo coi $
PArrSeq eft (FromThenTo expr1' expr2' expr3') }
tcExpr (PArrSeq _ _) _
= panic "TcExpr.tcExpr: Infinite parallel array!"
tcExpr (HsSpliceE splice) res_ty
= tcSpliceExpr splice res_ty
tcExpr (HsBracket brack) res_ty
= tcTypedBracket brack res_ty
tcExpr (HsRnBracketOut brack ps) res_ty
= tcUntypedBracket brack ps res_ty
tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> ExpRhoType
-> TcM (HsExpr TcId)
tcArithSeq witness seq@(From expr) res_ty
= do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
; expr' <- tcPolyExpr 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_ty, wit') <- arithSeqEltType witness res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr 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_ty, wit') <- arithSeqEltType witness res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr 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_ty, wit') <- arithSeqEltType witness res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenToName elt_ty
; return $ mkHsWrap wrap $
ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
arithSeqEltType :: Maybe (SyntaxExpr Name) -> ExpRhoType
-> TcM (HsWrapper, TcType, Maybe (SyntaxExpr Id))
arithSeqEltType Nothing res_ty
= do { res_ty <- expTypeToType res_ty
; (coi, elt_ty) <- matchExpectedListTy res_ty
; return (mkWpCastN coi, elt_ty, Nothing) }
arithSeqEltType (Just fl) res_ty
= do { (elt_ty, fl')
<- tcSyntaxOp ListOrigin fl [SynList] res_ty $
\ [elt_ty] -> return elt_ty
; return (idHsWrapper, elt_ty, Just fl') }
type LHsExprArgIn = Either (LHsExpr Name) (LHsWcType Name)
type LHsExprArgOut = Either (LHsExpr TcId) (LHsWcType Name)
tcApp1 :: HsExpr Name
-> ExpRhoType -> TcM (HsExpr TcId)
tcApp1 e res_ty
= do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty
; return (mkHsWrap wrap $ unLoc $ foldl mk_hs_app fun args) }
where
mk_hs_app f (Left a) = mkHsApp f a
mk_hs_app f (Right a) = mkHsAppTypeOut f a
tcApp :: Maybe SDoc
-> LHsExpr Name -> [LHsExprArgIn]
-> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
tcApp m_herald orig_fun orig_args res_ty
= go orig_fun orig_args
where
go :: LHsExpr Name -> [LHsExprArgIn]
-> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
go (L _ (HsPar e)) args = go e args
go (L _ (HsApp e1 e2)) args = go e1 (Left e2:args)
go (L _ (HsAppType e t)) args = go e (Right t:args)
go (L loc (HsVar (L _ fun))) args
| fun `hasKey` tagToEnumKey
, count isLeft args == 1
= do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty
; return (wrap, expr, args) }
| fun `hasKey` seqIdKey
, count isLeft args == 2
= do { (wrap, expr, args) <- tcSeq loc fun args res_ty
; return (wrap, expr, args) }
go (L loc (HsRecFld (Ambiguous lbl _))) args@(Left (L _ arg) : _)
| Just sig_ty <- obviousSig arg
= do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
; sel_name <- disambiguateSelector lbl sig_tc_ty
; go (L loc (HsRecFld (Unambiguous lbl sel_name))) args }
go fun args
= do {
; (fun1, fun_sigma) <- tcInferFun fun
; let orig = exprCtOrigin (unLoc fun)
; (wrap_fun, args1, actual_res_ty)
<- tcArgs fun fun_sigma orig args
(m_herald `orElse` mk_app_msg fun)
; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $
tcSubTypeDS_NC_O orig GenSigCtxt
(Just $ foldl mk_hs_app fun args)
actual_res_ty res_ty
; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) }
mk_hs_app f (Left a) = mkHsApp f a
mk_hs_app f (Right a) = mkHsAppType f a
mk_app_msg :: LHsExpr Name -> SDoc
mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun)
, text "is applied to"]
mk_op_msg :: LHsExpr Name -> SDoc
mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"
tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType)
tcInferFun (L loc (HsVar (L _ name)))
= do { (fun, ty) <- setSrcSpan loc (tcInferId name)
; return (L loc fun, ty) }
tcInferFun (L loc (HsRecFld f))
= do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
; return (L loc fun, ty) }
tcInferFun fun
= do { (fun, fun_ty) <- tcInferSigma fun
; fun_ty' <- zonkTcType fun_ty
; return (fun, fun_ty') }
tcArgs :: LHsExpr Name
-> TcSigmaType
-> CtOrigin
-> [LHsExprArgIn]
-> SDoc
-> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
tcArgs fun orig_fun_ty fun_orig orig_args herald
= go [] 1 orig_fun_ty orig_args
where
orig_arity = length orig_args
go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)
go acc_args n fun_ty (Right hs_ty_arg:args)
= do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty
; case tcSplitForAllTy_maybe upsilon_ty of
Just (binder, inner_ty)
| Just tv <- binderVar_maybe binder ->
ASSERT2( binderVisibility binder == Specified
, (vcat [ ppr fun_ty, ppr upsilon_ty, ppr binder
, ppr inner_ty, pprTvBndr tv
, ppr (binderVisibility binder) ]) )
do { let kind = tyVarKind tv
; ty_arg <- tcHsTypeApp hs_ty_arg kind
; let insted_ty = substTyWithUnchecked [tv] [ty_arg] inner_ty
; (inner_wrap, args', res_ty)
<- go acc_args (n+1) insted_ty args
; let inst_wrap = mkWpTyApps [ty_arg]
; return ( inner_wrap <.> inst_wrap <.> wrap1
, Right hs_ty_arg : args'
, res_ty ) }
_ -> ty_app_err upsilon_ty hs_ty_arg }
go acc_args n fun_ty (Left arg : args)
= do { (wrap, [arg_ty], res_ty)
<- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty
acc_args orig_arity
; arg' <- tcArg fun arg arg_ty n
; (inner_wrap, args', inner_res_ty)
<- go (arg_ty : acc_args) (n+1) res_ty args
; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty <.> wrap
, Left arg' : args'
, inner_res_ty ) }
ty_app_err ty arg
= do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty
; failWith $
text "Cannot apply expression of type" <+> quotes (ppr ty) $$
text "to a visible type argument" <+> quotes (ppr arg) }
tcArg :: LHsExpr Name
-> LHsExpr Name
-> TcRhoType
-> Int
-> TcM (LHsExpr TcId)
tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $
tcPolyExprNC arg ty
tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId]
tcTupArgs args tys
= ASSERT( equalLength args tys ) mapM go (args `zip` tys)
where
go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty))
go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
; return (L l (Present expr')) }
tcSyntaxOp :: CtOrigin
-> SyntaxExpr Name
-> [SyntaxOpType]
-> ExpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr TcId)
tcSyntaxOp orig expr arg_tys res_ty
= tcSyntaxOpGen orig expr arg_tys (SynType res_ty)
tcSyntaxOpGen :: CtOrigin
-> SyntaxExpr Name
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, SyntaxExpr TcId)
tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) })
arg_tys res_ty thing_inside
= do { (expr, sigma) <- tcInferId op
; (result, expr_wrap, arg_wraps, res_wrap)
<- tcSynArgA orig sigma arg_tys res_ty $
thing_inside
; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap }) }
tcSyntaxOpGen _ other _ _ _ = pprPanic "tcSyntaxOp" (ppr other)
tcSynArgE :: CtOrigin
-> TcSigmaType
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper)
tcSynArgE orig sigma_ty syn_ty thing_inside
= do { (skol_wrap, (result, ty_wrapper))
<- tcSkolemise 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 { ( ( ( (result, arg_ty, res_ty)
, res_wrapper )
, arg_wrapper1, [], arg_wrapper2 )
, match_wrapper )
<- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $
\ [arg_ty] res_ty ->
do { arg_tc_ty <- expTypeToType arg_ty
; res_tc_ty <- expTypeToType res_ty
; MASSERT2( case arg_shape of
SynFun {} -> False;
_ -> True
, text "Too many nested arrows in SyntaxOpType" $$
pprCtOrigin orig )
; tcSynArgA orig arg_tc_ty [] arg_shape $
\ arg_results ->
tcSynArgE orig res_tc_ty res_shape $
\ res_results ->
do { result <- thing_inside (arg_results ++ res_results)
; return (result, arg_tc_ty, res_tc_ty) }}
; return ( result
, match_wrapper <.>
mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper
arg_ty res_ty ) }
where
herald = text "This rebindable syntax expects a function with"
go rho_ty (SynType the_ty)
= do { wrap <- tcSubTypeET orig the_ty rho_ty
; result <- thing_inside []
; return (result, wrap) }
tcSynArgA :: CtOrigin
-> TcSigmaType
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
-> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
= do { (match_wrapper, arg_tys, res_ty)
<- matchActualFunTys herald orig noThing (length arg_shapes) sigma_ty
; ((result, res_wrapper), arg_wrappers)
<- tc_syn_args_e arg_tys arg_shapes $ \ arg_results ->
tc_syn_arg res_ty res_shape $ \ res_results ->
thing_inside (arg_results ++ res_results)
; return (result, match_wrapper, arg_wrappers, res_wrapper) }
where
herald = text "This rebindable syntax expects a function with"
tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
-> ([TcSigmaType] -> 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 arg_ty arg_shape $ \ arg1_results ->
tc_syn_args_e arg_tys arg_shapes $ \ args_results ->
thing_inside (arg1_results ++ args_results)
; return (result, arg_wrap : arg_wraps) }
tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside []
tc_syn_arg :: TcSigmaType -> SyntaxOpType
-> ([TcSigmaType] -> 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) <- deeplyInstantiate 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 <- tcSubTypeO orig GenSigCtxt res_ty the_ty
; result <- thing_inside []
; return (result, wrap) }
tcExprSig :: LHsExpr Name -> TcIdSigInfo -> TcM (LHsExpr TcId, TcType)
tcExprSig expr sig@(TISI { sig_bndr = s_bndr
, sig_skols = skol_prs
, sig_theta = theta
, sig_tau = tau })
| null skol_prs
, null theta
, CompleteSig {} <- s_bndr
= do { expr' <- tcPolyExprNC expr tau
; return (expr', tau) }
| CompleteSig poly_id <- s_bndr
= do { given <- newEvVars theta
; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $
tcExtendTyVarEnvFromSig sig $
tcPolyExprNC expr tau
; let poly_wrap = mkWpTyLams skol_tvs
<.> mkWpLams given
<.> mkWpLet ev_binds
; return (mkLHsWrap poly_wrap expr', idType poly_id) }
| PartialSig { sig_name = name } <- s_bndr
= do { (tclvl, wanted, expr') <- pushLevelAndCaptureConstraints $
tcExtendTyVarEnvFromSig sig $
tcPolyExprNC expr tau
; (qtvs, givens, ev_binds)
<- simplifyInfer tclvl False [sig] [(name, tau)] wanted
; tau <- zonkTcType tau
; let inferred_theta = map evVarPred givens
tau_tvs = tyCoVarsOfType tau
; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta
tau_tvs qtvs (Just sig)
; let inferred_sigma = mkInvSigmaTy qtvs inferred_theta tau
my_sigma = mkForAllTys binders (mkPhiTy my_theta tau)
; wrap <- if inferred_sigma `eqType` my_sigma
then return idHsWrapper
else tcSubType_NC ExprSigCtxt inferred_sigma
(mkCheckExpType my_sigma)
; let poly_wrap = wrap
<.> mkWpTyLams qtvs
<.> mkWpLams givens
<.> mkWpLet ev_binds
; return (mkLHsWrap poly_wrap expr', my_sigma) }
| otherwise = panic "tcExprSig"
where
skol_info = SigSkol ExprSigCtxt (mkCheckExpType $ mkPhiTy theta tau)
skol_tvs = map snd skol_prs
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId)
tcCheckId name res_ty
= do { (expr, actual_res_ty) <- tcInferId name
; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $
tcWrapResultO (OccurrenceOf name) expr actual_res_ty res_ty }
tcCheckRecSelId :: AmbiguousFieldOcc Name -> ExpRhoType -> TcM (HsExpr TcId)
tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty
= do { (expr, actual_res_ty) <- tcInferRecSelId f
; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $
tcWrapResultO (OccurrenceOfRecSel lbl) expr actual_res_ty res_ty }
tcCheckRecSelId (Ambiguous lbl _) res_ty
= case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of
Nothing -> ambiguousSelector lbl
Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty }
tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
tcInferRecSelId (Unambiguous (L _ lbl) sel)
= do { (expr', ty) <- tc_infer_id lbl sel
; return (expr', ty) }
tcInferRecSelId (Ambiguous lbl _)
= ambiguousSelector lbl
tcInferId :: Name -> TcM (HsExpr TcId, TcSigmaType)
tcInferId id_name
| id_name `hasKey` tagToEnumKey
= failWithTc (text "tagToEnum# must appear applied to one argument")
| id_name `hasKey` assertIdKey
= do { dflags <- getDynFlags
; if gopt Opt_IgnoreAsserts dflags
then tc_infer_id (nameRdrName id_name) id_name
else tc_infer_assert id_name }
| otherwise
= do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name
; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
; return (expr, ty) }
tc_infer_assert :: Name -> TcM (HsExpr TcId, TcSigmaType)
tc_infer_assert assert_name
= do { assert_error_id <- tcLookupId assertErrorName
; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
(idType assert_error_id)
; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho)
}
tc_infer_id :: RdrName -> Name -> TcM (HsExpr TcId, TcSigmaType)
tc_infer_id lbl id_name
= do { thing <- tcLookup id_name
; case thing of
ATcId { tct_id = id }
-> do { check_naughty id
; checkThLocalId id
; return_id id }
AGlobal (AnId id)
-> do { check_naughty id
; return_id id }
AGlobal (AConLike cl) -> case cl of
RealDataCon con -> return_data_con con
PatSynCon ps -> tcPatSynBuilderOcc ps
_ -> failWithTc $
ppr thing <+> text "used where a value identifier was expected" }
where
return_id id = return (HsVar (noLoc id), idType id)
return_data_con con
| null stupid_theta
= return_id con_wrapper_id
| otherwise
= do { let (tvs, theta, rho) = tcSplitSigmaTy (idType con_wrapper_id)
; (subst, tvs') <- newMetaTyVars tvs
; let tys' = mkTyVarTys tvs'
theta' = substTheta subst theta
rho' = substTy subst rho
; wrap <- instCall (OccurrenceOf id_name) tys' theta'
; addDataConStupidTheta con tys'
; return (mkHsWrap wrap (HsVar (noLoc con_wrapper_id)), rho') }
where
con_wrapper_id = dataConWrapId con
stupid_theta = dataConStupidTheta con
check_naughty id
| isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
| otherwise = return ()
tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr TcId)
tcUnboundId unbound res_ty
= do { ty <- newFlexiTyVarTy liftedTypeKind
; let occ = unboundVarOcc unbound
; name <- newSysName occ
; let ev = mkLocalId name ty
; loc <- getCtLocM HoleOrigin Nothing
; let can = CHoleCan { cc_ev = CtWanted { ctev_pred = ty
, ctev_dest = EvVarDest ev
, ctev_loc = loc}
, cc_hole = ExprHole unbound }
; emitInsoluble can
; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noLoc ev)) ty res_ty }
tcSeq :: SrcSpan -> Name -> [LHsExprArgIn]
-> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
tcSeq loc fun_name args res_ty
= do { fun <- tcLookupId fun_name
; (arg1_ty, args1) <- case args of
(Right hs_ty_arg1 : args1)
-> do { ty_arg1 <- tcHsTypeApp hs_ty_arg1 liftedTypeKind
; return (ty_arg1, args1) }
_ -> do { arg_ty1 <- newFlexiTyVarTy liftedTypeKind
; return (arg_ty1, args) }
; (arg1, arg2, arg2_exp_ty) <- case args1 of
[Right hs_ty_arg2, Left term_arg1, Left term_arg2]
-> do { rr_ty <- newFlexiTyVarTy runtimeRepTy
; ty_arg2 <- tcHsTypeApp hs_ty_arg2 (tYPE rr_ty)
; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg2 res_ty
; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) }
[Left term_arg1, Left term_arg2]
-> return (term_arg1, term_arg2, res_ty)
_ -> too_many_args "seq" args
; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty)
; arg2' <- tcMonoExpr arg2 arg2_exp_ty
; res_ty <- readExpType res_ty
; let fun' = L loc (HsWrap ty_args (HsVar (L loc fun)))
ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
; return (idHsWrapper, fun', [Left arg1', Left arg2']) }
tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
-> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
tcTagToEnum loc fun_name args res_ty
= do { fun <- tcLookupId fun_name
; arg <- case args of
[Right hs_ty_arg, Left term_arg]
-> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg res_ty
; return term_arg }
[Left term_arg] -> do { _ <- expTypeToType res_ty
; return term_arg }
_ -> too_many_args "tagToEnum#" args
; res_ty <- readExpType res_ty
; ty' <- zonkTcType res_ty
; let mb_tc_app = tcSplitTyConApp_maybe ty'
Just (tc, tc_args) = mb_tc_app
; checkTc (isJust mb_tc_app)
(mk_error ty' doc1)
; fam_envs <- tcGetFamInstEnvs
; let (rep_tc, rep_args, coi)
= tcLookupDataFamInst fam_envs tc tc_args
; checkTc (isEnumerationTyCon rep_tc)
(mk_error ty' doc2)
; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)
; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun)))
rep_ty = mkTyConApp rep_tc rep_args
; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) }
where
doc1 = vcat [ text "Specify the type by giving a type signature"
, text "e.g. (tagToEnum# x) :: Bool" ]
doc2 = text "Result type must be an enumeration type"
mk_error :: TcType -> SDoc -> SDoc
mk_error ty what
= hang (text "Bad call to tagToEnum#"
<+> text "at type" <+> ppr ty)
2 what
too_many_args :: String -> [LHsExprArgIn] -> TcM a
too_many_args fun args
= failWith $
hang (text "Too many type arguments to" <+> text fun <> colon)
2 (sep (map pp args))
where
pp (Left e) = pprParendLExpr e
pp (Right (HsWC { hswc_body = L _ t })) = pprParendHsType t
checkThLocalId :: Id -> TcM ()
checkThLocalId id
= do { mb_local_use <- getStageAndBindLevel (idName id)
; case mb_local_use of
Just (top_lvl, bind_lvl, use_stage)
| thLevel use_stage > bind_lvl
, isNotTopLevel top_lvl
-> checkCrossStageLifting id use_stage
_ -> return ()
}
checkCrossStageLifting :: Id -> ThStage -> TcM ()
checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
=
do { let id_ty = idType id
; checkTc (isTauTy id_ty) (polySpliceErr id)
; lift <- if isStringTy id_ty then
do { sid <- tcLookupId THNames.liftStringName
; return (HsVar (noLoc sid)) }
else
setConstraintVar lie_var $
newMethodFromName (OccurrenceOf (idName id))
THNames.liftName id_ty
; ps <- readMutVar ps_var
; let pending_splice = PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id))
; writeMutVar ps_var (pending_splice : ps)
; return () }
checkCrossStageLifting _ _ = return ()
polySpliceErr :: Id -> SDoc
polySpliceErr id
= text "Can't splice the polymorphic local variable" <+> quotes (ppr id)
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 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 ]
disambiguateSelector :: Located RdrName -> Type -> TcM Name
disambiguateSelector lr@(L _ rdr) parent_type
= do { fam_inst_envs <- tcGetFamInstEnvs
; case tyConOf fam_inst_envs parent_type of
Nothing -> ambiguousSelector lr
Just p ->
do { xs <- lookupParents rdr
; let parent = RecSelData p
; case lookup parent xs of
Just gre -> do { addUsedGRE True gre
; return (gre_name gre) }
Nothing -> failWithTc (fieldNotInType parent rdr) } }
ambiguousSelector :: Located RdrName -> TcM a
ambiguousSelector (L _ rdr)
= do { env <- getGlobalRdrEnv
; let gres = lookupGRE_RdrName rdr env
; setErrCtxt [] $ addNameClashErrRn rdr gres
; failM }
disambiguateRecordBinds :: LHsExpr Name -> TcRhoType
-> [LHsRecUpdField Name] -> ExpRhoType
-> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
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 Name -> Maybe (LHsRecUpdField Name, Name)
isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
Unambiguous _ sel_name -> Just (x, sel_name)
Ambiguous{} -> Nothing
getUpdFieldsParents :: TcM [(LHsRecUpdField Name
, [(RecSelParent, GlobalRdrElt)])]
getUpdFieldsParents
= fmap (zip rbnds) $ mapM
(lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)
rbnds
identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
identifyParent fam_inst_envs possible_parents
= case foldr1 intersect possible_parents of
[] -> failWithTc (noPossibleParents rbnds)
[p] -> return p
_:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p)
| Just {} <- obviousSig (unLoc record_expr)
, Just tc <- tyConOf fam_inst_envs record_rho
-> return (RecSelData tc)
_ -> failWithTc badOverloadedUpdate
pickParent :: RecSelParent
-> (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)])
-> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
pickParent p (upd, xs)
= case lookup p xs of
Just gre -> do { unless (null (tail xs)) $ do
let L loc _ = hsRecFieldLbl (unLoc upd)
setSrcSpan loc $ addUsedGRE True gre
; lookupSelector (upd, gre_name gre) }
Nothing -> do { addErrTc (fieldNotInType p
(unLoc (hsRecUpdFieldRdr (unLoc upd))))
; lookupSelector (upd, gre_name (snd (head xs))) }
lookupSelector :: (LHsRecUpdField Name, Name)
-> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
lookupSelector (L l upd, n)
= do { i <- tcLookupId n
; let L loc af = hsRecFieldLbl upd
lbl = rdrNameAmbiguousFieldOcc af
; return $ L l upd { hsRecFieldLbl
= L loc (Unambiguous (L loc lbl) i) } }
tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
tyConOf fam_inst_envs ty0
= case tcSplitTyConApp_maybe ty of
Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
Nothing -> Nothing
where
(_, _, ty) = tcSplitSigmaTy ty0
tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0
lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents rdr
= do { env <- getGlobalRdrEnv
; let gres = lookupGRE_RdrName rdr env
; mapM lookupParent gres }
where
lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
lookupParent gre = do { id <- tcLookupId (gre_name gre)
; if isRecordSelector id
then return (recordSelectorTyCon id, gre)
else failWithTc (notSelector (gre_name gre)) }
obviousSig :: HsExpr Name -> Maybe (LHsSigWcType Name)
obviousSig (ExprWithTySig _ ty) = Just ty
obviousSig (HsPar p) = obviousSig (unLoc p)
obviousSig _ = Nothing
tcRecordBinds
:: ConLike
-> [TcType]
-> HsRecordBinds Name
-> TcM (HsRecordBinds TcId)
tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
= do { mb_binds <- mapM do_bind rbinds
; return (HsRecFields (catMaybes mb_binds) dd) }
where
fields = map flLabel $ conLikeFieldLabels con_like
flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
do_bind :: LHsRecField Name (LHsExpr Name)
-> TcM (Maybe (LHsRecField TcId (LHsExpr TcId)))
do_bind (L l fld@(HsRecField { hsRecFieldLbl = f
, hsRecFieldArg = rhs }))
= do { mb <- tcRecordField con_like flds_w_tys f rhs
; case mb of
Nothing -> return Nothing
Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'
, hsRecFieldArg = rhs' }))) }
tcRecordUpd
:: ConLike
-> [TcType]
-> [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
-> TcM [LHsRecUpdField TcId]
tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
where
flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ conLikeFieldLabels con_like) arg_tys
do_bind :: LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name) -> TcM (Maybe (LHsRecUpdField TcId))
do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af
, hsRecFieldArg = rhs }))
= do { let lbl = rdrNameAmbiguousFieldOcc af
sel_id = selectorAmbiguousFieldOcc af
f = L loc (FieldOcc (L loc lbl) (idName sel_id))
; mb <- tcRecordField con_like flds_w_tys f rhs
; case mb of
Nothing -> return Nothing
Just (f', rhs') ->
return (Just
(L l (fld { hsRecFieldLbl
= L loc (Unambiguous (L loc lbl)
(selectorFieldOcc (unLoc f')))
, hsRecFieldArg = rhs' }))) }
tcRecordField :: ConLike -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name
-> TcM (Maybe (LFieldOcc Id, LHsExpr Id))
tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs
| Just field_ty <- assocMaybe flds_w_tys field_lbl
= addErrCtxt (fieldCtxt field_lbl) $
do { rhs' <- tcPolyExprNC rhs field_ty
; let field_id = mkUserLocal (nameOccName sel_name)
(nameUnique sel_name)
field_ty loc
; return (Just (L loc (FieldOcc lbl field_id), rhs')) }
| otherwise
= do { addErrTc (badFieldCon con_like field_lbl)
; return Nothing }
where
field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
checkMissingFields :: ConLike -> HsRecordBinds Name -> TcM ()
checkMissingFields con_like rbinds
| null field_labels
= if any isBanged field_strs then
addErrTc (missingStrictFields con_like [])
else
return ()
| otherwise = do
unless (null missing_s_fields)
(addErrTc (missingStrictFields con_like missing_s_fields))
warn <- woptM Opt_WarnMissingFields
unless (not (warn && notNull missing_ns_fields))
(warnTc (Reason Opt_WarnMissingFields) True
(missingFields con_like missing_ns_fields))
where
missing_s_fields
= [ flLabel fl | (fl, str) <- field_info,
isBanged str,
not (fl `elemField` field_names_used)
]
missing_ns_fields
= [ flLabel fl | (fl, str) <- field_info,
not (isBanged str),
not (fl `elemField` field_names_used)
]
field_names_used = hsRecFields rbinds
field_labels = conLikeFieldLabels con_like
field_info = zipEqual "missingFields"
field_labels
field_strs
field_strs = conLikeImplBangs con_like
fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
exprCtxt :: LHsExpr Name -> SDoc
exprCtxt expr
= hang (text "In the expression:") 2 (ppr expr)
fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt field_name
= text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
addFunResCtxt :: Bool
-> HsExpr Name -> TcType -> ExpRhoType
-> TcM a -> TcM a
addFunResCtxt has_args fun fun_res_ty env_ty
= addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg)
where
mk_msg
= do { mb_env_ty <- readExpType_maybe env_ty
; fun_res' <- zonkTcType fun_res_ty
; env' <- case mb_env_ty of
Just env_ty -> zonkTcType env_ty
Nothing ->
do { dumping <- doptM Opt_D_dump_tc_trace
; MASSERT( dumping )
; newFlexiTyVarTy liftedTypeKind }
; let (_, _, fun_tau) = tcSplitSigmaTy fun_res'
(_, _, env_tau) = tcSplitSigmaTy env'
(args_fun, res_fun) = tcSplitFunTys fun_tau
(args_env, res_env) = tcSplitFunTys env_tau
n_fun = length args_fun
n_env = length args_env
info | n_fun == n_env = Outputable.empty
| n_fun > n_env
, not_fun res_env
= text "Probable cause:" <+> quotes (ppr fun)
<+> text "is applied to too few arguments"
| has_args
, not_fun res_fun
= text "Possible cause:" <+> quotes (ppr fun)
<+> text "is applied to too many arguments"
| otherwise
= Outputable.empty
; return info }
where
not_fun ty
= case tcSplitTyConApp_maybe ty of
Just (tc, _) -> isAlgTyCon tc
Nothing -> False
badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
badFieldTypes prs
= hang (text "Record update for insufficiently polymorphic field"
<> plural prs <> colon)
2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
badFieldsUpd
:: [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
-> [ConLike]
-> SDoc
badFieldsUpd rbinds data_cons
= hang (text "No constructor has all these fields:")
2 (pprQuotedList 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 (Set.member fld) fieldLabelSets)) $
map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds
fieldLabelSets :: [Set.Set FieldLabelString]
fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons
sortMembership =
map snd .
sortBy (compare `on` fst) .
map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
countTrue = length . filter id
naughtyRecordSel :: RdrName -> SDoc
naughtyRecordSel sel_id
= text "Cannot use record selector" <+> quotes (ppr sel_id) <+>
text "as a function due to escaped type variables" $$
text "Probable fix: use pattern-matching syntax instead"
notSelector :: Name -> SDoc
notSelector field
= hsep [quotes (ppr field), text "is not a record selector"]
mixedSelectors :: [Id] -> [Id] -> SDoc
mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)
= ptext
(sLit "Cannot use a mixture of pattern synonym and record selectors") $$
text "Record selectors defined by"
<+> quotes (ppr (tyConName rep_dc))
<> text ":"
<+> pprWithCommas ppr data_sels $$
text "Pattern synonym selectors defined by"
<+> quotes (ppr (patSynName rep_ps))
<> text ":"
<+> pprWithCommas ppr pat_syn_sels
where
RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
RecSelData rep_dc = recordSelectorTyCon dc_rep_id
mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists"
missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
missingStrictFields con fields
= header <> rest
where
rest | null fields = Outputable.empty
| otherwise = colon <+> pprWithCommas ppr fields
header = text "Constructor" <+> quotes (ppr con) <+>
text "does not have the required strict field(s)"
missingFields :: ConLike -> [FieldLabelString] -> SDoc
missingFields con fields
= text "Fields of" <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
<+> pprWithCommas ppr fields
noPossibleParents :: [LHsRecUpdField Name] -> SDoc
noPossibleParents rbinds
= hang (text "No type has all these fields:")
2 (pprQuotedList fields)
where
fields = map (hsRecFieldLbl . unLoc) rbinds
badOverloadedUpdate :: SDoc
badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature"
fieldNotInType :: RecSelParent -> RdrName -> SDoc
fieldNotInType p rdr
= unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr