Revise implementation of overlapping type family instances.

This commit changes the syntax and story around overlapping type
family instances. Before, we had "unbranched" instances and
"branched" instances. Now, we have closed type families and
open ones.

The behavior of open families is completely unchanged. In particular,
coincident overlap of open type family instances still works, despite
emails to the contrary.

A closed type family is declared like this:
> type family F a where
>   F Int = Bool
>   F a   = Char
The equations are tried in order, from top to bottom, subject to
certain constraints, as described in the user manual. It is not
allowed to declare an instance of a closed family.

2 files changed, 24 insertions, 29 deletions

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 483ed87591..1545aa27f4 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -644,10 +644,10 @@ ty_decl :: { LTyClDecl RdrName }
                 {% mkTySynonym (comb2 $1 $4) $2 $4 }
 
            -- type family declarations
-        | 'type' 'family' type opt_kind_sig 
+        | 'type' 'family' type opt_kind_sig where_type_family
                 -- Note the use of type for the head; this allows
                 -- infix type constructors to be declared
-                {% do { L loc decl <- mkFamDecl (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4)
+                {% do { L loc decl <- mkFamDecl (comb4 $1 $3 $4 $5) (unLoc $5) $3 (unLoc $4)
                       ; return (L loc (FamDecl decl)) } }
 
           -- ordinary data type or newtype declaration
@@ -684,9 +684,6 @@ inst_decl :: { LInstDecl RdrName }
                 {% do { L loc tfi <- mkTyFamInst (comb2 $1 $3) $3
                       ; return (L loc (TyFamInstD { tfid_inst = tfi })) } }
 
-        | 'type' 'instance' 'where' ty_fam_inst_eqn_list
-                { LL (TyFamInstD { tfid_inst = mkTyFamInstGroup (unLoc $4) }) }
-
           -- data/newtype instance declaration
         | data_or_newtype 'instance' tycl_hdr constrs deriving
                 {% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3
@@ -701,14 +698,19 @@ inst_decl :: { LInstDecl RdrName }
                                             (unLoc $4) (unLoc $5) (unLoc $6)
                       ; return (L loc (DataFamInstD { dfid_inst = d })) } }
         
--- Type instance groups
+-- Closed type families
+
+where_type_family :: { Located (FamilyInfo RdrName) }
+        : {- empty -}                      { noLoc OpenTypeFamily }
+        | 'where' ty_fam_inst_eqn_list
+               { LL (ClosedTypeFamily (reverse (unLoc $2))) }
 
 ty_fam_inst_eqn_list :: { Located [LTyFamInstEqn RdrName] }
         :     '{' ty_fam_inst_eqns '}'     { LL (unLoc $2) }
         | vocurly ty_fam_inst_eqns close   { $2 }
 
 ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }
-        : ty_fam_inst_eqn ';' ty_fam_inst_eqns   { LL ($1 : unLoc $3) }
+        : ty_fam_inst_eqns ';' ty_fam_inst_eqn   { LL ($3 : unLoc $1) }
         | ty_fam_inst_eqns ';'                   { LL (unLoc $1) }
         | ty_fam_inst_eqn                        { LL [$1] }
 
@@ -716,7 +718,8 @@ ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
         : type '=' ctype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
-              {% mkTyFamInstEqn (comb2 $1 $3) $1 $3 }
+              {% do { eqn <- mkTyFamInstEqn $1 $3
+                    ; return (LL eqn) } }
 
 -- Associated type family declarations
 --
@@ -732,7 +735,7 @@ at_decl_cls :: { LHsDecl RdrName }
         : 'type' type opt_kind_sig
                 -- Note the use of type for the head; this allows
                 -- infix type constructors to be declared.
-                {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3)
+                {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2 (unLoc $3)
                       ; return (L loc (TyClD (FamDecl decl))) } }
 
         | 'data' type opt_kind_sig
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 3695daef58..e8c23cad52 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -10,7 +10,7 @@ module RdrHsSyn (
         mkHsDo, mkHsSplice, mkTopSpliceDecl,
         mkClassDecl, 
         mkTyData, mkFamInstData, 
-        mkTySynonym, mkTyFamInstEqn, mkTyFamInstGroup,
+        mkTySynonym, mkTyFamInstEqn,
         mkTyFamInst, 
         mkFamDecl, 
         splitCon, mkInlinePragma,
@@ -178,39 +178,31 @@ mkTySynonym loc lhs rhs
        ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars,
                                  tcdRhs = rhs, tcdFVs = placeHolderNames })) }
 
-mkTyFamInstEqn :: SrcSpan
+mkTyFamInstEqn :: LHsType RdrName
                -> LHsType RdrName
-               -> LHsType RdrName
-               -> P (LTyFamInstEqn RdrName)
-mkTyFamInstEqn loc lhs rhs
+               -> P (TyFamInstEqn RdrName)
+mkTyFamInstEqn lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
-       ; return (L loc (TyFamInstEqn { tfie_tycon = tc
-                                     , tfie_pats  = mkHsWithBndrs tparams
-                                     , tfie_rhs   = rhs })) }
+       ; return (TyFamInstEqn { tfie_tycon = tc
+                              , tfie_pats  = mkHsWithBndrs tparams
+                              , tfie_rhs   = rhs }) }
 
 mkTyFamInst :: SrcSpan
             -> LTyFamInstEqn RdrName
             -> P (LTyFamInstDecl RdrName)
 mkTyFamInst loc eqn
-  = return (L loc (TyFamInstDecl { tfid_eqns  = [eqn]
-                                 , tfid_group = False
-                                 , tfid_fvs   = placeHolderNames }))
-
-mkTyFamInstGroup :: [LTyFamInstEqn RdrName]
-                 -> TyFamInstDecl RdrName
-mkTyFamInstGroup eqns = TyFamInstDecl { tfid_eqns  = eqns
-                                      , tfid_group = True
-                                      , tfid_fvs   = placeHolderNames }
+  = return (L loc (TyFamInstDecl { tfid_eqn  = eqn
+                                 , tfid_fvs  = placeHolderNames }))
 
 mkFamDecl :: SrcSpan
-          -> FamilyFlavour
+          -> FamilyInfo RdrName
           -> LHsType RdrName   -- LHS
           -> Maybe (LHsKind RdrName) -- Optional kind signature
           -> P (LFamilyDecl RdrName)
-mkFamDecl loc flavour lhs ksig
+mkFamDecl loc info lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; tyvars <- checkTyVars lhs tparams
-       ; return (L loc (FamilyDecl flavour tc tyvars ksig)) }
+       ; return (L loc (FamilyDecl info tc tyvars ksig)) }
 
 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
 -- If the user wrote