X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=e38da87182e0c11fd570065b93bd1008915956ec;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=36b70dc831240f33000a84930a5d3c0375af7175;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 36b70dc..e38da87 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, + isDataTyCon, isSynTyCon, isNewTyCon, maybeNewTyCon, mkDataTyCon, mkFunTyCon, @@ -28,7 +28,9 @@ module TyCon( tyConDataCons, tyConFamilySize, tyConDerivings, - tyConArity, synTyConArity, + tyConTheta, + tyConPrimRep, + synTyConArity, getSynTyConDefn, maybeTyConSingleCon, @@ -37,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, dataConSig, - 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} @@ -68,15 +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 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 @@ -84,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 @@ -100,7 +110,7 @@ data TyCon | SynTyCon Unique - FullName + Name Kind Arity [TyVar] -- Argument type variables @@ -114,17 +124,23 @@ data NewOrData \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 -- At present there are no unboxed non-primitive types, so @@ -134,8 +150,22 @@ 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} @@ -147,8 +177,17 @@ kind2 = mkBoxedTypeKind `mkArrowKind` kind1 tyConKind :: TyCon -> Kind tyConKind FunTyCon = kind2 -tyConKind (DataTyCon _ kind _ _ _ _ _ _) = kind -tyConKind (PrimTyCon _ _ kind) = kind +tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind +tyConKind (PrimTyCon _ _ kind _) = kind +tyConKind (SynTyCon _ _ k _ _ _) = k + +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 @@ -157,33 +196,17 @@ tyConKind (SpecTyCon tc tys) spec kind (Just _ : tys) = spec (resultKind kind) tys spec kind (Nothing : tys) = argKind kind `mkArrowKind` spec (resultKind kind) tys - -tyConKind (TupleTyCon n) - = mkArrow n - where - mkArrow 0 = mkBoxedTypeKind - mkArrow 1 = kind1 - mkArrow 2 = kind2 - mkArrow n = mkBoxedTypeKind `mkArrowKind` mkArrow (n-1) \end{code} \begin{code} tyConUnique :: TyCon -> Unique tyConUnique FunTyCon = funTyConKey tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq -tyConUnique (TupleTyCon a) = mkTupleTyConUnique a -tyConUnique (PrimTyCon uniq _ _) = uniq +tyConUnique (TupleTyCon 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 @@ -193,10 +216,12 @@ synTyConArity _ = Nothing tyConTyVars :: TyCon -> [TyVar] tyConTyVars FunTyCon = [alphaTyVar,betaTyVar] tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs -tyConTyVars (TupleTyCon arity) = take arity alphaTyVars +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} @@ -204,20 +229,34 @@ tyConDataCons :: TyCon -> [Id] tyConFamilySize :: TyCon -> Int tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons -tyConDataCons (TupleTyCon a) = [mkTupleCon a] +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 a) = 1 +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} tyConDerivings :: TyCon -> [Class] tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _) = derivs -tyConDerivings other = [] +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} @@ -227,20 +266,18 @@ getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty) \begin{code} maybeTyConSingleCon :: TyCon -> Maybe Id -maybeTyConSingleCon (TupleTyCon arity) = Just (mkTupleCon arity) + +maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (mkTupleCon 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) +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 \end{code} @derivedFor@ reports if we have an {\em obviously}-derived instance @@ -269,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 } @@ -300,52 +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 = tyConUnique 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}