X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FTysWiredIn.lhs;h=bc450281991faa8dd930730b9c8baceea1e3fa33;hp=80530b9398c5a3d18c61e839cd45c4123d104ba9;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=7299e42cc5214458ba16034dbfbf58de55f7121b diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 80530b9..bc45028 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -3,12 +3,9 @@ % \section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} -This module tracks the ``state interface'' document, ``GHC prelude: -types and operations.'' - \begin{code} -- | This module is about types that can be defined in Haskell, but which --- must be wired into the compiler nonetheless. +-- must be wired into the compiler nonetheless. C.f module TysPrim module TysWiredIn ( -- * All wired in things wiredInTyCons, @@ -41,7 +38,7 @@ module TysWiredIn ( mkListTy, -- * Tuples - mkTupleTy, + mkTupleTy, mkBoxedTupleTy, tupleTyCon, tupleCon, unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedSingletonTyCon, unboxedSingletonDataCon, @@ -50,6 +47,12 @@ module TysWiredIn ( -- * Unit unitTy, + -- * Heterogeneous Metaprogramming + mkHetMetCodeTypeTy, + hetMetCodeTypeTyConName, + hetMetCodeTypeTyCon, isHetMetCodeTypeTyCon, + hetMetCodeTypeTyCon_RDR, + -- * Parallel arrays mkPArrTy, parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, @@ -67,28 +70,16 @@ 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 OccName ( mkTcOccFS, mkDataOccFS, mkTupleOcc, mkDataConWorkerOcc, - tcName, dataName ) -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, - StrictnessMark(..) ) - -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 Array +import Data.Array import FastString import Outputable @@ -130,12 +121,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , intTyCon , listTyCon , parrTyCon - , unsafeCoercionTyCon - , symCoercionTyCon - , transCoercionTyCon - , leftCoercionTyCon - , rightCoercionTyCon - , instCoercionTyCon + , hetMetCodeTypeTyCon ] \end{code} @@ -159,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 @@ -175,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 @@ -189,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} @@ -223,10 +208,8 @@ pcTyCon is_enum is_rec name tyvars cons tyvars [] -- No stupid theta (DataTyCon cons is_enum) - [] -- No record selectors NoParentTyCon is_rec - True -- All the wired-in tycons have generics False -- Not in GADT syntax pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon @@ -244,7 +227,7 @@ pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon = data_con where data_con = mkDataCon dc_name declared_infix - (map (const NotMarkedStrict) arg_tys) + (map (const HsNoBang) arg_tys) [] -- No labelled fields tyvars [] -- No existential type variables @@ -291,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 @@ -308,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 @@ -332,6 +313,7 @@ unboxedPairDataCon :: DataCon unboxedPairDataCon = tupleCon Unboxed 2 \end{code} + %************************************************************************ %* * \subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)} @@ -539,11 +521,17 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}. \end{itemize} \begin{code} -mkTupleTy :: Boxity -> Int -> [Type] -> Type -mkTupleTy boxity arity tys = mkTyConApp (tupleTyCon boxity arity) tys +mkTupleTy :: Boxity -> [Type] -> Type +-- Special case for *boxed* 1-tuples, which are represented by the type itself +mkTupleTy boxity [ty] | Boxed <- boxity = ty +mkTupleTy boxity tys = mkTyConApp (tupleTyCon boxity (length tys)) tys + +-- | Build the type of a small tuple that holds the specified type of thing +mkBoxedTupleTy :: [Type] -> Type +mkBoxedTupleTy tys = mkTupleTy Boxed tys unitTy :: Type -unitTy = mkTupleTy Boxed 0 [] +unitTy = mkTupleTy Boxed [] \end{code} %************************************************************************ @@ -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}