X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FBuildTyCl.lhs;h=dfa8ba2ffc11c122f69b3c57cbd4b6fa700d6be1;hb=84f4c1dfb0c39c5b48a8b960fc82ab10aeb10c84;hp=6384ddc4c504f9c4079eec2f093a6a9e24a2191c;hpb=0cb269be72ffe42498c74d5be845eb27d8818423;p=ghc-hetmet.git

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 6384ddc..dfa8ba2 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -15,9 +15,8 @@ module BuildTyCl (
 import IfaceEnv		( newImplicitBinder )
 import TcRnMonad
 
-import DataCon		( DataCon, isNullarySrcDataCon, dataConUnivTyVars,
-			  mkDataCon, dataConFieldLabels, dataConInstOrigArgTys,
-                          dataConTyCon )
+import DataCon		( DataCon, isNullarySrcDataCon, 
+			  mkDataCon, dataConFieldLabels, dataConInstOrigArgTys )
 import Var		( tyVarKind, TyVar, Id )
 import VarSet		( isEmptyVarSet, intersectVarSet, elemVarSet )
 import TysWiredIn  	( unitTy )
@@ -25,23 +24,22 @@ import BasicTypes	( RecFlag, StrictnessMark(..) )
 import Name		( Name )
 import OccName		( mkDataConWrapperOcc, mkDataConWorkerOcc,
 			  mkClassTyConOcc, mkClassDataConOcc,
-			  mkSuperDictSelOcc, mkNewTyCoOcc, mkInstTyTcOcc,
+			  mkSuperDictSelOcc, mkNewTyCoOcc, 
 			  mkInstTyCoOcc ) 
 import MkId		( mkDataConIds, mkRecordSelId, mkDictSelId )
 import Class		( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
 import TyCon		( mkSynTyCon, mkAlgTyCon, visibleDataCons,
 			  tyConStupidTheta, tyConDataCons, isNewTyCon,
 			  mkClassTyCon, TyCon( tyConTyVars ),
-			  isRecursiveTyCon, tyConArity, AlgTyConRhs(..),
+			  isRecursiveTyCon, AlgTyConRhs(..),
 			  SynTyConRhs(..), newTyConRhs, AlgTyConParent(..) )
 import Type		( mkArrowKinds, liftedTypeKind, typeKind, 
 			  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
 			  splitTyConApp_maybe, splitAppTy_maybe,
 			  getTyVar_maybe, 
-			  mkPredTys, mkTyVarTys, ThetaType, Type, Kind,
+			  mkPredTys, mkTyVarTys, ThetaType, Type, 
 			  TyThing(..), 
-			  substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
-                          mkTyConApp, mkTyVarTy )
+			  substTyWith, zipTopTvSubst, substTheta )
 import Coercion         ( mkNewTypeCoercion, mkDataInstCoercion )
 import Outputable
 import List		( nub )
@@ -130,21 +128,20 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
 -- because the latter is part of a knot, whereas the former is not.
 mkNewTyConRhs tycon_name tycon con 
   = do	{ co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
-	; let co_tycon = mkNewTypeCoercion co_tycon_name tycon tvs rhs_ty
-              cocon_maybe 
-                | all_coercions || isRecursiveTyCon tycon 
-                = Just co_tycon
-                | otherwise              
-                = Nothing
-	; return (NewTyCon { data_con = con, 
+	; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_rhs
+              cocon_maybe | all_coercions || isRecursiveTyCon tycon 
+		          = Just co_tycon
+                	  | otherwise              
+                	  = Nothing
+	; return (NewTyCon { data_con    = con, 
+		       	     nt_rhs      = rhs_ty,
+		       	     nt_etad_rhs = etad_rhs,
  		       	     nt_co = cocon_maybe, 
                              -- Coreview looks through newtypes with a Nothing
                              -- for nt_co, or uses explicit coercions otherwise
-		       	     nt_rhs = rhs_ty,
-		       	     nt_etad_rhs = eta_reduce tvs rhs_ty,
 		       	     nt_rep = mkNewTyConRep tycon rhs_ty }) }
   where
-        -- if all_coercions is True then we use coercions for all newtypes
+        -- If all_coercions is True then we use coercions for all newtypes
         -- otherwise we use coercions for recursive newtypes and look through
         -- non-recursive newtypes
     all_coercions = True
@@ -153,18 +150,20 @@ mkNewTyConRhs tycon_name tycon con
 	-- Instantiate the data con with the 
 	-- type variables from the tycon
 
-    eta_reduce [] ty = ([], ty)
-    eta_reduce (a:as) ty | null as', 
-			   Just (fun, arg) <- splitAppTy_maybe ty',
+    etad_rhs :: ([TyVar], Type)
+    etad_rhs = eta_reduce (reverse tvs) rhs_ty
+
+    eta_reduce :: [TyVar]		-- Reversed
+	       -> Type			-- Rhs type
+	       -> ([TyVar], Type)	-- Eta-reduced version (tyvars in normal order)
+    eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty,
 			   Just tv <- getTyVar_maybe arg,
 			   tv == a,
 			   not (a `elemVarSet` tyVarsOfType fun)
-			 = ([], fun)	-- Successful eta reduction
-			 | otherwise
-			 = (a:as', ty')
-	where
-  	  (as', ty') = eta_reduce as ty
+			 = eta_reduce as fun
+    eta_reduce tvs ty = (reverse tvs, ty)
 				
+
 mkNewTyConRep :: TyCon		-- The original type constructor
 	      -> Type		-- The arg type of its constructor
 	      -> Type		-- Chosen representation type