X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=3282d33601e577d2cf5a5da58d79eced88a8a500;hb=8a86866e9e382c1d4d06cad722ddbe965d09997c;hp=fc5d3aee2ec2ef32fc414f0006cd32ac3007fa5f;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index fc5d3ae..3282d33 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -16,6 +16,10 @@ is the principal client.
 \begin{code}
 module TcType (
   --------------------------------
+  -- TyThing
+  TyThing(..),	-- instance NamedThing
+
+  --------------------------------
   -- Types 
   TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, 
   TcTyVar, TcTyVarSet, TcKind, 
@@ -35,7 +39,7 @@ module TcType (
   tcSplitForAllTys, tcSplitPhiTy, 
   tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
   tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
-  tcSplitAppTy_maybe, tcSplitAppTy, tcSplitSigmaTy,
+  tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
   tcSplitMethodTy, tcGetTyVar_maybe, tcGetTyVar,
 
   ---------------------------------
@@ -96,7 +100,7 @@ module TcType (
 
   tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
   tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
-  typeKind, eqKind, eqUsage,
+  typeKind, eqKind,
 
   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta
   ) where
@@ -111,22 +115,30 @@ import {-# SOURCE #-} PprType( pprType )
 import TypeRep		( Type(..), TyNote(..), funTyCon )  -- friend
 
 import Type		(	-- Re-exports
-			  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
-			  Kind, Type, SourceType(..), PredType, ThetaType, 
-			  unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
-			  mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind,
+			  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
+			  tyVarsOfTheta, Kind, Type, SourceType(..),
+			  PredType, ThetaType, unliftedTypeKind,
+			  liftedTypeKind, openTypeKind, mkArrowKind,
+			  mkArrowKinds, mkForAllTy, mkForAllTys,
+			  defaultKind, isTypeKind, isAnyTypeKind,
 			  mkFunTy, mkFunTys, zipFunTys, isTyVarTy,
-			  mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
-			  mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
-			  isUnLiftedType, isUnboxedTupleType, isPrimitiveType,
-			  splitNewType_maybe, splitTyConApp_maybe,
-			  tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
-			  tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, eqKind, eqUsage,
-			  hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind
+			  mkTyConApp, mkGenTyConApp, mkAppTy,
+			  mkAppTys, mkSynTy, applyTy, applyTys,
+			  mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
+			  mkPredTys, isUnLiftedType,
+			  isUnboxedTupleType, isPrimitiveType,
+			  splitTyConApp_maybe,
+			  tidyTopType, tidyType, tidyPred, tidyTypes,
+			  tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
+			  tidyTyVarBndr, tidyOpenTyVar,
+			  tidyOpenTyVars, eqKind, 
+			  hasMoreBoxityInfo, liftedBoxity,
+			  superBoxity, typeKind, superKind, repType
 			)
+import DataCon		( DataCon )
 import TyCon		( TyCon, isUnLiftedTyCon )
 import Class		( classHasFDs, Class )
-import Var		( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails )
+import Var		( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails )
 import ForeignCall	( Safety, playSafe )
 import VarEnv
 import VarSet
@@ -141,7 +153,7 @@ import TysWiredIn	( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon )
 import BasicTypes	( IPName(..), ipNameName )
 import Unique		( Unique, Uniquable(..) )
 import SrcLoc		( SrcLoc )
-import Util		( cmpList, thenCmp, equalLength )
+import Util		( cmpList, thenCmp, equalLength, snocView )
 import Maybes		( maybeToBool, expectJust )
 import Outputable
 \end{code}
@@ -149,6 +161,26 @@ import Outputable
 
 %************************************************************************
 %*									*
+			TyThing
+%*									*
+%************************************************************************
+
+\begin{code}
+data TyThing = AnId     Id
+	     | ADataCon DataCon
+	     | ATyCon   TyCon
+	     | AClass   Class
+
+instance NamedThing TyThing where
+  getName (AnId id)     = getName id
+  getName (ATyCon tc)   = getName tc
+  getName (AClass cl)   = getName cl
+  getName (ADataCon dc) = getName dc
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection{Types}
 %*									*
 %************************************************************************
@@ -405,21 +437,26 @@ tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
 tcSplitAppTy_maybe (FunTy ty1 ty2)   	     = Just (TyConApp funTyCon [ty1], ty2)
 tcSplitAppTy_maybe (AppTy ty1 ty2)   	     = Just (ty1, ty2)
 tcSplitAppTy_maybe (NoteTy n ty)     	     = tcSplitAppTy_maybe ty
-tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys
-	--- Don't forget that newtype!
+tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys	--- Don't forget that newtype!
 tcSplitAppTy_maybe (TyConApp tc tys)	     = tc_split_app tc tys
 tcSplitAppTy_maybe other	  	     = Nothing
 
-tc_split_app tc []  = Nothing
-tc_split_app tc tys = split tys []
-		    where
-		      split [ty2]    acc = Just (TyConApp tc (reverse acc), ty2)
-		      split (ty:tys) acc = split tys (ty:acc)
+tc_split_app tc tys = case snocView tys of
+			Just (tys',ty') -> Just (TyConApp tc tys', ty')
+			Nothing		-> Nothing
 
 tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
 		    Just stuff -> stuff
 		    Nothing    -> pprPanic "tcSplitAppTy" (pprType ty)
 
+tcSplitAppTys :: Type -> (Type, [Type])
+tcSplitAppTys ty
+  = go ty []
+  where
+    go ty args = case tcSplitAppTy_maybe ty of
+		   Just (ty', arg) -> go ty' (arg:args)
+		   Nothing	   -> (ty,args)
+
 tcGetTyVar_maybe :: Type -> Maybe TyVar
 tcGetTyVar_maybe (TyVarTy tv) 	= Just tv
 tcGetTyVar_maybe (NoteTy _ t) 	= tcGetTyVar_maybe t
@@ -437,8 +474,7 @@ The type of a method for class C is always of the form:
 where sig_ty is the type given by the method's signature, and thus in general
 is a ForallTy.  At the point that splitMethodTy is called, it is expected
 that the outer Forall has already been stripped off.  splitMethodTy then
-returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes or
-Usages stripped off.
+returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes stripped off.
 
 \begin{code}
 tcSplitMethodTy :: Type -> (PredType, Type)
@@ -817,11 +853,10 @@ isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc =
 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
 	-- Look through newtypes
 	-- Non-recursive ones are transparent to splitTyConApp,
-	-- but recursive ones aren't; hence the splitNewType_maybe
+	-- but recursive ones aren't
 checkRepTyCon check_tc ty 
-  | Just ty'    <- splitNewType_maybe ty  = checkRepTyCon check_tc ty'
-  | Just (tc,_) <- splitTyConApp_maybe ty = check_tc tc
-  | otherwise				  = False
+  | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
+  | otherwise				  	    = False
 \end{code}
 
 ----------------------------------------------