X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FFamInstEnv.lhs;h=93a67a7eddc17417e9ed7fb1fed3c0c8039d5cc5;hb=ada48bbc7f6a43b2c042df629327902d82cea681;hp=7f698ded3f91cb8d2f26e5b100efbf9d936c81e0;hpb=89e484f7a0e0c5b6a394b93631abfbeb51850c6c;p=ghc-hetmet.git

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 7f698de..93a67a7 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -155,13 +155,31 @@ mkImportedFamInst fam mb_tcs tycon
 %*									*
 %************************************************************************
 
-InstEnv maps a family name to the list of known instances for that family.
+Note [FamInstEnv]
+~~~~~~~~~~~~~~~~~~~~~
+A FamInstEnv maps a family name to the list of known instances for that family.
+
+The same FamInstEnv includes both 'data family' and 'type family' instances.
+Type families are reduced during type inference, but not data families;
+the user explains when to use a data family instance by using contructors
+and pattern matching.
+
+Neverthless it is still useful to have data families in the FamInstEnv:
+
+ - For finding overlaps and conflicts
+
+ - For finding the representation type...see FamInstEnv.topNormaliseType
+   and its call site in Simplify
+
+ - In standalone deriving instance Eq (T [Int]) we need to find the 
+   representation type for T [Int]
 
 \begin{code}
 type FamInstEnv = UniqFM FamilyInstEnv	-- Maps a family to its instances
+     -- See Note [FamInstEnv]
 
 type FamInstEnvs = (FamInstEnv, FamInstEnv)
- 	-- External package inst-env, Home-package inst-env
+     -- External package inst-env, Home-package inst-env
 
 data FamilyInstEnv
   = FamIE [FamInst]	-- The instances for a particular family, in any order
@@ -169,6 +187,9 @@ data FamilyInstEnv
 			-- 	If *not* then the common case of looking up
 			--	(T a b c) can fail immediately
 
+instance Outputable FamilyInstEnv where
+  ppr (FamIE fs b) = ptext (sLit "FamIE") <+> ppr b <+> vcat (map ppr fs)
+
 -- INVARIANTS:
 --  * The fs_tvs are distinct in each FamInst
 --	of a range value of the map (so we can safely unify them)
@@ -233,6 +254,7 @@ lookupFamInstEnv
     :: FamInstEnvs
     -> TyCon -> [Type]		-- What we are looking for
     -> [FamInstMatch] 	        -- Successful matches
+-- Precondition: the tycon is saturated (or over-saturated)
 
 lookupFamInstEnv
    = lookup_fam_inst_env match True
@@ -250,6 +272,8 @@ lookupFamInstEnvConflicts
 -- to find conflicting matches
 -- The skolem tyvars are needed because we don't have a 
 -- unique supply to hand
+--
+-- Precondition: the tycon is saturated (or over-saturated)
 
 lookupFamInstEnvConflicts envs fam_inst skol_tvs
   = lookup_fam_inst_env my_unify False envs fam tys'
@@ -314,11 +338,14 @@ lookup_fam_inst_env 	      -- The worker, local to this module
     -> FamInstEnvs
     -> TyCon -> [Type]		-- What we are looking for
     -> [FamInstMatch] 	        -- Successful matches
+
+-- Precondition: the tycon is saturated (or over-saturated)
+
 lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys
   | not (isFamilyTyCon fam) 
   = []
   | otherwise
-  = ASSERT( n_tys >= arity )	-- Family type applications must be saturated
+  = ASSERT2( n_tys >= arity, ppr fam <+> ppr tys )	-- Family type applications must be saturated
     home_matches ++ pkg_matches
   where
     home_matches = lookup home_ie 
@@ -442,25 +469,28 @@ topNormaliseType env ty
 ---------------
 normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (CoercionI, Type)
 normaliseTcApp env tc tys
-  = let	-- First normalise the arg types so that they'll match 
+  | isFamilyTyCon tc
+  , tyConArity tc <= length tys	   -- Unsaturated data families are possible
+  , [(fam_inst, inst_tys)] <- lookupFamInstEnv env tc ntys 
+  = let    -- A matching family instance exists
+	rep_tc         	= famInstTyCon fam_inst
+	co_tycon       	= expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc)
+	co	       	= mkTyConApp co_tycon inst_tys
+	first_coi      	= mkTransCoI tycon_coi (ACo co)
+	(rest_coi, nty) = normaliseType env (mkTyConApp rep_tc inst_tys)
+	fix_coi         = mkTransCoI first_coi rest_coi
+    in 
+    (fix_coi, nty)
+
+  | otherwise
+  = (tycon_coi, TyConApp tc ntys)
+
+  where
+	-- Normalise the arg types so that they'll match 
 	-- when we lookup in in the instance envt
-	(cois, ntys) = mapAndUnzip (normaliseType env) tys
-	tycon_coi    = mkTyConAppCoI tc cois
-    in 	-- Now try the top-level redex
-    case lookupFamInstEnv env tc ntys of
-		-- A matching family instance exists
-	[(fam_inst, tys)] -> (fix_coi, nty)
-	    where
-		rep_tc         = famInstTyCon fam_inst
-		co_tycon       = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc)
-		co	       = mkTyConApp co_tycon tys
-		first_coi      = mkTransCoI tycon_coi (ACo co)
-		(rest_coi,nty) = normaliseType env (mkTyConApp rep_tc tys)
-		fix_coi        = mkTransCoI first_coi rest_coi
-
-		-- No unique matching family instance exists;
-		-- we do not do anything
-	_ -> (tycon_coi, TyConApp tc ntys)
+    (cois, ntys) = mapAndUnzip (normaliseType env) tys
+    tycon_coi    = mkTyConAppCoI tc cois
+
 ---------------
 normaliseType :: FamInstEnvs 		-- environment with family instances
 	      -> Type  			-- old type
@@ -476,11 +506,11 @@ normaliseType env (TyConApp tc tys)
 normaliseType env (AppTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
-    in  (mkAppTyCoI coi1 coi2, AppTy nty1 nty2)
+    in  (mkAppTyCoI coi1 coi2, mkAppTy nty1 nty2)
 normaliseType env (FunTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
-    in  (mkFunTyCoI coi1 coi2, FunTy nty1 nty2)
+    in  (mkFunTyCoI coi1 coi2, mkFunTy nty1 nty2)
 normaliseType env (ForAllTy tyvar ty1)
   = let (coi,nty1) = normaliseType env ty1
     in  (mkForAllTyCoI tyvar coi, ForAllTy tyvar nty1)