Back out changes to TcMonoType that didn't work right.
These changes are now done correctly on the before-ghci-branch,
and so will get merged in later.
mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe,
tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars,
tyVarsOfType, tyVarsOfPred, mkForAllTys,
mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe,
tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars,
tyVarsOfType, tyVarsOfPred, mkForAllTys,
- classesOfPreds, isUnboxedTupleType, isForAllTy
+ classesOfPreds, isUnboxedTupleType
)
import PprType ( pprType, pprPred )
import Subst ( mkTopTyVarSubst, substTy )
)
import PprType ( pprType, pprPred )
import Subst ( mkTopTyVarSubst, substTy )
= tc_app ty []
tcHsType (HsListTy ty)
= tc_app ty []
tcHsType (HsListTy ty)
- = tcHsArgType ty `thenTc` \ tau_ty ->
+ = tcHsType ty `thenTc` \ tau_ty ->
returnTc (mkListTy tau_ty)
returnTc (mkListTy tau_ty)
-tcHsType (HsTupleTy (HsTupCon _ Boxed) tys)
- = mapTc tcHsArgType tys `thenTc` \ tau_tys ->
- returnTc (mkTupleTy Boxed (length tys) tau_tys)
-
-tcHsType (HsTupleTy (HsTupCon _ Unboxed) tys)
- = -- Unboxed tuples can have polymorphic args.
- -- This happens in the workers for functions returning
- -- product types with polymorphic components
- mapTc tcHsType tys `thenTc` \ tau_tys ->
- returnTc (mkTupleTy Unboxed (length tys) tau_tys)
+tcHsType (HsTupleTy (HsTupCon _ boxity) tys)
+ = mapTc tcHsType tys `thenTc` \ tau_tys ->
+ returnTc (mkTupleTy boxity (length tys) tau_tys)
tcHsType (HsFunTy ty1 ty2)
= tcHsType ty1 `thenTc` \ tau_ty1 ->
tcHsType (HsFunTy ty1 ty2)
= tcHsType ty1 `thenTc` \ tau_ty1 ->
= ASSERT(n== 1)
returnTc (mkTyConApp genUnitTyCon [])
= ASSERT(n== 1)
returnTc (mkTyConApp genUnitTyCon [])
-tcHsType (HsOpTy ty1 op ty2)
- = tcHsArgType ty1 `thenTc` \ tau_ty1 ->
- tcHsArgType ty2 `thenTc` \ tau_ty2 ->
- tc_fun_type op [tau_ty1,tau_ty2]
+tcHsType (HsOpTy ty1 op ty2) =
+ tcHsType ty1 `thenTc` \ tau_ty1 ->
+ tcHsType ty2 `thenTc` \ tau_ty2 ->
+ tc_fun_type op [tau_ty1,tau_ty2]
tcHsType (HsAppTy ty1 ty2)
= tc_app ty1 [ty2]
tcHsType (HsAppTy ty1 ty2)
= tc_app ty1 [ty2]
tc_app ty tys
= tcAddErrCtxt (appKindCtxt pp_app) $
tc_app ty tys
= tcAddErrCtxt (appKindCtxt pp_app) $
- mapTc tcHsArgType tys `thenTc` \ arg_tys ->
+ mapTc tcHsType tys `thenTc` \ arg_tys ->
case ty of
HsTyVar fun -> tc_fun_type fun arg_tys
other -> tcHsType ty `thenTc` \ fun_ty ->
case ty of
HsTyVar fun -> tc_fun_type fun arg_tys
other -> tcHsType ty `thenTc` \ fun_ty ->
where
pp_app = ppr ty <+> sep (map pprParendHsType tys)
where
pp_app = ppr ty <+> sep (map pprParendHsType tys)
-tcHsArgType arg_ty -- Check that the argument of a type appplication
- -- isn't a for-all type
- = tcHsType arg_ty `thenTc` \ arg_ty' ->
- checkTc (not (isForAllTy arg_ty'))
- (argTyErr arg_ty) `thenTc_`
- returnTc arg_ty'
-
-- (tc_fun_type ty arg_tys) returns (mkAppTys ty arg_tys)
-- But not quite; for synonyms it checks the correct arity, and builds a SynTy
-- hence the rather strange functionality.
-- (tc_fun_type ty arg_tys) returns (mkAppTys ty arg_tys)
-- But not quite; for synonyms it checks the correct arity, and builds a SynTy
-- hence the rather strange functionality.
tcClassAssertion ccall_ok assn@(HsPClass class_name tys)
= tcAddErrCtxt (appKindCtxt (ppr assn)) $
tcClassAssertion ccall_ok assn@(HsPClass class_name tys)
= tcAddErrCtxt (appKindCtxt (ppr assn)) $
- mapTc tcHsArgType tys `thenTc` \ arg_tys ->
+ mapTc tcHsType tys `thenTc` \ arg_tys ->
tcLookupTy class_name `thenTc` \ thing ->
case thing of
AClass clas -> checkTc (arity == n_tys) err `thenTc_`
tcLookupTy class_name `thenTc` \ thing ->
case thing of
AClass clas -> checkTc (arity == n_tys) err `thenTc_`
unboxedTupleErr ty
= sep [ptext (SLIT("Illegal unboxed tuple as a function or contructor argument:")), nest 4 (ppr ty)]
unboxedTupleErr ty
= sep [ptext (SLIT("Illegal unboxed tuple as a function or contructor argument:")), nest 4 (ppr ty)]
-
-argTyErr ty = ptext SLIT("Illegal polymorphic type as argument:") <+> ppr ty
mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
- applyTy, applyTys, hoistForAllTys, isForAllTy,
+ applyTy, applyTys, hoistForAllTys,
TauType, RhoType, SigmaType, PredType(..), ThetaType,
ClassPred, ClassContext, mkClassPred,
TauType, RhoType, SigmaType, PredType(..), ThetaType,
ClassPred, ClassContext, mkClassPred,
(foldr ForAllTy ty' tyvars)
Nothing -> foldr ForAllTy ty tyvars
(foldr ForAllTy ty' tyvars)
Nothing -> foldr ForAllTy ty tyvars
-isForAllTy :: Type -> Bool
-isForAllTy (NoteTy _ ty) = isForAllTy ty
-isForAllTy (ForAllTy _ _) = True
-isForAllTy other_ty = False
-
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty'
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty'