X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=e38da87182e0c11fd570065b93bd1008915956ec;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=be4eccd0299c7bf32b97892eace9c9b77be0725a;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index be4eccd..e38da87 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -9,10 +9,10 @@
 module TyCon(
 	TyCon(..), 	-- NB: some pals need to see representation
 
-	Arity(..), NewOrData(..),
+	SYN_IE(Arity), NewOrData(..),
 
 	isFunTyCon, isPrimTyCon, isBoxedTyCon,
-	isDataTyCon, isSynTyCon, isNewTyCon,
+	isDataTyCon, isSynTyCon, isNewTyCon, maybeNewTyCon,
 
 	mkDataTyCon,
 	mkFunTyCon,
@@ -40,15 +40,16 @@ module TyCon(
 
 CHK_Ubiq()	-- debugging consistency check
 
-IMPORT_DELOOPER(TyLoop)		( Type(..), GenType,
-			  Class(..), GenClass,
-			  Id(..), GenId,
-			  mkTupleCon, isNullaryDataCon,
-			  specMaybeTysSuffix
+IMPORT_DELOOPER(TyLoop)	( SYN_IE(Type), GenType,
+			  SYN_IE(Class), GenClass,
+			  SYN_IE(Id), GenId,
+			  splitSigmaTy, splitFunTy,
+			  mkTupleCon, isNullaryDataCon, idType
+			  --LATER: specMaybeTysSuffix
 			)
 
-import TyVar		( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar )
-import Usage		( GenUsage, Usage(..) )
+import TyVar		( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar, SYN_IE(TyVar) )
+import Usage		( GenUsage, SYN_IE(Usage) )
 import Kind		( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
 
 import Maybes
@@ -56,14 +57,14 @@ import Name		( Name, RdrName(..), appendRdr, nameUnique,
 			  mkTupleTyConName, mkFunTyConName
 			)
 import Unique		( Unique, funTyConKey, mkTupleTyConUnique )
-import Pretty		( Pretty(..), PrettyRep )
+import Pretty		( SYN_IE(Pretty), PrettyRep )
 import PrimRep		( PrimRep(..) )
 import SrcLoc		( SrcLoc, mkBuiltinSrcLoc )
-import Util		( panic, panic#, pprPanic{-ToDo:rm-}, nOfThem, isIn, Ord3(..) )
-import {-hide me-}
-	PprType (pprTyCon)
-import {-hide me-}
-	PprStyle--ToDo:rm
+import Util		( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic )
+--import {-hide me-}
+--	PprType (pprTyCon)
+--import {-hide me-}
+--	PprStyle--ToDo:rm
 \end{code}
 
 \begin{code}
@@ -132,12 +133,9 @@ mkTupleTyCon arity
     n = mkTupleTyConName arity
     u = uniqueOf n
 
-mkDataTyCon name
-  = DataTyCon (nameUnique name) name
-mkPrimTyCon name
-  = PrimTyCon (nameUnique name) name
-mkSynTyCon name
-  = SynTyCon (nameUnique name) name
+mkDataTyCon name = DataTyCon (nameUnique name) name
+mkPrimTyCon name = PrimTyCon (nameUnique name) name
+mkSynTyCon  name = SynTyCon  (nameUnique name) name
 
 isFunTyCon FunTyCon = True
 isFunTyCon _ = False
@@ -155,6 +153,16 @@ isDataTyCon (DataTyCon _ _ _ _ _ _ _ DataType) = True
 isDataTyCon (TupleTyCon _ _ _)		       = True
 isDataTyCon other 			       = False
 
+maybeNewTyCon :: TyCon -> Maybe ([TyVar], Type) 	-- Returns representation type info
+maybeNewTyCon (DataTyCon _ _ _ _ _ (con:null_cons) _ NewType) 
+  = ASSERT( null null_cons && null null_tys)
+    Just (tyvars, rep_ty)
+  where
+    (tyvars, theta, tau)      = splitSigmaTy (idType con)
+    (rep_ty:null_tys, res_ty) = splitFunTy tau
+
+maybeNewTyCon other = Nothing
+
 isNewTyCon (DataTyCon _ _ _ _ _ _ _ NewType) = True 
 isNewTyCon other			     = False
 
@@ -230,7 +238,7 @@ tyConDataCons other				  = []
 tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons
 tyConFamilySize (TupleTyCon _ _ _)		    = 1
 #ifdef DEBUG
-tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
+--tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
 #endif
 
 tyConPrimRep :: TyCon -> PrimRep
@@ -331,7 +339,7 @@ instance NamedThing TyCon where
     getName tc				= panic "TyCon.getName"
 
 {- LATER:
-    getName (SpecTyCon tc tys) = let (m,n) = moduleNamePair tc in
+    getName (SpecTyCon tc tys) = let (OrigName m n) = origName "????" tc in
        			     (m, n _APPEND_ specMaybeTysSuffix tys)
     getName	other_tc           = moduleNamePair (expectJust "tycon1" (getName other_tc))
     getName other			     = Nothing