diff options
Diffstat (limited to 'compiler/typecheck/TcExpr.hs')
| -rw-r--r-- | compiler/typecheck/TcExpr.hs | 690 |
1 files changed, 396 insertions, 294 deletions
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 0e1e8662bf..b70276da7e 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -19,6 +19,8 @@ module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC, #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) import THNames( liftStringName, liftName ) @@ -43,7 +45,6 @@ import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr ) import TcPat import TcMType import TcType -import DsMonad import Id import IdInfo import ConLike @@ -58,14 +59,15 @@ import TyCoRep import Type import TcEvidence import VarSet +import MkId( seqId ) import TysWiredIn -import TysPrim( intPrimTy ) +import TysPrim( intPrimTy, mkTemplateTyVars, tYPE ) import PrimOp( tagToEnumKey ) import PrelNames import DynFlags import SrcLoc import Util -import VarEnv ( emptyTidyEnv ) +import VarEnv ( emptyTidyEnv, mkInScopeSet ) import ListSetOps import Maybes import Outputable @@ -77,7 +79,6 @@ import qualified GHC.LanguageExtensions as LangExt import Data.Function import Data.List -import Data.Either import qualified Data.Set as Set {- @@ -109,12 +110,10 @@ tc_poly_expr expr res_ty 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) + = setSrcSpan loc $ + do { traceTc "tcPolyExprNC" (ppr res_ty) ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> - setSrcSpan loc $ - -- NB: setSrcSpan *after* skolemising, so we get better - -- skolem locations tcExpr expr res_ty ; return $ L loc (mkHsWrap wrap expr') } @@ -166,43 +165,43 @@ NB: The res_ty is always deeply skolemised. -} tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty -tcExpr (HsUnboundVar uv) res_ty = tcUnboundId uv res_ty +tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty +tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e 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 +tcExpr e@(HsLit x lit) res_ty = do { let lit_ty = hsLitType lit - ; tcWrapResult e (HsLit (convertLit lit)) lit_ty res_ty } + ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } -tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar expr') } +tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty + ; return (HsPar x expr') } -tcExpr (HsSCC src lbl expr) res_ty +tcExpr (HsSCC x src lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsSCC src lbl expr') } + ; return (HsSCC x src lbl expr') } -tcExpr (HsTickPragma src info srcInfo expr) res_ty +tcExpr (HsTickPragma x src info srcInfo expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsTickPragma src info srcInfo expr') } + ; return (HsTickPragma x src info srcInfo expr') } -tcExpr (HsCoreAnn src lbl expr) res_ty +tcExpr (HsCoreAnn x src lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsCoreAnn src lbl expr') } + ; return (HsCoreAnn x src lbl expr') } -tcExpr (HsOverLit lit) res_ty +tcExpr (HsOverLit x lit) res_ty = do { lit' <- newOverloadedLit lit res_ty - ; return (HsOverLit lit') } + ; return (HsOverLit x lit') } -tcExpr (NegApp expr neg_expr) res_ty +tcExpr (NegApp x 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') } + ; return (NegApp x expr' neg_expr') } -tcExpr e@(HsIPVar x) res_ty +tcExpr e@(HsIPVar _ x) res_ty = do { {- Implicit parameters must have a *tau-type* not a type scheme. We enforce this by creating a fresh type variable as its type. (Because res_ty may not @@ -211,15 +210,16 @@ tcExpr e@(HsIPVar x) res_ty ; 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 } + ; tcWrapResult e + (fromDict ipClass ip_name ip_ty (HsVar noExt (noLoc ip_var))) + ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`. fromDict ipClass x ty = mkHsWrap $ mkWpCastR $ unwrapIP $ mkClassPred ipClass [x,ty] origin = IPOccOrigin x -tcExpr e@(HsOverLabel mb_fromLabel l) res_ty +tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty = do { -- See Note [Type-checking overloaded labels] loc <- getSrcSpanM ; case mb_fromLabel of @@ -229,7 +229,8 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty ; let pred = mkClassPred isLabelClass [lbl, alpha] ; loc <- getSrcSpanM ; var <- emitWantedEvVar origin pred - ; tcWrapResult e (fromDict pred (HsVar (L loc var))) + ; tcWrapResult e + (fromDict pred (HsVar noExt (L loc var))) alpha res_ty } } where -- Coerces a dictionary for `IsLabel "x" t` into `t`, @@ -239,12 +240,13 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty lbl = mkStrLitTy l applyFromLabel loc fromLabel = - L loc (HsVar (L loc fromLabel)) `HsAppType` - mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l))) + HsAppType + (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l)))) + (L loc (HsVar noExt (L loc fromLabel))) -tcExpr (HsLam match) res_ty +tcExpr (HsLam x match) res_ty = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty - ; return (mkHsWrap wrap (HsLam match')) } + ; return (mkHsWrap wrap (HsLam x match')) } where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } herald = sep [ text "The lambda expression" <+> @@ -253,23 +255,23 @@ tcExpr (HsLam match) res_ty -- The pprSetDepth makes the abstraction print briefly text "has"] -tcExpr e@(HsLamCase matches) res_ty +tcExpr e@(HsLamCase x matches) res_ty = do { (matches', wrap) <- tcMatchLambda msg match_ctxt matches res_ty -- The laziness annotation is because we don't want to fail here -- if there are multiple arguments - ; return (mkHsWrap wrap $ HsLamCase matches') } + ; return (mkHsWrap wrap $ HsLamCase x 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 +tcExpr e@(ExprWithTySig sig_ty expr) res_ty = do { let loc = getLoc (hsSigWcType sig_ty) ; sig_info <- checkNoErrs $ -- Avoid error cascade tcUserTypeSig loc sig_ty Nothing ; (expr', poly_ty) <- tcExprSig expr sig_info - ; let expr'' = ExprWithTySigOut expr' sig_ty + ; let expr'' = ExprWithTySig sig_ty expr' ; tcWrapResult e expr'' poly_ty res_ty } {- @@ -348,8 +350,8 @@ construct. See also Note [seqId magic] in MkId -} -tcExpr expr@(OpApp arg1 op fix arg2) res_ty - | (L loc (HsVar (L lv op_name))) <- op +tcExpr expr@(OpApp fix arg1 op arg2) res_ty + | (L loc (HsVar _ (L lv op_name))) <- op , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind ; let arg2_exp_ty = res_ty @@ -359,10 +361,10 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ; arg2_ty <- readExpType arg2_exp_ty ; op_id <- tcLookupId op_name ; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty]) - (HsVar (L lv op_id))) - ; return $ OpApp arg1' op' fix arg2' } + (HsVar noExt (L lv op_id))) + ; return $ OpApp fix arg1' op' arg2' } - | (L loc (HsVar (L lv op_name))) <- op + | (L loc (HsVar _ (L lv op_name))) <- op , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] = do { traceTc "Application rule" (ppr op) ; (arg1', arg1_ty) <- tcInferSigma arg1 @@ -370,7 +372,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ; let doc = text "The first argument of ($) takes" orig1 = lexprCtOrigin arg1 ; (wrap_arg1, [arg2_sigma], op_res_ty) <- - matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty + matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty -- We have (arg1 $ arg2) -- So: arg1_ty = arg2_ty -> op_res_ty @@ -385,7 +387,8 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty -- -- The *result* type can have any kind (Trac #8739), -- so we don't need to check anything for that - ; _ <- unifyKind (Just arg2_sigma) (typeKind arg2_sigma) liftedTypeKind + ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma)) + (typeKind arg2_sigma) liftedTypeKind -- ignore the evidence. arg2_sigma must have type * or #, -- because we know arg2_sigma -> or_res_ty is well-kinded -- (because otherwise matchActualFunTys would fail) @@ -396,10 +399,10 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ; op_id <- tcLookupId op_name ; res_ty <- readExpType res_ty - ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty + ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep res_ty , arg2_sigma , res_ty]) - (HsVar (L lv op_id))) + (HsVar noExt (L lv op_id))) -- arg1' :: arg1_ty -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) -- wrap_res :: op_res_ty "->" res_ty @@ -410,63 +413,63 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty <.> wrap_arg1 doc = text "When looking at the argument to ($)" - ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') } + ; return (OpApp fix (mkLHsWrap wrap1 arg1') op' arg2') } - | (L loc (HsRecFld (Ambiguous lbl _))) <- op + | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op , Just sig_ty <- obviousSig (unLoc arg1) -- See Note [Disambiguating record fields] = 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 + ; let op' = L loc (HsRecFld noExt (Unambiguous sel_name lbl)) + ; tcExpr (OpApp fix arg1 op' arg2) res_ty } | otherwise = do { traceTc "Non Application rule" (ppr op) - ; (wrap, op', [Left arg1', Left arg2']) + ; (wrap, op', [HsValArg arg1', HsValArg arg2']) <- tcApp (Just $ mk_op_msg op) - op [Left arg1, Left arg2] res_ty - ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') } + op [HsValArg arg1, HsValArg arg2] res_ty + ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') } -- Right sections, equivalent to \ x -> x `op` expr, or -- \ x -> op x expr -tcExpr expr@(SectionR op arg2) res_ty +tcExpr expr@(SectionR x op arg2) res_ty = do { (op', op_ty) <- tcInferFun op ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) - <- matchActualFunTys (mk_op_msg op) fn_orig (Just op) 2 op_ty + <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc 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' ) } + SectionR x (mkLHsWrap wrap_fun op') arg2' ) } where fn_orig = lexprCtOrigin op -- It's important to use the origin of 'op', so that call-stacks -- come out right; they are driven by the OccurrenceOf CtOrigin -- See Trac #13285 -tcExpr expr@(SectionL arg1 op) res_ty +tcExpr expr@(SectionL x arg1 op) res_ty = do { (op', op_ty) <- tcInferFun op ; dflags <- getDynFlags -- Note [Left sections] ; 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) fn_orig (Just op) + <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc 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') ) } + SectionL x arg1' (mkLHsWrap wrap_fn op') ) } where fn_orig = lexprCtOrigin op -- It's important to use the origin of 'op', so that call-stacks -- come out right; they are driven by the OccurrenceOf CtOrigin -- See Trac #13285 -tcExpr expr@(ExplicitTuple tup_args boxity) res_ty +tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty | all tupArgPresent tup_args = do { let arity = length tup_args tup_tc = tupleTyCon boxity arity @@ -478,7 +481,7 @@ tcExpr expr@(ExplicitTuple tup_args boxity) 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) } + ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } | otherwise = -- The tup_args are a mixture of Present and Missing (for tuple sections) @@ -498,16 +501,16 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty -- Handle tuple sections where ; tup_args1 <- tcTupArgs tup_args arg_tys - ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) } + ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) } -tcExpr (ExplicitSum alt arity expr _) 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 ; -- Drop levity vars, we don't care about them here let arg_tys' = drop arity arg_tys ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1)) - ; return $ mkHsWrapCo coi (ExplicitSum alt arity expr' arg_tys') } + ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } tcExpr (ExplicitList _ witness exprs) res_ty = case witness of @@ -528,15 +531,6 @@ tcExpr (ExplicitList _ witness exprs) res_ty ; return $ ExplicitList elt_ty (Just fln') exprs' } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty -tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty - = 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 - {- ************************************************************************ * * @@ -545,12 +539,12 @@ tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty ************************************************************************ -} -tcExpr (HsLet (L l binds) expr) res_ty +tcExpr (HsLet x (L l binds) expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty - ; return (HsLet (L l binds') expr') } + ; return (HsLet x (L l binds') expr') } -tcExpr (HsCase scrut matches) res_ty +tcExpr (HsCase x scrut matches) res_ty = do { -- We used to typecheck the case alternatives first. -- The case patterns tend to give good type info to use -- when typechecking the scrutinee. For example @@ -564,12 +558,12 @@ tcExpr (HsCase scrut matches) res_ty ; traceTc "HsCase" (ppr scrut_ty) ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty - ; return (HsCase scrut' matches') } + ; return (HsCase x scrut' matches') } where match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' +tcExpr (HsIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) ; res_ty <- tauifyExpType res_ty -- Just like Note [Case branches must never infer a non-tau type] @@ -577,9 +571,9 @@ tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' ; b1' <- tcMonoExpr b1 res_ty ; b2' <- tcMonoExpr b2 res_ty - ; return (HsIf Nothing pred' b1' b2') } + ; return (HsIf x Nothing pred' b1' b2') } -tcExpr (HsIf (Just fun) pred b1 b2) res_ty +tcExpr (HsIf x (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] -> @@ -587,7 +581,7 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty ; b1' <- tcPolyExpr b1 b1_ty ; b2' <- tcPolyExpr b2 b2_ty ; return (pred', b1', b2') } - ; return (HsIf (Just fun') pred' b1' b2') } + ; return (HsIf x (Just fun') pred' b1' b2') } tcExpr (HsMultiIf _ alts) res_ty = do { res_ty <- if isSingleton alts @@ -601,13 +595,13 @@ tcExpr (HsMultiIf _ alts) 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 +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 +tcExpr (HsProc x pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCo coi (HsProc pat' cmd') } + ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. -- See Note [Grand plan for static forms] in StaticPtrTable for an overview. @@ -648,7 +642,8 @@ tcExpr (HsStatic fvs expr) res_ty ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty ; let wrap = mkWpTyApps [expr_ty] ; loc <- getSrcSpanM - ; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr) + ; return $ mkHsWrapCo co $ HsApp noExt + (L loc $ mkHsWrap wrap fromStaticPtr) (L loc (HsStatic fvs expr')) } @@ -682,9 +677,10 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name ; 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 + RecordCon { rcon_ext = RecordConTc + { rcon_con_like = con_like + , rcon_con_expr = mkHsWrap con_wrap con_expr } + , rcon_con_name = L loc con_id , rcon_flds = rbinds' } } } {- @@ -938,7 +934,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty ; wrap_res <- tcSubTypeHR (exprCtOrigin expr) (Just expr) rec_res_ty res_ty - ; co_scrut <- unifyType (Just record_expr) record_rho scrut_ty + ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty -- NB: normal unification is OK here (as opposed to subsumption), -- because for this to work out, both record_rho and scrut_ty have -- to be normal datatypes -- no contravariant stuff can go on @@ -969,13 +965,17 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- Phew! ; return $ mkHsWrap wrap_res $ - RecordUpd { rupd_expr = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') + 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 } } + , rupd_ext = RecordUpdTc + { 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 e@(HsRecFld _ f) res_ty + = tcCheckRecSelId e f res_ty {- ************************************************************************ @@ -990,35 +990,6 @@ tcExpr (HsRecFld 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 -- !!!FIXME: chak - ; return $ - mkHsWrapCo coi $ - PArrSeq eft (FromThenTo expr1' expr2' expr3') } - -tcExpr (PArrSeq _ _) _ - = panic "TcExpr.tcExpr: Infinite parallel array!" - -- the parser shouldn't have generated it and the renamer shouldn't have - -- let it through - {- ************************************************************************ * * @@ -1031,16 +1002,16 @@ tcExpr (PArrSeq _ _) _ -- Here we get rid of it and add the finalizers to the global environment. -- -- See Note [Delaying modFinalizers in untyped splices] in RnSplice. -tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr))) +tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr))) res_ty = do addModFinalizersWithLclEnv mod_finalizers tcExpr expr res_ty -tcExpr (HsSpliceE splice) res_ty +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 e@(HsBracket _ brack) res_ty + = tcTypedBracket e brack res_ty +tcExpr e@(HsRnBracketOut _ brack ps) res_ty + = tcUntypedBracket e brack ps res_ty {- ************************************************************************ @@ -1122,19 +1093,61 @@ arithSeqEltType (Just fl) res_ty ************************************************************************ -} -type LHsExprArgIn = Either (LHsExpr GhcRn) (LHsWcType GhcRn) -type LHsExprArgOut = Either (LHsExpr GhcTcId) (LHsWcType GhcRn) - -- Left e => argument expression - -- Right ty => visible type application +data HsArg tm ty + = HsValArg tm -- Argument is an ordinary expression (f arg) + | HsTypeArg ty -- Argument is a visible type application (f @ty) + | HsArgPar SrcSpan -- See Note [HsArgPar] + +{- +Note [HsArgPar] +A HsArgPar indicates that everything to the left of this in the argument list is +enclosed in parentheses together with the function itself. It is necessary so +that we can recreate the parenthesis structure in the original source after +typechecking the arguments. + +The SrcSpan is the span of the original HsPar + +((f arg1) arg2 arg3) results in an input argument list of +[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2] + +-} + +wrapHsArgs :: (XAppTypeE (GhcPass id) ~ LHsWcType GhcRn) + => LHsExpr (GhcPass id) + -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)] + -> LHsExpr (GhcPass id) +wrapHsArgs f [] = f +wrapHsArgs f (HsValArg a : args) = wrapHsArgs (mkHsApp f a) args +wrapHsArgs f (HsTypeArg t : args) = wrapHsArgs (mkHsAppType f t) args +wrapHsArgs f (HsArgPar sp : args) = wrapHsArgs (L sp $ HsPar noExt f) args + +instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where + ppr (HsValArg tm) = text "HsValArg" <> ppr tm + ppr (HsTypeArg ty) = text "HsTypeArg" <> ppr ty + ppr (HsArgPar sp) = text "HsArgPar" <> ppr sp + +isHsValArg :: HsArg tm ty -> Bool +isHsValArg (HsValArg {}) = True +isHsValArg (HsTypeArg {}) = False +isHsValArg (HsArgPar {}) = False + +isArgPar :: HsArg tm ty -> Bool +isArgPar (HsArgPar {}) = True +isArgPar (HsValArg {}) = False +isArgPar (HsTypeArg {}) = False + +isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d) +isArgPar_maybe (HsArgPar sp) = Just $ HsArgPar sp +isArgPar_maybe _ = Nothing + +type LHsExprArgIn = HsArg (LHsExpr GhcRn) (LHsWcType GhcRn) +type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn) tcApp1 :: HsExpr GhcRn -- either HsApp or HsAppType -> ExpRhoType -> TcM (HsExpr GhcTcId) tcApp1 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 + ; return (mkHsWrap wrap $ unLoc $ wrapHsArgs fun args) } tcApp :: Maybe SDoc -- like "The function `f' is applied to" -- or leave out to get exactly that message @@ -1145,66 +1158,103 @@ tcApp :: Maybe SDoc -- like "The function `f' is applied to" -- But OpApp is slightly different, so that's why the caller -- must assemble -tcApp m_herald orig_fun orig_args res_ty - = go orig_fun orig_args +tcApp m_herald (L sp (HsPar _ fun)) args res_ty + = tcApp m_herald fun (HsArgPar sp : args) res_ty + +tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty + = tcApp m_herald fun (HsValArg arg1 : args) res_ty + +tcApp m_herald (L _ (HsAppType ty1 fun)) args res_ty + = tcApp m_herald fun (HsTypeArg ty1 : args) res_ty + +tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty + | Ambiguous _ lbl <- fld_lbl -- Still ambiguous + , HsValArg (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first + , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates + = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty + ; sel_name <- disambiguateSelector lbl sig_tc_ty + ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl) + ; tcFunApp m_herald fun (L loc tc_fun) fun_ty args res_ty } + +tcApp m_herald fun@(L loc (HsVar _ (L _ fun_id))) args res_ty + -- Special typing rule for tagToEnum# + | fun_id `hasKey` tagToEnumKey + , n_val_args == 1 + = tcTagToEnum loc fun_id args res_ty + + -- Special typing rule for 'seq' + -- In the saturated case, behave as if seq had type + -- forall a (b::TYPE r). a -> b -> b + -- for some type r. See Note [Typing rule for seq] + | fun_id `hasKey` seqIdKey + , n_val_args == 2 + = do { rep <- newFlexiTyVarTy runtimeRepTy + ; let [alpha, beta] = mkTemplateTyVars [liftedTypeKind, tYPE rep] + seq_ty = mkSpecForAllTys [alpha,beta] + (mkTyVarTy alpha `mkFunTy` mkTyVarTy beta `mkFunTy` mkTyVarTy beta) + seq_fun = L loc (HsVar noExt (L loc seqId)) + -- seq_ty = forall (a:*) (b:TYPE r). a -> b -> b + -- where 'r' is a meta type variable + ; tcFunApp m_herald fun seq_fun seq_ty args res_ty } + where + n_val_args = count isHsValArg args + +tcApp _ (L loc (ExplicitList _ Nothing [])) [HsTypeArg ty_arg] res_ty + -- See Note [Visible type application for the empty list constructor] + = do { ty_arg' <- tcHsTypeApp ty_arg liftedTypeKind + ; let list_ty = TyConApp listTyCon [ty_arg'] + ; _ <- tcSubTypeDS (OccurrenceOf nilDataConName) GenSigCtxt + list_ty res_ty + ; let expr :: LHsExpr GhcTcId + expr = L loc $ ExplicitList ty_arg' Nothing [] + ; return (idHsWrapper, expr, []) } + +tcApp m_herald fun args res_ty + = do { (tc_fun, fun_ty) <- tcInferFun fun + ; tcFunApp m_herald fun tc_fun fun_ty args res_ty } + +--------------------- +tcFunApp :: Maybe SDoc -- like "The function `f' is applied to" + -- or leave out to get exactly that message + -> LHsExpr GhcRn -- Renamed function + -> LHsExpr GhcTcId -> TcSigmaType -- Function and its type + -> [LHsExprArgIn] -- Arguments + -> ExpRhoType -- Overall result type + -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) + -- (wrapper-for-result, fun, args) + -- For an ordinary function application, + -- these should be assembled as wrap_res[ fun args ] + -- But OpApp is slightly different, so that's why the caller + -- must assemble + +-- tcFunApp deals with the general case; +-- the special cases are handled by tcApp +tcFunApp m_herald rn_fun tc_fun fun_sigma rn_args res_ty + = do { let orig = lexprCtOrigin rn_fun + + ; (wrap_fun, tc_args, actual_res_ty) + <- tcArgs rn_fun fun_sigma orig rn_args + (m_herald `orElse` mk_app_msg rn_fun rn_args) + + -- this is just like tcWrapResult, but the types don't line + -- up to call that function + ; wrap_res <- addFunResCtxt True (unLoc rn_fun) actual_res_ty res_ty $ + tcSubTypeDS_NC_O orig GenSigCtxt + (Just $ unLoc $ wrapHsArgs rn_fun rn_args) + actual_res_ty res_ty + + ; return (wrap_res, mkLHsWrap wrap_fun tc_fun, tc_args) } + +mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc +mk_app_msg fun args = sep [ text "The" <+> text what <+> quotes (ppr expr) + , text "is applied to"] where - go :: LHsExpr GhcRn -> [LHsExprArgIn] - -> TcM (HsWrapper, LHsExpr GhcTcId, [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 } - - -- See Note [Visible type application for the empty list constructor] - go (L loc (ExplicitList _ Nothing [])) [Right ty_arg] - = do { ty_arg' <- tcHsTypeApp ty_arg liftedTypeKind - ; let list_ty = TyConApp listTyCon [ty_arg'] - ; _ <- tcSubTypeDS (OccurrenceOf nilDataConName) GenSigCtxt - list_ty res_ty - ; let expr :: LHsExpr GhcTcId - expr = L loc $ ExplicitList ty_arg' Nothing [] - ; return (idHsWrapper, expr, []) } - - go fun args - = do { -- Type-check the function - ; (fun1, fun_sigma) <- tcInferFun fun - ; let orig = lexprCtOrigin fun - - ; (wrap_fun, args1, actual_res_ty) - <- tcArgs fun fun_sigma orig args - (m_herald `orElse` mk_app_msg fun) - - -- this is just like tcWrapResult, but the types don't line - -- up to call that function - ; 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 GhcRn -> SDoc -mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun) - , text "is applied to"] + what | null type_app_args = "function" + | otherwise = "expression" + -- Include visible type arguments (but not other arguments) in the herald. + -- See Note [Herald for matchExpectedFunTys] in TcUnify. + expr = mkHsAppTypes fun type_app_args + type_app_args = [hs_ty | HsTypeArg hs_ty <- args] mk_op_msg :: LHsExpr GhcRn -> SDoc mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" @@ -1232,12 +1282,12 @@ which is better than before. ---------------- tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType) -- Infer type of a function -tcInferFun (L loc (HsVar (L _ name))) +tcInferFun (L loc (HsVar _ (L _ name))) = do { (fun, ty) <- setSrcSpan loc (tcInferId name) -- Don't wrap a context around a plain Id ; return (L loc fun, ty) } -tcInferFun (L loc (HsRecFld f)) +tcInferFun (L loc (HsRecFld _ f)) = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f) -- Don't wrap a context around a plain Id ; return (L loc fun, ty) } @@ -1261,11 +1311,20 @@ tcArgs :: LHsExpr GhcRn -- ^ The function itself (for err msgs only) tcArgs fun orig_fun_ty fun_orig orig_args herald = go [] 1 orig_fun_ty orig_args where - orig_arity = length orig_args + -- Don't count visible type arguments when determining how many arguments + -- an expression is given in an arity mismatch error, since visible type + -- arguments reported as a part of the expression herald itself. + -- See Note [Herald for matchExpectedFunTys] in TcUnify. + orig_expr_args_arity = count isHsValArg orig_args go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty) - go acc_args n fun_ty (Right hs_ty_arg:args) + go acc_args n fun_ty (HsArgPar sp : args) + = do { (inner_wrap, args', res_ty) <- go acc_args n fun_ty args + ; return (inner_wrap, HsArgPar sp : args', res_ty) + } + + go acc_args n fun_ty (HsTypeArg hs_ty_arg : args) = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty -- wrap1 :: fun_ty "->" upsilon_ty ; case tcSplitForAllTy_maybe upsilon_ty of @@ -1278,27 +1337,40 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald , ppr inner_ty, pprTyVar tv , ppr vis ]) ) ; ty_arg <- tcHsTypeApp hs_ty_arg kind - ; let insted_ty = substTyWithUnchecked [tv] [ty_arg] inner_ty + + ; inner_ty <- zonkTcType inner_ty + -- See Note [Visible type application zonk] + + ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg]) + insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty + -- NB: tv and ty_arg have the same kind, so this + -- substitution is kind-respecting + ; traceTc "VTA" (vcat [ppr tv, debugPprType kind + , debugPprType ty_arg + , debugPprType (typeKind ty_arg) + , debugPprType inner_ty + , debugPprType insted_ty ]) + ; (inner_wrap, args', res_ty) <- go acc_args (n+1) insted_ty args -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty ; let inst_wrap = mkWpTyApps [ty_arg] ; return ( inner_wrap <.> inst_wrap <.> wrap1 - , Right hs_ty_arg : args' + , HsTypeArg hs_ty_arg : args' , res_ty ) } _ -> ty_app_err upsilon_ty hs_ty_arg } - go acc_args n fun_ty (Left arg : args) + go acc_args n fun_ty (HsValArg arg : args) = do { (wrap, [arg_ty], res_ty) - <- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty - acc_args orig_arity + <- matchActualFunTysPart herald fun_orig (Just (unLoc fun)) 1 fun_ty + acc_args orig_expr_args_arity -- wrap :: fun_ty "->" arg_ty -> res_ty ; arg' <- tcArg fun arg arg_ty n ; (inner_wrap, args', inner_res_ty) <- go (arg_ty : acc_args) (n+1) res_ty args -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap - , Left arg' : args' + , HsValArg arg' : args' , inner_res_ty ) } where doc = text "When checking the" <+> speakNth n <+> @@ -1310,6 +1382,35 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald text "Cannot apply expression of type" <+> quotes (ppr ty) $$ text "to a visible type argument" <+> quotes (ppr arg) } +{- Note [Visible type application zonk] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg). + +* tcHsTypeApp only guarantees that + - ty_arg is zonked + - kind(zonk(tv)) = kind(ty_arg) + (checkExpectedKind zonks as it goes). + +So we must zonk inner_ty as well, to guarantee consistency between zonk(tv) +and inner_ty. Otherwise we can build an ill-kinded type. An example was +Trac #14158, where we had: + id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a +and we had the visible type application + id @(->) + +* We instantiated k := kappa, yielding + forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a +* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *). +* That instantiated (->) as ((->) q1 q1), and unified kappa := q1, + Here q1 :: RuntimeRep +* Now we substitute + cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> * + but we must first zonk the inner_ty to get + forall (a :: TYPE q1). cat a a + so that the result of substitution is well-kinded + Failing to do so led to Trac #14158. +-} + ---------------- tcArg :: LHsExpr GhcRn -- The function (for error messages) -> LHsExpr GhcRn -- Actual arguments @@ -1325,8 +1426,9 @@ 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')) } + go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty + ; return (L l (Present x expr')) } + go (L _ (XTupArg{}), _) = panic "tcTupArgs" --------------------------- -- See TcType.SyntaxOpType also for commentary @@ -1349,7 +1451,7 @@ tcSyntaxOpGen :: CtOrigin -> SyntaxOpType -> ([TcSigmaType] -> TcM a) -> TcM (a, SyntaxExpr GhcTcId) -tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) }) +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) @@ -1449,7 +1551,7 @@ tcSynArgA :: CtOrigin -- and a wrapper to be applied to the overall expression 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 + <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) ; ((result, res_wrapper), arg_wrappers) <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results -> @@ -1534,10 +1636,14 @@ tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id ; given <- newEvVars theta + ; traceTc "tcExprSig: CompleteSig" $ + vcat [ text "poly_id:" <+> ppr poly_id <+> dcolon <+> ppr (idType poly_id) + , text "tv_prs:" <+> ppr tv_prs ] + ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs skol_tvs = map snd tv_prs ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $ - tcExtendTyVarEnv2 tv_prs $ + tcExtendNameTyVarEnv tv_prs $ tcPolyExprNC expr tau ; let poly_wrap = mkWpTyLams skol_tvs @@ -1550,8 +1656,8 @@ tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) do { (tclvl, wanted, (expr', sig_inst)) <- pushLevelAndCaptureConstraints $ do { sig_inst <- tcInstSig sig - ; expr' <- tcExtendTyVarEnv2 (sig_inst_skols sig_inst) $ - tcExtendTyVarEnv2 (sig_inst_wcs sig_inst) $ + ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $ + tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ tcPolyExprNC expr (sig_inst_tau sig_inst) ; return (expr', sig_inst) } -- See Note [Partial expression signatures] @@ -1561,7 +1667,7 @@ tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) = ApplyMR | otherwise = NoRestrictions - ; (qtvs, givens, ev_binds) + ; (qtvs, givens, ev_binds, _) <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted ; tau <- zonkTcType tau ; let inferred_theta = map evVarPred givens @@ -1622,27 +1728,31 @@ tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) 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 } + ; addFunResCtxt False (HsVar noExt (noLoc name)) actual_res_ty res_ty $ + tcWrapResultO (OccurrenceOf name) (HsVar noExt (noLoc name)) expr + actual_res_ty res_ty } -tcCheckRecSelId :: AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty +tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) +tcCheckRecSelId rn_expr 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 + ; addFunResCtxt False (HsRecFld noExt f) actual_res_ty res_ty $ + tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty } +tcCheckRecSelId rn_expr (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 } + ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) + res_ty } +tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = panic "tcCheckRecSelId" ------------------------ tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType) -tcInferRecSelId (Unambiguous (L _ lbl) sel) +tcInferRecSelId (Unambiguous sel (L _ lbl)) = do { (expr', ty) <- tc_infer_id lbl sel ; return (expr', ty) } -tcInferRecSelId (Ambiguous lbl _) +tcInferRecSelId (Ambiguous _ lbl) = ambiguousSelector lbl +tcInferRecSelId (XAmbiguousFieldOcc _) = panic "tcInferRecSelId" ------------------------ tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) @@ -1671,7 +1781,7 @@ 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) + ; return (mkHsWrap wrap (HsVar noExt (noLoc assert_error_id)), id_rho) } tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType) @@ -1697,12 +1807,12 @@ tc_infer_id lbl id_name _ -> failWithTc $ ppr thing <+> text "used where a value identifier was expected" } where - return_id id = return (HsVar (noLoc id), idType id) + return_id id = return (HsVar noExt (noLoc id), idType id) return_data_con con -- For data constructors, must perform the stupid-theta check | null stupid_theta - = return (HsConLikeOut (RealDataCon con), con_ty) + = return (HsConLikeOut noExt (RealDataCon con), con_ty) | otherwise -- See Note [Instantiating stupid theta] @@ -1713,7 +1823,8 @@ tc_infer_id lbl id_name rho' = substTy subst rho ; wrap <- instCall (OccurrenceOf id_name) tys' theta' ; addDataConStupidTheta con tys' - ; return (mkHsWrap wrap (HsConLikeOut (RealDataCon con)), rho') } + ; return ( mkHsWrap wrap (HsConLikeOut noExt (RealDataCon con)) + , rho') } where con_ty = dataConUserType con @@ -1724,7 +1835,7 @@ tc_infer_id lbl id_name | otherwise = return () -tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId) +tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId) -- Typecheck an occurrence of an unbound Id -- -- Some of these started life as a true expression hole "_". @@ -1733,7 +1844,7 @@ tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId) -- We turn all of them into HsVar, since HsUnboundVar can't contain an -- Id; and indeed the evidence for the CHoleCan does bind it, so it's -- not unbound any more! -tcUnboundId unbound res_ty +tcUnboundId rn_expr unbound res_ty = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (Trac #12531) ; let occ = unboundVarOcc unbound ; name <- newSysName occ @@ -1745,7 +1856,8 @@ tcUnboundId unbound res_ty , ctev_loc = loc} , cc_hole = ExprHole unbound } ; emitInsoluble can - ; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noLoc ev)) ty res_ty } + ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExt (noLoc ev)) + ty res_ty } {- @@ -1798,39 +1910,6 @@ the users that complain. -} -tcSeq :: SrcSpan -> Name -> [LHsExprArgIn] - -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) --- (seq e1 e2) :: res_ty --- We need a special typing rule because res_ty can be unboxed --- See Note [Typing rule for seq] -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 { arg2_kind <- newOpenTypeKind - ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 arg2_kind - -- see Note [Typing rule for seq] - ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt 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 -- by now, it's surely filled in - ; let fun' = L loc (mkHsWrap 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 GhcTcId, [LHsExprArgOut]) -- tagToEnum# :: forall a. Int# -> a @@ -1838,16 +1917,21 @@ tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType tcTagToEnum loc fun_name args res_ty = do { fun <- tcLookupId fun_name - ; arg <- case args of - [Right hs_ty_arg, Left term_arg] + ; let pars1 = mapMaybe isArgPar_maybe before + pars2 = mapMaybe isArgPar_maybe after + -- args contains exactly one HsValArg + (before, _:after) = break isHsValArg args + + ; arg <- case filterOut isArgPar args of + [HsTypeArg hs_ty_arg, HsValArg term_arg] -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty -- other than influencing res_ty, we just -- don't care about a type arg passed in. -- So drop the evidence. ; return term_arg } - [Left term_arg] -> do { _ <- expTypeToType res_ty - ; return term_arg } + [HsValArg term_arg] -> do { _ <- expTypeToType res_ty + ; return term_arg } _ -> too_many_args "tagToEnum#" args ; res_ty <- readExpType res_ty @@ -1869,10 +1953,15 @@ tcTagToEnum loc fun_name args res_ty (mk_error ty' doc2) ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy) - ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar (L loc fun))) + ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExt (L loc fun))) rep_ty = mkTyConApp rep_tc rep_args + out_args = concat + [ pars1 + , [HsValArg arg'] + , pars2 + ] - ; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) } + ; return (mkWpCastR (mkTcSymCo coi), fun', out_args) } -- coi is a Representational coercion where doc1 = vcat [ text "Specify the type by giving a type signature" @@ -1891,8 +1980,10 @@ too_many_args fun args hang (text "Too many type arguments to" <+> text fun <> colon) 2 (sep (map pp args)) where - pp (Left e) = ppr e - pp (Right (HsWC { hswc_body = L _ t })) = pprHsType t + pp (HsValArg e) = ppr e + pp (HsTypeArg (HsWC { hswc_body = L _ t })) = pprHsType t + pp (HsTypeArg (XHsWildCardBndrs _)) = panic "too_many_args" + pp (HsArgPar _) = empty {- @@ -1947,7 +2038,7 @@ checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var)) ; lift <- if isStringTy id_ty then do { sid <- tcLookupId THNames.liftStringName -- See Note [Lifting strings] - ; return (HsVar (noLoc sid)) } + ; return (HsVar noExt (noLoc sid)) } else setConstraintVar lie_var $ -- Put the 'lift' constraint into the right LIE @@ -2157,8 +2248,9 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Extract the selector name of a field update if it is unambiguous isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of - Unambiguous _ sel_name -> Just (x, sel_name) + Unambiguous sel_name _ -> Just (x, sel_name) Ambiguous{} -> Nothing + XAmbiguousFieldOcc{} -> Nothing -- Look up the possible parents and selector GREs for each field getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn @@ -2226,7 +2318,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty ; let L loc af = hsRecFieldLbl upd lbl = rdrNameAmbiguousFieldOcc af ; return $ L l upd { hsRecFieldLbl - = L loc (Unambiguous (L loc lbl) i) } } + = L loc (Unambiguous i (L loc lbl)) } } -- Extract the outermost TyCon of a type, if there is one; for @@ -2262,8 +2354,8 @@ lookupParents rdr -- the record expression in an update must be "obvious", i.e. the -- outermost constructor ignoring parentheses. obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) -obviousSig (ExprWithTySig _ ty) = Just ty -obviousSig (HsPar p) = obviousSig (unLoc p) +obviousSig (ExprWithTySig ty _) = Just ty +obviousSig (HsPar _ p) = obviousSig (unLoc p) obviousSig _ = Nothing @@ -2295,7 +2387,7 @@ 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 + fields = map flSelector $ conLikeFieldLabels con_like flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) @@ -2317,7 +2409,8 @@ tcRecordUpd 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 + fields = map flSelector $ conLikeFieldLabels con_like + flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) -> TcM (Maybe (LHsRecUpdField GhcTcId)) @@ -2325,22 +2418,23 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds , hsRecFieldArg = rhs })) = do { let lbl = rdrNameAmbiguousFieldOcc af sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (L loc lbl) (idName sel_id)) + f = L loc (FieldOcc (idName sel_id) (L 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 { hsRecFieldLbl - = L loc (Unambiguous (L loc lbl) - (selectorFieldOcc (unLoc f'))) + = L loc (Unambiguous + (extFieldOcc (unLoc f')) + (L loc lbl)) , hsRecFieldArg = rhs' }))) } -tcRecordField :: ConLike -> Assoc FieldLabelString Type +tcRecordField :: ConLike -> Assoc Name Type -> LFieldOcc GhcRn -> LHsExpr GhcRn -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) -tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs - | Just field_ty <- assocMaybe flds_w_tys field_lbl +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' <- tcPolyExprNC rhs field_ty ; let field_id = mkUserLocal (nameOccName sel_name) @@ -2350,12 +2444,13 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs -- (so we can find it easily) -- but is a LocalId with the appropriate type of the RHS -- (so the desugarer knows the type of local binder to make) - ; return (Just (L loc (FieldOcc lbl field_id), rhs')) } + ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } | otherwise = do { addErrTc (badFieldCon con_like field_lbl) ; return Nothing } where field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) +tcRecordField _ _ (L _ (XFieldOcc _)) _ = panic "tcRecordField" checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () @@ -2365,17 +2460,20 @@ checkMissingFields con_like rbinds = if any isBanged field_strs then -- Illegal if any arg is strict addErrTc (missingStrictFields con_like []) - else - return () + else do + warn <- woptM Opt_WarnMissingFields + when (warn && notNull field_strs && null field_labels) + (warnTc (Reason Opt_WarnMissingFields) True + (missingFields con_like [])) | otherwise = do -- A record 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)) + when (warn && notNull missing_ns_fields) + (warnTc (Reason Opt_WarnMissingFields) True + (missingFields con_like missing_ns_fields)) where missing_s_fields @@ -2636,10 +2734,14 @@ missingStrictFields con fields missingFields :: ConLike -> [FieldLabelString] -> SDoc missingFields con fields - = text "Fields of" <+> quotes (ppr con) <+> ptext (sLit "not initialised:") - <+> pprWithCommas ppr fields + = header <> rest + where + rest | null fields = Outputable.empty + | otherwise = colon <+> pprWithCommas ppr fields + header = text "Fields of" <+> quotes (ppr con) <+> + text "not initialised" --- callCtxt fun args = text "In the call" <+> parens (ppr (foldl mkHsApp fun args)) +-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args)) noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc noPossibleParents rbinds |