[project @ 2001-08-23 16:27:11 by simonpj]

Fix representation finding for recursive newtypes

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index d26184d..7997de5 100644 (file)
--- 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}