Fix warning about multiply exported name

[ghc-hetmet.git] / compiler / types / FamInstEnv.lhs

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 50c827f..89fd193 100644 (file)
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -36,8 +36,6 @@ import Outputable
 import Maybes
 import Util
 import FastString
 import Maybes
 import Util
 import FastString

-
-import Maybe

 \end{code}
 
 
 \end{code}
 
 

@@ -94,10 +92,11 @@ pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
   = pprTyConSort <+> pprHead
   where
     pprHead = pprTypeApp fam tys
   = pprTyConSort <+> pprHead
   where
     pprHead = pprTypeApp fam tys

-    pprTyConSort | isDataTyCon tycon = ptext (sLit "data instance")
-                | isNewTyCon  tycon = ptext (sLit "newtype instance")
-                | isSynTyCon  tycon = ptext (sLit "type instance")
-                | otherwise         = panic "FamInstEnv.pprFamInstHdr"
+    pprTyConSort | isDataTyCon     tycon = ptext (sLit "data instance")
+                | isNewTyCon      tycon = ptext (sLit "newtype instance")
+                | isSynTyCon      tycon = ptext (sLit "type instance")
+                | isAbstractTyCon tycon = ptext (sLit "data instance")
+                | otherwise             = panic "FamInstEnv.pprFamInstHdr"

 
 pprFamInsts :: [FamInst] -> SDoc
 pprFamInsts finsts = vcat (map pprFamInst finsts)
 
 pprFamInsts :: [FamInst] -> SDoc
 pprFamInsts finsts = vcat (map pprFamInst finsts)

@@ -228,7 +227,7 @@ lookupFamInstEnv
     -> [FamInstMatch]          -- Successful matches
 
 lookupFamInstEnv
     -> [FamInstMatch]          -- Successful matches
 
 lookupFamInstEnv

-   = lookup_fam_inst_env match
+   = lookup_fam_inst_env match True

    where
      match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys
 
    where
      match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys
 

@@ -245,7 +244,7 @@ lookupFamInstEnvConflicts
 -- unique supply to hand
 
 lookupFamInstEnvConflicts envs fam_inst skol_tvs
 -- unique supply to hand
 
 lookupFamInstEnvConflicts envs fam_inst skol_tvs

-  = lookup_fam_inst_env my_unify envs fam tys'
+  = lookup_fam_inst_env my_unify False envs fam tys'

   where
     inst_tycon = famInstTyCon fam_inst
     (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts"
   where
     inst_tycon = famInstTyCon fam_inst
     (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts"

@@ -275,12 +274,13 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs
       | otherwise      = not (old_rhs `tcEqType` new_rhs)
       where
         old_tycon = famInstTyCon old_fam_inst
       | otherwise      = not (old_rhs `tcEqType` new_rhs)
       where
         old_tycon = famInstTyCon old_fam_inst

-        old_rhs   = mkTyConApp old_tycon (substTyVars subst (tyConTyVars old_tycon))
+        old_tvs   = tyConTyVars old_tycon
+        old_rhs   = mkTyConApp old_tycon  (substTyVars subst old_tvs)

         new_rhs   = mkTyConApp inst_tycon (substTyVars subst skol_tvs)
 \end{code}
 
 While @lookupFamInstEnv@ uses a one-way match, the next function
         new_rhs   = mkTyConApp inst_tycon (substTyVars subst skol_tvs)
 \end{code}
 
 While @lookupFamInstEnv@ uses a one-way match, the next function

-@lookupFamInstEnvUnify@ uses two-way matching (ie, unification).  This is
+@lookupFamInstEnvConflicts@ uses two-way matching (ie, unification).  This is

 needed to check for overlapping instances.
 
 For class instances, these two variants of lookup are combined into one
 needed to check for overlapping instances.
 
 For class instances, these two variants of lookup are combined into one

@@ -297,12 +297,16 @@ type MatchFun =  FamInst          -- The FamInst template
              -> [Type]                 -- Target to match against
              -> Maybe TvSubst
 
              -> [Type]                 -- Target to match against
              -> Maybe TvSubst
 

+type OneSidedMatch = Bool     -- Are optimisations that are only valid for
+                              -- one sided matches allowed?
+

 lookup_fam_inst_env          -- The worker, local to this module
     :: MatchFun
 lookup_fam_inst_env          -- The worker, local to this module
     :: MatchFun

+    -> OneSidedMatch

     -> FamInstEnvs
     -> TyCon -> [Type]         -- What we are looking for
     -> [FamInstMatch]          -- Successful matches
     -> FamInstEnvs
     -> TyCon -> [Type]         -- What we are looking for
     -> [FamInstMatch]          -- Successful matches

-lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys
+lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys

   | not (isOpenTyCon fam) 
   = []
   | otherwise
   | not (isOpenTyCon fam) 
   = []
   | otherwise

@@ -323,7 +327,7 @@ lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys
 
     --------------
     rough_tcs = roughMatchTcs match_tys
 
     --------------
     rough_tcs = roughMatchTcs match_tys

-    all_tvs   = all isNothing rough_tcs
+    all_tvs   = all isNothing rough_tcs && one_sided

 
     --------------
     lookup env = case lookupUFM env fam of
 
     --------------
     lookup env = case lookupUFM env fam of