Super-monster patch implementing the new typechecker -- at last

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

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 50c827f..4cf33fc 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 Maybe
 \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 | 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)
@@ -228,7 +227,7 @@ 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
 
@@ -245,7 +244,7 @@ lookupFamInstEnvConflicts
 -- 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"
@@ -275,12 +274,13 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs
       | 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
-@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
@@ -297,13 +297,17 @@ type MatchFun =  FamInst          -- The FamInst template
              -> [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
+    -> OneSidedMatch
     -> FamInstEnvs
     -> TyCon -> [Type]         -- What we are looking for
     -> [FamInstMatch]          -- Successful matches
-lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys
-  | not (isOpenTyCon fam) 
+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
@@ -323,7 +327,7 @@ lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam 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
@@ -412,7 +416,7 @@ topNormaliseType env ty
                   | otherwise           = rec_nts
 
     go rec_nts (TyConApp tc tys)               -- Expand open tycons
-       | isOpenTyCon tc
+       | isFamilyTyCon tc
        , (ACo co, ty) <- normaliseTcApp env tc tys
        =       -- The ACo says "something happened"
                -- Note that normaliseType fully normalises, but it has do to so
@@ -433,7 +437,7 @@ normaliseTcApp env tc tys
   = let        -- First 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 ntys cois
+       tycon_coi    = mkTyConAppCoI tc cois
     in         -- Now try the top-level redex
     case lookupFamInstEnv env tc ntys of
                -- A matching family instance exists
@@ -464,16 +468,16 @@ normaliseType env (TyConApp tc tys)
 normaliseType env (AppTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
-    in  (mkAppTyCoI nty1 coi1 nty2 coi2, AppTy nty1 nty2)
+    in  (mkAppTyCoI coi1 coi2, AppTy nty1 nty2)
 normaliseType env (FunTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
-    in  (mkFunTyCoI nty1 coi1 nty2 coi2, FunTy nty1 nty2)
+    in  (mkFunTyCoI coi1 coi2, FunTy nty1 nty2)
 normaliseType env (ForAllTy tyvar ty1)
   = let (coi,nty1) = normaliseType env ty1
-    in  (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1)
+    in  (mkForAllTyCoI tyvar coi, ForAllTy tyvar nty1)
 normaliseType _   ty@(TyVarTy _)
-  = (IdCo,ty)
+  = (IdCo ty,ty)
 normaliseType env (PredTy predty)
   = normalisePred env predty
 
@@ -481,12 +485,12 @@ normaliseType env (PredTy predty)
 normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)
 normalisePred env (ClassP cls tys)
   =    let (cois,tys') = mapAndUnzip (normaliseType env) tys
-       in  (mkClassPPredCoI cls tys' cois, PredTy $ ClassP cls tys')
+       in  (mkClassPPredCoI cls cois, PredTy $ ClassP cls tys')
 normalisePred env (IParam ipn ty)
   =    let (coi,ty') = normaliseType env ty
        in  (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty')
 normalisePred env (EqPred ty1 ty2)
   =    let (coi1,ty1') = normaliseType env ty1
             (coi2,ty2') = normaliseType env ty2
-       in  (mkEqPredCoI ty1' coi1 ty2' coi2, PredTy $ EqPred ty1' ty2')
+       in  (mkEqPredCoI coi1 coi2, PredTy $ EqPred ty1' ty2')
 \end{code}