X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FFamInstEnv.lhs;h=f6e76a7161caebad2a4f798a0b92a80bb89f5675;hb=67ed735fab12c12a1d48878d7bda33588c67fb78;hp=4cf33fc4d748ab65edfcf84674caa21b63f3538c;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 4cf33fc..f6e76a7 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -88,15 +88,23 @@ pprFamInst famInst
 	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
-    pprHead = pprTypeApp fam tys
-    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"
+    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)
@@ -468,11 +476,11 @@ normaliseType env (TyConApp tc tys)
 normaliseType env (AppTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
-    in  (mkAppTyCoI coi1 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
-    in  (mkFunTyCoI coi1 coi2, FunTy nty1 nty2)
+    in  (mkFunTyCoI coi1 coi2, mkFunTy nty1 nty2)
 normaliseType env (ForAllTy tyvar ty1)
   = let (coi,nty1) = normaliseType env ty1
     in  (mkForAllTyCoI tyvar coi, ForAllTy tyvar nty1)