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

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 6384ddc..75d7234 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -1,4 +1,5 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 
@@ -12,40 +13,24 @@ module BuildTyCl (
 
 #include "HsVersions.h"
 
-import IfaceEnv		( newImplicitBinder )
+import IfaceEnv
 import TcRnMonad
 
-import DataCon		( DataCon, isNullarySrcDataCon, dataConUnivTyVars,
-			  mkDataCon, dataConFieldLabels, dataConInstOrigArgTys,
-                          dataConTyCon )
-import Var		( tyVarKind, TyVar, Id )
-import VarSet		( isEmptyVarSet, intersectVarSet, elemVarSet )
-import TysWiredIn  	( unitTy )
-import BasicTypes	( RecFlag, StrictnessMark(..) )
-import Name		( Name )
-import OccName		( mkDataConWrapperOcc, mkDataConWorkerOcc,
-			  mkClassTyConOcc, mkClassDataConOcc,
-			  mkSuperDictSelOcc, mkNewTyCoOcc, mkInstTyTcOcc,
-			  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(..),
-			  SynTyConRhs(..), newTyConRhs, AlgTyConParent(..) )
-import Type		( mkArrowKinds, liftedTypeKind, typeKind, 
-			  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
-			  splitTyConApp_maybe, splitAppTy_maybe,
-			  getTyVar_maybe, 
-			  mkPredTys, mkTyVarTys, ThetaType, Type, Kind,
-			  TyThing(..), 
-			  substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
-                          mkTyConApp, mkTyVarTy )
-import Coercion         ( mkNewTypeCoercion, mkDataInstCoercion )
+import DataCon
+import Var
+import VarSet
+import TysWiredIn
+import BasicTypes
+import Name
+import OccName
+import MkId
+import Class
+import TyCon
+import Type
+import Coercion
 import Outputable
-import List		( nub )
 
+import Data.List
 \end{code}
 	
 
@@ -130,21 +115,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 +137,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