projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Major bugfixing pass through the type checker
[ghc-hetmet.git] / compiler / types / FamInstEnv.lhs
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 50c827f..f6e76a7 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}
 
 
@@ -90,14 +88,23 @@ pprFamInst famInst
        2 (ptext (sLit "--") <+> pprNameLoc (getName famInst))
 
 pprFamInstHdr :: FamInst -> SDoc
        2 (ptext (sLit "--") <+> pprNameLoc (getName famInst))
 
 pprFamInstHdr :: FamInst -> SDoc
-pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
-  = pprTyConSort <+> pprHead
+pprFamInstHdr (FamInst {fi_tycon = rep_tc})
+  = pprTyConSort <+> pp_instance <+> pprHead
   where
   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"
+    Just (fam_tc, tys) = tyConFamInst_maybe rep_tc 
+    
+    -- For *associated* types, say "type T Int = blah" 
+    -- For *top level* type instances, say "type instance T Int = blah"
+    pp_instance 
+      | isTyConAssoc fam_tc = empty
+      | otherwise           = ptext (sLit "instance")
+
+    pprHead = pprTypeApp fam_tc tys
+    pprTyConSort | isDataTyCon     rep_tc = ptext (sLit "data")
+                | isNewTyCon      rep_tc = ptext (sLit "newtype")
+                | isSynTyCon      rep_tc = ptext (sLit "type")
+                | isAbstractTyCon rep_tc = ptext (sLit "data")
+                | otherwise              = panic "FamInstEnv.pprFamInstHdr"
 
 pprFamInsts :: [FamInst] -> SDoc
 pprFamInsts finsts = vcat (map pprFamInst finsts)
 
 pprFamInsts :: [FamInst] -> SDoc
 pprFamInsts finsts = vcat (map pprFamInst finsts)
@@ -228,7 +235,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 +252,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 +282,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,13 +305,17 @@ 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
-  | 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
   = []
   | otherwise
   = ASSERT( n_tys >= arity )   -- Family type applications must be saturated
@@ -323,7 +335,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
@@ -412,7 +424,7 @@ topNormaliseType env ty
                   | otherwise           = rec_nts
 
     go rec_nts (TyConApp tc tys)               -- Expand open tycons
                   | 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
        , (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 +445,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
   = 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
     in         -- Now try the top-level redex
     case lookupFamInstEnv env tc ntys of
                -- A matching family instance exists
@@ -464,16 +476,16 @@ normaliseType env (TyConApp tc tys)
 normaliseType env (AppTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
 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, mkAppTy nty1 nty2)
 normaliseType env (FunTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
 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, mkFunTy nty1 nty2)
 normaliseType env (ForAllTy tyvar ty1)
   = let (coi,nty1) = normaliseType env ty1
 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 _)
 normaliseType _   ty@(TyVarTy _)
-  = (IdCo,ty)
+  = (IdCo ty,ty)
 normaliseType env (PredTy predty)
   = normalisePred env predty
 
 normaliseType env (PredTy predty)
   = normalisePred env predty
 
@@ -481,12 +493,12 @@ normaliseType env (PredTy predty)
 normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)
 normalisePred env (ClassP cls tys)
   =    let (cois,tys') = mapAndUnzip (normaliseType env) tys
 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
 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}
 \end{code}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)