X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=e38da87182e0c11fd570065b93bd1008915956ec;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=79dae8e00d782e6b0db7ff56a4fb460fccddff0f;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 79dae8e..e38da87 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -9,9 +9,10 @@
 module TyCon(
 	TyCon(..), 	-- NB: some pals need to see representation
 
-	Arity(..), ConsVisible(..), NewOrData(..),
+	SYN_IE(Arity), NewOrData(..),
 
-	isFunTyCon, isPrimTyCon, isVisibleDataTyCon,
+	isFunTyCon, isPrimTyCon, isBoxedTyCon,
+	isDataTyCon, isSynTyCon, isNewTyCon, maybeNewTyCon,
 
 	mkDataTyCon,
 	mkFunTyCon,
@@ -21,12 +22,16 @@ module TyCon(
 
 	mkSynTyCon,
 
-	getTyConKind,
-	getTyConUnique,
-	getTyConTyVars,
-	getTyConDataCons,
-	getTyConDerivings,
-	getSynTyConArity,
+	tyConKind,
+	tyConUnique,
+	tyConTyVars,
+	tyConDataCons,
+	tyConFamilySize,
+	tyConDerivings,
+	tyConTheta,
+	tyConPrimRep,
+	synTyConArity,
+	getSynTyConDefn,
 
         maybeTyConSingleCon,
 	isEnumerationTyCon,
@@ -34,28 +39,32 @@ module TyCon(
 ) where
 
 CHK_Ubiq()	-- debugging consistency check
-import NameLoop	-- for paranoia checking
 
-import TyLoop		( Type(..), GenType,
-			  Class(..), GenClass,
-			  Id(..), GenId,
-			  mkTupleCon, getDataConSig,
-			  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 PrelMods		( pRELUDE_BUILTIN )
 
 import Maybes
-import NameTypes	( FullName )
+import Name		( Name, RdrName(..), appendRdr, nameUnique,
+			  mkTupleTyConName, mkFunTyConName
+			)
 import Unique		( Unique, funTyConKey, mkTupleTyConUnique )
-import Outputable
-import Pretty		( Pretty(..), PrettyRep )
-import PprStyle		( PprStyle )
+import Pretty		( SYN_IE(Pretty), PrettyRep )
+import PrimRep		( PrimRep(..) )
 import SrcLoc		( SrcLoc, mkBuiltinSrcLoc )
-import Util		( panic, panic#, nOfThem, isIn, Ord3(..) )
+import Util		( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic )
+--import {-hide me-}
+--	PprType (pprTyCon)
+--import {-hide me-}
+--	PprStyle--ToDo:rm
 \end{code}
 
 \begin{code}
@@ -65,16 +74,18 @@ data TyCon
   = FunTyCon		-- Kind = Type -> Type -> Type
 
   | DataTyCon	Unique{-TyConKey-}
+		Name
 		Kind
-		FullName
 		[TyVar]
 		[(Class,Type)]	-- Its context
 		[Id]		-- Its data constructors, with fully polymorphic types
 		[Class]		-- Classes which have derived instances
-		ConsVisible
 		NewOrData
 
-  | TupleTyCon	Arity	-- just a special case of DataTyCon
+  | TupleTyCon	Unique		-- cached
+		Name		-- again, we could do without this, but
+				-- it makes life somewhat easier
+		Arity	-- just a special case of DataTyCon
 			-- Kind = BoxedTypeKind
 			--      -> ... (n times) ...
 			--	-> BoxedTypeKind
@@ -82,8 +93,9 @@ data TyCon
 
   | PrimTyCon		-- Primitive types; cannot be defined in Haskell
 	Unique		-- Always unboxed; hence never represented by a closure
-	FullName	-- Often represented by a bit-pattern for the thing
+	Name		-- Often represented by a bit-pattern for the thing
 	Kind		-- itself (eg Int#), but sometimes by a pointer to
+	PrimRep
 
   | SpecTyCon		-- A specialised TyCon; eg (Arr# Int#), or (List Int#)
 	TyCon
@@ -98,7 +110,7 @@ data TyCon
 
   | SynTyCon
 	Unique
-	FullName
+	Name
 	Kind
 	Arity
 	[TyVar]		-- Argument type variables
@@ -106,31 +118,56 @@ data TyCon
 			-- Acts as a template for the expansion when
 			-- the tycon is applied to some types.
 
-data ConsVisible
-  = ConsVisible	    -- whether or not data constructors are visible
-  | ConsInvisible   -- outside their TyCon's defining module.
-
 data NewOrData
   = NewType	    -- "newtype Blah ..."
   | DataType	    -- "data Blah ..."
 \end{code}
 
 \begin{code}
-mkFunTyCon	= FunTyCon
-mkDataTyCon	= DataTyCon
-mkTupleTyCon	= TupleTyCon
-mkPrimTyCon	= PrimTyCon
-mkSpecTyCon	= SpecTyCon
-mkSynTyCon	= SynTyCon
+mkFunTyCon   = FunTyCon
+mkSpecTyCon  = SpecTyCon
+
+mkTupleTyCon arity
+  = TupleTyCon u n arity 
+  where
+    n = mkTupleTyConName arity
+    u = uniqueOf n
+
+mkDataTyCon name = DataTyCon (nameUnique name) name
+mkPrimTyCon name = PrimTyCon (nameUnique name) name
+mkSynTyCon  name = SynTyCon  (nameUnique name) name
 
 isFunTyCon FunTyCon = True
 isFunTyCon _ = False
 
-isPrimTyCon (PrimTyCon _ _ _) = True
+isPrimTyCon (PrimTyCon _ _ _ _) = True
 isPrimTyCon _ = False
 
-isVisibleDataTyCon (DataTyCon _ _ _ _ _ _ _ ConsVisible _) = True
-isVisibleDataTyCon _ = False
+-- At present there are no unboxed non-primitive types, so
+-- isBoxedTyCon is just the negation of isPrimTyCon.
+isBoxedTyCon = not . isPrimTyCon
+
+-- isDataTyCon returns False for @newtype@.
+-- Not sure about this decision yet.
+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
+
+isSynTyCon (SynTyCon _ _ _ _ _ _) = True
+isSynTyCon _			  = False
 \end{code}
 
 \begin{code}
@@ -138,81 +175,109 @@ isVisibleDataTyCon _ = False
 kind1 = mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind
 kind2 = mkBoxedTypeKind `mkArrowKind` kind1
 
-getTyConKind :: TyCon -> Kind
-getTyConKind FunTyCon 			      = kind2
-getTyConKind (DataTyCon _ kind _ _ _ _ _ _ _) = kind
-getTyConKind (PrimTyCon _ _ kind) 	      = kind
+tyConKind :: TyCon -> Kind
+tyConKind FunTyCon 			 = kind2
+tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind
+tyConKind (PrimTyCon _ _ kind _)	 = kind
+tyConKind (SynTyCon _ _ k _ _ _)	 = k
 
-getTyConKind (SpecTyCon tc tys)
-  = spec (getTyConKind tc) tys
-   where
-    spec kind []	      = kind
-    spec kind (Just _  : tys) = spec (resultKind kind) tys
-    spec kind (Nothing : tys) =
-      argKind kind `mkArrowKind` spec (resultKind kind) tys
-
-getTyConKind (TupleTyCon n)
+tyConKind (TupleTyCon _ _ n)
   = mkArrow n
    where
     mkArrow 0 = mkBoxedTypeKind
     mkArrow 1 = kind1
     mkArrow 2 = kind2
     mkArrow n = mkBoxedTypeKind `mkArrowKind` mkArrow (n-1)
+
+tyConKind (SpecTyCon tc tys)
+  = spec (tyConKind tc) tys
+   where
+    spec kind []	      = kind
+    spec kind (Just _  : tys) = spec (resultKind kind) tys
+    spec kind (Nothing : tys) =
+      argKind kind `mkArrowKind` spec (resultKind kind) tys
+\end{code}
+
+\begin{code}
+tyConUnique :: TyCon -> Unique
+tyConUnique FunTyCon			   = funTyConKey
+tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq
+tyConUnique (TupleTyCon uniq _ _)	   = uniq
+tyConUnique (PrimTyCon uniq _ _ _) 	   = uniq
+tyConUnique (SynTyCon uniq _ _ _ _ _)      = uniq
+tyConUnique (SpecTyCon _ _ )		   = panic "tyConUnique:SpecTyCon"
+
+synTyConArity :: TyCon -> Maybe Arity -- Nothing <=> not a syn tycon
+synTyConArity (SynTyCon _ _ _ arity _ _) = Just arity
+synTyConArity _				 = Nothing
 \end{code}
 
 \begin{code}
-getTyConUnique :: TyCon -> Unique
-getTyConUnique FunTyCon			        = funTyConKey
-getTyConUnique (DataTyCon uniq _ _ _ _ _ _ _ _) = uniq
-getTyConUnique (TupleTyCon a) 			= mkTupleTyConUnique a
-getTyConUnique (PrimTyCon uniq _ _) 	        = uniq
-getTyConUnique (SynTyCon uniq _ _ _ _ _)        = uniq
-getTyConUnique (SpecTyCon _ _ ) 	        = panic "getTyConUnique:SpecTyCon"
+tyConTyVars :: TyCon -> [TyVar]
+tyConTyVars FunTyCon			  = [alphaTyVar,betaTyVar]
+tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs
+tyConTyVars (TupleTyCon _ _ arity)	  = take arity alphaTyVars
+tyConTyVars (SynTyCon _ _ _ _ tvs _)      = tvs
+#ifdef DEBUG
+tyConTyVars (PrimTyCon _ _ _ _)	     	  = panic "tyConTyVars:PrimTyCon"
+tyConTyVars (SpecTyCon _ _ ) 	     	  = panic "tyConTyVars:SpecTyCon"
+#endif
 \end{code}
 
 \begin{code}
-getTyConTyVars :: TyCon -> [TyVar]
-getTyConTyVars FunTyCon			       = [alphaTyVar,betaTyVar]
-getTyConTyVars (DataTyCon _ _ _ tvs _ _ _ _ _) = tvs
-getTyConTyVars (TupleTyCon arity) 	       = take arity alphaTyVars
-getTyConTyVars (SynTyCon _ _ _ _ tvs _)        = tvs
-getTyConTyVars (PrimTyCon _ _ _) 	       = panic "getTyConTyVars:PrimTyCon"
-getTyConTyVars (SpecTyCon _ _ ) 	       = panic "getTyConTyVars:SpecTyCon"
+tyConDataCons :: TyCon -> [Id]
+tyConFamilySize  :: TyCon -> Int
+
+tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons
+tyConDataCons (TupleTyCon _ _ a)		  = [mkTupleCon a]
+tyConDataCons other				  = []
+	-- You may think this last equation should fail,
+	-- but it's quite convenient to return no constructors for
+	-- a synonym; see for example the call in TcTyClsDecls.
+
+tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons
+tyConFamilySize (TupleTyCon _ _ _)		    = 1
+#ifdef DEBUG
+--tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
+#endif
+
+tyConPrimRep :: TyCon -> PrimRep
+tyConPrimRep (PrimTyCon _ _ _ rep) = rep
+tyConPrimRep _			   = PtrRep
 \end{code}
 
 \begin{code}
-getTyConDataCons :: TyCon -> [Id]
-getTyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _ _) = data_cons
-getTyConDataCons (TupleTyCon a)			       = [mkTupleCon a]
+tyConDerivings :: TyCon -> [Class]
+tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _) = derivs
+tyConDerivings other				= []
 \end{code}
 
 \begin{code}
-getTyConDerivings :: TyCon -> [Class]
-getTyConDerivings (DataTyCon _ _ _ _ _ _ derivs _ _) = derivs
+tyConTheta :: TyCon -> [(Class,Type)]
+tyConTheta (DataTyCon _ _ _ _ theta _ _ _) = theta
+tyConTheta (TupleTyCon _ _ _)		   = []
+-- should ask about anything else
 \end{code}
 
 \begin{code}
-getSynTyConArity :: TyCon -> Maybe Arity
-getSynTyConArity (SynTyCon _ _ _ arity _ _) = Just arity
-getSynTyConArity other			    = Nothing
+getSynTyConDefn :: TyCon -> ([TyVar], Type)
+getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty)
 \end{code}
 
 \begin{code}
 maybeTyConSingleCon :: TyCon -> Maybe Id
-maybeTyConSingleCon (TupleTyCon arity)	             = Just (mkTupleCon arity)
-maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _ _)  = Just c
-maybeTyConSingleCon (DataTyCon _ _ _ _ _ _   _ _ _)  = Nothing
-maybeTyConSingleCon (PrimTyCon _ _ _)	             = Nothing
-maybeTyConSingleCon (SpecTyCon tc tys)               = panic "maybeTyConSingleCon:SpecTyCon"
-						     -- requires DataCons of TyCon
-
-isEnumerationTyCon (TupleTyCon arity)
+
+maybeTyConSingleCon (TupleTyCon _ _ arity)        = Just (mkTupleCon arity)
+maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c
+maybeTyConSingleCon (DataTyCon _ _ _ _ _ _   _ _) = Nothing
+maybeTyConSingleCon (PrimTyCon _ _ _ _)	          = Nothing
+maybeTyConSingleCon (SpecTyCon tc tys)            = panic "maybeTyConSingleCon:SpecTyCon"
+						  -- requires DataCons of TyCon
+
+isEnumerationTyCon (TupleTyCon _ _ arity)
   = arity == 0
-isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _ _)
-  = not (null data_cons) && all is_nullary data_cons
-  where
-    is_nullary con = case (getDataConSig con) of { (_,_, arg_tys, _) ->
-		     null arg_tys }
+isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _)
+  = not (null data_cons) && all isNullaryDataCon data_cons
 \end{code}
 
 @derivedFor@ reports if we have an {\em obviously}-derived instance
@@ -224,8 +289,8 @@ ToDo: what about derivings for specialised tycons !!!
 
 \begin{code}
 derivedFor :: Class -> TyCon -> Bool
-derivedFor clas (DataTyCon _ _ _ _ _ _ derivs _ _) = isIn "derivedFor" clas derivs
-derivedFor clas something_weird		           = False
+derivedFor clas (DataTyCon _ _ _ _ _ _ derivs _) = isIn "derivedFor" clas derivs
+derivedFor clas something_weird		         = False
 \end{code}
 
 %************************************************************************
@@ -241,26 +306,7 @@ the property @(a<=b) || (b<=a)@.
 
 \begin{code}
 instance Ord3 TyCon where
-  cmp FunTyCon		            FunTyCon		          = EQ_
-  cmp (DataTyCon a _ _ _ _ _ _ _ _) (DataTyCon b _ _ _ _ _ _ _ _) = a `cmp` b
-  cmp (SynTyCon a _ _ _ _ _)        (SynTyCon b _ _ _ _ _)        = a `cmp` b
-  cmp (TupleTyCon a)	            (TupleTyCon b)	          = a `cmp` b
-  cmp (PrimTyCon a _ _)		    (PrimTyCon b _ _)	          = a `cmp` b
-  cmp (SpecTyCon tc1 mtys1)	    (SpecTyCon tc2 mtys2)
-    = panic# "cmp on SpecTyCons" -- case (tc1 `cmp` tc2) of { EQ_ -> mtys1 `cmp` mtys2; xxx -> xxx }
-
-    -- now we *know* the tags are different, so...
-  cmp other_1 other_2
-    | tag1 _LT_ tag2 = LT_
-    | otherwise      = GT_
-    where
-      tag1 = tag_TyCon other_1
-      tag2 = tag_TyCon other_2
-      tag_TyCon FunTyCon    		      = ILIT(1)
-      tag_TyCon (DataTyCon _ _ _ _ _ _ _ _ _) = ILIT(2)
-      tag_TyCon (TupleTyCon _)		      = ILIT(3)
-      tag_TyCon (PrimTyCon  _ _ _)	      = ILIT(4)
-      tag_TyCon (SpecTyCon  _ _) 	      = ILIT(5)
+  cmp tc1 tc2 = uniqueOf tc1 `cmp` uniqueOf tc2
 
 instance Eq TyCon where
     a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
@@ -272,53 +318,30 @@ instance Ord TyCon where
     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
     a >	 b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-\end{code}
-
-\begin{code}
-instance NamedThing TyCon where
-    getExportFlag tc = case get_name tc of
-			 Nothing   -> NotExported
-			 Just name -> getExportFlag name
 
-
-    isLocallyDefined tc = case get_name tc of
-			    Nothing   -> False
-			    Just name -> isLocallyDefined name
-
-    getOrigName FunTyCon		= (pRELUDE_BUILTIN, SLIT("(->)"))
-    getOrigName (TupleTyCon a)		= (pRELUDE_BUILTIN, _PK_ ("Tuple" ++ show a))
-    getOrigName (SpecTyCon tc tys)	= let (m,n) = getOrigName tc in
-					  (m, n _APPEND_ specMaybeTysSuffix tys)
-    getOrigName	other_tc           	= getOrigName (expectJust "tycon1" (get_name other_tc))
-
-    getOccurrenceName  FunTyCon		= SLIT("(->)")
-    getOccurrenceName (TupleTyCon 0)	= SLIT("()")
-    getOccurrenceName (TupleTyCon a)	= _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
-    getOccurrenceName (SpecTyCon tc tys)= getOccurrenceName tc _APPEND_ specMaybeTysSuffix tys
-    getOccurrenceName other_tc          = getOccurrenceName (expectJust "tycon2" (get_name other_tc))
-
-    getInformingModules	tc = case get_name tc of
-				Nothing   -> panic "getInformingModule:TyCon"
-				Just name -> getInformingModules name
-
-    getSrcLoc tc = case get_name tc of
-		     Nothing   -> mkBuiltinSrcLoc
-		     Just name -> getSrcLoc name
-
-    getItsUnique tycon = getTyConUnique tycon
-
-    fromPreludeCore tc = case get_name tc of
-			   Nothing   -> True
-			   Just name -> fromPreludeCore name
+instance Uniquable TyCon where
+    uniqueOf (DataTyCon  u _ _ _ _ _ _ _) = u
+    uniqueOf (TupleTyCon u _ _)		  = u
+    uniqueOf (PrimTyCon  u _ _ _)	  = u
+    uniqueOf (SynTyCon   u _ _ _ _ _)	  = u
+    uniqueOf tc@(SpecTyCon _ _)		  = panic "uniqueOf:SpecTyCon"
+    uniqueOf tc				  = uniqueOf (getName tc)
 \end{code}
 
-Emphatically un-exported:
-
 \begin{code}
-get_name (DataTyCon _ _ n _ _ _ _ _ _) = Just n
-get_name (PrimTyCon _ n _)	       = Just n
-get_name (SpecTyCon tc _)	       = get_name tc
-get_name (SynTyCon _ n _ _ _ _)	       = Just n
-get_name other			       = Nothing
+instance NamedThing TyCon where
+    getName (DataTyCon _ n _ _ _ _ _ _) = n
+    getName (PrimTyCon _ n _ _)		= n
+    getName (SpecTyCon tc _)		= getName tc
+    getName (SynTyCon _ n _ _ _ _)	= n
+    getName FunTyCon			= mkFunTyConName
+    getName (TupleTyCon _ n _)		= n
+    getName tc				= panic "TyCon.getName"
+
+{- LATER:
+    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
+-}
 \end{code}
-