Commit 1d1c3c72 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent 9226af9e
......@@ -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) }
......
......@@ -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
......
......@@ -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; <rest> }
-- 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
......
......@@ -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
......
......@@ -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) ;
......
......@@ -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}
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment