X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fiface%2FBuildTyCl.lhs;h=bf71ca843ce8fa5158f27b326197aa2aa42341cb;hb=bb106f283663e9c16a4c72ec9ca57109ae57a0ed;hp=9eda9073dd6e90dde8d9e1f956ec2ffb32ce422f;hpb=44ba24dc84d271ca9bd5ab5060cb63ed87f585e3;p=ghc-hetmet.git

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 9eda907..bf71ca8 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -6,7 +6,8 @@
 module BuildTyCl (
 	buildSynTyCon, buildAlgTyCon, buildDataCon,
 	buildClass,
-	mkAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs
+	mkAbstractTyConRhs, mkOpenDataTyConRhs, mkOpenNewTyConRhs,
+	mkNewTyConRhs, mkDataTyConRhs 
     ) where
 
 #include "HsVersions.h"
@@ -26,14 +27,17 @@ import OccName		( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc,
 			  mkClassDataConOcc, mkSuperDictSelOcc, mkNewTyCoOcc )
 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(..), newTyConRhs )
+import TyCon		( mkSynTyCon, mkAlgTyCon, visibleDataCons,
+			  tyConStupidTheta, tyConDataCons, isNewTyCon,
+			  mkClassTyCon, TyCon( tyConTyVars ),
+			  isRecursiveTyCon, tyConArity, AlgTyConRhs(..),
+			  SynTyConRhs(..), newTyConRhs )
 import Type		( mkArrowKinds, liftedTypeKind, typeKind, 
 			  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
-			  splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe,
-			  mkPredTys, mkTyVarTys, ThetaType, Type, 
+			  splitTyConApp_maybe, splitAppTy_maybe,
+			  getTyVar_maybe, 
+			  mkPredTys, mkTyVarTys, ThetaType, Type, Kind,
+			  TyThing(..), 
 			  substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
                           mkTyConApp, mkTyVarTy )
 import Coercion         ( mkNewTypeCoercion )
@@ -45,8 +49,13 @@ import List		( nub )
 
 \begin{code}
 ------------------------------------------------------
-buildSynTyCon name tvs rhs_ty
-  = mkSynTyCon name kind tvs rhs_ty
+buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon
+buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki)
+  = mkSynTyCon name kind tvs rhs
+  where
+    kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
+buildSynTyCon name tvs rhs@(SynonymTyCon rhs_ty)
+  = mkSynTyCon name kind tvs rhs
   where
     kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
 
@@ -72,6 +81,12 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
 mkAbstractTyConRhs :: AlgTyConRhs
 mkAbstractTyConRhs = AbstractTyCon
 
+mkOpenDataTyConRhs :: AlgTyConRhs
+mkOpenDataTyConRhs = OpenDataTyCon
+
+mkOpenNewTyConRhs :: AlgTyConRhs
+mkOpenNewTyConRhs = OpenNewTyCon
+
 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
 mkDataTyConRhs cons
   = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }
@@ -82,15 +97,24 @@ 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 
+	; 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, 
- 		       	     nt_co = Just co_tycon, 
+ 		       	     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
+        -- otherwise we use coercions for recursive newtypes and look through
+        -- non-recursive newtypes
+    all_coercions = True
     tvs    = tyConTyVars tycon
     rhs_ty = head (dataConInstOrigArgTys con (mkTyVarTys tvs))
 	-- Instantiate the data con with the 
@@ -208,11 +232,12 @@ mkTyConSelIds tycon rhs
 \begin{code}
 buildClass :: Name -> [TyVar] -> ThetaType
 	   -> [FunDep TyVar]		-- Functional dependencies
+	   -> [TyThing]			-- Associated types
 	   -> [(Name, DefMeth, Type)]	-- Method info
 	   -> RecFlag			-- Info for type constructor
 	   -> TcRnIf m n Class
 
-buildClass class_name tvs sc_theta fds sig_stuff tc_isrec
+buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
   = do	{ tycon_name <- newImplicitBinder class_name mkClassTyConOcc
 	; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
 		-- The class name is the 'parent' for this datacon, not its tycon,
@@ -262,10 +287,12 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec
 		-- Because C has only one operation, it is represented by
 		-- a newtype, and it should be a *recursive* newtype.
 		-- [If we don't make it a recursive newtype, we'll expand the
-		-- newtype like a synonym, but that will lead to an infinite type]
+		-- newtype like a synonym, but that will lead to an infinite
+		-- type]
+	      ; atTyCons = [tycon | ATyCon tycon <- ats]
 	      }
-	; return (mkClass class_name tvs fds
-		       sc_theta sc_sel_ids op_items
+	; return (mkClass class_name tvs fds 
+		       sc_theta sc_sel_ids atTyCons op_items
 		       tycon)
 	})}
 \end{code}