[project @ 2000-02-01 16:08:17 by sewardj]

[ghc-hetmet.git] / ghc / compiler / types / TyCon.lhs

diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 189b0da..14180b2 100644 (file)
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module TyCon(
-       TyCon, KindCon, SuperKindCon,
+       TyCon, KindCon, SuperKindCon, ArgVrcs,
 
        isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon,
        isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
@@ -19,9 +19,12 @@ module TyCon(
        mkKindCon,
        mkSuperKindCon,
 
+       setTyConName,
+
        tyConKind,
        tyConUnique,
        tyConTyVars,
+       tyConArgVrcs_maybe,
        tyConDataCons,
        tyConFamilySize,
        tyConDerivings,
@@ -38,8 +41,11 @@ 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 {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon )
 
 import Class           ( Class )
 import Var             ( TyVar )
@@ -77,8 +83,9 @@ data TyCon
        tyConKind   :: Kind,
        tyConArity  :: Arity,
        
-       tyConTyVars     :: [TyVar],
-       dataTyConTheta  :: [(Class,[Type])],
+       tyConTyVars      :: [TyVar],
+       dataTyConTheta   :: [(Class,[Type])],
+       dataTyConArgVrcs :: ArgVrcs,
 
        dataCons :: [DataCon],
                -- Its data constructors, with fully polymorphic types
@@ -104,6 +111,7 @@ data TyCon
        tyConName    :: Name,
        tyConKind    :: Kind,
        tyConArity   :: Arity,
+       primTyConArgVrcs :: ArgVrcs,
        primTyConRep :: PrimRep
     }
 
@@ -124,10 +132,11 @@ data TyCon
        tyConKind   :: Kind,
        tyConArity  :: Arity,
 
-       tyConTyVars :: [TyVar],         -- Bound tyvars
-       synTyConDefn :: Type            -- Right-hand side, mentioning these type vars.
+       tyConTyVars     :: [TyVar],     -- Bound tyvars
+       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
     }
 
   | KindCon {          -- Type constructor at the kind level
@@ -141,6 +150,10 @@ data TyCon
        tyConUnique :: Unique,
        tyConName   :: Name
     }
+
+type ArgVrcs = [(Bool,Bool)]  -- Tyvar variance info: [(occPos,occNeg)]
+                              -- *NB*: this is tyvar variance info, *not*
+                              --       termvar usage info.
 \end{code}
 
 %************************************************************************
@@ -180,7 +193,7 @@ mkFunTyCon name kind
        tyConArity  = 2
     }
                            
-mkAlgTyCon name kind tyvars theta cons derivs maybe_clas flavour rec
+mkAlgTyCon name kind tyvars theta argvrcs cons derivs maybe_clas flavour rec
   = AlgTyCon { 
        tyConName = name,
        tyConUnique = nameUnique name,
@@ -188,6 +201,7 @@ mkAlgTyCon name kind tyvars theta cons derivs maybe_clas flavour rec
        tyConArity = length tyvars,
        tyConTyVars = tyvars,
        dataTyConTheta = theta,
+       dataTyConArgVrcs = argvrcs,
        dataCons = cons,
        dataTyConDerivings = derivs,
        dataTyConClass_maybe = maybe_clas,
@@ -206,24 +220,28 @@ mkTupleTyCon name kind arity tyvars con boxed
        dataCon = con
     }
 
-mkPrimTyCon name kind arity rep 
+mkPrimTyCon name kind arity arg_vrcs rep 
   = PrimTyCon {
        tyConName = name,
        tyConUnique = nameUnique name,
        tyConKind = kind,
        tyConArity = arity,
+        primTyConArgVrcs = arg_vrcs,
        primTyConRep = rep
     }
 
-mkSynTyCon name kind arity tyvars rhs 
+mkSynTyCon name kind arity tyvars rhs argvrcs
   = SynTyCon { 
        tyConName = name,
        tyConUnique = nameUnique name,
        tyConKind = kind,
        tyConArity = arity,
        tyConTyVars = tyvars,
-       synTyConDefn = rhs
+       synTyConDefn = rhs,
+       synTyConArgVrcs = argvrcs
     }
+
+setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name}
 \end{code}
 
 \begin{code}
@@ -258,10 +276,16 @@ isDataTyCon other = False
 isNewTyCon (AlgTyCon {algTyConFlavour = NewType}) = True 
 isNewTyCon other                                 = False
 
--- A "product" tycon is non-recursive and has one constructor,
+-- A "product" tycon is 
+--     non-recursive 
+--     has one constructor, 
+--     is *not* existential
+--     is *not* an unboxed tuple
 -- whether DataType or NewType
-isProductTyCon (AlgTyCon {dataCons = [c], algTyConRec = NonRecursive}) = True
-isProductTyCon (TupleTyCon {}) = True
+isProductTyCon (AlgTyCon {dataCons = [data_con], algTyConRec = NonRecursive}) 
+  = not (isExistentialDataCon data_con)
+isProductTyCon (TupleTyCon { tyConBoxed = boxed }) 
+  = boxed
 isProductTyCon other = False
 
 isSynTyCon (SynTyCon {}) = True
@@ -311,6 +335,21 @@ tyConTheta (AlgTyCon {dataTyConTheta = theta}) = theta
 -- should ask about anything else
 \end{code}
 
+@tyConArgVrcs_maybe@ gives a list of (occPos,occNeg) flags, one for
+each tyvar, if available.  See @calcAlgTyConArgVrcs@ for how this is
+actually computed (in another file).
+
+\begin{code}
+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 (TupleTyCon {tyConArity = arity   }) = Just (replicate arity (True,False))
+tyConArgVrcs_maybe (SynTyCon   {synTyConArgVrcs = oi }) = Just oi
+tyConArgVrcs_maybe _                                    = Nothing
+\end{code}
+
 \begin{code}
 getSynTyConDefn :: TyCon -> ([TyVar], Type)
 getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,ty)
@@ -322,6 +361,9 @@ maybeTyConSingleCon (AlgTyCon {dataCons = [c]})  = Just c
 maybeTyConSingleCon (AlgTyCon {})               = Nothing
 maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con
 maybeTyConSingleCon (PrimTyCon {})               = Nothing
+maybeTyConSingleCon (FunTyCon {})                = Nothing  -- case at funty
+maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $
+                         ppr tc
 \end{code}
 
 \begin{code}