X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=48445e4e9c1734c0ac4baaf48cea33e78fe952b5;hb=9df21db498fed4645fc624e692d70672a84432dc;hp=28eaddfc903f9c14e94f39f54e57f90be0366db0;hpb=4e7d56fde0f44d38bbb9a6fc72cf9c603264899d;p=ghc-hetmet.git diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 28eaddf..48445e4 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -5,13 +5,16 @@ \begin{code} module TyCon( - TyCon, KindCon, SuperKindCon, ArgVrcs, + TyCon, KindCon, SuperKindCon, ArgVrcs, AlgTyConFlavour(..), isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, + isEnumerationTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, + isRecursiveTyCon, newTyConRep, mkAlgTyCon, + mkClassTyCon, mkFunTyCon, mkPrimTyCon, mkTupleTyCon, @@ -25,7 +28,7 @@ module TyCon( tyConUnique, tyConTyVars, tyConArgVrcs_maybe, - tyConDataCons, + tyConDataCons, tyConDataConsIfAvailable, tyConFamilySize, tyConDerivings, tyConTheta, @@ -41,12 +44,15 @@ module TyCon( #include "HsVersions.h" -import {-# SOURCE #-} Type ( Type, Kind, SuperKind ) -import {-# SOURCE #-} DataCon ( DataCon ) +import {-# SOURCE #-} TypeRep ( Type, Kind, SuperKind ) + -- Should just be Type(Type), but this fails due to bug present up to + -- and including 4.02 involving slurping of hi-boot files. Bug is now fixed. -import Class ( Class ) +import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) + +import Class ( Class, ClassContext ) import Var ( TyVar ) -import BasicTypes ( Arity, NewOrData(..), RecFlag(..) ) +import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed ) import Maybes import Name ( Name, nameUnique, NamedThing(getName) ) import Unique ( Unique, Uniquable(..), anyBoxConKey ) @@ -80,9 +86,9 @@ data TyCon tyConKind :: Kind, tyConArity :: Arity, - tyConTyVars :: [TyVar], - dataTyConTheta :: [(Class,[Type])], - dataTyConArgVrcs :: ArgVrcs, + tyConTyVars :: [TyVar], + tyConArgVrcs :: ArgVrcs, + algTyConTheta :: ClassContext, dataCons :: [DataCon], -- Its data constructors, with fully polymorphic types @@ -92,14 +98,23 @@ data TyCon -- (b) in a quest for fast compilation we don't import -- the constructors - dataTyConDerivings :: [Class], -- Classes which have derived instances + noOfDataCons :: Int, -- Number of data constructors + -- Usually this is the same as the length of the + -- dataCons field, but the latter may be empty if + -- we imported the type abstractly. But even if we import + -- abstractly we still need to know the number of constructors + -- so we can get the return convention right. Tiresome! + + algTyConDerivings :: [Class], -- Classes which have derived instances + + algTyConFlavour :: AlgTyConFlavour, + algTyConRec :: RecFlag, -- Tells whether the data type is part of + -- a mutually-recursive group or not - dataTyConClass_maybe :: (Maybe Class), -- Nothing for ordinary types; + algTyConClass_maybe :: Maybe Class -- Nothing for ordinary types; -- Just c for the type constructor -- for dictionaries of class c. - algTyConFlavour :: NewOrData, - algTyConRec :: RecFlag -- Tells whether the data type is part of - -- a mutually-recursive group or not + } | PrimTyCon { -- Primitive types; cannot be defined in Haskell @@ -108,7 +123,7 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - primTyConArgVrcs :: ArgVrcs, + tyConArgVrcs :: ArgVrcs, primTyConRep :: PrimRep } @@ -118,7 +133,7 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - tyConBoxed :: Bool, -- True for boxed; False for unboxed + tyConBoxed :: Boxity, tyConTyVars :: [TyVar], dataCon :: DataCon } @@ -133,7 +148,7 @@ data TyCon synTyConDefn :: Type, -- Right-hand side, mentioning these type vars. -- Acts as a template for the expansion when -- the tycon is applied to some types. - synTyConArgVrcs :: ArgVrcs + tyConArgVrcs :: ArgVrcs } | KindCon { -- Type constructor at the kind level @@ -151,6 +166,22 @@ data TyCon type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] -- *NB*: this is tyvar variance info, *not* -- termvar usage info. + +data AlgTyConFlavour + = DataTyCon -- Data type + | EnumTyCon -- Special sort of enumeration type + | NewTyCon Type -- Newtype, with its *ultimate* representation type + -- By 'ultimate' I mean that the rep type is not itself + -- a newtype or type synonym. + + -- The rep type has explicit for-alls for the tyvars of + -- the TyCon. Thus: + -- newtype T a = MkT [(a,Int)] + -- The rep type is forall a. [(a,Int)] + -- + -- The rep type isn't entirely simple: + -- for a recursive newtype we pick () as the rep type + -- newtype T = MkT T \end{code} %************************************************************************ @@ -190,22 +221,41 @@ mkFunTyCon name kind tyConArity = 2 } -mkAlgTyCon name kind tyvars theta argvrcs cons derivs maybe_clas flavour rec +mkAlgTyCon name kind tyvars theta argvrcs cons ncons derivs flavour rec = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - dataTyConTheta = theta, - dataTyConArgVrcs = argvrcs, - dataCons = cons, - dataTyConDerivings = derivs, - dataTyConClass_maybe = maybe_clas, - algTyConFlavour = flavour, - algTyConRec = rec + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + tyConArgVrcs = argvrcs, + algTyConTheta = theta, + dataCons = cons, + noOfDataCons = ncons, + algTyConDerivings = derivs, + algTyConClass_maybe = Nothing, + algTyConFlavour = flavour, + algTyConRec = rec } +mkClassTyCon name kind tyvars argvrcs con clas flavour + = AlgTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + tyConArgVrcs = argvrcs, + algTyConTheta = [], + dataCons = [con], + noOfDataCons = 1, + algTyConDerivings = [], + algTyConClass_maybe = Just clas, + algTyConFlavour = flavour, + algTyConRec = NonRecursive + } + + mkTupleTyCon name kind arity tyvars con boxed = TupleTyCon { tyConUnique = nameUnique name, @@ -223,7 +273,7 @@ mkPrimTyCon name kind arity arg_vrcs rep tyConUnique = nameUnique name, tyConKind = kind, tyConArity = arity, - primTyConArgVrcs = arg_vrcs, + tyConArgVrcs = arg_vrcs, primTyConRep = rep } @@ -235,7 +285,7 @@ mkSynTyCon name kind arity tyvars rhs argvrcs tyConArity = arity, tyConTyVars = tyvars, synTyConDefn = rhs, - synTyConArgVrcs = argvrcs + tyConArgVrcs = argvrcs } setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name} @@ -249,13 +299,13 @@ isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _ = False isUnLiftedTyCon (PrimTyCon {}) = True -isUnLiftedTyCon (TupleTyCon { tyConBoxed = False }) = True +isUnLiftedTyCon (TupleTyCon { tyConBoxed = boxity}) = not (isBoxed boxity) isUnLiftedTyCon _ = False -- isBoxedTyCon should not be applied to SynTyCon, nor KindCon isBoxedTyCon (AlgTyCon {}) = True isBoxedTyCon (FunTyCon {}) = True -isBoxedTyCon (TupleTyCon {tyConBoxed = boxed}) = boxed +isBoxedTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isBoxedTyCon (PrimTyCon {primTyConRep = rep}) = isFollowableRep rep -- isAlgTyCon returns True for both @data@ and @newtype@ @@ -265,46 +315,68 @@ isAlgTyCon other = False -- isDataTyCon returns False for @newtype@ and for unboxed tuples isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of - NewType -> False + NewTyCon _ -> False other -> True -isDataTyCon (TupleTyCon {tyConBoxed = True}) = True +isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False -isNewTyCon (AlgTyCon {algTyConFlavour = NewType}) = True -isNewTyCon other = False +isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True +isNewTyCon other = False + +newTyConRep (AlgTyCon {algTyConFlavour = NewTyCon rep}) = Just rep +newTyConRep other = Nothing --- A "product" tycon is non-recursive and has one constructor, and is *not* an unboxed tuple --- whether DataType or NewType -isProductTyCon (AlgTyCon {dataCons = [c], algTyConRec = NonRecursive}) = True -isProductTyCon (TupleTyCon { tyConBoxed = boxed }) = boxed -isProductTyCon other = False +-- A "product" tycon +-- has *one* constructor, +-- is *not* existential +-- but +-- may be DataType or NewType, +-- may be unboxed or not, +-- may be recursive or not +isProductTyCon (AlgTyCon {dataCons = [data_con]}) = not (isExistentialDataCon data_con) +isProductTyCon (TupleTyCon {}) = True +isProductTyCon other = False isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False -isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumType}) = True -isEnumerationTyCon other = False +isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True +isEnumerationTyCon other = False --- The unit tycon isn't classed as a tuple tycon -isTupleTyCon (TupleTyCon {tyConArity = arity, tyConBoxed = True}) = arity >= 2 -isTupleTyCon other = False +-- The unit tycon didn't used to be classed as a tuple tycon +-- but I thought that was silly so I've undone it +-- If it can't be for some reason, it should be a AlgTyCon +isTupleTyCon (TupleTyCon {}) = True +isTupleTyCon other = False -isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = False}) = True +isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) isUnboxedTupleTyCon other = False + +isBoxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity +isBoxedTupleTyCon other = False + +tupleTyConBoxity tc = tyConBoxed tc + +isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True +isRecursiveTyCon other = False \end{code} \begin{code} tyConDataCons :: TyCon -> [DataCon] -tyConDataCons (AlgTyCon {dataCons = cons}) = cons -tyConDataCons (TupleTyCon {dataCon = con}) = [con] -tyConDataCons other = [] +tyConDataCons tycon = ASSERT2( not (null cons), ppr tycon ) cons + where + cons = tyConDataConsIfAvailable tycon + +tyConDataConsIfAvailable (AlgTyCon {dataCons = cons}) = cons -- Empty for abstract types +tyConDataConsIfAvailable (TupleTyCon {dataCon = con}) = [con] +tyConDataConsIfAvailable 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 :: TyCon -> Int -tyConFamilySize (AlgTyCon {dataCons = cons}) = length cons -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (AlgTyCon {noOfDataCons = n}) = n +tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif @@ -316,13 +388,13 @@ tyConPrimRep _ = PtrRep \begin{code} tyConDerivings :: TyCon -> [Class] -tyConDerivings (AlgTyCon {dataTyConDerivings = derivs}) = derivs -tyConDerivings other = [] +tyConDerivings (AlgTyCon {algTyConDerivings = derivs}) = derivs +tyConDerivings other = [] \end{code} \begin{code} -tyConTheta :: TyCon -> [(Class, [Type])] -tyConTheta (AlgTyCon {dataTyConTheta = theta}) = theta +tyConTheta :: TyCon -> ClassContext +tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta -- should ask about anything else \end{code} @@ -334,10 +406,10 @@ actually computed (in another file). tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs tyConArgVrcs_maybe (FunTyCon {} ) = Just [(False,True),(True,False)] -tyConArgVrcs_maybe (AlgTyCon {dataTyConArgVrcs = oi}) = Just oi -tyConArgVrcs_maybe (PrimTyCon {primTyConArgVrcs = oi}) = Just oi +tyConArgVrcs_maybe (AlgTyCon {tyConArgVrcs = oi}) = Just oi +tyConArgVrcs_maybe (PrimTyCon {tyConArgVrcs = oi}) = Just oi tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity }) = Just (replicate arity (True,False)) -tyConArgVrcs_maybe (SynTyCon {synTyConArgVrcs = oi }) = Just oi +tyConArgVrcs_maybe (SynTyCon {tyConArgVrcs = oi }) = Just oi tyConArgVrcs_maybe _ = Nothing \end{code} @@ -359,8 +431,8 @@ maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ \begin{code} tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {dataTyConClass_maybe = maybe_cls}) = maybe_cls -tyConClass_maybe other_tycon = Nothing +tyConClass_maybe (AlgTyCon {algTyConClass_maybe = maybe_cls}) = maybe_cls +tyConClass_maybe other_tycon = Nothing \end{code}