From: simonpj@microsoft.com Date: Wed, 21 Nov 2007 17:49:14 +0000 (+0000) Subject: Make rebindable do-notation behave as advertised X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=1d1c3c727617630beacacaf33022e1daba06a0bb Make rebindable do-notation behave as advertised Adopt Trac #1537. The patch ended up a bit bigger than I expected, so I suggest we do not merge this into the 6.8 branch. But there is no funadamental reason why not. With this patch, rebindable do-notation really does type as if you had written the original (>>) and (>>=) operations in desguared form. I ended up refactoring some of the (rather complicated) error-context stuff in TcUnify, by pushing an InstOrigin into tcSubExp and its various calls. That means we could get rid of tcFunResTy, and the SubCtxt type. This should improve error messages slightly in complicated situations, because we have an Origin to hand to instCall (in the (isSigmaTy actual_ty) case of tc_sub1). Thanks to Pepe for the first draft of the patch. --- diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index d0044d4..aab8f01 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -424,8 +424,9 @@ tcPrag poly_id (InlineSig v inl) = return (InlinePrag inl) tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag tcSpecPrag poly_id hs_ty inl - = do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty - ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty) + = do { let name = idName poly_id + ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty + ; (co_fn, lie) <- getLIE (tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty) ; extendLIEs lie ; let const_dicts = map instToId lie ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty const_dicts inl) } diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 27b4cf1..804fb47 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -153,19 +153,20 @@ tcExpr (HsOverLit lit) res_ty ; return (HsOverLit lit') } tcExpr (NegApp expr neg_expr) res_ty - = do { neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr + = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr (mkFunTy res_ty res_ty) ; expr' <- tcMonoExpr expr res_ty ; return (NegApp expr' neg_expr') } tcExpr (HsIPVar ip) res_ty - = do { -- Implicit parameters must have a *tau-type* not a + = do { let origin = IPOccOrigin ip + -- 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 -- be a tau-type.) - ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple - ; co_fn <- tcSubExp ip_ty res_ty - ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty + ; ip_ty <- newFlexiTyVarTy argTypeKind -- argTypeKind: it can't be an unboxed tuple + ; co_fn <- tcSubExp origin ip_ty res_ty + ; (ip', inst) <- newIPDict origin ip ip_ty ; extendLIE inst ; return (mkHsWrap co_fn (HsIPVar ip')) } @@ -192,7 +193,7 @@ tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ tcPolyExprNC expr res_ty) - ; co_fn <- tcSubExp sig_tc_ty res_ty + ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) } tcExpr (HsType ty) res_ty @@ -318,7 +319,7 @@ tcExpr (ExplicitTuple exprs boxity) res_ty ; arg_tys <- preSubType tvs (mkVarSet tvs) tup_res_ty res_ty ; exprs' <- tcPolyExprs exprs arg_tys ; arg_tys' <- mapM refineBox arg_tys - ; co_fn <- tcFunResTy (tyConName tup_tc) (mkTyConApp tup_tc arg_tys') res_ty + ; co_fn <- tcSubExp TupleOrigin (mkTyConApp tup_tc arg_tys') res_ty ; return (mkHsWrap co_fn (ExplicitTuple exprs' boxity)) } tcExpr (HsProc pat cmd) res_ty @@ -469,8 +470,9 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty let result_ty = substTy result_inst_env con1_res_ty con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys + origin = RecordUpdOrigin in - tcSubExp result_ty res_ty `thenM` \ co_fn -> + tcSubExp origin result_ty res_ty `thenM` \ co_fn -> tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' -> -- STEP 5: Typecheck the expression to be updated @@ -490,7 +492,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty let theta' = substTheta scrut_inst_env (dataConStupidTheta con1) in - instStupidTheta RecordUpdOrigin theta' `thenM_` + instStupidTheta origin theta' `thenM_` -- Step 7: make a cast for the scrutinee, in the case that it's from a type family let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon @@ -679,7 +681,7 @@ tcIdApp fun_name n_args arg_checker res_ty ; let res_subst = zipOpenTvSubst qtvs qtys'' fun_res_ty'' = substTy res_subst fun_res_ty res_ty'' = mkFunTys extra_arg_tys'' res_ty - ; co_fn <- tcFunResTy fun_name fun_res_ty'' res_ty'' + ; co_fn <- tcSubExp orig fun_res_ty'' res_ty'' -- And pack up the results -- By applying the coercion just to the *function* we can make @@ -726,7 +728,7 @@ tcId orig fun_name res_ty ; let res_subst = zipTopTvSubst qtvs qtv_tys fun_tau' = substTy res_subst fun_tau - ; co_fn <- tcFunResTy fun_name fun_tau' res_ty + ; co_fn <- tcSubExp orig fun_tau' res_ty -- And pack up the results ; fun' <- instFun orig fun res_subst tv_theta_prs diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index d11cb97..da1d0e0 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -238,12 +238,10 @@ tcDoStmts PArrComp stmts body res_ty (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) } tcDoStmts DoExpr stmts body res_ty - = do { ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty - ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty - ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts - (emptyRefinement, res_ty') $ + = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts + (emptyRefinement, res_ty) $ tcBody body - ; return $ mkHsWrapCoI coi (HsDo DoExpr stmts' body' res_ty') } + ; return (HsDo DoExpr stmts' body' res_ty) } tcDoStmts ctxt@(MDoExpr _) stmts body res_ty = do { ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty @@ -400,12 +398,10 @@ tcLcStmt m_tc ctxt stmt elt_ty thing_inside -- Do-notation -- The main excitement here is dealing with rebindable syntax -tcDoStmt :: TcType -- Monad type, m - -> TcStmtChecker +tcDoStmt :: TcStmtChecker -tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_inside - = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ pat_ty -> - tcMonoExpr rhs (mkAppTy m_ty pat_ty) +tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_inside + = do { (rhs', rhs_ty) <- tcInferRho rhs -- We should use type *inference* for the RHS computations, becuase of GADTs. -- do { pat <- rhs; } -- is rather like @@ -413,31 +409,34 @@ tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thi -- We do inference on rhs, so that information about its type can be refined -- when type-checking the pattern. - ; (pat', thing) <- tcLamPat pat pat_ty reft_res_ty thing_inside + -- Deal with rebindable syntax; (>>=) :: rhs_ty -> (a -> res_ty) -> res_ty + ; (bind_op', pat_ty) <- + withBox liftedTypeKind $ \ pat_ty -> + tcSyntaxOp DoOrigin bind_op + (mkFunTys [rhs_ty, mkFunTy pat_ty res_ty] res_ty) - -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b - ; let bind_ty = mkFunTys [mkAppTy m_ty pat_ty, - mkFunTy pat_ty res_ty] res_ty - ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty -- If (but only if) the pattern can fail, -- typecheck the 'fail' operator - ; fail_op' <- if isIrrefutableHsPat pat' + ; fail_op' <- if isIrrefutableHsPat pat then return noSyntaxExpr else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty) + + ; (pat', thing) <- tcLamPat pat pat_ty reft_res_ty thing_inside + ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } -tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) reft_res_ty@(_,res_ty) thing_inside - = do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b - a_ty <- newFlexiTyVarTy liftedTypeKind - ; let rhs_ty = mkAppTy m_ty a_ty - then_ty = mkFunTys [rhs_ty, res_ty] res_ty - ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty - ; rhs' <- tcPolyExpr rhs rhs_ty +tcDoStmt ctxt (ExprStmt rhs then_op _) reft_res_ty@(_,res_ty) thing_inside + = do { (rhs', rhs_ty) <- tcInferRho rhs + + -- Deal with rebindable syntax; (>>) :: rhs_ty -> res_ty -> res_ty + ; then_op' <- tcSyntaxOp DoOrigin then_op + (mkFunTys [rhs_ty, res_ty] res_ty) + ; thing <- thing_inside reft_res_ty ; return (ExprStmt rhs' then_op' rhs_ty, thing) } -tcDoStmt m_ty ctxt stmt res_ty thing_inside +tcDoStmt ctxt stmt res_ty thing_inside = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) -------------------------------- @@ -484,7 +483,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_insid = do { poly_id <- tcLookupId rec_name -- poly_id may have a polymorphic type -- but mono_ty is just a monomorphic type variable - ; co_fn <- tcSubExp (idType poly_id) mono_ty + ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty ; return (mkHsWrap co_fn (HsVar poly_id)) } tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index f220154..9c845b6 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -421,7 +421,9 @@ tc_pat pstate (orig@(ViewPat expr pat _)) overall_pat_ty thing_inside -- (view -> f) where view :: _ -> forall b. b -- we will only be able to use view at one instantation in the -- rest of the view - ; (expr_coerc, pat_ty) <- tcInfer (\ pat_ty -> tcSubExp (expr'_expected pat_ty) expr'_inferred) + ; (expr_coerc, pat_ty) <- tcInfer $ \ pat_ty -> + tcSubExp ViewPatOrigin (expr'_expected pat_ty) expr'_inferred + -- pattern must have pat_ty ; (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside -- this should get zonked later on, but we unBox it here diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index efe58a1..a646125 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1056,10 +1056,9 @@ tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; ret_id <- tcLookupId returnIOName ; -- return @ IO let { - io_ty = mkTyConApp ioTyCon [] ; ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts + tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts (emptyRefinement, io_ret_ty) ; names = map unLoc (collectLStmtsBinders stmts) ; diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index eb1cd04..0012325 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -864,18 +864,23 @@ data InstOrigin -- The rest are all occurrences: Insts that are 'wanted' ------------------------------------------------------- | OccurrenceOf Name -- Occurrence of an overloaded identifier + | SpecPragOrigin Name -- Specialisation pragma for identifier | IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter | LiteralOrigin (HsOverLit Name) -- Occurrence of a literal + | NegateOrigin -- Occurrence of syntactic negation | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc | PArrSeqOrigin (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:] + | TupleOrigin -- (..,..) | InstSigOrigin -- A dict occurrence arising from instantiating -- a polymorphic type during a subsumption check + | ExprSigOrigin -- e :: ty | RecordUpdOrigin + | ViewPatOrigin | InstScOrigin -- Typechecking superclasses of an instance declaration | DerivOrigin -- Typechecking deriving | StandAloneDerivOrigin -- Typechecking stand-alone deriving @@ -887,13 +892,17 @@ data InstOrigin instance Outputable InstOrigin where ppr (OccurrenceOf name) = hsep [ptext SLIT("a use of"), quotes (ppr name)] + ppr (SpecPragOrigin name) = hsep [ptext SLIT("a specialisation pragma for"), quotes (ppr name)] ppr (IPOccOrigin name) = hsep [ptext SLIT("a use of implicit parameter"), quotes (ppr name)] ppr (IPBindOrigin name) = hsep [ptext SLIT("a binding for implicit parameter"), quotes (ppr name)] ppr RecordUpdOrigin = ptext SLIT("a record update") + ppr ExprSigOrigin = ptext SLIT("an expression type signature") + ppr ViewPatOrigin = ptext SLIT("a view pattern") ppr (LiteralOrigin lit) = hsep [ptext SLIT("the literal"), quotes (ppr lit)] ppr (ArithSeqOrigin seq) = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)] ppr (PArrSeqOrigin seq) = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)] - ppr InstSigOrigin = ptext SLIT("instantiating a type signature") + ppr TupleOrigin = ptext SLIT("a tuple") + ppr NegateOrigin = ptext SLIT("a use of syntactic negation") ppr InstScOrigin = ptext SLIT("the superclasses of an instance declaration") ppr DerivOrigin = ptext SLIT("the 'deriving' clause of a data type declaration") ppr StandAloneDerivOrigin = ptext SLIT("a 'deriving' declaration") @@ -903,5 +912,4 @@ instance Outputable InstOrigin where ppr (ImplicOrigin doc) = doc ppr (SigOrigin info) = pprSkolInfo info ppr EqOrigin = ptext SLIT("a type equality") - \end{code} diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 04e9379..bd25c51 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -15,7 +15,7 @@ Type subsumption and unification module TcUnify ( -- Full-blown subsumption - tcSubExp, tcFunResTy, tcGen, + tcSubExp, tcGen, checkSigTyVars, checkSigTyVarsWrt, bleatEscapedTvs, sigCtxt, -- Various unifications @@ -70,11 +70,7 @@ import Unique \begin{code} tcInfer :: (BoxyType -> TcM a) -> TcM (a, TcType) -tcInfer tc_infer - = do { box <- newBoxyTyVar openTypeKind - ; res <- tc_infer (mkTyVarTy box) - ; res_ty <- {- pprTrace "tcInfer" (ppr (mkTyVarTy box)) $ -} readFilledBox box -- Guaranteed filled-in by now - ; return (res, res_ty) } +tcInfer tc_infer = withBox openTypeKind tc_infer \end{code} @@ -417,7 +413,7 @@ withMetaTvs tv kinds mk_res_ty withBox :: Kind -> (BoxySigmaType -> TcM a) -> TcM (a, TcType) -- Allocate a *boxy* tyvar withBox kind thing_inside - = do { box_tv <- newMetaTyVar BoxTv kind + = do { box_tv <- newBoxyTyVar kind ; res <- thing_inside (mkTyVarTy box_tv) ; ty <- {- pprTrace "with_box" (ppr (mkTyVarTy box_tv)) $ -} readFilledBox box_tv ; return (res, ty) } @@ -675,24 +671,24 @@ Later stuff will fail. All the tcSub calls have the form - tcSub expected_ty offered_ty + tcSub actual_ty expected_ty which checks - offered_ty <= expected_ty + actual_ty <= expected_ty -That is, that a value of type offered_ty is acceptable in +That is, that a value of type actual_ty is acceptable in a place expecting a value of type expected_ty. It returns a coercion function - co_fn :: offered_ty ~ expected_ty -which takes an HsExpr of type offered_ty into one of type + co_fn :: actual_ty ~ expected_ty +which takes an HsExpr of type actual_ty into one of type expected_ty. \begin{code} ----------------- -tcSubExp :: BoxySigmaType -> BoxySigmaType -> TcM HsWrapper -- Locally used only +tcSubExp :: InstOrigin -> BoxySigmaType -> BoxySigmaType -> TcM HsWrapper -- (tcSub act exp) checks that -- act <= exp -tcSubExp actual_ty expected_ty +tcSubExp orig actual_ty expected_ty = -- addErrCtxtM (unifyCtxt actual_ty expected_ty) $ -- Adding the error context here leads to some very confusing error -- messages, such as "can't match forall a. a->a with forall a. a->a" @@ -705,19 +701,10 @@ tcSubExp actual_ty expected_ty -- So instead I'm adding the error context when moving from tc_sub to u_tys traceTc (text "tcSubExp" <+> ppr actual_ty <+> ppr expected_ty) >> - tc_sub SubOther actual_ty actual_ty False expected_ty expected_ty + tc_sub orig actual_ty actual_ty False expected_ty expected_ty -tcFunResTy :: Name -> BoxySigmaType -> BoxySigmaType -> TcM HsWrapper -- Locally used only -tcFunResTy fun actual_ty expected_ty - = traceTc (text "tcFunResTy" <+> ppr actual_ty <+> ppr expected_ty) >> - tc_sub (SubFun fun) actual_ty actual_ty False expected_ty expected_ty - ----------------- -data SubCtxt = SubDone -- Error-context already pushed - | SubFun Name -- Context is tcFunResTy - | SubOther -- Context is something else - -tc_sub :: SubCtxt -- How to add an error-context +tc_sub :: InstOrigin -> BoxySigmaType -- actual_ty, before expanding synonyms -> BoxySigmaType -- ..and after -> InBox -- True <=> expected_ty is inside a box @@ -731,24 +718,24 @@ tc_sub :: SubCtxt -- How to add an error-context -- This invariant is needed so that we can "see" the foralls, ad -- e.g. in the SPEC rule where we just use splitSigmaTy -tc_sub sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty +tc_sub orig act_sty act_ty exp_ib exp_sty exp_ty = traceTc (text "tc_sub" <+> ppr act_ty $$ ppr exp_ty) >> - tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty + tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty -- This indirection is just here to make -- it easy to insert a debug trace! -tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty - | Just exp_ty' <- tcView exp_ty = tc_sub sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty' -tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty - | Just act_ty' <- tcView act_ty = tc_sub sub_ctxt act_sty act_ty' exp_ib exp_sty exp_ty +tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty + | Just exp_ty' <- tcView exp_ty = tc_sub orig act_sty act_ty exp_ib exp_sty exp_ty' +tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty + | Just act_ty' <- tcView act_ty = tc_sub orig act_sty act_ty' exp_ib exp_sty exp_ty ----------------------------------- -- Rule SBOXY, plus other cases when act_ty is a type variable -- Just defer to boxy matching -- This rule takes precedence over SKOL! -tc_sub1 sub_ctxt act_sty (TyVarTy tv) exp_ib exp_sty exp_ty +tc_sub1 orig act_sty (TyVarTy tv) exp_ib exp_sty exp_ty = do { traceTc (text "tc_sub1 - case 1") - ; coi <- addSubCtxt sub_ctxt act_sty exp_sty $ + ; coi <- addSubCtxt orig act_sty exp_sty $ uVar True False tv exp_ib exp_sty exp_ty ; traceTc (case coi of IdCo -> text "tc_sub1 (Rule SBOXY) IdCo" @@ -767,14 +754,14 @@ tc_sub1 sub_ctxt act_sty (TyVarTy tv) exp_ib exp_sty exp_ty -- g :: Ord b => b->b -- Consider f g ! -tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty +tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty | isSigmaTy exp_ty = do { traceTc (text "tc_sub1 - case 2") ; if exp_ib then -- SKOL does not apply if exp_ty is inside a box - defer_to_boxy_matching sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty + defer_to_boxy_matching orig act_sty act_ty exp_ib exp_sty exp_ty else do { (gen_fn, co_fn) <- tcGen exp_ty act_tvs $ \ _ body_exp_ty -> - tc_sub sub_ctxt act_sty act_ty False body_exp_ty body_exp_ty + tc_sub orig act_sty act_ty False body_exp_ty body_exp_ty ; return (gen_fn <.> co_fn) } } where @@ -788,7 +775,7 @@ tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty -- expected_ty: Int -> Int -- co_fn e = e Int dOrdInt -tc_sub1 sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty +tc_sub1 orig act_sty actual_ty exp_ib exp_sty expected_ty -- Implements the new SPEC rule in the Appendix of the paper -- "Boxy types: inference for higher rank types and impredicativity" -- (This appendix isn't in the published version.) @@ -815,73 +802,60 @@ tc_sub1 sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty ; traceTc (text "tc_sub_spec" <+> vcat [ppr actual_ty, ppr tyvars <+> ppr theta <+> ppr tau, ppr tau']) - ; co_fn2 <- tc_sub sub_ctxt tau' tau' exp_ib exp_sty expected_ty + ; co_fn2 <- tc_sub orig tau' tau' exp_ib exp_sty expected_ty -- Deal with the dictionaries - -- The origin gives a helpful origin when we have - -- a function with type f :: Int -> forall a. Num a => ... - -- This way the (Num a) dictionary gets an OccurrenceOf f origin - ; let orig = case sub_ctxt of - SubFun n -> OccurrenceOf n - other -> InstSigOrigin -- Unhelpful ; co_fn1 <- instCall orig inst_tys (substTheta subst' theta) ; return (co_fn2 <.> co_fn1) } ----------------------------------- -- Function case (rule F1) -tc_sub1 sub_ctxt act_sty (FunTy act_arg act_res) exp_ib exp_sty (FunTy exp_arg exp_res) +tc_sub1 orig act_sty (FunTy act_arg act_res) exp_ib exp_sty (FunTy exp_arg exp_res) = do { traceTc (text "tc_sub1 - case 4") - ; addSubCtxt sub_ctxt act_sty exp_sty $ - tc_sub_funs act_arg act_res exp_ib exp_arg exp_res + ; tc_sub_funs orig act_arg act_res exp_ib exp_arg exp_res } -- Function case (rule F2) -tc_sub1 sub_ctxt act_sty act_ty@(FunTy act_arg act_res) _ exp_sty (TyVarTy exp_tv) +tc_sub1 orig act_sty act_ty@(FunTy act_arg act_res) _ exp_sty (TyVarTy exp_tv) | isBoxyTyVar exp_tv - = addSubCtxt sub_ctxt act_sty exp_sty $ - do { traceTc (text "tc_sub1 - case 5") + = do { traceTc (text "tc_sub1 - case 5") ; cts <- readMetaTyVar exp_tv ; case cts of - Indirect ty -> tc_sub SubDone act_sty act_ty True exp_sty ty + Indirect ty -> tc_sub orig act_sty act_ty True exp_sty ty Flexi -> do { [arg_ty,res_ty] <- withMetaTvs exp_tv fun_kinds mk_res_ty - ; tc_sub_funs act_arg act_res True arg_ty res_ty } } + ; tc_sub_funs orig act_arg act_res True arg_ty res_ty } } where mk_res_ty [arg_ty', res_ty'] = mkFunTy arg_ty' res_ty' mk_res_ty other = panic "TcUnify.mk_res_ty3" fun_kinds = [argTypeKind, openTypeKind] -- Everything else: defer to boxy matching -tc_sub1 sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty@(TyVarTy exp_tv) +tc_sub1 orig act_sty actual_ty exp_ib exp_sty expected_ty@(TyVarTy exp_tv) = do { traceTc (text "tc_sub1 - case 6a" <+> ppr [isBoxyTyVar exp_tv, isMetaTyVar exp_tv, isSkolemTyVar exp_tv, isExistentialTyVar exp_tv,isSigTyVar exp_tv] ) - ; defer_to_boxy_matching sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty + ; defer_to_boxy_matching orig act_sty actual_ty exp_ib exp_sty expected_ty } -tc_sub1 sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty +tc_sub1 orig act_sty actual_ty exp_ib exp_sty expected_ty = do { traceTc (text "tc_sub1 - case 6") - ; defer_to_boxy_matching sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty + ; defer_to_boxy_matching orig act_sty actual_ty exp_ib exp_sty expected_ty } ----------------------------------- -defer_to_boxy_matching sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty - = do { coi <- addSubCtxt sub_ctxt act_sty exp_sty $ - u_tys outer False act_sty actual_ty exp_ib exp_sty expected_ty - ; return $ coiToHsWrapper coi - } - where - outer = case sub_ctxt of -- Ugh - SubDone -> False - other -> True +defer_to_boxy_matching orig act_sty actual_ty exp_ib exp_sty expected_ty + = do { coi <- addSubCtxt orig act_sty exp_sty $ + u_tys True False act_sty actual_ty exp_ib exp_sty expected_ty + ; return $ coiToHsWrapper coi } ----------------------------------- -tc_sub_funs act_arg act_res exp_ib exp_arg exp_res - = do { arg_coi <- uTys False act_arg exp_ib exp_arg - ; co_fn_res <- tc_sub SubDone act_res act_res exp_ib exp_res exp_res +tc_sub_funs orig act_arg act_res exp_ib exp_arg exp_res + = do { arg_coi <- addSubCtxt orig act_arg exp_arg $ + uTysOuter False act_arg exp_ib exp_arg + ; co_fn_res <- tc_sub orig act_res act_res exp_ib exp_res exp_res ; wrapper1 <- wrapFunResCoercion [exp_arg] co_fn_res ; let wrapper2 = case arg_coi of IdCo -> idHsWrapper ACo co -> WpCo $ FunTy co act_res - ; return (wrapper1 <.> wrapper2) - } + ; return (wrapper1 <.> wrapper2) } ----------------------------------- wrapFunResCoercion @@ -1714,9 +1688,7 @@ mkExpectedActualMsg act_ty exp_ty ---------------- -- If an error happens we try to figure out whether the function -- function has been given too many or too few arguments, and say so. -addSubCtxt SubDone actual_res_ty expected_res_ty thing_inside - = thing_inside -addSubCtxt sub_ctxt actual_res_ty expected_res_ty thing_inside +addSubCtxt orig actual_res_ty expected_res_ty thing_inside = addErrCtxtM mk_err thing_inside where mk_err tidy_env @@ -1730,10 +1702,11 @@ addSubCtxt sub_ctxt actual_res_ty expected_res_ty thing_inside len_act_args = length act_args len_exp_args = length exp_args - message = case sub_ctxt of - SubFun fun | len_exp_args < len_act_args -> wrongArgsCtxt "too few" fun - | len_exp_args > len_act_args -> wrongArgsCtxt "too many" fun - other -> mkExpectedActualMsg act_ty'' exp_ty'' + message = case orig of + OccurrenceOf fun + | len_exp_args < len_act_args -> wrongArgsCtxt "too few" fun + | len_exp_args > len_act_args -> wrongArgsCtxt "too many" fun + other -> mkExpectedActualMsg act_ty'' exp_ty'' ; return (env2, message) } wrongArgsCtxt too_many_or_few fun