From 72126bb92591460a0b98ee201510cb9f40751460 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 23 Aug 2001 16:27:11 +0000
Subject: [PATCH] [project @ 2001-08-23 16:27:11 by simonpj] Fix
 representation finding for recursive newtypes

---
 ghc/compiler/typecheck/TcTyClsDecls.lhs |   35 +++++++++++++++++++++++++++----
 1 file changed, 31 insertions(+), 4 deletions(-)

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index d26184d..7997de5 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -31,12 +31,15 @@ import TcInstDcls	( tcAddDeclCtxt )
 import TcMonoType	( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
 import TcMType		( unifyKind, newKindVar, zonkKindEnv )
 import TcType		( Type, Kind, mkArrowKind, liftedTypeKind, zipFunTys )
+import Type		( splitTyConApp_maybe )
 import Variance         ( calcTyConArgVrcs )
 import Class		( Class, mkClass, classTyCon )
 import TyCon		( TyCon, ArgVrcs, AlgTyConFlavour(..), 
-			  tyConKind, tyConDataCons,
+			  tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
 			  mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon, 
 			)
+import TysWiredIn	( unitTy )
+import Subst		( substTyWith )
 import DataCon		( dataConOrigArgTys )
 import Var		( varName )
 import FiniteMap
@@ -398,12 +401,36 @@ bogusVrcs = panic "Bogus tycon arg variances"
 \begin{code}
 mkNewTyConRep :: TyCon		-- The original type constructor
 	      -> Type		-- Chosen representation type
+				-- (guaranteed not to be another newtype)
+
 -- Find the representation type for this newtype TyCon
--- See notes on newypes in types/TypeRep about newtypes.
-mkNewTyConRep tc = head (dataConOrigArgTys (head (tyConDataCons tc)))
+-- 
+-- The non-recursive newtypes are easy, because they look transparent
+-- to splitTyConApp_maybe, but recursive ones really are represented as
+-- TyConApps (see TypeRep).
+-- 
+-- The trick is to to deal correctly with recursive newtypes
+-- such as	newtype T = MkT T
+
+mkNewTyConRep tc
+  = go [] tc
+  where
+	-- Invariant: tc is a NewTyCon
+	-- 	      tcs have been seen before
+    go tcs tc 
+	| tc `elem` tcs = unitTy
+	| otherwise
+	= let
+	      rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc)))
+	  in
+	  case splitTyConApp_maybe rep_ty of
+			Nothing -> rep_ty 
+			Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
+				        | otherwise	       -> go1 (tc:tcs) tc' tys
+
+    go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
 \end{code}
 
-
 %************************************************************************
 %*									*
 \subsection{Dependency analysis}
-- 
1.7.10.4