Commit 2b09da89 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-08-14 15:37:55 by simonpj]

Wibbles to the checking-types commit
parent 8731605f
...@@ -546,6 +546,7 @@ data UserTypeCtxt ...@@ -546,6 +546,7 @@ data UserTypeCtxt
| ResSigCtxt -- Result type sig | ResSigCtxt -- Result type sig
-- f x :: t = .... -- f x :: t = ....
| ForSigCtxt Name -- Foreign inport or export signature | ForSigCtxt Name -- Foreign inport or export signature
| RuleSigCtxt Name -- Signature on a forall'd variable in a RULE
pprUserTypeCtxt (FunSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n) pprUserTypeCtxt (FunSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n)
pprUserTypeCtxt ExprSigCtxt = ptext SLIT("an expression type signature") pprUserTypeCtxt ExprSigCtxt = ptext SLIT("an expression type signature")
...@@ -555,6 +556,7 @@ pprUserTypeCtxt GenPatCtxt = ptext SLIT("the type pattern of a generic defin ...@@ -555,6 +556,7 @@ pprUserTypeCtxt GenPatCtxt = ptext SLIT("the type pattern of a generic defin
pprUserTypeCtxt PatSigCtxt = ptext SLIT("a pattern type signature") pprUserTypeCtxt PatSigCtxt = ptext SLIT("a pattern type signature")
pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature") pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature")
pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign signature for") <+> quotes (ppr n) pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign signature for") <+> quotes (ppr n)
pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature on") <+> quotes (ppr n)
\end{code} \end{code}
\begin{code} \begin{code}
...@@ -575,6 +577,7 @@ checkValidType ctxt ty ...@@ -575,6 +577,7 @@ checkValidType ctxt ty
TySynCtxt _ | gla_exts -> 1 TySynCtxt _ | gla_exts -> 1
| otherwise -> 0 | otherwise -> 0
ForSigCtxt _ -> 1 ForSigCtxt _ -> 1
RuleSigCtxt _ -> 1
actual_kind = typeKind ty actual_kind = typeKind ty
...@@ -666,9 +669,18 @@ check_tau_type rank ubx_tup_ok (NoteTy note ty) ...@@ -666,9 +669,18 @@ check_tau_type rank ubx_tup_ok (NoteTy note ty)
= check_note note `thenTc_` check_tau_type rank ubx_tup_ok ty = check_note note `thenTc_` check_tau_type rank ubx_tup_ok ty
check_tau_type rank ubx_tup_ok ty@(TyConApp tc tys) check_tau_type rank ubx_tup_ok ty@(TyConApp tc tys)
= mapTc_ check_arg_type tys `thenTc_` | isSynTyCon tc
checkTc (not (isSynTyCon tc) || syn_arity_ok) arity_msg `thenTc_` = checkTc syn_arity_ok arity_msg `thenTc_`
checkTc (not (isUnboxedTupleTyCon tc) || ubx_tup_ok) ubx_tup_msg mapTc_ check_arg_type tys
| isUnboxedTupleTyCon tc
= checkTc ubx_tup_ok ubx_tup_msg `thenTc_`
mapTc_ (check_tau_type 0 True) tys -- Args are allowed to be unlifted, or
-- more unboxed tuples, so can't use check_arg_ty
| otherwise
= mapTc_ check_arg_type tys
where where
syn_arity_ok = tc_arity <= n_args syn_arity_ok = tc_arity <= n_args
-- It's OK to have an *over-applied* type synonym -- It's OK to have an *over-applied* type synonym
......
...@@ -135,7 +135,7 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc) ...@@ -135,7 +135,7 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty -> new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty ->
returnNF_Tc (mkLocalId var ty) returnNF_Tc (mkLocalId var ty)
new_id (RuleBndrSig var rn_ty) = tcHsSigType PatSigCtxt rn_ty `thenTc` \ ty -> new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt var) rn_ty `thenTc` \ ty ->
returnNF_Tc (mkLocalId var ty) returnNF_Tc (mkLocalId var ty)
ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
......
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