First implementation complete. Closed type families are accepted.

But, they don't work at all, as expected. Need to do more tests now.

compiler/deSugar/DsMeta.hs

@@ -265,17 +265,26 @@ repSynDecl tc bndrs ty
        ; repTySyn tc bndrs ty1 }
 
 repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
-repFamilyDecl (L loc (FamilyDecl { fdFlavour = flavour,
+repFamilyDecl (L loc (FamilyDecl { fdInfo    = info,
                                    fdLName   = tc,
                                    fdTyVars  = tvs, 
 		                   fdKindSig = opt_kind }))
   = do { tc1 <- lookupLOcc tc 		-- See note [Binders and occurrences] 
        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
-           do { flav <- repFamilyFlavour flavour
-	      ; case opt_kind of 
-                  Nothing -> repFamilyNoKind flav tc1 bndrs
-                  Just ki -> do { ki1 <- repLKind ki 
-                                ; repFamilyKind flav tc1 bndrs ki1 }
+           do { info' <- repFamilyInfo info
+	      ; case (opt_kind, info) of 
+                  (Nothing, ClosedTypeFamily eqns) ->
+                    do { eqns1 <- mapM repTyFamEqn eqns
+                       ; eqns2 <- coreList tySynEqnQTyConName eqns1
+                       ; repClosedFamilyNoKind tc1 bndrs eqns2 }
+                  (Just ki, ClosedTypeFamily eqns) ->
+                    do { eqns1 <- mapM repTyFamEqn eqns
+                       ; eqns2 <- coreList tySynEqnQTyConName eqns1
+                       ; ki1 <- repLKind ki
+                       ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }              
+                  (Nothing, _) -> repFamilyNoKind info' tc1 bndrs
+                  (Just ki, _) -> do { ki1 <- repLKind ki 
+                                ; repFamilyKind info' tc1 bndrs ki1 }
               }
        ; return (loc, dec)
        }
@@ -324,9 +333,10 @@ repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
 
 -- represent family declaration flavours
 --
-repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
-repFamilyFlavour TypeFamily = rep2 typeFamName []
-repFamilyFlavour DataFamily = rep2 dataFamName []
+repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
+repFamilyInfo OpenTypeFamily      = rep2 typeFamName []
+repFamilyInfo DataFamily          = rep2 dataFamName []
+repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
 
 -- Represent instance declarations
 --
@@ -369,12 +379,11 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
    Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
 
 repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
-repTyFamInstD decl@(TyFamInstDecl { tfid_eqns = eqns })
+repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
   = do { let tc_name = tyFamInstDeclLName decl
        ; tc <- lookupLOcc tc_name		-- See note [Binders and occurrences]  
-       ; eqns1 <- mapM repTyFamEqn eqns
-       ; eqns2 <- coreList tySynEqnQTyConName eqns1
-       ; repTySynInst tc eqns2 }
+       ; eqn1 <- repTyFamEqn eqn
+       ; repTySynInst tc eqn1 }
 
 repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
 repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys
@@ -1695,9 +1704,24 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
     = rep2 familyKindDName [flav, nm, tvs, ki]
 
-repTySynInst :: Core TH.Name -> Core [TH.TySynEqnQ] -> DsM (Core TH.DecQ)
-repTySynInst (MkC nm) (MkC eqns)
-  = rep2 tySynInstDName [nm, eqns]
+repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
+repTySynInst (MkC nm) (MkC eqn)
+    = rep2 tySynInstDName [nm, eqn]
+
+repClosedFamilyNoKind :: Core TH.Name
+                      -> Core [TH.TyVarBndr]
+                      -> Core [TH.TySynEqnQ]
+                      -> DsM (Core TH.DecQ)
+repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns)
+    = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns]
+
+repClosedFamilyKind :: Core TH.Name
+                    -> Core [TH.TyVarBndr]
+                    -> Core TH.Kind
+                    -> Core [TH.TySynEqnQ]
+                    -> DsM (Core TH.DecQ)
+repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns)
+    = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns]
 
 repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
 repTySynEqn (MkC lhs) (MkC rhs)
@@ -2001,7 +2025,8 @@ templateHaskellNames = [
     pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
     pragRuleDName,
     familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
-    tySynInstDName, infixLDName, infixRDName, infixNDName,
+    tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
+    infixLDName, infixRDName, infixNDName,
     -- Cxt
     cxtName,
     -- Pred
@@ -2214,6 +2239,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
     pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName,
     familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
+    closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
     infixLDName, infixRDName, infixNDName :: Name
 funDName          = libFun (fsLit "funD")          funDIdKey
 valDName          = libFun (fsLit "valD")          valDIdKey
@@ -2234,6 +2260,10 @@ familyKindDName   = libFun (fsLit "familyKindD")   familyKindDIdKey
 dataInstDName     = libFun (fsLit "dataInstD")     dataInstDIdKey
 newtypeInstDName  = libFun (fsLit "newtypeInstD")  newtypeInstDIdKey
 tySynInstDName    = libFun (fsLit "tySynInstD")    tySynInstDIdKey
+closedTypeFamilyKindDName
+                  = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey
+closedTypeFamilyNoKindDName
+                  = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey
 infixLDName       = libFun (fsLit "infixLD")       infixLDIdKey
 infixRDName       = libFun (fsLit "infixRD")       infixRDIdKey
 infixNDName       = libFun (fsLit "infixND")       infixNDIdKey
@@ -2550,29 +2580,32 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
     pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
     familyNoKindDIdKey, familyKindDIdKey,
     dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
+    closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,
     infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
-funDIdKey          = mkPreludeMiscIdUnique 330
-valDIdKey          = mkPreludeMiscIdUnique 331
-dataDIdKey         = mkPreludeMiscIdUnique 332
-newtypeDIdKey      = mkPreludeMiscIdUnique 333
-tySynDIdKey        = mkPreludeMiscIdUnique 334
-classDIdKey        = mkPreludeMiscIdUnique 335
-instanceDIdKey     = mkPreludeMiscIdUnique 336
-sigDIdKey          = mkPreludeMiscIdUnique 337
-forImpDIdKey       = mkPreludeMiscIdUnique 338
-pragInlDIdKey      = mkPreludeMiscIdUnique 339
-pragSpecDIdKey     = mkPreludeMiscIdUnique 340
-pragSpecInlDIdKey  = mkPreludeMiscIdUnique 341
-pragSpecInstDIdKey = mkPreludeMiscIdUnique 412
-pragRuleDIdKey     = mkPreludeMiscIdUnique 413
-familyNoKindDIdKey = mkPreludeMiscIdUnique 342
-familyKindDIdKey   = mkPreludeMiscIdUnique 343
-dataInstDIdKey     = mkPreludeMiscIdUnique 344
-newtypeInstDIdKey  = mkPreludeMiscIdUnique 345
-tySynInstDIdKey    = mkPreludeMiscIdUnique 346
-infixLDIdKey       = mkPreludeMiscIdUnique 347
-infixRDIdKey       = mkPreludeMiscIdUnique 348
-infixNDIdKey       = mkPreludeMiscIdUnique 349
+funDIdKey                    = mkPreludeMiscIdUnique 330
+valDIdKey                    = mkPreludeMiscIdUnique 331
+dataDIdKey                   = mkPreludeMiscIdUnique 332
+newtypeDIdKey                = mkPreludeMiscIdUnique 333
+tySynDIdKey                  = mkPreludeMiscIdUnique 334
+classDIdKey                  = mkPreludeMiscIdUnique 335
+instanceDIdKey               = mkPreludeMiscIdUnique 336
+sigDIdKey                    = mkPreludeMiscIdUnique 337
+forImpDIdKey                 = mkPreludeMiscIdUnique 338
+pragInlDIdKey                = mkPreludeMiscIdUnique 339
+pragSpecDIdKey               = mkPreludeMiscIdUnique 340
+pragSpecInlDIdKey            = mkPreludeMiscIdUnique 341
+pragSpecInstDIdKey           = mkPreludeMiscIdUnique 412
+pragRuleDIdKey               = mkPreludeMiscIdUnique 413
+familyNoKindDIdKey           = mkPreludeMiscIdUnique 342
+familyKindDIdKey             = mkPreludeMiscIdUnique 343
+dataInstDIdKey               = mkPreludeMiscIdUnique 344
+newtypeInstDIdKey            = mkPreludeMiscIdUnique 345
+tySynInstDIdKey              = mkPreludeMiscIdUnique 346
+closedTypeFamilyKindDIdKey   = mkPreludeMiscIdUnique 347
+closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 348
+infixLDIdKey                 = mkPreludeMiscIdUnique 349
+infixRDIdKey                 = mkPreludeMiscIdUnique 350
+infixNDIdKey                 = mkPreludeMiscIdUnique 351
 
 -- type Cxt = ...
 cxtIdKey :: Unique

compiler/hsSyn/Convert.lhs

@@ -215,7 +215,7 @@ cvtDec (FamilyD flav tc tvs kind)
        ; kind' <- cvtMaybeKind kind
        ; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) }
   where
-    cvtFamFlavour TypeFam = TypeFamily
+    cvtFamFlavour TypeFam = OpenTypeFamily
     cvtFamFlavour DataFam = DataFamily
 
 cvtDec (DataInstD ctxt tc tys constrs derivs)
@@ -243,13 +243,18 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
            { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
                                          , dfid_defn = defn, dfid_fvs = placeHolderNames } }}
 
-cvtDec (TySynInstD tc eqns)
+cvtDec (TySynInstD tc eqn)
   = do  { tc' <- tconNameL tc
-        ; eqns' <- mapM (cvtTySynEqn tc') eqns
+        ; eqn' <- cvtTySynEqn tc' eqn
         ; returnL $ InstD $ TyFamInstD
-            { tfid_inst = TyFamInstDecl { tfid_eqns = eqns'
-                                        , tfid_group = (length eqns' /= 1)
+            { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
                                         , tfid_fvs = placeHolderNames } } }
+
+cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
+  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars
+       ; mkind' <- cvtMaybeKind mkind
+       ; eqns' <- mapM (cvtTySynEqn tc') eqns
+       ; returnL $ TyClD (FamDecl (FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind')) }
 ----------------
 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
 cvtTySynEqn tc (TySynEqn lhs rhs)

compiler/hsSyn/HsDecls.lhs

@@ -618,6 +618,9 @@ pprFlavour DataFamily            = ptext (sLit "data family")
 pprFlavour OpenTypeFamily        = ptext (sLit "type family")
 pprFlavour (ClosedTypeFamily {}) = ptext (sLit "type family")
 
+instance Outputable (FamilyInfo name) where
+  ppr = pprFlavour
+
 pp_vanilla_decl_head :: OutputableBndr name
    => Located name
    -> LHsTyVarBndrs name

compiler/iface/MkIface.lhs

@@ -311,7 +311,6 @@ mkIface_ hsc_env maybe_old_fingerprint
                         mi_warn_fn     = mkIfaceWarnCache warns,
                         mi_fix_fn      = mkIfaceFixCache fixities }
                 }
-
         ; (new_iface, no_change_at_all) 
                 <- {-# SCC "versioninfo" #-}
                          addFingerprints hsc_env maybe_old_fingerprint

compiler/main/HscTypes.lhs

@@ -1280,10 +1280,12 @@ implicitTyConThings tc
 extras_plus :: TyThing -> [TyThing]
 extras_plus thing = thing : implicitTyThings thing
 
--- For newtypes (only) add the implicit coercion tycon
+-- For newtypes and closed type families (only) add the implicit coercion tycon
 implicitCoTyCon :: TyCon -> [TyThing]
 implicitCoTyCon tc
   | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co]
+  | Just co <- isClosedSynFamilyTyCon_maybe tc
+                                   = [ACoAxiom co]
   | otherwise                      = []
 
 -- | Returns @True@ if there should be no interface-file declaration

compiler/main/PprTyThing.hs

@@ -175,13 +175,13 @@ pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc
 pprTyCon pefas ss tyCon
   | Just syn_rhs <- GHC.synTyConRhs_maybe tyCon
   = case syn_rhs of
-      IfaceOpenSynFamilyTyCon -> pprTyConHdr pefas tyCon <+> dcolon <+> 
+      OpenSynFamilyTyCon -> pprTyConHdr pefas tyCon <+> dcolon <+> 
                                  pprTypeForUser pefas (GHC.synTyConResKind tyCon)
-      IfaceClosedSynFamilyTyCon ax ->
+      ClosedSynFamilyTyCon ax ->
         hang (pprTyConHdr pefas tyCon <+> dcolon <+>
               pprTypeForUser pefas (GHC.synTyConResKind tyCon) <+> equals)
            2 (ppr ax)
-      IfaceSynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) 
+      SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) 
                                      2 (ppr rhs_ty)   -- Don't suppress foralls on RHS type!
                                                  -- e.g. type T = forall a. a->a
   | Just cls <- GHC.tyConClass_maybe tyCon

compiler/typecheck/FamInst.lhs

@@ -65,6 +65,7 @@ newFamInst flavor axiom@(CoAxiom { co_ax_branches = FirstBranch branch
                          , fi_tcs      = roughMatchTcs lhs
                          , fi_tvs      = tvs'
                          , fi_tys      = substTys subst lhs
+                         , fi_rhs      = substTy  subst rhs
                          , fi_axiom    = axiom }) }
   where
     fam_tc_name = tyConName fam_tc
@@ -236,10 +237,8 @@ tcLookupDataFamInst tycon tys
        ; case maybeFamInst of
            Nothing             -> famInstNotFound tycon tys
            Just (FamInstMatch { fim_instance = famInst
-                              , fim_index    = index
                               , fim_tys      = tys })
-             -> ASSERT( index == 0 )
-                let tycon' = dataFamInstRepTyCon famInst
+             -> let tycon' = dataFamInstRepTyCon famInst
                 in return (tycon', tys) }
 
 famInstNotFound :: TyCon -> [Type] -> TcM a
@@ -339,7 +338,7 @@ environments (one for the EPS and one for the HPT).
 checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool
 checkForConflicts inst_envs fam_inst
   = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst
-             no_conflicts = all null conflicts
+             no_conflicts = null conflicts
        ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs)
        ; unless no_conflicts $ conflictInstErr fam_inst conflicts
        ; return no_conflicts }
@@ -362,7 +361,7 @@ addFamInstsErr herald insts
  where
    getSpan   = getSrcLoc . famInstAxiom
    sorted    = sortWith getSpan insts
-   (fi1,ix1) = head sorted
+   fi1       = head sorted
    srcSpan   = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))
    -- The sortWith just arranges that instances are dislayed in order
    -- of source location, which reduced wobbling in error messages,

compiler/typecheck/TcDeriv.lhs

@@ -46,7 +46,6 @@ import RdrName
 import Name
 import NameSet
 import TyCon
-import CoAxiom
 import TcType
 import Var
 import VarSet
@@ -551,8 +550,9 @@ deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats
                                     , dfid_defn = HsDataDefn { dd_derivs = Just preds } })
   = tcAddDataFamInstCtxt decl $
     do { fam_tc <- tcLookupTyCon tc_name
-       ; tcFamTyPats fam_tc pats (\_ -> return ()) $ \ tvs' pats' _ ->
-         mapM (deriveTyData tvs' fam_tc pats') preds }
+       ; tcFamTyPats tc_name (tyConKind fam_tc) pats (\_ -> return ()) $
+         \ tvs' pats' _ ->
+           mapM (deriveTyData tvs' fam_tc pats') preds }
         -- Tiresomely we must figure out the "lhs", which is awkward for type families
         -- E.g.   data T a b = .. deriving( Eq )
         --          Here, the lhs is (T a b)

compiler/typecheck/TcExpr.lhs

@@ -1245,9 +1245,8 @@ tcTagToEnum loc fun_name arg res_ty
            ; case mb_fam of 
 	       Nothing -> failWithTc (tagToEnumError ty doc3)
                Just (FamInstMatch { fim_instance = rep_fam
-                                  , fim_index    = index
                                   , fim_tys      = rep_args })
-                   -> return ( mkTcSymCo (mkTcAxInstCo co_tc index rep_args)
+                   -> return ( mkTcSymCo (mkTcUnbranchedAxInstCo co_tc rep_args)
                              , rep_tc, rep_args )
                  where
                    co_tc  = famInstAxiom rep_fam

compiler/typecheck/TcGenDeriv.lhs

@@ -51,7 +51,6 @@ import PrelNames hiding (error_RDR)
 import PrimOp
 import SrcLoc
 import TyCon
-import CoAxiom
 import TcType
 import TysPrim
 import TysWiredIn

compiler/typecheck/TcGenGenerics.lhs

@@ -27,7 +27,6 @@ import TcType
 import TcGenDeriv
 import DataCon
 import TyCon
-import CoAxiom
 import Coercion         ( mkSingleCoAxiom )
 import FamInstEnv       ( FamInst, FamFlavor(..) )
 import FamInst
@@ -445,7 +444,7 @@ tc_mkRepFamInsts gk tycon metaDts mod =
                         (nameSrcSpan (tyConName tycon))
 
      ; let axiom = mkSingleCoAxiom rep_name tyvars fam_tc appT repTy
-     ; newFamInst OpenTypeFamily axiom  }
+     ; newFamInst SynFamilyInst axiom  }
 
 --------------------------------------------------------------------------------
 -- Type representation

compiler/typecheck/TcHsType.lhs

@@ -18,7 +18,7 @@ module TcHsType (
 	UserTypeCtxt(..), 
 
                 -- Type checking type and class decls
-	kcTyClTyVars, tcTyClTyVars,
+	kcLookupKind, kcTyClTyVars, tcTyClTyVars,
         tcHsConArgType, tcDataKindSig, 
         tcClassSigType,