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, 43 insertions, 44 deletions

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 8caf987336..a07fafe00d 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/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)
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index ce391c73e2..e088af7c18 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -24,7 +24,7 @@ module HsDecls (
   FamilyDecl(..), LFamilyDecl,
 
   -- ** Instance declarations
-  InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
+  InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
   TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
   DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
   TyFamInstEqn(..), LTyFamInstEqn,
@@ -470,16 +470,17 @@ data TyClDecl name
 
 type LFamilyDecl name = Located (FamilyDecl name)
 data FamilyDecl name = FamilyDecl
-  { fdFlavour :: FamilyFlavour              -- type or data
+  { fdInfo    :: FamilyInfo name            -- type or data, closed or open
   , fdLName   :: Located name               -- type constructor
   , fdTyVars  :: LHsTyVarBndrs name         -- type variables
   , fdKindSig :: Maybe (LHsKind name) }     -- result kind
   deriving( Data, Typeable )
 
-data FamilyFlavour
-  = TypeFamily
-  | DataFamily
-  deriving( Data, Typeable, Eq )
+data FamilyInfo name
+  = DataFamily
+  | OpenTypeFamily
+  | ClosedTypeFamily [LTyFamInstEqn name]
+  deriving( Data, Typeable )
 
 \end{code}
 
@@ -510,12 +511,15 @@ isFamilyDecl _other        = False
 
 -- | type family declaration
 isTypeFamilyDecl :: TyClDecl name -> Bool
-isTypeFamilyDecl (FamDecl d) = fdFlavour d == TypeFamily
-isTypeFamilyDecl _other      = False
+isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of
+  OpenTypeFamily      -> True
+  ClosedTypeFamily {} -> True
+  _                   -> False
+isTypeFamilyDecl _ = False
 
 -- | data family declaration
 isDataFamilyDecl :: TyClDecl name -> Bool
-isDataFamilyDecl (FamDecl d) = fdFlavour d == DataFamily
+isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True
 isDataFamilyDecl _other      = False
 \end{code}
 
@@ -528,11 +532,9 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName
 
 tyFamInstDeclLName :: OutputableBndr name
                    => TyFamInstDecl name -> Located name
-tyFamInstDeclLName (TyFamInstDecl { tfid_eqns =
-                     (L _ (TyFamInstEqn { tfie_tycon = ln })) : _ })
-  -- there may be more than one equation, but grab the name from the first
+tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
+                     (L _ (TyFamInstEqn { tfie_tycon = ln })) })
   = ln
-tyFamInstDeclLName decl = pprPanic "tyFamInstDeclLName" (ppr decl)
 
 tyClDeclLName :: TyClDecl name -> Located name
 tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln
@@ -598,17 +600,26 @@ instance OutputableBndr name
                      <+> pprFundeps (map unLoc fds)
 
 instance (OutputableBndr name) => Outputable (FamilyDecl name) where
-  ppr (FamilyDecl { fdFlavour = flavour, fdLName = ltycon, 
+  ppr (FamilyDecl { fdInfo = info, fdLName = ltycon, 
                     fdTyVars = tyvars, fdKindSig = mb_kind})
-      = ppr flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind
+      = vcat [ pprFlavour info <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind <+> pp_where
+             , nest 2 $ pp_eqns ]
         where
           pp_kind = case mb_kind of
                       Nothing   -> empty
                       Just kind -> dcolon <+> ppr kind
+          (pp_where, pp_eqns) = case info of
+            ClosedTypeFamily eqns -> ( ptext (sLit "where")
+                                     , vcat $ map ppr eqns )
+            _                     -> (empty, empty)
+
+pprFlavour :: FamilyInfo name -> SDoc
+pprFlavour DataFamily            = ptext (sLit "data family")
+pprFlavour OpenTypeFamily        = ptext (sLit "type family")
+pprFlavour (ClosedTypeFamily {}) = ptext (sLit "type family")
 
-instance Outputable FamilyFlavour where
-  ppr TypeFamily = ptext (sLit "type family")
-  ppr DataFamily = ptext (sLit "data family")
+instance Outputable (FamilyInfo name) where
+  ppr = pprFlavour
 
 pp_vanilla_decl_head :: OutputableBndr name
    => Located name
@@ -838,10 +849,9 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
 \begin{code}
 ----------------- Type synonym family instances -------------
 
--- See note [Family instance equation groups]
 type LTyFamInstEqn name = Located (TyFamInstEqn name)
 
--- | One equation in a family instance declaration
+-- | One equation in a type family instance declaration
 data TyFamInstEqn name   
   = TyFamInstEqn
        { tfie_tycon :: Located name
@@ -854,15 +864,10 @@ data TyFamInstEqn name
 type LTyFamInstDecl name = Located (TyFamInstDecl name)
 data TyFamInstDecl name 
   = TyFamInstDecl
-       { tfid_eqns  :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns 
-                                            -- Always non-empty
-       , tfid_group :: Bool                 -- Was this declared with the "where" syntax?
-       , tfid_fvs   :: NameSet }            -- The group is type-checked as one,
-                                            --   so one NameSet will do
-       -- INVARIANT: tfid_group == False --> length tfid_eqns == 1
+       { tfid_eqn  :: LTyFamInstEqn name 
+       , tfid_fvs  :: NameSet }
   deriving( Typeable, Data )
 
-
 ----------------- Data family instances -------------
 
 type LDataFamInstDecl name = Located (DataFamInstDecl name)
@@ -925,24 +930,13 @@ tvs are fv(pat_tys), *including* ones that are already in scope
    so that we can compare the type patter in the 'instance' decl and
    in the associated 'type' decl
 
-Note [Family instance equation groups]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A TyFamInstDecl contains a list of FamInstEqn's, one for each
-equation defined in the instance group. For a standalone
-instance declaration, this list contains exactly one element.
-It is not possible for this list to have 0 elements --
-'type instance where' without anything else is not allowed.
-
 \begin{code}
 instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
   ppr = pprTyFamInstDecl TopLevel
 
 pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc
-pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_group = False, tfid_eqns = [eqn] })
+pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
    = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn)
-pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqns = eqns })
-   = hang (ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ptext (sLit "where"))
-        2 (vcat (map ppr eqns))
 
 ppr_instance_keyword :: TopLevelFlag -> SDoc
 ppr_instance_keyword TopLevel    = ptext (sLit "instance")