Revised signature of tcLookupFamInst and lookupFamInstEnv

- This changes the signature of FamInstEnv.lookupFamInstEnv and
  FamInstEnv.lookupFamInstEnvUnify in a manner similar to SPJ's
  previous patch for InstEnv.llokupInstEnv
- tcLookupFamInst now permits the lookup of instances that are more
  general than the type instance requested.

diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index a7b613d..9f03adf 100644 (file)
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -274,10 +274,9 @@ mkCase :: LibCaseEnv -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
 -- See Note [Indexed data types]
 mkCase env scrut bndr ty [(DEFAULT,_,rhs)]
   | Just (tycon, tys)   <- splitTyConApp_maybe (idType bndr)
 -- See Note [Indexed data types]
 mkCase env scrut bndr ty [(DEFAULT,_,rhs)]
   | Just (tycon, tys)   <- splitTyConApp_maybe (idType bndr)

-  , [(subst, fam_inst)] <- lookupFamInstEnv (lc_fams env) tycon tys
+  , [(fam_inst, rep_tys)] <- lookupFamInstEnv (lc_fams env) tycon tys

   = let 
        rep_tc     = famInstTyCon fam_inst
   = let 
        rep_tc     = famInstTyCon fam_inst

-       rep_tys    = map (substTyVar subst) (tyConTyVars rep_tc)

        bndr'      = setIdType bndr (mkTyConApp rep_tc rep_tys)
        Just co_tc = tyConFamilyCoercion_maybe rep_tc
        co         = mkTyConApp co_tc rep_tys
        bndr'      = setIdType bndr (mkTyConApp rep_tc rep_tys)
        Just co_tc = tyConFamilyCoercion_maybe rep_tc
        co         = mkTyConApp co_tc rep_tys

diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index fd98fe9..f85f6b9 100644 (file)
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -180,7 +180,7 @@ checkForConflicts inst_envs famInst
 
        ; let { matches   = lookupFamInstEnvUnify inst_envs fam tys'
             ; conflicts = [ conflictingFamInst
 
        ; let { matches   = lookupFamInstEnvUnify inst_envs fam tys'
             ; conflicts = [ conflictingFamInst

-                          | match@(_, conflictingFamInst) <- matches
+                          | match@(conflictingFamInst, _) <- matches

                           , conflicting fam tys' tycon match 
                           ]
             }
                           , conflicting fam tys' tycon match 
                           ]
             }

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 1a9a881..4e1a065 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -47,6 +47,8 @@ import Util
 import ListSetOps
 import Outputable
 import Bag
 import ListSetOps
 import Outputable
 import Bag

+
+import Monad (unless)

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -395,7 +397,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app
              full_tc_args = tc_args ++ mkTyVarTys extra_tvs
              full_tvs = tvs ++ extra_tvs
                
              full_tc_args = tc_args ++ mkTyVarTys extra_tvs
              full_tvs = tvs ++ extra_tvs
                

-       ; (rep_tc, rep_tc_args) <- tcLookupFamInst tycon full_tc_args
+       ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args

 
        ; gla_exts <- doptM Opt_GlasgowExts
        ; overlap_flag <- getOverlapFlag
 
        ; gla_exts <- doptM Opt_GlasgowExts
        ; overlap_flag <- getOverlapFlag

@@ -415,6 +417,27 @@ mkEqnHelp orig tvs cls cls_tys tc_app
 baleOut err = addErrTc err >> returnM (Nothing, Nothing) 
 \end{code}
 
 baleOut err = addErrTc err >> returnM (Nothing, Nothing) 
 \end{code}
 

+Auxiliary lookup wrapper which requires that looked up family instances are
+not type instances.
+
+\begin{code}
+tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
+tcLookupFamInstExact tycon tys
+  = do { result@(rep_tycon, rep_tys) <- tcLookupFamInst tycon tys
+       ; let { tvs                   = map (Type.getTyVar 
+                                               "TcDeriv.tcLookupFamInstExact") 
+                                           tys
+            ; variable_only_subst = all Type.isTyVarTy rep_tys &&
+                                    sizeVarSet (mkVarSet tvs) == length tvs
+                                       -- renaming may have no repetitions
+             }
+       ; unless variable_only_subst $
+           famInstNotFound tycon tys [result]
+       ; return result
+       }
+       
+\end{code}
+

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -980,7 +1003,7 @@ genInst spec
 
           -- In case of a family instance, we need to use the representation
           -- tycon (after all, it has the data constructors)
 
           -- In case of a family instance, we need to use the representation
           -- tycon (after all, it has the data constructors)

-        ; (tycon, _) <- tcLookupFamInst visible_tycon tyArgs
+        ; (tycon, _) <- tcLookupFamInstExact visible_tycon tyArgs

        ; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
 
        -- Bring the right type variables into 
        ; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
 
        -- Bring the right type variables into 

diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 787616a..0f9bf23 100644 (file)
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -42,7 +42,10 @@ module TcEnv(
        topIdLvl, 
 
        -- New Ids
        topIdLvl, 
 
        -- New Ids

-       newLocalName, newDFunName, newFamInstTyConName
+       newLocalName, newDFunName, newFamInstTyConName,
+
+        -- Errors
+        famInstNotFound

   ) where
 
 #include "HsVersions.h"
   ) where
 
 #include "HsVersions.h"

@@ -159,7 +162,21 @@ tcLookupLocatedTyCon :: Located Name -> TcM TyCon
 tcLookupLocatedTyCon = addLocM tcLookupTyCon
 
 -- Look up the representation tycon of a family instance.
 tcLookupLocatedTyCon = addLocM tcLookupTyCon
 
 -- Look up the representation tycon of a family instance.

--- Return the rep tycon and the corresponding rep args
+--
+-- The match must be unique - ie, match exactly one instance - but the 
+-- type arguments used for matching may be more specific than those of 
+-- the family instance declaration.
+--
+-- Return the instance tycon and its type instance.  For example, if we have
+--
+--  tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
+--
+-- then we have a coercion (ie, type instance of family instance coercion)
+--
+--  :Co:R42T Int :: T [Int] ~ :R42T Int
+--
+-- which implies that :R42T was declared as 'data instance T [a]'.
+--

 tcLookupFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
 tcLookupFamInst tycon tys
   | not (isOpenTyCon tycon)
 tcLookupFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
 tcLookupFamInst tycon tys
   | not (isOpenTyCon tycon)

@@ -169,20 +186,8 @@ tcLookupFamInst tycon tys
        ; eps <- getEps
        ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
        ; case lookupFamInstEnv instEnv tycon tys of
        ; eps <- getEps
        ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
        ; case lookupFamInstEnv instEnv tycon tys of

-
-          [(subst, fam_inst)] | variable_only_subst -> 
-            return (rep_tc, substTyVars subst (tyConTyVars rep_tc))
-               where   -- NB: assumption is that (tyConTyVars rep_tc) is in 
-                       --     the domain of the substitution
-                 rep_tc              = famInstTyCon fam_inst
-                 subst_domain        = varEnvElts . getTvSubstEnv $ subst
-                 tvs                 = map (Type.getTyVar "tcLookupFamInst") 
-                                           subst_domain
-                 variable_only_subst = all Type.isTyVarTy subst_domain &&
-                                       sizeVarSet (mkVarSet tvs) == length tvs
-                                       -- renaming may have no repetitions
-
-          other -> famInstNotFound tycon tys other
+          [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
+          other                 -> famInstNotFound tycon tys other

        }
 \end{code}
 
        }
 \end{code}
 

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 481c680..b8c82f8 100644 (file)
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -198,10 +198,24 @@ 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).
 
 families), and then, it doesn't matter which match we choose (as the
 instances are guaranteed confluent).
 

+We return the matching family instances and the type instance at which it
+matches.  For example, if we lookup 'T [Int]' and have a family instance
+
+  data instance T [a] = ..
+
+desugared to
+
+  data :R42T a = ..
+  coe :Co:R42T a :: T [a] ~ :R42T a
+
+we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.
+

 \begin{code}
 \begin{code}

+type FamInstMatch = (FamInst, [Type])           -- Matching type instance
+

 lookupFamInstEnv :: FamInstEnvs
                 -> TyCon -> [Type]             -- What we are looking for
 lookupFamInstEnv :: FamInstEnvs
                 -> TyCon -> [Type]             -- What we are looking for

-                -> [(TvSubst, FamInst)]        -- Successful matches
+                -> [FamInstMatch]              -- Successful matches

 lookupFamInstEnv (pkg_ie, home_ie) fam tys
   = home_matches ++ pkg_matches
   where
 lookupFamInstEnv (pkg_ie, home_ie) fam tys
   = home_matches ++ pkg_matches
   where

@@ -231,7 +245,7 @@ lookupFamInstEnv (pkg_ie, home_ie) fam tys
 
         -- Proper check
       | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
 
         -- Proper check
       | Just subst <- tcMatchTys tpl_tvs tpl_tys tys

-      = (subst, item) : find rest
+      = (item, substTyVars subst (tyConTyVars tycon)) : find rest

 
         -- No match => try next
       | otherwise
 
         -- No match => try next
       | otherwise

@@ -250,7 +264,7 @@ indexed synonyms and we don't want to slow that down by needless unification.
 
 \begin{code}
 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
 
 \begin{code}
 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]

-                     -> [(TvSubst, FamInst)]
+                     -> [(FamInstMatch)]

 lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
   = home_matches ++ pkg_matches
   where
 lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
   = home_matches ++ pkg_matches
   where

@@ -286,7 +300,9 @@ lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
                -- Unification will break badly if the variables overlap
                -- They shouldn't because we allocate separate uniques for them
         case tcUnifyTys bind_fn tpl_tys tys of
                -- Unification will break badly if the variables overlap
                -- They shouldn't because we allocate separate uniques for them
         case tcUnifyTys bind_fn tpl_tys tys of

-           Just subst -> (subst, item) : find rest
+           Just subst -> let rep_tys = substTyVars subst (tyConTyVars tycon)
+                          in
+                          (item, rep_tys) : find rest

            Nothing    -> find rest
 
 -- See explanation at @InstEnv.bind_fn@.
            Nothing    -> find rest
 
 -- See explanation at @InstEnv.bind_fn@.