From cb2d19815fed0daa19c56e4d12746756fe8966ac Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 4 May 2001 14:43:26 +0000 Subject: [PATCH] [project @ 2001-05-04 14:43:26 by simonpj] **** MERGE WITH 5.00 BRANCH ******** -------------------------------- Fix a black hole when type checking type decls -------------------------------- GHC was falling into a black hole when type checking a recursive group of type declarations including a chain of type synonyms. type PhraseFun = PMap -> Float type PMap = () -> Player data Player = P.MkT P.PhraseFun Reason: too much consistency checking in TcMonoType. Easily fixed using the existing wimp_out hack, but it's a mess. This commit fixes it for the 5.00 branch but I'll do something better in the head shortly. --- ghc/compiler/typecheck/TcMonoType.lhs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 9308390..0864781 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -371,7 +371,10 @@ tc_type wimp_out (HsFunTy ty1 ty2) = tc_type wimp_out ty1 `thenTc` \ tau_ty1 -> -- Function argument can be polymorphic, but -- must not be an unboxed tuple - checkTc (not (isUnboxedTupleType tau_ty1)) + -- + -- In a recursive loop we can't ask whether the thing is + -- unboxed -- might be a synonym inside a synonym inside a group + checkTc (isRec wimp_out || not (isUnboxedTupleType tau_ty1)) (ubxArgTyErr ty1) `thenTc_` tc_type wimp_out ty2 `thenTc` \ tau_ty2 -> returnTc (mkFunTy tau_ty1 tau_ty2) @@ -433,9 +436,9 @@ tc_arg_type wimp_out arg_ty = tc_type wimp_out arg_ty | otherwise - = tc_type wimp_out arg_ty `thenTc` \ arg_ty' -> - checkTc (not (isForAllTy arg_ty')) (polyArgTyErr arg_ty) `thenTc_` - checkTc (not (isUnboxedTupleType arg_ty')) (ubxArgTyErr arg_ty) `thenTc_` + = tc_type wimp_out arg_ty `thenTc` \ arg_ty' -> + checkTc (isRec wimp_out || not (isForAllTy arg_ty')) (polyArgTyErr arg_ty) `thenTc_` + checkTc (isRec wimp_out || not (isUnboxedTupleType arg_ty')) (ubxArgTyErr arg_ty) `thenTc_` returnTc arg_ty' tc_arg_types wimp_out arg_tys = mapTc (tc_arg_type wimp_out) arg_tys -- 1.7.10.4