Checkpoint. About to try compiling.

compiler/prelude/TysPrim.lhs

@@ -731,6 +731,7 @@ anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep
   where kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
 
 {-   Can't do this yet without messing up kind proxies
+-- RAE: I think you can now.
 anyTyCon :: TyCon
 anyTyCon = mkSynTyCon anyTyConName kind [kKiVar] 
                       syn_rhs

compiler/typecheck/FamInst.lhs

@@ -53,16 +53,18 @@ import qualified Data.Map as Map
 -- creates the fresh variables and applies the necessary substitution
 -- It is defined here to avoid a dependency from FamInstEnv on the monad
 -- code.
-newFamInst :: FamFlavor -> Bool -> CoAxiom br -> TcRnIf gbl lcl(FamInst br)
+
+-- NB: Can't pull out the fam_tc's name because closed type families have
+-- their FamInsts created in a typechecking knot, and the tycon isn't ready
+-- yet. RAE: Is this logic accurate?
+newFamInst :: FamFlavor -> Name -> CoAxiom br -> TcRnIf gbl lcl (FamInst br)
 -- Freshen the type variables of the FamInst branches
 -- Called from the vectoriser monad too, hence the rather general type
-newFamInst flavor is_branched axiom@(CoAxiom { co_ax_tc       = fam_tc
-                                             , co_ax_branches = ax_branches })
+newFamInst flavor fam_tc_name axiom@(CoAxiom { co_ax_branches = ax_branches })
   = do { fam_branches <- go ax_branches
-       ; return (FamInst { fi_fam      = tyConName fam_tc
+       ; return (FamInst { fi_fam      = fam_tc_name
                          , fi_flavor   = flavor
                          , fi_branches = fam_branches
-                         , fi_branched = is_branched
                          , fi_axiom    = axiom }) }
   where
     go :: BranchList CoAxBranch br -> TcRnIf gbl lcl (BranchList FamInstBranch br)

compiler/typecheck/TcEnv.lhs

@@ -734,8 +734,9 @@ newGlobalBinder.
 newFamInstTyConName :: Located Name -> [Type] -> TcM Name
 newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
 
-newFamInstAxiomName :: SrcSpan -> Name -> [[Type]] -> TcM Name
-newFamInstAxiomName = mk_fam_inst_name mkInstTyCoOcc
+newFamInstAxiomName :: SrcSpan -> Name -> [CoAxBranch] -> TcM Name
+newFamInstAxiomName loc name branches
+  = mk_fam_inst_name mkInstTyCoOcc loc name (map coAxBranchLHS branches)
 
 mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
 mk_fam_inst_name adaptOcc loc tc_name tyss

compiler/typecheck/TcGenGenerics.lhs

@@ -445,7 +445,7 @@ tc_mkRepFamInsts gk tycon metaDts mod =
                         (nameSrcSpan (tyConName tycon))
 
      ; let axiom = mkSingleCoAxiom rep_name tyvars fam_tc appT repTy
-     ; newFamInst SynFamilyInst False axiom  }
+     ; newFamInst SynFamilyInst False (tyConName fam_tc) axiom  }
 
 --------------------------------------------------------------------------------
 -- Type representation

compiler/typecheck/TcInstDcls.lhs

@@ -559,7 +559,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
                      ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
                      ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs'
                      ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) 
-                       newFamInst SynFamilyInst False {- group -} axiom }
+                       newFamInst OpenTypeFamily (tyConName fam_tc) axiom }
 
         ; tyfam_insts1 <- mapM mk_deflt_at_instances (classATItems clas)
         
@@ -636,33 +636,17 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqns = eqns }))
                  (notOpenFamily fam_tc)
 
          -- (1) do the work of verifying the synonym group
-       ; co_ax_branches <- tcSynFamInstDecl fam_tc decl
+       ; co_ax_branch <- tcSynFamInstDecl fam_tc decl
 
-         -- (2) check for validity and inaccessibility
-       ; foldlM_ (check_valid_branch fam_tc) [] co_ax_branches
+         -- (2) check for validity
+       ; checkValidTyFamInst mb_clsinfo fam_tc co_ax_branch
 
          -- (3) construct coercion axiom
        ; rep_tc_name <- newFamInstAxiomName loc
                                             (tyFamInstDeclName decl)
-                                            (map cab_lhs co_ax_branches)
+                                            [co_ax_branch]
        ; let axiom = mkBranchedCoAxiom rep_tc_name fam_tc co_ax_branches
-       ; newFamInst SynFamilyInst group axiom }
-    where 
-      check_valid_branch :: TyCon
-                         -> [CoAxBranch]     -- previous
-                         -> CoAxBranch       -- current
-                         -> TcM [CoAxBranch] -- current : previous
-      check_valid_branch fam_tc prev_branches cur_branch
-        = do { -- Check the well-formedness of the instance
-               checkValidTyFamInst mb_clsinfo fam_tc cur_branch
-
-               -- Check whether the branch is dominated by earlier
-               -- ones and hence is inaccessible
-             ; when (cur_branch `isDominatedBy` prev_branches) $
-               setSrcSpan (coAxBranchSpan cur_branch) $
-               addErrTc $ inaccessibleCoAxBranch fam_tc cur_branch
-
-             ; return $ cur_branch : prev_branches }
+       ; newFamInst OpenTypeFamily (tyConName fam_tc) axiom }
 
 tcDataFamInstDecl :: Maybe (Class, VarEnv Type)
                   -> LDataFamInstDecl Name -> TcM (FamInst Unbranched)
@@ -723,7 +707,7 @@ tcDataFamInstDecl mb_clsinfo
                  -- further instance might not introduce a new recursive
                  -- dependency.  (2) They are always valid loop breakers as
                  -- they involve a coercion.
-              ; fam_inst <- newFamInst (DataFamilyInst rep_tc) False axiom
+              ; fam_inst <- newFamInst (DataFamily rep_tc) (tyConName fam_tc) axiom
               ; return (rep_tc, fam_inst) }
 
          -- Remember to check validity; no recursion to worry about here

compiler/typecheck/TcTyClsDecls.lhs

@@ -159,7 +159,14 @@ tcTyClGroup boot_details tyclds
            -- we want them in the environment because
            -- they may be mentioned in interface files
        ; tcExtendGlobalValEnv (mkDefaultMethodIds tyclss) $
+         addFamInsts (get_fam_insts tyclss) $ -- RAE: Remove this hack
          tcAddImplicits tyclss } }
+  where --RAE remove all of this.
+    get_fam_insts :: [TyThing] -> [FamInst Branched]
+    get_fam_insts [] = []
+    get_fam_insts (ATyCon (SynTyCon { synTcRhs = ClosedSynFamilyTyCon inst }) : rest)
+      = inst : get_fam_insts rest
+    get_fam_insts (h : t) = get_fam_insts t
 
 tcAddImplicits :: [TyThing] -> TcM TcGblEnv
 tcAddImplicits tyclss
@@ -648,14 +655,53 @@ tcTyClDecl1 _ _
 \begin{code}
 tcFamDecl1 :: TyConParent -> FamilyDecl Name -> TcM [TyThing]
 tcFamDecl1 parent
-            (FamilyDecl {fdFlavour = TypeFamily, fdLName = L _ tc_name, fdTyVars = tvs})
+            (FamilyDecl {fdInfo = OpenTypeFamily, fdLName = L _ tc_name, fdTyVars = tvs})
   = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
-  { traceTc "type family:" (ppr tc_name)
+  { traceTc "open type family:" (ppr tc_name)
   ; checkFamFlag tc_name
-  ; let syn_rhs = SynFamilyTyCon { synf_open = True, synf_injective = False }
-  ; tycon <- buildSynTyCon tc_name tvs' syn_rhs kind parent
+  ; tycon <- buildSynTyCon tc_name tvs' OpenSynFamilyTyCon kind parent
   ; return [ATyCon tycon] }
 
+tcFamDecl1 parent
+            (FamilyDecl { fdInfo = ClosedTypeFamily eqns
+                        , fdLName = lname@(L _ tc_name), fdTyVars = tvs })
+-- Closed type families are a little tricky, because they contain the definition
+-- of both the type family and an instance.
+  = do { traceTc "closed type family:" (ppr tc_name)
+         -- the variables in the header have no scope:
+       ; (tvs', kind) <- tcTyClTyVars tc_name tvs $ \ tvs' kind ->
+                         return (tvs', kind)
+
+       ; checkFamFlag tc_name -- make sure we have -XTypeFamilies
+
+         -- check to make sure all the names used in the equations are
+         -- consistent
+       ; let names = map (tfie_tycon . unLoc) eqns
+       ; tcSynFamInstNames lname names
+
+         -- The CoAxiom refers to the TyCon, and vice versa. So, we need a
+         -- knot:
+       ; (fam_tc, axiom) <- fixM $ \(rec_fam_tc, _rec_axiom) -> do
+
+         -- process the equations, creating CoAxBranches
+         { branches <- mapM (tcTyFamInstEqn rec_fam_tc) eqns
+
+           -- create a CoAxiom, with the correct src location
+         ; loc <- getSrcSpanM
+         ; co_ax_name <- newFamInstAxiomName loc tc_name branches
+         ; let co_ax = mkBranchedCoAxiom co_ax_name rec_fam_tc branches
+
+           -- make the FamInst
+         ; fam_inst <- newFamInst ClosedTypeFamily tc_name co_ax
+
+           -- now, finally, build the TyCon
+         ; let syn_rhs = ClosedSynFamilyTyCon fam_inst
+         ; tycon <- buildSynTyCon tc_name tvs' syn_rhs kind parent }
+
+       ; return [ATyCon fam_tc, ACoAxiom axiom] }
+-- We check for instance validity later, when doing validity checking for
+-- the tycon
+
 tcFamDecl1 parent
            (FamilyDecl {fdFlavour = DataFamily, fdLName = L _ tc_name, fdTyVars = tvs})
   = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
@@ -785,17 +831,12 @@ tcDefaultAssocDecl fam_tc (L loc decl)
     -- We check for well-formedness and validity later, in checkValidClass
 
 -------------------------
-tcSynFamInstDecl :: TyCon -> TyFamInstDecl Name -> TcM [CoAxBranch]
+tcSynFamInstDecl :: TyCon -> TyFamInstDecl Name -> TcM CoAxBranch
 -- Placed here because type family instances appear as
 -- default decls in class declarations
-tcSynFamInstDecl fam_tc (TyFamInstDecl { tfid_eqns = eqns })
-  -- we know the first equation matches the fam_tc because of the lookup logic
-  -- now, just check that all other names match the first
-  = do { let names = map (tfie_tycon . unLoc) eqns
-             first = head names
-       ; tcSynFamInstNames first names
-       ; checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
-       ; mapM (tcTyFamInstEqn fam_tc) eqns }
+tcSynFamInstDecl fam_tc (TyFamInstDecl { tfid_eqn = eqn })
+  = do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
+       ; tcTyFamInstEqn fam_tc eqn }
 
 -- Checks to make sure that all the names in an instance group are the same
 tcSynFamInstNames :: Located Name -> [Located Name] -> TcM ()
@@ -1244,8 +1285,9 @@ checkValidTyCon tc
 
   | Just syn_rhs <- synTyConRhs_maybe tc
   = case syn_rhs of
-      SynFamilyTyCon {} -> return ()
-      SynonymTyCon ty   -> checkValidType syn_ctxt ty
+      ClosedSynFamilyTyCon inst -> checkValidClosedFamInst inst
+      OpenSynFamilyTyCon  -> return ()
+      SynonymTyCon ty     -> checkValidType syn_ctxt ty
 
   | otherwise
   = do { -- Check the context on the data decl
@@ -1309,6 +1351,25 @@ checkValidTyCon tc
                 fty2 = dataConFieldType con2 label
     check_fields [] = panic "checkValidTyCon/check_fields []"
 
+checkValidClosedFamInst :: FamInst Branched -> TcM ()
+checkValidClosedFamInst (FamInst { fi_axiom = axiom, fi_fam_tc = tc })
+ = tcAddClosedTypeFamilyDeclCtxt tc $
+   do { foldlM_ check_accessibility [] branches
+      ; void $ brListMapM (checkValidTyFamInst Nothing tc) branches }
+   where
+     branches = coAxBranches axiom
+
+     check_accessibility :: [CoAxBranch]       -- prev branches (in reverse order)
+                         -> CoAxBranch         -- cur branch
+                         -> TcM [CoAxBranch]   -- cur : prev
+               -- Check whether the branch is dominated by earlier
+               -- ones and hence is inaccessible
+     check_accessibility prev_branches cur_branch
+       = do { when (cur_branch `isDominatedBy` prev_branches) $
+              setSrcSpan (coAxBranchSpan cur_branch) $
+              addErrTc $ inaccessibleCoAxBranch fam_tc cur_branch
+            ; return (cur_branch : prev_branches) }
+
 checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet
                  -> Type -> Type -> Type -> Type -> TcM ()
 checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2

compiler/types/CoAxiom.lhs

@@ -13,7 +13,7 @@ module CoAxiom (
        Branched, Unbranched, BranchIndex, BranchList(..),
        toBranchList, fromBranchList,
        toBranchedList, toUnbranchedList,
-       brListLength, brListNth, brListMap, brListFoldr,
+       brListLength, brListNth, brListMap, brListFoldr, brListMapM,
        brListZipWith, brListIndices,
 
        CoAxiom(..), CoAxBranch(..), 
@@ -178,6 +178,12 @@ brListFoldr :: (a -> b -> b) -> b -> BranchList a br -> b
 brListFoldr f x (FirstBranch b) = f b x
 brListFoldr f x (NextBranch h t) = f h (brListFoldr f x t)
 
+brListMapM :: Monad m => (a -> m b) -> BranchList a br -> m [b]
+brListMapM f (FirstBranch b) = f b >>= \fb -> return [fb]
+brListMapM f (NextBranch h t) = do { fh <- f h
+                                   ; ft <- brListMapM f t
+                                   ; return (fh : ft) }
+
 -- zipWith
 brListZipWith :: (a -> b -> c) -> BranchList a br1 -> BranchList b br2 -> [c]
 brListZipWith f (FirstBranch a) (FirstBranch b) = [f a b]

compiler/types/TyCon.lhs

@@ -580,20 +580,22 @@ data SynTyConRhs ty
                       -- It acts as a template for the expansion when the 'TyCon'
                       -- is applied to some types.
 
-   -- | A type synonym family  e.g. @type family F x y :: * -> *@
-   | SynFamilyTyCon {
-        synf_open :: Bool,         -- See Note [Closed type families]
-        synf_injective :: Bool 
-     }
+   -- | An open type synonym family  e.g. @type family F x y :: * -> *@
+   | OpenSynFamilyTyCon 
+
+   -- | A closed type synonym family  e.g. @type family F x where { F Int = Bool }@
+   | ClosedSynFamilyTyCon
+       (FamInst Branched) -- RAE: Should we reuse this structure here?
 \end{code}
 
 Note [Closed type families]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 * In an open type family you can add new instances later.  This is the 
   usual case.  
 
-* In a closed type family you can only put instnaces where the family
-  is defined.  GHC doesn't support syntax for this yet.
+* In a closed type family you can only put equations where the family
+  is defined.
+
 
 Note [Promoted data constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

compiler/vectorise/Vectorise/Generic/PAMethods.hs

@@ -38,7 +38,7 @@ buildPReprTyCon orig_tc vect_tc repr
       rhs_ty    <- sumReprType repr
       prepr_tc  <- builtin preprTyCon
       let axiom = mkSingleCoAxiom name tyvars prepr_tc instTys rhs_ty
-      liftDs $ newFamInst SynFamilyInst False axiom
+      liftDs $ newFamInst OpenTypeFamily (tyConName prepr_tc) axiom
   where
     tyvars = tyConTyVars vect_tc
     instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc]

compiler/vectorise/Vectorise/Generic/PData.hs

@@ -60,7 +60,7 @@ buildDataFamInst name' fam_tc vect_tc rhs
                            False       -- Not promotable
                            False       -- not GADT syntax
                            (FamInstTyCon ax fam_tc pat_tys)
-      ; liftDs $ newFamInst (DataFamilyInst rep_tc) False ax }
+      ; liftDs $ newFamInst (DataFamily rep_tc) (tyConName fam_tc) ax }
  where
     tyvars    = tyConTyVars vect_tc
     rec_flag  = boolToRecFlag (isRecursiveTyCon vect_tc)