X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FFamInstEnv.lhs;h=481c680a7f4cc33e5e2d70b72288dddf012f1b15;hp=eb31751678daf8add4ec0422749daec5759187f6;hb=940524aec90652b5ef81789c9a453c57c0e42cc9;hpb=84923cc7de2a93c22a2f72daf9ac863959efae13

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index eb31751..481c680 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -10,7 +10,8 @@ module FamInstEnv (
 	pprFamInst, pprFamInstHdr, pprFamInsts, 
 	famInstHead, mkLocalFamInst, mkImportedFamInst,
 
-	FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList, 
+	FamInstEnvs, FamInstEnv, emptyFamInstEnv, 
+	extendFamInstEnv, extendFamInstEnvList, 
 	famInstEnvElts, familyInstances,
 
 	lookupFamInstEnv, lookupFamInstEnvUnify
@@ -45,13 +46,19 @@ import Maybe
 \begin{code}
 data FamInst 
   = FamInst { fi_fam   :: Name		-- Family name
+		-- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of
+		--			   Just (tc, tys) -> tc
 
 		-- Used for "rough matching"; same idea as for class instances
 	    , fi_tcs   :: [Maybe Name]	-- Top of type args
+		-- INVARIANT: fi_tcs = roughMatchTcs fi_tys
 
 		-- Used for "proper matching"; ditto
 	    , fi_tvs   :: TyVarSet	-- Template tyvars for full match
 	    , fi_tys   :: [Type]	-- Full arg types
+		-- INVARIANT: fi_tvs = tyConTyVars fi_tycon
+		--	      fi_tys = case tyConFamInst_maybe fi_tycon of
+		--			   Just (_, tys) -> tys
 
 	    , fi_tycon :: TyCon		-- Representation tycon
 	    }
@@ -75,14 +82,13 @@ instance Outputable FamInst where
 pprFamInst :: FamInst -> SDoc
 pprFamInst famInst
   = hang (pprFamInstHdr famInst)
-	2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc famInst)))
+	2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan famInst)))
 
 pprFamInstHdr :: FamInst -> SDoc
 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
   = pprTyConSort <+> pprHead
   where
-    pprHead = parenSymOcc (getOccName fam) (ppr fam) <+> 
-	      sep (map pprParendType tys)
+    pprHead = pprTypeApp (parenSymOcc (getOccName fam) (ppr fam)) tys
     pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
 		 | isNewTyCon  tycon = ptext SLIT("newtype instance")
 		 | isSynTyCon  tycon = ptext SLIT("type instance")
@@ -142,6 +148,9 @@ InstEnv maps a family name to the list of known instances for that family.
 \begin{code}
 type FamInstEnv = UniqFM FamilyInstEnv	-- Maps a family to its instances
 
+type FamInstEnvs = (FamInstEnv, FamInstEnv)
+ 	-- External package inst-env, Home-package inst-env
+
 data FamilyInstEnv
   = FamIE [FamInst]	-- The instances for a particular family, in any order
   	  Bool 		-- True <=> there is an instance of form T a b c
@@ -184,60 +193,13 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
 %*									*
 %************************************************************************
 
-@lookupFamInstEnvExact@ looks up in a @FamInstEnv@ using an exact match.
-This is used when we want the @TyCon@ of a particular family instance (e.g.,
-during deriving classes).
-
-\begin{code}
-{-		NOT NEEDED ANY MORE
-lookupFamInstEnvExact :: (FamInstEnv		-- External package inst-env
-		         ,FamInstEnv)		-- Home-package inst-env
-		      -> TyCon -> [Type]	-- What we are looking for
-	              -> Maybe FamInst
-lookupFamInstEnvExact (pkg_ie, home_ie) fam tys
-  = home_matches `mplus` pkg_matches
-  where
-    rough_tcs    = roughMatchTcs tys
-    all_tvs      = all isNothing rough_tcs
-    home_matches = lookup home_ie 
-    pkg_matches  = lookup pkg_ie  
-
-    --------------
-    lookup env = case lookupUFM env fam of
-		   Nothing -> Nothing		-- No instances for this class
-		   Just (FamIE insts has_tv_insts)
-		       -- Short cut for common case:
-		       --   The thing we are looking up is of form (C a
-		       --   b c), and the FamIE has no instances of
-		       --   that form, so don't bother to search 
-		     | all_tvs && not has_tv_insts -> Nothing
-		     | otherwise                   -> find insts
-
-    --------------
-    find [] = Nothing
-    find (item@(FamInst { fi_tcs = mb_tcs, fi_tys = tpl_tys }) : rest)
-	-- Fast check for no match, uses the "rough match" fields
-      | instanceCantMatch rough_tcs mb_tcs
-      = find rest
-
-        -- Proper check
-      | tcEqTypes tpl_tys tys
-      = Just item
-
-        -- No match => try next
-      | otherwise
-      = find rest
--}
-\end{code}
-
 @lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.
 Multiple matches are only possible in case of type families (not data
 families), and then, it doesn't matter which match we choose (as the
 instances are guaranteed confluent).
 
 \begin{code}
-lookupFamInstEnv :: (FamInstEnv 	-- External package inst-env
-		    ,FamInstEnv) 	-- Home-package inst-env
+lookupFamInstEnv :: FamInstEnvs
 	         -> TyCon -> [Type]		-- What we are looking for
 	         -> [(TvSubst, FamInst)] 	-- Successful matches
 lookupFamInstEnv (pkg_ie, home_ie) fam tys