X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FTysWiredIn.lhs;h=bc450281991faa8dd930730b9c8baceea1e3fa33;hp=4695c87e8681f7dd9bf9cc55b7e7ef4f2b680732;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=215ce9f15215399ce30ae55c9521087847d78646

diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 4695c87..bc45028 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -47,6 +47,12 @@ module TysWiredIn (
         -- * Unit
 	unitTy,
 
+        -- * Heterogeneous Metaprogramming
+	mkHetMetCodeTypeTy,
+        hetMetCodeTypeTyConName,
+	hetMetCodeTypeTyCon,     isHetMetCodeTypeTyCon,
+	hetMetCodeTypeTyCon_RDR,
+
         -- * Parallel arrays
 	mkPArrTy,
 	parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
@@ -64,23 +70,14 @@ import TysPrim
 -- others:
 import Constants	( mAX_TUPLE_SIZE )
 import Module		( Module )
+import DataCon          ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
+import Var
+import TyCon
+import TypeRep
 import RdrName
 import Name
-import DataCon		( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
-import Var
-import TyCon		( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons,
-			  mkTupleTyCon, mkAlgTyCon, tyConName,
-			  TyConParent(NoParentTyCon) )
-
-import BasicTypes	( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) )
-
-import Type		( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys,
-			  TyThing(..) )
-import Coercion         ( unsafeCoercionTyCon, symCoercionTyCon,
-                          transCoercionTyCon, leftCoercionTyCon, 
-                          rightCoercionTyCon, instCoercionTyCon )
-import TypeRep          ( mkArrowKinds, liftedTypeKind, ubxTupleKind )
-import Unique		( incrUnique, mkTupleTyConUnique,
+import BasicTypes       ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) )
+import Unique           ( incrUnique, mkTupleTyConUnique,
 			  mkTupleDataConUnique, mkPArrDataConUnique )
 import Data.Array
 import FastString
@@ -124,12 +121,7 @@ wiredInTyCons = [ unitTyCon	-- Not treated like other tuples, because
     	      , intTyCon
     	      , listTyCon
 	      , parrTyCon
-              , unsafeCoercionTyCon
-              , symCoercionTyCon
-              , transCoercionTyCon
-              , leftCoercionTyCon
-              , rightCoercionTyCon
-              , instCoercionTyCon
+	      , hetMetCodeTypeTyCon
     	      ]
 \end{code}
 
@@ -153,9 +145,9 @@ intTyConName	  = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Int") intTyCo
 intDataConName	  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey  intDataCon
 
 boolTyConName, falseDataConName, trueDataConName :: Name
-boolTyConName	  = mkWiredInTyConName   UserSyntax gHC_BOOL (fsLit "Bool") boolTyConKey boolTyCon
-falseDataConName  = mkWiredInDataConName UserSyntax gHC_BOOL (fsLit "False") falseDataConKey falseDataCon
-trueDataConName	  = mkWiredInDataConName UserSyntax gHC_BOOL (fsLit "True")  trueDataConKey  trueDataCon 
+boolTyConName	  = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon
+falseDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon
+trueDataConName	  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True")  trueDataConKey  trueDataCon
 
 listTyConName, nilDataConName, consDataConName :: Name
 listTyConName	  = mkWiredInTyConName   BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon
@@ -169,11 +161,19 @@ doubleTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Double")
 doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon
 
 parrTyConName, parrDataConName :: Name
-parrTyConName	  = mkWiredInTyConName   BuiltInSyntax gHC_PARR (fsLit "[::]") parrTyConKey parrTyCon 
-parrDataConName   = mkWiredInDataConName UserSyntax    gHC_PARR (fsLit "PArr") parrDataConKey parrDataCon
+parrTyConName   = mkWiredInTyConName   BuiltInSyntax 
+                    gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon 
+parrDataConName = mkWiredInDataConName UserSyntax    
+                    gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon
+
+hetMetCodeTypeTyConName :: Name
+hetMetCodeTypeTyConName	= mkWiredInTyConName   BuiltInSyntax gHC_HETMET_CODETYPES (fsLit "<[]>@")      hetMetCodeTypeTyConKey   hetMetCodeTypeTyCon 
+hetMetCodeTypeDataConName :: Name
+hetMetCodeTypeDataConName	=
+    mkWiredInDataConName  BuiltInSyntax gHC_HETMET_CODETYPES (fsLit "<[]>")      hetMetCodeTypeDataConKey hetMetCodeTypeDataCon
 
 boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
-    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR:: RdrName
+    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, hetMetCodeTypeTyCon_RDR :: RdrName
 boolTyCon_RDR   = nameRdrName boolTyConName
 false_RDR	= nameRdrName falseDataConName
 true_RDR	= nameRdrName trueDataConName
@@ -183,16 +183,7 @@ intDataCon_RDR	= nameRdrName intDataConName
 listTyCon_RDR	= nameRdrName listTyConName
 consDataCon_RDR = nameRdrName consDataConName
 parrTyCon_RDR	= nameRdrName parrTyConName
-{-
-tySuperKindTyCon_RDR     = nameRdrName tySuperKindTyConName
-coSuperKindTyCon_RDR = nameRdrName coSuperKindTyConName
-liftedTypeKindTyCon_RDR   = nameRdrName liftedTypeKindTyConName
-openTypeKindTyCon_RDR     = nameRdrName openTypeKindTyConName
-unliftedTypeKindTyCon_RDR = nameRdrName unliftedTypeKindTyConName
-ubxTupleKindTyCon_RDR     = nameRdrName ubxTupleKindTyConName
-argTypeKindTyCon_RDR      = nameRdrName argTypeKindTyConName
-funKindTyCon_RDR          = nameRdrName funKindTyConName
--}
+hetMetCodeTypeTyCon_RDR	= nameRdrName hetMetCodeTypeTyConName
 \end{code}
 
 
@@ -219,7 +210,6 @@ pcTyCon is_enum is_rec name tyvars cons
 		(DataTyCon cons is_enum)
 		NoParentTyCon
                 is_rec
-		True		-- All the wired-in tycons have generics
 		False		-- Not in GADT syntax
 
 pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
@@ -284,7 +274,7 @@ unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mA
 mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
 mk_tuple boxity arity = (tycon, tuple_con)
   where
-	tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info 
+	tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity 
 	modu	= mkTupleModule boxity arity
 	tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq
 				(ATyCon tycon) BuiltInSyntax
@@ -301,8 +291,6 @@ mk_tuple boxity arity = (tycon, tuple_con)
 				  (ADataCon tuple_con) BuiltInSyntax
  	tc_uniq   = mkTupleTyConUnique   boxity arity
 	dc_uniq   = mkTupleDataConUnique boxity arity
-	gen_info  = True		-- Tuples all have generics..
-					-- hmm: that's a *lot* of code
 
 unitTyCon :: TyCon
 unitTyCon     = tupleTyCon Boxed 0
@@ -610,7 +598,7 @@ mkPArrFakeCon arity  = data_con
 	tyvar     = head alphaTyVars
 	tyvarTys  = replicate arity $ mkTyVarTy tyvar
         nameStr   = mkFastString ("MkPArr" ++ show arity)
-	name      = mkWiredInName gHC_PARR (mkDataOccFS nameStr) unique
+	name      = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique
 				  (ADataCon data_con) UserSyntax
 	unique      = mkPArrDataConUnique arity
 
@@ -619,4 +607,28 @@ isPArrFakeCon      :: DataCon -> Bool
 isPArrFakeCon dcon  = dcon == parrFakeCon (dataConSourceArity dcon)
 \end{code}
 
+Heterogeneous Metaprogramming
+
+\begin{code}
+-- | Construct a type representing the application of the box type
+mkHetMetCodeTypeTy    :: TyVar -> Type -> Type
+mkHetMetCodeTypeTy ecn ty = mkTyConApp hetMetCodeTypeTyCon [(mkTyVarTy ecn), ty]
 
+ecTyVar = head ecTyVars
+
+-- | Represents the type constructor of box types
+hetMetCodeTypeTyCon :: TyCon
+hetMetCodeTypeTyCon  = pcNonRecDataTyCon hetMetCodeTypeTyConName [ecTyVar, betaTyVar] [hetMetCodeTypeDataCon]
+
+-- | Check whether a type constructor is the constructor for box types
+isHetMetCodeTypeTyCon    :: TyCon -> Bool
+isHetMetCodeTypeTyCon tc  = tyConName tc == hetMetCodeTypeTyConName
+
+hetMetCodeTypeDataCon :: DataCon
+hetMetCodeTypeDataCon  = pcDataCon 
+	         hetMetCodeTypeDataConName 
+		 [betaTyVar]		-- forall'ed type variables
+		 [betaTy] 
+		 hetMetCodeTypeTyCon
+
+\end{code}