X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=29997cde76254998cf39c29c9865dc333eaa81fc;hb=cda70f58ef004fd5b91749ab4f87f4589bebec45;hp=531709af92ec7f293d47188b0043345a88857aba;hpb=c92ddc55847b34d45f188f7c62092d69915a7a7d;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 531709a..29997cd 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -35,7 +35,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,
 
   ---------------------------------
@@ -50,15 +50,15 @@ module TcType (
 
   ---------------------------------
   -- Misc type manipulators
-  deNoteType, 
-  namesOfType, namesOfDFunHead,
+  deNoteType, classNamesOfTheta,
+  tyClsNamesOfType, tyClsNamesOfDFunHead, 
   getDFunTyKey,
 
   ---------------------------------
   -- Predicate types  
-  PredType, getClassPredTys_maybe, getClassPredTys, 
+  getClassPredTys_maybe, getClassPredTys, 
   isPredTy, isClassPred, isTyVarClassPred, predHasFDs,
-  mkDictTy, tcSplitPredTy_maybe, predTyUnique,
+  mkDictTy, tcSplitPredTy_maybe, 
   isDictTy, tcSplitDFunTy, predTyUnique, 
   mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, 
 
@@ -105,6 +105,7 @@ module TcType (
 
 
 import {-# SOURCE #-} PprType( pprType )
+-- PprType imports TcType so that it can print intelligently
 
 -- friends:
 import TypeRep		( Type(..), TyNote(..), funTyCon )  -- friend
@@ -140,7 +141,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}
@@ -404,21 +405,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
@@ -736,34 +742,38 @@ deNoteSourceType (IParam n ty)    = IParam n (deNoteType ty)
 deNoteSourceType (NType tc tys)   = NType tc (map deNoteType tys)
 \end{code}
 
-Find the free names of a type, including the type constructors and classes it mentions
-This is used in the front end of the compiler
+Find the free tycons and classes of a type.  This is used in the front
+end of the compiler.
 
 \begin{code}
-namesOfType :: Type -> NameSet
-namesOfType (TyVarTy tv)		= unitNameSet (getName tv)
-namesOfType (TyConApp tycon tys)	= unitNameSet (getName tycon) `unionNameSets` namesOfTypes tys
-namesOfType (NoteTy (SynNote ty1) ty2)	= namesOfType ty1
-namesOfType (NoteTy other_note    ty2)	= namesOfType ty2
-namesOfType (SourceTy (IParam n ty))	= namesOfType ty
-namesOfType (SourceTy (ClassP cl tys))	= unitNameSet (getName cl) `unionNameSets` namesOfTypes tys
-namesOfType (SourceTy (NType tc tys))	= unitNameSet (getName tc) `unionNameSets` namesOfTypes tys
-namesOfType (FunTy arg res)		= namesOfType arg `unionNameSets` namesOfType res
-namesOfType (AppTy fun arg)		= namesOfType fun `unionNameSets` namesOfType arg
-namesOfType (ForAllTy tyvar ty)		= namesOfType ty `delFromNameSet` getName tyvar
-
-namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
-
-namesOfDFunHead :: Type -> NameSet
+tyClsNamesOfType :: Type -> NameSet
+tyClsNamesOfType (TyVarTy tv)		    = emptyNameSet
+tyClsNamesOfType (TyConApp tycon tys)	    = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
+tyClsNamesOfType (NoteTy other_note    ty2) = tyClsNamesOfType ty2
+tyClsNamesOfType (SourceTy (IParam n ty))   = tyClsNamesOfType ty
+tyClsNamesOfType (SourceTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (SourceTy (NType tc tys))  = unitNameSet (getName tc) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (FunTy arg res)	    = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
+tyClsNamesOfType (AppTy fun arg)	    = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
+tyClsNamesOfType (ForAllTy tyvar ty)	    = tyClsNamesOfType ty
+
+tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
+
+tyClsNamesOfDFunHead :: Type -> NameSet
 -- Find the free type constructors and classes 
 -- of the head of the dfun instance type
 -- The 'dfun_head_type' is because of
 --	instance Foo a => Baz T where ...
 -- The decl is an orphan if Baz and T are both not locally defined,
 --	even if Foo *is* locally defined
-namesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of
-				(tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty)
-								      (map getName tvs)
+tyClsNamesOfDFunHead dfun_ty 
+  = case tcSplitSigmaTy dfun_ty of
+	(tvs,_,head_ty) -> tyClsNamesOfType head_ty
+
+classNamesOfTheta :: ThetaType -> [Name]
+-- Looks just for ClassP things; maybe it should check
+classNamesOfTheta preds = [ getName c | ClassP c _ <- preds ]
 \end{code}