[project @ 2003-02-04 15:09:38 by simonpj]

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

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 6d90068..ec41604 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -9,6 +9,8 @@ module Type (
        Type, PredType, ThetaType,
        Kind, TyVarSubst, 
 
+       TyThing(..), isTyClThing,
+
        superKind, superBoxity,                         -- KX and BX respectively
        liftedBoxity, unliftedBoxity,                   -- :: BX
        openKindCon,                                    -- :: KX
@@ -18,11 +20,6 @@ module Type (
        isTypeKind, isAnyTypeKind,
        funTyCon,
 
-        usageKindCon,                                  -- :: KX
-        usageTypeKind,                                 -- :: KX
-        usOnceTyCon, usManyTyCon,                      -- :: $
-        usOnce, usMany,                                        -- :: $
-
         -- exports from this module:
         hasMoreBoxityInfo, defaultKind,
 
@@ -65,7 +62,7 @@ module Type (
        tidyTopType,   tidyPred,
 
        -- Comparison
-       eqType, eqKind, eqUsage, 
+       eqType, eqKind, 
 
        -- Seq
        seqType, seqTypes
@@ -85,12 +82,12 @@ import {-# SOURCE #-}       PprType( pprType )      -- Only called in debug messages
 import {-# SOURCE #-}   Subst  ( substTyWith )
 
 -- friends:
-import Var     ( TyVar, tyVarKind, tyVarName, setTyVarName )
+import Var     ( Id, TyVar, tyVarKind, tyVarName, setTyVarName )
 import VarEnv
 import VarSet
 
 import Name    ( NamedThing(..), mkInternalName, tidyOccName )
-import Class   ( classTyCon )
+import Class   ( Class, classTyCon )
 import TyCon   ( TyCon, isRecursiveTyCon, isPrimTyCon,
                  isUnboxedTupleTyCon, isUnLiftedTyCon,
                  isFunTyCon, isNewTyCon, newTyConRep,
@@ -104,7 +101,7 @@ import CmdLineOpts  ( opt_DictsStrict )
 import SrcLoc          ( noSrcLoc )
 import PrimRep         ( PrimRep(..) )
 import Unique          ( Uniquable(..) )
-import Util            ( mapAccumL, seqList, lengthIs )
+import Util            ( mapAccumL, seqList, lengthIs, snocView )
 import Outputable
 import UniqSet         ( sizeUniqSet )         -- Should come via VarSet
 import Maybe           ( isJust )
@@ -113,6 +110,29 @@ import Maybe               ( isJust )
 
 %************************************************************************
 %*                                                                     *
+                       TyThing
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+data TyThing = AnId   Id
+            | ATyCon TyCon
+            | AClass Class
+
+isTyClThing :: TyThing -> Bool
+isTyClThing (ATyCon _) = True
+isTyClThing (AClass _) = True
+isTyClThing (AnId   _) = False
+
+instance NamedThing TyThing where
+  getName (AnId id)   = getName id
+  getName (ATyCon tc) = getName tc
+  getName (AClass cl) = getName cl
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
 \subsection{Stuff to do with kinds.}
 %*                                                                     *
 %************************************************************************
@@ -224,14 +244,11 @@ splitAppTy_maybe :: Type -> Maybe (Type, Type)
 splitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
 splitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 splitAppTy_maybe (NoteTy _ ty)     = splitAppTy_maybe ty
-splitAppTy_maybe (SourceTy p)        = splitAppTy_maybe (sourceTypeRep p)
-splitAppTy_maybe (TyConApp tc [])  = Nothing
-splitAppTy_maybe (TyConApp tc tys) = split tys []
-                           where
-                              split [ty2]    acc = Just (TyConApp tc (reverse acc), ty2)
-                              split (ty:tys) acc = split tys (ty:acc)
-
-splitAppTy_maybe other           = Nothing
+splitAppTy_maybe (SourceTy p)      = splitAppTy_maybe (sourceTypeRep p)
+splitAppTy_maybe (TyConApp tc tys) = case snocView tys of
+                                       Nothing -> Nothing
+                                       Just (tys',ty') -> Just (TyConApp tc tys', ty')
+splitAppTy_maybe other            = Nothing
 
 splitAppTy :: Type -> (Type, Type)
 splitAppTy ty = case splitAppTy_maybe ty of
@@ -243,7 +260,7 @@ splitAppTys ty = split ty ty []
   where
     split orig_ty (AppTy ty arg)        args = split ty ty (arg:args)
     split orig_ty (NoteTy _ ty)         args = split orig_ty ty args
-    split orig_ty (SourceTy p)            args = split orig_ty (sourceTypeRep p) args
+    split orig_ty (SourceTy p)          args = split orig_ty (sourceTypeRep p) args
     split orig_ty (FunTy ty1 ty2)       args = ASSERT( null args )
                                               (TyConApp funTyCon [], [ty1,ty2])
     split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
@@ -853,7 +870,6 @@ I don't think this is harmful, but it's soemthing to watch out for.
 \begin{code}
 eqType t1 t2 = eq_ty emptyVarEnv t1 t2
 eqKind  = eqType       -- No worries about looking 
-eqUsage = eqType       -- through source types for these two
 
 -- Look through Notes
 eq_ty env (NoteTy _ t1)       t2                 = eq_ty env t1 t2