projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 1996-05-16 09:42:08 by partain]
[ghc-hetmet.git] / ghc / compiler / types / TyCon.lhs
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 87dfc62..d406196 100644 (file)
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -12,7 +12,7 @@ module TyCon(
        Arity(..), NewOrData(..),
 
        isFunTyCon, isPrimTyCon, isBoxedTyCon,
-       isDataTyCon, isSynTyCon,
+       isDataTyCon, isSynTyCon, isNewTyCon,
 
        mkDataTyCon,
        mkFunTyCon,
@@ -48,14 +48,17 @@ import TyLoop               ( Type(..), GenType,
 import TyVar           ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar )
 import Usage           ( GenUsage, Usage(..) )
 import Kind            ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
-import PrelMods                ( pRELUDE_BUILTIN )
 
 import Maybes
-import Name            ( Name, RdrName(..), appendRdr, nameUnique )
+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 SrcLoc          ( SrcLoc, mkBuiltinSrcLoc )
+import Unique          ( intDataConKey, charDataConKey )
 import Util            ( panic, panic#, nOfThem, isIn, Ord3(..) )
 \end{code}
 
@@ -74,7 +77,10 @@ data TyCon
                [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
@@ -113,9 +119,14 @@ data NewOrData
 
 \begin{code}
 mkFunTyCon   = FunTyCon
-mkTupleTyCon = TupleTyCon
 mkSpecTyCon  = SpecTyCon
 
+mkTupleTyCon arity
+  = TupleTyCon u n arity 
+  where
+    n = mkTupleTyConName arity
+    u = uniqueOf n
+
 mkDataTyCon name
   = DataTyCon (nameUnique name) name
 mkPrimTyCon name
@@ -136,8 +147,12 @@ isBoxedTyCon = not . isPrimTyCon
 -- isDataTyCon returns False for @newtype@.
 -- Not sure about this decision yet.
 isDataTyCon (DataTyCon _ _ _ _ _ _ _ DataType) = True
+isDataTyCon (TupleTyCon _ _ _)                = True
 isDataTyCon other                             = False
 
+isNewTyCon (DataTyCon _ _ _ _ _ _ _ NewType) = True 
+isNewTyCon other                            = False
+
 isSynTyCon (SynTyCon _ _ _ _ _ _) = True
 isSynTyCon _                     = False
 \end{code}
@@ -151,6 +166,15 @@ tyConKind :: TyCon -> Kind
 tyConKind FunTyCon                      = kind2
 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
@@ -159,21 +183,13 @@ 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 (TupleTyCon uniq _ _)         = uniq
 tyConUnique (PrimTyCon uniq _ _)          = uniq
 tyConUnique (SynTyCon uniq _ _ _ _ _)      = uniq
 tyConUnique (SpecTyCon _ _ )              = panic "tyConUnique:SpecTyCon"
@@ -181,7 +197,7 @@ tyConUnique (SpecTyCon _ _ )                   = panic "tyConUnique:SpecTyCon"
 tyConArity :: TyCon -> Arity
 tyConArity FunTyCon                     = 2
 tyConArity (DataTyCon _ _ _ tvs _ _ _ _) = length tvs
-tyConArity (TupleTyCon arity)           = arity
+tyConArity (TupleTyCon _ _ arity)       = arity
 tyConArity (PrimTyCon _ _ _)            = 0    -- ??
 tyConArity (SpecTyCon _ _)              = 0
 tyConArity (SynTyCon _ _ _ arity _ _)    = arity
@@ -195,7 +211,7 @@ 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"
 tyConTyVars (SpecTyCon _ _ )             = panic "tyConTyVars:SpecTyCon"
@@ -206,20 +222,20 @@ 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
 \end{code}
 
 \begin{code}
 tyConDerivings :: TyCon -> [Class]
 tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _) = derivs
-tyConDerivings other                              = []
+tyConDerivings other                           = []
 \end{code}
 
 \begin{code}
@@ -229,14 +245,15 @@ 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 (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
@@ -274,7 +291,7 @@ 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 (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 }
@@ -286,11 +303,13 @@ instance Ord3 TyCon where
     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 (TupleTyCon _ _ _)         = ILIT(3)
       tag_TyCon (PrimTyCon  _ _ _)         = ILIT(4)
       tag_TyCon (SpecTyCon  _ _)           = ILIT(5)
+      tag_TyCon (SynTyCon _ _ _ _ _ _)     = ILIT(6)
 
 instance Eq TyCon where
     a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
@@ -304,11 +323,12 @@ instance Ord TyCon where
     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 
 instance Uniquable TyCon where
-    uniqueOf (DataTyCon u _ _ _ _ _ _ _) = u
-    uniqueOf (PrimTyCon u _ _)          = u
-    uniqueOf (SynTyCon  u _ _ _ _ _)    = u
-    uniqueOf tc@(SpecTyCon _ _)                 = panic "uniqueOf:SpecTyCon"
-    uniqueOf tc                                 = uniqueOf (getName tc)
+    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}
 
 \begin{code}
@@ -317,16 +337,14 @@ instance NamedThing TyCon where
     getName (PrimTyCon _ n _)          = n
     getName (SpecTyCon tc _)           = getName tc
     getName (SynTyCon _ n _ _ _ _)     = n
-{- LATER:
-    getName FunTyCon                   = (pRELUDE_BUILTIN, SLIT("(->)"))
-    getName (TupleTyCon a)             = (pRELUDE_BUILTIN, _PK_ ("Tuple" ++ show a))
--}
+    getName FunTyCon                   = mkFunTyConName
+    getName (TupleTyCon _ n _)         = n
     getName tc                         = panic "TyCon.getName"
 
 {- LATER:
-    getName (SpecTyCon tc tys) = let (m,n) = getOrigName tc in
+    getName (SpecTyCon tc tys) = let (m,n) = moduleNamePair tc in
                                     (m, n _APPEND_ specMaybeTysSuffix tys)
-    getName    other_tc           = getOrigName (expectJust "tycon1" (getName other_tc))
+    getName    other_tc           = moduleNamePair (expectJust "tycon1" (getName other_tc))
     getName other                           = Nothing
 -}
 \end{code}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)