X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=ada7c8d4b362d990b6ea8ce1584b9cb5d10ca7a9;hb=38db229302890403037c5de7453299b3538bb404;hp=d40619627a2185374231223d0f56075c1e4ccdb8;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index d406196..ada7c8d 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,
+	isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, maybeNewTyCon,
 
 	mkDataTyCon,
 	mkFunTyCon,
@@ -28,43 +28,50 @@ module TyCon(
 	tyConDataCons,
 	tyConFamilySize,
 	tyConDerivings,
-	tyConArity, synTyConArity,
+	tyConTheta,
+	tyConPrimRep,
+	synTyConArity,
 	getSynTyConDefn,
 
         maybeTyConSingleCon,
-	isEnumerationTyCon,
-	derivedFor
+	isEnumerationTyCon, isTupleTyCon,
+	derivedClasses
 ) where
 
 CHK_Ubiq()	-- debugging consistency check
 
-import TyLoop		( Type(..), GenType,
-			  Class(..), GenClass,
-			  Id(..), GenId,
-			  mkTupleCon, dataConSig,
-			  specMaybeTysSuffix
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
+IMPORT_DELOOPER(TyLoop) ( SYN_IE(Type), GenType,
+			  SYN_IE(Class), GenClass,
+			  SYN_IE(Id), GenId,
+			  splitSigmaTy, splitFunTy,
+			  tupleCon, isNullaryDataCon, idType
+			  --LATER: specMaybeTysSuffix
 			)
-
-import TyVar		( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar )
-import Usage		( GenUsage, Usage(..) )
+#else
+import {-# SOURCE #-} Type  ( Type, splitSigmaTy, splitFunTy  )
+import {-# SOURCE #-} Class ( Class )
+import {-# SOURCE #-} Id    ( Id, isNullaryDataCon, idType )
+import {-# SOURCE #-} TysWiredIn ( tupleCon )
+#endif
+
+import BasicTypes	( SYN_IE(Arity), NewOrData(..) )
+import TyVar		( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar, SYN_IE(TyVar) )
+import Usage		( GenUsage, SYN_IE(Usage) )
 import Kind		( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
 
 import Maybes
-import Name		( Name, RdrName(..), appendRdr, nameUnique,
-			  mkTupleTyConName, mkFunTyConName
-			)
-import Unique		( Unique, funTyConKey, mkTupleTyConUnique )
-import PrelInfo		( intDataCon, charDataCon )
-import Pretty		( Pretty(..), PrettyRep )
-import PprStyle		( PprStyle )
+import Name		( Name, nameUnique, mkWiredInTyConName, NamedThing(getName) )
+import Unique		( Unique, funTyConKey, Uniquable(..) )
+import Pretty		( Doc )
+import PrimRep		( PrimRep(..) )
+import PrelMods		( gHC__, pREL_TUP, pREL_BASE )
+import Lex		( mkTupNameStr )
 import SrcLoc		( SrcLoc, mkBuiltinSrcLoc )
-import Unique		( intDataConKey, charDataConKey )
-import Util		( panic, panic#, nOfThem, isIn, Ord3(..) )
+import Util		( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic )
 \end{code}
 
 \begin{code}
-type Arity = Int
-
 data TyCon
   = FunTyCon		-- Kind = Type -> Type -> Type
 
@@ -73,7 +80,12 @@ data TyCon
 		Kind
 		[TyVar]
 		[(Class,Type)]	-- Its context
-		[Id]		-- Its data constructors, with fully polymorphic types
+		[Id{-DataCon-}]	-- Its data constructors, with fully polymorphic types
+				-- 	This list can be empty, when we import a data type abstractly,
+				-- 	either (a) the interface is hand-written and doesn't give
+				--		   the constructors, or
+				--	       (b) in a quest for fast compilation we don't import 
+				--		   the constructors
 		[Class]		-- Classes which have derived instances
 		NewOrData
 
@@ -90,6 +102,7 @@ data TyCon
 	Unique		-- Always unboxed; hence never represented by a closure
 	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
@@ -111,45 +124,49 @@ data TyCon
 	Type		-- Right-hand side, mentioning these type vars.
 			-- Acts as a template for the expansion when
 			-- the tycon is applied to some types.
-
-data NewOrData
-  = NewType	    -- "newtype Blah ..."
-  | DataType	    -- "data Blah ..."
 \end{code}
 
 \begin{code}
-mkFunTyCon   = FunTyCon
-mkSpecTyCon  = SpecTyCon
+mkFunTyCon     = FunTyCon
+mkFunTyConName = mkWiredInTyConName funTyConKey gHC__ SLIT("->") FunTyCon
 
-mkTupleTyCon arity
-  = TupleTyCon u n arity 
-  where
-    n = mkTupleTyConName arity
-    u = uniqueOf n
+mkSpecTyCon  = SpecTyCon
+mkTupleTyCon = TupleTyCon
 
-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
 
-isPrimTyCon (PrimTyCon _ _ _) = True
+isPrimTyCon (PrimTyCon _ _ _ _) = True
 isPrimTyCon _ = False
 
 -- At present there are no unboxed non-primitive types, so
 -- isBoxedTyCon is just the negation of isPrimTyCon.
 isBoxedTyCon = not . isPrimTyCon
 
+-- isAlgTyCon returns True for both @data@ and @newtype@
+isAlgTyCon (DataTyCon _ _ _ _ _ _ _ _) = True
+isAlgTyCon (TupleTyCon _ _ _)	       = True
+isAlgTyCon other 		       = False
+
 -- 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
 
@@ -165,7 +182,7 @@ kind2 = mkBoxedTypeKind `mkArrowKind` kind1
 tyConKind :: TyCon -> Kind
 tyConKind FunTyCon 			 = kind2
 tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind
-tyConKind (PrimTyCon _ _ kind)		 = kind
+tyConKind (PrimTyCon _ _ kind _)	 = kind
 tyConKind (SynTyCon _ _ k _ _ _)	 = k
 
 tyConKind (TupleTyCon _ _ n)
@@ -190,18 +207,10 @@ tyConUnique :: TyCon -> Unique
 tyConUnique FunTyCon			   = funTyConKey
 tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq
 tyConUnique (TupleTyCon uniq _ _)	   = uniq
-tyConUnique (PrimTyCon uniq _ _) 	   = uniq
+tyConUnique (PrimTyCon uniq _ _ _) 	   = uniq
 tyConUnique (SynTyCon uniq _ _ _ _ _)      = uniq
 tyConUnique (SpecTyCon _ _ )		   = panic "tyConUnique:SpecTyCon"
 
-tyConArity :: TyCon -> Arity
-tyConArity FunTyCon			 = 2
-tyConArity (DataTyCon _ _ _ tvs _ _ _ _) = length tvs
-tyConArity (TupleTyCon _ _ arity)	 = arity
-tyConArity (PrimTyCon _ _ _)		 = 0	-- ??
-tyConArity (SpecTyCon _ _)		 = 0
-tyConArity (SynTyCon _ _ _ arity _ _)    = arity
-
 synTyConArity :: TyCon -> Maybe Arity -- Nothing <=> not a syn tycon
 synTyConArity (SynTyCon _ _ _ arity _ _) = Just arity
 synTyConArity _				 = Nothing
@@ -213,8 +222,10 @@ tyConTyVars FunTyCon			  = [alphaTyVar,betaTyVar]
 tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs
 tyConTyVars (TupleTyCon _ _ arity)	  = take arity alphaTyVars
 tyConTyVars (SynTyCon _ _ _ _ tvs _)      = tvs
-tyConTyVars (PrimTyCon _ _ _) 	     	  = panic "tyConTyVars:PrimTyCon"
+#ifdef DEBUG
+tyConTyVars (PrimTyCon _ _ _ _)	     	  = panic "tyConTyVars:PrimTyCon"
 tyConTyVars (SpecTyCon _ _ ) 	     	  = panic "tyConTyVars:SpecTyCon"
+#endif
 \end{code}
 
 \begin{code}
@@ -222,7 +233,7 @@ tyConDataCons :: TyCon -> [Id]
 tyConFamilySize  :: TyCon -> Int
 
 tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons
-tyConDataCons (TupleTyCon _ _ a)		  = [mkTupleCon a]
+tyConDataCons (TupleTyCon _ _ a)		  = [tupleCon a]
 tyConDataCons other				  = []
 	-- You may think this last equation should fail,
 	-- but it's quite convenient to return no constructors for
@@ -230,6 +241,13 @@ tyConDataCons other				  = []
 
 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}
@@ -239,6 +257,13 @@ tyConDerivings other				= []
 \end{code}
 
 \begin{code}
+tyConTheta :: TyCon -> [(Class,Type)]
+tyConTheta (DataTyCon _ _ _ _ theta _ _ _) = theta
+tyConTheta (TupleTyCon _ _ _)		   = []
+-- should ask about anything else
+\end{code}
+
+\begin{code}
 getSynTyConDefn :: TyCon -> ([TyVar], Type)
 getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty)
 \end{code}
@@ -246,20 +271,24 @@ getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty)
 \begin{code}
 maybeTyConSingleCon :: TyCon -> Maybe Id
 
-maybeTyConSingleCon (TupleTyCon _ _ arity)        = Just (mkTupleCon arity)
+maybeTyConSingleCon (TupleTyCon _ _ arity)        = Just (tupleCon arity)
 maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c
 maybeTyConSingleCon (DataTyCon _ _ _ _ _ _   _ _) = Nothing
-maybeTyConSingleCon (PrimTyCon _ _ _)	          = 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 (dataConSig con) of { (_,_, arg_tys, _) ->
-		     null arg_tys }
+  = not (null data_cons) && all isNullaryDataCon data_cons
+
+
+isTupleTyCon (TupleTyCon _ _ arity) = arity >= 2    -- treat "0-tuple" specially
+isTupleTyCon (SpecTyCon tc tys)     = isTupleTyCon tc
+isTupleTyCon other		    = False
+
+
 \end{code}
 
 @derivedFor@ reports if we have an {\em obviously}-derived instance
@@ -270,9 +299,9 @@ function doesn't deal with that.
 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
+derivedClasses :: TyCon -> [Class]
+derivedClasses (DataTyCon _ _ _ _ _ _ derivs _) = derivs
+derivedClasses something_weird		        = []
 \end{code}
 
 %************************************************************************
@@ -288,28 +317,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)
-      tag_TyCon (SynTyCon _ _ _ _ _ _)	    = ILIT(6)
+  cmp tc1 tc2 = uniqueOf tc1 `cmp` uniqueOf tc2
 
 instance Eq TyCon where
     a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
@@ -325,7 +333,7 @@ instance Ord TyCon where
 instance Uniquable TyCon where
     uniqueOf (DataTyCon  u _ _ _ _ _ _ _) = u
     uniqueOf (TupleTyCon u _ _)		  = u
-    uniqueOf (PrimTyCon  u _ _)		  = u
+    uniqueOf (PrimTyCon  u _ _ _)	  = u
     uniqueOf (SynTyCon   u _ _ _ _ _)	  = u
     uniqueOf tc@(SpecTyCon _ _)		  = panic "uniqueOf:SpecTyCon"
     uniqueOf tc				  = uniqueOf (getName tc)
@@ -334,7 +342,7 @@ instance Uniquable TyCon where
 \begin{code}
 instance NamedThing TyCon where
     getName (DataTyCon _ n _ _ _ _ _ _) = n
-    getName (PrimTyCon _ n _)		= n
+    getName (PrimTyCon _ n _ _)		= n
     getName (SpecTyCon tc _)		= getName tc
     getName (SynTyCon _ n _ _ _ _)	= n
     getName FunTyCon			= mkFunTyConName
@@ -342,9 +350,10 @@ 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
 -}
+
 \end{code}