Fix an ASSERT failure in FamInstEnv

I added a lot of comments too, to explain the preconditions;
esp Note [FamInstEnv]

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index f6e76a7..eed3bf5 100644 (file)
--- 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
 
 \begin{code}
 type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances

+     -- See Note [FamInstEnv]

 
 type FamInstEnvs = (FamInstEnv, 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
 
 data FamilyInstEnv
   = FamIE [FamInst]    -- The instances for a particular family, in any order

@@ -233,6 +251,7 @@ lookupFamInstEnv
     :: FamInstEnvs
     -> TyCon -> [Type]         -- What we are looking for
     -> [FamInstMatch]          -- Successful matches
     :: 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
 
 lookupFamInstEnv
    = lookup_fam_inst_env match True

@@ -250,6 +269,8 @@ lookupFamInstEnvConflicts
 -- to find conflicting matches
 -- The skolem tyvars are needed because we don't have a 
 -- unique supply to hand
 -- 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'
 
 lookupFamInstEnvConflicts envs fam_inst skol_tvs
   = lookup_fam_inst_env my_unify False envs fam tys'

@@ -314,11 +335,14 @@ lookup_fam_inst_env             -- The worker, local to this module
     -> FamInstEnvs
     -> TyCon -> [Type]         -- What we are looking for
     -> [FamInstMatch]          -- Successful matches
     -> 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
 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 
     home_matches ++ pkg_matches
   where
     home_matches = lookup home_ie 

@@ -442,25 +466,28 @@ topNormaliseType env ty
 ---------------
 normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (CoercionI, Type)
 normaliseTcApp env tc tys
 ---------------
 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
        -- 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
 ---------------
 normaliseType :: FamInstEnvs           -- environment with family instances
              -> Type                   -- old type